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

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
1.25      www         7: # fileembstyle(ext)  : embed style in page for file extension
                      8: # filedescription(ext) : descriptor text for file extension
1.29      www         9: # allowed(short,url) : returns codes for allowed actions 
                     10: #                      F: full access
                     11: #                      U,I,K: authentication modes (cxx only)
                     12: #                      '': forbidden
                     13: #                      1: user needs to choose course
                     14: #                      2: browse allowed
1.21      www        15: # definerole(rolename,sys,dom,cou) : define a custom role rolename
                     16: #                      set priviledges in format of lonTabs/roles.tab for
                     17: #                      system, domain and course level, 
                     18: # assignrole(udom,uname,url,role,end,start) : give a role to a user for the
                     19: #                      level given by url. Optional start and end dates
                     20: #                      (leave empty string or zero for "no date") 
                     21: # assigncustomrole (udom,uname,url,rdom,rnam,rolename,end,start) : give a
                     22: #                      custom role to a user for the level given by url.
                     23: #                      Specify name and domain of role author, and role name
                     24: # revokerole (udom,uname,url,role) : Revoke a role for url
                     25: # revokecustomrole (udom,uname,url,rdom,rnam,rolename) : Revoke a custom role
1.24      www        26: # appenv(hash)       : adds hash to session environment
1.56      www        27: # delenv(varname)    : deletes all environment entries starting with varname
1.12      www        28: # store(hash)        : stores hash permanently for this url
1.47      www        29: # cstore(hash)       : critical store
1.12      www        30: # restore            : returns hash for this url
                     31: # eget(namesp,array) : returns hash with keys from array filled in from namesp
                     32: # get(namesp,array)  : returns hash with keys from array filled in from namesp
1.38      www        33: # del(namesp,array)  : deletes keys out of array from namesp
1.12      www        34: # put(namesp,hash)   : stores hash in namesp
1.47      www        35: # cput(namesp,hash)  : critical put
1.15      www        36: # dump(namesp)       : dumps the complete namespace into a hash
1.23      www        37: # ssi(url,hash)      : does a complete request cycle on url to localhost, posts
                     38: #                      hash
1.34      www        39: # coursedescription(id) : returns and caches course description for id
1.17      www        40: # repcopy(filename)  : replicate file
                     41: # dirlist(url)       : gets a directory listing
1.40      www        42: # directcondval(index) : reading condition value of single condition from 
                     43: #                        state string
1.28      www        44: # condval(index)     : value of condition index based on state
1.58      www        45: # EXT(name)          : value of a variable
1.31      www        46: # symblist(map,hash) : Updates symbolic storage links
1.44      www        47: # symbread([filename]) : returns the data handle (filename optional)
1.31      www        48: # rndseed()          : returns a random seed  
1.36      albertel   49: # getfile(filename)  : returns the contents of filename, or a -1 if it can't
                     50: #                      be found, replicates and subscribes to the file
                     51: # filelocation(dir,file) : returns a farily clean absolute reference to file 
                     52: #                          from the directory dir
1.46      www        53: # hreflocation(dir,file) : same as filelocation, but for hrefs
1.47      www        54: # log(domain,user,home,msg) : write to permanent log for user
1.12      www        55: #
1.1       albertel   56: # 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30,
1.5       www        57: # 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19,
1.8       www        58: # 11/8,11/16,11/18,11/22,11/23,12/22,
1.12      www        59: # 01/06,01/13,02/24,02/28,02/29,
                     60: # 03/01,03/02,03/06,03/07,03/13,
1.15      www        61: # 04/05,05/29,05/31,06/01,
                     62: # 06/05,06/26 Gerd Kortemeyer
                     63: # 06/26 Ben Tyszka
1.22      www        64: # 06/30,07/15,07/17,07/18,07/20,07/21,07/22,07/25 Gerd Kortemeyer
1.23      www        65: # 08/14 Ben Tyszka
1.36      albertel   66: # 08/22,08/28,08/31,09/01,09/02,09/04,09/05,09/25,09/28,09/30 Gerd Kortemeyer
1.35      www        67: # 10/04 Gerd Kortemeyer
1.36      albertel   68: # 10/04 Guy Albertelli
1.54      www        69: # 10/06,10/09,10/10,10/11,10/14,10/20,10/23,10/25,10/26,10/27,10/28,10/29, 
1.66    ! www        70: # 10/30,10/31,11/2,11/14,11/15,11/16,11/20 Gerd Kortemeyer
1.1       albertel   71: 
                     72: package Apache::lonnet;
                     73: 
                     74: use strict;
                     75: use Apache::File;
1.8       www        76: use LWP::UserAgent();
1.15      www        77: use HTTP::Headers;
1.11      www        78: use vars 
1.25      www        79: qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp %fe %fd $readit);
1.1       albertel   80: use IO::Socket;
1.31      www        81: use GDBM_File;
1.8       www        82: use Apache::Constants qw(:common :http);
1.1       albertel   83: 
                     84: # --------------------------------------------------------------------- Logging
                     85: 
                     86: sub logthis {
                     87:     my $message=shift;
                     88:     my $execdir=$perlvar{'lonDaemons'};
                     89:     my $now=time;
                     90:     my $local=localtime($now);
                     91:     my $fh=Apache::File->new(">>$execdir/logs/lonnet.log");
                     92:     print $fh "$local ($$): $message\n";
                     93:     return 1;
                     94: }
                     95: 
                     96: sub logperm {
                     97:     my $message=shift;
                     98:     my $execdir=$perlvar{'lonDaemons'};
                     99:     my $now=time;
                    100:     my $local=localtime($now);
                    101:     my $fh=Apache::File->new(">>$execdir/logs/lonnet.perm.log");
                    102:     print $fh "$now:$message:$local\n";
                    103:     return 1;
                    104: }
                    105: 
                    106: # -------------------------------------------------- Non-critical communication
                    107: sub subreply {
                    108:     my ($cmd,$server)=@_;
                    109:     my $peerfile="$perlvar{'lonSockDir'}/$server";
                    110:     my $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",
                    111:                                      Type    => SOCK_STREAM,
                    112:                                      Timeout => 10)
                    113:        or return "con_lost";
                    114:     print $client "$cmd\n";
                    115:     my $answer=<$client>;
1.9       www       116:     if (!$answer) { $answer="con_lost"; }
1.1       albertel  117:     chomp($answer);
                    118:     return $answer;
                    119: }
                    120: 
                    121: sub reply {
                    122:     my ($cmd,$server)=@_;
                    123:     my $answer=subreply($cmd,$server);
                    124:     if ($answer eq 'con_lost') { $answer=subreply($cmd,$server); }
1.65      www       125:     if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
1.12      www       126:        &logthis("<font color=blue>WARNING:".
                    127:                 " $cmd to $server returned $answer</font>");
                    128:     }
1.1       albertel  129:     return $answer;
                    130: }
                    131: 
                    132: # ----------------------------------------------------------- Send USR1 to lonc
                    133: 
                    134: sub reconlonc {
                    135:     my $peerfile=shift;
                    136:     &logthis("Trying to reconnect for $peerfile");
                    137:     my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
                    138:     if (my $fh=Apache::File->new("$loncfile")) {
                    139: 	my $loncpid=<$fh>;
                    140:         chomp($loncpid);
                    141:         if (kill 0 => $loncpid) {
                    142: 	    &logthis("lonc at pid $loncpid responding, sending USR1");
                    143:             kill USR1 => $loncpid;
                    144:             sleep 1;
                    145:             if (-e "$peerfile") { return; }
                    146:             &logthis("$peerfile still not there, give it another try");
                    147:             sleep 5;
                    148:             if (-e "$peerfile") { return; }
1.12      www       149:             &logthis(
                    150:   "<font color=blue>WARNING: $peerfile still not there, giving up</font>");
1.1       albertel  151:         } else {
1.12      www       152: 	    &logthis(
                    153:                "<font color=blue>WARNING:".
                    154:                " lonc at pid $loncpid not responding, giving up</font>");
1.1       albertel  155:         }
                    156:     } else {
1.12      www       157:      &logthis('<font color=blue>WARNING: lonc not running, giving up</font>');
1.1       albertel  158:     }
                    159: }
                    160: 
                    161: # ------------------------------------------------------ Critical communication
