--- loncom/lonnet/perl/lonnet.pm 2001/03/20 21:33:37 1.110 +++ loncom/lonnet/perl/lonnet.pm 2004/05/09 00:45:01 1.498 @@ -1,121 +1,102 @@ # The LearningOnline Network # TCP networking package # -# Functions for use by content handlers: +# $Id: lonnet.pm,v 1.498 2004/05/09 00:45:01 www Exp $ # -# metadata_query(sql-query-string) : returns file handle of where sql -# results will be stored for query -# plaintext(short) : plain text explanation of short term -# fileembstyle(ext) : embed style in page for file extension -# filedescription(ext) : descriptor text for file extension -# allowed(short,url) : 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 -# definerole(rolename,sys,dom,cou) : define a custom role rolename -# set privileges in format of lonTabs/roles.tab for -# system, domain and course level, -# assignrole(udom,uname,url,role,end,start) : 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") -# assigncustomrole (udom,uname,url,rdom,rnam,rolename,end,start) : give a -# custom role to a user for the level given by url. -# Specify name and domain of role author, and role name -# revokerole (udom,uname,url,role) : Revoke a role for url -# revokecustomrole (udom,uname,url,rdom,rnam,rolename) : Revoke a custom role -# appenv(hash) : adds hash to session environment -# delenv(varname) : deletes all environment entries starting with varname -# store(hash) : stores hash permanently for this url -# cstore(hash) : critical store -# restore : returns hash for this url -# eget(namesp,array) : returns hash with keys from array filled in from namesp -# get(namesp,array) : returns hash with keys from array filled in from namesp -# del(namesp,array) : deletes keys out of array from namesp -# put(namesp,hash) : stores hash in namesp -# cput(namesp,hash) : critical put -# dump(namesp) : dumps the complete namespace into a hash -# ssi(url,hash) : does a complete request cycle on url to localhost, posts -# hash -# coursedescription(id) : returns and caches course description for id -# repcopy(filename) : replicate file -# dirlist(url) : gets a directory listing -# directcondval(index) : reading condition value of single condition from -# state string -# condval(index) : value of condition index based on state -# EXT(name) : value of a variable -# symblist(map,hash) : Updates symbolic storage links -# symbread([filename]) : returns the data handle (filename optional) -# rndseed() : returns a random seed -# receipt() : returns a receipt to be given out to users -# getfile(filename) : returns the contents of filename, or a -1 if it can't -# be found, replicates and subscribes to the file -# filelocation(dir,file) : returns a farily clean absolute reference to file -# from the directory dir -# hreflocation(dir,file) : same as filelocation, but for hrefs -# log(domain,user,home,msg) : write to permanent log for user -# usection(domain,user,courseid) : output of section name/number or '' for -# "not in course" and '-1' for "no section" -# userenvironment(domain,user,what) : puts out any environment parameter -# for a user -# idput(domain,hash) : writes IDs for users from hash (name=>id,name=>id) -# idget(domain,array): returns hash with usernames (id=>name,id=>name) for -# an array of IDs -# idrget(domain,array): returns hash with IDs for usernames (name=>id,...) for -# an array of names -# metadata(file,entry): returns the metadata entry for a file. entry='keys' -# returns a comma separated list of keys -# -# 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 -# 02/27/01 Scott Harrison -# 3/2 Gerd Kortemeyer -# 3/15 Scott Harrison -# 3/19,3/20 Gerd Kortemeyer +# 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/ +# +### package Apache::lonnet; use strict; -use Apache::File; use LWP::UserAgent(); use HTTP::Headers; +use HTTP::Date; +# use Date::Parse; use vars -qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp %fe %fd $readit %metacache); +qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom + %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache + %courselogs %accesshash %userrolehash $processmarker $dumpcount + %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache + %userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def + %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir); + use IO::Socket; use GDBM_File; use Apache::Constants qw(:common :http); -use HTML::TokeParser; +use HTML::LCParser; use Fcntl qw(:flock); +use Apache::loncoursedata; +use Apache::lonlocal; +use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw); +use Time::HiRes(); +my $readit; + +=pod + +=head1 Package Variables + +These are largely undocumented, so if you decipher one please note it here. + +=over 4 + +=item $processmarker + +Contains the time this process was started and this servers host id. + +=item $dumpcount + +Counts the number of times a message log flush has been attempted (regardless +of success) by this process. Used as part of the filename when messages are +delayed. + +=back + +=cut + # --------------------------------------------------------------------- Logging +sub logtouch { + my $execdir=$perlvar{'lonDaemons'}; + unless (-e "$execdir/logs/lonnet.log") { + open(my $fh,">>$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"; + if (open(my $fh,">>$execdir/logs/lonnet.log")) { + print $fh "$local ($$): $message\n"; + close($fh); + } return 1; } @@ -124,8 +105,10 @@ sub logperm { 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"; + if (open(my $fh,">>$execdir/logs/lonnet.perm.log")) { + print $fh "$now:$message:$local\n"; + close($fh); + } return 1; } @@ -146,8 +129,24 @@ sub subreply { sub reply { my ($cmd,$server)=@_; + unless (defined($hostname{$server})) { return 'no_such_host'; } my $answer=subreply($cmd,$server); - if ($answer eq 'con_lost') { $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"); @@ -161,7 +160,7 @@ 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")) { + if (open(my $fh,"<$loncfile")) { my $loncpid=<$fh>; chomp($loncpid); if (kill 0 => $loncpid) { @@ -206,20 +205,23 @@ sub critical { $middlename=substr($middlename,0,16); $middlename=~s/\W//g; my $dfilename= - "$perlvar{'lonSockDir'}/delayed/$now.$middlename.$server"; + "$perlvar{'lonSockDir'}/delayed/$now.$dumpcount.$$.$middlename.$server"; + $dumpcount++; { - my $dfh; - if ($dfh=Apache::File->new(">$dfilename")) { - print $dfh "$cmd\n"; - } + my $dfh; + if (open($dfh,">$dfilename")) { + print $dfh "$cmd\n"; + close($dfh); + } } sleep 2; my $wcmd=''; { - my $dfh; - if ($dfh=Apache::File->new("$dfilename")) { - $wcmd=<$dfh>; - } + my $dfh; + if (open($dfh,"<$dfilename")) { + $wcmd=<$dfh>; + close($dfh); + } } chomp($wcmd); if ($wcmd eq $cmd) { @@ -238,62 +240,106 @@ sub critical { return $answer; } +# +# -------------- Remove all key from the env that start witha lowercase letter +# (Which is always a lon-capa value) + +sub cleanenv { +# unless (defined(&Apache::exists_config_define("MODPERL2"))) { return; } +# unless (&Apache::exists_config_define("MODPERL2")) { return; } + foreach my $key (keys(%ENV)) { + if ($key =~ /^[a-z]/) { + delete($ENV{$key}); + } + } +} + +# ------------------------------------------- Transfer profile into environment + +sub transfer_profile_to_env { + my ($lonidsdir,$handle)=@_; + my @profile; + { + open(my $idf,"$lonidsdir/$handle.id"); + flock($idf,LOCK_SH); + @profile=<$idf>; + close($idf); + } + my $envi; + my %Remove; + for ($envi=0;$envi<=$#profile;$envi++) { + chomp($profile[$envi]); + my ($envname,$envvalue)=split(/=/,$profile[$envi]); + $ENV{$envname} = $envvalue; + if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) { + if ($time < time-300) { + $Remove{$key}++; + } + } + } + $ENV{'user.environment'} = "$lonidsdir/$handle.id"; + foreach my $expired_key (keys(%Remove)) { + &delenv($expired_key); + } +} + # ---------------------------------------------------------- Append Environment sub appenv { my %newenv=@_; - map { + foreach (keys %newenv) { if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) { &logthis("WARNING: ". - "Attempt to modify environment ".$_." to ".$newenv{$_}); + "Attempt to modify environment ".$_." to ".$newenv{$_} + .''); delete($newenv{$_}); } else { $ENV{$_}=$newenv{$_}; } - } keys %newenv; + } my $lockfh; - unless ($lockfh=Apache::File->new("$ENV{'user.environment'}")) { - return 'error: '.$!; + unless (open($lockfh,"$ENV{'user.environment'}")) { + return 'error: '.$!; } unless (flock($lockfh,LOCK_EX)) { &logthis("WARNING: ". 'Could not obtain exclusive lock in appenv: '.$!); - $lockfh->close(); + close($lockfh); return 'error: '.$!; } my @oldenv; { - my $fh; - unless ($fh=Apache::File->new("$ENV{'user.environment'}")) { - return 'error: '.$!; - } - @oldenv=<$fh>; - $fh->close(); + my $fh; + unless (open($fh,"$ENV{'user.environment'}")) { + return 'error: '.$!; + } + @oldenv=<$fh>; + close($fh); } 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 ($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(); + my $fh; + unless (open($fh,">$ENV{'user.environment'}")) { + return 'error'; + } + my $newname; + foreach $newname (keys %newenv) { + print $fh "$newname=$newenv{$newname}\n"; + } + close($fh); } - - $lockfh->close(); + + close($lockfh); return 'ok'; } # ----------------------------------------------------- Delete from Environment @@ -308,110 +354,220 @@ sub delenv { } 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 (open($fh,"$ENV{'user.environment'}")) { + return 'error'; + } + unless (flock($fh,LOCK_SH)) { + &logthis("WARNING: ". + 'Could not obtain shared lock in delenv: '.$!); + close($fh); + return 'error: '.$!; + } + @oldenv=<$fh>; + close($fh); } { - 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: '.$!; - } - map { - unless ($_=~/^$delthis/) { print $fh $_; } - } @oldenv; - $fh->close(); + my $fh; + unless (open($fh,">$ENV{'user.environment'}")) { + return 'error'; + } + unless (flock($fh,LOCK_EX)) { + &logthis("WARNING: ". + 'Could not obtain exclusive lock in delenv: '.$!); + close($fh); + return 'error: '.$!; + } + foreach (@oldenv) { + if ($_=~/^$delthis/) { + my ($key,undef) = split('=',$_); + delete($ENV{$key}); + } else { + print $fh $_; + } + } + close($fh); } return 'ok'; } +# ------------------------------------------ Find out current server userload +# there is a copy in lond +sub userload { + my $numusers=0; + { + opendir(LONIDS,$perlvar{'lonIDsDir'}); + my $filename; + my $curtime=time; + while ($filename=readdir(LONIDS)) { + if ($filename eq '.' || $filename eq '..') {next;} + my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9]; + if ($curtime-$mtime < 1800) { $numusers++; } + } + closedir(LONIDS); + } + my $userloadpercent=0; + my $maxuserload=$perlvar{'lonUserLoadLim'}; + if ($maxuserload) { + $userloadpercent=100*$numusers/$maxuserload; + } + $userloadpercent=sprintf("%.2f",$userloadpercent); + return $userloadpercent; +} + +# ------------------------------------------ Fight off request when overloaded + +sub overloaderror { + my ($r,$checkserver)=@_; + unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; } + my $loadavg; + if ($checkserver eq $perlvar{'lonHostID'}) { + open(my $loadfile,'/proc/loadavg'); + $loadavg=<$loadfile>; + $loadavg =~ s/\s.*//g; + $loadavg = 100*$loadavg/$perlvar{'lonLoadLim'}; + close($loadfile); + } else { + $loadavg=&reply('load',$checkserver); + } + my $overload=$loadavg-100; + if ($overload>0) { + $r->err_headers_out->{'Retry-After'}=$overload; + $r->log_error('Overload of '.$overload.' on '.$checkserver); + return 413; + } + return ''; +} + # ------------------------------ Find server with least workload from spare.tab sub spareserver { + my ($loadpercent,$userloadpercent) = @_; my $tryserver; my $spareserver=''; - my $lowestserver=100; + if ($userloadpercent !~ /\d/) { $userloadpercent=0; } + my $lowestserver=$loadpercent > $userloadpercent? + $loadpercent : $userloadpercent; foreach $tryserver (keys %spareid) { - my $answer=reply('load',$tryserver); - if (($answer =~ /\d/) && ($answer<$lowestserver)) { - $spareserver="http://$hostname{$tryserver}"; - $lowestserver=$answer; - } - } + my $loadans=reply('load',$tryserver); + my $userloadans=reply('userload',$tryserver); + if ($loadans !~ /\d/ && $userloadans !~ /\d/) { + next; #didn't get a number from the server + } + my $answer; + if ($loadans =~ /\d/) { + if ($userloadans =~ /\d/) { + #both are numbers, pick the bigger one + $answer=$loadans > $userloadans? + $loadans : $userloadans; + } else { + $answer = $loadans; + } + } else { + $answer = $userloadans; + } + 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)=@_; + my $uhome=&homeserver($uname,$udom); + if (!$uhome) { + &logthis("User $uname at $udom is unknown when looking for authentication mechanism"); + return 'no_host'; + } + my $answer=reply("encrypt:currentauth:$udom:$uname",$uhome); + if ($answer =~ /^(unknown_user|refused|con_lost)/) { + &logthis("User $uname at $udom threw error $answer when checking authentication mechanism"); + } + return $answer; +} + # --------- Try to authenticate user from domain's lib servers (first this one) sub authenticate { my ($uname,$upass,$udom)=@_; $upass=escape($upass); - 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'; - } - } - } + $uname=~s/\W//g; + my $uhome=&homeserver($uname,$udom); + if (!$uhome) { + &logthis("User $uname at $udom is unknown in authenticate"); + return 'no_host'; + } + my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome); + if ($answer eq 'authorized') { + &logthis("User $uname at $udom authorized by $uhome"); + return $uhome; + } + if ($answer eq 'non_authorized') { + &logthis("User $uname at $udom rejected by $uhome"); + return 'no_host'; } - &logthis("User $uname at $udom could not be authenticated"); + &logthis("User $uname at $udom threw error $answer when checking authentication mechanism"); return 'no_host'; } # ---------------------- Find the homebase for a user from domain's lib servers sub homeserver { - my ($uname,$udom)=@_; - + my ($uname,$udom,$ignoreBadCache)=@_; my $index="$uname:$udom"; - if ($homecache{$index}) { return "$homecache{$index}"; } + my ($result,$cached)=&is_cached(\%homecache,$index,'home',86400); + if (defined($cached)) { return $result; } 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; - } + return &do_cache(\%homecache,$index,$tryserver,'home'); + } elsif ($answer eq 'no_host') { + $badServerCache{$tryserver}=1; + } } } return 'no_host'; @@ -449,9 +605,9 @@ sub idget { sub idrget { my ($udom,@unames)=@_; my %returnhash=(); - map { + foreach (@unames) { $returnhash{$_}=(&userenvironment($udom,$_,'id'))[1]; - } @unames; + } return %returnhash; } @@ -460,7 +616,8 @@ sub idrget { sub idput { my ($udom,%ids)=@_; my %servers=(); - map { + foreach (keys %ids) { + &cput('environment',{'id'=>$ids{$_}},$udom,$_); my $uhom=&homeserver($_,$udom); if ($uhom ne 'no_host') { my $id=&escape($ids{$_}); @@ -471,24 +628,348 @@ sub idput { } else { $servers{$uhom}=$id.'='.$unam; } - &critical('put:'.$udom.':'.$unam.':environment:id='.$id,$uhom); } - } keys %ids; - map { + } + foreach (keys %servers) { &critical('idput:'.$udom.':'.$servers{$_},$_); - } keys %servers; + } +} + +# --------------------------------------------------- Assign a key to a student + +sub assign_access_key { +# +# a valid key looks like uname:udom#comments +# comments are being appended +# + my ($ckey,$kdom,$knum,$cdom,$cnum,$udom,$uname,$logentry)=@_; + $kdom= + $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($kdom)); + $knum= + $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($knum)); + $cdom= + $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); + $cnum= + $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); + $udom=$ENV{'user.name'} unless (defined($udom)); + $uname=$ENV{'user.domain'} unless (defined($uname)); + my %existing=&get('accesskeys',[$ckey],$kdom,$knum); + if (($existing{$ckey}=~/^\#(.*)$/) || # - new key + ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#(.*)$/)) { + # assigned to this person + # - this should not happen, + # unless something went wrong + # the first time around +# ready to assign + $logentry=$1.'; '.$logentry; + if (&put('accesskeys',{$ckey=>$uname.':'.$udom.'#'.$logentry}, + $kdom,$knum) eq 'ok') { +# key now belongs to user + my $envkey='key.'.$cdom.'_'.$cnum; + if (&put('environment',{$envkey => $ckey}) eq 'ok') { + &appenv('environment.'.$envkey => $ckey); + return 'ok'; + } else { + return + 'error: Count not permanently assign key, will need to be re-entered later.'; + } + } else { + return 'error: Could not assign key, try again later.'; + } + } elsif (!$existing{$ckey}) { +# the key does not exist + return 'error: The key does not exist'; + } else { +# the key is somebody else's + return 'error: The key is already in use'; + } +} + +# ------------------------------------------ put an additional comment on a key + +sub comment_access_key { +# +# a valid key looks like uname:udom#comments +# comments are being appended +# + my ($ckey,$cdom,$cnum,$logentry)=@_; + $cdom= + $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); + $cnum= + $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); + my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); + if ($existing{$ckey}) { + $existing{$ckey}.='; '.$logentry; +# ready to assign + if (&put('accesskeys',{$ckey=>$existing{$ckey}}, + $cdom,$cnum) eq 'ok') { + return 'ok'; + } else { + return 'error: Count not store comment.'; + } + } else { +# the key does not exist + return 'error: The key does not exist'; + } +} + +# ------------------------------------------------------ Generate a set of keys + +sub generate_access_keys { + my ($number,$cdom,$cnum,$logentry)=@_; + $cdom= + $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); + $cnum= + $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); + unless (&allowed('mky',$cdom)) { return 0; } + unless (($cdom) && ($cnum)) { return 0; } + if ($number>10000) { return 0; } + sleep(2); # make sure don't get same seed twice + srand(time()^($$+($$<<15))); # from "Programming Perl" + my $total=0; + for (my $i=1;$i<=$number;$i++) { + my $newkey=sprintf("%lx",int(100000*rand)).'-'. + sprintf("%lx",int(100000*rand)).'-'. + sprintf("%lx",int(100000*rand)); + $newkey=~s/1/g/g; # folks mix up 1 and l + $newkey=~s/0/h/g; # and also 0 and O + my %existing=&get('accesskeys',[$newkey],$cdom,$cnum); + if ($existing{$newkey}) { + $i--; + } else { + if (&put('accesskeys', + { $newkey => '# generated '.localtime(). + ' by '.$ENV{'user.name'}.'@'.$ENV{'user.domain'}. + '; '.$logentry }, + $cdom,$cnum) eq 'ok') { + $total++; + } + } + } + &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'}, + 'Generated '.$total.' keys for '.$cnum.' at '.$cdom); + return $total; +} + +# ------------------------------------------------------- Validate an accesskey + +sub validate_access_key { + my ($ckey,$cdom,$cnum,$udom,$uname)=@_; + $cdom= + $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); + $cnum= + $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); + $udom=$ENV{'user.domain'} unless (defined($udom)); + $uname=$ENV{'user.name'} unless (defined($uname)); + my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); + return ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#/); } # ------------------------------------- Find the section of student in a course +sub getsection { + my ($udom,$unam,$courseid)=@_; + $courseid=~s/\_/\//g; + $courseid=~s/^(\w)/\/$1/; + my %Pending; + my %Expired; + # + # Each role can either have not started yet (pending), be active, + # or have expired. + # + # If there is an active role, we are done. + # + # If there is more than one role which has not started yet, + # choose the one which will start sooner + # If there is one role which has not started yet, return it. + # + # If there is more than one expired role, choose the one which ended last. + # If there is a role which has expired, return it. + # + foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles', + &homeserver($unam,$udom)))) { + my ($key,$value)=split(/\=/,$_); + $key=&unescape($key); + next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/); + my $section=$1; + if ($key eq $courseid.'_st') { $section=''; } + my ($dummy,$end,$start)=split(/\_/,&unescape($value)); + my $now=time; + if (defined($end) && ($now > $end)) { + $Expired{$end}=$section; + next; + } + if (defined($start) && ($now < $start)) { + $Pending{$start}=$section; + next; + } + return $section; + } + # + # Presumedly there will be few matching roles from the above + # loop and the sorting time will be negligible. + if (scalar(keys(%Pending))) { + my ($time) = sort {$a <=> $b} keys(%Pending); + return $Pending{$time}; + } + if (scalar(keys(%Expired))) { + my @sorted = sort {$a <=> $b} keys(%Expired); + my $time = pop(@sorted); + return $Expired{$time}; + } + return '-1'; +} + + +my $disk_caching_disabled=1; + +sub devalidate_cache { + my ($cache,$id,$name) = @_; + delete $$cache{$id.'.time'}; + delete $$cache{$id}; + if ($disk_caching_disabled) { return; } + my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db"; + open(DB,"$filename.lock"); + flock(DB,LOCK_EX); + my %hash; + if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) { + eval <<'EVALBLOCK'; + delete($hash{$id}); + delete($hash{$id.'.time'}); +EVALBLOCK + if ($@) { + &logthis("devalidate_cache blew up :$@:$name"); + unlink($filename); + } + } else { + if (-e $filename) { + &logthis("Unable to tie hash (devalidate cache): $name"); + unlink($filename); + } + } + untie(%hash); + flock(DB,LOCK_UN); + close(DB); +} + +sub is_cached { + my ($cache,$id,$name,$time) = @_; + if (!$time) { $time=300; } + if (!exists($$cache{$id.'.time'})) { + &load_cache_item($cache,$name,$id); + } + if (!exists($$cache{$id.'.time'})) { +# &logthis("Didn't find $id"); + return (undef,undef); + } else { + if (time-($$cache{$id.'.time'})>$time) { +# &logthis("Devalidating $id - ".time-($$cache{$id.'.time'})); + &devalidate_cache($cache,$id,$name); + return (undef,undef); + } + } + return ($$cache{$id},1); +} + +sub do_cache { + my ($cache,$id,$value,$name) = @_; + $$cache{$id.'.time'}=time; + $$cache{$id}=$value; +# &logthis("Caching $id as :$value:"); + &save_cache_item($cache,$name,$id); + # do_cache implictly return the set value + $$cache{$id}; +} + +sub save_cache_item { + my ($cache,$name,$id)=@_; + if ($disk_caching_disabled) { return; } + my $starttime=&Time::HiRes::time(); +# &logthis("Saving :$name:$id"); + my %hash; + my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db"; + open(DB,"$filename.lock"); + flock(DB,LOCK_EX); + if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) { + eval <<'EVALBLOCK'; + $hash{$id.'.time'}=$$cache{$id.'.time'}; + $hash{$id}=freeze({'item'=>$$cache{$id}}); +EVALBLOCK + if ($@) { + &logthis("save_cache blew up :$@:$name"); + unlink($filename); + } + } else { + if (-e $filename) { + &logthis("Unable to tie hash (save cache item): $name ($!)"); + unlink($filename); + } + } + untie(%hash); + flock(DB,LOCK_UN); + close(DB); +# &logthis("save_cache_item $name took ".(&Time::HiRes::time()-$starttime)); +} + +sub load_cache_item { + my ($cache,$name,$id)=@_; + if ($disk_caching_disabled) { return; } + my $starttime=&Time::HiRes::time(); +# &logthis("Before Loading $name for $id size is ".scalar(%$cache)); + my %hash; + my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db"; + open(DB,"$filename.lock"); + flock(DB,LOCK_SH); + if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) { + eval <<'EVALBLOCK'; + if (!%$cache) { + my $count; + while (my ($key,$value)=each(%hash)) { + $count++; + if ($key =~ /\.time$/) { + $$cache{$key}=$value; + } else { + my $hashref=thaw($value); + $$cache{$key}=$hashref->{'item'}; + } + } +# &logthis("Initial load: $count"); + } else { + my $hashref=thaw($hash{$id}); + $$cache{$id}=$hashref->{'item'}; + $$cache{$id.'.time'}=$hash{$id.'.time'}; + } +EVALBLOCK + if ($@) { + &logthis("load_cache blew up :$@:$name"); + unlink($filename); + } + } else { + if (-e $filename) { + &logthis("Unable to tie hash (load cache item): $name ($!)"); + unlink($filename); + } + } + untie(%hash); + flock(DB,LOCK_UN); + close(DB); +# &logthis("After Loading $name size is ".scalar(%$cache)); +# &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime)); +} + sub usection { my ($udom,$unam,$courseid)=@_; + my $hashid="$udom:$unam:$courseid"; + + my ($result,$cached)=&is_cached(\%usectioncache,$hashid,'usection'); + if (defined($cached)) { return $result; } $courseid=~s/\_/\//g; $courseid=~s/^(\w)/\/$1/; - map { + foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles', + &homeserver($unam,$udom)))) { my ($key,$value)=split(/\=/,$_); $key=&unescape($key); - if ($key=~/^$courseid(?:\/)*(\w+)*\_st$/) { + if ($key=~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/) { my $section=$1; if ($key eq $courseid.'_st') { $section=''; } my ($dummy,$end,$start)=split(/\_/,&unescape($value)); @@ -500,11 +981,12 @@ sub usection { if ($end) { if ($now>$end) { $notactive=1; } } - unless ($notactive) { return $section; } + unless ($notactive) { + return &do_cache(\%usectioncache,$hashid,$section,'usection'); + } } - } split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles', - &homeserver($unam,$udom))); - return '-1'; + } + return &do_cache(\%usectioncache,$hashid,'-1','usection'); } # ------------------------------------- Read an entry from a user's environment @@ -522,16 +1004,55 @@ sub userenvironment { return %returnhash; } +# -------------------------------------------------------------------- New chat + +sub chatsend { + my ($newentry,$anon)=@_; + my $cnum=$ENV{'course.'.$ENV{'request.course.id'}.'.num'}; + my $cdom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}; + my $chome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'}; + &reply('chatsend:'.$cdom.':'.$cnum.':'. + &escape($ENV{'user.domain'}.':'.$ENV{'user.name'}.':'.$anon.':'. + &escape($newentry)),$chome); +} + +# ------------------------------------------ Find current version of a resource + +sub getversion { + my $fname=&clutter(shift); + unless ($fname=~/^\/res\//) { return -1; } + return ¤tversion(&filelocation('',$fname)); +} + +sub currentversion { + my $fname=shift; + my ($result,$cached)=&is_cached(\%resversioncache,$fname,'resversion',600); + if (defined($cached)) { return $result; } + 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') { + return -1; + } + my $answer=reply("currentversion:$fname",$home); + if (($answer eq 'con_lost') || ($answer eq 'rejected')) { + return -1; + } + return &do_cache(\%resversioncache,$fname,$answer,'resversion'); +} + # ----------------------------- Subscribe to a resource, return URL if possible sub subscribe { my $fname=shift; + if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; } 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'; + if ($home eq 'no_host') { + return 'not_found'; } my $answer=reply("sub:$fname",$home); if (($answer eq 'con_lost') || ($answer eq 'rejected')) { @@ -545,6 +1066,7 @@ sub subscribe { 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); @@ -552,7 +1074,7 @@ sub repcopy { &logthis("Subscribe returned $remoteurl: $filename"); return HTTP_SERVICE_UNAVAILABLE; } elsif ($remoteurl eq 'not_found') { - &logthis("Subscribe returned not_found: $filename"); + #&logthis("Subscribe returned not_found: $filename"); return HTTP_NOT_FOUND; } elsif ($remoteurl =~ /^rejected by/) { &logthis("Subscribe returned $remoteurl: $filename"); @@ -560,6 +1082,11 @@ sub repcopy { } elsif ($remoteurl eq 'directory') { return OK; } else { + my $author=$filename; + $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; + my ($udom,$uname)=split(/\//,$author); + my $home=homeserver($uname,$udom); + unless ($home eq $perlvar{'lonHostID'}) { my @parts=split(/\//,$filename); my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]"; if ($path ne "$perlvar{'lonDocRoot'}/res") { @@ -595,9 +1122,22 @@ sub repcopy { rename($transname,$filename); return OK; } + } } } +# ------------------------------------------------ Get server side include body +sub ssi_body { + my ($filelink,%form)=@_; + my $output=($filelink=~/^http\:/?&externalssi($filelink): + &ssi($filelink,%form)); + $output=~s/^.*?\]*\>//si; + $output=~s/(.*)\<\/body\s*\>.*?$/$1/si; + $output=~ + s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs; + return $output; +} + # --------------------------------------------------------- Server Side Include sub ssi { @@ -610,7 +1150,7 @@ sub ssi { if (%form) { $request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn); - $request->content(join '&', map { "$_=$form{$_}" } keys %form); + $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form)); } else { $request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn); } @@ -621,6 +1161,205 @@ sub ssi { return $response->content; } +sub externalssi { + my ($url)=@_; + my $ua=new LWP::UserAgent; + my $request=new HTTP::Request('GET',$url); + my $response=$ua->request($request); + return $response->content; +} + +# -------------------------------- Allow a /uploaded/ URI to be vouched for + +sub allowuploaded { + my ($srcurl,$url)=@_; + $url=&clutter(&declutter($url)); + my $dir=$url; + $dir=~s/\/[^\/]+$//; + my %httpref=(); + my $httpurl=&hreflocation('',$url); + $httpref{'httpref.'.$httpurl}=$srcurl; + &Apache::lonnet::appenv(%httpref); +} + +sub tokenwrapper { + &FIXME_blow_up; +} + +# --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course +# input: action, courseID, current domain, home server for course, intended +# path to file, source of file. +# output: url to file (if action was uploaddoc), +# ok if successful, or diagnostic message otherwise (if action was propagate or copy) +# +# Allows directory structure to be used within lonUsers/../userfiles/ for a +# course. +# +# action = propagate - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file +# will be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles in +# course's home server. +# +# action = copy - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file will +# be copied from $source (current location) to +# /home/httpd/html/userfiles/$domain/1/2/3/$course/$file +# and will then be copied to +# /home/httpd/lonUsers/$domain/1/2/3/$course/userfiles/$file in +# course's home server. +# +# action = uploaddoc - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file +# will be retrived from $ENV{form.uploaddoc} (from DOCS interface) to +# /home/httpd/html/userfiles/$domain/1/2/3/$course/$file +# and will then be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles/$file +# in course's home server. + + +sub process_coursefile { + my ($action,$docuname,$docudom,$docuhome,$file,$source)=@_; + my $fetchresult; + if ($action eq 'propagate') { + $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file + ,$docuhome); + } else { + my $fetchresult = ''; + my $fpath = ''; + my $fname = $file; + ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|); + $fpath=$docudom.'/'.$docuname.'/'.$fpath; + my $filepath=$perlvar{'lonDocRoot'}.'/userfiles'; + unless ($fpath eq '') { + my @parts=split('/',$fpath); + foreach my $part (@parts) { + $filepath.= '/'.$part; + if ((-e $filepath)!=1) { + mkdir($filepath,0777); + } + } + } + if ($action eq 'copy') { + if ($source eq '') { + $fetchresult = 'no source file'; + return $fetchresult; + } else { + my $destination = $filepath.'/'.$fname; + rename($source,$destination); + $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, + $docuhome); + } + } elsif ($action eq 'uploaddoc') { + open(my $fh,'>'.$filepath.'/'.$fname); + print $fh $ENV{'form.'.$source}; + close($fh); + $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, + $docuhome); + if ($fetchresult eq 'ok') { + return '/uploaded/'.$fpath.'/'.$fname; + } else { + &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file. + ' to host '.$docuhome.': '.$fetchresult); + return '/adm/notfound.html'; + } + } + } + unless ( $fetchresult eq 'ok') { + &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file. + ' to host '.$docuhome.': '.$fetchresult); + } + return $fetchresult; +} + +# --------------- Take an uploaded file and put it into the userfiles directory +# input: name of form element, coursedoc=1 means this is for the course +# output: url of file in userspace + +sub userfileupload { + my ($formname,$coursedoc,$subdir)=@_; + if (!defined($subdir)) { $subdir='unknown'; } + my $fname=$ENV{'form.'.$formname.'.filename'}; +# Replace Windows backslashes by forward slashes + $fname=~s/\\/\//g; +# Get rid of everything but the actual filename + $fname=~s/^.*\/([^\/]+)$/$1/; +# Replace spaces by underscores + $fname=~s/\s+/\_/g; +# Replace all other weird characters by nothing + $fname=~s/[^\w\.\-]//g; +# See if there is anything left + unless ($fname) { return 'error: no uploaded file'; } + chop($ENV{'form.'.$formname}); +# Create the directory if not present + my $docuname=''; + my $docudom=''; + my $docuhome=''; + $fname="$subdir/$fname"; + if ($coursedoc) { + $docuname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'}; + $docudom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}; + $docuhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'}; + if ($ENV{'form.folder'} =~ m/^default/) { + return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname); + } else { + $fname=$ENV{'form.folder'}.'/'.$fname; + return &process_coursefile('uploaddoc',$docuname,$docudom,$docuhome,$fname,$formname); + } + } else { + $docuname=$ENV{'user.name'}; + $docudom=$ENV{'user.domain'}; + $docuhome=$ENV{'user.home'}; + return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname); + } +} + +sub finishuserfileupload { + my ($docuname,$docudom,$docuhome,$formname,$fname)=@_; + my $path=$docudom.'/'.$docuname.'/'; + my $filepath=$perlvar{'lonDocRoot'}; + my ($fnamepath,$file); + $file=$fname; + if ($fname=~m|/|) { + ($fnamepath,$file) = ($fname =~ m|^(.*)/([^/]+)$|); + $path.=$fnamepath.'/'; + } + my @parts=split(/\//,$filepath.'/userfiles/'.$path); + my $count; + for ($count=4;$count<=$#parts;$count++) { + $filepath.="/$parts[$count]"; + if ((-e $filepath)!=1) { + mkdir($filepath,0777); + } + } +# Save the file + { + &Apache::lonnet::logthis("Saving to $filepath $file"); + open(my $fh,'>'.$filepath.'/'.$file); + print $fh $ENV{'form.'.$formname}; + close($fh); + } +# Notify homeserver to grep it +# + my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome); + if ($fetchresult eq 'ok') { +# +# Return the URL to it + return '/uploaded/'.$path.$file; + } else { + &logthis('Failed to transfer '.$path.$file.' to host '.$docuhome. + ': '.$fetchresult); + return '/adm/notfound.html'; + } +} + +sub removeuploadedurl { + my ($url)=@_; + my (undef,undef,$udom,$uname,$fname)=split('/',$url,5); + return &Apache::lonnet::removeuserfile($uname,$udom,$fname); +} + +sub removeuserfile { + my ($docuname,$docudom,$fname)=@_; + my $home=&homeserver($docuname,$docudom); + return &reply("removeuserfile:$docudom/$docuname/$fname",$home); +} + # ------------------------------------------------------------------------- Log sub log { @@ -628,6 +1367,366 @@ sub log { return critical("log:$dom:$nam:$what",$hom); } +# ------------------------------------------------------------------ Course Log +# +# This routine flushes several buffers of non-mission-critical nature +# + +sub flushcourselogs { + &logthis('Flushing log buffers'); +# +# course logs +# This is a log of all transactions in a course, which can be used +# for data mining purposes +# +# It also collects the courseid database, which lists last transaction +# times and course titles for all courseids +# + my %courseidbuffer=(); + foreach (keys %courselogs) { + my $crsid=$_; + if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$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}; + } + } + if ($courseidbuffer{$coursehombuf{$crsid}}) { + $courseidbuffer{$coursehombuf{$crsid}}.='&'. + &escape($crsid).'='.&escape($coursedescrbuf{$crsid}); + } else { + $courseidbuffer{$coursehombuf{$crsid}}= + &escape($crsid).'='.&escape($coursedescrbuf{$crsid}); + } + } +# +# Write course id database (reverse lookup) to homeserver of courses +# Is used in pickcourse +# + foreach (keys %courseidbuffer) { + &courseidput($hostdom{$_},$courseidbuffer{$_},$_); + } +# +# File accesses +# Writes to the dynamic metadata of resources to get hit counts, etc. +# + foreach my $entry (keys(%accesshash)) { + if ($entry =~ /___count$/) { + my ($dom,$name); + ($dom,$name,undef)=($entry=~m:___(\w+)/(\w+)/(.*)___count$:); + if (! defined($dom) || $dom eq '' || + ! defined($name) || $name eq '') { + my $cid = $ENV{'request.course.id'}; + $dom = $ENV{'request.'.$cid.'.domain'}; + $name = $ENV{'request.'.$cid.'.num'}; + } + my $value = $accesshash{$entry}; + my (undef,$url,undef) = ($entry =~ /^(.*)___(.*)___count$/); + my %temphash=($url => $value); + my $result = &inc('nohist_accesscount',\%temphash,$dom,$name); + if ($result eq 'ok') { + delete $accesshash{$entry}; + } elsif ($result eq 'unknown_cmd') { + # Target server has old code running on it. + my %temphash=($entry => $value); + if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') { + delete $accesshash{$entry}; + } + } + } else { + my ($dom,$name) = ($entry=~m:___(\w+)/(\w+)/(.*)___(\w+)$:); + my %temphash=($entry => $accesshash{$entry}); + if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') { + delete $accesshash{$entry}; + } + } + } +# +# Roles +# Reverse lookup of user roles for course faculty/staff and co-authorship +# + foreach (keys %userrolehash) { + my $entry=$_; + my ($role,$uname,$udom,$runame,$rudom,$rsec)= + split(/\:/,$entry); + if (&Apache::lonnet::put('nohist_userroles', + { $role.':'.$uname.':'.$udom.':'.$rsec => $userrolehash{$entry} }, + $rudom,$runame) eq 'ok') { + delete $userrolehash{$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'}; + $coursenumbuf{$ENV{'request.course.id'}}= + $ENV{'course.'.$ENV{'request.course.id'}.'.num'}; + $coursehombuf{$ENV{'request.course.id'}}= + $ENV{'course.'.$ENV{'request.course.id'}.'.home'}; + $coursedescrbuf{$ENV{'request.course.id'}}= + $ENV{'course.'.$ENV{'request.course.id'}.'.description'}; + 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|page)$/) { + $what.=':POST'; + foreach (keys %ENV) { + if ($_=~/^form\.(.*)/) { + $what.=':'.$1.'='.$ENV{$_}; + } + } + } + &courselog($what); +} + +sub countacc { + my $url=&declutter(shift); + return if (! defined($url) || $url eq ''); + unless ($ENV{'request.course.id'}) { return ''; } + $accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1; + my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count'; + $accesshash{$key}++; +} + +sub linklog { + my ($from,$to)=@_; + $from=&declutter($from); + $to=&declutter($to); + $accesshash{$from.'___'.$to.'___comefrom'}=1; + $accesshash{$to.'___'.$from.'___goto'}=1; +} + +sub userrolelog { + my ($trole,$username,$domain,$area,$tstart,$tend)=@_; + if (($trole=~/^ca/) || ($trole=~/^in/) || + ($trole=~/^cc/) || ($trole=~/^ep/) || + ($trole=~/^cr/) || ($trole=~/^ta/)) { + my (undef,$rudom,$runame,$rsec)=split(/\//,$area); + $userrolehash + {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} + =$tend.':'.$tstart; + } +} + +sub get_course_adv_roles { + my $cid=shift; + $cid=$ENV{'request.course.id'} unless (defined($cid)); + my %coursehash=&coursedescription($cid); + my %nothide=(); + foreach (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { + $nothide{join(':',split(/[\@\:]/,$_))}=1; + } + my %returnhash=(); + my %dumphash= + &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'}); + my $now=time; + foreach (keys %dumphash) { + my ($tend,$tstart)=split(/\:/,$dumphash{$_}); + if (($tstart) && ($tstart<0)) { next; } + if (($tend) && ($tend<$now)) { next; } + if (($tstart) && ($now<$tstart)) { next; } + my ($role,$username,$domain,$section)=split(/\:/,$_); + if ((&privileged($username,$domain)) && + (!$nothide{$username.':'.$domain})) { next; } + my $key=&plaintext($role); + if ($section) { $key.=' (Sec/Grp '.$section.')'; } + if ($returnhash{$key}) { + $returnhash{$key}.=','.$username.':'.$domain; + } else { + $returnhash{$key}=$username.':'.$domain; + } + } + return %returnhash; +} + +sub get_my_roles { + my ($uname,$udom)=@_; + unless (defined($uname)) { $uname=$ENV{'user.name'}; } + unless (defined($udom)) { $udom=$ENV{'user.domain'}; } + my %dumphash= + &dump('nohist_userroles',$udom,$uname); + my %returnhash=(); + my $now=time; + foreach (keys %dumphash) { + my ($tend,$tstart)=split(/\:/,$dumphash{$_}); + if (($tstart) && ($tstart<0)) { next; } + if (($tend) && ($tend<$now)) { next; } + if (($tstart) && ($now<$tstart)) { next; } + my ($role,$username,$domain,$section)=split(/\:/,$_); + $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend; + } + return %returnhash; +} + +# ----------------------------------------------------- Frontpage Announcements +# +# + +sub postannounce { + my ($server,$text)=@_; + unless (&allowed('psa',$hostdom{$server})) { return 'refused'; } + unless ($text=~/\w/) { $text=''; } + return &reply('setannounce:'.&escape($text),$server); +} + +sub getannounce { + + if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) { + my $announcement=''; + while (<$fh>) { $announcement .=$_; } + close($fh); + if ($announcement=~/\w/) { + return + ''. + '
'.$announcement.'
'; + } else { + return ''; + } + } else { + return ''; + } +} + +# ---------------------------------------------------------- Course ID routines +# Deal with domain's nohist_courseid.db files +# + +sub courseidput { + my ($domain,$what,$coursehome)=@_; + return &reply('courseidput:'.$domain.':'.$what,$coursehome); +} + +sub courseiddump { + my ($domfilter,$descfilter,$sincefilter)=@_; + my %returnhash=(); + unless ($domfilter) { $domfilter=''; } + foreach my $tryserver (keys %libserv) { + if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) { + foreach ( + split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. + $sincefilter.':'.&escape($descfilter), + $tryserver))) { + my ($key,$value)=split(/\=/,$_); + if (($key) && ($value)) { + $returnhash{&unescape($key)}=&unescape($value); + } + } + + } + } + return %returnhash; +} + +# +# ----------------------------------------------------------- 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 { @@ -648,94 +1747,451 @@ sub expirespread { # ----------------------------------------------------- Devalidate Spreadsheets sub devalidate { - my $symb=shift; + my ($symb,$uname,$udom)=@_; my $cid=$ENV{'request.course.id'}; if ($cid) { - my $key=$ENV{'user.name'}.':'.$ENV{'user.domain'}.':'; + # delete the stored spreadsheets for + # - the student level sheet of this user in course's homespace + # - the assessment level sheet for this resource + # for this user in user's homespace + my $key=$uname.':'.$udom.':'; my $status= - &reply('del:'.$ENV{'course.'.$cid.'.domain'}.':'. - $ENV{'course.'.$cid.'.num'}. - ':nohist_calculatedsheets:'. - &escape($key.'studentcalc:'), - $ENV{'course.'.$cid.'.home'}) - .' '. - &reply('del:'.$ENV{'user.domain'}.':'. - $ENV{'user.name'}. - ':nohist_calculatedsheets_'.$cid.':'. - &escape($key.'assesscalc:'.$symb), - $ENV{'user.home'}); + &del('nohist_calculatedsheets', + [$key.'studentcalc:'], + $ENV{'course.'.$cid.'.domain'}, + $ENV{'course.'.$cid.'.num'}) + .' '. + &del('nohist_calculatedsheets_'.$cid, + [$key.'assesscalc:'.$symb],$udom,$uname); unless ($status eq 'ok ok') { &logthis('Could not devalidate spreadsheet '. - $ENV{'user.name'}.' at '.$ENV{'user.domain'}.' for '. + $uname.' at '.$udom.' for '. $symb.': '.$status); - } + } + } +} + +sub get_scalar { + my ($string,$end) = @_; + my $value; + if ($$string =~ s/^([^&]*?)($end)/$2/) { + $value = $1; + } elsif ($$string =~ s/^([^&]*?)&//) { + $value = $1; + } + return &unescape($value); +} + +sub array2str { + my (@array) = @_; + my $result=&arrayref2str(\@array); + $result=~s/^__ARRAY_REF__//; + $result=~s/__END_ARRAY_REF__$//; + return $result; +} + +sub arrayref2str { + my ($arrayref) = @_; + my $result='__ARRAY_REF__'; + foreach my $elem (@$arrayref) { + if(ref($elem) eq 'ARRAY') { + $result.=&arrayref2str($elem).'&'; + } elsif(ref($elem) eq 'HASH') { + $result.=&hashref2str($elem).'&'; + } elsif(ref($elem)) { + #print("Got a ref of ".(ref($elem))." skipping."); + } else { + $result.=&escape($elem).'&'; + } + } + $result=~s/\&$//; + $result .= '__END_ARRAY_REF__'; + return $result; +} + +sub hash2str { + my (%hash) = @_; + my $result=&hashref2str(\%hash); + $result=~s/^__HASH_REF__//; + $result=~s/__END_HASH_REF__$//; + return $result; +} + +sub hashref2str { + my ($hashref)=@_; + my $result='__HASH_REF__'; + foreach (sort(keys(%$hashref))) { + if (ref($_) eq 'ARRAY') { + $result.=&arrayref2str($_).'='; + } elsif (ref($_) eq 'HASH') { + $result.=&hashref2str($_).'='; + } elsif (ref($_)) { + $result.='='; + #print("Got a ref of ".(ref($_))." skipping."); + } else { + if ($_) {$result.=&escape($_).'=';} else { last; } + } + + if(ref($hashref->{$_}) eq 'ARRAY') { + $result.=&arrayref2str($hashref->{$_}).'&'; + } elsif(ref($hashref->{$_}) eq 'HASH') { + $result.=&hashref2str($hashref->{$_}).'&'; + } elsif(ref($hashref->{$_})) { + $result.='&'; + #print("Got a ref of ".(ref($hashref->{$_}))." skipping."); + } else { + $result.=&escape($hashref->{$_}).'&'; + } + } + $result=~s/\&$//; + $result .= '__END_HASH_REF__'; + return $result; +} + +sub str2hash { + my ($string)=@_; + my ($hash)=&str2hashref('__HASH_REF__'.$string.'__END_HASH_REF__'); + return %$hash; +} + +sub str2hashref { + my ($string) = @_; + + my %hash; + + if($string !~ /^__HASH_REF__/) { + if (! ($string eq '' || !defined($string))) { + $hash{'error'}='Not hash reference'; + } + return (\%hash, $string); + } + + $string =~ s/^__HASH_REF__//; + + while($string !~ /^__END_HASH_REF__/) { + #key + my $key=''; + if($string =~ /^__HASH_REF__/) { + ($key, $string)=&str2hashref($string); + if(defined($key->{'error'})) { + $hash{'error'}='Bad data'; + return (\%hash, $string); + } + } elsif($string =~ /^__ARRAY_REF__/) { + ($key, $string)=&str2arrayref($string); + if($key->[0] eq 'Array reference error') { + $hash{'error'}='Bad data'; + return (\%hash, $string); + } + } else { + $string =~ s/^(.*?)=//; + $key=&unescape($1); + } + $string =~ s/^=//; + + #value + my $value=''; + if($string =~ /^__HASH_REF__/) { + ($value, $string)=&str2hashref($string); + if(defined($value->{'error'})) { + $hash{'error'}='Bad data'; + return (\%hash, $string); + } + } elsif($string =~ /^__ARRAY_REF__/) { + ($value, $string)=&str2arrayref($string); + if($value->[0] eq 'Array reference error') { + $hash{'error'}='Bad data'; + return (\%hash, $string); + } + } else { + $value=&get_scalar(\$string,'__END_HASH_REF__'); + } + $string =~ s/^&//; + + $hash{$key}=$value; + } + + $string =~ s/^__END_HASH_REF__//; + + return (\%hash, $string); +} + +sub str2array { + my ($string)=@_; + my ($array)=&str2arrayref('__ARRAY_REF__'.$string.'__END_ARRAY_REF__'); + return @$array; +} + +sub str2arrayref { + my ($string) = @_; + my @array; + + if($string !~ /^__ARRAY_REF__/) { + if (! ($string eq '' || !defined($string))) { + $array[0]='Array reference error'; + } + return (\@array, $string); + } + + $string =~ s/^__ARRAY_REF__//; + + while($string !~ /^__END_ARRAY_REF__/) { + my $value=''; + if($string =~ /^__HASH_REF__/) { + ($value, $string)=&str2hashref($string); + if(defined($value->{'error'})) { + $array[0] ='Array reference error'; + return (\@array, $string); + } + } elsif($string =~ /^__ARRAY_REF__/) { + ($value, $string)=&str2arrayref($string); + if($value->[0] eq 'Array reference error') { + $array[0] ='Array reference error'; + return (\@array, $string); + } + } else { + $value=&get_scalar(\$string,'__END_ARRAY_REF__'); + } + $string =~ s/^&//; + + push(@array, $value); + } + + $string =~ s/^__END_ARRAY_REF__//; + + return (\@array, $string); +} + +# -------------------------------------------------------------------Temp Store + +sub tmpreset { + my ($symb,$namespace,$domain,$stuname) = @_; + if (!$symb) { + $symb=&symbread(); + if (!$symb) { $symb= $ENV{'request.url'}; } + } + $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=@_; - my $symb; - unless ($symb=&symbread()) { return ''; } + 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); + if (!$domain) { $domain=$ENV{'user.domain'}; } + if (!$stuname) { $stuname=$ENV{'user.name'}; } + + &devalidate($symb,$stuname,$domain); $symb=escape($symb); - my $namespace; - unless ($namespace=$ENV{'request.course.id'}) { return ''; } + if (!$namespace) { + unless ($namespace=$ENV{'request.course.id'}) { + return ''; + } + } + if (!$home) { $home=$ENV{'user.home'}; } + + $$storehash{'ip'}=$ENV{'REMOTE_ADDR'}; + $$storehash{'host'}=$perlvar{'lonHostID'}; + my $namevalue=''; - map { - $namevalue.=escape($_).'='.escape($storehash{$_}).'&'; - } keys %storehash; + foreach (keys %$storehash) { + $namevalue.=escape($_).'='.escape($$storehash{$_}).'&'; + } $namevalue=~s/\&$//; - return reply( - "store:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$symb:$namevalue", - "$ENV{'user.home'}"); + &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue); + return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home"); } # -------------------------------------------------------------- Critical Store sub cstore { - my %storehash=@_; - my $symb; - unless ($symb=&symbread()) { return ''; } + 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); + if (!$domain) { $domain=$ENV{'user.domain'}; } + if (!$stuname) { $stuname=$ENV{'user.name'}; } + + &devalidate($symb,$stuname,$domain); $symb=escape($symb); - my $namespace; - unless ($namespace=$ENV{'request.course.id'}) { return ''; } + if (!$namespace) { + unless ($namespace=$ENV{'request.course.id'}) { + return ''; + } + } + if (!$home) { $home=$ENV{'user.home'}; } + + $$storehash{'ip'}=$ENV{'REMOTE_ADDR'}; + $$storehash{'host'}=$perlvar{'lonHostID'}; + my $namevalue=''; - map { - $namevalue.=escape($_).'='.escape($storehash{$_}).'&'; - } keys %storehash; + foreach (keys %$storehash) { + $namevalue.=escape($_).'='.escape($$storehash{$_}).'&'; + } $namevalue=~s/\&$//; - return critical( - "store:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$symb:$namevalue", - "$ENV{'user.home'}"); + &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue); + return critical + ("store:$domain:$stuname:$namespace:$symb:$namevalue","$home"); } # --------------------------------------------------------------------- Restore sub restore { - my $symb; - unless ($symb=escape(&symbread())) { return ''; } - my $namespace; - unless ($namespace=$ENV{'request.course.id'}) { return ''; } - my $answer=reply( - "restore:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$symb", - "$ENV{'user.home'}"); + 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=(); - map { + foreach (split(/\&/,$answer)) { my ($name,$value)=split(/\=/,$_); $returnhash{&unescape($name)}=&unescape($value); - } split(/\&/,$answer); + } my $version; for ($version=1;$version<=$returnhash{'version'};$version++) { - map { + foreach (split(/\:/,$returnhash{$version.':keys'})) { $returnhash{$_}=$returnhash{$version.':'.$_}; - } split(/\:/,$returnhash{$version.':keys'}); + } } return %returnhash; } @@ -747,34 +2203,62 @@ sub coursedescription { $courseid=~s/^\///; $courseid=~s/\_/\//g; my ($cdomain,$cnum)=split(/\//,$courseid); - my $chome=homeserver($cnum,$cdomain); + my $chome=&homeserver($cnum,$cdomain); + my $normalid=$cdomain.'_'.$cnum; + # need to always cache even if we get errors otherwise we keep + # trying and trying and trying to get the course description. + my %envhash=(); + my %returnhash=(); + $envhash{'course.'.$normalid.'.last_cache'}=time; if ($chome ne 'no_host') { - my $rep=reply("dump:$cdomain:$cnum:environment",$chome); - if ($rep ne 'con_lost') { - my $normalid=$cdomain.'_'.$cnum; - my %envhash=(); - my %returnhash=('home' => $chome, - 'domain' => $cdomain, - 'num' => $cnum); - map { - my ($name,$value)=split(/\=/,$_); - $name=&unescape($name); - $value=&unescape($value); - $returnhash{$name}=$value; + %returnhash=&dump('environment',$cdomain,$cnum); + if (!exists($returnhash{'con_lost'})) { + $returnhash{'home'}= $chome; + $returnhash{'domain'} = $cdomain; + $returnhash{'num'} = $cnum; + while (my ($name,$value) = each %returnhash) { $envhash{'course.'.$normalid.'.'.$name}=$value; - } split(/\&/,$rep); - $returnhash{'url'}='/res/'.declutter($returnhash{'url'}); + } + $returnhash{'url'}=&clutter($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 (); + &appenv(%envhash); + return %returnhash; +} + +# -------------------------------------------------See if a user is privileged + +sub privileged { + my ($username,$domain)=@_; + my $rolesdump=&reply("dump:$domain:$username:roles", + &homeserver($username,$domain)); + if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return 0; } + my $now=time; + if ($rolesdump ne '') { + foreach (split(/&/,$rolesdump)) { + if ($_!~/^rolesdef\&/) { + my ($area,$role)=split(/=/,$_); + $area=~s/\_\w\w$//; + my ($trole,$tend,$tstart)=split(/_/,$role); + if (($trole eq 'dc') || ($trole eq 'su')) { + my $active=1; + if ($tend) { + if ($tend<$now) { $active=0; } + } + if ($tstart) { + if ($tstart>$now) { $active=0; } + } + if ($active) { return 1; } + } + } + } + } + return 0; } # -------------------------------------------------------- Get user privileges @@ -790,13 +2274,15 @@ sub rolesinit { my $thesestr; if ($rolesdump ne '') { - map { + 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"; +# log the associated role with the area + &userrolelog($trole,$username,$domain,$area,$tstart,$tend); if ($tend!=0) { if ($tend<$now) { $trole=''; @@ -808,48 +2294,64 @@ sub rolesinit { } } 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 $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 ($rdummy,$roledef)= + &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor); + + if (($rdummy ne 'con_lost') && ($roledef ne '')) { + my ($syspriv,$dompriv,$coursepriv)= + split(/\_/,$roledef); + if (defined($syspriv)) { + $allroles{'cm./'}.=':'.$syspriv; + $allroles{$spec.'./'}.=':'.$syspriv; + } + if ($tdomain ne '') { + if (defined($dompriv)) { + $allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv; + $allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv; + } + if ($trest ne '') { + if (defined($coursepriv)) { + $allroles{'cm.'.$area}.=':'.$coursepriv; + $allroles{$spec.'.'.$area}.=':'.$coursepriv; + } + } + } + } + } + } else { + if (defined($pr{$trole.':s'})) { + $allroles{'cm./'}.=':'.$pr{$trole.':s'}; + $allroles{$spec.'./'}.=':'.$pr{$trole.':s'}; + } + if ($tdomain ne '') { + if (defined($pr{$trole.':d'})) { + $allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'}; + $allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'}; + } + if ($trest ne '') { + if (defined($pr{$trole.':c'})) { + $allroles{'cm.'.$area}.=':'.$pr{$trole.':c'}; + $allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'}; + } + } + } + } } } - } split(/&/,$rolesdump); - map { + } + my $adv=0; + my $author=0; + foreach (keys %allroles) { %thesepriv=(); - map { + if (($_!~/^st/) && ($_!~/^ta/) && ($_!~/^cm/)) { $adv=1; } + if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; } + foreach (split(/:/,$allroles{$_})) { if ($_ ne '') { my ($privilege,$restrictions)=split(/&/,$_); if ($restrictions eq '') { @@ -860,11 +2362,14 @@ sub rolesinit { } } } - } split(/:/,$allroles{$_}); + } $thesestr=''; - map { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } keys %thesepriv; + foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } $userroles.='user.priv.'.$_.'='.$thesestr."\n"; - } keys %allroles; + } + $userroles.='user.adv='.$adv."\n". + 'user.author='.$author."\n"; + $ENV{'user.adv'}=$adv; } return $userroles; } @@ -872,126 +2377,318 @@ sub rolesinit { # --------------------------------------------------------------- get interface sub get { - my ($namespace,@storearr)=@_; + my ($namespace,$storearr,$udomain,$uname)=@_; my $items=''; - map { + foreach (@$storearr) { $items.=escape($_).'&'; - } @storearr; + } $items=~s/\&$//; - my $rep=reply("get:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items", - $ENV{'user.home'}); + 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); + if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) { + return @pairs; + } my %returnhash=(); my $i=0; - map { + foreach (@$storearr) { $returnhash{$_}=unescape($pairs[$i]); $i++; - } @storearr; + } return %returnhash; } # --------------------------------------------------------------- del interface sub del { - my ($namespace,@storearr)=@_; + my ($namespace,$storearr,$udomain,$uname)=@_; my $items=''; - map { + foreach (@$storearr) { $items.=escape($_).'&'; - } @storearr; + } $items=~s/\&$//; - return reply("del:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items", - $ENV{'user.home'}); + 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=shift; - my $rep=reply("dump:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace", - $ENV{'user.home'}); + 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=(); - map { + foreach (@pairs) { my ($key,$value)=split(/=/,$_); $returnhash{unescape($key)}=unescape($value); - } @pairs; + } + return %returnhash; +} + +# -------------------------------------------------------------- keys interface + +sub getkeys { + my ($namespace,$udomain,$uname)=@_; + if (!$udomain) { $udomain=$ENV{'user.domain'}; } + if (!$uname) { $uname=$ENV{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); + my $rep=reply("keys:$udomain:$uname:$namespace",$uhome); + my @keyarray=(); + foreach (split(/\&/,$rep)) { + push (@keyarray,&unescape($_)); + } + return @keyarray; +} + +# --------------------------------------------------------------- currentdump +sub currentdump { + my ($courseid,$sdom,$sname)=@_; + $courseid = $ENV{'request.course.id'} if (! defined($courseid)); + $sdom = $ENV{'user.domain'} if (! defined($sdom)); + $sname = $ENV{'user.name'} if (! defined($sname)); + my $uhome = &homeserver($sname,$sdom); + my $rep=reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome); + return if ($rep =~ /^(error:|no_such_host)/); + # + my %returnhash=(); + # + if ($rep eq "unknown_cmd") { + # an old lond will not know currentdump + # Do a dump and make it look like a currentdump + my @tmp = &dump($courseid,$sdom,$sname,'.'); + return if ($tmp[0] =~ /^(error:|no_such_host)/); + my %hash = @tmp; + @tmp=(); + %returnhash = %{&convert_dump_to_currentdump(\%hash)}; + } else { + my @pairs=split(/\&/,$rep); + foreach (@pairs) { + my ($key,$value)=split(/=/,$_); + my ($symb,$param) = split(/:/,$key); + $returnhash{&unescape($symb)}->{&unescape($param)} = + &unescape($value); + } + } return %returnhash; } +sub convert_dump_to_currentdump{ + my %hash = %{shift()}; + my %returnhash; + # Code ripped from lond, essentially. The only difference + # here is the unescaping done by lonnet::dump(). Conceivably + # we might run in to problems with parameter names =~ /^v\./ + while (my ($key,$value) = each(%hash)) { + my ($v,$symb,$param) = split(/:/,$key); + next if ($v eq 'version' || $symb eq 'keys'); + next if (exists($returnhash{$symb}) && + exists($returnhash{$symb}->{$param}) && + $returnhash{$symb}->{'v.'.$param} > $v); + $returnhash{$symb}->{$param}=$value; + $returnhash{$symb}->{'v.'.$param}=$v; + } + # + # Remove all of the keys in the hashes which keep track of + # the version of the parameter. + while (my ($symb,$param_hash) = each(%returnhash)) { + # use a foreach because we are going to delete from the hash. + foreach my $key (keys(%$param_hash)) { + delete($param_hash->{$key}) if ($key =~ /^v\./); + } + } + return \%returnhash; +} + +# --------------------------------------------------------------- inc interface + +sub inc { + my ($namespace,$store,$udomain,$uname) = @_; + if (!$udomain) { $udomain=$ENV{'user.domain'}; } + if (!$uname) { $uname=$ENV{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); + my $items=''; + if (! ref($store)) { + # got a single value, so use that instead + $items = &escape($store).'=&'; + } elsif (ref($store) eq 'SCALAR') { + $items = &escape($$store).'=&'; + } elsif (ref($store) eq 'ARRAY') { + $items = join('=&',map {&escape($_);} @{$store}); + } elsif (ref($store) eq 'HASH') { + while (my($key,$value) = each(%{$store})) { + $items.= &escape($key).'='.&escape($value).'&'; + } + } + $items=~s/\&$//; + return &reply("inc:$udomain:$uname:$namespace:$items",$uhome); +} + # --------------------------------------------------------------- put interface sub put { - my ($namespace,%storehash)=@_; + my ($namespace,$storehash,$udomain,$uname)=@_; + if (!$udomain) { $udomain=$ENV{'user.domain'}; } + if (!$uname) { $uname=$ENV{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); my $items=''; - map { - $items.=escape($_).'='.escape($storehash{$_}).'&'; - } keys %storehash; + foreach (keys %$storehash) { + $items.=&escape($_).'='.&escape($$storehash{$_}).'&'; + } $items=~s/\&$//; - return reply("put:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items", - $ENV{'user.home'}); + return &reply("put:$udomain:$uname:$namespace:$items",$uhome); } # ------------------------------------------------------ critical put interface sub cput { - my ($namespace,%storehash)=@_; + my ($namespace,$storehash,$udomain,$uname)=@_; + if (!$udomain) { $udomain=$ENV{'user.domain'}; } + if (!$uname) { $uname=$ENV{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); my $items=''; - map { - $items.=escape($_).'='.escape($storehash{$_}).'&'; - } keys %storehash; + foreach (keys %$storehash) { + $items.=escape($_).'='.escape($$storehash{$_}).'&'; + } $items=~s/\&$//; - return critical - ("put:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items", - $ENV{'user.home'}); + return &critical("put:$udomain:$uname:$namespace:$items",$uhome); } # -------------------------------------------------------------- eget interface sub eget { - my ($namespace,@storearr)=@_; + my ($namespace,$storearr,$udomain,$uname)=@_; my $items=''; - map { + foreach (@$storearr) { $items.=escape($_).'&'; - } @storearr; + } $items=~s/\&$//; - my $rep=reply("eget:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items", - $ENV{'user.home'}); + 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; - map { + foreach (@$storearr) { $returnhash{$_}=unescape($pairs[$i]); $i++; - } @storearr; + } return %returnhash; } +# ---------------------------------------------- Custom access rule evaluation + +sub customaccess { + my ($priv,$uri)=@_; + my ($urole,$urealm)=split(/\./,$ENV{'request.role'}); + $urealm=~s/^\W//; + my ($udom,$ucrs,$usec)=split(/\//,$urealm); + my $access=0; + foreach (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) { + my ($effect,$realm,$role)=split(/\:/,$_); + if ($role) { + if ($role ne $urole) { next; } + } + foreach (split(/\s*\,\s*/,$realm)) { + my ($tdom,$tcrs,$tsec)=split(/\_/,$_); + if ($tdom) { + if ($tdom ne $udom) { next; } + } + if ($tcrs) { + if ($tcrs ne $ucrs) { next; } + } + if ($tsec) { + if ($tsec ne $usec) { next; } + } + $access=($effect eq 'allow'); + last; + } + if ($realm eq '' && $role eq '') { + $access=($effect eq 'allow'); + } + } + return $access; +} + # ------------------------------------------------- Check for a user privilege sub allowed { my ($priv,$uri)=@_; + $uri=&deversion($uri); + my $orguri=$uri; $uri=&declutter($uri); + if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; } # 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') && (!$ENV{'request.course.id'})) { + 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 ''; + } + } + if ($ENV{'request.role'}=~ /li\.\//) { + # Library role, so allow browsing of resources in this domain. + return 'F'; + } + if ($copyright eq 'custom') { + unless (&customaccess($priv,$uri)) { return ''; } + } + } + # Domain coordinator is trying to create a course + if (($priv eq 'ccc') && ($ENV{'request.role'} =~ /^dc\./)) { + # uri is the requested domain in this case. + # comparison to 'request.role.domain' shows if the user has selected + # a role of dc for the domain in question. + return 'F' if ($uri eq $ENV{'request.role.domain'}); + } + my $thisallowed=''; my $statecond=0; my $courseprivid=''; # Course - if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'}=~/$priv\&([^\:]*)/) { + if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) { $thisallowed.=$1; } # Domain if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.(split(/\//,$uri))[0].'/'} - =~/$priv\&([^\:]*)/) { + =~/\Q$priv\E\&([^\:]*)/) { $thisallowed.=$1; } @@ -1001,10 +2698,21 @@ sub allowed { $courseuri=~s/^([^\/])/\/$1/; if ($ENV{'user.priv.'.$ENV{'request.role'}.'.'.$courseuri} - =~/$priv\&([^\:]*)/) { + =~/\Q$priv\E\&([^\:]*)/) { $thisallowed.=$1; } +# URI is an uploaded document for this course + + if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) { + my $refuri=$ENV{'httpref.'.$orguri}; + if ($refuri) { + if ($refuri =~ m|^/adm/|) { + $thisallowed='F'; + } + } + } + # Full access at system, domain or course-wide level? Exit. if ($thisallowed=~/F/) { @@ -1013,7 +2721,7 @@ sub allowed { # If this is generating or modifying users, exit with special codes - if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:'=~/\:$priv\:/) { + if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:\Q$priv\E\:/) { return $thisallowed; } # @@ -1023,47 +2731,52 @@ sub allowed { # 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 @uriparts=split(/\//,$uri); - my $filename=$uriparts[$#uriparts]; - my $pathname=$uri; - $pathname=~s/\/$filename$//; - if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ - /\&$filename\:([\d\|]+)\&/) { - $statecond=$1; + my ($match,$cond)=&is_on_map($uri); + if ($match) { + $statecond=$cond; if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} - =~/$priv\&([^\:]*)/) { + =~/\Q$priv\E\&([^\:]*)/) { $thisallowed.=$1; $checkreferer=0; } } - if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) { - my $refuri=$ENV{'HTTP_REFERER'}; - $refuri=~s/^http\:\/\/$ENV{'request.host'}//i; - $refuri=&declutter($refuri); - my @uriparts=split(/\//,$refuri); - my $filename=$uriparts[$#uriparts]; - my $pathname=$refuri; - $pathname=~s/\/$filename$//; - my @filenameparts=split(/\./,$uri); - if (&fileembstyle($filenameparts[$#filenameparts]) ne 'ssi') { - if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ - /\&$filename\:([\d\|]+)\&/) { - my $refstatecond=$1; + 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\&([^\:]*)/) { + =~/\Q$priv\E\&([^\:]*)/) { $thisallowed.=$1; $uri=$refuri; $statecond=$refstatecond; } - } } + } } } @@ -1110,22 +2823,22 @@ sub allowed { if ((time-$ENV{$prefix.'last_cache'})>$expiretime) { &coursedescription($courseid); } - if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,$csec\,/) + if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,\Q$csec\E\,/) || ($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.host'}, + $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\,/) + if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/) || ($ENV{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) { if ($ENV{'priv.'.$priv.'.lock.expire'}>time) { &log($ENV{'user.domain'},$ENV{'user.name'}, - $ENV{'user.host'}, + $ENV{'user.home'}, 'Locked by priv: '.$priv.' for '.$uri.' due to '. $cdom.'/'.$cnum.'/'.$csec.' expire '. $ENV{$prefix.'priv.'.$priv.'.lock.expire'}); @@ -1153,39 +2866,44 @@ sub allowed { 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\,/) { + =~/\Q$rolecode\E/) { &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'} + =~/\Q$unamedom\E/) { + &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)=~ - /\]*\>[^\<]*$rolecode[^\<]*\<\/roledeny\>/) { - &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, + if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) { + &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); - return ''; - - } + return ''; } } -# Restricted by state? +# Restricted by state or randomout? if ($thisallowed=~/X/) { + if ($ENV{'acc.randomout'}) { + my $symb=&symbread($uri,1); + if (($symb) && ($ENV{'acc.randomout'}=~/\&\Q$symb\E\&/)) { + return ''; + } + } if (&condval($statecond)) { return '2'; } else { @@ -1196,38 +2914,81 @@ sub allowed { return 'F'; } +# --------------------------------------------------- Is a resource on the map? + +sub is_on_map { + my $uri=&declutter(shift); + $uri=~s/\.\d+\.(\w+)$/\.$1/; + my @uriparts=split(/\//,$uri); + my $filename=$uriparts[$#uriparts]; + my $pathname=$uri; + $pathname=~s|/\Q$filename\E$||; + $pathname=~s/^adm\/wrapper\///; + #Trying to find the conditional for the file + my $match=($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ + /\&\Q$filename\E\:([\d\|]+)\&/); + if ($match) { + return (1,$1); + } else { + return (0,0); + } +} + +# --------------------------------------------------------- Get symb from alias + +sub get_symb_from_alias { + my $symb=shift; + my ($map,$resid,$url)=&decode_symb($symb); +# Already is a symb + if ($url) { return $symb; } +# Must be an alias + my $aliassymb=''; + my %bighash; + if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', + &GDBM_READER(),0640)) { + my $rid=$bighash{'mapalias_'.$symb}; + if ($rid) { + my ($mapid,$resid)=split(/\./,$rid); + $aliassymb=&encode_symb($bighash{'map_id_'.$mapid}, + $resid,$bighash{'src_'.$rid}); + } + untie %bighash; + } + return $aliassymb; +} + # ----------------------------------------------------------------- Define Role sub definerole { if (allowed('mcr','/')) { my ($rolename,$sysrole,$domrole,$courole)=@_; - map { + 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/) { + if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; } + if ($pr{'cr:s'}=~/\Q$crole\E\&/) { + if ($pr{'cr:s'}!~/\Q$crole\E\&\w*\Q$cqual\E/) { return "refused:s:$crole&$cqual"; } } - } split('/',$sysrole); - map { + } + 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/) { + if ($pr{'cr:d'}!~/\Q$crole\E/) { return "refused:d:$crole"; } + if ($pr{'cr:d'}=~/\Q$crole\E\&/) { + if ($pr{'cr:d'}!~/\Q$crole\W\&\w*\Q$cqual\E/) { return "refused:d:$crole&$cqual"; } } - } split('/',$domrole); - map { + } + 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/) { + if ($pr{'cr:c'}!~/\Q$crole\E/) { return "refused:c:$crole"; } + if ($pr{'cr:c'}=~/\Q$crole\E\&/) { + if ($pr{'cr:c'}!~/\Q$crole\E\&\w*\Q$cqual\E/) { return "refused:c:$crole&$cqual"; } } - } split('/',$courole); + } my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:". "$ENV{'user.domain'}:$ENV{'user.name'}:". "rolesdef_$rolename=". @@ -1241,38 +3002,99 @@ sub definerole { # ---------------- Make a metadata query against the network of library servers sub metadata_query { - my ($query)=@_; - my $reply=&reply("querysend:".&escape($query),'msul3'); + my ($query,$custom,$customshow,$server_array)=@_; + my %rhash; + my @server_list = (defined($server_array) ? @$server_array + : keys(%libserv) ); + for my $server (@server_list) { + 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; } -# ------------------------------------------------------------------ Plain Text +# ----------------------------------------- Send log queries and wait for reply -sub plaintext { - my $short=shift; - return $prp{$short}; +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=~/^\Q$uhost\E\_/) { 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 (open(my $fh,$replyfile)) { + $reply.=<$fh>; + close($fh); + } else { return 'error: reply_file_error'; } + return &unescape($reply); + } + } + return 'timeout:'.$queryid; } -# ------------------------------------------------------------------ Plain Text +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 fileembstyle { - my $ending=shift; - return $fe{$ending}; +sub userlog_query { + my ($uname,$udom,%filters)=@_; + return &log_query($uname,$udom,'userlog',%filters); } -# ------------------------------------------------------------ Description Text +# ------------------------------------------------------------------ Plain Text -sub filedescription { - my $ending=shift; - return $fd{$ending}; +sub plaintext { + my $short=shift; + return &mt($prp{$short}); } # ----------------------------------------------------------------- Assign Role sub assignrole { - my ($udom,$uname,$url,$role,$end,$start)=@_; + my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_; my $mrole; if ($role =~ /^cr\//) { - unless (&allowed('ccr',$url)) { + my $cwosec=$url; + $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/; + unless (&allowed('ccr',$cwosec)) { &logthis('Refused custom assignrole: '. $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. $ENV{'user.name'}.' at '.$ENV{'user.domain'}); @@ -1282,7 +3104,7 @@ sub assignrole { } else { my $cwosec=$url; $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/; - unless (&allowed('c'.$role,$cwosec)) { + unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) { &logthis('Refused assignrole: '. $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. $ENV{'user.name'}.' at '.$ENV{'user.domain'}); @@ -1300,25 +3122,79 @@ sub assignrole { $command.='_0_'.$start; } } - return &reply($command,&homeserver($uname,$udom)); +# actually delete + if ($deleteflag) { + if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) { +# modify command to delete the role + $command="encrypt:rolesdel:$ENV{'user.domain'}:$ENV{'user.name'}:". + "$udom:$uname:$url".'_'."$mrole"; + &logthis("$ENV{'user.name'} at $ENV{'user.domain'} deletes $mrole in $url for $uname at $udom"); +# set start and finish to negative values for userrolelog + $start=-1; + $end=-1; + } + } +# send command + my $answer=&reply($command,&homeserver($uname,$udom)); +# log new user role if status is ok + if ($answer eq 'ok') { + &userrolelog($mrole,$uname,$udom,$url,$start,$end); + } + return $answer; } -# --------------------------------------------------------------- Modify a user +# -------------------------------------------------- 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'}. + ' in domain '.$ENV{'request.role.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)=@_; + my ($udom, $uname, $uid, + $umode, $upass, $first, + $middle, $last, $gene, + $forceid, $desiredhome, $email)=@_; + $udom=~s/\W//g; + $uname=~s/\W//g; &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. $umode.', '.$first.', '.$middle.', '. - $last.', '.$gene.' by '. - $ENV{'user.name'}.' at '.$ENV{'user.domain'}); - my $uhome=&homeserver($uname,$udom); + $last.', '.$gene.'(forceid: '.$forceid.')'. + (defined($desiredhome) ? ' desiredhome = '.$desiredhome : + ' desiredhome not specified'). + ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}. + ' in domain '.$ENV{'request.role.domain'}); + my $uhome=&homeserver($uname,$udom,'true'); # ----------------------------------------------------------------- Create User - if (($uhome eq 'no_host') && ($umode) && ($upass)) { + if (($uhome eq 'no_host') && + (($umode && $upass) || ($umode eq 'localauth'))) { my $unhome=''; - if ($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $udom) { + 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 { + } else { # load balancing routine for determining $unhome my $tryserver; my $loadm=10000000; foreach $tryserver (keys %libserv) { @@ -1332,81 +3208,140 @@ sub modifyuser { } } if (($unhome eq '') || ($unhome eq 'no_host')) { - return 'error: find home'; + 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); + $uhome=&homeserver($uname,$udom,'true'); if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) { - return 'error: verify home'; + return 'error: unable verify users home machine.'; } - } + } # 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\:/)) { + if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/) + && (!$forceid)) { unless ($uid eq $uidhash{$uname}) { - return 'error: mismatch '.$uidhash{$uname}.' versus '.$uid; + return 'error: user id "'.$uid.'" does not match '. + 'current user id "'.$uidhash{$uname}.'".'; } } else { &idput($udom,($uname => $uid)); } } # -------------------------------------------------------------- Add names, etc - my $names=&reply('get:'.$udom.':'.$uname. - ':environment:firstname&middlename&lastname&generation', - $uhome); - my ($efirst,$emiddle,$elast,$egene)=split(/\&/,$names); - if ($first) { $efirst = &escape($first); } - if ($middle) { $emiddle = &escape($middle); } - if ($last) { $elast = &escape($last); } - if ($gene) { $egene = &escape($gene); } - my $reply=&reply('put:'.$udom.':'.$uname. - ':environment:firstname='.$efirst. - '&middlename='.$emiddle. - '&lastname='.$elast. - '&generation='.$egene,$uhome); - if ($reply ne 'ok') { - return 'error: '.$reply; + my @tmp=&get('environment', + ['firstname','middlename','lastname','generation'], + $udom,$uname); + my %names; + if ($tmp[0] =~ m/^error:.*/) { + %names=(); + } else { + %names = @tmp; } +# +# Make sure to not trash student environment if instructor does not bother +# to supply name and email information +# + if ($first) { $names{'firstname'} = $first; } + if (defined($middle)) { $names{'middlename'} = $middle; } + if ($last) { $names{'lastname'} = $last; } + if (defined($gene)) { $names{'generation'} = $gene; } + if ($email) { $names{'notification'} = $email; + $names{'critnotification'} = $email; } + + 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'; + return 'ok'; } # -------------------------------------------------------------- Modify student sub modifystudent { my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, - $end,$start)=@_; - my $cid=''; - unless ($cid=$ENV{'request.course.id'}) { - return 'not_in_class'; + $end,$start,$forceid,$desiredhome,$email,$type,$cid)=@_; + if (!$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); + ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid, + $desiredhome,$email); unless ($reply eq 'ok') { return $reply; } + # This will cause &modify_student_enrollment to get the uid from the + # students environment + $uid = undef if (!$forceid); + $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last, + $gene,$usec,$end,$start,$type,$cid); + return $reply; +} + +sub modify_student_enrollment { + my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type, + $cid) = @_; + my ($cdom,$cnum,$chome); + if (!$cid) { + unless ($cid=$ENV{'request.course.id'}) { + return 'not_in_class'; + } + $cdom=$ENV{'course.'.$cid.'.domain'}; + $cnum=$ENV{'course.'.$cid.'.num'}; + } else { + ($cdom,$cnum)=split(/_/,$cid); + } + $chome=$ENV{'course.'.$cid.'.home'}; + if (!$chome) { + $chome=&homeserver($cnum,$cdom); + } + if (!$chome) { return 'unknown_course'; } + # Make sure the user exists my $uhome=&homeserver($uname,$udom); if (($uhome eq '') || ($uhome eq 'no_host')) { return 'error: no such user'; } -# -------------------------------------------------- Add student to course list - my $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'. - $ENV{'course.'.$cid.'.num'}.':classlist:'. - &escape($uname.':'.$udom).'='. - &escape($end.':'.$start), - $ENV{'course.'.$cid.'.home'}); + # Get student data if we were not given enough information + if (!defined($first) || $first eq '' || + !defined($last) || $last eq '' || + !defined($uid) || $uid eq '' || + !defined($middle) || $middle eq '' || + !defined($gene) || $gene eq '') { + # They did not supply us with enough data to enroll the student, so + # we need to pick up more information. + my %tmp = &get('environment', + ['firstname','middlename','lastname', 'generation','id'] + ,$udom,$uname); + + #foreach (keys(%tmp)) { + # &logthis("key $_ = ".$tmp{$_}); + #} + $first = $tmp{'firstname'} if (!defined($first) || $first eq ''); + $middle = $tmp{'middlename'} if (!defined($middle) || $middle eq ''); + $last = $tmp{'lastname'} if (!defined($last) || $last eq ''); + $gene = $tmp{'generation'} if (!defined($gene) || $gene eq ''); + $uid = $tmp{'id'} if (!defined($uid) || $uid eq ''); + } + my $fullname = &Apache::loncoursedata::ProcessFullName($last,$gene, + $first,$middle); + my $reply=cput('classlist', + {"$uname:$udom" => + join(':',$end,$start,$uid,$usec,$fullname,$type) }, + $cdom,$cnum); unless (($reply eq 'ok') || ($reply eq 'delayed')) { return 'error: '.$reply; } -# ---------------------------------------------------- Add student role to user + # Add student role to user my $uurl='/'.$cid; $uurl=~s/\_/\//g; if ($usec) { @@ -1427,9 +3362,9 @@ sub writecoursepref { return 'error: no such course'; } my $cstring=''; - map { + foreach (keys %prefs) { $cstring.=escape($_).'='.escape($prefs{$_}).'&'; - } keys %prefs; + } $cstring=~s/\&$//; return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome); } @@ -1437,114 +3372,196 @@ sub writecoursepref { # ---------------------------------------------------------- Make/modify course sub createcourse { - my ($udom,$description,$url)=@_; + my ($udom,$description,$url,$course_server,$nonstandard)=@_; $url=&declutter($url); my $cid=''; - unless (&allowed('ccc',$ENV{'user.domain'})) { - return 'refused'; - } - unless ($udom eq $ENV{'user.domain'}) { + unless (&allowed('ccc',$udom)) { 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); + 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); + $uhome=&homeserver($uname,$udom,'true'); unless (($uhome eq '') || ($uhome eq 'no_host')) { return 'error: unable to generate unique course-ID'; } } +# ------------------------------------------------ Check supplied server name + $course_server = $ENV{'user.homeserver'} if (! defined($course_server)); + if (! exists($libserv{$course_server})) { + return 'error:bad server name '.$course_server; + } # ------------------------------------------------------------- Make the course my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::', - $ENV{'user.home'}); + $course_server); unless ($reply eq 'ok') { return 'error: '.$reply; } - my $uhome=&homeserver($uname,$udom); + $uhome=&homeserver($uname,$udom,'true'); if (($uhome eq '') || ($uhome eq 'no_host')) { return 'error: no such course'; } +# ----------------------------------------------------------------- Course made +# log existance + &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description), + $uhome); + &flushcourselogs(); +# set toplevel url + my $topurl=$url; + unless ($nonstandard) { +# ------------------------------------------ For standard courses, make top url + my $mapurl=&clutter($url); + if ($mapurl eq '/res/') { $mapurl=''; } + $ENV{'form.initmap'}=(< + + + + + + +ENDINITMAP + $topurl=&declutter( + &finishuserfileupload($uname,$udom,$uhome,'initmap','default.sequence') + ); + } +# ----------------------------------------------------------- Write preferences &writecoursepref($udom.'_'.$uname, ('description' => $description, - 'url' => $url)); + 'url' => $topurl)); return '/'.$udom.'/'.$uname; } # ---------------------------------------------------------- Assign Custom Role sub assigncustomrole { - my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start)=@_; + my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag)=@_; return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename, - $end,$start); + $end,$start,$deleteflag); } # ----------------------------------------------------------------- Revoke Role sub revokerole { - my ($udom,$uname,$url,$role)=@_; + my ($udom,$uname,$url,$role,$deleteflag)=@_; my $now=time; - return &assignrole($udom,$uname,$url,$role,$now); + return &assignrole($udom,$uname,$url,$role,$now,$deleteflag); } # ---------------------------------------------------------- Revoke Custom Role sub revokecustomrole { - my ($udom,$uname,$url,$rdom,$rnam,$rolename)=@_; + my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag)=@_; my $now=time; - return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now); + return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now, + $deleteflag); } # ------------------------------------------------------------ Directory lister sub dirlist { - my $uri=shift; + my ($uri,$userdomain,$username,$alternateDirectoryRoot)=@_; + $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')) { - map { - my ($entry,@stat)=split(/&/,$_); - $allusers{$entry}=1; - } split(/:/,$listing); - } - } - } - my $alluserstr=''; - map { - $alluserstr.=$_.'&user:'; - } sort keys %allusers; - $alluserstr=~s/:$//; - return split(/:/,$alluserstr); - } - } else { - my $tryserver; - my %alldom=(); - foreach $tryserver (keys %libserv) { - $alldom{$hostdom{$tryserver}}=1; - } - my $alldomstr=''; - map { - $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:'; - } sort keys %alldom; - $alldomstr=~s/:$//; - return split(/:/,$alldomstr); - } + my ($udom, $uname); + (undef,$udom,$uname)=split(/\//,$uri); + if(defined($userdomain)) { + $udom = $userdomain; + } + if(defined($username)) { + $uname = $username; + } + + my $dirRoot = $perlvar{'lonDocRoot'}; + if(defined($alternateDirectoryRoot)) { + $dirRoot = $alternateDirectoryRoot; + $dirRoot =~ s/\/$//; + } + + if($udom) { + if($uname) { + my $listing=reply('ls:'.$dirRoot.'/'.$uri, + homeserver($uname,$udom)); + return split(/:/,$listing); + } elsif(!defined($alternateDirectoryRoot)) { + 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 @emptyResults = (); + push(@emptyResults, 'missing user name'); + return split(':',@emptyResults); + } + } elsif(!defined($alternateDirectoryRoot)) { + 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); + } else { + my @emptyResults = (); + push(@emptyResults, 'missing domain'); + return split(':',@emptyResults); + } +} + +# --------------------------------------------- GetFileTimestamp +# This function utilizes dirlist and returns the date stamp for +# when it was last modified. It will also return an error of -1 +# if an error occurs + +## +## FIXME: This subroutine assumes its caller knows something about the +## directory structure of the home server for the student ($root). +## Not a good assumption to make. Since this is for looking up files +## in user directories, the full path should be constructed by lond, not +## whatever machine we request data from. +## +sub GetFileTimestamp { + my ($studentDomain,$studentName,$filename,$root)=@_; + $studentDomain=~s/\W//g; + $studentName=~s/\W//g; + my $subdir=$studentName.'__'; + $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; + my $proname="$studentDomain/$subdir/$studentName"; + $proname .= '/'.$filename; + my ($fileStat) = &Apache::lonnet::dirlist($proname, $studentDomain, + $studentName, $root); + my @stats = split('&', $fileStat); + if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') { + # @stats contains first the filename, then the stat output + return $stats[10]; # so this is 10 instead of 9. + } else { + return -1; + } } # -------------------------------------------------------- Value of a Condition @@ -1562,18 +3579,18 @@ sub condval { my $condidx=shift; my $result=0; my $allpathcond=''; - map { + foreach (split(/\|/,$condidx)) { if (defined($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_})) { $allpathcond.= '('.$ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_}.')|'; } - } split(/\|/,$condidx); + } $allpathcond=~s/\|$//; if ($ENV{'request.course.id'}) { if ($allpathcond) { my $operand='|'; my @stack; - map { + foreach ($allpathcond=~/(\d+|\(|\)|\&|\|)/g) { if ($_ eq '(') { push @stack,($operand,$result) } elsif ($_ eq ')') { @@ -1591,26 +3608,101 @@ sub condval { $result=$result>$new?$new:$result; } else { $result=$result>$new?$result:$new; - } + } } - } ($allpathcond=~/(\d+|\(|\)|\&|\|)/g); + } } } return $result; } -# --------------------------------------------------------- Value of a Variable +# ---------------------------------------------------- Devalidate courseresdata +sub devalidatecourseresdata { + my ($coursenum,$coursedomain)=@_; + my $hashid=$coursenum.':'.$coursedomain; + &devalidate_cache(\%courseresdatacache,$hashid,'courseres'); +} + +# --------------------------------------------------- Course Resourcedata Query + +sub courseresdata { + my ($coursenum,$coursedomain,@which)=@_; + my $coursehom=&homeserver($coursenum,$coursedomain); + my $hashid=$coursenum.':'.$coursedomain; + my ($result,$cached)=&is_cached(\%courseresdatacache,$hashid,'courseres'); + unless (defined($cached)) { + my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum); + $result=\%dumpreply; + my ($tmp) = keys(%dumpreply); + if ($tmp !~ /^(con_lost|error|no_such_host)/i) { + &do_cache(\%courseresdatacache,$hashid,$result,'courseres'); + } elsif ($tmp =~ /^(con_lost|no_such_host)/) { + return $tmp; + } elsif ($tmp =~ /^(error)/) { + $result=undef; + &do_cache(\%courseresdatacache,$hashid,$result,'courseres'); + } + } + foreach my $item (@which) { + if (defined($result->{$item})) { + return $result->{$item}; + } + } + return undef; +} + +# +# EXT resource caching routines +# + +sub clear_EXT_cache_status { + &delenv('cache.EXT.'); +} + +sub EXT_cache_status { + my ($target_domain,$target_user) = @_; + my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain; + if (exists($ENV{$cachename}) && ($ENV{$cachename}+600) > time) { + # We know already the user has no data + return 1; + } else { + return 0; + } +} + +sub EXT_cache_set { + my ($target_domain,$target_user) = @_; + my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain; + &appenv($cachename => time); +} + +# --------------------------------------------------------- Value of a Variable sub EXT { - my $varname=shift; + my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_; + unless ($varname) { return ''; } + #get real user name/domain, courseid and symb + my $courseid; + my $publicuser; + if ($symbparm) { + $symbparm=&get_symb_from_alias($symbparm); + } + if (!($uname && $udom)) { + (my $cursymb,$courseid,$udom,$uname,$publicuser)= + &Apache::lonxml::whichuser($symbparm); + if (!$symbparm) { $symbparm=$cursymb; } + } else { + $courseid=$ENV{'request.course.id'}; + } my ($realm,$space,$qualifier,@therest)=split(/\./,$varname); my $rest; - if ($therest[0]) { + if (defined($therest[0])) { $rest=join('.',@therest); } else { $rest=''; } + my $qualifierrest=$qualifier; if ($rest) { $qualifierrest.='.'.$rest; } my $spacequalifierrest=$space; @@ -1618,19 +3710,41 @@ sub EXT { if ($realm eq 'user') { # --------------------------------------------------------------- user.resource if ($space eq 'resource') { - my %restored=&restore; - return $restored{$qualifierrest}; + if (defined($Apache::lonhomework::parsing_a_problem)) { + return $Apache::lonhomework::history{$qualifierrest}; + } else { + my %restored; + if ($publicuser || $ENV{'request.state'} eq 'construct') { + %restored=&tmprestore($symbparm,$courseid,$udom,$uname); + } else { + %restored=&restore($symbparm,$courseid,$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')) { - return $ENV{join('.',('environment',$qualifierrest))}; + if (($uname eq $ENV{'user.name'}) && + ($udom eq $ENV{'user.domain'})) { + return $ENV{join('.',('environment',$qualifierrest))}; + } else { + my %returnhash; + if (!$publicuser) { + %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; @@ -1639,127 +3753,169 @@ sub EXT { } # ----------------------------------------------------------------- user.domain } elsif ($space eq 'domain') { - return $ENV{'user.domain'}; + return $udom; # ------------------------------------------------------------------- user.name } elsif ($space eq 'name') { - return $ENV{'user.name'}; + return $uname; # ---------------------------------------------------- Any other user namespace } else { - my $item=($rest)?$qualifier.'.'.$rest:$qualifier; - my %reply=&get($space,$item); - return $reply{$item}; + my %reply; + if (!$publicuser) { + %reply=&get($space,[$qualifierrest],$udom,$uname); + } + return $reply{$qualifierrest}; } - } elsif ($realm eq 'request') { + } elsif ($realm eq 'query') { +# ---------------------------------------------- pull stuff out of query string + &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'}, + [$spacequalifierrest]); + return $ENV{'form.'.$spacequalifierrest}; + } elsif ($realm eq 'request') { # ------------------------------------------------------------- request.browser if ($space eq 'browser') { - return $ENV{'browser.'.$qualifier}; + if ($qualifier eq 'textremote') { + if (&mt('textual_remote_display') eq 'on') { + return 1; + } else { + return 0; + } + } else { + return $ENV{'browser.'.$qualifier}; + } # ------------------------------------------------------------ request.filename } else { return $ENV{'request.'.$spacequalifierrest}; } } elsif ($realm eq 'course') { # ---------------------------------------------------------- course.description - my $section=''; - if ($ENV{'request.course.sec'}) { - $section='_'.$ENV{'request.course.sec'}; - } - return $ENV{'course.'.$ENV{'request.course.id'}.$section.'.'. - $spacequalifierrest}; + return $ENV{'course.'.$courseid.'.'.$spacequalifierrest}; } elsif ($realm eq 'resource') { - if ($ENV{'request.course.id'}) { -# ----------------------------------------------------- Cascading lookup scheme - my $symbp=&symbread(); - my $mapp=(split(/\_\_\_/,$symbp))[0]; - my $symbparm=$symbp.'.'.$spacequalifierrest; - my $mapparm=$mapp.'___(all).'.$spacequalifierrest; + my $section; + if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) { - my $seclevel= - $ENV{'request.course.id'}.'.['. - $ENV{'request.course.sec'}.'].'.$spacequalifierrest; - my $seclevelr= - $ENV{'request.course.id'}.'.['. - $ENV{'request.course.sec'}.'].'.$symbparm; - my $seclevelm= - $ENV{'request.course.id'}.'.['. - $ENV{'request.course.sec'}.'].'.$mapparm; - - my $courselevel= - $ENV{'request.course.id'}.'.'.$spacequalifierrest; - my $courselevelr= - $ENV{'request.course.id'}.'.'.$symbparm; - my $courselevelm= - $ENV{'request.course.id'}.'.'.$mapparm; + #print '
'.$space.' - '.$qualifier.' - '.$spacequalifierrest; -# ----------------------------------------------------------- first, check user - my %resourcedata=get('resourcedata', - ($courselevelr,$courselevelm,$courselevel)); - 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}; } +# ----------------------------------------------------- Cascading lookup scheme + if (!$symbparm) { $symbparm=&symbread(); } + my $symbp=$symbparm; + my $mapp=(&decode_symb($symbp))[0]; + + my $symbparm=$symbp.'.'.$spacequalifierrest; + my $mapparm=$mapp.'___(all).'.$spacequalifierrest; + + if (($ENV{'user.name'} eq $uname) && + ($ENV{'user.domain'} eq $udom)) { + $section=$ENV{'request.course.sec'}; + } else { + if (! defined($usection)) { + $section=&usection($udom,$uname,$courseid); + } else { + $section = $usection; + } + } - } else { - if ($resourcedata{$courselevelr}!~/No such file/) { - &logthis("WARNING:". - " Trying to get resource data for ".$ENV{'user.name'}." at " - .$ENV{'user.domain'}.": ".$resourcedata{$courselevelr}. - ""); - } - } + 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 + #most student don\'t have any data set, check if there is some data + if (! &EXT_cache_status($udom,$uname)) { + my $hashid="$udom:$uname"; + my ($result,$cached)=&is_cached(\%userresdatacache,$hashid, + 'userres'); + if (!defined($cached)) { + my %resourcedata=&dump('resourcedata',$udom,$uname); + $result=\%resourcedata; + &do_cache(\%userresdatacache,$hashid,$result,'userres'); + } + my ($tmp)=keys(%$result); + if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) { + if ($$result{$courselevelr}) { + return $$result{$courselevelr}; } + if ($$result{$courselevelm}) { + return $$result{$courselevelm}; } + if ($$result{$courselevel}) { + return $$result{$courselevel}; } + } else { + #error 2 occurs when the .db doesn't exist + if ($tmp!~/error: 2 /) { + &logthis("WARNING:". + " Trying to get resource data for ". + $uname." at ".$udom.": ". + $tmp.""); + } elsif ($tmp=~/error: 2 /) { + &EXT_cache_set($udom,$uname); + } elsif ($tmp =~ /^(con_lost|no_such_host)/) { + return $tmp; + } + } + } # -------------------------------------------------------- second, check course - my $reply=&reply('get:'. - $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'. - $ENV{'course.'.$ENV{'request.course.id'}.'.num'}. - ':resourcedata:'. - &escape($seclevelr).'&'.&escape($seclevelm).'&'.&escape($seclevel).'&'. - &escape($courselevelr).'&'.&escape($courselevelm).'&'.&escape($courselevel), - $ENV{'course.'.$ENV{'request.course.id'}.'.home'}); - if ($reply!~/^error\:/) { - map { - if ($_) { return &unescape($_); } - } split(/\&/,$reply); - } - if (($reply=~/^con_lost/) || ($reply=~/^error\:/)) { - &logthis("WARNING:". - " Getting ".$reply." asking for ".$varname." for ". - $ENV{'course.'.$ENV{'request.course.id'}.'.num'}. - ' at '. - $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}. - ' from '. - $ENV{'course.'.$ENV{'request.course.id'}.'.home'}. - ""); - } + my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'}, + $ENV{'course.'.$courseid.'.domain'}, + ($seclevelr,$seclevelm,$seclevel, + $courselevelr,$courselevelm, + $courselevel)); + if (defined($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; } - } - + 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; } + $spacequalifierrest=~s/\./\_/; + my $filename; + if (!$symbparm) { $symbparm=&symbread(); } + if ($symbparm) { + $filename=(&decode_symb($symbparm))[2]; + } else { + $filename=$ENV{'request.filename'}; + } + my $metadata=&metadata($filename,$spacequalifierrest); + if (defined($metadata)) { return $metadata; } + $metadata=&metadata($filename,'parameter_'.$spacequalifierrest); + if (defined($metadata)) { return $metadata; } + +# ------------------------------------------------------------------ Cascade up + unless ($space eq '0') { + my @parts=split(/_/,$space); + my $id=pop(@parts); + my $part=join('_',@parts); + if ($part eq '') { $part='0'; } + my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, + $symbparm,$udom,$uname,$section,1); + if (defined($partgeneral)) { return $partgeneral; } + } + if ($recurse) { return undef; } + my $pack_def=&packages_tab_default($filename,$varname); + if (defined($pack_def)) { return $pack_def; } # ---------------------------------------------------- Any other user namespace } elsif ($realm eq 'environment') { # ----------------------------------------------------------------- environment - return $ENV{$spacequalifierrest}; + 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') { @@ -1769,60 +3925,325 @@ sub EXT { return ''; } +sub packages_tab_default { + my ($uri,$varname)=@_; + my (undef,$part,$name)=split(/\./,$varname); + my $packages=&metadata($uri,'packages'); + foreach my $package (split(/,/,$packages)) { + my ($pack_type,$pack_part)=split(/_/,$package,2); + if (defined($packagetab{"$pack_type&$name&default"})) { + return $packagetab{"$pack_type&$name&default"}; + } + if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) { + return $packagetab{$pack_type."_".$pack_part."&$name&default"}; + } + } + return undef; +} + +sub add_prefix_and_part { + my ($prefix,$part)=@_; + my $keyroot; + if (defined($prefix) && $prefix !~ /^__/) { + # prefix that has a part already + $keyroot=$prefix; + } elsif (defined($prefix)) { + # prefix that is missing a part + if (defined($part)) { $keyroot='_'.$part.substr($prefix,1); } + } else { + # no prefix at all + if (defined($part)) { $keyroot='_'.$part; } + } + return $keyroot; +} + # ---------------------------------------------------------------- Get metadata sub metadata { - my ($uri,$what)=@_; - + my ($uri,$what,$liburi,$prefix,$depthcount)=@_; $uri=&declutter($uri); + # if it is a non metadata possible uri return quickly + if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) || + ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) || + ($uri =~ m|home/[^/]+/public_html/|)) { + return undef; + } my $filename=$uri; $uri=~s/\.meta$//; - unless ($metacache{$uri.':keys'}) { +# +# Is the metadata already cached? +# Look at timestamp of caching +# Everything is cached by the main uri, libraries are never directly cached +# + if (!defined($liburi)) { + my ($result,$cached)=&is_cached(\%metacache,$uri,'meta'); + if (defined($cached)) { return $result->{':'.$what}; } + } + { +# +# Is this a recursive call for a library? +# + if (! exists($metacache{$uri})) { + $metacache{$uri}={}; + } + if ($liburi) { + $liburi=&declutter($liburi); + $filename=$liburi; + } else { + &devalidate_cache(\%metacache,$uri,'meta'); + } + my %metathesekeys=(); unless ($filename=~/\.meta$/) { $filename.='.meta'; } - my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename); - my $parser=HTML::TokeParser->new(\$metastring); + my $metastring; + if ($uri !~ m|^uploaded/|) { + $metastring=&getfile(&filelocation('',&clutter($filename))); + } + my $parser=HTML::LCParser->new(\$metastring); my $token; + undef %metathesekeys; while ($token=$parser->get_token) { - if ($token->[0] eq 'S') { - my $entry=$token->[1]; - my $unikey=$entry; - if (defined($token->[2]->{'part'})) { - $unikey.='_'.$token->[2]->{'part'}; - } - if (defined($token->[2]->{'name'})) { - $unikey.='_'.$token->[2]->{'name'}; - } - if ($metacache{$uri.':keys'}) { - $metacache{$uri.':keys'}.=','.$unikey; - } else { - $metacache{$uri.':keys'}=$unikey; - } - map { - $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_}; - } @{$token->[3]}; - unless ( - $metacache{$uri.':'.$unikey}=$parser->get_text('/'.$entry) - ) { $metacache{$uri.':'.$unikey}= - $metacache{$uri.':'.$unikey.'.default'}; - } - } - } + if ($token->[0] eq 'S') { + if (defined($token->[2]->{'package'})) { +# +# This is a package - get package info +# + my $package=$token->[2]->{'package'}; + my $keyroot=&add_prefix_and_part($prefix,$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) { + my $part=$keyroot; + $part=~s/^\_//; + if ($_=~/^\Q$package\E\&/ || + $_=~/^\Q$package\E_0\&/) { + my ($pack,$name,$subp)=split(/\&/,$_); + # ignore package.tab specified default values + # here &package_tab_default() will fetch those + if ($subp eq 'default') { next; } + my $value=$packagetab{$_}; + my $unikey; + if ($pack =~ /_0$/) { + $unikey='parameter_0_'.$name; + $part=0; + } else { + $unikey='parameter'.$keyroot.'_'.$name; + } + if ($subp eq 'display') { + $value.=' [Part: '.$part.']'; + } + $metacache{$uri}->{':'.$unikey.'.part'}=$part; + $metathesekeys{$unikey}=1; + unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) { + $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value; + } + if (defined($metacache{$uri}->{':'.$unikey.'.default'})) { + $metacache{$uri}->{':'.$unikey}= + $metacache{$uri}->{':'.$unikey.'.default'}; + } + } + } + } 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; + } + $unikey.=&add_prefix_and_part($prefix,$token->[2]->{'part'}); + + if (defined($token->[2]->{'id'})) { + $unikey.='_'.$token->[2]->{'id'}; + } + + if ($entry eq 'import') { +# +# Importing a library here +# + if ($depthcount<20) { + my $location=$parser->get_text('/import'); + my $dir=$filename; + $dir=~s|[^/]*$||; + $location=&filelocation($dir,$location); + foreach (sort(split(/\,/,&metadata($uri,'keys', + $location,$unikey, + $depthcount+1)))) { + $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_}; + $metathesekeys{$_}=1; + } + } + } else { + + if (defined($token->[2]->{'name'})) { + $unikey.='_'.$token->[2]->{'name'}; + } + $metathesekeys{$unikey}=1; + foreach (@{$token->[3]}) { + $metacache{$uri}->{':'.$unikey.'.'.$_}=$token->[2]->{$_}; + } + my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry)); + my $default=$metacache{$uri}->{':'.$unikey.'.default'}; + if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) { + # only ws inside the tag, and not in default, so use default + # as value + $metacache{$uri}->{':'.$unikey}=$default; + } else { + # either something interesting inside the tag or default + # uninteresting + $metacache{$uri}->{':'.$unikey}=$internaltext; + } +# end of not-a-package not-a-library import + } +# end of not-a-package start tag + } +# the next is the end of "start tag" + } + } + my ($extension) = ($uri =~ /\.(\w+)$/); + foreach my $key (sort(keys(%packagetab))) { + #&logthis("extsion1 $extension $key !!"); + #no specific packages #how's our extension + if ($key!~/^extension_\Q$extension\E&/) { next; } + &metadata_create_package_def($uri,$key,'extension_'.$extension, + \%metathesekeys); + } + if (!exists($metacache{$uri}->{':packages'})) { + foreach my $key (sort(keys(%packagetab))) { + #no specific packages well let's get default then + if ($key!~/^default&/) { next; } + &metadata_create_package_def($uri,$key,'default', + \%metathesekeys); + } + } +# are there custom rights to evaluate + if ($metacache{$uri}->{':copyright'} eq 'custom') { + + # + # Importing a rights file here + # + unless ($depthcount) { + my $location=$metacache{$uri}->{':customdistributionfile'}; + my $dir=$filename; + $dir=~s|[^/]*$||; + $location=&filelocation($dir,$location); + foreach (sort(split(/\,/,&metadata($uri,'keys', + $location,'_rights', + $depthcount+1)))) { + $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_}; + $metathesekeys{$_}=1; + } + } + } + $metacache{$uri}->{':keys'}=join(',',keys %metathesekeys); + &metadata_generate_part0(\%metathesekeys,$metacache{$uri},$uri); + $metacache{$uri}->{':allpossiblekeys'}=join(',',keys %metathesekeys); + &do_cache(\%metacache,$uri,$metacache{$uri},'meta'); +# this is the end of "was not already recently cached + } + return $metacache{$uri}->{':'.$what}; +} + +sub metadata_create_package_def { + my ($uri,$key,$package,$metathesekeys)=@_; + my ($pack,$name,$subp)=split(/\&/,$key); + if ($subp eq 'default') { next; } + + if (defined($metacache{$uri}->{':packages'})) { + $metacache{$uri}->{':packages'}.=','.$package; + } else { + $metacache{$uri}->{':packages'}=$package; + } + my $value=$packagetab{$key}; + my $unikey; + $unikey='parameter_0_'.$name; + $metacache{$uri}->{':'.$unikey.'.part'}=0; + $$metathesekeys{$unikey}=1; + unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) { + $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value; + } + if (defined($metacache{$uri}->{':'.$unikey.'.default'})) { + $metacache{$uri}->{':'.$unikey}= + $metacache{$uri}->{':'.$unikey.'.default'}; } - return $metacache{$uri.':'.$what}; } +sub metadata_generate_part0 { + my ($metadata,$metacache,$uri) = @_; + my %allnames; + foreach my $metakey (sort keys %$metadata) { + if ($metakey=~/^parameter\_(.*)/) { + my $part=$$metacache{':'.$metakey.'.part'}; + my $name=$$metacache{':'.$metakey.'.name'}; + if (! exists($$metadata{'parameter_0_'.$name.'.name'})) { + $allnames{$name}=$part; + } + } + } + foreach my $name (keys(%allnames)) { + $$metadata{"parameter_0_$name"}=1; + my $key=":parameter_0_$name"; + $$metacache{"$key.part"}='0'; + $$metacache{"$key.name"}=$name; + $$metacache{"$key.type"}=$$metacache{':parameter_'. + $allnames{$name}.'_'.$name. + '.type'}; + my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name. + '.display'}; + my $expr='\\[Part: '.$allnames{$name}.'\\]'; + $olddis=~s/\Q$expr\E/\[Part: 0\]/; + $$metacache{"$key.display"}=$olddis; + } +} + +# ------------------------------------------------- Get the title of a resource + +sub gettitle { + my $urlsymb=shift; + my $symb=&symbread($urlsymb); + unless ($symb) { + unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; } + return &metadata($urlsymb,'title'); + } + my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600); + if (defined($cached)) { return $result; } + my ($map,$resid,$url)=&decode_symb($symb); + my $title=''; + my %bighash; + if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', + &GDBM_READER(),0640)) { + my $mapid=$bighash{'map_pc_'.&clutter($map)}; + $title=$bighash{'title_'.$mapid.'.'.$resid}; + untie %bighash; + } + $title=~s/\&colon\;/\:/gs; + if ($title) { + return &do_cache(\%titlecache,$symb,$title,'title'); + } else { + return &metadata($urlsymb,'title'); + } +} + # ------------------------------------------------- Update symbolic store links sub symblist { my ($mapname,%newhash)=@_; - $mapname=declutter($mapname); + $mapname=&deversion(&declutter($mapname)); my %hash; if (($ENV{'request.course.fn'}) && (%newhash)) { if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', - &GDBM_WRCREAT,0640)) { - map { - $hash{declutter($_)}=$mapname.'___'.$newhash{$_}; - } keys %newhash; + &GDBM_WRCREAT(),0640)) { + foreach (keys %newhash) { + $hash{declutter($_)}=$mapname.'___'.&deversion($newhash{$_}); + } if (untie(%hash)) { return 'ok'; } @@ -1831,21 +4252,129 @@ sub symblist { 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)=&decode_symb($symb); + + unless ($url eq $thisfn) { return 0; } + + $symb=&symbclean($symb); + $thisfn=&deversion($thisfn); + + my %bighash; + my $okay=0; + + if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', + &GDBM_READER(),0640)) { + my $ids=$bighash{'ids_'.&clutter($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; +} + +# ---------------------------------------------- Split symb to find map and url + +sub encode_symb { + my ($map,$resid,$url)=@_; + return &symbclean(&declutter($map).'___'.$resid.'___'.&declutter($url)); +} + +sub decode_symb { + my ($map,$resid,$url)=split(/\_\_\_/,shift); + return (&fixversion($map),$resid,&fixversion($url)); +} + +sub fixversion { + my $fn=shift; + if ($fn=~/^(adm|uploaded|public)/) { return $fn; } + my %bighash; + my $uri=&clutter($fn); + my $key=$ENV{'request.course.id'}.'_'.$uri; +# is this cached? + my ($result,$cached)=&is_cached(\%courseresversioncache,$key, + 'courseresversion',600); + if (defined($cached)) { return $result; } +# unfortunately not cached, or expired + if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', + &GDBM_READER(),0640)) { + if ($bighash{'version_'.$uri}) { + my $version=$bighash{'version_'.$uri}; + unless (($version eq 'mostrecent') || + ($version==&getversion($uri))) { + $uri=~s/\.(\w+)$/\.$version\.$1/; + } + } + untie %bighash; + } + return &do_cache + (\%courseresversioncache,$key,&declutter($uri),'courseresversion'); +} + +sub deversion { + my $url=shift; + $url=~s/\.\d+\.(\w+)$/\.$1/; + return $url; +} + # ------------------------------------------------------ Return symb list entry sub symbread { - my $thisfn=shift; + my ($thisfn,$donotrecurse)=@_; +# 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)) { + my $targetfn = $thisfn; + if ( ($thisfn =~ m/^uploaded\//) && ($thisfn !~ m/\.(page|sequence)$/) ) { + $targetfn = 'adm/wrapper/'.$thisfn; + } if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', - &GDBM_READER,0640)) { - $syval=$hash{$thisfn}; + &GDBM_READER(),0640)) { + $syval=$hash{$targetfn}; untie(%hash); } # ---------------------------------------------------------- There was an entry @@ -1860,12 +4389,16 @@ sub symbread { } else { # ------------------------------------------------------- Was not in symb table if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', - &GDBM_READER,0640)) { + &GDBM_READER(),0640)) { # ---------------------------------------------- Get ID(s) for current resource - my $ids=$bighash{'ids_/res/'.$thisfn}; + my $ids=$bighash{'ids_'.&clutter($thisfn)}; unless ($ids) { $ids=$bighash{'ids_/'.$thisfn}; } + unless ($ids) { +# alias? + $ids=$bighash{'mapalias_'.$thisfn}; + } if ($ids) { # ------------------------------------------------------------------- Has ID(s) my @possibilities=split(/\,/,$ids); @@ -1873,10 +4406,10 @@ sub symbread { # ----------------------------------------------- There is only one possibility my ($mapid,$resid)=split(/\./,$ids); $syval=declutter($bighash{'map_id_'.$mapid}).'___'.$resid; - } else { + } elsif (!$donotrecurse) { # ------------------------------------------ There is more than one possibility my $realpossible=0; - map { + foreach (@possibilities) { my $file=$bighash{'src_'.$_}; if (&allowed('bre',$file)) { my ($mapid,$resid)=split(/\./,$_); @@ -1886,15 +4419,17 @@ sub symbread { '___'.$resid; } } - } @possibilities; + } if ($realpossible!=1) { $syval=''; } + } else { + $syval=''; } } untie(%bighash) - } + } } if ($syval) { - return $syval.'___'.$thisfn; + return &symbclean($syval.'___'.$thisfn); } } &appenv('request.ambiguous' => $thisfn); @@ -1913,58 +4448,303 @@ sub numval { $txt=~tr/u-z/0-5/; $txt=~s/\D//g; return int($txt); -} +} + +sub numval2 { + 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; + my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt); + my $total; + foreach my $val (@txts) { $total+=$val; } + return int($total); +} + +sub latest_rnd_algorithm_id { + return '64bit2'; +} + +sub getCODE { + if (defined($ENV{'form.CODE'})) { return $ENV{'form.CODE'}; } + if (defined($Apache::lonhomework::parsing_a_problem) && + defined($Apache::lonhomework::history{'resource.CODE'})) { + return $Apache::lonhomework::history{'resource.CODE'}; + } + return undef; +} sub rndseed { - my $symb; - unless ($symb=&symbread()) { return time; } - { - use integer; - my $symbchck=unpack("%32C*",$symb) << 27; - my $symbseed=numval($symb) << 22; - my $namechck=unpack("%32C*",$ENV{'user.name'}) << 17; - my $nameseed=numval($ENV{'user.name'}) << 12; - my $domainseed=unpack("%32C*",$ENV{'user.domain'}) << 7; - my $courseseed=unpack("%32C*",$ENV{'request.course.id'}); - 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; + my ($symb,$courseid,$domain,$username)=@_; + + my ($wsymb,$wcourseid,$wdomain,$wusername)=&Apache::lonxml::whichuser(); + if (!$symb) { + unless ($symb=$wsymb) { return time; } + } + if (!$courseid) { $courseid=$wcourseid; } + if (!$domain) { $domain=$wdomain; } + if (!$username) { $username=$wusername } + my $which=$ENV{"course.$courseid.rndseed"}; + if (defined(&getCODE())) { + return &rndseed_CODE_64bit($symb,$courseid,$domain,$username); + } elsif ($which eq '64bit2') { + return &rndseed_64bit2($symb,$courseid,$domain,$username); + } elsif ($which eq '64bit') { + return &rndseed_64bit($symb,$courseid,$domain,$username); + } + return &rndseed_32bit($symb,$courseid,$domain,$username); +} + +sub rndseed_32bit { + my ($symb,$courseid,$domain,$username)=@_; + { + 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; + #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); + #&Apache::lonxml::debug("rndseed :$num:$symb"); + return $num; + } +} + +sub rndseed_64bit { + my ($symb,$courseid,$domain,$username)=@_; + { + use integer; + my $symbchck=unpack("%32S*",$symb) << 21; + my $symbseed=numval($symb) << 10; + my $namechck=unpack("%32S*",$username); + + my $nameseed=numval($username) << 21; + my $domainseed=unpack("%32S*",$domain) << 10; + my $courseseed=unpack("%32S*",$courseid); + + my $num1=$symbchck+$symbseed+$namechck; + my $num2=$nameseed+$domainseed+$courseseed; + #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); + #&Apache::lonxml::debug("rndseed :$num:$symb"); + return "$num1,$num2"; } } +sub rndseed_64bit2 { + my ($symb,$courseid,$domain,$username)=@_; + { + use integer; + # strings need to be an even # of cahracters long, it it is odd the + # last characters gets thrown away + my $symbchck=unpack("%32S*",$symb.' ') << 21; + my $symbseed=numval($symb) << 10; + my $namechck=unpack("%32S*",$username.' '); + + my $nameseed=numval($username) << 21; + my $domainseed=unpack("%32S*",$domain.' ') << 10; + my $courseseed=unpack("%32S*",$courseid.' '); + + my $num1=$symbchck+$symbseed+$namechck; + my $num2=$nameseed+$domainseed+$courseseed; + #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); + #&Apache::lonxml::debug("rndseed :$num:$symb"); + return "$num1,$num2"; + } +} + +sub rndseed_CODE_64bit { + my ($symb,$courseid,$domain,$username)=@_; + { + use integer; + my $symbchck=unpack("%32S*",$symb.' ') << 16; + my $symbseed=numval2($symb); + my $CODEchck=unpack("%32S*",&getCODE().' ') << 16; + my $CODEseed=numval(&getCODE()); + my $courseseed=unpack("%32S*",$courseid.' '); + my $num1=$symbseed+$CODEchck; + my $num2=$CODEseed+$courseseed+$symbchck; + #&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck"); + #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb"); + return "$num1,$num2"; + } +} + +sub setup_random_from_rndseed { + my ($rndseed)=@_; + if ($rndseed =~/,/) { + my ($num1,$num2)=split(/,/,$rndseed); + &Math::Random::random_set_seed(abs($num1),abs($num2)); + } else { + &Math::Random::random_set_seed_from_phrase($rndseed); + } +} + +sub latest_receipt_algorithm_id { + return 'receipt2'; +} + +sub recunique { + my $fucourseid=shift; + my $unique; + if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2') { + $unique=$ENV{"course.$fucourseid.internal.encseed"}; + } else { + $unique=$perlvar{'lonReceipt'}; + } + return unpack("%32C*",$unique); +} + +sub recprefix { + my $fucourseid=shift; + my $prefix; + if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2') { + $prefix=$ENV{"course.$fucourseid.internal.encpref"}; + } else { + $prefix=$perlvar{'lonHostID'}; + } + return unpack("%32C*",$prefix); +} + sub ireceipt { - my ($funame,$fudom,$fucourseid,$fusymb)=@_; + my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_; 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); + my $cunique=&recunique($fucourseid); + my $cpart=unpack("%32S*",$part); + my $return =&recprefix($fucourseid).'-'; + if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2' || + $ENV{'request.state'} eq 'construct') { + &Apache::lonxml::debug("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname). + " and ".($cpart%$cudom)); + + $return.= ($cunique%$cuname+ + $cunique%$cudom+ + $cusymb%$cuname+ + $cusymb%$cudom+ + $cucourseid%$cuname+ + $cucourseid%$cudom+ + $cpart%$cuname+ + $cpart%$cudom); + } else { + $return.= ($cunique%$cuname+ + $cunique%$cudom+ + $cusymb%$cuname+ + $cusymb%$cudom+ + $cucourseid%$cuname+ + $cucourseid%$cudom); + } + return $return; } sub receipt { - return &ireceipt($ENV{'user.name'},$ENV{'user.domain'}, - $ENV{'request.course.id'},&symbread()); + my ($part)=@_; + my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser(); + return &ireceipt($name,$domain,$courseid,$symb,$part); } - + # ------------------------------------------------------------ Serves up a file -# returns either the contents of the file or a -1 +# returns either the contents of the file or +# -1 if the file doesn't exist +# +# if the target is a file that was uploaded via DOCS, +# a check will be made to see if a current copy exists on the local server, +# if it does this will be served, otherwise a copy will be retrieved from +# the home server for the course and stored in /home/httpd/html/userfiles on +# the local server. + 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 + my ($file,$caller) = @_; + + if ($file !~ m|^/*uploaded/(\w+)/(\w+)/(.+)$|) { + # normal file from res space + &repcopy($file); + return &readfile($file); + } + + my $info; + my $cdom = $1; + my $cnum = $2; + my $filename = $3; + my $path = $Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles'; + my ($lwpresp,$rtncode); + my $localfile = $path.'/'.$cdom.'/'.$cnum.'/'.$filename; + if (-e "$localfile") { + my @fileinfo = stat($localfile); + $lwpresp = &getuploaded('HEAD',$file,$cdom,$cnum,\$info,\$rtncode); + if ($lwpresp ne 'ok') { + if ($rtncode eq '404') { + unlink($localfile); + } + return -1; + } + if ($info < $fileinfo[9]) { + return &readfile($localfile); + } + $info = ''; + $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode); + if ($lwpresp ne 'ok') { + return -1; + } + } else { + $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode); + if ($lwpresp ne 'ok') { + return -1; + } + my @parts = ($cdom,$cnum); + if ($filename =~ m|^(.+)/[^/]+$|) { + push @parts, split(/\//,$1); + } + foreach my $part (@parts) { + $path .= '/'.$part; + if (!-e $path) { + mkdir($path,0770); + } + } + } + open (FILE,">$localfile"); + print FILE $info; + close(FILE); + if ($caller eq 'uploadrep') { + return 'ok'; + } + return $info; +} + +sub getuploaded { + my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_; + $uri=~s/^\///; + $uri = 'http://'.$hostname{ &homeserver($cnum,$cdom)}.'/raw/'.$uri; + my $ua=new LWP::UserAgent; + my $request=new HTTP::Request($reqtype,$uri); + my $response=$ua->request($request); + $$rtncode = $response->code; + if (! $response->is_success()) { + return 'failed'; + } + if ($reqtype eq 'HEAD') { + $$info = &HTTP::Date::str2time( $response->header('Last-modified') ); + } elsif ($reqtype eq 'GET') { + $$info = $response->content; + } + return 'ok'; +} + +sub readfile { + my $file = shift; + if ( (! -e $file ) || ($file eq '') ) { return -1; }; + my $fh; + open($fh,"<$file"); + my $a=''; + while (<$fh>) { $a .=$_; } + return $a; } sub filelocation { @@ -1974,9 +4754,11 @@ sub filelocation { if ($file=~m:^/~:) { # is a contruction space reference $location = $file; $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; + } elsif ($file=~/^\/*uploaded/) { # is an uploaded file + $location=$file; } else { - $file=~s/^$perlvar{'lonDocRoot'}//; - $file=~s:^/*res::; + $file=~s/^\Q$perlvar{'lonDocRoot'}\E//; + $file=~s:^/res/:/:; if ( !( $file =~ m:^/:) ) { $location = $dir. '/'.$file; } else { @@ -1985,27 +4767,67 @@ sub filelocation { } $location=~s://+:/:g; # remove duplicate / while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/.. + while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./ return $location; } sub hreflocation { my ($dir,$file)=@_; - unless (($_=~/^http:\/\//i) || ($_=~/^\//)) { - my $finalpath=filelocation($dir,$file); - $finalpath=~s/^\/home\/httpd\/html//; - return $finalpath; - } else { - return $file; + unless (($file=~m-^http://-i) || ($file=~m-^/-)) { + my $finalpath=filelocation($dir,$file); + $finalpath=~s-^/home/httpd/html--; + $finalpath=~s-^/home/(\w+)/public_html/-/~$1/-; + return $finalpath; + } elsif ($file=~m-^/home-) { + $file=~s-^/home/httpd/html--; + $file=~s-^/home/(\w+)/public_html/-/~$1/-; + return $file; + } + return $file; +} + +sub current_machine_domains { + my $hostname=$hostname{$perlvar{'lonHostID'}}; + my @domains; + while( my($id, $name) = each(%hostname)) { +# &logthis("-$id-$name-$hostname-"); + if ($hostname eq $name) { + push(@domains,$hostdom{$id}); + } } + return @domains; +} + +sub current_machine_ids { + my $hostname=$hostname{$perlvar{'lonHostID'}}; + my @ids; + while( my($id, $name) = each(%hostname)) { +# &logthis("-$id-$name-$hostname-"); + if ($hostname eq $name) { + push(@ids,$id); + } + } + return @ids; } # ------------------------------------------------------------- Declutters URLs sub declutter { my $thisfn=shift; - $thisfn=~s/^$perlvar{'lonDocRoot'}//; + $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//; $thisfn=~s/^\///; $thisfn=~s/^res\///; + $thisfn=~s/\?.+$//; + return $thisfn; +} + +# ------------------------------------------------------------- Clutter up URLs + +sub clutter { + my $thisfn='/'.&declutter(shift); + unless ($thisfn=~/^\/(uploaded|adm|userfiles|ext|raw|priv)\//) { + $thisfn='/res'.$thisfn; + } return $thisfn; } @@ -2025,86 +4847,1025 @@ sub unescape { return $str; } +sub mod_perl_version { + if (defined($perlvar{'MODPERL2'})) { + return 2; + } + return 1; +} + +sub correct_line_ends { + my ($result)=@_; + $$result =~s/\r\n/\n/mg; + $$result =~s/\r/\n/mg; +} # ================================================================ Main Program -sub BEGIN { -if ($readit ne 'done') { -# ------------------------------------------------------------ Read access.conf +sub goodbye { + &logthis("Starting Shut down"); +#not converted to using infrastruture and probably shouldn't be + &logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache))); +#converted + &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache))); + &logthis(sprintf("%-20s is %s",'%homecache',scalar(%homecache))); + &logthis(sprintf("%-20s is %s",'%titlecache',scalar(%titlecache))); + &logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache))); +#1.1 only + &logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache))); + &logthis(sprintf("%-20s is %s",'%usectioncache',scalar(%usectioncache))); + &logthis(sprintf("%-20s is %s",'%courseresversioncache',scalar(%courseresversioncache))); + &logthis(sprintf("%-20s is %s",'%resversioncache',scalar(%resversioncache))); + &flushcourselogs(); + &logthis("Shutting down"); + return DONE; +} + +BEGIN { +# ----------------------------------- Read loncapa.conf and loncapa_apache.conf + unless ($readit) { { - my $config=Apache::File->new("/etc/httpd/conf/access.conf"); + open(my $config,") { - if ($configline =~ /PerlSetVar/) { + if ($configline=~/\S/ && $configline =~ /^[^\#]*PerlSetVar/) { my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); chomp($varvalue); $perlvar{$varname}=$varvalue; } } + close($config); } +{ + open(my $config,") { + if ($configline =~ /^[^\#]*PerlSetVar/) { + my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); + chomp($varvalue); + $perlvar{$varname}=$varvalue; + } + } + close($config); +} + +# ------------------------------------------------------------ Read domain file +{ + %domaindescription = (); + %domain_auth_def = (); + %domain_auth_arg_def = (); + my $fh; + if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) { + while (<$fh>) { + next if (/^(\#|\s*$)/); +# next if /^\#/; + chomp; + my ($domain, $domain_description, $def_auth, $def_auth_arg, + $def_lang, $city, $longi, $lati) = split(/:/,$_); + $domain_auth_def{$domain}=$def_auth; + $domain_auth_arg_def{$domain}=$def_auth_arg; + $domaindescription{$domain}=$domain_description; + $domain_lang_def{$domain}=$def_lang; + $domain_city{$domain}=$city; + $domain_longi{$domain}=$longi; + $domain_lati{$domain}=$lati; + + # &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}"); +# &logthis("Domain.tab: $domain ".$domaindescription{$domain} ); + } + } + close ($fh); +} + # ------------------------------------------------------------- Read hosts file { - my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab"); + open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); while (my $configline=<$config>) { - my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); - $hostname{$id}=$name; - $hostdom{$id}=$domain; - if ($role eq 'library') { $libserv{$id}=$name; } + next if ($configline =~ /^(\#|\s*$)/); + chomp($configline); + my ($id,$domain,$role,$name,$ip,$domdescr)=split(/:/,$configline); + if ($id && $domain && $role && $name && $ip) { + $hostname{$id}=$name; + $hostdom{$id}=$domain; + $hostip{$id}=$ip; + $iphost{$ip}=$id; + if ($role eq 'library') { $libserv{$id}=$name; } + } else { + if ($configline) { + &logthis("Skipping hosts.tab line -$configline-"); + } + } } + close($config); } # ------------------------------------------------------ Read spare server file { - my $config=Apache::File->new("$perlvar{'lonTabDir'}/spare.tab"); + open(my $config,"<$perlvar{'lonTabDir'}/spare.tab"); while (my $configline=<$config>) { chomp($configline); - if (($configline) && ($configline ne $perlvar{'lonHostID'})) { + if ($configline) { $spareid{$configline}=1; } } + close($config); } # ------------------------------------------------------------ Read permissions { - my $config=Apache::File->new("$perlvar{'lonTabDir'}/roles.tab"); + open(my $config,"<$perlvar{'lonTabDir'}/roles.tab"); while (my $configline=<$config>) { - chomp($configline); - my ($role,$perm)=split(/ /,$configline); - if ($perm ne '') { $pr{$role}=$perm; } + chomp($configline); + if ($configline) { + my ($role,$perm)=split(/ /,$configline); + if ($perm ne '') { $pr{$role}=$perm; } + } } + close($config); } # -------------------------------------------- Read plain texts for permissions { - my $config=Apache::File->new("$perlvar{'lonTabDir'}/rolesplain.tab"); + open(my $config,"<$perlvar{'lonTabDir'}/rolesplain.tab"); while (my $configline=<$config>) { - chomp($configline); - my ($short,$plain)=split(/:/,$configline); - if ($plain ne '') { $prp{$short}=$plain; } + chomp($configline); + if ($configline) { + my ($short,$plain)=split(/:/,$configline); + if ($plain ne '') { $prp{$short}=$plain; } + } } + close($config); } -# ------------------------------------------------------------- Read file types +# ---------------------------------------------------------- Read package table { - my $config=Apache::File->new("$perlvar{'lonTabDir'}/filetypes.tab"); + open(my $config,"<$perlvar{'lonTabDir'}/packages.tab"); while (my $configline=<$config>) { - chomp($configline); - my ($ending,$emb,@descr)=split(/\s+/,$configline); - if ($descr[0] ne '') { - $fe{$ending}=$emb; - $fd{$ending}=join(' ',@descr); - } + if ($configline !~ /\S/ || $configline=~/^#/) { next; } + chomp($configline); + my ($short,$plain)=split(/:/,$configline); + my ($pack,$name)=split(/\&/,$short); + if ($plain ne '') { + $packagetab{$pack.'&'.$name.'&name'}=$name; + $packagetab{$short}=$plain; + } } + close($config); +} + +# ------------- set up temporary directory +{ + $tmpdir = $perlvar{'lonDaemons'}.'/tmp/'; + } %metacache=(); -$readit='done'; +$processmarker='_'.time.'_'.$perlvar{'lonHostID'}; +$dumpcount=0; + +&logtouch(); &logthis('INFO: Read configuration'); +$readit=1; } } + 1; +__END__ + +=pod + +=head1 NAME + +Apache::lonnet - Subroutines to ask questions about things in the network. + +=head1 SYNOPSIS + +Invoked by other LON-CAPA modules, when they need to talk to or about objects in the network. + + &Apache::lonnet::SUBROUTINENAME(ARGUMENTS); + +Common parameters: + +=over 4 + +=item * + +$uname : an internal username (if $cname expecting a course Id specifically) + +=item * + +$udom : a domain (if $cdom expecting a course's domain specifically) + +=item * + +$symb : a resource instance identifier + +=item * + +$namespace : the name of a .db file that contains the data needed or +being set. + +=back + +=head1 OVERVIEW + +lonnet provides subroutines which interact with the +lonc/lond (TCP) network layer of LON-CAPA. They can be used to ask +about classes, users, and resources. + +For many of these objects you can also use this to store data about +them or modify them in various ways. + +=head2 Symbs + +To identify a specific instance of a resource, LON-CAPA uses symbols +or "symbs"X. These identifiers are built from the URL of the +map, the resource number of the resource in the map, and the URL of +the resource itself. The latter is somewhat redundant, but might help +if maps change. + +An example is + + msu/korte/parts/part1.sequence___19___msu/korte/tests/part12.problem + +The respective map entry is + + + + +Symbs are used by the random number generator, as well as to store and +restore data specific to a certain instance of for example a problem. + +=head2 Storing And Retrieving Data + +XXXThree of the most important functions +in C are C<&Apache::lonnet::cstore()>, +C<&Apache::lonnet:restore()>, and C<&Apache::lonnet::store()>, which +is is the non-critical message twin of cstore. These functions are for +handlers to store a perl hash to a user's permanent data space in an +easy manner, and to retrieve it again on another call. It is expected +that a handler would use this once at the beginning to retrieve data, +and then again once at the end to send only the new data back. + +The data is stored in the user's data directory on the user's +homeserver under the ID of the course. + +The hash that is returned by restore will have all of the previous +value for all of the elements of the hash. + +Example: + + #creating a hash + my %hash; + $hash{'foo'}='bar'; + + #storing it + &Apache::lonnet::cstore(\%hash); + + #changing a value + $hash{'foo'}='notbar'; + + #adding a new value + $hash{'bar'}='foo'; + &Apache::lonnet::cstore(\%hash); + + #retrieving the hash + my %history=&Apache::lonnet::restore(); + + #print the hash + foreach my $key (sort(keys(%history))) { + print("\%history{$key} = $history{$key}"); + } + +Will print out: + + %history{1:foo} = bar + %history{1:keys} = foo:timestamp + %history{1:timestamp} = 990455579 + %history{2:bar} = foo + %history{2:foo} = notbar + %history{2:keys} = foo:bar:timestamp + %history{2:timestamp} = 990455580 + %history{bar} = foo + %history{foo} = notbar + %history{timestamp} = 990455580 + %history{version} = 2 + +Note that the special hash entries C, C and +C were added to the hash. C will be equal to the +total number of versions of the data that have been stored. The +C attribute will be the UNIX time the hash was +stored. C is available in every historical section to list which +keys were added or changed at a specific historical revision of a +hash. + +B: do not store the hash that restore returns directly. This +will cause a mess since it will restore the historical keys as if the +were new keys. I.E. 1:foo will become 1:1:foo etc. + +Calling convention: + + my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname,$home); + &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$home); + +For more detailed information, see lonnet specific documentation. + +=head1 RETURN MESSAGES + +=over 4 + +=item * B: unable to contact remote host + +=item * B: unable to contact remote host, message will be delivered +when the connection is brought back up + +=item * B: unable to contact remote host and unable to save message +for later delivery + +=item * B: an error a occured, a description of the error follows the : + +=item * B: unable to fund a host associated with the user/domain +that was requested + +=back + +=head1 PUBLIC SUBROUTINES + +=head2 Session Environment Functions + +=over 4 + +=item * +X +B: the value of %hash is written to +the user envirnoment file, and will be restored for each access this +user makes during this session, also modifies the %ENV for the current +process + +=item * +X +B: removes all items from the session +environment file that matches the regular expression in $regexp. The +values are also delted from the current processes %ENV. + +=back + +=head2 User Information + +=over 4 + +=item * +X +B: try to determine user's current +authentication scheme + +=item * +X +B: try to +authenticate user from domain's lib servers (first use the current +one). C<$upass> should be the users password. + +=item * +X +B: find the server which has +the user's directory and files (there must be only one), this caches +the answer, and also caches if there is a borken connection. + +=item * +X +B: find the usernames behind a list of IDs +(IDs are a unique resource in a domain, there must be only 1 ID per +username, and only 1 username per ID in a specific domain) (returns +hash: id=>name,id=>name) + +=item * +X +B: find the IDs behind a list of +usernames (returns hash: name=>id,name=>id) + +=item * +X +B: store away a list of names and associated IDs + +=item * +X +B: get user privileges + +=item * +X +B: finds the section of student in the +course $cname, return section name/number or '' for "not in course" +and '-1' for "no section" + +=item * +X +B: gets the values of the keys +passed in @what from the requested user's environment, returns a hash + +=back + +=head2 User Roles + +=over 4 + +=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 * + +plaintext($short) : return value in %prp hash (rolesplain.tab); plain text +explanation of a user role term + +=back + +=head2 User Modification + +=over 4 + +=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 * + +changepass($uname,$udom,$currentpass,$newpass,$server) : attempts to +change a users, password, possible return values are: ok, +pwchange_failure, non_authorized, auth_mode_error, unknown_user, +refused + +=item * + +modifyuserauth($udom,$uname,$umode,$upass) : modify user authentication + +=item * + +modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) : +modify user + +=item * + +modifystudent + +modify a students enrollment and identification information. +The course id is resolved based on the current users environment. +This means the envoking user must be a course coordinator or otherwise +associated with a course. + +This call is essentially a wrapper for lonnet::modifyuser and +lonnet::modify_student_enrollment + +Inputs: + +=over 4 + +=item B<$udom> Students loncapa domain + +=item B<$uname> Students loncapa login name + +=item B<$uid> Students id/student number + +=item B<$umode> Students authentication mode + +=item B<$upass> Students password + +=item B<$first> Students first name + +=item B<$middle> Students middle name + +=item B<$last> Students last name + +=item B<$gene> Students generation + +=item B<$usec> Students section in course + +=item B<$end> Unix time of the roles expiration + +=item B<$start> Unix time of the roles start date + +=item B<$forceid> If defined, allow $uid to be changed + +=item B<$desiredhome> server to use as home server for student + +=back + +=item * + +modify_student_enrollment + +Change a students enrollment status in a class. The environment variable +'role.request.course' must be defined for this function to proceed. + +Inputs: + +=over 4 + +=item $udom, students domain + +=item $uname, students name + +=item $uid, students user id + +=item $first, students first name + +=item $middle + +=item $last + +=item $gene + +=item $usec + +=item $end + +=item $start + +=back + + +=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 + +=back + +=head2 Course Infomation + +=over 4 + +=item * + +coursedescription($courseid) : course description + +=item * + +courseresdata($coursenum,$coursedomain,@which) : request for current +parameter setting for a specific course, @what should be a list of +parameters to ask about. This routine caches answers for 5 minutes. + +=back + +=head2 Course Modification + +=over 4 + +=item * + +writecoursepref($courseid,%prefs) : write preferences (environment +database) for a course + +=item * + +createcourse($udom,$description,$url) : make/modify course + +=back + +=head2 Resource Subroutines + +=over 4 + +=item * + +subscribe($fname) : subscribe to a resource, returns URL if possible (probably should use repcopy instead) + +=item * + +repcopy($filename) : subscribes to the requested file, and attempts to +replicate from the owning library server, Might return +HTTP_SERVICE_UNAVAILABLE, HTTP_NOT_FOUND, FORBIDDEN, OK, or +HTTP_BAD_REQUEST, also attempts to grab the metadata for the +resource. Expects the local filesystem pathname +(/home/httpd/html/res/....) + +=back + +=head2 Resource Information + +=over 4 + +=item * + +EXT($varname,$symb,$udom,$uname) : evaluates and returns the value of +a vairety of different possible values, $varname should be a request +string, and the other parameters can be used to specify who and what +one is asking about. + +Possible values for $varname are environment.lastname (or other item +from the envirnment hash), user.name (or someother aspect about the +user), resource.0.maxtries (or some other part and parameter of a +resource) + +=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 * + +metadata($uri,$what,$liburi,$prefix,$depthcount) : request a +resource's metadata, $what should be either a specific key, or either +'keys' (to get a list of possible keys) or 'packages' to get a list of +packages that this resource currently uses, the last 3 arguments are only used internally for recursive metadata. + +this function automatically caches all requests + +=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 * + +symbread($filename) : return symbolic list entry (filename argument optional); +returns the data handle + +=item * + +symbverify($symb,$thisfn) : verifies that $symb actually exists and is +a possible symb for the URL in $thisfn, returns a 1 on success, 0 on +failure, user must be in a course, as it assumes the existance of the +course initi hash, and uses $ENV('request.course.id'} + + +=item * + +symbclean($symb) : removes versions numbers from a symb, returns the +cleaned symb + +=item * + +is_on_map($uri) : checks if the $uri is somewhere on the current +course map, user must be in a course for it to work. + +=item * + +numval($salt) : return random seed value (addend for rndseed) + +=item * + +rndseed($symb,$courseid,$udom,$uname) : 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 * + +countacc($url) : count the number of accesses to a given URL + +=item * + +checkout($symb,$tuname,$tudom,$tcrsid) : creates a record of a user having looked at an item, most likely printed out or otherwise using a resource + +=item * + +checkin($token) : updates that a resource has beeen returned (a hard copy version for instance) and returns the data that $token was Checkout with ($symb, $tuname, $tudom, and $tcrsid) + +=item * + +expirespread($uname,$udom,$stype,$usymb) : set expire date for spreadsheet + +=item * + +devalidate($symb) : devalidate temporary spreadsheet calculations, +forcing spreadsheet to reevaluate the resource scores next time. + +=back + +=head2 Storing/Retreiving Data + +=over 4 + +=item * + +store($storehash,$symb,$namespace,$udom,$uname) : 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,$udom,$uname) : same as store but +uses critical subroutine + +=item * + +restore($symb,$namespace,$udom,$uname) : returns hash for this symb; +all args are optional + +=item * + +tmpstore($storehash,$symb,$namespace,$udom,$uname) : storage that +works very similar to store/cstore, but all data is stored in a +temporary location and can be reset using tmpreset, $storehash should +be a hash reference, returns nothing on success + +=item * + +tmprestore($symb,$namespace,$udom,$uname) : storage that works very +similar to restore, but all data is stored in a temporary location and +can be reset using tmpreset. Returns a hash of values on success, +error string otherwise. + +=item * + +tmpreset($symb,$namespace,$udom,$uname) : temporary storage reset, +deltes all keys for $symb form the temporary storage hash. + +=item * + +get($namespace,$storearr,$udom,$uname) : returns hash with keys from array +reference filled in from namesp ($udom and $uname are optional) + +=item * + +del($namespace,$storearr,$udom,$uname) : deletes keys out of array from +namesp ($udom and $uname are optional) + +=item * + +dump($namespace,$udom,$uname,$regexp) : +dumps the complete (or key matching regexp) namespace into a hash +($udom, $uname and $regexp are optional) + +=item * + +inc($namespace,$store,$udom,$uname) : increments $store in $namespace. +$store can be a scalar, an array reference, or if the amount to be +incremented is > 1, a hash reference. + +($udom and $uname are optional) + +=item * + +put($namespace,$storehash,$udom,$uname) : stores hash in namesp +($udom and $uname are optional) + +=item * + +cput($namespace,$storehash,$udom,$uname) : critical put +($udom and $uname are optional) + +=item * + +eget($namespace,$storearr,$udom,$uname) : returns hash with keys from array +reference filled in from namesp (encrypts the return communication) +($udom and $uname are optional) + +=item * + +log($udom,$name,$home,$message) : write to permanent log for user; use +critical subroutine + +=back + +=head2 Network Status Functions + +=over 4 + +=item * + +dirlist($uri) : return directory list based on URI + +=item * + +spareserver() : find server with least workload from spare.tab + +=back + +=head2 Apache Request + +=over 4 + +=item * + +ssi($url,%hash) : server side include, does a complete request cycle on url to +localhost, posts hash + +=back + +=head2 Data to String to Data + +=over 4 + +=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 + +=back + +=head2 Logging Routines + +=over 4 + +These routines allow one to make log messages in the lonnet.log and +lonnet.perm logfiles. + +=item * + +logtouch() : make sure the logfile, lonnet.log, exists + +=item * + +logthis() : append message to the normal lonnet.log file, it gets +preiodically rolled over and deleted. + +=item * + +logperm() : append a permanent message to lonnet.perm.log, this log +file never gets deleted by any automated portion of the system, only +messages of critical importance should go in here. + +=back + +=head2 General File Helper Routines + +=over 4 + +=item * + +getfile($file,$caller) : two cases - requests for files in /res or in /uploaded. +(a) files in /uploaded + (i) If a local copy of the file exists - + compares modification date of local copy with last-modified date for + definitive version stored on home server for course. If local copy is + stale, requests a new version from the home server and stores it. + If the original has been removed from the home server, then local copy + is unlinked. + (ii) If local copy does not exist - + requests the file from the home server and stores it. + + If $caller is 'uploadrep': + This indicates a call from lonuploadrep.pm (PerlHeaderParserHandler phase) + for request for files originally uploaded via DOCS. + - returns 'ok' if fresh local copy now available, -1 otherwise. + + Otherwise: + This indicates a call from the content generation phase of the request. + - returns the entire contents of the file or -1. + +(b) files in /res + - returns the entire contents of a file or -1; + it properly subscribes to and replicates the file if neccessary. + +=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) + +=back + +=head2 HTTP Helper Routines + +=over 4 + +=item * + +escape() : unpack non-word characters into CGI-compatible hex codes + +=item * + +unescape() : pack CGI-compatible hex codes into actual non-word ASCII character + +=back + +=head1 PRIVATE SUBROUTINES + +=head2 Underlying communication routines (Shouldn't call) + +=over 4 + +=item * + +subreply() : tries to pass a message to lonc, returns con_lost if incapable + +=item * + +reply() : uses subreply to send a message to remote machine, logs all failures + +=item * + +critical() : passes a critical message to another server; if cannot +get through then place message in connection buffer directory and +returns con_delayed, if incapable of saving message, returns +con_failed + +=item * + +reconlonc() : tries to reconnect lonc client processes. + +=back + +=head2 Resource Access Logging + +=over 4 + +=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 * + +goodbye() : flush course logs and log shutting down; it is called in srm.conf +as a PerlChildExitHandler + +=back + +=head2 Other + +=over 4 + +=item * + +symblist($mapname,%newhash) : update symbolic storage links + +=back + +=cut