Annotation of loncom/lonnet/perl/lonnet.pm, revision 1.15

1.1       albertel    1: # The LearningOnline Network
                      2: # TCP networking package
1.12      www         3: #
                      4: # Functions for use by content handlers:
                      5: #
                      6: # plaintext(short)   : plain text explanation of short term
                      7: # allowed(short,url) : returns codes for allowed actions
                      8: # appendenv(hash)    : adds hash to session environment
                      9: # store(hash)        : stores hash permanently for this url
                     10: # restore            : returns hash for this url
                     11: # eget(namesp,array) : returns hash with keys from array filled in from namesp
                     12: # get(namesp,array)  : returns hash with keys from array filled in from namesp
                     13: # put(namesp,hash)   : stores hash in namesp
1.15    ! www        14: # dump(namesp)       : dumps the complete namespace into a hash
        !            15: # ssi(url)           : does a complete request cycle on url to localhost
1.12      www        16: #
1.1       albertel   17: # 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30,
1.5       www        18: # 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19,
1.8       www        19: # 11/8,11/16,11/18,11/22,11/23,12/22,
1.12      www        20: # 01/06,01/13,02/24,02/28,02/29,
                     21: # 03/01,03/02,03/06,03/07,03/13,
1.15    ! www        22: # 04/05,05/29,05/31,06/01,
        !            23: # 06/05,06/26 Gerd Kortemeyer
        !            24: # 06/26 Ben Tyszka
1.1       albertel   25: 
                     26: package Apache::lonnet;
                     27: 
                     28: use strict;
                     29: use Apache::File;
1.8       www        30: use LWP::UserAgent();
1.15    ! www        31: use HTTP::Headers;
1.11      www        32: use vars 
                     33: qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp $readit);
1.1       albertel   34: use IO::Socket;
1.8       www        35: use Apache::Constants qw(:common :http);
1.1       albertel   36: 
                     37: # --------------------------------------------------------------------- Logging
                     38: 
                     39: sub logthis {
                     40:     my $message=shift;
                     41:     my $execdir=$perlvar{'lonDaemons'};
                     42:     my $now=time;
                     43:     my $local=localtime($now);
                     44:     my $fh=Apache::File->new(">>$execdir/logs/lonnet.log");
                     45:     print $fh "$local ($$): $message\n";
                     46:     return 1;
                     47: }
                     48: 
                     49: sub logperm {
                     50:     my $message=shift;
                     51:     my $execdir=$perlvar{'lonDaemons'};
                     52:     my $now=time;
                     53:     my $local=localtime($now);
                     54:     my $fh=Apache::File->new(">>$execdir/logs/lonnet.perm.log");
                     55:     print $fh "$now:$message:$local\n";
                     56:     return 1;
                     57: }
                     58: 
                     59: # -------------------------------------------------- Non-critical communication
                     60: sub subreply {
                     61:     my ($cmd,$server)=@_;
                     62:     my $peerfile="$perlvar{'lonSockDir'}/$server";
                     63:     my $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",
                     64:                                      Type    => SOCK_STREAM,
                     65:                                      Timeout => 10)
                     66:        or return "con_lost";
                     67:     print $client "$cmd\n";
                     68:     my $answer=<$client>;