1.12      www       162: 
1.1       albertel  163: sub critical {
                    164:     my ($cmd,$server)=@_;
                    165:     my $answer=reply($cmd,$server);
                    166:     if ($answer eq 'con_lost') {
                    167:         my $pingreply=reply('ping',$server);
                    168: 	&reconlonc("$perlvar{'lonSockDir'}/$server");
                    169:         my $pongreply=reply('pong',$server);
                    170:         &logthis("Ping/Pong for $server: $pingreply/$pongreply");
                    171:         $answer=reply($cmd,$server);
                    172:         if ($answer eq 'con_lost') {
                    173:             my $now=time;
                    174:             my $middlename=$cmd;
1.5       www       175:             $middlename=substr($middlename,0,16);
1.1       albertel  176:             $middlename=~s/\W//g;
                    177:             my $dfilename=
                    178:              "$perlvar{'lonSockDir'}/delayed/$now.$middlename.$server";
                    179:             {
                    180:              my $dfh;
                    181:              if ($dfh=Apache::File->new(">$dfilename")) {
1.7       www       182:                 print $dfh "$cmd\n";
1.1       albertel  183: 	     }
                    184:             }
                    185:             sleep 2;
                    186:             my $wcmd='';
                    187:             {
                    188: 	     my $dfh;
                    189:              if ($dfh=Apache::File->new("$dfilename")) {
                    190:                 $wcmd=<$dfh>;
                    191: 	     }
                    192:             }
                    193:             chomp($wcmd);
1.7       www       194:             if ($wcmd eq $cmd) {
1.12      www       195: 		&logthis("<font color=blue>WARNING: ".
                    196:                          "Connection buffer $dfilename: $cmd</font>");
1.1       albertel  197:                 &logperm("D:$server:$cmd");
                    198: 	        return 'con_delayed';
                    199:             } else {
1.12      www       200:                 &logthis("<font color=red>CRITICAL:"
                    201:                         ." Critical connection failed: $server $cmd</font>");
1.1       albertel  202:                 &logperm("F:$server:$cmd");
                    203:                 return 'con_failed';
                    204:             }
                    205:         }
                    206:     }
                    207:     return $answer;
                    208: }
                    209: 
1.5       www       210: # ---------------------------------------------------------- Append Environment
                    211: 
                    212: sub appenv {
1.6       www       213:     my %newenv=@_;
1.35      www       214:     map {
                    215: 	if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {
                    216:             &logthis("<font color=blue>WARNING: ".
                    217:                 "Attempt to modify environment ".$_." to ".$newenv{$_});
                    218: 	    delete($newenv{$_});
                    219:         } else {
                    220:             $ENV{$_}=$newenv{$_};
                    221:         }
                    222:     } keys %newenv;
1.6       www       223:     my @oldenv;
                    224:     {
                    225:      my $fh;
                    226:      unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {
1.5       www       227: 	return 'error';
1.6       www       228:      }
                    229:      @oldenv=<$fh>;
                    230:     }
                    231:     for (my $i=0; $i<=$#oldenv; $i++) {
                    232:         chomp($oldenv[$i]);
1.9       www       233:         if ($oldenv[$i] ne '') {
                    234:            my ($name,$value)=split(/=/,$oldenv[$i]);
1.24      www       235:            unless (defined($newenv{$name})) {
                    236: 	      $newenv{$name}=$value;
                    237: 	   }
1.9       www       238:         }
1.6       www       239:     }
                    240:     {
                    241:      my $fh;
                    242:      unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) {
                    243: 	return 'error';
                    244:      }
                    245:      my $newname;
                    246:      foreach $newname (keys %newenv) {
                    247: 	 print $fh "$newname=$newenv{$newname}\n";
                    248:      }
1.56      www       249:     }
                    250:     return 'ok';
                    251: }
                    252: # ----------------------------------------------------- Delete from Environment
                    253: 
                    254: sub delenv {
                    255:     my $delthis=shift;
                    256:     my %newenv=();
                    257:     if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {
                    258:         &logthis("<font color=blue>WARNING: ".
                    259:                 "Attempt to delete from environment ".$delthis);
                    260:         return 'error';
                    261:     }
                    262:     my @oldenv;
                    263:     {
                    264:      my $fh;
                    265:      unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {
                    266: 	return 'error';
                    267:      }
                    268:      @oldenv=<$fh>;
                    269:     }
                    270:     {
                    271:      my $fh;
                    272:      unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) {
                    273: 	return 'error';
                    274:      }
                    275:      map {
                    276: 	 unless ($_=~/^$delthis/) { print $fh $_; }
                    277:      } @oldenv;
1.5       www       278:     }
                    279:     return 'ok';
                    280: }
1.1       albertel  281: 
                    282: # ------------------------------ Find server with least workload from spare.tab
1.11      www       283: 
1.1       albertel  284: sub spareserver {
                    285:     my $tryserver;
                    286:     my $spareserver='';
                    287:     my $lowestserver=100;
                    288:     foreach $tryserver (keys %spareid) {
                    289:        my $answer=reply('load',$tryserver);
                    290:        if (($answer =~ /\d/) && ($answer<$lowestserver)) {
                    291: 	   $spareserver="http://$hostname{$tryserver}";
                    292:            $lowestserver=$answer;
                    293:        }
                    294:     }    
                    295:     return $spareserver;
                    296: }
                    297: 
                    298: # --------- Try to authenticate user from domain's lib servers (first this one)
1.11      www       299: 
1.1       albertel  300: sub authenticate {
                    301:     my ($uname,$upass,$udom)=@_;
1.12      www       302:     $upass=escape($upass);
1.1       albertel  303:     if (($perlvar{'lonRole'} eq 'library') && 
                    304:         ($udom eq $perlvar{'lonDefDomain'})) {
1.3       www       305:     my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'});
1.2       www       306:         if ($answer =~ /authorized/) {
1.9       www       307:               if ($answer eq 'authorized') {
                    308:                  &logthis("User $uname at $udom authorized by local server"); 
                    309:                  return $perlvar{'lonHostID'}; 
                    310:               }
                    311:               if ($answer eq 'non_authorized') {
                    312:                  &logthis("User $uname at $udom rejected by local server"); 
                    313:                  return 'no_host'; 
                    314:               }
1.2       www       315: 	}
1.1       albertel  316:     }
                    317: 
                    318:     my $tryserver;
                    319:     foreach $tryserver (keys %libserv) {
                    320: 	if ($hostdom{$tryserver} eq $udom) {
1.10      www       321:            my $answer=reply("encrypt:auth:$udom:$uname:$upass",$tryserver);
1.1       albertel  322:            if ($answer =~ /authorized/) {
1.9       www       323:               if ($answer eq 'authorized') {
                    324:                  &logthis("User $uname at $udom authorized by $tryserver"); 
                    325:                  return $tryserver; 
                    326:               }
                    327:               if ($answer eq 'non_authorized') {
                    328:                  &logthis("User $uname at $udom rejected by $tryserver");
                    329:                  return 'no_host';
                    330:               } 
1.1       albertel  331: 	   }
                    332:        }
1.9       www       333:     }
                    334:     &logthis("User $uname at $udom could not be authenticated");    
1.1       albertel  335:     return 'no_host';
                    336: }
                    337: 
                    338: # ---------------------- Find the homebase for a user from domain's lib servers
1.11      www       339: 
1.1       albertel  340: sub homeserver {
                    341:     my ($uname,$udom)=@_;
                    342: 
                    343:     my $index="$uname:$udom";
                    344:     if ($homecache{$index}) { return "$homecache{$index}"; }
                    345: 
                    346:     my $tryserver;
                    347:     foreach $tryserver (keys %libserv) {
                    348: 	if ($hostdom{$tryserver} eq $udom) {
                    349:            my $answer=reply("home:$udom:$uname",$tryserver);
                    350:            if ($answer eq 'found') { 
                    351: 	      $homecache{$index}=$tryserver;
                    352:               return $tryserver; 
                    353: 	   }
                    354:        }
                    355:     }    
                    356:     return 'no_host';
                    357: }
                    358: 
                    359: # ----------------------------- Subscribe to a resource, return URL if possible
1.11      www       360: 
1.1       albertel  361: sub subscribe {
                    362:     my $fname=shift;
                    363:     my $author=$fname;
                    364:     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
                    365:     my ($udom,$uname)=split(/\//,$author);
                    366:     my $home=homeserver($uname,$udom);
                    367:     if (($home eq 'no_host') || ($home eq $perlvar{'lonHostID'})) { 
                    368:         return 'not_found'; 
                    369:     }
                    370:     my $answer=reply("sub:$fname",$home);
1.64      www       371:     if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
                    372: 	$answer.=' by '.$home;
                    373:     }
1.1       albertel  374:     return $answer;
                    375: }
                    376:     
