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

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

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