loncom/lonnet/perl/lonnet.pm - view

File: [LON-CAPA] / loncom / lonnet / perl / lonnet.pm
Revision 1.242: download - view: text, annotated - select for diffs
Mon Jun 24 14:16:58 2002 UTC (21 years, 11 months ago) by www
Branches: MAIN
CVS tags: HEAD

Toward bug 305: &symbread now recognizes "mapalias" names and returns symb.

Also, if &symbread is handed a symb, it verifies the symb and returns it
"cleaned" if okay.

In effect, &symbread can now be handed symbs, URLs, and aliases, and should
return a cleaned verified symb in any of those cases.

# The LearningOnline Network # TCP networking package # # $Id: lonnet.pm,v 1.242 2002/06/24 14:16:58 www Exp $ # # Copyright Michigan State University Board of Trustees # # This file is part of the LearningOnline Network with CAPA (LON-CAPA). # # LON-CAPA is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # LON-CAPA is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with LON-CAPA; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA # # /home/httpd/html/adm/gpl.txt # # http://www.lon-capa.org/ # # 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30, # 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19, # 11/8,11/16,11/18,11/22,11/23,12/22, # 01/06,01/13,02/24,02/28,02/29, # 03/01,03/02,03/06,03/07,03/13, # 04/05,05/29,05/31,06/01, # 06/05,06/26 Gerd Kortemeyer # 06/26 Ben Tyszka # 06/30,07/15,07/17,07/18,07/20,07/21,07/22,07/25 Gerd Kortemeyer # 08/14 Ben Tyszka # 08/22,08/28,08/31,09/01,09/02,09/04,09/05,09/25,09/28,09/30 Gerd Kortemeyer # 10/04 Gerd Kortemeyer # 10/04 Guy Albertelli # 10/06,10/09,10/10,10/11,10/14,10/20,10/23,10/25,10/26,10/27,10/28,10/29, # 10/30,10/31, # 11/2,11/14,11/15,11/16,11/20,11/21,11/22,11/25,11/27, # 12/02,12/12,12/13,12/14,12/28,12/29 Gerd Kortemeyer # 05/01/01 Guy Albertelli # 05/01,06/01,09/01 Gerd Kortemeyer # 09/01 Guy Albertelli # 09/01,10/01,11/01 Gerd Kortemeyer # YEAR=2001 # 02/27/01 Scott Harrison # 3/2 Gerd Kortemeyer # 3/15,3/19 Scott Harrison # 3/19,3/20 Gerd Kortemeyer # 3/22,3/27,4/2,4/16,4/17 Scott Harrison # 5/26,5/28 Gerd Kortemeyer # 5/30 H. K. Ng # 6/1 Gerd Kortemeyer # July Guy Albertelli # 8/4,8/7,8/8,8/9,8/11,8/16,8/17,8/18,8/20,8/23,9/20,9/21,9/26, # 10/2 Gerd Kortemeyer # 10/5,10/10,11/13,11/15 Scott Harrison # 11/17,11/20,11/22,11/29 Gerd Kortemeyer # 12/5 Matthew Hall # 12/5 Guy Albertelli # 12/6,12/7,12/12 Gerd Kortemeyer # 12/18 Scott Harrison # 12/21,12/22,12/27,12/28 Gerd Kortemeyer # YEAR=2002 # 1/4,2/4,2/7 Gerd Kortemeyer # ### package Apache::lonnet; use strict; use Apache::File; use LWP::UserAgent(); use HTTP::Headers; use vars qw(%perlvar %hostname %homecache %badServerCache %hostip %spareid %hostdom %libserv %pr %prp %metacache %packagetab %courselogs %accesshash $processmarker $dumpcount %coursedombuf %coursehombuf %courseresdatacache); use IO::Socket; use GDBM_File; use Apache::Constants qw(:common :http); use HTML::LCParser; use Fcntl qw(:flock); my $readit; # --------------------------------------------------------------------- Logging sub logtouch { my $execdir=$perlvar{'lonDaemons'}; unless (-e "$execdir/logs/lonnet.log") { my $fh=Apache::File->new(">>$execdir/logs/lonnet.log"); close $fh; } my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3]; chown($wwwuid,$wwwgid,$execdir.'/logs/lonnet.log'); } sub logthis { my $message=shift; my $execdir=$perlvar{'lonDaemons'}; my $now=time; my $local=localtime($now); my $fh=Apache::File->new(">>$execdir/logs/lonnet.log"); print $fh "$local ($$): $message\n"; return 1; } sub logperm { my $message=shift; my $execdir=$perlvar{'lonDaemons'}; my $now=time; my $local=localtime($now); my $fh=Apache::File->new(">>$execdir/logs/lonnet.perm.log"); print $fh "$now:$message:$local\n"; return 1; } # -------------------------------------------------- Non-critical communication sub subreply { my ($cmd,$server)=@_; my $peerfile="$perlvar{'lonSockDir'}/$server"; my $client=IO::Socket::UNIX->new(Peer =>"$peerfile", Type => SOCK_STREAM, Timeout => 10) or return "con_lost"; print $client "$cmd\n"; my $answer=<$client>; if (!$answer) { $answer="con_lost"; } chomp($answer); return $answer; } sub reply { my ($cmd,$server)=@_; unless (defined($hostname{$server})) { return 'no_such_host'; } my $answer=subreply($cmd,$server); if ($answer eq 'con_lost') { #sleep 5; #$answer=subreply($cmd,$server); #if ($answer eq 'con_lost') { # &logthis("Second attempt con_lost on $server"); # my $peerfile="$perlvar{'lonSockDir'}/$server"; # my $client=IO::Socket::UNIX->new(Peer =>"$peerfile", # Type => SOCK_STREAM, # Timeout => 10) # or return "con_lost"; # &logthis("Killing socket"); # print $client "close_connection_exit\n"; #sleep 5; # $answer=subreply($cmd,$server); #} } if (($answer=~/^refused/) || ($answer=~/^rejected/)) { &logthis("WARNING:". " $cmd to $server returned $answer"); } return $answer; } # ----------------------------------------------------------- Send USR1 to lonc sub reconlonc { my $peerfile=shift; &logthis("Trying to reconnect for $peerfile"); my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid"; if (my $fh=Apache::File->new("$loncfile")) { my $loncpid=<$fh>; chomp($loncpid); if (kill 0 => $loncpid) { &logthis("lonc at pid $loncpid responding, sending USR1"); kill USR1 => $loncpid; sleep 1; if (-e "$peerfile") { return; } &logthis("$peerfile still not there, give it another try"); sleep 5; if (-e "$peerfile") { return; } &logthis( "WARNING: $peerfile still not there, giving up"); } else { &logthis( "WARNING:". " lonc at pid $loncpid not responding, giving up"); } } else { &logthis('WARNING: lonc not running, giving up'); } } # ------------------------------------------------------ Critical communication sub critical { my ($cmd,$server)=@_; unless ($hostname{$server}) { &logthis("WARNING:". " Critical message to unknown server ($server)"); return 'no_such_host'; } my $answer=reply($cmd,$server); if ($answer eq 'con_lost') { my $pingreply=reply('ping',$server); &reconlonc("$perlvar{'lonSockDir'}/$server"); my $pongreply=reply('pong',$server); &logthis("Ping/Pong for $server: $pingreply/$pongreply"); $answer=reply($cmd,$server); if ($answer eq 'con_lost') { my $now=time; my $middlename=$cmd; $middlename=substr($middlename,0,16); $middlename=~s/\W//g; my $dfilename= "$perlvar{'lonSockDir'}/delayed/$now.$middlename.$server"; { my $dfh; if ($dfh=Apache::File->new(">$dfilename")) { print $dfh "$cmd\n"; } } sleep 2; my $wcmd=''; { my $dfh; if ($dfh=Apache::File->new("$dfilename")) { $wcmd=<$dfh>; } } chomp($wcmd); if ($wcmd eq $cmd) { &logthis("WARNING: ". "Connection buffer $dfilename: $cmd"); &logperm("D:$server:$cmd"); return 'con_delayed'; } else { &logthis("CRITICAL:" ." Critical connection failed: $server $cmd"); &logperm("F:$server:$cmd"); return 'con_failed'; } } } return $answer; } # ---------------------------------------------------------- Append Environment sub appenv { my %newenv=@_; foreach (keys %newenv) { if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) { &logthis("WARNING: ". "Attempt to modify environment ".$_." to ".$newenv{$_} .''); delete($newenv{$_}); } else { $ENV{$_}=$newenv{$_}; } } my $lockfh; unless ($lockfh=Apache::File->new("$ENV{'user.environment'}")) { return 'error: '.$!; } unless (flock($lockfh,LOCK_EX)) { &logthis("WARNING: ". 'Could not obtain exclusive lock in appenv: '.$!); $lockfh->close(); return 'error: '.$!; } my @oldenv; { my $fh; unless ($fh=Apache::File->new("$ENV{'user.environment'}")) { return 'error: '.$!; } @oldenv=<$fh>; $fh->close(); } for (my $i=0; $i<=$#oldenv; $i++) { chomp($oldenv[$i]); if ($oldenv[$i] ne '') { my ($name,$value)=split(/=/,$oldenv[$i]); unless (defined($newenv{$name})) { $newenv{$name}=$value; } } } { my $fh; unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) { return 'error'; } my $newname; foreach $newname (keys %newenv) { print $fh "$newname=$newenv{$newname}\n"; } $fh->close(); } $lockfh->close(); return 'ok'; } # ----------------------------------------------------- Delete from Environment sub delenv { my $delthis=shift; my %newenv=(); if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) { &logthis("WARNING: ". "Attempt to delete from environment ".$delthis); return 'error'; } my @oldenv; { my $fh; unless ($fh=Apache::File->new("$ENV{'user.environment'}")) { return 'error'; } unless (flock($fh,LOCK_SH)) { &logthis("WARNING: ". 'Could not obtain shared lock in delenv: '.$!); $fh->close(); return 'error: '.$!; } @oldenv=<$fh>; $fh->close(); } { my $fh; unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) { return 'error'; } unless (flock($fh,LOCK_EX)) { &logthis("WARNING: ". 'Could not obtain exclusive lock in delenv: '.$!); $fh->close(); return 'error: '.$!; } foreach (@oldenv) { unless ($_=~/^$delthis/) { print $fh $_; } } $fh->close(); } return 'ok'; } # ------------------------------ Find server with least workload from spare.tab sub spareserver { my $tryserver; my $spareserver=''; my $lowestserver=100; foreach $tryserver (keys %spareid) { my $answer=reply('load',$tryserver); if (($answer =~ /\d/) && ($answer<$lowestserver)) { $spareserver="http://$hostname{$tryserver}"; $lowestserver=$answer; } } return $spareserver; } # --------------------------------------------- Try to change a user's password sub changepass { my ($uname,$udom,$currentpass,$newpass,$server)=@_; $currentpass = &escape($currentpass); $newpass = &escape($newpass); my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass", $server); if (! $answer) { &logthis("No reply on password change request to $server ". "by $uname in domain $udom."); } elsif ($answer =~ "^ok") { &logthis("$uname in $udom successfully changed their password ". "on $server."); } elsif ($answer =~ "^pwchange_failure") { &logthis("$uname in $udom was unable to change their password ". "on $server. The action was blocked by either lcpasswd ". "or pwchange"); } elsif ($answer =~ "^non_authorized") { &logthis("$uname in $udom did not get their password correct when ". "attempting to change it on $server."); } elsif ($answer =~ "^auth_mode_error") { &logthis("$uname in $udom attempted to change their password despite ". "not being locally or internally authenticated on $server."); } elsif ($answer =~ "^unknown_user") { &logthis("$uname in $udom attempted to change their password ". "on $server but were unable to because $server is not ". "their home server."); } elsif ($answer =~ "^refused") { &logthis("$server refused to change $uname in $udom password because ". "it was sent an unencrypted request to change the password."); } return $answer; } # ----------------------- Try to determine user's current authentication scheme sub queryauthenticate { my ($uname,$udom)=@_; if (($perlvar{'lonRole'} eq 'library') && ($udom eq $perlvar{'lonDefDomain'})) { my $answer=reply("encrypt:currentauth:$udom:$uname", $perlvar{'lonHostID'}); unless ($answer eq 'unknown_user' or $answer eq 'refused') { if (length($answer)) { return $answer; } else { &logthis("User $uname at $udom lacks an authentication mechanism"); return 'no_host'; } } } my $tryserver; foreach $tryserver (keys %libserv) { if ($hostdom{$tryserver} eq $udom) { my $answer=reply("encrypt:currentauth:$udom:$uname",$tryserver); unless ($answer eq 'unknown_user' or $answer eq 'refused') { if (length($answer)) { return $answer; } else { &logthis("User $uname at $udom lacks an authentication mechanism"); return 'no_host'; } } } } &logthis("User $uname at $udom lacks an authentication mechanism"); return 'no_host'; } # --------- Try to authenticate user from domain's lib servers (first this one) sub authenticate { my ($uname,$upass,$udom)=@_; $upass=escape($upass); $uname=~s/\W//g; if (($perlvar{'lonRole'} eq 'library') && ($udom eq $perlvar{'lonDefDomain'})) { my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'}); if ($answer =~ /authorized/) { if ($answer eq 'authorized') { &logthis("User $uname at $udom authorized by local server"); return $perlvar{'lonHostID'}; } if ($answer eq 'non_authorized') { &logthis("User $uname at $udom rejected by local server"); return 'no_host'; } } } my $tryserver; foreach $tryserver (keys %libserv) { if ($hostdom{$tryserver} eq $udom) { my $answer=reply("encrypt:auth:$udom:$uname:$upass",$tryserver); if ($answer =~ /authorized/) { if ($answer eq 'authorized') { &logthis("User $uname at $udom authorized by $tryserver"); return $tryserver; } if ($answer eq 'non_authorized') { &logthis("User $uname at $udom rejected by $tryserver"); return 'no_host'; } } } } &logthis("User $uname at $udom could not be authenticated"); return 'no_host'; } # ---------------------- Find the homebase for a user from domain's lib servers sub homeserver { my ($uname,$udom,$ignoreBadCache)=@_; my $index="$uname:$udom"; if ($homecache{$index}) { return "$homecache{$index}"; } my $tryserver; foreach $tryserver (keys %libserv) { next if ($ignoreBadCache ne 'true' && exists($badServerCache{$tryserver})); if ($hostdom{$tryserver} eq $udom) { my $answer=reply("home:$udom:$uname",$tryserver); if ($answer eq 'found') { $homecache{$index}=$tryserver; return $tryserver; } elsif ($answer eq 'no_host') { $badServerCache{$tryserver}=1; } } } return 'no_host'; } # ------------------------------------- Find the usernames behind a list of IDs sub idget { my ($udom,@ids)=@_; my %returnhash=(); my $tryserver; foreach $tryserver (keys %libserv) { if ($hostdom{$tryserver} eq $udom) { my $idlist=join('&',@ids); $idlist=~tr/A-Z/a-z/; my $reply=&reply("idget:$udom:".$idlist,$tryserver); my @answer=(); if (($reply ne 'con_lost') && ($reply!~/^error\:/)) { @answer=split(/\&/,$reply); } ; my $i; for ($i=0;$i<=$#ids;$i++) { if ($answer[$i]) { $returnhash{$ids[$i]}=$answer[$i]; } } } } return %returnhash; } # ------------------------------------- Find the IDs behind a list of usernames sub idrget { my ($udom,@unames)=@_; my %returnhash=(); foreach (@unames) { $returnhash{$_}=(&userenvironment($udom,$_,'id'))[1]; } return %returnhash; } # ------------------------------- Store away a list of names and associated IDs sub idput { my ($udom,%ids)=@_; my %servers=(); foreach (keys %ids) { my $uhom=&homeserver($_,$udom); if ($uhom ne 'no_host') { my $id=&escape($ids{$_}); $id=~tr/A-Z/a-z/; my $unam=&escape($_); if ($servers{$uhom}) { $servers{$uhom}.='&'.$id.'='.$unam; } else { $servers{$uhom}=$id.'='.$unam; } &critical('put:'.$udom.':'.$unam.':environment:id='.$id,$uhom); } } foreach (keys %servers) { &critical('idput:'.$udom.':'.$servers{$_},$_); } } # ------------------------------------- Find the section of student in a course sub usection { my ($udom,$unam,$courseid)=@_; $courseid=~s/\_/\//g; $courseid=~s/^(\w)/\/$1/; foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles', &homeserver($unam,$udom)))) { my ($key,$value)=split(/\=/,$_); $key=&unescape($key); if ($key=~/^$courseid(?:\/)*(\w+)*\_st$/) { my $section=$1; if ($key eq $courseid.'_st') { $section=''; } my ($dummy,$end,$start)=split(/\_/,&unescape($value)); my $now=time; my $notactive=0; if ($start) { if ($now<$start) { $notactive=1; } } if ($end) { if ($now>$end) { $notactive=1; } } unless ($notactive) { return $section; } } } return '-1'; } # ------------------------------------- Read an entry from a user's environment sub userenvironment { my ($udom,$unam,@what)=@_; my %returnhash=(); my @answer=split(/\&/, &reply('get:'.$udom.':'.$unam.':environment:'.join('&',@what), &homeserver($unam,$udom))); my $i; for ($i=0;$i<=$#what;$i++) { $returnhash{$what[$i]}=&unescape($answer[$i]); } return %returnhash; } # ----------------------------- Subscribe to a resource, return URL if possible sub subscribe { my $fname=shift; my $author=$fname; $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; my ($udom,$uname)=split(/\//,$author); my $home=homeserver($uname,$udom); if (($home eq 'no_host') || ($home eq $perlvar{'lonHostID'})) { return 'not_found'; } my $answer=reply("sub:$fname",$home); if (($answer eq 'con_lost') || ($answer eq 'rejected')) { $answer.=' by '.$home; } return $answer; } # -------------------------------------------------------------- Replicate file sub repcopy { my $filename=shift; $filename=~s/\/+/\//g; if ($filename=~/^\/home\/httpd\/html\/adm\//) { return OK; } my $transname="$filename.in.transfer"; if ((-e $filename) || (-e $transname)) { return OK; } my $remoteurl=subscribe($filename); if ($remoteurl =~ /^con_lost by/) { &logthis("Subscribe returned $remoteurl: $filename"); return HTTP_SERVICE_UNAVAILABLE; } elsif ($remoteurl eq 'not_found') { &logthis("Subscribe returned not_found: $filename"); return HTTP_NOT_FOUND; } elsif ($remoteurl =~ /^rejected by/) { &logthis("Subscribe returned $remoteurl: $filename"); return FORBIDDEN; } elsif ($remoteurl eq 'directory') { return OK; } else { my @parts=split(/\//,$filename); my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]"; if ($path ne "$perlvar{'lonDocRoot'}/res") { &logthis("Malconfiguration for replication: $filename"); return HTTP_BAD_REQUEST; } my $count; for ($count=5;$count<$#parts;$count++) { $path.="/$parts[$count]"; if ((-e $path)!=1) { mkdir($path,0777); } } my $ua=new LWP::UserAgent; my $request=new HTTP::Request('GET',"$remoteurl"); my $response=$ua->request($request,$transname); if ($response->is_error()) { unlink($transname); my $message=$response->status_line; &logthis("WARNING:" ." LWP get: $message: $filename"); return HTTP_SERVICE_UNAVAILABLE; } else { if ($remoteurl!~/\.meta$/) { my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta'); my $mresponse=$ua->request($mrequest,$filename.'.meta'); if ($mresponse->is_error()) { unlink($filename.'.meta'); &logthis( "INFO: No metadata: $filename"); } } rename($transname,$filename); return OK; } } } # --------------------------------------------------------- Server Side Include sub ssi { my ($fn,%form)=@_; my $ua=new LWP::UserAgent; my $request; if (%form) { $request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn); $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form)); } else { $request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn); } $request->header(Cookie => $ENV{'HTTP_COOKIE'}); my $response=$ua->request($request); return $response->content; } # ------------------------------------------------------------------------- Log sub log { my ($dom,$nam,$hom,$what)=@_; return critical("log:$dom:$nam:$what",$hom); } # ------------------------------------------------------------------ Course Log sub flushcourselogs { &logthis('Flushing course log buffers'); foreach (keys %courselogs) { my $crsid=$_; if (&reply('log:'.$coursedombuf{$crsid}.':'. &escape($courselogs{$crsid}), $coursehombuf{$crsid}) eq 'ok') { delete $courselogs{$crsid}; } else { &logthis('Failed to flush log buffer for '.$crsid); if (length($courselogs{$crsid})>40000) { &logthis("WARNING: Buffer for ".$crsid. " exceeded maximum size, deleting."); delete $courselogs{$crsid}; } } } &logthis('Flushing access logs'); foreach (keys %accesshash) { my $entry=$_; $entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/; my %temphash=($entry => $accesshash{$entry}); if (&Apache::lonnet::put('resevaldata',\%temphash,$1,$2) eq 'ok') { delete $accesshash{$entry}; } } $dumpcount++; } sub courselog { my $what=shift; $what=time.':'.$what; unless ($ENV{'request.course.id'}) { return ''; } $coursedombuf{$ENV{'request.course.id'}}= $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'. $ENV{'course.'.$ENV{'request.course.id'}.'.num'}; $coursehombuf{$ENV{'request.course.id'}}= $ENV{'course.'.$ENV{'request.course.id'}.'.home'}; if (defined $courselogs{$ENV{'request.course.id'}}) { $courselogs{$ENV{'request.course.id'}}.='&'.$what; } else { $courselogs{$ENV{'request.course.id'}}.=$what; } if (length($courselogs{$ENV{'request.course.id'}})>4048) { &flushcourselogs(); } } sub courseacclog { my $fnsymb=shift; unless ($ENV{'request.course.id'}) { return ''; } my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'}; if ($fnsymb=~/(problem|exam|quiz|assess|survey|form)$/) { $what.=':POST'; foreach (keys %ENV) { if ($_=~/^form\.(.*)/) { $what.=':'.$1.'='.$ENV{$_}; } } } &courselog($what); } sub countacc { my $url=&declutter(shift); unless ($ENV{'request.course.id'}) { return ''; } $accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1; my $key=$processmarker.'_'.$dumpcount.'___'.$url.'___count'; if (defined($accesshash{$key})) { $accesshash{$key}++; } else { $accesshash{$key}=1; } } # ----------------------------------------------------------- Check out an item sub checkout { my ($symb,$tuname,$tudom,$tcrsid)=@_; my $now=time; my $lonhost=$perlvar{'lonHostID'}; my $infostr=&escape( 'CHECKOUTTOKEN&'. $tuname.'&'. $tudom.'&'. $tcrsid.'&'. $symb.'&'. $now.'&'.$ENV{'REMOTE_ADDR'}); my $token=&reply('tmpput:'.$infostr,$lonhost); if ($token=~/^error\:/) { &logthis("WARNING: ". "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb. ""); return ''; } $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/; $token=~tr/a-z/A-Z/; my %infohash=('resource.0.outtoken' => $token, 'resource.0.checkouttime' => $now, 'resource.0.outremote' => $ENV{'REMOTE_ADDR'}); unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') { return ''; } else { &logthis("WARNING: ". "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb. ""); } if (&log($tudom,$tuname,&homeserver($tuname,$tudom), &escape('Checkout '.$infostr.' - '. $token)) ne 'ok') { return ''; } else { &logthis("WARNING: ". "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb. ""); } return $token; } # ------------------------------------------------------------ Check in an item sub checkin { my $token=shift; my $now=time; my ($ta,$tb,$lonhost)=split(/\*/,$token); $lonhost=~tr/A-Z/a-z/; my $dtoken=$ta.'_'.$hostip{$lonhost}.'_'.$tb; $dtoken=~s/\W/\_/g; my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)= split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost))); unless (($tuname) && ($tudom)) { &logthis('Check in '.$token.' ('.$dtoken.') failed'); return ''; } unless (&allowed('mgr',$tcrsid)) { &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '. $ENV{'user.name'}.' - '.$ENV{'user.domain'}); return ''; } my %infohash=('resource.0.intoken' => $token, 'resource.0.checkintime' => $now, 'resource.0.inremote' => $ENV{'REMOTE_ADDR'}); unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') { return ''; } if (&log($tudom,$tuname,&homeserver($tuname,$tudom), &escape('Checkin - '.$token)) ne 'ok') { return ''; } return ($symb,$tuname,$tudom,$tcrsid); } # --------------------------------------------- Set Expire Date for Spreadsheet sub expirespread { my ($uname,$udom,$stype,$usymb)=@_; my $cid=$ENV{'request.course.id'}; if ($cid) { my $now=time; my $key=$uname.':'.$udom.':'.$stype.':'.$usymb; return &reply('put:'.$ENV{'course.'.$cid.'.domain'}.':'. $ENV{'course.'.$cid.'.num'}. ':nohist_expirationdates:'. &escape($key).'='.$now, $ENV{'course.'.$cid.'.home'}) } return 'ok'; } # ----------------------------------------------------- Devalidate Spreadsheets sub devalidate { my $symb=shift; my $cid=$ENV{'request.course.id'}; if ($cid) { my $key=$ENV{'user.name'}.':'.$ENV{'user.domain'}.':'; my $status= &del('nohist_calculatedsheet', [$key.'studentcalc'], $ENV{'course.'.$cid.'.domain'}, $ENV{'course.'.$cid.'.num'}) .' '. &del('nohist_calculatedsheets_'.$cid, [$key.'assesscalc:'.$symb]); unless ($status eq 'ok ok') { &logthis('Could not devalidate spreadsheet '. $ENV{'user.name'}.' at '.$ENV{'user.domain'}.' for '. $symb.': '.$status); } } } sub arrayref2str { my ($arrayref) = @_; my $result='_ARRAY_REF__'; foreach my $elem (@$arrayref) { if (ref($elem) eq 'ARRAY') { $result.=&escape(&arrayref2str($elem)).'&'; } elsif (ref($elem) eq 'HASH') { $result.=&escape(&hashref2str($elem)).'&'; } elsif (ref($elem)) { &logthis("Got a ref of ".(ref($elem))." skipping."); } else { $result.=&escape($elem).'&'; } } $result=~s/\&$//; return $result; } sub hash2str { my (%hash) = @_; my $result=&hashref2str(\%hash); $result=~s/^_HASH_REF__//; return $result; } sub hashref2str { my ($hashref)=@_; my $result='_HASH_REF__'; foreach (keys(%$hashref)) { if (ref($_) eq 'ARRAY') { $result.=&escape(&arrayref2str($_)).'='; } elsif (ref($_) eq 'HASH') { $result.=&escape(&hashref2str($_)).'='; } elsif (ref($_)) { &logthis("Got a ref of ".(ref($_))." skipping."); } else { $result.=&escape($_).'='; } if (ref($$hashref{$_}) eq 'ARRAY') { $result.=&escape(&arrayref2str($$hashref{$_})).'&'; } elsif (ref($$hashref{$_}) eq 'HASH') { $result.=&escape(&hashref2str($$hashref{$_})).'&'; } elsif (ref($$hashref{$_})) { &logthis("Got a ref of ".(ref($$hashref{$_}))." skipping."); } else { $result.=&escape($$hashref{$_}).'&'; } } $result=~s/\&$//; return $result; } sub str2hash { my ($string) = @_; my %returnhash; foreach (split(/\&/,$string)) { my ($name,$value)=split(/\=/,$_); $name=&unescape($name); $value=&unescape($value); if ($value =~ /^_HASH_REF__/) { $value =~ s/^_HASH_REF__//; my %hash=&str2hash($value); $value=\%hash; } elsif ($value =~ /^_ARRAY_REF__/) { $value =~ s/^_ARRAY_REF__//; my @array=&str2array($value); $value=\@array; } $returnhash{$name}=$value; } return (%returnhash); } sub str2array { my ($string) = @_; my @returnarray; foreach my $value (split(/\&/,$string)) { $value=&unescape($value); if ($value =~ /^_HASH_REF__/) { $value =~ s/^_HASH_REF__//; my %hash=&str2hash($value); $value=\%hash; } elsif ($value =~ /^_ARRAY_REF__/) { $value =~ s/^_ARRAY_REF__//; my @array=&str2array($value); $value=\@array; } push(@returnarray,$value); } return (@returnarray); } # -------------------------------------------------------------------Temp Store sub tmpreset { my ($symb,$namespace,$domain,$stuname) = @_; if (!$symb) { $symb=&symbread(); if (!$symb) { $symb= $ENV{'REQUEST_URI'}; } } $symb=escape($symb); if (!$namespace) { $namespace=$ENV{'request.state'}; } $namespace=~s/\//\_/g; $namespace=~s/\W//g; #FIXME needs to do something for /pub resources if (!$domain) { $domain=$ENV{'user.domain'}; } if (!$stuname) { $stuname=$ENV{'user.name'}; } my $path=$perlvar{'lonDaemons'}.'/tmp'; my %hash; if (tie(%hash,'GDBM_File', $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', &GDBM_WRCREAT,0640)) { foreach my $key (keys %hash) { if ($key=~ /:$symb/) { delete($hash{$key}); } } } } sub tmpstore { my ($storehash,$symb,$namespace,$domain,$stuname) = @_; if (!$symb) { $symb=&symbread(); if (!$symb) { $symb= $ENV{'request.url'}; } } $symb=escape($symb); if (!$namespace) { # I don't think we would ever want to store this for a course. # it seems this will only be used if we don't have a course. #$namespace=$ENV{'request.course.id'}; #if (!$namespace) { $namespace=$ENV{'request.state'}; #} } $namespace=~s/\//\_/g; $namespace=~s/\W//g; #FIXME needs to do something for /pub resources if (!$domain) { $domain=$ENV{'user.domain'}; } if (!$stuname) { $stuname=$ENV{'user.name'}; } my $now=time; my %hash; my $path=$perlvar{'lonDaemons'}.'/tmp'; if (tie(%hash,'GDBM_File', $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', &GDBM_WRCREAT,0640)) { $hash{"version:$symb"}++; my $version=$hash{"version:$symb"}; my $allkeys=''; foreach my $key (keys(%$storehash)) { $allkeys.=$key.':'; $hash{"$version:$symb:$key"}=$$storehash{$key}; } $hash{"$version:$symb:timestamp"}=$now; $allkeys.='timestamp'; $hash{"$version:keys:$symb"}=$allkeys; if (untie(%hash)) { return 'ok'; } else { return "error:$!"; } } else { return "error:$!"; } } # -----------------------------------------------------------------Temp Restore sub tmprestore { my ($symb,$namespace,$domain,$stuname) = @_; if (!$symb) { $symb=&symbread(); if (!$symb) { $symb= $ENV{'request.url'}; } } $symb=escape($symb); if (!$namespace) { $namespace=$ENV{'request.state'}; } #FIXME needs to do something for /pub resources if (!$domain) { $domain=$ENV{'user.domain'}; } if (!$stuname) { $stuname=$ENV{'user.name'}; } my %returnhash; $namespace=~s/\//\_/g; $namespace=~s/\W//g; my %hash; my $path=$perlvar{'lonDaemons'}.'/tmp'; if (tie(%hash,'GDBM_File', $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', &GDBM_READER,0640)) { my $version=$hash{"version:$symb"}; $returnhash{'version'}=$version; my $scope; for ($scope=1;$scope<=$version;$scope++) { my $vkeys=$hash{"$scope:keys:$symb"}; my @keys=split(/:/,$vkeys); my $key; $returnhash{"$scope:keys"}=$vkeys; foreach $key (@keys) { $returnhash{"$scope:$key"}=$hash{"$scope:$symb:$key"}; $returnhash{"$key"}=$hash{"$scope:$symb:$key"}; } } if (!(untie(%hash))) { return "error:$!"; } } else { return "error:$!"; } return %returnhash; } # ----------------------------------------------------------------------- Store sub store { my ($storehash,$symb,$namespace,$domain,$stuname) = @_; my $home=''; if ($stuname) { $home=&homeserver($stuname,$domain); } $symb=&symbclean($symb); if (!$symb) { unless ($symb=&symbread()) { return ''; } } &devalidate($symb); $symb=escape($symb); if (!$namespace) { unless ($namespace=$ENV{'request.course.id'}) { return ''; } } if (!$domain) { $domain=$ENV{'user.domain'}; } if (!$stuname) { $stuname=$ENV{'user.name'}; } if (!$home) { $home=$ENV{'user.home'}; } my $namevalue=''; foreach (keys %$storehash) { $namevalue.=escape($_).'='.escape($$storehash{$_}).'&'; } $namevalue=~s/\&$//; &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue); return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home"); } # -------------------------------------------------------------- Critical Store sub cstore { my ($storehash,$symb,$namespace,$domain,$stuname) = @_; my $home=''; if ($stuname) { $home=&homeserver($stuname,$domain); } $symb=&symbclean($symb); if (!$symb) { unless ($symb=&symbread()) { return ''; } } &devalidate($symb); $symb=escape($symb); if (!$namespace) { unless ($namespace=$ENV{'request.course.id'}) { return ''; } } if (!$domain) { $domain=$ENV{'user.domain'}; } if (!$stuname) { $stuname=$ENV{'user.name'}; } if (!$home) { $home=$ENV{'user.home'}; } my $namevalue=''; foreach (keys %$storehash) { $namevalue.=escape($_).'='.escape($$storehash{$_}).'&'; } $namevalue=~s/\&$//; &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue); return critical ("store:$domain:$stuname:$namespace:$symb:$namevalue","$home"); } # --------------------------------------------------------------------- Restore sub restore { my ($symb,$namespace,$domain,$stuname) = @_; my $home=''; if ($stuname) { $home=&homeserver($stuname,$domain); } if (!$symb) { unless ($symb=escape(&symbread())) { return ''; } } else { $symb=&escape(&symbclean($symb)); } if (!$namespace) { unless ($namespace=$ENV{'request.course.id'}) { return ''; } } if (!$domain) { $domain=$ENV{'user.domain'}; } if (!$stuname) { $stuname=$ENV{'user.name'}; } if (!$home) { $home=$ENV{'user.home'}; } my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home"); my %returnhash=(); foreach (split(/\&/,$answer)) { my ($name,$value)=split(/\=/,$_); $returnhash{&unescape($name)}=&unescape($value); } my $version; for ($version=1;$version<=$returnhash{'version'};$version++) { foreach (split(/\:/,$returnhash{$version.':keys'})) { $returnhash{$_}=$returnhash{$version.':'.$_}; } } return %returnhash; } # ---------------------------------------------------------- Course Description sub coursedescription { my $courseid=shift; $courseid=~s/^\///; $courseid=~s/\_/\//g; my ($cdomain,$cnum)=split(/\//,$courseid); my $chome=&homeserver($cnum,$cdomain); if ($chome ne 'no_host') { my %returnhash=&dump('environment',$cdomain,$cnum); if (!exists($returnhash{'con_lost'})) { my $normalid=$cdomain.'_'.$cnum; my %envhash=(); $returnhash{'home'}= $chome; $returnhash{'domain'} = $cdomain; $returnhash{'num'} = $cnum; while (my ($name,$value) = each %returnhash) { $envhash{'course.'.$normalid.'.'.$name}=$value; } $returnhash{'url'}='/res/'.declutter($returnhash{'url'}); $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'. $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum; $envhash{'course.'.$normalid.'.last_cache'}=time; $envhash{'course.'.$normalid.'.home'}=$chome; $envhash{'course.'.$normalid.'.domain'}=$cdomain; $envhash{'course.'.$normalid.'.num'}=$cnum; &appenv(%envhash); return %returnhash; } } return (); } # -------------------------------------------------------- Get user privileges sub rolesinit { my ($domain,$username,$authhost)=@_; my $rolesdump=reply("dump:$domain:$username:roles",$authhost); if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; } my %allroles=(); my %thesepriv=(); my $now=time; my $userroles="user.login.time=$now\n"; my $thesestr; if ($rolesdump ne '') { foreach (split(/&/,$rolesdump)) { if ($_!~/^rolesdef\&/) { my ($area,$role)=split(/=/,$_); $area=~s/\_\w\w$//; my ($trole,$tend,$tstart)=split(/_/,$role); $userroles.='user.role.'.$trole.'.'.$area.'='. $tstart.'.'.$tend."\n"; if ($tend!=0) { if ($tend<$now) { $trole=''; } } if ($tstart!=0) { if ($tstart>$now) { $trole=''; } } if (($area ne '') && ($trole ne '')) { my $spec=$trole.'.'.$area; my ($tdummy,$tdomain,$trest)=split(/\//,$area); if ($trole =~ /^cr\//) { my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole); my $homsvr=homeserver($rauthor,$rdomain); if ($hostname{$homsvr} ne '') { my $roledef= reply("get:$rdomain:$rauthor:roles:rolesdef_$rrole", $homsvr); if (($roledef ne 'con_lost') && ($roledef ne '')) { my ($syspriv,$dompriv,$coursepriv)= split(/\_/,unescape($roledef)); $allroles{'cm./'}.=':'.$syspriv; $allroles{$spec.'./'}.=':'.$syspriv; if ($tdomain ne '') { $allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv; $allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv; if ($trest ne '') { $allroles{'cm.'.$area}.=':'.$coursepriv; $allroles{$spec.'.'.$area}.=':'.$coursepriv; } } } } } else { $allroles{'cm./'}.=':'.$pr{$trole.':s'}; $allroles{$spec.'./'}.=':'.$pr{$trole.':s'}; if ($tdomain ne '') { $allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'}; $allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'}; if ($trest ne '') { $allroles{'cm.'.$area}.=':'.$pr{$trole.':c'}; $allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'}; } } } } } } my $adv=0; my $author=0; foreach (keys %allroles) { %thesepriv=(); if (($_!~/^st/) && ($_!~/^ta/) && ($_!~/^cm/)) { $adv=1; } if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; } foreach (split(/:/,$allroles{$_})) { if ($_ ne '') { my ($privilege,$restrictions)=split(/&/,$_); if ($restrictions eq '') { $thesepriv{$privilege}='F'; } else { if ($thesepriv{$privilege} ne 'F') { $thesepriv{$privilege}.=$restrictions; } } } } $thesestr=''; foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } $userroles.='user.priv.'.$_.'='.$thesestr."\n"; } $userroles.='user.adv='.$adv."\n". 'user.author='.$author."\n"; $ENV{'user.adv'}=$adv; } return $userroles; } # --------------------------------------------------------------- get interface sub get { my ($namespace,$storearr,$udomain,$uname)=@_; my $items=''; foreach (@$storearr) { $items.=escape($_).'&'; } $items=~s/\&$//; if (!$udomain) { $udomain=$ENV{'user.domain'}; } if (!$uname) { $uname=$ENV{'user.name'}; } my $uhome=&homeserver($uname,$udomain); my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome); my @pairs=split(/\&/,$rep); my %returnhash=(); my $i=0; foreach (@$storearr) { $returnhash{$_}=unescape($pairs[$i]); $i++; } return %returnhash; } # --------------------------------------------------------------- del interface sub del { my ($namespace,$storearr,$udomain,$uname)=@_; my $items=''; foreach (@$storearr) { $items.=escape($_).'&'; } $items=~s/\&$//; if (!$udomain) { $udomain=$ENV{'user.domain'}; } if (!$uname) { $uname=$ENV{'user.name'}; } my $uhome=&homeserver($uname,$udomain); return &reply("del:$udomain:$uname:$namespace:$items",$uhome); } # -------------------------------------------------------------- dump interface sub dump { my ($namespace,$udomain,$uname,$regexp)=@_; if (!$udomain) { $udomain=$ENV{'user.domain'}; } if (!$uname) { $uname=$ENV{'user.name'}; } my $uhome=&homeserver($uname,$udomain); if ($regexp) { $regexp=&escape($regexp); } else { $regexp='.'; } my $rep=reply("dump:$udomain:$uname:$namespace:$regexp",$uhome); my @pairs=split(/\&/,$rep); my %returnhash=(); foreach (@pairs) { my ($key,$value)=split(/=/,$_); $returnhash{unescape($key)}=unescape($value); } return %returnhash; } # --------------------------------------------------------------- put interface sub put { my ($namespace,$storehash,$udomain,$uname)=@_; if (!$udomain) { $udomain=$ENV{'user.domain'}; } if (!$uname) { $uname=$ENV{'user.name'}; } my $uhome=&homeserver($uname,$udomain); my $items=''; foreach (keys %$storehash) { $items.=&escape($_).'='.&escape($$storehash{$_}).'&'; } $items=~s/\&$//; return &reply("put:$udomain:$uname:$namespace:$items",$uhome); } # ------------------------------------------------------ critical put interface sub cput { my ($namespace,$storehash,$udomain,$uname)=@_; if (!$udomain) { $udomain=$ENV{'user.domain'}; } if (!$uname) { $uname=$ENV{'user.name'}; } my $uhome=&homeserver($uname,$udomain); my $items=''; foreach (keys %$storehash) { $items.=escape($_).'='.escape($$storehash{$_}).'&'; } $items=~s/\&$//; return &critical("put:$udomain:$uname:$namespace:$items",$uhome); } # -------------------------------------------------------------- eget interface sub eget { my ($namespace,$storearr,$udomain,$uname)=@_; my $items=''; foreach (@$storearr) { $items.=escape($_).'&'; } $items=~s/\&$//; if (!$udomain) { $udomain=$ENV{'user.domain'}; } if (!$uname) { $uname=$ENV{'user.name'}; } my $uhome=&homeserver($uname,$udomain); my $rep=&reply("eget:$udomain:$uname:$namespace:$items",$uhome); my @pairs=split(/\&/,$rep); my %returnhash=(); my $i=0; foreach (@$storearr) { $returnhash{$_}=unescape($pairs[$i]); $i++; } return %returnhash; } # ------------------------------------------------- Check for a user privilege sub allowed { my ($priv,$uri)=@_; my $orguri=$uri; $uri=&declutter($uri); # Free bre access to adm and meta resources if ((($uri=~/^adm\//) || ($uri=~/\.meta$/)) && ($priv eq 'bre')) { return 'F'; } # Free bre to public access if ($priv eq 'bre') { my $copyright=&metadata($uri,'copyright'); if ($copyright eq 'public') { return 'F'; } if ($copyright eq 'priv') { $uri=~/([^\/]+)\/([^\/]+)\//; unless (($ENV{'user.name'} eq $2) && ($ENV{'user.domain'} eq $1)) { return ''; } } if ($copyright eq 'domain') { $uri=~/([^\/]+)\/([^\/]+)\//; unless (($ENV{'user.domain'} eq $1) || ($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $1)) { return ''; } } } my $thisallowed=''; my $statecond=0; my $courseprivid=''; # Course if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'}=~/$priv\&([^\:]*)/) { $thisallowed.=$1; } # Domain if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.(split(/\//,$uri))[0].'/'} =~/$priv\&([^\:]*)/) { $thisallowed.=$1; } # Course: uri itself is a course my $courseuri=$uri; $courseuri=~s/\_(\d)/\/$1/; $courseuri=~s/^([^\/])/\/$1/; if ($ENV{'user.priv.'.$ENV{'request.role'}.'.'.$courseuri} =~/$priv\&([^\:]*)/) { $thisallowed.=$1; } # Full access at system, domain or course-wide level? Exit. if ($thisallowed=~/F/) { return 'F'; } # If this is generating or modifying users, exit with special codes if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:$priv\:/) { return $thisallowed; } # # Gathered so far: system, domain and course wide privileges # # Course: See if uri or referer is an individual resource that is part of # the course if ($ENV{'request.course.id'}) { $courseprivid=$ENV{'request.course.id'}; if ($ENV{'request.course.sec'}) { $courseprivid.='/'.$ENV{'request.course.sec'}; } $courseprivid=~s/\_/\//; my $checkreferer=1; my ($match,$cond)=&is_on_map($uri); if ($match) { $statecond=$cond; if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} =~/$priv\&([^\:]*)/) { $thisallowed.=$1; $checkreferer=0; } } if ($checkreferer) { my $refuri=$ENV{'httpref.'.$orguri}; unless ($refuri) { foreach (keys %ENV) { if ($_=~/^httpref\..*\*/) { my $pattern=$_; $pattern=~s/^httpref\.\/res\///; $pattern=~s/\*/\[\^\/\]\+/g; $pattern=~s/\//\\\//g; if ($orguri=~/$pattern/) { $refuri=$ENV{$_}; } } } } if ($refuri) { $refuri=&declutter($refuri); my ($match,$cond)=&is_on_map($refuri); if ($match) { my $refstatecond=$cond; if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} =~/$priv\&([^\:]*)/) { $thisallowed.=$1; $uri=$refuri; $statecond=$refstatecond; } } } } } # # Gathered now: all privileges that could apply, and condition number # # # Full or no access? # if ($thisallowed=~/F/) { return 'F'; } unless ($thisallowed) { return ''; } # Restrictions exist, deal with them # # C:according to course preferences # R:according to resource settings # L:unless locked # X:according to user session state # # Possibly locked functionality, check all courses # Locks might take effect only after 10 minutes cache expiration for other # courses, and 2 minutes for current course my $envkey; if ($thisallowed=~/L/) { foreach $envkey (keys %ENV) { if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) { my $courseid=$2; my $roleid=$1.'.'.$2; $courseid=~s/^\///; my $expiretime=600; if ($ENV{'request.role'} eq $roleid) { $expiretime=120; } my ($cdom,$cnum,$csec)=split(/\//,$courseid); my $prefix='course.'.$cdom.'_'.$cnum.'.'; if ((time-$ENV{$prefix.'last_cache'})>$expiretime) { &coursedescription($courseid); } if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,$csec\,/) || ($ENV{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) { if ($ENV{$prefix.'res.'.$uri.'.lock.expire'}>time) { &log($ENV{'user.domain'},$ENV{'user.name'}, $ENV{'user.home'}, 'Locked by res: '.$priv.' for '.$uri.' due to '. $cdom.'/'.$cnum.'/'.$csec.' expire '. $ENV{$prefix.'priv.'.$priv.'.lock.expire'}); return ''; } } if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,$csec\,/) || ($ENV{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) { if ($ENV{'priv.'.$priv.'.lock.expire'}>time) { &log($ENV{'user.domain'},$ENV{'user.name'}, $ENV{'user.home'}, 'Locked by priv: '.$priv.' for '.$uri.' due to '. $cdom.'/'.$cnum.'/'.$csec.' expire '. $ENV{$prefix.'priv.'.$priv.'.lock.expire'}); return ''; } } } } } # # Rest of the restrictions depend on selected course # unless ($ENV{'request.course.id'}) { return '1'; } # # Now user is definitely in a course # # Course preferences if ($thisallowed=~/C/) { my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; my $unamedom=$ENV{'user.name'}.':'.$ENV{'user.domain'}; if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'} =~/$rolecode/) { &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. $ENV{'request.course.id'}); return ''; } if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.users.denied'} =~/$unamedom/) { &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '. $ENV{'request.course.id'}); return ''; } } # Resource preferences if ($thisallowed=~/R/) { my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; my $filename=$perlvar{'lonDocRoot'}.'/res/'.$uri.'.meta'; if (-e $filename) { my @content; { my $fh=Apache::File->new($filename); @content=<$fh>; } if (join('',@content)=~ /\<roledeny[^\>]*\>[^\<]*$rolecode[^\<]*\<\/roledeny\>/) { &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); return ''; } } } # Restricted by state? if ($thisallowed=~/X/) { if (&condval($statecond)) { return '2'; } else { return ''; } } return 'F'; } # --------------------------------------------------- Is a resource on the map? sub is_on_map { my $uri=&declutter(shift); my @uriparts=split(/\//,$uri); my $filename=$uriparts[$#uriparts]; my $pathname=$uri; $pathname=~s/\/$filename$//; my $match=($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ /\&$filename\:([\d\|]+)\&/); if ($match) { return (1,$1); } else { return (0,0); } } # ----------------------------------------------------------------- Define Role sub definerole { if (allowed('mcr','/')) { my ($rolename,$sysrole,$domrole,$courole)=@_; foreach (split('/',$sysrole)) { my ($crole,$cqual)=split(/\&/,$_); if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; } if ($pr{'cr:s'}=~/$crole\&/) { if ($pr{'cr:s'}!~/$crole\&\w*$cqual/) { return "refused:s:$crole&$cqual"; } } } foreach (split('/',$domrole)) { my ($crole,$cqual)=split(/\&/,$_); if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; } if ($pr{'cr:d'}=~/$crole\&/) { if ($pr{'cr:d'}!~/$crole\&\w*$cqual/) { return "refused:d:$crole&$cqual"; } } } foreach (split('/',$courole)) { my ($crole,$cqual)=split(/\&/,$_); if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; } if ($pr{'cr:c'}=~/$crole\&/) { if ($pr{'cr:c'}!~/$crole\&\w*$cqual/) { return "refused:c:$crole&$cqual"; } } } my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:". "$ENV{'user.domain'}:$ENV{'user.name'}:". "rolesdef_$rolename=". escape($sysrole.'_'.$domrole.'_'.$courole); return reply($command,$ENV{'user.home'}); } else { return 'refused'; } } # ---------------- Make a metadata query against the network of library servers sub metadata_query { my ($query,$custom,$customshow)=@_; my %rhash; for my $server (keys %libserv) { unless ($custom or $customshow) { my $reply=&reply("querysend:".&escape($query),$server); $rhash{$server}=$reply; } else { my $reply=&reply("querysend:".&escape($query).':'. &escape($custom).':'.&escape($customshow), $server); $rhash{$server}=$reply; } } return \%rhash; } # ----------------------------------------- Send log queries and wait for reply sub log_query { my ($uname,$udom,$query,%filters)=@_; my $uhome=&homeserver($uname,$udom); if ($uhome eq 'no_host') { return 'error: no_host'; } my $uhost=$hostname{$uhome}; my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys %filters)); my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command, $uhome); unless ($queryid=~/^$uhost\_/) { return 'error: '.$queryid; } return get_query_reply($queryid); } sub get_query_reply { my $queryid=shift; my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid; my $reply=''; for (1..100) { sleep 2; if (-e $replyfile.'.end') { if (my $fh=Apache::File->new($replyfile)) { $reply.=<$fh>; $fh->close; } else { return 'error: reply_file_error'; } return &unescape($reply); } } return 'timeout:'.$queryid; } sub courselog_query { # # possible filters: # url: url or symb # username # domain # action: view, submit, grade # start: timestamp # end: timestamp # my (%filters)=@_; unless ($ENV{'request.course.id'}) { return 'no_course'; } if ($filters{'url'}) { $filters{'url'}=&symbclean(&declutter($filters{'url'})); $filters{'url'}=~s/\.(\w+)$/(\\.\\d+)*\\.$1/; $filters{'url'}=~s/\.(\w+)\_\_\_/(\\.\\d+)*\\.$1/; } my $cname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'}; my $cdom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}; return &log_query($cname,$cdom,'courselog',%filters); } sub userlog_query { my ($uname,$udom,%filters)=@_; return &log_query($uname,$udom,'userlog',%filters); } # ------------------------------------------------------------------ Plain Text sub plaintext { my $short=shift; return $prp{$short}; } # ----------------------------------------------------------------- Assign Role sub assignrole { my ($udom,$uname,$url,$role,$end,$start)=@_; my $mrole; if ($role =~ /^cr\//) { unless (&allowed('ccr',$url)) { &logthis('Refused custom assignrole: '. $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. $ENV{'user.name'}.' at '.$ENV{'user.domain'}); return 'refused'; } $mrole='cr'; } else { my $cwosec=$url; $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/; unless (&allowed('c'.$role,$cwosec)) { &logthis('Refused assignrole: '. $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. $ENV{'user.name'}.' at '.$ENV{'user.domain'}); return 'refused'; } $mrole=$role; } my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:". "$udom:$uname:$url".'_'."$mrole=$role"; if ($end) { $command.='_'.$end; } if ($start) { if ($end) { $command.='_'.$start; } else { $command.='_0_'.$start; } } return &reply($command,&homeserver($uname,$udom)); } # -------------------------------------------------- Modify user authentication # Overrides without validation sub modifyuserauth { my ($udom,$uname,$umode,$upass)=@_; my $uhome=&homeserver($uname,$udom); unless (&allowed('mau',$udom)) { return 'refused'; } &logthis('Call to modify user authentication '.$udom.', '.$uname.', '. $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}); my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'. &escape($upass),$uhome); &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'}, 'Authentication changed for '.$udom.', '.$uname.', '.$umode. '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply); &log($udom,,$uname,$uhome, 'Authentication changed by '.$ENV{'user.domain'}.', '. $ENV{'user.name'}.', '.$umode. '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply); unless ($reply eq 'ok') { &logthis('Authentication mode error: '.$reply); return 'error: '.$reply; } return 'ok'; } # --------------------------------------------------------------- Modify a user sub modifyuser { my ($udom, $uname, $uid, $umode, $upass, $first, $middle, $last, $gene, $forceid, $desiredhome)=@_; $udom=~s/\W//g; $uname=~s/\W//g; &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. $umode.', '.$first.', '.$middle.', '. $last.', '.$gene.'(forceid: '.$forceid.')'. (defined($desiredhome) ? ' desiredhome = '.$desiredhome : ' desiredhome not specified'). ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}); my $uhome=&homeserver($uname,$udom,'true'); # ----------------------------------------------------------------- Create User if (($uhome eq 'no_host') && ($umode) && ($upass)) { my $unhome=''; if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) { $unhome = $desiredhome; } elsif($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $udom) { $unhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'}; } else { # load balancing routine for determining $unhome my $tryserver; my $loadm=10000000; foreach $tryserver (keys %libserv) { if ($hostdom{$tryserver} eq $udom) { my $answer=reply('load',$tryserver); if (($answer=~/\d+/) && ($answer<$loadm)) { $loadm=$answer; $unhome=$tryserver; } } } } if (($unhome eq '') || ($unhome eq 'no_host')) { return 'error: unable to find a home server for '.$uname. ' in domain '.$udom; } my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':'.$umode.':'. &escape($upass),$unhome); unless ($reply eq 'ok') { return 'error: '.$reply; } $uhome=&homeserver($uname,$udom,'true'); if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) { return 'error: verify home'; } } # End of creation of new user # ---------------------------------------------------------------------- Add ID if ($uid) { $uid=~tr/A-Z/a-z/; my %uidhash=&idrget($udom,$uname); if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/) && (!$forceid)) { unless ($uid eq $uidhash{$uname}) { return 'error: mismatch '.$uidhash{$uname}.' versus '.$uid; } } else { &idput($udom,($uname => $uid)); } } # -------------------------------------------------------------- Add names, etc my %names=&get('environment', ['firstname','middlename','lastname','generation'], $udom,$uname); if ($names{'firstname'} =~ m/^error:.*/) { %names=(); } if ($first) { $names{'firstname'} = $first; } if ($middle) { $names{'middlename'} = $middle; } if ($last) { $names{'lastname'} = $last; } if ($gene) { $names{'generation'} = $gene; } my $reply = &put('environment', \%names, $udom,$uname); if ($reply ne 'ok') { return 'error: '.$reply; } &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '. $umode.', '.$first.', '.$middle.', '. $last.', '.$gene.' by '. $ENV{'user.name'}.' at '.$ENV{'user.domain'}); return 'ok'; } # -------------------------------------------------------------- Modify student sub modifystudent { my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, $end,$start,$forceid,$desiredhome)=@_; my $cid=''; unless ($cid=$ENV{'request.course.id'}) { return 'not_in_class'; } # --------------------------------------------------------------- Make the user my $reply=&modifyuser ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid, $desiredhome); unless ($reply eq 'ok') { return $reply; } my $uhome=&homeserver($uname,$udom); if (($uhome eq '') || ($uhome eq 'no_host')) { return 'error: no such user'; } # -------------------------------------------------- Add student to course list $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'. $ENV{'course.'.$cid.'.num'}.':classlist:'. &escape($uname.':'.$udom).'='. &escape($end.':'.$start), $ENV{'course.'.$cid.'.home'}); unless (($reply eq 'ok') || ($reply eq 'delayed')) { return 'error: '.$reply; } # ---------------------------------------------------- Add student role to user my $uurl='/'.$cid; $uurl=~s/\_/\//g; if ($usec) { $uurl.='/'.$usec; } return &assignrole($udom,$uname,$uurl,'st',$end,$start); } # ------------------------------------------------- Write to course preferences sub writecoursepref { my ($courseid,%prefs)=@_; $courseid=~s/^\///; $courseid=~s/\_/\//g; my ($cdomain,$cnum)=split(/\//,$courseid); my $chome=homeserver($cnum,$cdomain); if (($chome eq '') || ($chome eq 'no_host')) { return 'error: no such course'; } my $cstring=''; foreach (keys %prefs) { $cstring.=escape($_).'='.escape($prefs{$_}).'&'; } $cstring=~s/\&$//; return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome); } # ---------------------------------------------------------- Make/modify course sub createcourse { my ($udom,$description,$url)=@_; $url=&declutter($url); my $cid=''; unless (&allowed('ccc',$ENV{'user.domain'})) { return 'refused'; } unless ($udom eq $ENV{'user.domain'}) { return 'refused'; } # ------------------------------------------------------------------- Create ID my $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)). unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; # ----------------------------------------------- Make sure that does not exist my $uhome=&homeserver($uname,$udom,'true'); unless (($uhome eq '') || ($uhome eq 'no_host')) { $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)). unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; $uhome=&homeserver($uname,$udom,'true'); unless (($uhome eq '') || ($uhome eq 'no_host')) { return 'error: unable to generate unique course-ID'; } } # ------------------------------------------------------------- Make the course my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::', $ENV{'user.home'}); unless ($reply eq 'ok') { return 'error: '.$reply; } $uhome=&homeserver($uname,$udom,'true'); if (($uhome eq '') || ($uhome eq 'no_host')) { return 'error: no such course'; } &writecoursepref($udom.'_'.$uname, ('description' => $description, 'url' => $url)); return '/'.$udom.'/'.$uname; } # ---------------------------------------------------------- Assign Custom Role sub assigncustomrole { my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start)=@_; return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename, $end,$start); } # ----------------------------------------------------------------- Revoke Role sub revokerole { my ($udom,$uname,$url,$role)=@_; my $now=time; return &assignrole($udom,$uname,$url,$role,$now); } # ---------------------------------------------------------- Revoke Custom Role sub revokecustomrole { my ($udom,$uname,$url,$rdom,$rnam,$rolename)=@_; my $now=time; return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now); } # ------------------------------------------------------------ Directory lister sub dirlist { my $uri=shift; $uri=~s/^\///; $uri=~s/\/$//; my ($res,$udom,$uname,@rest)=split(/\//,$uri); if ($udom) { if ($uname) { my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/'.$uri, homeserver($uname,$udom)); return split(/:/,$listing); } else { my $tryserver; my %allusers=(); foreach $tryserver (keys %libserv) { if ($hostdom{$tryserver} eq $udom) { my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.$udom, $tryserver); if (($listing ne 'no_such_dir') && ($listing ne 'empty') && ($listing ne 'con_lost')) { foreach (split(/:/,$listing)) { my ($entry,@stat)=split(/&/,$_); $allusers{$entry}=1; } } } } my $alluserstr=''; foreach (sort keys %allusers) { $alluserstr.=$_.'&user:'; } $alluserstr=~s/:$//; return split(/:/,$alluserstr); } } else { my $tryserver; my %alldom=(); foreach $tryserver (keys %libserv) { $alldom{$hostdom{$tryserver}}=1; } my $alldomstr=''; foreach (sort keys %alldom) { $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:'; } $alldomstr=~s/:$//; return split(/:/,$alldomstr); } } # -------------------------------------------------------- Value of a Condition sub directcondval { my $number=shift; if ($ENV{'user.state.'.$ENV{'request.course.id'}}) { return substr($ENV{'user.state.'.$ENV{'request.course.id'}},$number,1); } else { return 2; } } sub condval { my $condidx=shift; my $result=0; my $allpathcond=''; foreach (split(/\|/,$condidx)) { if (defined($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_})) { $allpathcond.= '('.$ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_}.')|'; } } $allpathcond=~s/\|$//; if ($ENV{'request.course.id'}) { if ($allpathcond) { my $operand='|'; my @stack; foreach ($allpathcond=~/(\d+|$|$|\&|\|)/g) { if ($_ eq '(') { push @stack,($operand,$result) } elsif ($_ eq ')') { my $before=pop @stack; if (pop @stack eq '&') { $result=$result>$before?$before:$result; } else { $result=$result>$before?$result:$before; } } elsif (($_ eq '&') || ($_ eq '|')) { $operand=$_; } else { my $new=directcondval($_); if ($operand eq '&') { $result=$result>$new?$new:$result; } else { $result=$result>$new?$result:$new; } } } } } return $result; } # --------------------------------------------------- Course Resourcedata Query sub courseresdata { my ($coursenum,$coursedomain,@which)=@_; my $coursehom=&homeserver($coursenum,$coursedomain); my $hashid=$coursenum.':'.$coursedomain; unless (defined($courseresdatacache{$hashid.'.time'})) { unless (time-$courseresdatacache{$hashid.'.time'}<300) { my $coursehom=&homeserver($coursenum,$coursedomain); if ($coursehom) { my $dumpreply=&reply('dump:'.$coursedomain.':'.$coursenum. ':resourcedata:.',$coursehom); unless ($dumpreply=~/^error\:/) { $courseresdatacache{$hashid.'.time'}=time; $courseresdatacache{$hashid}=$dumpreply; } } } } my @pairs=split(/\&/,$courseresdatacache{$hashid}); my %returnhash=(); foreach (@pairs) { my ($key,$value)=split(/=/,$_); $returnhash{unescape($key)}=unescape($value); } my $item; foreach $item (@which) { if ($returnhash{$item}) { return $returnhash{$item}; } } return ''; } # --------------------------------------------------------- Value of a Variable sub EXT { my ($varname,$symbparm,$udom,$uname)=@_; unless ($varname) { return ''; } #get real user name/domain, courseid and symb my $courseid; if (!($uname && $udom)) { (my $cursymb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); if (!$symbparm) { $symbparm=$cursymb; } } else { $courseid=$ENV{'request.course.id'}; } my ($realm,$space,$qualifier,@therest)=split(/\./,$varname); my $rest; if ($therest[0]) { $rest=join('.',@therest); } else { $rest=''; } my $qualifierrest=$qualifier; if ($rest) { $qualifierrest.='.'.$rest; } my $spacequalifierrest=$space; if ($qualifierrest) { $spacequalifierrest.='.'.$qualifierrest; } if ($realm eq 'user') { # --------------------------------------------------------------- user.resource if ($space eq 'resource') { my %restored=&restore(undef,undef,$udom,$uname); return $restored{$qualifierrest}; # ----------------------------------------------------------------- user.access } elsif ($space eq 'access') { # FIXME - not supporting calls for a specific user return &allowed($qualifier,$rest); # ------------------------------------------ user.preferences, user.environment } elsif (($space eq 'preferences') || ($space eq 'environment')) { if (($uname eq $ENV{'user.name'}) && ($udom eq $ENV{'user.domain'})) { return $ENV{join('.',('environment',$qualifierrest))}; } else { my %returnhash=&userenvironment($udom,$uname,$qualifierrest); return $returnhash{$qualifierrest}; } # ----------------------------------------------------------------- user.course } elsif ($space eq 'course') { # FIXME - not supporting calls for a specific user return $ENV{join('.',('request.course',$qualifier))}; # ------------------------------------------------------------------- user.role } elsif ($space eq 'role') { # FIXME - not supporting calls for a specific user my ($role,$where)=split(/\./,$ENV{'request.role'}); if ($qualifier eq 'value') { return $role; } elsif ($qualifier eq 'extent') { return $where; } # ----------------------------------------------------------------- user.domain } elsif ($space eq 'domain') { return $udom; # ------------------------------------------------------------------- user.name } elsif ($space eq 'name') { return $uname; # ---------------------------------------------------- Any other user namespace } else { my $item=($rest)?$qualifier.'.'.$rest:$qualifier; my %reply=&get($space,[$item]); return $reply{$item}; } } elsif ($realm eq 'query') { # ---------------------------------------------- pull stuff out of query string &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},[$space]); return $ENV{'form.'.$space}; } elsif ($realm eq 'request') { # ------------------------------------------------------------- request.browser if ($space eq 'browser') { return $ENV{'browser.'.$qualifier}; # ------------------------------------------------------------ request.filename } else { return $ENV{'request.'.$spacequalifierrest}; } } elsif ($realm eq 'course') { # ---------------------------------------------------------- course.description return $ENV{'course.'.$courseid.'.'.$spacequalifierrest}; } elsif ($realm eq 'resource') { if ($courseid eq $ENV{'request.course.id'}) { #print ' '.$space.' - '.$qualifier.' - '.$spacequalifierrest; # ----------------------------------------------------- Cascading lookup scheme if (!$symbparm) { $symbparm=&symbread(); } my $symbp=$symbparm; my $mapp=(split(/\_\_\_/,$symbp))[0]; my $symbparm=$symbp.'.'.$spacequalifierrest; my $mapparm=$mapp.'___(all).'.$spacequalifierrest; my $section; if (($ENV{'user.name'} eq $uname) && ($ENV{'user.domain'} eq $udom)) { $section={'request.course.sec'}; } else { $section=&usection($udom,$uname,$courseid); } my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; my $seclevelr=$courseid.'.['.$section.'].'.$symbparm; my $seclevelm=$courseid.'.['.$section.'].'.$mapparm; my $courselevel=$courseid.'.'.$spacequalifierrest; my $courselevelr=$courseid.'.'.$symbparm; my $courselevelm=$courseid.'.'.$mapparm; # ----------------------------------------------------------- first, check user my %resourcedata=&get('resourcedata', [$courselevelr,$courselevelm,$courselevel], $udom,$uname); if (($resourcedata{$courselevelr}!~/^error\:/) && ($resourcedata{$courselevelr}!~/^con_lost/)) { if ($resourcedata{$courselevelr}) { return $resourcedata{$courselevelr}; } if ($resourcedata{$courselevelm}) { return $resourcedata{$courselevelm}; } if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; } } else { if ($resourcedata{$courselevelr}!~/No such file/) { &logthis("WARNING:". " Trying to get resource data for ". $uname." at ".$udom.": ". $resourcedata{$courselevelr}.""); } } # -------------------------------------------------------- second, check course my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'}, $ENV{'course.'.$courseid.'.domain'}, ($seclevelr,$seclevelm,$seclevel, $courselevelr,$courselevelm, $courselevel)); if ($coursereply) { return $coursereply; } # ------------------------------------------------------ third, check map parms my %parmhash=(); my $thisparm=''; if (tie(%parmhash,'GDBM_File', $ENV{'request.course.fn'}.'_parms.db', &GDBM_READER,0640)) { $thisparm=$parmhash{$symbparm}; untie(%parmhash); } if ($thisparm) { return $thisparm; } } # --------------------------------------------- last, look in resource metadata $spacequalifierrest=~s/\./\_/; my $metadata=&metadata($ENV{'request.filename'},$spacequalifierrest); if ($metadata) { return $metadata; } $metadata=&metadata($ENV{'request.filename'}, 'parameter_'.$spacequalifierrest); if ($metadata) { return $metadata; } # ------------------------------------------------------------------ Cascade up unless ($space eq '0') { my ($part,$id)=split(/\_/,$space); if ($id) { my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, $symbparm,$udom,$uname); if ($partgeneral) { return $partgeneral; } } else { my $resourcegeneral=&EXT('resource.0.'.$qualifierrest, $symbparm,$udom,$uname); if ($resourcegeneral) { return $resourcegeneral; } } } # ---------------------------------------------------- Any other user namespace } elsif ($realm eq 'environment') { # ----------------------------------------------------------------- environment if (($uname eq $ENV{'user.name'})&&($udom eq $ENV{'user.domain'})) { return $ENV{'environment.'.$spacequalifierrest}; } else { my %returnhash=&userenvironment($udom,$uname, $spacequalifierrest); return $returnhash{$spacequalifierrest}; } } elsif ($realm eq 'system') { # ----------------------------------------------------------------- system.time if ($space eq 'time') { return time; } } return ''; } # ---------------------------------------------------------------- Get metadata sub metadata { my ($uri,$what,$liburi,$prefix,$depthcount)=@_; $uri=&declutter($uri); my $filename=$uri; $uri=~s/\.meta$//; # # Is the metadata already cached? # Look at timestamp of caching # Everything is cached by the main uri, libraries are never directly cached # unless (abs($metacache{$uri.':cachedtimestamp'}-time)<600) { # # Is this a recursive call for a library? # if ($liburi) { $liburi=&declutter($liburi); $filename=$liburi; } my %metathesekeys=(); unless ($filename=~/\.meta$/) { $filename.='.meta'; } my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename); my $parser=HTML::LCParser->new(\$metastring); my $token; undef %metathesekeys; while ($token=$parser->get_token) { if ($token->[0] eq 'S') { if (defined($token->[2]->{'package'})) { # # This is a package - get package info # my $package=$token->[2]->{'package'}; my $keyroot=''; if ($prefix) { $keyroot.='_'.$prefix; } else { if (defined($token->[2]->{'part'})) { $keyroot.='_'.$token->[2]->{'part'}; } } if (defined($token->[2]->{'id'})) { $keyroot.='_'.$token->[2]->{'id'}; } if ($metacache{$uri.':packages'}) { $metacache{$uri.':packages'}.=','.$package.$keyroot; } else { $metacache{$uri.':packages'}=$package.$keyroot; } foreach (keys %packagetab) { if ($_=~/^$package\&/) { my ($pack,$name,$subp)=split(/\&/,$_); my $value=$packagetab{$_}; my $part=$keyroot; $part=~s/^\_//; if ($subp eq 'display') { $value.=' [Part: '.$part.']'; } my $unikey='parameter'.$keyroot.'_'.$name; $metathesekeys{$unikey}=1; $metacache{$uri.':'.$unikey.'.part'}=$part; unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) { $metacache{$uri.':'.$unikey.'.'.$subp}=$value; } } } } else { # # This is not a package - some other kind of start tag # my $entry=$token->[1]; my $unikey; if ($entry eq 'import') { $unikey=''; } else { $unikey=$entry; } if ($prefix) { $unikey.=$prefix; } else { if (defined($token->[2]->{'part'})) { $unikey.='_'.$token->[2]->{'part'}; } } if (defined($token->[2]->{'id'})) { $unikey.='_'.$token->[2]->{'id'}; } if ($entry eq 'import') { # # Importing a library here # if (defined($depthcount)) { $depthcount++; } else { $depthcount=0; } if ($depthcount<20) { foreach (split(/\,/,&metadata($uri,'keys', $parser->get_text('/import'),$unikey, $depthcount))) { $metathesekeys{$_}=1; } } } else { if (defined($token->[2]->{'name'})) { $unikey.='_'.$token->[2]->{'name'}; } $metathesekeys{$unikey}=1; foreach (@{$token->[3]}) { $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_}; } unless ( $metacache{$uri.':'.$unikey}=&HTML::Entities::decode($parser->get_text('/'.$entry)) ) { $metacache{$uri.':'.$unikey}= $metacache{$uri.':'.$unikey.'.default'}; } # end of not-a-package not-a-library import } # end of not-a-package start tag } # the next is the end of "start tag" } } $metacache{$uri.':keys'}=join(',',keys %metathesekeys); $metacache{$uri.':cachedtimestamp'}=time; # this is the end of "was not already recently cached } return $metacache{$uri.':'.$what}; } # ------------------------------------------------- Update symbolic store links sub symblist { my ($mapname,%newhash)=@_; $mapname=declutter($mapname); my %hash; if (($ENV{'request.course.fn'}) && (%newhash)) { if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', &GDBM_WRCREAT,0640)) { foreach (keys %newhash) { $hash{declutter($_)}=$mapname.'___'.$newhash{$_}; } if (untie(%hash)) { return 'ok'; } } } return 'error'; } # --------------------------------------------------------------- Verify a symb sub symbverify { my ($symb,$thisfn)=@_; $thisfn=&declutter($thisfn); # direct jump to resource in page or to a sequence - will construct own symbs if ($thisfn=~/\.(page|sequence)$/) { return 1; } # check URL part my ($map,$resid,$url)=split(/\_\_\_/,$symb); unless (&symbclean($url) eq &symbclean($thisfn)) { return 0; } $symb=&symbclean($symb); my %bighash; my $okay=0; if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', &GDBM_READER,0640)) { my $ids=$bighash{'ids_/res/'.$thisfn}; unless ($ids) { $ids=$bighash{'ids_/'.$thisfn}; } if ($ids) { # ------------------------------------------------------------------- Has ID(s) foreach (split(/\,/,$ids)) { my ($mapid,$resid)=split(/\./,$_); if ( &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) eq $symb) { $okay=1; } } } untie(%bighash); } return $okay; } # --------------------------------------------------------------- Clean-up symb sub symbclean { my $symb=shift; # remove version from map $symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/; # remove version from URL $symb=~s/\.(\d+)\.(\w+)$/\.$2/; return $symb; } # ------------------------------------------------------ Return symb list entry sub symbread { my $thisfn=shift; # no filename provided? try from environment unless ($thisfn) { if ($ENV{'request.symb'}) { return &symbclean($ENV{'request.symb'}); } $thisfn=$ENV{'request.filename'}; } # is that filename actually a symb? Verify, clean, and return if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) { if (&symbverify($thisfn,$1)) { return &symbclean($thisfn); } } $thisfn=declutter($thisfn); my %hash; my %bighash; my $syval=''; if (($ENV{'request.course.fn'}) && ($thisfn)) { if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', &GDBM_READER,0640)) { $syval=$hash{$thisfn}; untie(%hash); } # ---------------------------------------------------------- There was an entry if ($syval) { unless ($syval=~/\_\d+$/) { unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) { &appenv('request.ambiguous' => $thisfn); return ''; } $syval.=$1; } } else { # ------------------------------------------------------- Was not in symb table if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', &GDBM_READER,0640)) { # ---------------------------------------------- Get ID(s) for current resource my $ids=$bighash{'ids_/res/'.$thisfn}; unless ($ids) { $ids=$bighash{'ids_/'.$thisfn}; } unless ($ids) { # alias? $ids=$bighash{'mapalias_'.$thisfn}; } if ($ids) { # ------------------------------------------------------------------- Has ID(s) my @possibilities=split(/\,/,$ids); if ($#possibilities==0) { # ----------------------------------------------- There is only one possibility my ($mapid,$resid)=split(/\./,$ids); $syval=declutter($bighash{'map_id_'.$mapid}).'___'.$resid; } else { # ------------------------------------------ There is more than one possibility my $realpossible=0; foreach (@possibilities) { my $file=$bighash{'src_'.$_}; if (&allowed('bre',$file)) { my ($mapid,$resid)=split(/\./,$_); if ($bighash{'map_type_'.$mapid} ne 'page') { $realpossible++; $syval=declutter($bighash{'map_id_'.$mapid}). '___'.$resid; } } } if ($realpossible!=1) { $syval=''; } } } untie(%bighash) } } if ($syval) { return &symbclean($syval.'___'.$thisfn); } } &appenv('request.ambiguous' => $thisfn); return ''; } # ---------------------------------------------------------- Return random seed sub numval { my $txt=shift; $txt=~tr/A-J/0-9/; $txt=~tr/a-j/0-9/; $txt=~tr/K-T/0-9/; $txt=~tr/k-t/0-9/; $txt=~tr/U-Z/0-5/; $txt=~tr/u-z/0-5/; $txt=~s/\D//g; return int($txt); } sub rndseed { my ($symb,$courseid,$domain,$username)=@_; if (!$symb) { unless ($symb=&symbread()) { return time; } } if (!$courseid) { $courseid=$ENV{'request.course.id'};} if (!$domain) {$domain=$ENV{'user.domain'};} if (!$username) {$username=$ENV{'user.name'};} { use integer; my $symbchck=unpack("%32C*",$symb) << 27; my $symbseed=numval($symb) << 22; my $namechck=unpack("%32C*",$username) << 17; my $nameseed=numval($username) << 12; my $domainseed=unpack("%32C*",$domain) << 7; my $courseseed=unpack("%32C*",$courseid); my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck; #uncommenting these lines can break things! #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); #&Apache::lonxml::debug("rndseed :$num:$symb"); return $num; } } sub ireceipt { my ($funame,$fudom,$fucourseid,$fusymb)=@_; my $cuname=unpack("%32C*",$funame); my $cudom=unpack("%32C*",$fudom); my $cucourseid=unpack("%32C*",$fucourseid); my $cusymb=unpack("%32C*",$fusymb); my $cunique=unpack("%32C*",$perlvar{'lonReceipt'}); return unpack("%32C*",$perlvar{'lonHostID'}).'-'. ($cunique%$cuname+ $cunique%$cudom+ $cusymb%$cuname+ $cusymb%$cudom+ $cucourseid%$cuname+ $cucourseid%$cudom); } sub receipt { return &ireceipt($ENV{'user.name'},$ENV{'user.domain'}, $ENV{'request.course.id'},&symbread()); } # ------------------------------------------------------------ Serves up a file # returns either the contents of the file or a -1 sub getfile { my $file=shift; &repcopy($file); if (! -e $file ) { return -1; }; my $fh=Apache::File->new($file); my $a=''; while (<$fh>) { $a .=$_; } return $a } sub filelocation { my ($dir,$file) = @_; my $location; $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces if ($file=~m:^/~:) { # is a contruction space reference $location = $file; $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; } else { $file=~s/^$perlvar{'lonDocRoot'}//; $file=~s:^/*res::; if ( !( $file =~ m:^/:) ) { $location = $dir. '/'.$file; } else { $location = '/home/httpd/html/res'.$file; } } $location=~s://+:/:g; # remove duplicate / while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/.. return $location; } sub hreflocation { my ($dir,$file)=@_; unless (($file=~/^http:\/\//i) || ($file=~/^\//)) { my $finalpath=filelocation($dir,$file); $finalpath=~s/^\/home\/httpd\/html//; $finalpath=~s-/home/(\w+)/public_html/-/~$1/-; return $finalpath; } else { return $file; } } # ------------------------------------------------------------- Declutters URLs sub declutter { my $thisfn=shift; $thisfn=~s/^$perlvar{'lonDocRoot'}//; $thisfn=~s/^\///; $thisfn=~s/^res\///; $thisfn=~s/\?.+$//; return $thisfn; } # -------------------------------------------------------- Escape Special Chars sub escape { my $str=shift; $str =~ s/(\W)/"%".unpack('H2',$1)/eg; return $str; } # ----------------------------------------------------- Un-Escape Special Chars sub unescape { my $str=shift; $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; return $str; } # ================================================================ Main Program sub goodbye { &logthis("Starting Shut down"); &flushcourselogs(); &logthis("Shutting down"); } BEGIN { # ----------------------------------- Read loncapa.conf and loncapa_apache.conf unless ($readit) { { my $config=Apache::File->new("/etc/httpd/conf/loncapa.conf"); while (my $configline=<$config>) { if ($configline =~ /^[^\#]*PerlSetVar/) { my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); chomp($varvalue); $perlvar{$varname}=$varvalue; } } } { my $config=Apache::File->new("/etc/httpd/conf/loncapa_apache.conf"); while (my $configline=<$config>) { if ($configline =~ /^[^\#]*PerlSetVar/) { my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); chomp($varvalue); $perlvar{$varname}=$varvalue; } } } # ------------------------------------------------------------- Read hosts file { my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab"); while (my $configline=<$config>) { chomp($configline); my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); $hostname{$id}=$name; $hostdom{$id}=$domain; $hostip{$id}=$ip; if ($role eq 'library') { $libserv{$id}=$name; } } } # ------------------------------------------------------ Read spare server file { my $config=Apache::File->new("$perlvar{'lonTabDir'}/spare.tab"); while (my $configline=<$config>) { chomp($configline); if (($configline) && ($configline ne $perlvar{'lonHostID'})) { $spareid{$configline}=1; } } } # ------------------------------------------------------------ Read permissions { my $config=Apache::File->new("$perlvar{'lonTabDir'}/roles.tab"); while (my $configline=<$config>) { chomp($configline); if ($configline) { my ($role,$perm)=split(/ /,$configline); if ($perm ne '') { $pr{$role}=$perm; } } } } # -------------------------------------------- Read plain texts for permissions { my $config=Apache::File->new("$perlvar{'lonTabDir'}/rolesplain.tab"); while (my $configline=<$config>) { chomp($configline); if ($configline) { my ($short,$plain)=split(/:/,$configline); if ($plain ne '') { $prp{$short}=$plain; } } } } # ---------------------------------------------------------- Read package table { my $config=Apache::File->new("$perlvar{'lonTabDir'}/packages.tab"); while (my $configline=<$config>) { chomp($configline); my ($short,$plain)=split(/:/,$configline); my ($pack,$name)=split(/\&/,$short); if ($plain ne '') { $packagetab{$pack.'&'.$name.'&name'}=$name; $packagetab{$short}=$plain; } } } %metacache=(); $processmarker=$$.'_'.time.'_'.$perlvar{'lonHostID'}; $dumpcount=0; &logtouch(); &logthis('INFO: Read configuration'); $readit=1; } } 1; __END__ =head1 NAME Apache::lonnet - TCP networking package =head1 SYNOPSIS Invoked by other LON-CAPA modules. &Apache::lonnet::SUBROUTINENAME(ARGUMENTS); =head1 INTRODUCTION This module provides subroutines which interact with the lonc/lond (TCP) network layer of LON-CAPA. This is part of the LearningOnline Network with CAPA project described at http://www.lon-capa.org. =head1 HANDLER SUBROUTINE There is no handler routine for this module. =head1 OTHER SUBROUTINES =over 4 =item * logtouch() : make sure the logfile, lonnet.log, exists =item * logthis() : append message to lonnet.log =item * logperm() : append a permanent message to lonnet.perm.log =item * subreply() : non-critical communication, called by &reply =item * reply() : makes two attempts to pass message; logs refusals and rejections =item * reconlonc() : tries to reconnect lonc client processes. =item * critical() : passes a critical message to another server; if cannot get through then place message in connection buffer =item * appenv(%hash) : read in current user environment, append new environment values to make new user environment =item * delenv($varname) : read in current user environment, remove all values beginning with $varname, write new user environment (note: flock is used to prevent conflicting shared read/writes with file) =item * spareserver() : find server with least workload from spare.tab =item * queryauthenticate($uname,$udom) : try to determine user's current authentication scheme =item * authenticate($uname,$upass,$udom) : try to authenticate user from domain's lib servers (first use the current one) =item * homeserver($uname,$udom) : find the homebase for a user from domain's lib servers =item * idget($udom,@ids) : find the usernames behind a list of IDs (returns hash: id=>name,id=>name) =item * idrget($udom,@unames) : find the IDs behind a list of usernames (returns hash: name=>id,name=>id) =item * idput($udom,%ids) : store away a list of names and associated IDs =item * usection($domain,$user,$courseid) : output of section name/number or '' for "not in course" and '-1' for "no section" =item * userenvironment($domain,$user,$what) : puts out any environment parameter for a user =item * subscribe($fname) : subscribe to a resource, return URL if possible =item * repcopy($filename) : replicate file =item * ssi($url,%hash) : server side include, does a complete request cycle on url to localhost, posts hash =item * log($domain,$name,$home,$message) : write to permanent log for user; use critical subroutine =item * flushcourselogs() : flush (save) buffer logs and access logs =item * courselog($what) : save message for course in hash =item * courseacclog($what) : save message for course using &courselog(). Perform special processing for specific resource types (problems, exams, quizzes, etc). =item * countacc($url) : count the number of accesses to a given URL =item * sub checkout($symb,$tuname,$tudom,$tcrsid) : check out an item =item * sub checkin($token) : check in an item =item * sub expirespread($uname,$udom,$stype,$usymb) : set expire date for spreadsheet =item * devalidate($symb) : devalidate spreadsheets =item * hash2str(%hash) : convert a hash into a string complete with escaping and '=' and '&' separators, supports elements that are arrayrefs and hashrefs =item * hashref2str($hashref) : convert a hashref into a string complete with escaping and '=' and '&' separators, supports elements that are arrayrefs and hashrefs =item * arrayref2str($arrayref) : convert an arrayref into a string complete with escaping and '&' separators, supports elements that are arrayrefs and hashrefs =item * str2hash($string) : convert string to hash using unescaping and splitting on '=' and '&', supports elements that are arrayrefs and hashrefs =item * str2array($string) : convert string to hash using unescaping and splitting on '&', supports elements that are arrayrefs and hashrefs =item * tmpreset($symb,$namespace,$domain,$stuname) : temporary storage =item * tmprestore($symb,$namespace,$domain,$stuname) : temporary restore =item * store($storehash,$symb,$namespace,$domain,$stuname) : stores hash permanently for this url; hashref needs to be given and should be a \%hashname; the remaining args aren't required and if they aren't passed or are '' they will be derived from the ENV =item * cstore($storehash,$symb,$namespace,$domain,$stuname) : same as store but uses critical subroutine =item * restore($symb,$namespace,$domain,$stuname) : returns hash for this symb; all args are optional =item * coursedescription($courseid) : course description =item * rolesinit($domain,$username,$authhost) : get user privileges =item * get($namespace,$storearr,$udomain,$uname) : returns hash with keys from array reference filled in from namesp ($udomain and $uname are optional) =item * del($namespace,$storearr,$udomain,$uname) : deletes keys out of array from namesp ($udomain and $uname are optional) =item * dump($namespace,$udomain,$uname,$regexp) : dumps the complete (or key matching regexp) namespace into a hash ($udomain, $uname and $regexp are optional) =item * put($namespace,$storehash,$udomain,$uname) : stores hash in namesp ($udomain and $uname are optional) =item * cput($namespace,$storehash,$udomain,$uname) : critical put ($udomain and $uname are optional) =item * eget($namespace,$storearr,$udomain,$uname) : returns hash with keys from array reference filled in from namesp (encrypts the return communication) ($udomain and $uname are optional) =item * allowed($priv,$uri) : check for a user privilege; returns codes for allowed actions F: full access U,I,K: authentication modes (cxx only) '': forbidden 1: user needs to choose course 2: browse allowed =item * definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom role rolename set privileges in format of lonTabs/roles.tab for system, domain, and course level =item * metadata_query($query,$custom,$customshow) : make a metadata query against the network of library servers; returns file handle of where SQL and regex results will be stored for query =item * plaintext($short) : return value in %prp hash (rolesplain.tab); plain text explanation of a user role term =item * assignrole($udom,$uname,$url,$role,$end,$start) : assign role; give a role to a user for the level given by URL. Optional start and end dates (leave empty string or zero for "no date") =item * modifyuserauth($udom,$uname,$umode,$upass) : modify user authentication =item * modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) : modify user =item * modifystudent($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, $end,$start) : modify student =item * writecoursepref($courseid,%prefs) : write preferences for a course =item * createcourse($udom,$description,$url) : make/modify course =item * assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start) : assign custom role; give a custom role to a user for the level given by URL. Specify name and domain of role author, and role name =item * revokerole($udom,$uname,$url,$role) : revoke a role for url =item * revokecustomrole($udom,$uname,$url,$role) : revoke a custom role =item * dirlist($uri) : return directory list based on URI =item * directcondval($number) : get current value of a condition; reads from a state string =item * condval($condidx) : value of condition index based on state =item * EXT($varname,$symbparm) : value of a variable =item * metadata($uri,$what,$liburi,$prefix,$depthcount) : get metadata; returns the metadata entry for a file; entry='keys', returns a comma separated list of keys =item * symblist($mapname,%newhash) : update symbolic storage links =item * symbread($filename) : return symbolic list entry (filename argument optional); returns the data handle =item * numval($salt) : return random seed value (addend for rndseed) =item * rndseed($symb,$courseid,$domain,$username) : create a random sum; returns a random seed, all arguments are optional, if they aren't sent it uses the environment to derive them. Note: if symb isn't sent and it can't get one from &symbread it will use the current time as its return value =item * ireceipt($funame,$fudom,$fucourseid,$fusymb) : return unique, unfakeable, receipt =item * receipt() : API to ireceipt working off of ENV values; given out to users =item * getfile($file) : serves up a file, returns the contents of a file or -1; replicates and subscribes to the file =item * filelocation($dir,$file) : returns file system location of a file based on URI; meant to be "fairly clean" absolute reference, $dir is a directory that relative $file lookups are to looked in ($dir of /a/dir and a file of ../bob will become /a/bob) =item * hreflocation($dir,$file) : returns file system location or a URL; same as filelocation except for hrefs =item * declutter() : declutters URLs (remove docroot, beginning slashes, 'res' etc) =item * escape() : unpack non-word characters into CGI-compatible hex codes =item * unescape() : pack CGI-compatible hex codes into actual non-word ASCII character =item * goodbye() : flush course logs and log shutting down; it is called in srm.conf as a PerlChildExitHandler =back =cut