1.8       www       377: # -------------------------------------------------------------- Replicate file
                    378: 
                    379: sub repcopy {
                    380:     my $filename=shift;
1.23      www       381:     $filename=~s/\/+/\//g;
1.8       www       382:     my $transname="$filename.in.transfer";
1.17      www       383:     if ((-e $filename) || (-e $transname)) { return OK; }
1.8       www       384:     my $remoteurl=subscribe($filename);
1.64      www       385:     if ($remoteurl =~ /^con_lost by/) {
                    386: 	   &logthis("Subscribe returned $remoteurl: $filename");
1.8       www       387:            return HTTP_SERVICE_UNAVAILABLE;
                    388:     } elsif ($remoteurl eq 'not_found') {
                    389: 	   &logthis("Subscribe returned not_found: $filename");
                    390: 	   return HTTP_NOT_FOUND;
1.64      www       391:     } elsif ($remoteurl =~ /^rejected by/) {
                    392: 	   &logthis("Subscribe returned $remoteurl: $filename");
1.8       www       393:            return FORBIDDEN;
1.20      www       394:     } elsif ($remoteurl eq 'directory') {
                    395:            return OK;
1.8       www       396:     } else {
                    397:            my @parts=split(/\//,$filename);
                    398:            my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
                    399:            if ($path ne "$perlvar{'lonDocRoot'}/res") {
                    400:                &logthis("Malconfiguration for replication: $filename");
                    401: 	       return HTTP_BAD_REQUEST;
                    402:            }
                    403:            my $count;
                    404:            for ($count=5;$count<$#parts;$count++) {
                    405:                $path.="/$parts[$count]";
                    406:                if ((-e $path)!=1) {
                    407: 		   mkdir($path,0777);
                    408:                }
                    409:            }
                    410:            my $ua=new LWP::UserAgent;
                    411:            my $request=new HTTP::Request('GET',"$remoteurl");
                    412:            my $response=$ua->request($request,$transname);
                    413:            if ($response->is_error()) {
                    414: 	       unlink($transname);
                    415:                my $message=$response->status_line;
1.12      www       416:                &logthis("<font color=blue>WARNING:"
                    417:                        ." LWP get: $message: $filename</font>");
1.8       www       418:                return HTTP_SERVICE_UNAVAILABLE;
                    419:            } else {
1.16      www       420: 	       if ($remoteurl!~/\.meta$/) {
                    421:                   my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');
                    422:                   my $mresponse=$ua->request($mrequest,$filename.'.meta');
                    423:                   if ($mresponse->is_error()) {
                    424: 		      unlink($filename.'.meta');
                    425:                       &logthis(
                    426:                      "<font color=yellow>INFO: No metadata: $filename</font>");
                    427:                   }
                    428: 	       }
1.8       www       429:                rename($transname,$filename);
                    430:                return OK;
                    431:            }
                    432:     }
                    433: }
                    434: 
1.15      www       435: # --------------------------------------------------------- Server Side Include
                    436: 
                    437: sub ssi {
                    438: 
1.23      www       439:     my ($fn,%form)=@_;
1.15      www       440: 
                    441:     my $ua=new LWP::UserAgent;
1.23      www       442:     
                    443:     my $request;
                    444:     
                    445:     if (%form) {
                    446:       $request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn);
                    447:       $request->content(join '&', map { "$_=$form{$_}" } keys %form);
                    448:     } else {
                    449:       $request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn);
                    450:     }
                    451: 
1.15      www       452:     $request->header(Cookie => $ENV{'HTTP_COOKIE'});
                    453:     my $response=$ua->request($request);
                    454: 
                    455:     return $response->content;
                    456: }
                    457: 
1.14      www       458: # ------------------------------------------------------------------------- Log
                    459: 
                    460: sub log {
                    461:     my ($dom,$nam,$hom,$what)=@_;
1.47      www       462:     return critical("log:$dom:$nam:$what",$hom);
1.14      www       463: }
                    464: 
1.9       www       465: # ----------------------------------------------------------------------- Store
                    466: 
                    467: sub store {
1.31      www       468:     my %storehash=@_;
                    469:     my $symb;
1.44      www       470:     unless ($symb=escape(&symbread())) { return ''; }
1.31      www       471:     my $namespace;
1.33      www       472:     unless ($namespace=$ENV{'request.course.id'}) { return ''; }
1.12      www       473:     my $namevalue='';
                    474:     map {
                    475:         $namevalue.=escape($_).'='.escape($storehash{$_}).'&';
                    476:     } keys %storehash;
                    477:     $namevalue=~s/\&$//;
1.31      www       478:     return reply(
                    479:      "store:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$symb:$namevalue",
1.12      www       480: 		 "$ENV{'user.home'}");
1.9       www       481: }
                    482: 
1.47      www       483: # -------------------------------------------------------------- Critical Store
                    484: 
                    485: sub cstore {
                    486:     my %storehash=@_;
                    487:     my $symb;
                    488:     unless ($symb=escape(&symbread())) { return ''; }
                    489:     my $namespace;
                    490:     unless ($namespace=$ENV{'request.course.id'}) { return ''; }
                    491:     my $namevalue='';
                    492:     map {
                    493:         $namevalue.=escape($_).'='.escape($storehash{$_}).'&';
                    494:     } keys %storehash;
                    495:     $namevalue=~s/\&$//;
                    496:     return critical(
                    497:      "store:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$symb:$namevalue",
                    498: 		 "$ENV{'user.home'}");
                    499: }
                    500: 
