--- loncom/lonnet/perl/lonnet.pm 2002/06/24 20:25:44 1.244 +++ loncom/lonnet/perl/lonnet.pm 2004/07/16 17:56:01 1.522 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.244 2002/06/24 20:25:44 matthew Exp $ +# $Id: lonnet.pm,v 1.522 2004/07/16 17:56:01 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -25,75 +25,63 @@ # # http://www.lon-capa.org/ # -# 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30, -# 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19, -# 11/8,11/16,11/18,11/22,11/23,12/22, -# 01/06,01/13,02/24,02/28,02/29, -# 03/01,03/02,03/06,03/07,03/13, -# 04/05,05/29,05/31,06/01, -# 06/05,06/26 Gerd Kortemeyer -# 06/26 Ben Tyszka -# 06/30,07/15,07/17,07/18,07/20,07/21,07/22,07/25 Gerd Kortemeyer -# 08/14 Ben Tyszka -# 08/22,08/28,08/31,09/01,09/02,09/04,09/05,09/25,09/28,09/30 Gerd Kortemeyer -# 10/04 Gerd Kortemeyer -# 10/04 Guy Albertelli -# 10/06,10/09,10/10,10/11,10/14,10/20,10/23,10/25,10/26,10/27,10/28,10/29, -# 10/30,10/31, -# 11/2,11/14,11/15,11/16,11/20,11/21,11/22,11/25,11/27, -# 12/02,12/12,12/13,12/14,12/28,12/29 Gerd Kortemeyer -# 05/01/01 Guy Albertelli -# 05/01,06/01,09/01 Gerd Kortemeyer -# 09/01 Guy Albertelli -# 09/01,10/01,11/01 Gerd Kortemeyer -# YEAR=2001 -# 02/27/01 Scott Harrison -# 3/2 Gerd Kortemeyer -# 3/15,3/19 Scott Harrison -# 3/19,3/20 Gerd Kortemeyer -# 3/22,3/27,4/2,4/16,4/17 Scott Harrison -# 5/26,5/28 Gerd Kortemeyer -# 5/30 H. K. Ng -# 6/1 Gerd Kortemeyer -# July Guy Albertelli -# 8/4,8/7,8/8,8/9,8/11,8/16,8/17,8/18,8/20,8/23,9/20,9/21,9/26, -# 10/2 Gerd Kortemeyer -# 10/5,10/10,11/13,11/15 Scott Harrison -# 11/17,11/20,11/22,11/29 Gerd Kortemeyer -# 12/5 Matthew Hall -# 12/5 Guy Albertelli -# 12/6,12/7,12/12 Gerd Kortemeyer -# 12/18 Scott Harrison -# 12/21,12/22,12/27,12/28 Gerd Kortemeyer -# YEAR=2002 -# 1/4,2/4,2/7 Gerd Kortemeyer -# ### package Apache::lonnet; use strict; -use Apache::File; use LWP::UserAgent(); use HTTP::Headers; +use HTTP::Date; +# use Date::Parse; use vars -qw(%perlvar %hostname %homecache %badServerCache %hostip %spareid %hostdom - %libserv %pr %prp %metacache %packagetab - %courselogs %accesshash $processmarker $dumpcount - %coursedombuf %coursehombuf %courseresdatacache); +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 %courseinstcodebuf %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::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") { - my $fh=Apache::File->new(">>$execdir/logs/lonnet.log"); + unless (-e "$execdir/logs/lonnet.log") { + open(my $fh,">>$execdir/logs/lonnet.log"); close $fh; } my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3]; @@ -105,8 +93,10 @@ sub logthis { 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; } @@ -115,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; } @@ -140,9 +132,9 @@ sub reply { unless (defined($hostname{$server})) { return 'no_such_host'; } my $answer=subreply($cmd,$server); if ($answer eq 'con_lost') { - #sleep 5; - #$answer=subreply($cmd,$server); - #if ($answer eq 'con_lost') { + #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", @@ -168,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) { @@ -213,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) { @@ -245,6 +240,49 @@ 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 { @@ -261,47 +299,47 @@ sub appenv { } 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 @@ -316,51 +354,123 @@ 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: '.$!; - } - foreach (@oldenv) { - unless ($_=~/^$delthis/) { print $fh $_; } - } - $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 409; + } + 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; } @@ -403,38 +513,16 @@ sub changepass { sub queryauthenticate { my ($uname,$udom)=@_; - if (($perlvar{'lonRole'} eq 'library') && - ($udom eq $perlvar{'lonDefDomain'})) { - my $answer=reply("encrypt:currentauth:$udom:$uname", - $perlvar{'lonHostID'}); - unless ($answer eq 'unknown_user' or $answer eq 'refused') { - if (length($answer)) { - return $answer; - } - else { - &logthis("User $uname at $udom lacks an authentication mechanism"); - return 'no_host'; - } - } - } - - my $tryserver; - foreach $tryserver (keys %libserv) { - if ($hostdom{$tryserver} eq $udom) { - my $answer=reply("encrypt:currentauth:$udom:$uname",$tryserver); - unless ($answer eq 'unknown_user' or $answer eq 'refused') { - if (length($answer)) { - return $answer; - } - else { - &logthis("User $uname at $udom lacks an authentication mechanism"); - return 'no_host'; - } - } - } + 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"); } - &logthis("User $uname at $udom lacks an authentication mechanism"); - return 'no_host'; + return $answer; } # --------- Try to authenticate user from domain's lib servers (first this one) @@ -443,38 +531,21 @@ sub authenticate { my ($uname,$upass,$udom)=@_; $upass=escape($upass); $uname=~s/\W//g; - if (($perlvar{'lonRole'} eq 'library') && - ($udom eq $perlvar{'lonDefDomain'})) { - my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'}); - if ($answer =~ /authorized/) { - if ($answer eq 'authorized') { - &logthis("User $uname at $udom authorized by local server"); - return $perlvar{'lonHostID'}; - } - if ($answer eq 'non_authorized') { - &logthis("User $uname at $udom rejected by local server"); - return 'no_host'; - } - } - } - - my $tryserver; - foreach $tryserver (keys %libserv) { - if ($hostdom{$tryserver} eq $udom) { - my $answer=reply("encrypt:auth:$udom:$uname:$upass",$tryserver); - if ($answer =~ /authorized/) { - if ($answer eq 'authorized') { - &logthis("User $uname at $udom authorized by $tryserver"); - return $tryserver; - } - if ($answer eq 'non_authorized') { - &logthis("User $uname at $udom rejected by $tryserver"); - return 'no_host'; - } - } - } + 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'; } @@ -483,9 +554,9 @@ sub authenticate { sub homeserver { 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' && @@ -493,8 +564,7 @@ sub homeserver { 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; } @@ -547,6 +617,7 @@ sub idput { my ($udom,%ids)=@_; my %servers=(); foreach (keys %ids) { + &cput('environment',{'id'=>$ids{$_}},$udom,$_); my $uhom=&homeserver($_,$udom); if ($uhom ne 'no_host') { my $id=&escape($ids{$_}); @@ -557,7 +628,6 @@ sub idput { } else { $servers{$uhom}=$id.'='.$unam; } - &critical('put:'.$udom.':'.$unam.':environment:id='.$id,$uhom); } } foreach (keys %servers) { @@ -565,17 +635,341 @@ sub idput { } } +# --------------------------------------------------- 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/; 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)); @@ -587,10 +981,12 @@ sub usection { if ($end) { if ($now>$end) { $notactive=1; } } - unless ($notactive) { return $section; } + unless ($notactive) { + return &do_cache(\%usectioncache,$hashid,$section,'usection'); + } } } - return '-1'; + return &do_cache(\%usectioncache,$hashid,'-1','usection'); } # ------------------------------------- Read an entry from a user's environment @@ -608,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')) { @@ -639,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"); @@ -647,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") { @@ -682,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 { @@ -708,6 +1161,201 @@ 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); +} + +# --------- 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 { @@ -716,12 +1364,24 @@ sub log { } # ------------------------------------------------------------------ Course Log +# +# This routine flushes several buffers of non-mission-critical nature +# sub flushcourselogs { - &logthis('Flushing course log buffers'); + &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}.':'. + if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'. &escape($courselogs{$crsid}), $coursehombuf{$crsid}) eq 'ok') { delete $courselogs{$crsid}; @@ -732,15 +1392,71 @@ sub flushcourselogs { " exceeded maximum size, deleting."); delete $courselogs{$crsid}; } - } + } + if ($courseidbuffer{$coursehombuf{$crsid}}) { + $courseidbuffer{$coursehombuf{$crsid}}.='&'. + &escape($crsid).'='.&escape($coursedescrbuf{$crsid}). + '='.&escape($courseinstcodebuf{$crsid}); + } else { + $courseidbuffer{$coursehombuf{$crsid}}= + &escape($crsid).'='.&escape($coursedescrbuf{$crsid}). + '='.&escape($courseinstcodebuf{$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}; + } + } } - &logthis('Flushing access logs'); - foreach (keys %accesshash) { +# +# Roles +# Reverse lookup of user roles for course faculty/staff and co-authorship +# + foreach (keys %userrolehash) { my $entry=$_; - $entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/; - my %temphash=($entry => $accesshash{$entry}); - if (&Apache::lonnet::put('resevaldata',\%temphash,$1,$2) eq 'ok') { - delete $accesshash{$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++; @@ -751,10 +1467,15 @@ sub courselog { $what=time.':'.$what; unless ($ENV{'request.course.id'}) { return ''; } $coursedombuf{$ENV{'request.course.id'}}= - $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'. + $ENV{'course.'.$ENV{'request.course.id'}.'.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'}; + $courseinstcodebuf{$ENV{'request.course.id'}}= + $ENV{'course.'.$ENV{'request.course.id'}.'.internal.coursecode'}; if (defined $courselogs{$ENV{'request.course.id'}}) { $courselogs{$ENV{'request.course.id'}}.='&'.$what; } else { @@ -769,7 +1490,7 @@ 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)$/) { + if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|page)$/) { $what.=':POST'; foreach (keys %ENV) { if ($_=~/^form\.(.*)/) { @@ -782,18 +1503,168 @@ sub courseacclog { 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'; - if (defined($accesshash{$key})) { - $accesshash{$key}++; + 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 { - $accesshash{$key}=1; + 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,$hostidflag,$hostidref)=@_; + my %returnhash=(); + unless ($domfilter) { $domfilter=''; } + foreach my $tryserver (keys %libserv) { + if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) || (!defined($hostidflag)) ) { + 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)}=$value; + } + } + } + } + } + return %returnhash; +} + +# # ----------------------------------------------------------- Check out an item +sub get_first_access { + my ($type,$argsymb)=@_; + my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); + if ($argsymb) { $symb=$argsymb; } + my ($map,$id,$res)=&decode_symb($symb); + if ($type eq 'map') { $res=$map; } + my %times=&get('firstaccesstimes',[$res],$udom,$uname); + return $times{$res}; +} + +sub set_first_access { + my ($type)=@_; + my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); + my ($map,$id,$res)=&decode_symb($symb); + if ($type eq 'map') { $res=$map; } + my $firstaccess=&get_first_access($type); + if (!$firstaccess) { + return &put('firstaccesstimes',{$res=>time},$udom,$uname); + } + return 'already_set'; +} + sub checkout { my ($symb,$tuname,$tudom,$tcrsid)=@_; my $now=time; @@ -899,117 +1770,219 @@ 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= - &del('nohist_calculatedsheet', - [$key.'studentcalc'], + &del('nohist_calculatedsheets', + [$key.'studentcalc:'], $ENV{'course.'.$cid.'.domain'}, $ENV{'course.'.$cid.'.num'}) .' '. &del('nohist_calculatedsheets_'.$cid, - [$key.'assesscalc:'.$symb]); + [$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__'; + my $result='__ARRAY_REF__'; foreach my $elem (@$arrayref) { - if (ref($elem) eq 'ARRAY') { - $result.=&escape(&arrayref2str($elem)).'&'; - } elsif (ref($elem) eq 'HASH') { - $result.=&escape(&hashref2str($elem)).'&'; - } elsif (ref($elem)) { - &logthis("Got a ref of ".(ref($elem))." skipping."); + 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/^__HASH_REF__//; + $result=~s/__END_HASH_REF__$//; return $result; } sub hashref2str { my ($hashref)=@_; - my $result='_HASH_REF__'; - foreach (keys(%$hashref)) { + my $result='__HASH_REF__'; + foreach (sort(keys(%$hashref))) { if (ref($_) eq 'ARRAY') { - $result.=&escape(&arrayref2str($_)).'='; + $result.=&arrayref2str($_).'='; } elsif (ref($_) eq 'HASH') { - $result.=&escape(&hashref2str($_)).'='; + $result.=&hashref2str($_).'='; } elsif (ref($_)) { - &logthis("Got a ref of ".(ref($_))." skipping."); + $result.='='; + #print("Got a ref of ".(ref($_))." skipping."); } else { - $result.=&escape($_).'='; + if ($_) {$result.=&escape($_).'=';} else { last; } } - if (ref($$hashref{$_}) eq 'ARRAY') { - $result.=&escape(&arrayref2str($$hashref{$_})).'&'; - } elsif (ref($$hashref{$_}) eq 'HASH') { - $result.=&escape(&hashref2str($$hashref{$_})).'&'; - } elsif (ref($$hashref{$_})) { - &logthis("Got a ref of ".(ref($$hashref{$_}))." skipping."); + 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.=&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 %returnhash; - foreach (split(/\&/,$string)) { - my ($name,$value)=split(/\=/,$_); - $name=&unescape($name); - $value=&unescape($value); - if ($value =~ /^_HASH_REF__/) { - $value =~ s/^_HASH_REF__//; - my %hash=&str2hash($value); - $value=\%hash; - } elsif ($value =~ /^_ARRAY_REF__/) { - $value =~ s/^_ARRAY_REF__//; - my @array=&str2array($value); - $value=\@array; - } - $returnhash{$name}=$value; + + my %hash; + + if($string !~ /^__HASH_REF__/) { + if (! ($string eq '' || !defined($string))) { + $hash{'error'}='Not hash reference'; + } + return (\%hash, $string); } - return (%returnhash); + + $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 @returnarray; - foreach my $value (split(/\&/,$string)) { - $value=&unescape($value); - if ($value =~ /^_HASH_REF__/) { - $value =~ s/^_HASH_REF__//; - my %hash=&str2hash($value); - $value=\%hash; - } elsif ($value =~ /^_ARRAY_REF__/) { - $value =~ s/^_ARRAY_REF__//; - my @array=&str2array($value); - $value=\@array; - } - push(@returnarray,$value); + 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); } - return (@returnarray); + + $string =~ s/^__END_ARRAY_REF__//; + + return (\@array, $string); } # -------------------------------------------------------------------Temp Store @@ -1018,7 +1991,7 @@ sub tmpreset { my ($symb,$namespace,$domain,$stuname) = @_; if (!$symb) { $symb=&symbread(); - if (!$symb) { $symb= $ENV{'REQUEST_URI'}; } + if (!$symb) { $symb= $ENV{'request.url'}; } } $symb=escape($symb); @@ -1033,7 +2006,7 @@ sub tmpreset { my %hash; if (tie(%hash,'GDBM_File', $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', - &GDBM_WRCREAT,0640)) { + &GDBM_WRCREAT(),0640)) { foreach my $key (keys %hash) { if ($key=~ /:$symb/) { delete($hash{$key}); @@ -1069,7 +2042,7 @@ sub tmpstore { my $path=$perlvar{'lonDaemons'}.'/tmp'; if (tie(%hash,'GDBM_File', $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', - &GDBM_WRCREAT,0640)) { + &GDBM_WRCREAT(),0640)) { $hash{"version:$symb"}++; my $version=$hash{"version:$symb"}; my $allkeys=''; @@ -1113,7 +2086,7 @@ sub tmprestore { my $path=$perlvar{'lonDaemons'}.'/tmp'; if (tie(%hash,'GDBM_File', $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', - &GDBM_READER,0640)) { + &GDBM_READER(),0640)) { my $version=$hash{"version:$symb"}; $returnhash{'version'}=$version; my $scope; @@ -1147,7 +2120,10 @@ sub store { $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); if (!$namespace) { @@ -1155,9 +2131,11 @@ sub store { return ''; } } - if (!$domain) { $domain=$ENV{'user.domain'}; } - if (!$stuname) { $stuname=$ENV{'user.name'}; } if (!$home) { $home=$ENV{'user.home'}; } + + $$storehash{'ip'}=$ENV{'REMOTE_ADDR'}; + $$storehash{'host'}=$perlvar{'lonHostID'}; + my $namevalue=''; foreach (keys %$storehash) { $namevalue.=escape($_).'='.escape($$storehash{$_}).'&'; @@ -1178,7 +2156,10 @@ sub cstore { $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); if (!$namespace) { @@ -1186,10 +2167,11 @@ sub cstore { return ''; } } - if (!$domain) { $domain=$ENV{'user.domain'}; } - if (!$stuname) { $stuname=$ENV{'user.name'}; } if (!$home) { $home=$ENV{'user.home'}; } + $$storehash{'ip'}=$ENV{'REMOTE_ADDR'}; + $$storehash{'host'}=$perlvar{'lonHostID'}; + my $namevalue=''; foreach (keys %$storehash) { $namevalue.=escape($_).'='.escape($$storehash{$_}).'&'; @@ -1245,29 +2227,61 @@ sub coursedescription { $courseid=~s/\_/\//g; my ($cdomain,$cnum)=split(/\//,$courseid); 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 %returnhash=&dump('environment',$cdomain,$cnum); + %returnhash=&dump('environment',$cdomain,$cnum); if (!exists($returnhash{'con_lost'})) { - my $normalid=$cdomain.'_'.$cnum; - my %envhash=(); $returnhash{'home'}= $chome; $returnhash{'domain'} = $cdomain; $returnhash{'num'} = $cnum; while (my ($name,$value) = each %returnhash) { $envhash{'course.'.$normalid.'.'.$name}=$value; } - $returnhash{'url'}='/res/'.declutter($returnhash{'url'}); + $returnhash{'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 @@ -1290,6 +2304,8 @@ sub rolesinit { 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=''; @@ -1301,42 +2317,54 @@ 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'}; + } + } + } + } } } } @@ -1384,6 +2412,9 @@ sub get { 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; foreach (@$storearr) { @@ -1431,6 +2462,104 @@ sub dump { 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 { @@ -1484,14 +2613,49 @@ sub eget { 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')) { @@ -1502,7 +2666,9 @@ sub allowed { if ($priv eq 'bre') { my $copyright=&metadata($uri,'copyright'); - if ($copyright eq 'public') { return 'F'; } + 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)) { @@ -1516,6 +2682,20 @@ sub allowed { 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=''; @@ -1524,14 +2704,14 @@ sub allowed { # 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; } @@ -1541,10 +2721,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/) { @@ -1553,7 +2744,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:cca:'=~/\:$priv\:/) { + if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:\Q$priv\E\:/) { return $thisallowed; } # @@ -1574,7 +2765,7 @@ sub allowed { if ($match) { $statecond=$cond; if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} - =~/$priv\&([^\:]*)/) { + =~/\Q$priv\E\&([^\:]*)/) { $thisallowed.=$1; $checkreferer=0; } @@ -1602,7 +2793,7 @@ sub allowed { if ($match) { my $refstatecond=$cond; if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} - =~/$priv\&([^\:]*)/) { + =~/\Q$priv\E\&([^\:]*)/) { $thisallowed.=$1; $uri=$refuri; $statecond=$refstatecond; @@ -1655,7 +2846,7 @@ 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'}, @@ -1666,7 +2857,7 @@ sub allowed { 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'}, @@ -1700,7 +2891,7 @@ sub allowed { 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'}); @@ -1708,7 +2899,7 @@ sub allowed { } if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.users.denied'} - =~/$unamedom/) { + =~/\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'}); @@ -1720,26 +2911,22 @@ sub allowed { 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 { @@ -1754,17 +2941,43 @@ sub allowed { 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/\/$filename$//; + $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}=~ - /\&$filename\:([\d\|]+)\&/); + /\&\Q$filename\E\:([\d\|]+)\&/); if ($match) { - return (1,$1); - } else { - return (0,0); - } + 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 @@ -1772,29 +2985,29 @@ sub is_on_map { sub definerole { if (allowed('mcr','/')) { my ($rolename,$sysrole,$domrole,$courole)=@_; - foreach (split('/',$sysrole)) { + 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"; } } } - foreach (split('/',$domrole)) { + 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"; } } } - foreach (split('/',$courole)) { + 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"; } } @@ -1841,10 +3054,63 @@ sub log_query { my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys %filters)); my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command, $uhome); - unless ($queryid=~/^$uhost\_/) { return 'error: '.$queryid; } + unless ($queryid=~/^\Q$uhost\E\_/) { return 'error: '.$queryid; } return get_query_reply($queryid); } +# ------- Request retrieval of institutional classlists for course(s) + +sub fetch_enrollment_query { + my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_; + my $homeserver; + if ($context eq 'automated') { + $homeserver = $perlvar{'lonHostID'}; + } else { + $homeserver = &homeserver($cnum,$dom); + } + my $host=$hostname{$homeserver}; + my $cmd = ''; + foreach (keys %{$affiliatesref}) { + $cmd .= $_.'='.join(",",@{$$affiliatesref{$_}}).'%%'; + } + $cmd =~ s/%%$//; + $cmd = &escape($cmd); + my $query = 'fetchenrollment'; + my $queryid=&reply("querysend:".$query.':'.$dom.':'.$ENV{'user.name'}.':'.$cmd,$homeserver); + unless ($queryid=~/^\Q$host\E\_/) { return 'error: '.$queryid; } + my $reply = &get_query_reply($queryid); + unless ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { + my @responses = split/:/,$reply; + if ($homeserver eq $perlvar{'lonHostID'}) { + foreach (@responses) { + my ($key,$value) = split/=/,$_; + $$replyref{$key} = $value; + } + } else { + my $pathname = $perlvar{'lonDaemons'}.'/tmp'; + foreach (@responses) { + my ($key,$value) = split/=/,$_; + $$replyref{$key} = $value; + if ($value > 0) { + foreach (@{$$affiliatesref{$key}}) { + my $filename = $dom.'_'.$key.'_'.$_.'_classlist.xml'; + my $destname = $pathname.'/'.$filename; + my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver); + unless ($xml_classlist =~ /^error/) { + if ( open(FILE,">$destname") ) { + print FILE &unescape($xml_classlist); + close(FILE); + } + } + } + } + } + } + return 'ok'; + } + return 'error'; +} + sub get_query_reply { my $queryid=shift; my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid; @@ -1852,9 +3118,9 @@ sub get_query_reply { for (1..100) { sleep 2; if (-e $replyfile.'.end') { - if (my $fh=Apache::File->new($replyfile)) { + if (open(my $fh,$replyfile)) { $reply.=<$fh>; - $fh->close; + close($fh); } else { return 'error: reply_file_error'; } return &unescape($reply); } @@ -1889,20 +3155,96 @@ sub userlog_query { return &log_query($uname,$udom,'userlog',%filters); } +#--------- Call auto-enrollment subs in localenroll.pm for homeserver for course + +sub auto_run { + my ($cnum,$cdom) = @_; + my $homeserver = &homeserver($cnum,$cdom); + my $response = &reply('autorun:'.$cdom,$homeserver); + return $response; +} + +sub auto_get_sections { + my ($cnum,$cdom,$inst_coursecode) = @_; + my $homeserver = &homeserver($cnum,$cdom); + my @secs = (); + my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver)); + unless ($response eq 'refused') { + @secs = split/:/,$response; + } + return @secs; +} + +sub auto_new_course { + my ($cnum,$cdom,$inst_course_id,$owner) = @_; + my $homeserver = &homeserver($cnum,$cdom); + my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver)); + return $response; +} + +sub auto_validate_courseID { + my ($cnum,$cdom,$inst_course_id) = @_; + my $homeserver = &homeserver($cnum,$cdom); + my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver)); + return $response; +} + +sub auto_create_password { + my ($cnum,$cdom,$authparam) = @_; + my $homeserver = &homeserver($cnum,$cdom); + my $create_passwd = 0; + my $authchk = ''; + my $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver)); + if ($response eq 'refused') { + $authchk = 'refused'; + } else { + ($authparam,$create_passwd,$authchk) = split/:/,$response; + } + return ($authparam,$create_passwd,$authchk); +} + +sub auto_instcode_format { + my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_; + my $courses = ''; + my $homeserver; + if ($caller eq 'global') { + $homeserver = $perlvar{'lonHostID'}; + } else { + $homeserver = &homeserver($caller,$codedom); + } + my $host=$hostname{$homeserver}; + foreach (keys %{$instcodes}) { + $courses .= &escape($_).'='.&escape($$instcodes{$_}).'&'; + } + chop($courses); + my $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$homeserver); + unless ($response =~ /(con_lost|error|no_such_host|refused)/) { + my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = split/:/,$response; + %{$codes} = &str2hash($codes_str); + @{$codetitles} = &str2array($codetitles_str); + %{$cat_titles} = &str2hash($cat_titles_str); + %{$cat_order} = &str2hash($cat_order_str); + return 'ok'; + } + return $response; +} + # ------------------------------------------------------------------ Plain Text sub plaintext { my $short=shift; - return $prp{$short}; + 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'}); @@ -1912,7 +3254,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'}); @@ -1930,7 +3272,25 @@ 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 user authentication @@ -1941,7 +3301,8 @@ sub modifyuserauth { 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'}); + $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'}, @@ -1964,7 +3325,7 @@ sub modifyuser { my ($udom, $uname, $uid, $umode, $upass, $first, $middle, $last, $gene, - $forceid, $desiredhome)=@_; + $forceid, $desiredhome, $email)=@_; $udom=~s/\W//g; $uname=~s/\W//g; &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. @@ -1972,10 +3333,12 @@ sub modifyuser { $last.', '.$gene.'(forceid: '.$forceid.')'. (defined($desiredhome) ? ' desiredhome = '.$desiredhome : ' desiredhome not specified'). - ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}); + ' 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 (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) { $unhome = $desiredhome; @@ -2005,7 +3368,7 @@ sub modifyuser { } $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 @@ -2015,21 +3378,34 @@ sub modifyuser { 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=&get('environment', + my @tmp=&get('environment', ['firstname','middlename','lastname','generation'], $udom,$uname); - if ($names{'firstname'} =~ m/^error:.*/) { %names=(); } + 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 ($middle) { $names{'middlename'} = $middle; } + if (defined($middle)) { $names{'middlename'} = $middle; } if ($last) { $names{'lastname'} = $last; } - if ($gene) { $names{'generation'} = $gene; } + 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.', '. @@ -2043,30 +3419,78 @@ sub modifyuser { sub modifystudent { my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, - $end,$start,$forceid,$desiredhome)=@_; - my $cid=''; - unless ($cid=$ENV{'request.course.id'}) { - return 'not_in_class'; + $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$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,$forceid, - $desiredhome); + $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,$locktype,$cid); + return $reply; +} + +sub modify_student_enrollment { + my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$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 - $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,$locktype) }, + $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) { @@ -2097,13 +3521,10 @@ sub writecoursepref { # ---------------------------------------------------------- Make/modify course sub createcourse { - my ($udom,$description,$url)=@_; + my ($udom,$description,$url,$course_server,$nonstandard,$inst_code)=@_; $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 @@ -2119,92 +3540,213 @@ sub createcourse { 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; } $uhome=&homeserver($uname,$udom,'true'); if (($uhome eq '') || ($uhome eq 'no_host')) { return 'error: no such course'; } +# ----------------------------------------------------------------- Course made +# log existence + &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description). + '='.&escape($inst_code),$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); } + +# ------------------------------------------------------------ Portfolio Director Lister +# returns listing of contents of user's /userfiles/portfolio/ directory +# + +sub portfoliolist { + my ($currentPath, $currentFile) = @_; + my ($udom, $uname, $portfolioRoot); + $uname=$ENV{'user.name'}; + $udom=$ENV{'user.domain'}; + # really should interrogate the system for home directory information, but . . . + $portfolioRoot = '/home/httpd/lonUsers/'.$udom.'/'; + $uname =~ /^(.?)(.?)(.?)/; + $portfolioRoot = $portfolioRoot.$1.'/'.$2.'/'.$3.'/'.$uname.'/userfiles/portfolio'; + my $listing = &reply('ls:'.$portfolioRoot.$currentPath, &homeserver($uname,$udom)); + return $listing; +} + +sub portfoliomanage { + +#FIXME please user the existing remove userfile function instead and +#add a userfilerename functions. +#FIXME uhome should never be an argument to any lonnet functions + + # handles deleting and renaming files in user's userfiles/portfolio/ directory + # + my ($filename, $fileaction, $filenewname) = @_; + my ($udom, $uname, $uhome); + $uname=$ENV{'user.name'}; + $udom=$ENV{'user.domain'}; + $uhome=$ENV{'user.home'}; + my $listing = reply('portfoliomanage:'.$uname.':'.$udom.':'.$filename.':'.$fileaction.':'.$filenewname, $uhome); + return $listing; +} + + # ------------------------------------------------------------ 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')) { - foreach (split(/:/,$listing)) { - my ($entry,@stat)=split(/&/,$_); - $allusers{$entry}=1; + 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 $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); - } + } + 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 @@ -2259,61 +3801,93 @@ sub condval { return $result; } +# ---------------------------------------------------- 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; - unless (defined($courseresdatacache{$hashid.'.time'})) { - unless (time-$courseresdatacache{$hashid.'.time'}<300) { - my $coursehom=&homeserver($coursenum,$coursedomain); - if ($coursehom) { - my $dumpreply=&reply('dump:'.$coursedomain.':'.$coursenum. - ':resourcedata:.',$coursehom); - unless ($dumpreply=~/^error\:/) { - $courseresdatacache{$hashid.'.time'}=time; - $courseresdatacache{$hashid}=$dumpreply; - } - } - } + my ($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'); + } } - my @pairs=split(/\&/,$courseresdatacache{$hashid}); - my %returnhash=(); - foreach (@pairs) { - my ($key,$value)=split(/=/,$_); - $returnhash{unescape($key)}=unescape($value); - } - my $item; - foreach $item (@which) { - if ($returnhash{$item}) { return $returnhash{$item}; } - } - return ''; + foreach my $item (@which) { + if (defined($result->{$item})) { + return $result->{$item}; + } + } + return undef; } -# --------------------------------------------------------- Value of a Variable +# +# 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,$symbparm,$udom,$uname)=@_; + 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)=&Apache::lonxml::whichuser(); + (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; @@ -2321,8 +3895,17 @@ sub EXT { if ($realm eq 'user') { # --------------------------------------------------------------- user.resource if ($space eq 'resource') { - my %restored=&restore(undef,undef,$udom,$uname); - 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 @@ -2333,7 +3916,11 @@ sub EXT { ($udom eq $ENV{'user.domain'})) { return $ENV{join('.',('environment',$qualifierrest))}; } else { - my %returnhash=&userenvironment($udom,$uname,$qualifierrest); + my %returnhash; + if (!$publicuser) { + %returnhash=&userenvironment($udom,$uname, + $qualifierrest); + } return $returnhash{$qualifierrest}; } # ----------------------------------------------------------------- user.course @@ -2357,18 +3944,29 @@ sub EXT { 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 'query') { # ---------------------------------------------- pull stuff out of query string - &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},[$space]); - return $ENV{'form.'.$space}; + &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}; @@ -2378,24 +3976,28 @@ sub EXT { return $ENV{'course.'.$courseid.'.'.$spacequalifierrest}; } elsif ($realm eq 'resource') { - if ($courseid eq $ENV{'request.course.id'}) { + my $section; + if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) { #print '
'.$space.' - '.$qualifier.' - '.$spacequalifierrest; # ----------------------------------------------------- Cascading lookup scheme if (!$symbparm) { $symbparm=&symbread(); } my $symbp=$symbparm; - my $mapp=(split(/\_\_\_/,$symbp))[0]; + my $mapp=(&decode_symb($symbp))[0]; my $symbparm=$symbp.'.'.$spacequalifierrest; my $mapparm=$mapp.'___(all).'.$spacequalifierrest; - my $section; if (($ENV{'user.name'} eq $uname) && ($ENV{'user.domain'} eq $udom)) { - $section={'request.course.sec'}; + $section=$ENV{'request.course.sec'}; } else { - $section=&usection($udom,$uname,$courseid); + if (! defined($usection)) { + $section=&usection($udom,$uname,$courseid); + } else { + $section = $usection; + } } my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; @@ -2407,24 +4009,36 @@ sub EXT { my $courselevelm=$courseid.'.'.$mapparm; # ----------------------------------------------------------- first, check user - my %resourcedata=&get('resourcedata', - [$courselevelr,$courselevelm,$courselevel], - $udom,$uname); - if (($resourcedata{$courselevelr}!~/^error\:/) && - ($resourcedata{$courselevelr}!~/^con_lost/)) { - - if ($resourcedata{$courselevelr}) { - return $resourcedata{$courselevelr}; } - if ($resourcedata{$courselevelm}) { - return $resourcedata{$courselevelm}; } - if ($resourcedata{$courselevel}) { - return $resourcedata{$courselevel}; } - } else { - if ($resourcedata{$courselevelr}!~/No such file/) { - &logthis("WARNING:". - " Trying to get resource data for ". - $uname." at ".$udom.": ". - $resourcedata{$courselevelr}.""); + #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; + } } } @@ -2435,14 +4049,14 @@ sub EXT { ($seclevelr,$seclevelm,$seclevel, $courselevelr,$courselevelm, $courselevel)); - if ($coursereply) { return $coursereply; } + 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)) { + &GDBM_READER(),0640)) { $thisparm=$parmhash{$symbparm}; untie(%parmhash); } @@ -2451,25 +4065,31 @@ sub EXT { # --------------------------------------------- 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; } + 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 ($part,$id)=split(/\_/,$space); - if ($id) { - my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, - $symbparm,$udom,$uname); - if ($partgeneral) { return $partgeneral; } - } else { - my $resourcegeneral=&EXT('resource.0.'.$qualifierrest, - $symbparm,$udom,$uname); - if ($resourcegeneral) { return $resourcegeneral; } - } + 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') { @@ -2490,12 +4110,49 @@ 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,$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$//; # @@ -2503,135 +4160,274 @@ sub metadata { # Look at timestamp of caching # Everything is cached by the main uri, libraries are never directly cached # - unless (abs($metacache{$uri.':cachedtimestamp'}-time)<600) { + 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 $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') { - if (defined($token->[2]->{'package'})) { + if ($token->[0] eq 'S') { + if (defined($token->[2]->{'package'})) { # # This is a package - get package info # - my $package=$token->[2]->{'package'}; - my $keyroot=''; - if ($prefix) { - $keyroot.='_'.$prefix; - } else { - if (defined($token->[2]->{'part'})) { - $keyroot.='_'.$token->[2]->{'part'}; - } - } - if (defined($token->[2]->{'id'})) { - $keyroot.='_'.$token->[2]->{'id'}; - } - if ($metacache{$uri.':packages'}) { - $metacache{$uri.':packages'}.=','.$package.$keyroot; - } else { - $metacache{$uri.':packages'}=$package.$keyroot; - } - foreach (keys %packagetab) { - if ($_=~/^$package\&/) { - my ($pack,$name,$subp)=split(/\&/,$_); - my $value=$packagetab{$_}; - my $part=$keyroot; - $part=~s/^\_//; - if ($subp eq 'display') { - $value.=' [Part: '.$part.']'; - } - my $unikey='parameter'.$keyroot.'_'.$name; - $metathesekeys{$unikey}=1; - $metacache{$uri.':'.$unikey.'.part'}=$part; - unless - (defined($metacache{$uri.':'.$unikey.'.'.$subp})) { - $metacache{$uri.':'.$unikey.'.'.$subp}=$value; - } - } - } - } else { + 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; - } - if ($prefix) { - $unikey.=$prefix; - } else { - if (defined($token->[2]->{'part'})) { - $unikey.='_'.$token->[2]->{'part'}; - } - } - if (defined($token->[2]->{'id'})) { - $unikey.='_'.$token->[2]->{'id'}; - } +# + 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') { + if ($entry eq 'import') { # # Importing a library here -# - if (defined($depthcount)) { $depthcount++; } else - { $depthcount=0; } - if ($depthcount<20) { - foreach (split(/\,/,&metadata($uri,'keys', - $parser->get_text('/import'),$unikey, - $depthcount))) { - $metathesekeys{$_}=1; - } - } - } else { - - if (defined($token->[2]->{'name'})) { - $unikey.='_'.$token->[2]->{'name'}; - } - $metathesekeys{$unikey}=1; - foreach (@{$token->[3]}) { - $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_}; - } - unless ( - $metacache{$uri.':'.$unikey}=&HTML::Entities::decode($parser->get_text('/'.$entry)) - ) { $metacache{$uri.':'.$unikey}= - $metacache{$uri.':'.$unikey.'.default'}; - } +# + 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" - } - } - $metacache{$uri.':keys'}=join(',',keys %metathesekeys); - $metacache{$uri.':cachedtimestamp'}=time; + } + } + 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}; + 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'}; + } +} + +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)) { + &GDBM_WRCREAT(),0640)) { foreach (keys %newhash) { - $hash{declutter($_)}=$mapname.'___'.$newhash{$_}; + $hash{declutter($_)}=$mapname.'___'.&deversion($newhash{$_}); } if (untie(%hash)) { return 'ok'; @@ -2644,23 +4440,30 @@ sub symblist { # --------------------------------------------------------------- Verify a symb sub symbverify { - my ($symb,$thisfn)=@_; + my ($symb,$thisurl)=@_; + my $thisfn=$thisurl; +# wrapper not part of symbs + $thisfn=~s/^\/adm\/wrapper//; $thisfn=&declutter($thisfn); # direct jump to resource in page or to a sequence - will construct own symbs if ($thisfn=~/\.(page|sequence)$/) { return 1; } # check URL part - my ($map,$resid,$url)=split(/\_\_\_/,$symb); - unless (&symbclean($url) eq &symbclean($thisfn)) { return 0; } + my ($map,$resid,$url)=&decode_symb($symb); + + unless ($url eq $thisfn) { return 0; } $symb=&symbclean($symb); + $thisurl=&deversion($thisurl); + $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_/res/'.$thisfn}; + &GDBM_READER(),0640)) { + my $ids=$bighash{'ids_'.&clutter($thisurl)}; unless ($ids) { - $ids=$bighash{'ids_/'.$thisfn}; + $ids=$bighash{'ids_/'.$thisurl}; } if ($ids) { # ------------------------------------------------------------------- Has ID(s) @@ -2689,13 +4492,60 @@ sub symbclean { # remove version from URL $symb=~s/\.(\d+)\.(\w+)$/\.$2/; +# remove wrapper + + $symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/; 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'}); } @@ -2710,9 +4560,13 @@ sub symbread { 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 @@ -2727,9 +4581,9 @@ 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}; } @@ -2744,7 +4598,7 @@ 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; foreach (@possibilities) { @@ -2759,10 +4613,12 @@ sub symbread { } } if ($realpossible!=1) { $syval=''; } + } else { + $syval=''; } } untie(%bighash) - } + } } if ($syval) { return &symbclean($syval.'___'.$thisfn); @@ -2784,63 +4640,367 @@ 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 '64bit3'; +} + +sub get_rand_alg { + my ($courseid)=@_; + if (!$courseid) { $courseid=(&Apache::lonxml::whichuser())[1]; } + if ($courseid) { + return $ENV{"course.$courseid.rndseed"}; + } + return &latest_rnd_algorithm_id(); +} + +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,$courseid,$domain,$username)=@_; + + my ($wsymb,$wcourseid,$wdomain,$wusername)=&Apache::lonxml::whichuser(); if (!$symb) { - unless ($symb=&symbread()) { return time; } + unless ($symb=$wsymb) { return time; } + } + if (!$courseid) { $courseid=$wcourseid; } + if (!$domain) { $domain=$wdomain; } + if (!$username) { $username=$wusername } + my $which=&get_rand_alg(); + if (defined(&getCODE())) { + return &rndseed_CODE_64bit($symb,$courseid,$domain,$username); + } elsif ($which eq '64bit3') { + return &rndseed_64bit3($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_64bit3 { + 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=numval2($symb) << 10; + my $namechck=unpack("%32S*",$username.' '); + + my $nameseed=numval2($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"; } - if (!$courseid) { $courseid=$ENV{'request.course.id'};} - if (!$domain) {$domain=$ENV{'user.domain'};} - if (!$username) {$username=$ENV{'user.name'};} +} + +sub rndseed_CODE_64bit { + 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; - #uncommenting these lines can break things! - #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); - #&Apache::lonxml::debug("rndseed :$num:$symb"); - return $num; + 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); + } + #my $ua=new LWP::UserAgent; + #my $request=new HTTP::Request('GET',&tokenwrapper($file)); + #my $response=$ua->request($request); + #if ($response->is_success()) { + # return $response->content; + # } else { + # return -1; + # } + 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') { + my $ua=new LWP::UserAgent; + my $request=new HTTP::Request('GET',&tokenwrapper($file)); + my $response=$ua->request($request); + if ($response->is_success()) { + return $response->content; + } else { + 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 tokenwrapper { + my $uri=shift; + $uri=~s/^http\:\/\/([^\/]+)//; + $uri=~s/^\///; + $ENV{'user.environment'}=~/\/([^\/]+)\.id/; + my $token=$1; + if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) { + &appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'}); + return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri. + (($uri=~/\?/)?'&':'?').'token='.$token. + '&tokenissued='.$perlvar{'lonHostID'}; + } else { + return '/adm/notfound.html'; + } +} + +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 { @@ -2850,9 +5010,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 { @@ -2861,32 +5023,70 @@ 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 (($file=~/^http:\/\//i) || ($file=~/^\//)) { - my $finalpath=filelocation($dir,$file); - $finalpath=~s/^\/home\/httpd\/html//; - $finalpath=~s-/home/(\w+)/public_html/-/~$1/-; - return $finalpath; - } else { - return $file; + 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|public)\//) { + $thisfn='/res'.$thisfn; + } + return $thisfn; +} + # -------------------------------------------------------- Escape Special Chars sub escape { @@ -2903,30 +5103,56 @@ 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 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/loncapa.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); } { - my $config=Apache::File->new("/etc/httpd/conf/loncapa_apache.conf"); + open(my $config,") { if ($configline =~ /^[^\#]*PerlSetVar/) { @@ -2935,77 +5161,127 @@ BEGIN { $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>) { + next if ($configline =~ /^(\#|\s*$)/); chomp($configline); - my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); - $hostname{$id}=$name; - $hostdom{$id}=$domain; - $hostip{$id}=$ip; - if ($role eq 'library') { $libserv{$id}=$name; } + 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); - if ($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); - if ($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 package table { - my $config=Apache::File->new("$perlvar{'lonTabDir'}/packages.tab"); + open(my $config,"<$perlvar{'lonTabDir'}/packages.tab"); while (my $configline=<$config>) { - chomp($configline); - my ($short,$plain)=split(/:/,$configline); - my ($pack,$name)=split(/\&/,$short); - if ($plain ne '') { - $packagetab{$pack.'&'.$name.'&name'}=$name; - $packagetab{$short}=$plain; - } + 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=(); -$processmarker=$$.'_'.time.'_'.$perlvar{'lonHostID'}; +$processmarker='_'.time.'_'.$perlvar{'lonHostID'}; $dumpcount=0; &logtouch(); @@ -3052,45 +5328,125 @@ being set. =back -=head1 INTRODUCTION +=head1 OVERVIEW -This module provides subroutines which interact with the -lonc/lond (TCP) network layer of LON-CAPA. And Can be used to ask about -- classes -- users -- resources +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. -This is part of the LearningOnline Network with CAPA project -described at http://www.lon-capa.org. +=head2 Symbs -=head1 RETURN MESSAGES +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. -=over 4 +An example is -=item * + msu/korte/parts/part1.sequence___19___msu/korte/tests/part12.problem -con_lost : unable to contact remote host +The respective map entry is -=item * + + -con_delayed : unable to contact remote host, message will be delivered -when the connection is brought back up +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. -=item * +=head2 Storing And Retrieving Data -con_failed : unable to contact remote host and unable to save message -for later delivery +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. -=item * +The data is stored in the user's data directory on the user's +homeserver under the ID of the course. -error: : an error a occured, a description of the error follows the : +The hash that is returned by restore will have all of the previous +value for all of the elements of the hash. -=item * +Example: + + #creating a hash + my %hash; + $hash{'foo'}='bar'; -no_such_host : unable to fund a host associated with the user/domain + #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 @@ -3101,15 +5457,18 @@ that was requested =over 4 -=item * - -appenv(%hash) : 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: 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 * - -delenv($regexp) : 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. +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 @@ -3118,50 +5477,51 @@ delenv($regexp) : removes all items from =over 4 =item * - -queryauthenticate($uname,$udom) : try to determine user's current +X +B: try to determine user's current authentication scheme =item * - -authenticate($uname,$upass,$udom) : try to authenticate user from domain's lib -servers (first use the current one), $upass should be the users password +X +B: try to +authenticate user from domain's lib servers (first use the current +one). C<$upass> should be the users password. =item * - -homeserver($uname,$udom) : 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. +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 * - -idget($udom,@ids) : 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) +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 * - -idrget($udom,@unames) : find the IDs behind a list of usernames (returns hash: -name=>id,name=>id) +X +B: find the IDs behind a list of +usernames (returns hash: name=>id,name=>id) =item * - -idput($udom,%ids) : store away a list of names and associated IDs +X +B: store away a list of names and associated IDs =item * - -rolesinit($udom,$username,$authhost) : get user privileges +X +B: get user privileges =item * - -usection($udom,$uname,$cname) : finds the section of student in the +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 * - -userenvironment($udom,$uname,@what) : gets the values of the keys +X +B: gets the values of the keys passed in @what from the requested user's environment, returns a hash =back @@ -3221,7 +5581,83 @@ modify user =item * -modifystudent($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,$end,$start) : modify student +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 * @@ -3453,6 +5889,14 @@ dumps the complete (or key matching rege =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) @@ -3563,8 +6007,29 @@ messages of critical importance should g =item * -getfile($file) : returns the entire contents of a file or -1; it -properly subscribes to and replicates the file if neccessary. +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 *