1.9       www        69:     if (!$answer) { $answer="con_lost"; }
1.1       albertel   70:     chomp($answer);
                     71:     return $answer;
                     72: }
                     73: 
                     74: sub reply {
                     75:     my ($cmd,$server)=@_;
                     76:     my $answer=subreply($cmd,$server);
                     77:     if ($answer eq 'con_lost') { $answer=subreply($cmd,$server); }
1.12      www        78:     if (($answer=~/^error:/) || ($answer=~/^refused/) || 
                     79:         ($answer=~/^rejected/)) {
                     80:        &logthis("<font color=blue>WARNING:".
                     81:                 " $cmd to $server returned $answer</font>");
                     82:     }
1.1       albertel   83:     return $answer;
                     84: }
                     85: 
                     86: # ----------------------------------------------------------- Send USR1 to lonc
                     87: 
                     88: sub reconlonc {
                     89:     my $peerfile=shift;
                     90:     &logthis("Trying to reconnect for $peerfile");
                     91:     my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
                     92:     if (my $fh=Apache::File->new("$loncfile")) {
                     93: 	my $loncpid=<$fh>;
                     94:         chomp($loncpid);
                     95:         if (kill 0 => $loncpid) {
                     96: 	    &logthis("lonc at pid $loncpid responding, sending USR1");
                     97:             kill USR1 => $loncpid;
                     98:             sleep 1;
                     99:             if (-e "$peerfile") { return; }
                    100:             &logthis("$peerfile still not there, give it another try");
                    101:             sleep 5;
                    102:             if (-e "$peerfile") { return; }
1.12      www       103:             &logthis(
                    104:   "<font color=blue>WARNING: $peerfile still not there, giving up</font>");
1.1       albertel  105:         } else {
1.12      www       106: 	    &logthis(
                    107:                "<font color=blue>WARNING:".
                    108:                " lonc at pid $loncpid not responding, giving up</font>");
1.1       albertel  109:         }
                    110:     } else {
1.12      www       111:      &logthis('<font color=blue>WARNING: lonc not running, giving up</font>');
1.1       albertel  112:     }
                    113: }
                    114: 
                    115: # ------------------------------------------------------ Critical communication
1.12      www       116: 
1.1       albertel  117: sub critical {
                    118:     my ($cmd,$server)=@_;
                    119:     my $answer=reply($cmd,$server);
                    120:     if ($answer eq 'con_lost') {
                    121:         my $pingreply=reply('ping',$server);
                    122: 	&reconlonc("$perlvar{'lonSockDir'}/$server");
                    123:         my $pongreply=reply('pong',$server);
                    124:         &logthis("Ping/Pong for $server: $pingreply/$pongreply");
                    125:         $answer=reply($cmd,$server);
                    126:         if ($answer eq 'con_lost') {
                    127:             my $now=time;
                    128:             my $middlename=$cmd;
1.5       www       129:             $middlename=substr($middlename,0,16);
1.1       albertel  130:             $middlename=~s/\W//g;
                    131:             my $dfilename=
                    132:              "$perlvar{'lonSockDir'}/delayed/$now.$middlename.$server";
                    133:             {
                    134:              my $dfh;
                    135:              if ($dfh=Apache::File->new(">$dfilename")) {
1.7       www       136:                 print $dfh "$cmd\n";
1.1       albertel  137: 	     }
                    138:             }
                    139:             sleep 2;
                    140:             my $wcmd='';
                    141:             {
                    142: 	     my $dfh;
                    143:              if ($dfh=Apache::File->new("$dfilename")) {
                    144:                 $wcmd=<$dfh>;
                    145: 	     }
                    146:             }
                    147:             chomp($wcmd);
1.7       www       148:             if ($wcmd eq $cmd) {
1.12      www       149: 		&logthis("<font color=blue>WARNING: ".
                    150:                          "Connection buffer $dfilename: $cmd</font>");
1.1       albertel  151:                 &logperm("D:$server:$cmd");
                    152: 	        return 'con_delayed';
                    153:             } else {
1.12      www       154:                 &logthis("<font color=red>CRITICAL:"
                    155:                         ." Critical connection failed: $server $cmd</font>");
1.1       albertel  156:                 &logperm("F:$server:$cmd");
                    157:                 return 'con_failed';
                    158:             }
                    159:         }
                    160:     }
                    161:     return $answer;
                    162: }
                    163: 