1.9       www       501: # --------------------------------------------------------------------- Restore
                    502: 
                    503: sub restore {
1.31      www       504:     my $symb;
1.44      www       505:     unless ($symb=escape(&symbread())) { return ''; }
1.31      www       506:     my $namespace;
1.33      www       507:     unless ($namespace=$ENV{'request.course.id'}) { return ''; }
1.31      www       508:     my $answer=reply(
                    509:               "restore:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$symb",
                    510:               "$ENV{'user.home'}");
1.12      www       511:     my %returnhash=();
                    512:     map {
                    513: 	my ($name,$value)=split(/\=/,$_);
                    514:         $returnhash{&unescape($name)}=&unescape($value);
                    515:     } split(/\&/,$answer);
1.31      www       516:     map {
                    517:         $returnhash{$_}=$returnhash{$returnhash{'version'}.':'.$_};
                    518:     } split(/\:/,$returnhash{$returnhash{'version'}.':keys'});
1.13      www       519:     return %returnhash;
1.34      www       520: }
                    521: 
                    522: # ---------------------------------------------------------- Course Description
                    523: 
                    524: sub coursedescription {
                    525:     my $courseid=shift;
                    526:     $courseid=~s/^\///;
1.49      www       527:     $courseid=~s/\_/\//g;
1.34      www       528:     my ($cdomain,$cnum)=split(/\//,$courseid);
                    529:     my $chome=homeserver($cnum,$cdomain);
                    530:     if ($chome ne 'no_host') {
                    531:        my $rep=reply("dump:$cdomain:$cnum:environment",$chome);
                    532:        if ($rep ne 'con_lost') {
1.54      www       533:            my $normalid=$courseid;
                    534:            $normalid=~s/\//\_/g;
1.53      www       535:            my %envhash=();
1.34      www       536:            my %returnhash=('home'   => $chome, 
                    537:                            'domain' => $cdomain,
                    538:                            'num'    => $cnum);
                    539:            map {
                    540:                my ($name,$value)=split(/\=/,$_);
                    541:                $name=&unescape($name);
                    542:                $value=&unescape($value);
                    543:                $returnhash{$name}=$value;
1.53      www       544:                $envhash{'course.'.$normalid.'.'.$name}=$value;
1.34      www       545:            } split(/\&/,$rep);
                    546:            $returnhash{'url'}='/res/'.declutter($returnhash{'url'});
                    547:            $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.
1.38      www       548: 	       $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum;
1.54      www       549:            $envhash{'course.'.$normalid.'.last_cache'}=time;
1.60      www       550:            $envhash{'course.'.$normalid.'.home'}=$chome;
                    551:            $envhash{'course.'.$normalid.'.domain'}=$cdomain;
                    552:            $envhash{'course.'.$normalid.'.num'}=$cnum;
1.53      www       553:            &appenv(%envhash);
1.34      www       554:            return %returnhash;
                    555:        }
                    556:     }
                    557:     return ();
1.9       www       558: }
1.1       albertel  559: 
1.11      www       560: # -------------------------------------------------------- Get user priviledges
                    561: 
                    562: sub rolesinit {
                    563:     my ($domain,$username,$authhost)=@_;
                    564:     my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
1.12      www       565:     if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; }
1.11      www       566:     my %allroles=();
                    567:     my %thesepriv=();
                    568:     my $now=time;
1.21      www       569:     my $userroles="user.login.time=$now\n";
1.11      www       570:     my $thesestr;
                    571: 
                    572:     if ($rolesdump ne '') {
                    573:         map {
1.21      www       574: 	  if ($_!~/^rolesdef\&/) {
1.11      www       575:             my ($area,$role)=split(/=/,$_);
1.21      www       576:             $area=~s/\_\w\w$//;
1.11      www       577:             my ($trole,$tend,$tstart)=split(/_/,$role);
1.21      www       578:             $userroles.='user.role.'.$trole.'.'.$area.'='.
                    579:                         $tstart.'.'.$tend."\n";
1.11      www       580:             if ($tend!=0) {
                    581: 	        if ($tend<$now) {
                    582: 	            $trole='';
                    583:                 } 
                    584:             }
                    585:             if ($tstart!=0) {
                    586:                 if ($tstart>$now) {
                    587:                    $trole='';        
                    588:                 }
                    589:             }
                    590:             if (($area ne '') && ($trole ne '')) {
1.50      www       591: 	       my $spec=$trole.'.'.$area;
1.12      www       592:                my ($tdummy,$tdomain,$trest)=split(/\//,$area);
                    593:                if ($trole =~ /^cr\//) {
                    594: 		   my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
                    595:                    my $homsvr=homeserver($rauthor,$rdomain);
                    596:                    if ($hostname{$homsvr} ne '') {
                    597:                       my $roledef=
1.21      www       598: 			  reply("get:$rdomain:$rauthor:roles:rolesdef_$rrole",
1.12      www       599:                                 $homsvr);
                    600:                       if (($roledef ne 'con_lost') && ($roledef ne '')) {
                    601:                          my ($syspriv,$dompriv,$coursepriv)=
1.21      www       602: 			     split(/\_/,unescape($roledef));
1.50      www       603:  	                 $allroles{'cm./'}.=':'.$syspriv;
                    604:                          $allroles{$spec.'./'}.=':'.$syspriv;
1.12      www       605:                          if ($tdomain ne '') {
1.50      www       606:                              $allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv;
                    607:                              $allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;
1.12      www       608:                              if ($trest ne '') {
1.50      www       609: 		                $allroles{'cm.'.$area}.=':'.$coursepriv;
                    610: 		                $allroles{$spec.'.'.$area}.=':'.$coursepriv;
1.12      www       611:                              }
                    612: 	                 }
                    613:                       }
1.11      www       614:                    }
1.12      www       615:                } else {
1.50      www       616: 	           $allroles{'cm./'}.=':'.$pr{$trole.':s'};
                    617: 	           $allroles{$spec.'./'}.=':'.$pr{$trole.':s'};
1.12      www       618:                    if ($tdomain ne '') {
1.50      www       619:                      $allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
                    620:                      $allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
1.12      www       621:                       if ($trest ne '') {
1.50      www       622: 		          $allroles{'cm.'.$area}.=':'.$pr{$trole.':c'};
                    623: 		          $allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'};
1.12      www       624:                       }
                    625: 	           }
1.11      www       626: 	       }
1.12      www       627:             }
                    628:           } 
1.11      www       629:         } split(/&/,$rolesdump);
                    630:         map {
                    631:             %thesepriv=();
                    632:             map {
                    633:                 if ($_ ne '') {
                    634: 		    my ($priviledge,$restrictions)=split(/&/,$_);
                    635:                     if ($restrictions eq '') {
                    636: 			$thesepriv{$priviledge}='F';
                    637:                     } else {
                    638:                         if ($thesepriv{$priviledge} ne 'F') {
                    639: 			    $thesepriv{$priviledge}.=$restrictions;
                    640:                         }
                    641:                     }
                    642:                 }
                    643:             } split(/:/,$allroles{$_});
                    644:             $thesestr='';
                    645:             map { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } keys %thesepriv;
                    646:             $userroles.='user.priv.'.$_.'='.$thesestr."\n";
                    647:         } keys %allroles;            
                    648:     }
                    649:     return $userroles;  
                    650: }
                    651: 
1.12      www       652: # --------------------------------------------------------------- get interface
                    653: 
                    654: sub get {
                    655:    my ($namespace,@storearr)=@_;
                    656:    my $items='';
                    657:    map {
                    658:        $items.=escape($_).'&';
                    659:    } @storearr;
                    660:    $items=~s/\&$//;
                    661:  my $rep=reply("get:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
                    662:                  $ENV{'user.home'});
1.15      www       663:    my @pairs=split(/\&/,$rep);
                    664:    my %returnhash=();
1.42      www       665:    my $i=0;
1.15      www       666:    map {
1.42      www       667:       $returnhash{$_}=unescape($pairs[$i]);
                    668:       $i++;
                    669:    } @storearr;
1.15      www       670:    return %returnhash;
1.27      www       671: }
                    672: 
                    673: # --------------------------------------------------------------- del interface
                    674: 
                    675: sub del {
                    676:    my ($namespace,@storearr)=@_;
                    677:    my $items='';
                    678:    map {
                    679:        $items.=escape($_).'&';
                    680:    } @storearr;
                    681:    $items=~s/\&$//;
                    682:    return reply("del:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
                    683:                  $ENV{'user.home'});
1.15      www       684: }
                    685: 
                    686: # -------------------------------------------------------------- dump interface
                    687: 
                    688: sub dump {
                    689:    my $namespace=shift;
                    690:    my $rep=reply("dump:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace",
                    691:                 $ENV{'user.home'});
1.12      www       692:    my @pairs=split(/\&/,$rep);
                    693:    my %returnhash=();
                    694:    map {
                    695:       my ($key,$value)=split(/=/,$_);
1.29      www       696:       $returnhash{unescape($key)}=unescape($value);
1.12      www       697:    } @pairs;
                    698:    return %returnhash;
                    699: }
                    700: 
                    701: # --------------------------------------------------------------- put interface
                    702: 
                    703: sub put {
                    704:    my ($namespace,%storehash)=@_;
                    705:    my $items='';
                    706:    map {
                    707:        $items.=escape($_).'='.escape($storehash{$_}).'&';
                    708:    } keys %storehash;
                    709:    $items=~s/\&$//;
                    710:    return reply("put:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
1.47      www       711:                  $ENV{'user.home'});
                    712: }
                    713: 
                    714: # ------------------------------------------------------ critical put interface
                    715: 
                    716: sub cput {
                    717:    my ($namespace,%storehash)=@_;
                    718:    my $items='';
                    719:    map {
                    720:        $items.=escape($_).'='.escape($storehash{$_}).'&';
                    721:    } keys %storehash;
                    722:    $items=~s/\&$//;
                    723:    return critical
                    724:            ("put:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
1.12      www       725:                  $ENV{'user.home'});
                    726: }
                    727: 
                    728: # -------------------------------------------------------------- eget interface
                    729: 
                    730: sub eget {
                    731:    my ($namespace,@storearr)=@_;
                    732:    my $items='';
                    733:    map {
                    734:        $items.=escape($_).'&';
                    735:    } @storearr;
                    736:    $items=~s/\&$//;
                    737:  my $rep=reply("eget:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
                    738:                  $ENV{'user.home'});
                    739:    my @pairs=split(/\&/,$rep);
                    740:    my %returnhash=();
1.42      www       741:    my $i=0;
1.12      www       742:    map {
1.42      www       743:       $returnhash{$_}=unescape($pairs[$i]);
                    744:       $i++;
                    745:    } @storearr;
1.12      www       746:    return %returnhash;
                    747: }
                    748: 
                    749: # ------------------------------------------------- Check for a user priviledge
                    750: 
                    751: sub allowed {
                    752:     my ($priv,$uri)=@_;
1.52      www       753:     $uri=&declutter($uri);
1.29      www       754: 
1.54      www       755: # Free bre access to adm and meta resources
1.29      www       756: 
1.54      www       757:     if ((($uri=~/^adm\//) || ($uri=~/\.meta$/)) && ($priv eq 'bre')) {
1.14      www       758: 	return 'F';
                    759:     }
1.29      www       760: 
1.52      www       761:     my $thisallowed='';
                    762:     my $statecond=0;
                    763:     my $courseprivid='';
                    764: 
                    765: # Course
                    766: 
                    767:     if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'}=~/$priv\&([^\:]*)/) {
                    768:        $thisallowed.=$1;
                    769:     }
1.29      www       770: 
1.52      www       771: # Domain
                    772: 
                    773:     if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.(split(/\//,$uri))[0].'/'}
                    774:        =~/$priv\&([^\:]*)/) {
1.12      www       775:        $thisallowed.=$1;
                    776:     }
1.52      www       777: 
                    778: # Course: uri itself is a course
1.66    ! www       779:     my $courseuri=$uri;
        !           780:     $courseuri=~s/\_(\d)/\/$1/;
        !           781:     if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseuri}
1.52      www       782:        =~/$priv\&([^\:]*)/) {
1.12      www       783:        $thisallowed.=$1;
                    784:     }
1.29      www       785: 
1.52      www       786: # Full access at system, domain or course-wide level? Exit.
1.29      www       787: 
                    788:     if ($thisallowed=~/F/) {
                    789: 	return 'F';
                    790:     }
                    791: 
1.52      www       792: # If this is generating or modifying users, exit with special codes
1.29      www       793: 
1.52      www       794:     if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:'=~/\:$priv\:/) {
                    795: 	return $thisallowed;
                    796:     }
                    797: #
                    798: # Gathered so far: system, domain and course wide priviledges
                    799: #
                    800: # Course: See if uri or referer is an individual resource that is part of 
                    801: # the course
                    802: 
                    803:     if ($ENV{'request.course.id'}) {
                    804:        $courseprivid=$ENV{'request.course.id'};
                    805:        if ($ENV{'request.course.sec'}) {
                    806:           $courseprivid.='/'.$ENV{'request.course.sec'};
                    807:        }
                    808:        $courseprivid=~s/\_/\//;
                    809:        my $checkreferer=1;
                    810:        my @uriparts=split(/\//,$uri);
                    811:        my $filename=$uriparts[$#uriparts];
                    812:        my $pathname=$uri;
                    813:        $pathname=~s/\/$filename$//;
                    814:        if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
1.54      www       815:            /\&$filename\:([\d\|]+)\&/) {
1.52      www       816:            $statecond=$1;
                    817:            if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}
                    818:                =~/$priv\&([^\:]*)/) {
                    819:                $thisallowed.=$1;
                    820:                $checkreferer=0;
                    821:            }
1.29      www       822:        }
1.55      www       823: 
1.52      www       824:        if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) {
1.55      www       825: 	  my $refuri=$ENV{'HTTP_REFERER'};
                    826:           $refuri=~s/^http\:\/\/$ENV{'request.host'}//i;
                    827:           $refuri=&declutter($refuri);
1.53      www       828:           my @uriparts=split(/\//,$refuri);
1.52      www       829:           my $filename=$uriparts[$#uriparts];
1.53      www       830:           my $pathname=$refuri;
1.52      www       831:           $pathname=~s/\/$filename$//;
1.55      www       832:           my @filenameparts=split(/\./,$uri);
1.53      www       833:           if (&fileembstyle($filenameparts[$#filenameparts]) ne 'ssi') {
                    834:             if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
1.54      www       835:               /\&$filename\:([\d\|]+)\&/) {
1.53      www       836:               my $refstatecond=$1;
1.52      www       837:               if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}
                    838:                   =~/$priv\&([^\:]*)/) {
                    839:                   $thisallowed.=$1;
1.53      www       840:                   $uri=$refuri;
                    841:                   $statecond=$refstatecond;
1.52      www       842:               }
1.53      www       843:             }
1.52      www       844:           }
1.29      www       845:        }
1.52      www       846:    }
1.29      www       847: 
1.52      www       848: #
                    849: # Gathered now: all priviledges that could apply, and condition number
                    850: # 
                    851: #
                    852: # Full or no access?
                    853: #