1.5       www       164: # ---------------------------------------------------------- Append Environment
                    165: 
                    166: sub appenv {
1.6       www       167:     my %newenv=@_;
                    168:     my @oldenv;
                    169:     {
                    170:      my $fh;
                    171:      unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {
1.5       www       172: 	return 'error';
1.6       www       173:      }
                    174:      @oldenv=<$fh>;
                    175:     }
                    176:     for (my $i=0; $i<=$#oldenv; $i++) {
                    177:         chomp($oldenv[$i]);
1.9       www       178:         if ($oldenv[$i] ne '') {
                    179:            my ($name,$value)=split(/=/,$oldenv[$i]);
                    180: 	   $newenv{$name}=$value;
                    181:         }
1.6       www       182:     }
                    183:     {
                    184:      my $fh;
                    185:      unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) {
                    186: 	return 'error';
                    187:      }
                    188:      my $newname;
                    189:      foreach $newname (keys %newenv) {
                    190: 	 print $fh "$newname=$newenv{$newname}\n";
                    191:      }
1.5       www       192:     }
                    193:     return 'ok';
                    194: }
1.1       albertel  195: 
                    196: # ------------------------------ Find server with least workload from spare.tab
1.11      www       197: 
1.1       albertel  198: sub spareserver {
                    199:     my $tryserver;
                    200:     my $spareserver='';
                    201:     my $lowestserver=100;
                    202:     foreach $tryserver (keys %spareid) {
                    203:        my $answer=reply('load',$tryserver);
                    204:        if (($answer =~ /\d/) && ($answer<$lowestserver)) {
                    205: 	   $spareserver="http://$hostname{$tryserver}";
                    206:            $lowestserver=$answer;
                    207:        }
                    208:     }    
                    209:     return $spareserver;
                    210: }
                    211: 
                    212: # --------- Try to authenticate user from domain's lib servers (first this one)
1.11      www       213: 
1.1       albertel  214: sub authenticate {
                    215:     my ($uname,$upass,$udom)=@_;
1.12      www       216:     $upass=escape($upass);
1.1       albertel  217:     if (($perlvar{'lonRole'} eq 'library') && 
                    218:         ($udom eq $perlvar{'lonDefDomain'})) {
1.3       www       219:     my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'});
1.2       www       220:         if ($answer =~ /authorized/) {
1.9       www       221:               if ($answer eq 'authorized') {
                    222:                  &logthis("User $uname at $udom authorized by local server"); 
                    223:                  return $perlvar{'lonHostID'}; 
                    224:               }
                    225:               if ($answer eq 'non_authorized') {
                    226:                  &logthis("User $uname at $udom rejected by local server"); 
                    227:                  return 'no_host'; 
                    228:               }
1.2       www       229: 	}
1.1       albertel  230:     }
                    231: 
                    232:     my $tryserver;
                    233:     foreach $tryserver (keys %libserv) {
                    234: 	if ($hostdom{$tryserver} eq $udom) {
1.10      www       235:            my $answer=reply("encrypt:auth:$udom:$uname:$upass",$tryserver);
1.1       albertel  236:            if ($answer =~ /authorized/) {
1.9       www       237:               if ($answer eq 'authorized') {
                    238:                  &logthis("User $uname at $udom authorized by $tryserver"); 
                    239:                  return $tryserver; 
                    240:               }
                    241:               if ($answer eq 'non_authorized') {
                    242:                  &logthis("User $uname at $udom rejected by $tryserver");
                    243:                  return 'no_host';
                    244:               } 
1.1       albertel  245: 	   }
                    246:        }
1.9       www       247:     }
                    248:     &logthis("User $uname at $udom could not be authenticated");    
1.1       albertel  249:     return 'no_host';
                    250: }
                    251: 
                    252: # ---------------------- Find the homebase for a user from domain's lib servers
1.11      www       253: 
1.1       albertel  254: sub homeserver {
                    255:     my ($uname,$udom)=@_;
                    256: 
                    257:     my $index="$uname:$udom";
                    258:     if ($homecache{$index}) { return "$homecache{$index}"; }
                    259: 
                    260:     my $tryserver;
                    261:     foreach $tryserver (keys %libserv) {
                    262: 	if ($hostdom{$tryserver} eq $udom) {
                    263:            my $answer=reply("home:$udom:$uname",$tryserver);
                    264:            if ($answer eq 'found') { 
                    265: 	      $homecache{$index}=$tryserver;
                    266:               return $tryserver; 
                    267: 	   }
                    268:        }
                    269:     }    
                    270:     return 'no_host';
                    271: }
                    272: 
                    273: # ----------------------------- Subscribe to a resource, return URL if possible