1.29      www       854: 
1.52      www       855:     if ($thisallowed=~/F/) {
                    856: 	return 'F';
                    857:     }
1.29      www       858: 
1.52      www       859:     unless ($thisallowed) {
                    860:         return '';
                    861:     }
1.29      www       862: 
1.52      www       863: # Restrictions exist, deal with them
                    864: #
                    865: #   C:according to course preferences
                    866: #   R:according to resource settings
                    867: #   L:unless locked
                    868: #   X:according to user session state
                    869: #
                    870: 
                    871: # Possibly locked functionality, check all courses
1.54      www       872: # Locks might take effect only after 10 minutes cache expiration for other
                    873: # courses, and 2 minutes for current course
1.52      www       874: 
                    875:     my $envkey;
                    876:     if ($thisallowed=~/L/) {
                    877:         foreach $envkey (keys %ENV) {
1.54      www       878:            if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {
                    879:                my $courseid=$2;
                    880:                my $roleid=$1.'.'.$2;
                    881:                my $expiretime=600;
                    882:                if ($ENV{'request.role'} eq $roleid) {
                    883: 		  $expiretime=120;
                    884:                }
                    885: 	       my ($cdom,$cnum,$csec)=split(/\//,$courseid);
                    886:                my $prefix='course.'.$cdom.'_'.$cnum.'.';
                    887:                if ((time-$ENV{$prefix.'last_cache'})>$expiretime) {
                    888: 		   &coursedescription($courseid);
                    889:                }
                    890:                if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,$csec\,/)
                    891:                 || ($ENV{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {
                    892: 		   if ($ENV{$prefix.'res.'.$uri.'.lock.expire'}>time) {
1.57      www       893:                        &log($ENV{'user.domain'},$ENV{'user.name'},
                    894:                             $ENV{'user.host'},
                    895:                             'Locked by res: '.$priv.' for '.$uri.' due to '.
1.52      www       896:                             $cdom.'/'.$cnum.'/'.$csec.' expire '.
1.54      www       897:                             $ENV{$prefix.'priv.'.$priv.'.lock.expire'});
1.52      www       898: 		       return '';
                    899:                    }
                    900:                }
1.54      www       901:                if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,$csec\,/)
                    902:                 || ($ENV{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {
                    903: 		   if ($ENV{'priv.'.$priv.'.lock.expire'}>time) {
1.57      www       904:                        &log($ENV{'user.domain'},$ENV{'user.name'},
                    905:                             $ENV{'user.host'},
                    906:                             'Locked by priv: '.$priv.' for '.$uri.' due to '.
1.52      www       907:                             $cdom.'/'.$cnum.'/'.$csec.' expire '.
1.54      www       908:                             $ENV{$prefix.'priv.'.$priv.'.lock.expire'});
1.52      www       909: 		       return '';
                    910:                    }
                    911:                }
                    912: 	   }
1.29      www       913:        }
1.52      www       914:     }
                    915:    
                    916: #
                    917: # Rest of the restrictions depend on selected course
                    918: #
                    919: 
                    920:     unless ($ENV{'request.course.id'}) {
                    921:        return '1';
                    922:     }
1.29      www       923: 
1.52      www       924: #
                    925: # Now user is definitely in a course
                    926: #
1.53      www       927: 
                    928: 
                    929: # Course preferences
                    930: 
                    931:    if ($thisallowed=~/C/) {
1.54      www       932:        my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
                    933:        if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'}
                    934: 	   =~/\,$rolecode\,/) {
1.57      www       935:            &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
                    936:                 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
1.54      www       937:                 $ENV{'request.course.id'});
                    938:            return '';
                    939:        }
1.53      www       940:    }
                    941: 
                    942: # Resource preferences
                    943: 
                    944:    if ($thisallowed=~/R/) {
1.54      www       945:        my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
                    946:        my $filename=$perlvar{'lonDocRoot'}.'/res/'.$uri.'.meta';
                    947:        if (-e $filename) {
                    948:            my @content;
                    949:            {
                    950: 	     my $fh=Apache::File->new($filename);
                    951:              @content=<$fh>;
                    952: 	   }
                    953:            if (join('',@content)=~
                    954:                     /\<roledeny[^\>]*\>[^\<]*$rolecode[^\<]*\<\/roledeny\>/) {
1.57      www       955: 	       &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
                    956:                     'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
1.54      www       957:            return '';
                    958: 
                    959:            }
                    960:        }
1.53      www       961:    }
1.30      www       962: 
1.52      www       963: # Restricted by state?
1.30      www       964: 
1.52      www       965:    if ($thisallowed=~/X/) {
                    966:       if (&condval($statecond)) {
                    967: 	 return '2';
                    968:       } else {
                    969:          return '';
                    970:       }
                    971:    }
1.30      www       972: 
1.52      www       973:    return 'F';
1.12      www       974: }
                    975: 
                    976: # ----------------------------------------------------------------- Define Role
                    977: 
                    978: sub definerole {
                    979:   if (allowed('mcr','/')) {
                    980:     my ($rolename,$sysrole,$domrole,$courole)=@_;
1.21      www       981:     map {
                    982: 	my ($crole,$cqual)=split(/\&/,$_);
                    983:         if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; }
                    984:         if ($pr{'cr:s'}=~/$crole\&/) {
                    985: 	    if ($pr{'cr:s'}!~/$crole\&\w*$cqual/) { 
                    986:                return "refused:s:$crole&$cqual"; 
                    987:             }
                    988:         }
                    989:     } split('/',$sysrole);
                    990:     map {
                    991: 	my ($crole,$cqual)=split(/\&/,$_);
                    992:         if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; }
                    993:         if ($pr{'cr:d'}=~/$crole\&/) {
                    994: 	    if ($pr{'cr:d'}!~/$crole\&\w*$cqual/) { 
                    995:                return "refused:d:$crole&$cqual"; 
                    996:             }
                    997:         }
                    998:     } split('/',$domrole);
                    999:     map {
                   1000: 	my ($crole,$cqual)=split(/\&/,$_);
                   1001:         if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; }
                   1002:         if ($pr{'cr:c'}=~/$crole\&/) {
                   1003: 	    if ($pr{'cr:c'}!~/$crole\&\w*$cqual/) { 
                   1004:                return "refused:c:$crole&$cqual"; 
                   1005:             }
                   1006:         }
                   1007:     } split('/',$courole);
1.12      www      1008:     my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".
                   1009:                 "$ENV{'user.domain'}:$ENV{'user.name'}:".
1.21      www      1010: 	        "rolesdef_$rolename=".
                   1011:                 escape($sysrole.'_'.$domrole.'_'.$courole);
1.12      www      1012:     return reply($command,$ENV{'user.home'});
                   1013:   } else {
                   1014:     return 'refused';
                   1015:   }
                   1016: }
                   1017: 
                   1018: # ------------------------------------------------------------------ Plain Text
                   1019: 
                   1020: sub plaintext {
1.22      www      1021:     my $short=shift;
                   1022:     return $prp{$short};
1.12      www      1023: }
                   1024: 
1.25      www      1025: # ------------------------------------------------------------------ Plain Text
                   1026: 
                   1027: sub fileembstyle {
                   1028:     my $ending=shift;
                   1029:     return $fe{$ending};
                   1030: }
                   1031: 
                   1032: # ------------------------------------------------------------ Description Text
                   1033: 
                   1034: sub filedecription {
                   1035:     my $ending=shift;
                   1036:     return $fd{$ending};
                   1037: }
                   1038: 
1.12      www      1039: # ----------------------------------------------------------------- Assign Role
                   1040: 
                   1041: sub assignrole {
1.21      www      1042:     my ($udom,$uname,$url,$role,$end,$start)=@_;
                   1043:     my $mrole;
1.31      www      1044:     $url=declutter($url);
1.21      www      1045:     if ($role =~ /^cr\//) {
                   1046:         unless ($url=~/\.course$/) { return 'invalid'; }
                   1047: 	unless (allowed('ccr',$url)) { return 'refused'; }
                   1048:         $mrole='cr';
                   1049:     } else {
                   1050:         unless (($url=~/\.course$/) || ($url=~/\/$/)) { return 'invalid'; }
                   1051:         unless (allowed('c'+$role)) { return 'refused'; }
                   1052:         $mrole=$role;
                   1053:     }
                   1054:     my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".
                   1055:                 "$udom:$uname:$url".'_'."$mrole=$role";
                   1056:     if ($end) { $command.='_$end'; }
                   1057:     if ($start) {
                   1058: 	if ($end) { 
                   1059:            $command.='_$start'; 
                   1060:         } else {
                   1061:            $command.='_0_$start';
                   1062:         }
                   1063:     }
                   1064:     return &reply($command,&homeserver($uname,$udom));
                   1065: }
                   1066: 
                   1067: # ---------------------------------------------------------- Assign Custom Role
                   1068: 
                   1069: sub assigncustomrole {
                   1070:     my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start)=@_;
                   1071:     return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,
                   1072:                        $end,$start);
                   1073: }
                   1074: 
                   1075: # ----------------------------------------------------------------- Revoke Role
                   1076: 
                   1077: sub revokerole {
                   1078:     my ($udom,$uname,$url,$role)=@_;
                   1079:     my $now=time;
                   1080:     return &assignrole($udom,$uname,$url,$role,$now);
                   1081: }
                   1082: 
                   1083: # ---------------------------------------------------------- Revoke Custom Role
                   1084: 
                   1085: sub revokecustomrole {
                   1086:     my ($udom,$uname,$url,$rdom,$rnam,$rolename)=@_;
                   1087:     my $now=time;
                   1088:     return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now);
1.17      www      1089: }
                   1090: 
                   1091: # ------------------------------------------------------------ Directory lister
                   1092: 
                   1093: sub dirlist {
                   1094:     my $uri=shift;
1.18      www      1095:     $uri=~s/^\///;
                   1096:     $uri=~s/\/$//;
1.19      www      1097:     my ($res,$udom,$uname,@rest)=split(/\//,$uri);
                   1098:     if ($udom) {
                   1099:      if ($uname) {
                   1100:        my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/'.$uri,
                   1101:                       homeserver($uname,$udom));
                   1102:        return split(/:/,$listing);
                   1103:      } else {
                   1104:        my $tryserver;
                   1105:        my %allusers=();
                   1106:        foreach $tryserver (keys %libserv) {
                   1107: 	  if ($hostdom{$tryserver} eq $udom) {
                   1108:              my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.$udom,
                   1109: 			       $tryserver);
                   1110:              if (($listing ne 'no_such_dir') && ($listing ne 'empty')
                   1111:               && ($listing ne 'con_lost')) {
                   1112:                 map {
                   1113:                   my ($entry,@stat)=split(/&/,$_);
                   1114:                   $allusers{$entry}=1;
                   1115:                 } split(/:/,$listing);
                   1116:              }
                   1117: 	  }
                   1118:        }
                   1119:        my $alluserstr='';
                   1120:        map {
                   1121:            $alluserstr.=$_.'&user:';
                   1122:        } sort keys %allusers;
                   1123:        $alluserstr=~s/:$//;
                   1124:        return split(/:/,$alluserstr);
                   1125:      } 
                   1126:    } else {
                   1127:        my $tryserver;
                   1128:        my %alldom=();
                   1129:        foreach $tryserver (keys %libserv) {
                   1130: 	   $alldom{$hostdom{$tryserver}}=1;
                   1131:        }
                   1132:        my $alldomstr='';
                   1133:        map {
                   1134:           $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:';
                   1135:        } sort keys %alldom;
                   1136:        $alldomstr=~s/:$//;
                   1137:        return split(/:/,$alldomstr);       
                   1138:    }
1.26      www      1139: }
                   1140: 
                   1141: # -------------------------------------------------------- Value of a Condition
                   1142: 
1.40      www      1143: sub directcondval {
                   1144:     my $number=shift;
                   1145:     if ($ENV{'user.state.'.$ENV{'request.course.id'}}) {
                   1146:        return substr($ENV{'user.state.'.$ENV{'request.course.id'}},$number,1);
                   1147:     } else {
                   1148:        return 2;
                   1149:     }
                   1150: }
                   1151: 
1.26      www      1152: sub condval {
                   1153:     my $condidx=shift;
                   1154:     my $result=0;
1.54      www      1155:     my $allpathcond='';
                   1156:     map {
                   1157:        if (defined($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_})) {
                   1158: 	   $allpathcond.=
                   1159:                '('.$ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_}.')|';
                   1160:        }
                   1161:     } split(/\|/,$condidx);
                   1162:     $allpathcond=~s/\|$//;
1.33      www      1163:     if ($ENV{'request.course.id'}) {
1.54      www      1164:        if ($allpathcond) {
1.26      www      1165:           my $operand='|';
                   1166: 	  my @stack;
                   1167:           map {
                   1168:               if ($_ eq '(') {
                   1169:                  push @stack,($operand,$result)
                   1170:               } elsif ($_ eq ')') {
                   1171:                   my $before=pop @stack;
                   1172: 		  if (pop @stack eq '&') {
                   1173: 		      $result=$result>$before?$before:$result;
                   1174:                   } else {
                   1175:                       $result=$result>$before?$result:$before;
                   1176:                   }
                   1177:               } elsif (($_ eq '&') || ($_ eq '|')) {
                   1178:                   $operand=$_;
                   1179:               } else {
1.40      www      1180:                   my $new=directcondval($_);
1.26      www      1181:                   if ($operand eq '&') {
                   1182:                      $result=$result>$new?$new:$result;
                   1183:                   } else {
                   1184:                      $result=$result>$new?$result:$new;
                   1185:                   }                  
                   1186:               }
1.54      www      1187:           } ($allpathcond=~/(\d+|\(|\)|\&|\|)/g);
1.26      www      1188:        }
                   1189:     }
                   1190:     return $result;
1.28      www      1191: }
                   1192: 
                   1193: # --------------------------------------------------------- Value of a Variable
                   1194: 