1.11      www       274: 
1.1       albertel  275: sub subscribe {
                    276:     my $fname=shift;
                    277:     my $author=$fname;
                    278:     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
                    279:     my ($udom,$uname)=split(/\//,$author);
                    280:     my $home=homeserver($uname,$udom);
                    281:     if (($home eq 'no_host') || ($home eq $perlvar{'lonHostID'})) { 
                    282:         return 'not_found'; 
                    283:     }
                    284:     my $answer=reply("sub:$fname",$home);
                    285:     return $answer;
                    286: }
                    287:     
1.8       www       288: # -------------------------------------------------------------- Replicate file
                    289: 
                    290: sub repcopy {
                    291:     my $filename=shift;
                    292:     my $transname="$filename.in.transfer";
                    293:     my $remoteurl=subscribe($filename);
                    294:     if ($remoteurl eq 'con_lost') {
                    295: 	   &logthis("Subscribe returned con_lost: $filename");
                    296:            return HTTP_SERVICE_UNAVAILABLE;
                    297:     } elsif ($remoteurl eq 'not_found') {
                    298: 	   &logthis("Subscribe returned not_found: $filename");
                    299: 	   return HTTP_NOT_FOUND;
                    300:     } elsif ($remoteurl eq 'forbidden') {
                    301: 	   &logthis("Subscribe returned forbidden: $filename");
                    302:            return FORBIDDEN;
                    303:     } else {
                    304:            my @parts=split(/\//,$filename);
                    305:            my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
                    306:            if ($path ne "$perlvar{'lonDocRoot'}/res") {
                    307:                &logthis("Malconfiguration for replication: $filename");
                    308: 	       return HTTP_BAD_REQUEST;
                    309:            }
                    310:            my $count;
                    311:            for ($count=5;$count<$#parts;$count++) {
                    312:                $path.="/$parts[$count]";
                    313:                if ((-e $path)!=1) {
                    314: 		   mkdir($path,0777);
                    315:                }
                    316:            }
                    317:            my $ua=new LWP::UserAgent;
                    318:            my $request=new HTTP::Request('GET',"$remoteurl");
                    319:            my $response=$ua->request($request,$transname);
                    320:            if ($response->is_error()) {
                    321: 	       unlink($transname);
                    322:                my $message=$response->status_line;
1.12      www       323:                &logthis("<font color=blue>WARNING:"
                    324:                        ." LWP get: $message: $filename</font>");
1.8       www       325:                return HTTP_SERVICE_UNAVAILABLE;
                    326:            } else {
                    327:                rename($transname,$filename);
                    328:                return OK;
                    329:            }
                    330:     }
                    331: }
                    332: 
1.15    ! www       333: # --------------------------------------------------------- Server Side Include
        !           334: 
        !           335: sub ssi {
        !           336: 
        !           337:     my $fn=shift;
        !           338: 
        !           339:     my $ua=new LWP::UserAgent;
        !           340:     my $request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn);
        !           341:     $request->header(Cookie => $ENV{'HTTP_COOKIE'});
        !           342:     my $response=$ua->request($request);
        !           343: 
        !           344:     return $response->content;
        !           345: }
        !           346: 
        !           347: 
        !           348: 
        !           349: 
1.14      www       350: # ------------------------------------------------------------------------- Log
                    351: 
                    352: sub log {
                    353:     my ($dom,$nam,$hom,$what)=@_;
                    354:     return reply("log:$dom:$nam:$what",$hom);
                    355: }
                    356: 
1.9       www       357: # ----------------------------------------------------------------------- Store
                    358: 
                    359: sub store {
                    360:     my %storehash=shift;
1.12      www       361:     my $namevalue='';
                    362:     map {
                    363:         $namevalue.=escape($_).'='.escape($storehash{$_}).'&';
                    364:     } keys %storehash;
                    365:     $namevalue=~s/\&$//;
                    366:     return reply("store:$ENV{'user.domain'}:$ENV{'user.name'}:"
                    367:                ."$ENV{'user.class'}:$ENV{'request.filename'}:$namevalue",
                    368: 		 "$ENV{'user.home'}");
1.9       www       369: }
                    370: 
                    371: # --------------------------------------------------------------------- Restore
                    372: 
                    373: sub restore {
1.12      www       374:     my $answer=reply("restore:$ENV{'user.domain'}:$ENV{'user.name'}:"
                    375:                ."$ENV{'user.class'}:$ENV{'request.filename'}",
                    376:                 "$ENV{'user.home'}");
                    377:     my %returnhash=();
                    378:     map {
                    379: 	my ($name,$value)=split(/\=/,$_);
                    380:         $returnhash{&unescape($name)}=&unescape($value);
                    381:     } split(/\&/,$answer);
1.13      www       382:     return %returnhash;
1.9       www       383: }
1.1       albertel  384: 
1.11      www       385: # -------------------------------------------------------- Get user priviledges
                    386: 
                    387: sub rolesinit {
                    388:     my ($domain,$username,$authhost)=@_;
                    389:     my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
1.12      www       390:     if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; }
1.11      www       391:     my %allroles=();
                    392:     my %thesepriv=();
                    393:     my $userroles='';
                    394:     my $now=time;
                    395:     my $thesestr;
                    396: 
                    397:     if ($rolesdump ne '') {
                    398:         map {
1.12      www       399: 	  if ($_!~/rolesdef\&/) {
1.11      www       400:             my ($area,$role)=split(/=/,$_);
                    401:             my ($trole,$tend,$tstart)=split(/_/,$role);
                    402:             if ($tend!=0) {
                    403: 	        if ($tend<$now) {
                    404: 	            $trole='';
                    405:                 } 
                    406:             }
                    407:             if ($tstart!=0) {
                    408:                 if ($tstart>$now) {
                    409:                    $trole='';        
                    410:                 }
                    411:             }
                    412:             if (($area ne '') && ($trole ne '')) {
1.12      www       413:                $userroles.='user.role.'.$trole.'.'.$area.'='.
                    414:                            $tstart.'.'.$tend."\n";
                    415:                my ($tdummy,$tdomain,$trest)=split(/\//,$area);
                    416:                if ($trole =~ /^cr\//) {
                    417: 		   my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
                    418:                    my $homsvr=homeserver($rauthor,$rdomain);
                    419:                    if ($hostname{$homsvr} ne '') {
                    420:                       my $roledef=
                    421: 			  reply("get:$rdomain:$rauthor:roles:rolesdef&$rrole",
                    422:                                 $homsvr);
                    423:                       if (($roledef ne 'con_lost') && ($roledef ne '')) {
                    424:                          my ($syspriv,$dompriv,$coursepriv)=
                    425: 			     split(/&&/,$roledef);
                    426:  	                 $allroles{'/'}.=':'.$syspriv;
                    427:                          if ($tdomain ne '') {
                    428:                              $allroles{'/'.$tdomain.'/'}.=':'.$dompriv;
                    429:                              if ($trest ne '') {
                    430: 		                $allroles{$area}.=':'.$coursepriv;
                    431:                              }
                    432: 	                 }
                    433:                       }
1.11      www       434:                    }
1.12      www       435:                } else {
                    436: 	           $allroles{'/'}.=':'.$pr{$trole.':s'};
                    437:                    if ($tdomain ne '') {
                    438:                       $allroles{'/'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
                    439:                       if ($trest ne '') {
                    440: 		          $allroles{$area}.=':'.$pr{$trole.':c'};
                    441:                       }
                    442: 	           }
1.11      www       443: 	       }
1.12      www       444:             }
                    445:           } 
1.11      www       446:         } split(/&/,$rolesdump);
                    447:         map {
                    448:             %thesepriv=();
                    449:             map {
                    450:                 if ($_ ne '') {
                    451: 		    my ($priviledge,$restrictions)=split(/&/,$_);
                    452:                     if ($restrictions eq '') {
                    453: 			$thesepriv{$priviledge}='F';
                    454:                     } else {
                    455:                         if ($thesepriv{$priviledge} ne 'F') {
                    456: 			    $thesepriv{$priviledge}.=$restrictions;
                    457:                         }
                    458:                     }
                    459:                 }
                    460:             } split(/:/,$allroles{$_});
                    461:             $thesestr='';
                    462:             map { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } keys %thesepriv;
                    463:             $userroles.='user.priv.'.$_.'='.$thesestr."\n";
                    464:         } keys %allroles;            
                    465:     }
                    466:     return $userroles;  
                    467: }
                    468: 
1.12      www       469: # --------------------------------------------------------------- get interface
                    470: 
                    471: sub get {
                    472:    my ($namespace,@storearr)=@_;
                    473:    my $items='';
                    474:    map {
                    475:        $items.=escape($_).'&';
                    476:    } @storearr;
                    477:    $items=~s/\&$//;
                    478:  my $rep=reply("get:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
                    479:                  $ENV{'user.home'});
1.15    ! www       480:    my @pairs=split(/\&/,$rep);
        !           481:    my %returnhash=();
        !           482:    map {
        !           483:       my ($key,$value)=split(/=/,$_);
        !           484:       $returnhash{unespace($key)}=unescape($value);
        !           485:    } @pairs;
        !           486:    return %returnhash;
        !           487: }
        !           488: 
        !           489: # -------------------------------------------------------------- dump interface
        !           490: 
        !           491: sub dump {
        !           492:    my $namespace=shift;
        !           493:    my $rep=reply("dump:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace",
        !           494:                 $ENV{'user.home'});
1.12      www       495:    my @pairs=split(/\&/,$rep);
                    496:    my %returnhash=();
                    497:    map {
                    498:       my ($key,$value)=split(/=/,$_);
                    499:       $returnhash{unespace($key)}=unescape($value);
                    500:    } @pairs;
                    501:    return %returnhash;
                    502: }
                    503: 
                    504: # --------------------------------------------------------------- put interface
                    505: 
                    506: sub put {
                    507:    my ($namespace,%storehash)=@_;
                    508:    my $items='';
                    509:    map {
                    510:        $items.=escape($_).'='.escape($storehash{$_}).'&';
                    511:    } keys %storehash;
                    512:    $items=~s/\&$//;
                    513:    return reply("put:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
                    514:                  $ENV{'user.home'});
                    515: }
                    516: 
                    517: # -------------------------------------------------------------- eget interface
                    518: 
                    519: sub eget {
                    520:    my ($namespace,@storearr)=@_;
                    521:    my $items='';
                    522:    map {
                    523:        $items.=escape($_).'&';
                    524:    } @storearr;
                    525:    $items=~s/\&$//;
                    526:  my $rep=reply("eget:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
                    527:                  $ENV{'user.home'});
                    528:    my @pairs=split(/\&/,$rep);
                    529:    my %returnhash=();
                    530:    map {
                    531:       my ($key,$value)=split(/=/,$_);
                    532:       $returnhash{unespace($key)}=unescape($value);
                    533:    } @pairs;
                    534:    return %returnhash;
                    535: }
                    536: 
                    537: # ------------------------------------------------- Check for a user priviledge
                    538: 
                    539: sub allowed {
                    540:     my ($priv,$uri)=@_;
                    541:     $uri=~s/^\/res//;
                    542:     $uri=~s/^\///;
1.14      www       543:     if ($uri=~/^adm\//) {
                    544: 	return 'F';
                    545:     }
1.12      www       546:     my $thisallowed='';
                    547:     if ($ENV{'user.priv./'}=~/$priv\&([^\:]*)/) {
                    548:        $thisallowed.=$1;
                    549:     }
                    550:     if ($ENV{'user.priv./'.(split(/\//,$uri))[0].'/'}=~/$priv\&([^\:]*)/) {
                    551:        $thisallowed.=$1;
                    552:     }
                    553:     if ($ENV{'user.priv./'.$uri}=~/$priv\&([^\:]*)/) {
                    554:        $thisallowed.=$1;
                    555:     }
                    556:     return $thisallowed;
                    557: }
                    558: 
                    559: # ----------------------------------------------------------------- Define Role
                    560: 
                    561: sub definerole {
                    562:   if (allowed('mcr','/')) {
                    563:     my ($rolename,$sysrole,$domrole,$courole)=@_;
                    564:     my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".
                    565:                 "$ENV{'user.domain'}:$ENV{'user.name'}:".
                    566: 	        "rolesdef&$rolename=$sysrole&&$domrole&&$courole";
                    567:     return reply($command,$ENV{'user.home'});
                    568:   } else {
                    569:     return 'refused';
                    570:   }
                    571: }
                    572: 
                    573: # ------------------------------------------------------------------ Plain Text
                    574: 
                    575: sub plaintext {
                    576:     return $prp{$_};
                    577: }
                    578: 
                    579: # ----------------------------------------------------------------- Assign Role
                    580: 
                    581: sub assignrole {
                    582: }
                    583: 
                    584: # -------------------------------------------------------- Escape Special Chars
                    585: 
                    586: sub escape {
                    587:     my $str=shift;
                    588:     $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
                    589:     return $str;
                    590: }
                    591: 
                    592: # ----------------------------------------------------- Un-Escape Special Chars
                    593: 
                    594: sub unescape {
                    595:     my $str=shift;
                    596:     $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
                    597:     return $str;
                    598: }
1.11      www       599: 
1.1       albertel  600: # ================================================================ Main Program
                    601: 
                    602: sub BEGIN {
                    603: if ($readit ne 'done') {
                    604: # ------------------------------------------------------------ Read access.conf
                    605: {
                    606:     my $config=Apache::File->new("/etc/httpd/conf/access.conf");
                    607: 
                    608:     while (my $configline=<$config>) {
                    609:         if ($configline =~ /PerlSetVar/) {
                    610: 	   my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
1.8       www       611:            chomp($varvalue);
1.1       albertel  612:            $perlvar{$varname}=$varvalue;
                    613:         }
                    614:     }
                    615: }
                    616: 
                    617: # ------------------------------------------------------------- Read hosts file
                    618: {
                    619:     my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab");
                    620: 
                    621:     while (my $configline=<$config>) {
                    622:        my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
                    623:        $hostname{$id}=$name;
                    624:        $hostdom{$id}=$domain;
                    625:        if ($role eq 'library') { $libserv{$id}=$name; }
                    626:     }
                    627: }
                    628: 
                    629: # ------------------------------------------------------ Read spare server file
                    630: {
                    631:     my $config=Apache::File->new("$perlvar{'lonTabDir'}/spare.tab");
                    632: 
                    633:     while (my $configline=<$config>) {
                    634:        chomp($configline);
                    635:        if (($configline) && ($configline ne $perlvar{'lonHostID'})) {
                    636:           $spareid{$configline}=1;
                    637:        }
                    638:     }
                    639: }
1.11      www       640: # ------------------------------------------------------------ Read permissions
                    641: {
                    642:     my $config=Apache::File->new("$perlvar{'lonTabDir'}/roles.tab");
                    643: 
                    644:     while (my $configline=<$config>) {
                    645:        chomp($configline);
                    646:        my ($role,$perm)=split(/ /,$configline);
                    647:        if ($perm ne '') { $pr{$role}=$perm; }
                    648:     }
                    649: }
                    650: 
                    651: # -------------------------------------------- Read plain texts for permissions
                    652: {
                    653:     my $config=Apache::File->new("$perlvar{'lonTabDir'}/rolesplain.tab");
                    654: 
                    655:     while (my $configline=<$config>) {
                    656:        chomp($configline);
                    657:        my ($short,$plain)=split(/:/,$configline);
                    658:        if ($plain ne '') { $prp{$short}=$plain; }
                    659:     }
                    660: }
                    661: 
1.1       albertel  662: $readit='done';
1.12      www       663: &logthis('<font color=yellow>INFO: Read configuration</font>');
1.1       albertel  664: }
                    665: }
                    666: 1;
1.11      www       667: 
1.1       albertel  668: 
                    669: 
                    670: 

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>