1.58      www      1195: sub EXT {
1.48      www      1196:     my $varname=shift;
                   1197:     my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
                   1198:     my $rest;
                   1199:     if ($therest[0]) {
                   1200:        $rest=join('.',@therest);
                   1201:     } else {
                   1202:        $rest='';
                   1203:     }
1.57      www      1204:     my $qualifierrest=$qualifier;
                   1205:     if ($rest) { $qualifierrest.='.'.$rest; }
                   1206:     my $spacequalifierrest=$space;
                   1207:     if ($qualifierrest) { $spacequalifierrest.='.'.$qualifierrest; }
1.28      www      1208:     if ($realm eq 'user') {
1.48      www      1209: # --------------------------------------------------------------- user.resource
                   1210: 	if ($space eq 'resource') {
1.57      www      1211: 	    my %restored=&restore;
                   1212:             return $restored{$qualifierrest};
1.48      www      1213: # ----------------------------------------------------------------- user.access
                   1214:         } elsif ($space eq 'access') {
                   1215:             return &allowed($qualifier,$rest);
                   1216: # ------------------------------------------ user.preferences, user.environment
                   1217:         } elsif (($space eq 'preferences') || ($space eq 'environment')) {
1.57      www      1218:             return $ENV{join('.',('environment',$qualifierrest))};
1.48      www      1219: # ----------------------------------------------------------------- user.course
                   1220:         } elsif ($space eq 'course') {
                   1221:             return $ENV{join('.',('request.course',$qualifier))};
                   1222: # ------------------------------------------------------------------- user.role
                   1223:         } elsif ($space eq 'role') {
                   1224:             my ($role,$where)=split(/\./,$ENV{'request.role'});
                   1225:             if ($qualifier eq 'value') {
                   1226: 		return $role;
                   1227:             } elsif ($qualifier eq 'extent') {
                   1228:                 return $where;
                   1229:             }
                   1230: # ----------------------------------------------------------------- user.domain
                   1231:         } elsif ($space eq 'domain') {
                   1232:             return $ENV{'user.domain'};
                   1233: # ------------------------------------------------------------------- user.name
                   1234:         } elsif ($space eq 'name') {
                   1235:             return $ENV{'user.name'};
                   1236: # ---------------------------------------------------- Any other user namespace
1.29      www      1237:         } else {
1.48      www      1238:             my $item=($rest)?$qualifier.'.'.$rest:$qualifier;
                   1239:             my %reply=&get($space,$item);
                   1240:             return $reply{$item};
                   1241:         }
                   1242:     } elsif ($realm eq 'request') {
                   1243: # ------------------------------------------------------------- request.browser
                   1244:         if ($space eq 'browser') {
                   1245: 	    return $ENV{'browser.'.$qualifier};
1.57      www      1246: # ------------------------------------------------------------ request.filename
                   1247:         } else {
                   1248:             return $ENV{'request.'.$spacequalifierrest};
1.29      www      1249:         }
1.28      www      1250:     } elsif ($realm eq 'course') {
1.48      www      1251: # ---------------------------------------------------------- course.description
1.57      www      1252:         my $section='';
                   1253:         if ($ENV{'request.course.sec'}) {
                   1254: 	    $section='_'.$ENV{'request.course.sec'};
1.48      www      1255:         }
1.57      www      1256:         return $ENV{'course.'.$ENV{'request.course.id'}.$section.'.'.
                   1257:                               $spacequalifierrest};
                   1258:     } elsif ($realm eq 'resource') {
1.60      www      1259:       if ($ENV{'request.course.id'}) {
                   1260: # ----------------------------------------------------- Cascading lookup scheme
1.65      www      1261:        my $symbparm=&symbread().'.'.$spacequalifierrest;
1.60      www      1262:        my $reslevel=
1.65      www      1263: 	    $ENV{'request.course.id'}.'.'.$symbparm;
1.60      www      1264:        my $seclevel=
                   1265:             $ENV{'request.course.id'}.'.'.
                   1266: 		$ENV{'request.course.sec'}.'.'.$spacequalifierrest;
                   1267:        my $courselevel=
                   1268:             $ENV{'request.course.id'}.'.'.$spacequalifierrest;
                   1269: 
                   1270: # ----------------------------------------------------------- first, check user
1.63      www      1271:       my %resourcedata=get('resourcedata',($reslevel,$seclevel,$courselevel));
                   1272:       if ($resourcedata{$reslevel}!~/^error\:/) {
1.60      www      1273:        if ($resourcedata{$reslevel}) { return $resourcedata{$reslevel}; }
                   1274:        if ($resourcedata{$seclevel}) { return $resourcedata{$seclevel}; }
                   1275:        if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; }
1.63      www      1276:       }
1.60      www      1277: # -------------------------------------------------------- second, check course
                   1278:         my $section='';
                   1279:         if ($ENV{'request.course.sec'}) {
                   1280: 	    $section='_'.$ENV{'request.course.sec'};
                   1281:         }
                   1282:         my $reply=&reply('get:'.
                   1283:               $ENV{'course.'.$ENV{'request.course.id'}.$section.'.domain'}.':'.
                   1284:               $ENV{'course.'.$ENV{'request.course.id'}.$section.'.num'}.
                   1285:               ':resourcedata:'.
                   1286:               escape($reslevel).':'.escape($seclevel).':'.escape($courselevel),
                   1287: 		   $ENV{'course.'.$ENV{'request.course.id'}.$section.'.home'});
1.63      www      1288:       if ($reply!~/^error\:/) {
1.60      www      1289:         map {
                   1290:            my ($name,$value)=split(/\=/,$_);
                   1291:            $resourcedata{unescape($name)}=unescape($value);  
                   1292:         } split(/\&/,$reply);
                   1293:        if ($resourcedata{$reslevel}) { return $resourcedata{$reslevel}; }
1.63      www      1294:        if ($resourcedata{$seclevel}) { return $resourcedata{$seclevel}; }  
1.60      www      1295:        if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; }
1.63      www      1296:       }
1.60      www      1297: 
                   1298: # ------------------------------------------------------ third, check map parms
1.65      www      1299:        my %parmhash=();
                   1300:        my $thisparm='';       
                   1301:        if (tie(%parmhash,'GDBM_File',
                   1302:           $ENV{'request.course.fn'}.'_parms.db',&GDBM_READER,0640)) {
                   1303:            $thisparm=$parmhash{$symbparm};
                   1304: 	   untie(%parmhash);
1.60      www      1305:        }
1.65      www      1306:        if ($thisparm) { return $thisparm; }
1.60      www      1307:      }
                   1308:      
                   1309: # --------------------------------------------- last, look in resource metadata
1.57      www      1310: 	my $uri=&declutter($ENV{'request.filename'});
                   1311:         my $filename=$perlvar{'lonDocRoot'}.'/res/'.$ENV.'.meta';
                   1312:         if (-e $filename) {
                   1313:             my @content;
                   1314:             {
                   1315:              my $fh=Apache::File->new($filename);
                   1316:              @content=<$fh>;
                   1317:             }
                   1318:             if (join('',@content)=~
                   1319:                  /\<$space[^\>]*\>([^\<]*)\<\/$space\>/) {
                   1320: 	        return $1;
1.60      www      1321:  	    }
                   1322:         }
1.48      www      1323: # ---------------------------------------------------- Any other user namespace
                   1324:     } elsif ($realm eq 'environment') {
                   1325: # ----------------------------------------------------------------- environment
1.57      www      1326:         return $ENV{$spacequalifierrest};
1.28      www      1327:     } elsif ($realm eq 'system') {
1.48      www      1328: # ----------------------------------------------------------------- system.time
                   1329: 	if ($space eq 'time') {
                   1330: 	    return time;
                   1331:         }
1.28      www      1332:     }
1.48      www      1333:     return '';
1.61      www      1334: }
                   1335: 
1.31      www      1336: # ------------------------------------------------- Update symbolic store links
                   1337: 
                   1338: sub symblist {
                   1339:     my ($mapname,%newhash)=@_;
                   1340:     $mapname=declutter($mapname);
                   1341:     my %hash;
                   1342:     if (($ENV{'request.course.fn'}) && (%newhash)) {
                   1343:         if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
                   1344:                       &GDBM_WRCREAT,0640)) {
                   1345: 	    map {
                   1346:                 $hash{declutter($_)}=$mapname.'___'.$newhash{$_};
                   1347:             } keys %newhash;
                   1348:             if (untie(%hash)) {
                   1349: 		return 'ok';
                   1350:             }
                   1351:         }
                   1352:     }
                   1353:     return 'error';
                   1354: }
                   1355: 
                   1356: # ------------------------------------------------------ Return symb list entry
                   1357: 
                   1358: sub symbread {
1.44      www      1359:     my $thisfn=shift;
                   1360:     unless ($thisfn) {
                   1361: 	$thisfn=$ENV{'request.filename'};
                   1362:     }
                   1363:     $thisfn=declutter($thisfn);
1.31      www      1364:     my %hash;
1.37      www      1365:     my %bighash;
                   1366:     my $syval='';
1.45      www      1367:     if (($ENV{'request.course.fn'}) && ($thisfn)) {
1.31      www      1368:         if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
                   1369:                       &GDBM_READER,0640)) {
                   1370: 	    $syval=$hash{$thisfn};
1.37      www      1371:             untie(%hash);
                   1372:         }
                   1373: # ---------------------------------------------------------- There was an entry
                   1374:         if ($syval) {
                   1375:            unless ($syval=~/\_\d+$/) {
                   1376: 	       unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) {
1.44      www      1377:                   &appenv('request.ambiguous' => $thisfn);
1.37      www      1378:                   return '';
                   1379:                }    
                   1380:                $syval.=$1;
                   1381: 	   }
                   1382:         } else {
                   1383: # ------------------------------------------------------- Was not in symb table
                   1384:            if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
                   1385:                             &GDBM_READER,0640)) {
                   1386: # ---------------------------------------------- Get ID(s) for current resource
                   1387:               my $ids=$bighash{'ids_/res/'.$thisfn};
1.65      www      1388:               unless ($ids) { 
                   1389:                  $ids=$bighash{'ids_/'.$thisfn};
                   1390:               }
1.37      www      1391:               if ($ids) {
                   1392: # ------------------------------------------------------------------- Has ID(s)
                   1393:                  my @possibilities=split(/\,/,$ids);
1.39      www      1394:                  if ($#possibilities==0) {
                   1395: # ----------------------------------------------- There is only one possibility
1.37      www      1396: 		     my ($mapid,$resid)=split(/\./,$ids);
                   1397:                      $syval=declutter($bighash{'map_id_'.$mapid}).'___'.$resid;
                   1398:                  } else {
1.39      www      1399: # ------------------------------------------ There is more than one possibility
                   1400:                      my $realpossible=0;
                   1401:                      map {
                   1402: 			 my $file=$bighash{'src_'.$_};
                   1403:                          if (&allowed('bre',$file)) {
                   1404:          		    my ($mapid,$resid)=split(/\./,$_);
                   1405:                             if ($bighash{'map_type_'.$mapid} ne 'page') {
                   1406: 				$realpossible++;
                   1407:                                 $syval=declutter($bighash{'map_id_'.$mapid}).
                   1408:                                        '___'.$resid;
                   1409:                             }
                   1410: 			 }
                   1411:                      } @possibilities;
                   1412: 		     if ($realpossible!=1) { $syval=''; }
1.37      www      1413:                  }
                   1414: 	      }
                   1415:               untie(%bighash)
                   1416:            } 
1.31      www      1417:         }
1.62      www      1418:         if ($syval) {
                   1419:            return $syval.'___'.$thisfn; 
                   1420:         }
1.31      www      1421:     }
1.44      www      1422:     &appenv('request.ambiguous' => $thisfn);
1.31      www      1423:     return '';
                   1424: }
                   1425: 
                   1426: # ---------------------------------------------------------- Return random seed
                   1427: 
1.32      www      1428: sub numval {
                   1429:     my $txt=shift;
                   1430:     $txt=~tr/A-J/0-9/;
                   1431:     $txt=~tr/a-j/0-9/;
                   1432:     $txt=~tr/K-T/0-9/;
                   1433:     $txt=~tr/k-t/0-9/;
                   1434:     $txt=~tr/U-Z/0-5/;
                   1435:     $txt=~tr/u-z/0-5/;
                   1436:     $txt=~s/\D//g;
                   1437:     return int($txt);
                   1438: }    
                   1439: 
1.31      www      1440: sub rndseed {
                   1441:     my $symb;
1.44      www      1442:     unless ($symb=&symbread()) { return time; }
1.32      www      1443:     my $symbchck=unpack("%32C*",$symb);
                   1444:     my $symbseed=numval($symb)%$symbchck;
                   1445:     my $namechck=unpack("%32C*",$ENV{'user.name'});
                   1446:     my $nameseed=numval($ENV{'user.name'})%$namechck;
                   1447:     return int( $symbseed
                   1448: 	       .$nameseed
                   1449:                .unpack("%32C*",$ENV{'user.domain'})
1.33      www      1450:                .unpack("%32C*",$ENV{'request.course.id'})
1.32      www      1451:                .$namechck
                   1452:                .$symbchck);
1.36      albertel 1453: }
                   1454: 
                   1455: # ------------------------------------------------------------ Serves up a file
                   1456: # returns either the contents of the file or a -1
                   1457: sub getfile {
                   1458:   my $file=shift;
1.37      www      1459:   &repcopy($file);
1.36      albertel 1460:   if (! -e $file ) { return -1; };
                   1461:   my $fh=Apache::File->new($file);
                   1462:   my $a='';
                   1463:   while (<$fh>) { $a .=$_; }
                   1464:   return $a
                   1465: }
                   1466: 
                   1467: sub filelocation {
                   1468:   my ($dir,$file) = @_;
                   1469:   my $location;
                   1470:   $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces
1.59      albertel 1471:   if ($file=~m:^/~:) { # is a contruction space reference
                   1472:     $location = $file;
                   1473:     $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
1.36      albertel 1474:   } else {
1.59      albertel 1475:     $file=~s/^$perlvar{'lonDocRoot'}//;
                   1476:     $file=~s:^/*res::;
                   1477:     if ( !( $file =~ m:^/:) ) {
                   1478:       $location = $dir. '/'.$file;
                   1479:     } else {
                   1480:       $location = '/home/httpd/html/res'.$file;
                   1481:     }
1.36      albertel 1482:   }
                   1483:   $location=~s://+:/:g; # remove duplicate /
1.46      www      1484:   while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..
                   1485:   return $location;
                   1486: }
1.36      albertel 1487: 
1.46      www      1488: sub hreflocation {
                   1489:     my ($dir,$file)=@_;
                   1490:     unless (($_=~/^http:\/\//i) || ($_=~/^\//)) {
                   1491:        my $finalpath=filelocation($dir,$file);
                   1492:        $finalpath=~s/^\/home\/httpd\/html//;
                   1493:        return $finalpath;
                   1494:     } else {
                   1495:        return $file;
                   1496:     }
1.31      www      1497: }
                   1498: 
                   1499: # ------------------------------------------------------------- Declutters URLs
                   1500: 
                   1501: sub declutter {
                   1502:     my $thisfn=shift;
                   1503:     $thisfn=~s/^$perlvar{'lonDocRoot'}//;
                   1504:     $thisfn=~s/^\///;
                   1505:     $thisfn=~s/^res\///;
                   1506:     return $thisfn;
1.12      www      1507: }
                   1508: 
                   1509: # -------------------------------------------------------- Escape Special Chars
                   1510: 
                   1511: sub escape {
                   1512:     my $str=shift;
                   1513:     $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
                   1514:     return $str;
                   1515: }
                   1516: 
                   1517: # ----------------------------------------------------- Un-Escape Special Chars
                   1518: 
                   1519: sub unescape {
                   1520:     my $str=shift;
                   1521:     $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
                   1522:     return $str;
                   1523: }
1.11      www      1524: 
1.1       albertel 1525: # ================================================================ Main Program
                   1526: 
                   1527: sub BEGIN {
                   1528: if ($readit ne 'done') {
                   1529: # ------------------------------------------------------------ Read access.conf
                   1530: {
                   1531:     my $config=Apache::File->new("/etc/httpd/conf/access.conf");
                   1532: 
                   1533:     while (my $configline=<$config>) {
                   1534:         if ($configline =~ /PerlSetVar/) {
                   1535: 	   my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
1.8       www      1536:            chomp($varvalue);
1.1       albertel 1537:            $perlvar{$varname}=$varvalue;
                   1538:         }
                   1539:     }
                   1540: }
                   1541: 
                   1542: # ------------------------------------------------------------- Read hosts file
                   1543: {
                   1544:     my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab");
                   1545: 
                   1546:     while (my $configline=<$config>) {
                   1547:        my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
                   1548:        $hostname{$id}=$name;
                   1549:        $hostdom{$id}=$domain;
                   1550:        if ($role eq 'library') { $libserv{$id}=$name; }
                   1551:     }
                   1552: }
                   1553: 
                   1554: # ------------------------------------------------------ Read spare server file
                   1555: {
                   1556:     my $config=Apache::File->new("$perlvar{'lonTabDir'}/spare.tab");
                   1557: 
                   1558:     while (my $configline=<$config>) {
                   1559:        chomp($configline);
                   1560:        if (($configline) && ($configline ne $perlvar{'lonHostID'})) {
                   1561:           $spareid{$configline}=1;
                   1562:        }
                   1563:     }
                   1564: }
1.11      www      1565: # ------------------------------------------------------------ Read permissions
                   1566: {
                   1567:     my $config=Apache::File->new("$perlvar{'lonTabDir'}/roles.tab");
                   1568: 
                   1569:     while (my $configline=<$config>) {
                   1570:        chomp($configline);
                   1571:        my ($role,$perm)=split(/ /,$configline);
                   1572:        if ($perm ne '') { $pr{$role}=$perm; }
                   1573:     }
                   1574: }
                   1575: 
                   1576: # -------------------------------------------- Read plain texts for permissions
                   1577: {
                   1578:     my $config=Apache::File->new("$perlvar{'lonTabDir'}/rolesplain.tab");
                   1579: 
                   1580:     while (my $configline=<$config>) {
                   1581:        chomp($configline);
                   1582:        my ($short,$plain)=split(/:/,$configline);
                   1583:        if ($plain ne '') { $prp{$short}=$plain; }
1.25      www      1584:     }
                   1585: }
                   1586: 
                   1587: # ------------------------------------------------------------- Read file types
                   1588: {
                   1589:     my $config=Apache::File->new("$perlvar{'lonTabDir'}/filetypes.tab");
                   1590: 
                   1591:     while (my $configline=<$config>) {
                   1592:        chomp($configline);
                   1593:        my ($ending,$emb,@descr)=split(/\s+/,$configline);
                   1594:        if ($descr[0] ne '') { 
                   1595:          $fe{$ending}=$emb;
                   1596:          $fd{$ending}=join(' ',@descr);
                   1597:        }
1.11      www      1598:     }
                   1599: }
                   1600: 
1.22      www      1601: 
1.1       albertel 1602: $readit='done';
1.12      www      1603: &logthis('<font color=yellow>INFO: Read configuration</font>');
1.1       albertel 1604: }
                   1605: }
                   1606: 1;

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