--- loncom/lonnet/perl/lonnet.pm 1999/11/08 16:20:35 1.2 +++ loncom/lonnet/perl/lonnet.pm 2003/11/10 23:57:49 1.446 @@ -1,17 +1,69 @@ # The LearningOnline Network # TCP networking package -# 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 Gerd Kortemeyer +# +# $Id: lonnet.pm,v 1.446 2003/11/10 23:57:49 albertel Exp $ +# +# Copyright Michigan State University Board of Trustees +# +# This file is part of the LearningOnline Network with CAPA (LON-CAPA). +# +# LON-CAPA is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# LON-CAPA is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with LON-CAPA; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +# +# /home/httpd/html/adm/gpl.txt +# +# http://www.lon-capa.org/ +# +### package Apache::lonnet; use strict; use Apache::File; -use vars qw(%perlvar %hostname %homecache %spareid %hostdom %libserv $readit); +use LWP::UserAgent(); +use HTTP::Headers; +use vars +qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom + %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache + %courselogs %accesshash %userrolehash $processmarker $dumpcount + %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache + %userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def + %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir); + use IO::Socket; +use GDBM_File; +use Apache::Constants qw(:common :http); +use HTML::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; # --------------------------------------------------------------------- Logging +sub logtouch { + my $execdir=$perlvar{'lonDaemons'}; + unless (-e "$execdir/logs/lonnet.log") { + my $fh=Apache::File->new(">>$execdir/logs/lonnet.log"); + close $fh; + } + my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3]; + chown($wwwuid,$wwwgid,$execdir.'/logs/lonnet.log'); +} + sub logthis { my $message=shift; my $execdir=$perlvar{'lonDaemons'}; @@ -42,39 +94,36 @@ sub subreply { or return "con_lost"; print $client "$cmd\n"; my $answer=<$client>; - chomp($answer); if (!$answer) { $answer="con_lost"; } + chomp($answer); return $answer; } sub reply { my ($cmd,$server)=@_; + unless (defined($hostname{$server})) { return 'no_such_host'; } my $answer=subreply($cmd,$server); - if ($answer eq 'con_lost') { $answer=subreply($cmd,$server); } - return $answer; -} - -# ------------------------------------------------ Try to send delayed messages - -sub senddelayed { - my $server=shift; - my $dfname; - my $path="$perlvar{'lonSockDir'}/delayed"; - while ($dfname=<$path/*.$server>) { - my $wcmd; - { - my $dfh=Apache::File->new($dfname); - $wcmd=<$dfh>; - } - my ($server,$cmd)=split(/:/,$wcmd); - chomp($cmd); - my $answer=subreply($cmd,$server); - if ($answer ne 'con_lost') { - unlink("$dfname"); - &logthis("Delayed $cmd to $server: $answer"); - &logperm("S:$server:$cmd"); - } + if ($answer eq 'con_lost') { + #sleep 5; + #$answer=subreply($cmd,$server); + #if ($answer eq 'con_lost') { + # &logthis("Second attempt con_lost on $server"); + # my $peerfile="$perlvar{'lonSockDir'}/$server"; + # my $client=IO::Socket::UNIX->new(Peer =>"$peerfile", + # Type => SOCK_STREAM, + # Timeout => 10) + # or return "con_lost"; + # &logthis("Killing socket"); + # print $client "close_connection_exit\n"; + #sleep 5; + # $answer=subreply($cmd,$server); + #} + } + if (($answer=~/^refused/) || ($answer=~/^rejected/)) { + &logthis("WARNING:". + " $cmd to $server returned $answer"); } + return $answer; } # ----------------------------------------------------------- Send USR1 to lonc @@ -94,19 +143,27 @@ sub reconlonc { &logthis("$peerfile still not there, give it another try"); sleep 5; if (-e "$peerfile") { return; } - &logthis("$peerfile still not there, giving up"); + &logthis( + "WARNING: $peerfile still not there, giving up"); } else { - &logthis("lonc at pid $loncpid not responding, giving up"); + &logthis( + "WARNING:". + " lonc at pid $loncpid not responding, giving up"); } } else { - &logthis('lonc not running, giving up'); + &logthis('WARNING: lonc not running, giving up'); } } # ------------------------------------------------------ Critical communication + sub critical { my ($cmd,$server)=@_; - &senddelayed($server); + unless ($hostname{$server}) { + &logthis("WARNING:". + " Critical message to unknown server ($server)"); + return 'no_such_host'; + } my $answer=reply($cmd,$server); if ($answer eq 'con_lost') { my $pingreply=reply('ping',$server); @@ -117,13 +174,15 @@ sub critical { if ($answer eq 'con_lost') { my $now=time; my $middlename=$cmd; + $middlename=substr($middlename,0,16); $middlename=~s/\W//g; my $dfilename= - "$perlvar{'lonSockDir'}/delayed/$now.$middlename.$server"; + "$perlvar{'lonSockDir'}/delayed/$now.$dumpcount.$$.$middlename.$server"; + $dumpcount++; { my $dfh; if ($dfh=Apache::File->new(">$dfilename")) { - print $dfh "$server:$cmd\n"; + print $dfh "$cmd\n"; } } sleep 2; @@ -135,12 +194,14 @@ sub critical { } } chomp($wcmd); - if ($wcmd eq "$server:$cmd") { - &logthis("Connection buffer $dfilename: $cmd"); + if ($wcmd eq $cmd) { + &logthis("WARNING: ". + "Connection buffer $dfilename: $cmd"); &logperm("D:$server:$cmd"); return 'con_delayed'; } else { - &logthis("CRITICAL CONNECTION FAILED: $server $cmd"); + &logthis("CRITICAL:" + ." Critical connection failed: $server $cmd"); &logperm("F:$server:$cmd"); return 'con_failed'; } @@ -149,109 +210,4312 @@ 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; + { + my $idf=Apache::File->new("$lonidsdir/$handle.id"); + flock($idf,LOCK_SH); + @profile=<$idf>; + $idf->close(); + } + my $envi; + my %Remove; + for ($envi=0;$envi<=$#profile;$envi++) { + chomp($profile[$envi]); + my ($envname,$envvalue)=split(/=/,$profile[$envi]); + $ENV{$envname} = $envvalue; + if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) { + if ($time < time-300) { + $Remove{$key}++; + } + } + } + $ENV{'user.environment'} = "$lonidsdir/$handle.id"; + foreach my $expired_key (keys(%Remove)) { + &delenv($expired_key); + } +} + +# ---------------------------------------------------------- Append Environment + +sub appenv { + my %newenv=@_; + foreach (keys %newenv) { + if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) { + &logthis("WARNING: ". + "Attempt to modify environment ".$_." to ".$newenv{$_} + .''); + delete($newenv{$_}); + } else { + $ENV{$_}=$newenv{$_}; + } + } + + my $lockfh; + unless ($lockfh=Apache::File->new("$ENV{'user.environment'}")) { + return 'error: '.$!; + } + unless (flock($lockfh,LOCK_EX)) { + &logthis("WARNING: ". + 'Could not obtain exclusive lock in appenv: '.$!); + $lockfh->close(); + return 'error: '.$!; + } + + my @oldenv; + { + my $fh; + unless ($fh=Apache::File->new("$ENV{'user.environment'}")) { + return 'error: '.$!; + } + @oldenv=<$fh>; + $fh->close(); + } + for (my $i=0; $i<=$#oldenv; $i++) { + chomp($oldenv[$i]); + if ($oldenv[$i] ne '') { + my ($name,$value)=split(/=/,$oldenv[$i]); + unless (defined($newenv{$name})) { + $newenv{$name}=$value; + } + } + } + { + my $fh; + unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) { + return 'error'; + } + my $newname; + foreach $newname (keys %newenv) { + print $fh "$newname=$newenv{$newname}\n"; + } + $fh->close(); + } + + $lockfh->close(); + return 'ok'; +} +# ----------------------------------------------------- Delete from Environment + +sub delenv { + my $delthis=shift; + my %newenv=(); + if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) { + &logthis("WARNING: ". + "Attempt to delete from environment ".$delthis); + return 'error'; + } + my @oldenv; + { + my $fh; + unless ($fh=Apache::File->new("$ENV{'user.environment'}")) { + return 'error'; + } + unless (flock($fh,LOCK_SH)) { + &logthis("WARNING: ". + 'Could not obtain shared lock in delenv: '.$!); + $fh->close(); + return 'error: '.$!; + } + @oldenv=<$fh>; + $fh->close(); + } + { + my $fh; + unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) { + return 'error'; + } + unless (flock($fh,LOCK_EX)) { + &logthis("WARNING: ". + 'Could not obtain exclusive lock in delenv: '.$!); + $fh->close(); + return 'error: '.$!; + } + foreach (@oldenv) { + unless ($_=~/^$delthis/) { print $fh $_; } + } + $fh->close(); + } + return 'ok'; +} + +# ------------------------------------------ Find 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'}) { + my $loadfile=Apache::File->new('/proc/loadavg'); + $loadavg=<$loadfile>; + $loadavg =~ s/\s.*//g; + $loadavg = 100*$loadavg/$perlvar{'lonLoadLim'}; + } else { + $loadavg=&reply('load',$checkserver); + } + my $overload=$loadavg-100; + if ($overload>0) { + $r->err_headers_out->{'Retry-After'}=$overload; + $r->log_error('Overload of '.$overload.' on '.$checkserver); + return 413; + } + return ''; +} # ------------------------------ Find server with least workload from spare.tab + sub spareserver { + my ($loadpercent,$userloadpercent) = @_; my $tryserver; my $spareserver=''; - my $lowestserver=100; + if ($userloadpercent !~ /\d/) { $userloadpercent=0; } + my $lowestserver=$loadpercent > $userloadpercent? + $loadpercent : $userloadpercent; foreach $tryserver (keys %spareid) { - my $answer=reply('load',$tryserver); - if (($answer =~ /\d/) && ($answer<$lowestserver)) { - $spareserver="http://$hostname{$tryserver}"; - $lowestserver=$answer; - } - } + my $loadans=reply('load',$tryserver); + my $userloadans=reply('userload',$tryserver); + if ($loadans !~ /\d/ && $userloadans !~ /\d/) { + next; #didn't get a number from the server + } + my $answer; + if ($loadans =~ /\d/) { + if ($userloadans =~ /\d/) { + #both are numbers, pick the bigger one + $answer=$loadans > $userloadans? + $loadans : $userloadans; + } else { + $answer = $loadans; + } + } else { + $answer = $userloadans; + } + if (($answer =~ /\d/) && ($answer<$lowestserver)) { + $spareserver="http://$hostname{$tryserver}"; + $lowestserver=$answer; + } + } return $spareserver; } +# --------------------------------------------- Try to change a user's password + +sub changepass { + my ($uname,$udom,$currentpass,$newpass,$server)=@_; + $currentpass = &escape($currentpass); + $newpass = &escape($newpass); + my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass", + $server); + if (! $answer) { + &logthis("No reply on password change request to $server ". + "by $uname in domain $udom."); + } elsif ($answer =~ "^ok") { + &logthis("$uname in $udom successfully changed their password ". + "on $server."); + } elsif ($answer =~ "^pwchange_failure") { + &logthis("$uname in $udom was unable to change their password ". + "on $server. The action was blocked by either lcpasswd ". + "or pwchange"); + } elsif ($answer =~ "^non_authorized") { + &logthis("$uname in $udom did not get their password correct when ". + "attempting to change it on $server."); + } elsif ($answer =~ "^auth_mode_error") { + &logthis("$uname in $udom attempted to change their password despite ". + "not being locally or internally authenticated on $server."); + } elsif ($answer =~ "^unknown_user") { + &logthis("$uname in $udom attempted to change their password ". + "on $server but were unable to because $server is not ". + "their home server."); + } elsif ($answer =~ "^refused") { + &logthis("$server refused to change $uname in $udom password because ". + "it was sent an unencrypted request to change the password."); + } + return $answer; +} + +# ----------------------- Try to determine user's current authentication scheme + +sub queryauthenticate { + my ($uname,$udom)=@_; + if (($perlvar{'lonRole'} eq 'library') && + ($udom eq $perlvar{'lonDefDomain'})) { + my $answer=reply("encrypt:currentauth:$udom:$uname", + $perlvar{'lonHostID'}); + unless ($answer eq 'unknown_user' or $answer eq 'refused') { + if (length($answer)) { + return $answer; + } + else { + &logthis("User $uname at $udom lacks an authentication mechanism"); + return 'no_host'; + } + } + } + + my $tryserver; + foreach $tryserver (keys %libserv) { + if ($hostdom{$tryserver} eq $udom) { + my $answer=reply("encrypt:currentauth:$udom:$uname",$tryserver); + unless ($answer eq 'unknown_user' or $answer eq 'refused') { + if (length($answer)) { + return $answer; + } + else { + &logthis("User $uname at $udom lacks an authentication mechanism"); + return 'no_host'; + } + } + } + } + &logthis("User $uname at $udom lacks an authentication mechanism"); + return 'no_host'; +} + # --------- Try to authenticate user from domain's lib servers (first this one) + sub authenticate { my ($uname,$upass,$udom)=@_; - + $upass=escape($upass); + $uname=~s/\W//g; if (($perlvar{'lonRole'} eq 'library') && ($udom eq $perlvar{'lonDefDomain'})) { - my $answer=reply("enc:auth:$udom:$uname:$upass",$perlvar{'lonHostID'}); + my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'}); if ($answer =~ /authorized/) { - if ($answer eq 'authorized') { return $perlvar{'lonHostID'}; } - if ($answer eq 'non_authorized') { return 'no_host'; } + 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("enc:auth:$udom:$uname:$upass",$tryserver); + my $answer=reply("encrypt:auth:$udom:$uname:$upass",$tryserver); if ($answer =~ /authorized/) { - if ($answer eq 'authorized') { return $tryserver; } + if ($answer eq 'authorized') { + &logthis("User $uname at $udom authorized by $tryserver"); + return $tryserver; + } + if ($answer eq 'non_authorized') { + &logthis("User $uname at $udom rejected by $tryserver"); + return 'no_host'; + } } } - } + } + &logthis("User $uname at $udom could not be authenticated"); return 'no_host'; } # ---------------------- Find the homebase for a user from domain's lib servers -sub homeserver { - my ($uname,$udom)=@_; +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' && + exists($badServerCache{$tryserver})); if ($hostdom{$tryserver} eq $udom) { my $answer=reply("home:$udom:$uname",$tryserver); if ($answer eq 'found') { - $homecache{$index}=$tryserver; - return $tryserver; - } + return &do_cache(\%homecache,$index,$tryserver,'home'); + } elsif ($answer eq 'no_host') { + $badServerCache{$tryserver}=1; + } } } return 'no_host'; } +# ------------------------------------- Find the usernames behind a list of IDs + +sub idget { + my ($udom,@ids)=@_; + my %returnhash=(); + + my $tryserver; + foreach $tryserver (keys %libserv) { + if ($hostdom{$tryserver} eq $udom) { + my $idlist=join('&',@ids); + $idlist=~tr/A-Z/a-z/; + my $reply=&reply("idget:$udom:".$idlist,$tryserver); + my @answer=(); + if (($reply ne 'con_lost') && ($reply!~/^error\:/)) { + @answer=split(/\&/,$reply); + } ; + my $i; + for ($i=0;$i<=$#ids;$i++) { + if ($answer[$i]) { + $returnhash{$ids[$i]}=$answer[$i]; + } + } + } + } + return %returnhash; +} + +# ------------------------------------- Find the IDs behind a list of usernames + +sub idrget { + my ($udom,@unames)=@_; + my %returnhash=(); + foreach (@unames) { + $returnhash{$_}=(&userenvironment($udom,$_,'id'))[1]; + } + return %returnhash; +} + +# ------------------------------- Store away a list of names and associated IDs + +sub idput { + my ($udom,%ids)=@_; + my %servers=(); + foreach (keys %ids) { + my $uhom=&homeserver($_,$udom); + if ($uhom ne 'no_host') { + my $id=&escape($ids{$_}); + $id=~tr/A-Z/a-z/; + my $unam=&escape($_); + if ($servers{$uhom}) { + $servers{$uhom}.='&'.$id.'='.$unam; + } else { + $servers{$uhom}=$id.'='.$unam; + } + &critical('put:'.$udom.':'.$unam.':environment:id='.$id,$uhom); + } + } + foreach (keys %servers) { + &critical('idput:'.$udom.':'.$servers{$_},$_); + } +} + +# --------------------------------------------------- Assign a key to a student + +sub assign_access_key { +# +# a valid key looks like uname:udom#comments +# comments are being appended +# + my ($ckey,$cdom,$cnum,$udom,$uname,$logentry)=@_; + $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],$cdom,$cnum); + if (($existing{$ckey}=~/^\#(.*)$/) || # - new key + ($existing{$ckey}=~/^$uname\:$udom\#(.*)$/)) { + # assigned to this person + # - this should not happen, + # unless something went wrong + # the first time around +# ready to assign + $logentry=$1.'; '.$logentry; + if (&put('accesskey',{$ckey=>$uname.':'.$udom.'#'.$logentry}, + $cdom,$cnum) 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.name'} unless (defined($udom)); + $uname=$ENV{'user.domain'} unless (defined($uname)); + my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); + return ($existing{$ckey}=~/^$uname\:$udom\#/); +} + +# ------------------------------------- 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 !~/^$courseid(?:\/)*(\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'; +} + +sub devalidate_cache { + my ($cache,$id,$name) = @_; + delete $$cache{$id.'.time'}; + delete $$cache{$id}; + 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)=@_; + 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)=@_; + 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$/) { + my $section=$1; + if ($key eq $courseid.'_st') { $section=''; } + my ($dummy,$end,$start)=split(/\_/,&unescape($value)); + my $now=time; + my $notactive=0; + if ($start) { + if ($now<$start) { $notactive=1; } + } + if ($end) { + if ($now>$end) { $notactive=1; } + } + unless ($notactive) { + return &do_cache(\%usectioncache,$hashid,$section,'usection'); + } + } + } + return &do_cache(\%usectioncache,$hashid,'-1','usection'); +} + +# ------------------------------------- Read an entry from a user's environment + +sub userenvironment { + my ($udom,$unam,@what)=@_; + my %returnhash=(); + my @answer=split(/\&/, + &reply('get:'.$udom.':'.$unam.':environment:'.join('&',@what), + &homeserver($unam,$udom))); + my $i; + for ($i=0;$i<=$#what;$i++) { + $returnhash{$what[$i]}=&unescape($answer[$i]); + } + return %returnhash; +} + +# -------------------------------------------------------------------- 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; - &logthis($fname); + 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); - &logthis("$home $udom $uname"); - 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')) { + $answer.=' by '.$home; + } + return $answer; +} + +# -------------------------------------------------------------- Replicate file + +sub repcopy { + my $filename=shift; + $filename=~s/\/+/\//g; + if ($filename=~/^\/home\/httpd\/html\/adm\//) { return OK; } + my $transname="$filename.in.transfer"; + if ((-e $filename) || (-e $transname)) { return OK; } + my $remoteurl=subscribe($filename); + if ($remoteurl =~ /^con_lost by/) { + &logthis("Subscribe returned $remoteurl: $filename"); + return HTTP_SERVICE_UNAVAILABLE; + } elsif ($remoteurl eq 'not_found') { + #&logthis("Subscribe returned not_found: $filename"); + return HTTP_NOT_FOUND; + } elsif ($remoteurl =~ /^rejected by/) { + &logthis("Subscribe returned $remoteurl: $filename"); + return FORBIDDEN; + } elsif ($remoteurl eq 'directory') { + return OK; + } else { + my $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") { + &logthis("Malconfiguration for replication: $filename"); + return HTTP_BAD_REQUEST; + } + my $count; + for ($count=5;$count<$#parts;$count++) { + $path.="/$parts[$count]"; + if ((-e $path)!=1) { + mkdir($path,0777); + } + } + my $ua=new LWP::UserAgent; + my $request=new HTTP::Request('GET',"$remoteurl"); + my $response=$ua->request($request,$transname); + if ($response->is_error()) { + unlink($transname); + my $message=$response->status_line; + &logthis("WARNING:" + ." LWP get: $message: $filename"); + return HTTP_SERVICE_UNAVAILABLE; + } else { + if ($remoteurl!~/\.meta$/) { + my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta'); + my $mresponse=$ua->request($mrequest,$filename.'.meta'); + if ($mresponse->is_error()) { + unlink($filename.'.meta'); + &logthis( + "INFO: No metadata: $filename"); + } + } + rename($transname,$filename); + return OK; + } + } + } +} + +# ------------------------------------------------ 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*\>.*$//si; + $output=~ + s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs; + return $output; +} + +# --------------------------------------------------------- Server Side Include + +sub ssi { + + my ($fn,%form)=@_; + + my $ua=new LWP::UserAgent; + + my $request; + + if (%form) { + $request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn); + $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form)); + } else { + $request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn); + } + + $request->header(Cookie => $ENV{'HTTP_COOKIE'}); + my $response=$ua->request($request); + + return $response->content; +} + +sub externalssi { + my ($url)=@_; + my $ua=new LWP::UserAgent; + my $request=new HTTP::Request('GET',$url); + my $response=$ua->request($request); + return $response->content; +} + +# ------- Add a token to a remote URI's query string to vouch for access rights + +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'; + } +} + +# --------------- 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)=@_; + 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=''; + 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'}; + } 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 @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 + { + my $fh=Apache::File->new('>'.$filepath.'/'.$fname); + print $fh $ENV{'form.'.$formname}; + } +# Notify homeserver to grep it +# + + my $fetchresult= + &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,$docuhome); + if ($fetchresult eq 'ok') { +# +# Return the URL to it + return '/uploaded/'.$path.$fname; + } else { + &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$fname. + ' to host '.$docuhome.': '.$fetchresult); + return '/adm/notfound.html'; + } +} + +# ------------------------------------------------------------------------- Log + +sub log { + my ($dom,$nam,$hom,$what)=@_; + return critical("log:$dom:$nam:$what",$hom); +} + +# ------------------------------------------------------------------ Course Log +# +# This routine flushes several buffers of non-mission-critical nature +# + +sub flushcourselogs { + &logthis('Flushing log buffers'); +# +# course logs +# This is a log of all transactions in a course, which can be used +# for data mining purposes +# +# It also collects the courseid database, which lists last transaction +# times and course titles for all courseids +# + my %courseidbuffer=(); + foreach (keys %courselogs) { + my $crsid=$_; + if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'. + &escape($courselogs{$crsid}), + $coursehombuf{$crsid}) eq 'ok') { + delete $courselogs{$crsid}; + } else { + &logthis('Failed to flush log buffer for '.$crsid); + if (length($courselogs{$crsid})>40000) { + &logthis("WARNING: Buffer for ".$crsid. + " exceeded maximum size, deleting."); + delete $courselogs{$crsid}; + } + } + if ($courseidbuffer{$coursehombuf{$crsid}}) { + $courseidbuffer{$coursehombuf{$crsid}}.='&'. + &escape($crsid).'='.&escape($coursedescrbuf{$crsid}); + } else { + $courseidbuffer{$coursehombuf{$crsid}}= + &escape($crsid).'='.&escape($coursedescrbuf{$crsid}); + } + } +# +# Write course id database (reverse lookup) to homeserver of courses +# Is used in pickcourse +# + foreach (keys %courseidbuffer) { + &courseidput($hostdom{$_},$courseidbuffer{$_},$_); + } +# +# File accesses +# Writes to the dynamic metadata of resources to get hit counts, etc. +# + foreach (keys %accesshash) { + my $entry=$_; + $entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/; + my %temphash=($entry => $accesshash{$entry}); + if (&Apache::lonnet::put('nohist_resevaldata',\%temphash,$1,$2) eq 'ok') { + delete $accesshash{$entry}; + } + } +# +# Roles +# Reverse lookup of user roles for course faculty/staff and co-authorship +# + foreach (keys %userrolehash) { + my $entry=$_; + my ($role,$uname,$udom,$runame,$rudom,$rsec)= + split(/\:/,$entry); + if (&Apache::lonnet::put('nohist_userroles', + { $role.':'.$uname.':'.$udom.':'.$rsec => $userrolehash{$entry} }, + $rudom,$runame) eq 'ok') { + delete $userrolehash{$entry}; + } + } + $dumpcount++; +} + +sub courselog { + my $what=shift; + $what=time.':'.$what; + unless ($ENV{'request.course.id'}) { return ''; } + $coursedombuf{$ENV{'request.course.id'}}= + $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}; + $coursenumbuf{$ENV{'request.course.id'}}= + $ENV{'course.'.$ENV{'request.course.id'}.'.num'}; + $coursehombuf{$ENV{'request.course.id'}}= + $ENV{'course.'.$ENV{'request.course.id'}.'.home'}; + $coursedescrbuf{$ENV{'request.course.id'}}= + $ENV{'course.'.$ENV{'request.course.id'}.'.description'}; + if (defined $courselogs{$ENV{'request.course.id'}}) { + $courselogs{$ENV{'request.course.id'}}.='&'.$what; + } else { + $courselogs{$ENV{'request.course.id'}}.=$what; + } + if (length($courselogs{$ENV{'request.course.id'}})>4048) { + &flushcourselogs(); + } +} + +sub courseacclog { + my $fnsymb=shift; + unless ($ENV{'request.course.id'}) { return ''; } + my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'}; + if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|page)$/) { + $what.=':POST'; + foreach (keys %ENV) { + if ($_=~/^form\.(.*)/) { + $what.=':'.$1.'='.$ENV{$_}; + } + } + } + &courselog($what); +} + +sub countacc { + my $url=&declutter(shift); + unless ($ENV{'request.course.id'}) { return ''; } + $accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1; + my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count'; + if (defined($accesshash{$key})) { + $accesshash{$key}++; + } else { + $accesshash{$key}=1; + } +} + +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/)) { + 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 %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(/\:/,$_); + 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 (my $fh=Apache::File->new($perlvar{'lonDocRoot'}.'/announcement.txt')) { + my $announcement=''; + while (<$fh>) { $announcement .=$_; } + $fh->close(); + if ($announcement=~/\w/) { + return + ''. + '
'.$announcement.'
'; + } else { + return ''; + } + } else { + return ''; + } +} + +# ---------------------------------------------------------- Course ID routines +# Deal with domain's nohist_courseid.db files +# + +sub courseidput { + my ($domain,$what,$coursehome)=@_; + return &reply('courseidput:'.$domain.':'.$what,$coursehome); +} + +sub courseiddump { + my ($domfilter,$descfilter,$sincefilter)=@_; + my %returnhash=(); + unless ($domfilter) { $domfilter=''; } + foreach my $tryserver (keys %libserv) { + if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) { + foreach ( + split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. + $sincefilter.':'.&escape($descfilter), + $tryserver))) { + my ($key,$value)=split(/\=/,$_); + if (($key) && ($value)) { + $returnhash{&unescape($key)}=&unescape($value); + } + } + + } + } + return %returnhash; +} + +# +# ----------------------------------------------------------- Check out an item + +sub checkout { + my ($symb,$tuname,$tudom,$tcrsid)=@_; + my $now=time; + my $lonhost=$perlvar{'lonHostID'}; + my $infostr=&escape( + 'CHECKOUTTOKEN&'. + $tuname.'&'. + $tudom.'&'. + $tcrsid.'&'. + $symb.'&'. + $now.'&'.$ENV{'REMOTE_ADDR'}); + my $token=&reply('tmpput:'.$infostr,$lonhost); + if ($token=~/^error\:/) { + &logthis("WARNING: ". + "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb. + ""); + return ''; + } + + $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/; + $token=~tr/a-z/A-Z/; + + my %infohash=('resource.0.outtoken' => $token, + 'resource.0.checkouttime' => $now, + 'resource.0.outremote' => $ENV{'REMOTE_ADDR'}); + + unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') { + return ''; + } else { + &logthis("WARNING: ". + "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb. + ""); + } + + if (&log($tudom,$tuname,&homeserver($tuname,$tudom), + &escape('Checkout '.$infostr.' - '. + $token)) ne 'ok') { + return ''; + } else { + &logthis("WARNING: ". + "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb. + ""); + } + return $token; +} + +# ------------------------------------------------------------ Check in an item + +sub checkin { + my $token=shift; + my $now=time; + my ($ta,$tb,$lonhost)=split(/\*/,$token); + $lonhost=~tr/A-Z/a-z/; + my $dtoken=$ta.'_'.$hostip{$lonhost}.'_'.$tb; + $dtoken=~s/\W/\_/g; + my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)= + split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost))); + + unless (($tuname) && ($tudom)) { + &logthis('Check in '.$token.' ('.$dtoken.') failed'); + return ''; + } + + unless (&allowed('mgr',$tcrsid)) { + &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '. + $ENV{'user.name'}.' - '.$ENV{'user.domain'}); + return ''; + } + + my %infohash=('resource.0.intoken' => $token, + 'resource.0.checkintime' => $now, + 'resource.0.inremote' => $ENV{'REMOTE_ADDR'}); + + unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') { + return ''; + } + + if (&log($tudom,$tuname,&homeserver($tuname,$tudom), + &escape('Checkin - '.$token)) ne 'ok') { + return ''; + } + + return ($symb,$tuname,$tudom,$tcrsid); +} + +# --------------------------------------------- Set Expire Date for Spreadsheet + +sub expirespread { + my ($uname,$udom,$stype,$usymb)=@_; + my $cid=$ENV{'request.course.id'}; + if ($cid) { + my $now=time; + my $key=$uname.':'.$udom.':'.$stype.':'.$usymb; + return &reply('put:'.$ENV{'course.'.$cid.'.domain'}.':'. + $ENV{'course.'.$cid.'.num'}. + ':nohist_expirationdates:'. + &escape($key).'='.$now, + $ENV{'course.'.$cid.'.home'}) + } + return 'ok'; +} + +# ----------------------------------------------------- Devalidate Spreadsheets + +sub devalidate { + my ($symb,$uname,$udom)=@_; + my $cid=$ENV{'request.course.id'}; + if ($cid) { + # 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_calculatedsheets', + [$key.'studentcalc:'], + $ENV{'course.'.$cid.'.domain'}, + $ENV{'course.'.$cid.'.num'}) + .' '. + &del('nohist_calculatedsheets_'.$cid, + [$key.'assesscalc:'.$symb],$udom,$uname); + unless ($status eq 'ok ok') { + &logthis('Could not devalidate spreadsheet '. + $uname.' at '.$udom.' for '. + $symb.': '.$status); + } + } +} + +sub get_scalar { + my ($string,$end) = @_; + my $value; + if ($$string =~ s/^([^&]*?)($end)/$2/) { + $value = $1; + } elsif ($$string =~ s/^([^&]*?)&//) { + $value = $1; + } + return &unescape($value); +} + +sub array2str { + my (@array) = @_; + my $result=&arrayref2str(\@array); + $result=~s/^__ARRAY_REF__//; + $result=~s/__END_ARRAY_REF__$//; + return $result; +} + +sub arrayref2str { + my ($arrayref) = @_; + my $result='__ARRAY_REF__'; + foreach my $elem (@$arrayref) { + if(ref($elem) eq 'ARRAY') { + $result.=&arrayref2str($elem).'&'; + } elsif(ref($elem) eq 'HASH') { + $result.=&hashref2str($elem).'&'; + } elsif(ref($elem)) { + #print("Got a ref of ".(ref($elem))." skipping."); + } else { + $result.=&escape($elem).'&'; + } + } + $result=~s/\&$//; + $result .= '__END_ARRAY_REF__'; + return $result; +} + +sub hash2str { + my (%hash) = @_; + my $result=&hashref2str(\%hash); + $result=~s/^__HASH_REF__//; + $result=~s/__END_HASH_REF__$//; + return $result; +} + +sub hashref2str { + my ($hashref)=@_; + my $result='__HASH_REF__'; + foreach (keys(%$hashref)) { + if (ref($_) eq 'ARRAY') { + $result.=&arrayref2str($_).'='; + } elsif (ref($_) eq 'HASH') { + $result.=&hashref2str($_).'='; + } elsif (ref($_)) { + $result.='='; + #print("Got a ref of ".(ref($_))." skipping."); + } else { + if ($_) {$result.=&escape($_).'=';} else { last; } + } + + if(ref($hashref->{$_}) eq 'ARRAY') { + $result.=&arrayref2str($hashref->{$_}).'&'; + } elsif(ref($hashref->{$_}) eq 'HASH') { + $result.=&hashref2str($hashref->{$_}).'&'; + } elsif(ref($hashref->{$_})) { + $result.='&'; + #print("Got a ref of ".(ref($hashref->{$_}))." skipping."); + } else { + $result.=&escape($hashref->{$_}).'&'; + } + } + $result=~s/\&$//; + $result .= '__END_HASH_REF__'; + return $result; +} + +sub str2hash { + my ($string)=@_; + my ($hash)=&str2hashref('__HASH_REF__'.$string.'__END_HASH_REF__'); + return %$hash; +} + +sub str2hashref { + my ($string) = @_; + + my %hash; + + if($string !~ /^__HASH_REF__/) { + if (! ($string eq '' || !defined($string))) { + $hash{'error'}='Not hash reference'; + } + return (\%hash, $string); + } + + $string =~ s/^__HASH_REF__//; + + while($string !~ /^__END_HASH_REF__/) { + #key + my $key=''; + if($string =~ /^__HASH_REF__/) { + ($key, $string)=&str2hashref($string); + if(defined($key->{'error'})) { + $hash{'error'}='Bad data'; + return (\%hash, $string); + } + } elsif($string =~ /^__ARRAY_REF__/) { + ($key, $string)=&str2arrayref($string); + if($key->[0] eq 'Array reference error') { + $hash{'error'}='Bad data'; + return (\%hash, $string); + } + } else { + $string =~ s/^(.*?)=//; + $key=&unescape($1); + } + $string =~ s/^=//; + + #value + my $value=''; + if($string =~ /^__HASH_REF__/) { + ($value, $string)=&str2hashref($string); + if(defined($value->{'error'})) { + $hash{'error'}='Bad data'; + return (\%hash, $string); + } + } elsif($string =~ /^__ARRAY_REF__/) { + ($value, $string)=&str2arrayref($string); + if($value->[0] eq 'Array reference error') { + $hash{'error'}='Bad data'; + return (\%hash, $string); + } + } else { + $value=&get_scalar(\$string,'__END_HASH_REF__'); + } + $string =~ s/^&//; + + $hash{$key}=$value; + } + + $string =~ s/^__END_HASH_REF__//; + + return (\%hash, $string); +} + +sub str2array { + my ($string)=@_; + my ($array)=&str2arrayref('__ARRAY_REF__'.$string.'__END_ARRAY_REF__'); + return @$array; +} + +sub str2arrayref { + my ($string) = @_; + my @array; + + if($string !~ /^__ARRAY_REF__/) { + if (! ($string eq '' || !defined($string))) { + $array[0]='Array reference error'; + } + return (\@array, $string); + } + + $string =~ s/^__ARRAY_REF__//; + + while($string !~ /^__END_ARRAY_REF__/) { + my $value=''; + if($string =~ /^__HASH_REF__/) { + ($value, $string)=&str2hashref($string); + if(defined($value->{'error'})) { + $array[0] ='Array reference error'; + return (\@array, $string); + } + } elsif($string =~ /^__ARRAY_REF__/) { + ($value, $string)=&str2arrayref($string); + if($value->[0] eq 'Array reference error') { + $array[0] ='Array reference error'; + return (\@array, $string); + } + } else { + $value=&get_scalar(\$string,'__END_ARRAY_REF__'); + } + $string =~ s/^&//; + + push(@array, $value); + } + + $string =~ s/^__END_ARRAY_REF__//; + + return (\@array, $string); +} + +# -------------------------------------------------------------------Temp Store + +sub tmpreset { + my ($symb,$namespace,$domain,$stuname) = @_; + if (!$symb) { + $symb=&symbread(); + if (!$symb) { $symb= $ENV{'request.url'}; } + } + $symb=escape($symb); + + if (!$namespace) { $namespace=$ENV{'request.state'}; } + $namespace=~s/\//\_/g; + $namespace=~s/\W//g; + + #FIXME needs to do something for /pub resources + if (!$domain) { $domain=$ENV{'user.domain'}; } + if (!$stuname) { $stuname=$ENV{'user.name'}; } + my $path=$perlvar{'lonDaemons'}.'/tmp'; + my %hash; + if (tie(%hash,'GDBM_File', + $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', + &GDBM_WRCREAT(),0640)) { + foreach my $key (keys %hash) { + if ($key=~ /:$symb/) { + delete($hash{$key}); + } + } + } +} + +sub tmpstore { + my ($storehash,$symb,$namespace,$domain,$stuname) = @_; + + if (!$symb) { + $symb=&symbread(); + if (!$symb) { $symb= $ENV{'request.url'}; } + } + $symb=escape($symb); + + if (!$namespace) { + # I don't think we would ever want to store this for a course. + # it seems this will only be used if we don't have a course. + #$namespace=$ENV{'request.course.id'}; + #if (!$namespace) { + $namespace=$ENV{'request.state'}; + #} + } + $namespace=~s/\//\_/g; + $namespace=~s/\W//g; +#FIXME needs to do something for /pub resources + if (!$domain) { $domain=$ENV{'user.domain'}; } + if (!$stuname) { $stuname=$ENV{'user.name'}; } + my $now=time; + my %hash; + my $path=$perlvar{'lonDaemons'}.'/tmp'; + if (tie(%hash,'GDBM_File', + $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', + &GDBM_WRCREAT(),0640)) { + $hash{"version:$symb"}++; + my $version=$hash{"version:$symb"}; + my $allkeys=''; + foreach my $key (keys(%$storehash)) { + $allkeys.=$key.':'; + $hash{"$version:$symb:$key"}=$$storehash{$key}; + } + $hash{"$version:$symb:timestamp"}=$now; + $allkeys.='timestamp'; + $hash{"$version:keys:$symb"}=$allkeys; + if (untie(%hash)) { + return 'ok'; + } else { + return "error:$!"; + } + } else { + return "error:$!"; + } +} + +# -----------------------------------------------------------------Temp Restore + +sub tmprestore { + my ($symb,$namespace,$domain,$stuname) = @_; + + if (!$symb) { + $symb=&symbread(); + if (!$symb) { $symb= $ENV{'request.url'}; } + } + $symb=escape($symb); + + if (!$namespace) { $namespace=$ENV{'request.state'}; } + #FIXME needs to do something for /pub resources + if (!$domain) { $domain=$ENV{'user.domain'}; } + if (!$stuname) { $stuname=$ENV{'user.name'}; } + + my %returnhash; + $namespace=~s/\//\_/g; + $namespace=~s/\W//g; + my %hash; + my $path=$perlvar{'lonDaemons'}.'/tmp'; + if (tie(%hash,'GDBM_File', + $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', + &GDBM_READER(),0640)) { + my $version=$hash{"version:$symb"}; + $returnhash{'version'}=$version; + my $scope; + for ($scope=1;$scope<=$version;$scope++) { + my $vkeys=$hash{"$scope:keys:$symb"}; + my @keys=split(/:/,$vkeys); + my $key; + $returnhash{"$scope:keys"}=$vkeys; + foreach $key (@keys) { + $returnhash{"$scope:$key"}=$hash{"$scope:$symb:$key"}; + $returnhash{"$key"}=$hash{"$scope:$symb:$key"}; + } + } + if (!(untie(%hash))) { + return "error:$!"; + } + } else { + return "error:$!"; + } + return %returnhash; +} + +# ----------------------------------------------------------------------- Store + +sub store { + my ($storehash,$symb,$namespace,$domain,$stuname) = @_; + my $home=''; + + if ($stuname) { $home=&homeserver($stuname,$domain); } + + $symb=&symbclean($symb); + if (!$symb) { unless ($symb=&symbread()) { return ''; } } + + if (!$domain) { $domain=$ENV{'user.domain'}; } + if (!$stuname) { $stuname=$ENV{'user.name'}; } + + &devalidate($symb,$stuname,$domain); + + $symb=escape($symb); + if (!$namespace) { + unless ($namespace=$ENV{'request.course.id'}) { + return ''; + } + } + if (!$home) { $home=$ENV{'user.home'}; } + my $namevalue=''; + foreach (keys %$storehash) { + $namevalue.=escape($_).'='.escape($$storehash{$_}).'&'; + } + $namevalue=~s/\&$//; + &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue); + return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home"); +} + +# -------------------------------------------------------------- Critical Store + +sub cstore { + my ($storehash,$symb,$namespace,$domain,$stuname) = @_; + my $home=''; + + if ($stuname) { $home=&homeserver($stuname,$domain); } + + $symb=&symbclean($symb); + if (!$symb) { unless ($symb=&symbread()) { return ''; } } + + if (!$domain) { $domain=$ENV{'user.domain'}; } + if (!$stuname) { $stuname=$ENV{'user.name'}; } + + &devalidate($symb,$stuname,$domain); + + $symb=escape($symb); + if (!$namespace) { + unless ($namespace=$ENV{'request.course.id'}) { + return ''; + } + } + if (!$home) { $home=$ENV{'user.home'}; } + + my $namevalue=''; + foreach (keys %$storehash) { + $namevalue.=escape($_).'='.escape($$storehash{$_}).'&'; + } + $namevalue=~s/\&$//; + &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue); + return critical + ("store:$domain:$stuname:$namespace:$symb:$namevalue","$home"); +} + +# --------------------------------------------------------------------- Restore + +sub restore { + my ($symb,$namespace,$domain,$stuname) = @_; + my $home=''; + + if ($stuname) { $home=&homeserver($stuname,$domain); } + + if (!$symb) { + unless ($symb=escape(&symbread())) { return ''; } + } else { + $symb=&escape(&symbclean($symb)); + } + if (!$namespace) { + unless ($namespace=$ENV{'request.course.id'}) { + return ''; + } + } + if (!$domain) { $domain=$ENV{'user.domain'}; } + if (!$stuname) { $stuname=$ENV{'user.name'}; } + if (!$home) { $home=$ENV{'user.home'}; } + my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home"); + + my %returnhash=(); + foreach (split(/\&/,$answer)) { + my ($name,$value)=split(/\=/,$_); + $returnhash{&unescape($name)}=&unescape($value); + } + my $version; + for ($version=1;$version<=$returnhash{'version'};$version++) { + foreach (split(/\:/,$returnhash{$version.':keys'})) { + $returnhash{$_}=$returnhash{$version.':'.$_}; + } + } + return %returnhash; +} + +# ---------------------------------------------------------- Course Description + +sub coursedescription { + my $courseid=shift; + $courseid=~s/^\///; + $courseid=~s/\_/\//g; + my ($cdomain,$cnum)=split(/\//,$courseid); + my $chome=&homeserver($cnum,$cdomain); + 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') { + %returnhash=&dump('environment',$cdomain,$cnum); + if (!exists($returnhash{'con_lost'})) { + $returnhash{'home'}= $chome; + $returnhash{'domain'} = $cdomain; + $returnhash{'num'} = $cnum; + while (my ($name,$value) = each %returnhash) { + $envhash{'course.'.$normalid.'.'.$name}=$value; + } + $returnhash{'url'}=&clutter($returnhash{'url'}); + $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'. + $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum; + $envhash{'course.'.$normalid.'.home'}=$chome; + $envhash{'course.'.$normalid.'.domain'}=$cdomain; + $envhash{'course.'.$normalid.'.num'}=$cnum; + } + } + &appenv(%envhash); + return %returnhash; +} + +# -------------------------------------------------------- Get user privileges + +sub rolesinit { + my ($domain,$username,$authhost)=@_; + my $rolesdump=reply("dump:$domain:$username:roles",$authhost); + if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; } + my %allroles=(); + my %thesepriv=(); + my $now=time; + my $userroles="user.login.time=$now\n"; + my $thesestr; + + if ($rolesdump ne '') { + foreach (split(/&/,$rolesdump)) { + if ($_!~/^rolesdef\&/) { + my ($area,$role)=split(/=/,$_); + $area=~s/\_\w\w$//; + my ($trole,$tend,$tstart)=split(/_/,$role); + $userroles.='user.role.'.$trole.'.'.$area.'='. + $tstart.'.'.$tend."\n"; +# log the associated role with the area + &userrolelog($trole,$username,$domain,$area,$tstart,$tend); + if ($tend!=0) { + if ($tend<$now) { + $trole=''; + } + } + if ($tstart!=0) { + if ($tstart>$now) { + $trole=''; + } + } + if (($area ne '') && ($trole ne '')) { + my $spec=$trole.'.'.$area; + my ($tdummy,$tdomain,$trest)=split(/\//,$area); + if ($trole =~ /^cr\//) { + my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole); + my $homsvr=homeserver($rauthor,$rdomain); + if ($hostname{$homsvr} ne '') { + my ($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'}; + } + } + } + } + } + } + } + my $adv=0; + my $author=0; + foreach (keys %allroles) { + %thesepriv=(); + if (($_!~/^st/) && ($_!~/^ta/) && ($_!~/^cm/)) { $adv=1; } + if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; } + foreach (split(/:/,$allroles{$_})) { + if ($_ ne '') { + my ($privilege,$restrictions)=split(/&/,$_); + if ($restrictions eq '') { + $thesepriv{$privilege}='F'; + } else { + if ($thesepriv{$privilege} ne 'F') { + $thesepriv{$privilege}.=$restrictions; + } + } + } + } + $thesestr=''; + foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } + $userroles.='user.priv.'.$_.'='.$thesestr."\n"; + } + $userroles.='user.adv='.$adv."\n". + 'user.author='.$author."\n"; + $ENV{'user.adv'}=$adv; + } + return $userroles; +} + +# --------------------------------------------------------------- get interface + +sub get { + my ($namespace,$storearr,$udomain,$uname)=@_; + my $items=''; + foreach (@$storearr) { + $items.=escape($_).'&'; + } + $items=~s/\&$//; + if (!$udomain) { $udomain=$ENV{'user.domain'}; } + if (!$uname) { $uname=$ENV{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); + + my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome); + my @pairs=split(/\&/,$rep); + if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) { + return @pairs; + } + my %returnhash=(); + my $i=0; + foreach (@$storearr) { + $returnhash{$_}=unescape($pairs[$i]); + $i++; + } + return %returnhash; +} + +# --------------------------------------------------------------- del interface + +sub del { + my ($namespace,$storearr,$udomain,$uname)=@_; + my $items=''; + foreach (@$storearr) { + $items.=escape($_).'&'; + } + $items=~s/\&$//; + if (!$udomain) { $udomain=$ENV{'user.domain'}; } + if (!$uname) { $uname=$ENV{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); + + return &reply("del:$udomain:$uname:$namespace:$items",$uhome); +} + +# -------------------------------------------------------------- dump interface + +sub dump { + my ($namespace,$udomain,$uname,$regexp)=@_; + if (!$udomain) { $udomain=$ENV{'user.domain'}; } + if (!$uname) { $uname=$ENV{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); + if ($regexp) { + $regexp=&escape($regexp); + } else { + $regexp='.'; + } + my $rep=reply("dump:$udomain:$uname:$namespace:$regexp",$uhome); + my @pairs=split(/\&/,$rep); + my %returnhash=(); + foreach (@pairs) { + my ($key,$value)=split(/=/,$_); + $returnhash{unescape($key)}=unescape($value); + } + return %returnhash; +} + +# -------------------------------------------------------------- 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; +} + +# --------------------------------------------------------------- put interface + +sub put { + my ($namespace,$storehash,$udomain,$uname)=@_; + if (!$udomain) { $udomain=$ENV{'user.domain'}; } + if (!$uname) { $uname=$ENV{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); + my $items=''; + foreach (keys %$storehash) { + $items.=&escape($_).'='.&escape($$storehash{$_}).'&'; + } + $items=~s/\&$//; + return &reply("put:$udomain:$uname:$namespace:$items",$uhome); +} + +# ------------------------------------------------------ critical put interface + +sub cput { + my ($namespace,$storehash,$udomain,$uname)=@_; + if (!$udomain) { $udomain=$ENV{'user.domain'}; } + if (!$uname) { $uname=$ENV{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); + my $items=''; + foreach (keys %$storehash) { + $items.=escape($_).'='.escape($$storehash{$_}).'&'; + } + $items=~s/\&$//; + return &critical("put:$udomain:$uname:$namespace:$items",$uhome); +} + +# -------------------------------------------------------------- eget interface + +sub eget { + my ($namespace,$storearr,$udomain,$uname)=@_; + my $items=''; + foreach (@$storearr) { + $items.=escape($_).'&'; + } + $items=~s/\&$//; + if (!$udomain) { $udomain=$ENV{'user.domain'}; } + if (!$uname) { $uname=$ENV{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); + my $rep=&reply("eget:$udomain:$uname:$namespace:$items",$uhome); + my @pairs=split(/\&/,$rep); + my %returnhash=(); + my $i=0; + foreach (@$storearr) { + $returnhash{$_}=unescape($pairs[$i]); + $i++; + } + return %returnhash; +} + +# ---------------------------------------------- Custom access rule evaluation + +sub customaccess { + my ($priv,$uri)=@_; + my ($urole,$urealm)=split(/\./,$ENV{'request.role'}); + $urealm=~s/^\W//; + my ($udom,$ucrs,$usec)=split(/\//,$urealm); + my $access=0; + foreach (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) { + my ($effect,$realm,$role)=split(/\:/,$_); + if ($role) { + if ($role ne $urole) { next; } + } + foreach (split(/\s*\,\s*/,$realm)) { + my ($tdom,$tcrs,$tsec)=split(/\_/,$_); + if ($tdom) { + if ($tdom ne $udom) { next; } + } + if ($tcrs) { + if ($tcrs ne $ucrs) { next; } + } + if ($tsec) { + if ($tsec ne $usec) { next; } + } + $access=($effect eq 'allow'); + last; + } + if ($realm eq '' && $role eq '') { + $access=($effect eq 'allow'); + } + } + return $access; +} + +# ------------------------------------------------- Check for a user privilege + +sub allowed { + my ($priv,$uri)=@_; + $uri=&deversion($uri); + my $orguri=$uri; + $uri=&declutter($uri); + + if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; } +# Free bre access to adm and meta resources + + if ((($uri=~/^adm\//) || ($uri=~/\.meta$/)) && ($priv eq 'bre')) { + return 'F'; + } + +# Free bre to public access + + if ($priv eq 'bre') { + my $copyright=&metadata($uri,'copyright'); + if (($copyright eq 'public') && (!$ENV{'request.course.id'})) { + return 'F'; + } + if ($copyright eq 'priv') { + $uri=~/([^\/]+)\/([^\/]+)\//; + unless (($ENV{'user.name'} eq $2) && ($ENV{'user.domain'} eq $1)) { + return ''; + } + } + if ($copyright eq 'domain') { + $uri=~/([^\/]+)\/([^\/]+)\//; + unless (($ENV{'user.domain'} eq $1) || + ($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $1)) { + return ''; + } + } + if ($ENV{'request.role'}=~ /li\.\//) { + # Library role, so allow browsing of resources in this domain. + return 'F'; + } + if ($copyright eq 'custom') { + unless (&customaccess($priv,$uri)) { return ''; } + } + } + # Domain coordinator is trying to create a course + if (($priv eq 'ccc') && ($ENV{'request.role'} =~ /^dc\./)) { + # uri is the requested domain in this case. + # comparison to 'request.role.domain' shows if the user has selected + # a role of dc for the domain in question. + return 'F' if ($uri eq $ENV{'request.role.domain'}); + } + + my $thisallowed=''; + my $statecond=0; + my $courseprivid=''; + +# Course + + if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'}=~/$priv\&([^\:]*)/) { + $thisallowed.=$1; + } + +# Domain + + if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.(split(/\//,$uri))[0].'/'} + =~/$priv\&([^\:]*)/) { + $thisallowed.=$1; + } + +# Course: uri itself is a course + my $courseuri=$uri; + $courseuri=~s/\_(\d)/\/$1/; + $courseuri=~s/^([^\/])/\/$1/; + + if ($ENV{'user.priv.'.$ENV{'request.role'}.'.'.$courseuri} + =~/$priv\&([^\:]*)/) { + $thisallowed.=$1; + } + +# URI is an uploaded document for this course + + if (($priv eq 'bre') && + ($uri=~/^uploaded\/$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}\/$ENV{'course.'.$ENV{'request.course.id'}.'.num'}/)) { + return 'F'; + } +# Full access at system, domain or course-wide level? Exit. + + if ($thisallowed=~/F/) { + return 'F'; + } + +# If this is generating or modifying users, exit with special codes + + if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:$priv\:/) { + return $thisallowed; + } +# +# Gathered so far: system, domain and course wide privileges +# +# Course: See if uri or referer is an individual resource that is part of +# the course + + if ($ENV{'request.course.id'}) { + + $courseprivid=$ENV{'request.course.id'}; + if ($ENV{'request.course.sec'}) { + $courseprivid.='/'.$ENV{'request.course.sec'}; + } + $courseprivid=~s/\_/\//; + my $checkreferer=1; + my ($match,$cond)=&is_on_map($uri); + if ($match) { + $statecond=$cond; + if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} + =~/$priv\&([^\:]*)/) { + $thisallowed.=$1; + $checkreferer=0; + } + } + + if ($checkreferer) { + my $refuri=$ENV{'httpref.'.$orguri}; + unless ($refuri) { + foreach (keys %ENV) { + if ($_=~/^httpref\..*\*/) { + my $pattern=$_; + $pattern=~s/^httpref\.\/res\///; + $pattern=~s/\*/\[\^\/\]\+/g; + $pattern=~s/\//\\\//g; + if ($orguri=~/$pattern/) { + $refuri=$ENV{$_}; + } + } + } + } + + if ($refuri) { + $refuri=&declutter($refuri); + my ($match,$cond)=&is_on_map($refuri); + if ($match) { + my $refstatecond=$cond; + if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} + =~/$priv\&([^\:]*)/) { + $thisallowed.=$1; + $uri=$refuri; + $statecond=$refstatecond; + } + } + } + } + } + +# +# Gathered now: all privileges that could apply, and condition number +# +# +# Full or no access? +# + + if ($thisallowed=~/F/) { + return 'F'; + } + + unless ($thisallowed) { + return ''; + } + +# Restrictions exist, deal with them +# +# C:according to course preferences +# R:according to resource settings +# L:unless locked +# X:according to user session state +# + +# Possibly locked functionality, check all courses +# Locks might take effect only after 10 minutes cache expiration for other +# courses, and 2 minutes for current course + + my $envkey; + if ($thisallowed=~/L/) { + foreach $envkey (keys %ENV) { + if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) { + my $courseid=$2; + my $roleid=$1.'.'.$2; + $courseid=~s/^\///; + my $expiretime=600; + if ($ENV{'request.role'} eq $roleid) { + $expiretime=120; + } + my ($cdom,$cnum,$csec)=split(/\//,$courseid); + my $prefix='course.'.$cdom.'_'.$cnum.'.'; + if ((time-$ENV{$prefix.'last_cache'})>$expiretime) { + &coursedescription($courseid); + } + if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,$csec\,/) + || ($ENV{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) { + if ($ENV{$prefix.'res.'.$uri.'.lock.expire'}>time) { + &log($ENV{'user.domain'},$ENV{'user.name'}, + $ENV{'user.home'}, + 'Locked by res: '.$priv.' for '.$uri.' due to '. + $cdom.'/'.$cnum.'/'.$csec.' expire '. + $ENV{$prefix.'priv.'.$priv.'.lock.expire'}); + return ''; + } + } + if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,$csec\,/) + || ($ENV{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) { + if ($ENV{'priv.'.$priv.'.lock.expire'}>time) { + &log($ENV{'user.domain'},$ENV{'user.name'}, + $ENV{'user.home'}, + 'Locked by priv: '.$priv.' for '.$uri.' due to '. + $cdom.'/'.$cnum.'/'.$csec.' expire '. + $ENV{$prefix.'priv.'.$priv.'.lock.expire'}); + return ''; + } + } + } + } + } + +# +# Rest of the restrictions depend on selected course +# + + unless ($ENV{'request.course.id'}) { + return '1'; + } + +# +# Now user is definitely in a course +# + + +# Course preferences + + if ($thisallowed=~/C/) { + my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; + my $unamedom=$ENV{'user.name'}.':'.$ENV{'user.domain'}; + if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'} + =~/$rolecode/) { + &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, + 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. + $ENV{'request.course.id'}); + return ''; + } + + if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.users.denied'} + =~/$unamedom/) { + &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, + 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '. + $ENV{'request.course.id'}); + return ''; + } + } + +# Resource preferences + + if ($thisallowed=~/R/) { + my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; + if (&metadata($uri,'roledeny')=~/$rolecode/) { + &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, + 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); + return ''; + } + } + +# Restricted by state or randomout? + + if ($thisallowed=~/X/) { + if ($ENV{'acc.randomout'}) { + my $symb=&symbread($uri,1); + if (($symb) && ($ENV{'acc.randomout'}=~/\&$symb\&/)) { + return ''; + } + } + if (&condval($statecond)) { + return '2'; + } else { + return ''; + } + } + + return 'F'; +} + +# --------------------------------------------------- Is a resource on the map? + +sub is_on_map { + my $uri=&declutter(shift); + $uri=~s/\.\d+\.(\w+)$/\.$1/; + my @uriparts=split(/\//,$uri); + my $filename=$uriparts[$#uriparts]; + my $pathname=$uri; + $pathname=~s|/\Q$filename\E$||; + $pathname=~s/^adm\/wrapper\///; + #Trying to find the conditional for the file + my $match=($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ + /\&\Q$filename\E\:([\d\|]+)\&/); + if ($match) { + return (1,$1); + } else { + return (0,0); + } +} + +# --------------------------------------------------------- Get symb from alias + +sub get_symb_from_alias { + my $symb=shift; + my ($map,$resid,$url)=&decode_symb($symb); +# Already is a symb + if ($url) { return $symb; } +# Must be an alias + my $aliassymb=''; + my %bighash; + if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', + &GDBM_READER(),0640)) { + my $rid=$bighash{'mapalias_'.$symb}; + if ($rid) { + my ($mapid,$resid)=split(/\./,$rid); + $aliassymb=&encode_symb($bighash{'map_id_'.$mapid}, + $resid,$bighash{'src_'.$rid}); + } + untie %bighash; + } + return $aliassymb; +} + +# ----------------------------------------------------------------- Define Role + +sub definerole { + if (allowed('mcr','/')) { + my ($rolename,$sysrole,$domrole,$courole)=@_; + foreach (split(':',$sysrole)) { + my ($crole,$cqual)=split(/\&/,$_); + if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; } + if ($pr{'cr:s'}=~/$crole\&/) { + if ($pr{'cr:s'}!~/$crole\&\w*$cqual/) { + return "refused:s:$crole&$cqual"; + } + } + } + foreach (split(':',$domrole)) { + my ($crole,$cqual)=split(/\&/,$_); + if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; } + if ($pr{'cr:d'}=~/$crole\&/) { + if ($pr{'cr:d'}!~/$crole\&\w*$cqual/) { + return "refused:d:$crole&$cqual"; + } + } + } + foreach (split(':',$courole)) { + my ($crole,$cqual)=split(/\&/,$_); + if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; } + if ($pr{'cr:c'}=~/$crole\&/) { + if ($pr{'cr:c'}!~/$crole\&\w*$cqual/) { + return "refused:c:$crole&$cqual"; + } + } + } + my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:". + "$ENV{'user.domain'}:$ENV{'user.name'}:". + "rolesdef_$rolename=". + escape($sysrole.'_'.$domrole.'_'.$courole); + return reply($command,$ENV{'user.home'}); + } else { + return 'refused'; + } +} + +# ---------------- Make a metadata query against the network of library servers + +sub metadata_query { + my ($query,$custom,$customshow,$server_array)=@_; + my %rhash; + my @server_list = (defined($server_array) ? @$server_array + : keys(%libserv) ); + for my $server (@server_list) { + unless ($custom or $customshow) { + my $reply=&reply("querysend:".&escape($query),$server); + $rhash{$server}=$reply; + } + else { + my $reply=&reply("querysend:".&escape($query).':'. + &escape($custom).':'.&escape($customshow), + $server); + $rhash{$server}=$reply; + } + } + return \%rhash; +} + +# ----------------------------------------- Send log queries and wait for reply + +sub log_query { + my ($uname,$udom,$query,%filters)=@_; + my $uhome=&homeserver($uname,$udom); + if ($uhome eq 'no_host') { return 'error: no_host'; } + my $uhost=$hostname{$uhome}; + my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys %filters)); + my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command, + $uhome); + unless ($queryid=~/^$uhost\_/) { return 'error: '.$queryid; } + return get_query_reply($queryid); +} + +sub get_query_reply { + my $queryid=shift; + my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid; + my $reply=''; + for (1..100) { + sleep 2; + if (-e $replyfile.'.end') { + if (my $fh=Apache::File->new($replyfile)) { + $reply.=<$fh>; + $fh->close; + } else { return 'error: reply_file_error'; } + return &unescape($reply); + } + } + return 'timeout:'.$queryid; +} + +sub courselog_query { +# +# possible filters: +# url: url or symb +# username +# domain +# action: view, submit, grade +# start: timestamp +# end: timestamp +# + my (%filters)=@_; + unless ($ENV{'request.course.id'}) { return 'no_course'; } + if ($filters{'url'}) { + $filters{'url'}=&symbclean(&declutter($filters{'url'})); + $filters{'url'}=~s/\.(\w+)$/(\\.\\d+)*\\.$1/; + $filters{'url'}=~s/\.(\w+)\_\_\_/(\\.\\d+)*\\.$1/; + } + my $cname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'}; + my $cdom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}; + return &log_query($cname,$cdom,'courselog',%filters); +} + +sub userlog_query { + my ($uname,$udom,%filters)=@_; + return &log_query($uname,$udom,'userlog',%filters); +} + +# ------------------------------------------------------------------ Plain Text + +sub plaintext { + my $short=shift; + return &mt($prp{$short}); +} + +# ----------------------------------------------------------------- Assign Role + +sub assignrole { + my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_; + my $mrole; + if ($role =~ /^cr\//) { + 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'}); + return 'refused'; + } + $mrole='cr'; + } else { + my $cwosec=$url; + $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/; + 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'}); + return 'refused'; + } + $mrole=$role; + } + my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:". + "$udom:$uname:$url".'_'."$mrole=$role"; + if ($end) { $command.='_'.$end; } + if ($start) { + if ($end) { + $command.='_'.$start; + } else { + $command.='_0_'.$start; + } + } +# 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 +# Overrides without validation + +sub modifyuserauth { + my ($udom,$uname,$umode,$upass)=@_; + my $uhome=&homeserver($uname,$udom); + unless (&allowed('mau',$udom)) { return 'refused'; } + &logthis('Call to modify user authentication '.$udom.', '.$uname.', '. + $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}. + ' in domain '.$ENV{'request.role.domain'}); + my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'. + &escape($upass),$uhome); + &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'}, + 'Authentication changed for '.$udom.', '.$uname.', '.$umode. + '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply); + &log($udom,,$uname,$uhome, + 'Authentication changed by '.$ENV{'user.domain'}.', '. + $ENV{'user.name'}.', '.$umode. + '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply); + unless ($reply eq 'ok') { + &logthis('Authentication mode error: '.$reply); + return 'error: '.$reply; + } + return 'ok'; +} + +# --------------------------------------------------------------- Modify a user + +sub modifyuser { + my ($udom, $uname, $uid, + $umode, $upass, $first, + $middle, $last, $gene, + $forceid, $desiredhome, $email)=@_; + $udom=~s/\W//g; + $uname=~s/\W//g; + &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. + $umode.', '.$first.', '.$middle.', '. + $last.', '.$gene.'(forceid: '.$forceid.')'. + (defined($desiredhome) ? ' desiredhome = '.$desiredhome : + ' desiredhome not specified'). + ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}. + ' in domain '.$ENV{'request.role.domain'}); + my $uhome=&homeserver($uname,$udom,'true'); +# ----------------------------------------------------------------- Create User + if (($uhome eq 'no_host') && + (($umode && $upass) || ($umode eq 'localauth'))) { + my $unhome=''; + if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) { + $unhome = $desiredhome; + } elsif($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $udom) { + $unhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'}; + } else { # load balancing routine for determining $unhome + my $tryserver; + my $loadm=10000000; + foreach $tryserver (keys %libserv) { + if ($hostdom{$tryserver} eq $udom) { + my $answer=reply('load',$tryserver); + if (($answer=~/\d+/) && ($answer<$loadm)) { + $loadm=$answer; + $unhome=$tryserver; + } + } + } + } + if (($unhome eq '') || ($unhome eq 'no_host')) { + return 'error: unable to find a home server for '.$uname. + ' in domain '.$udom; + } + my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':'.$umode.':'. + &escape($upass),$unhome); + unless ($reply eq 'ok') { + return 'error: '.$reply; + } + $uhome=&homeserver($uname,$udom,'true'); + if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) { + return 'error: unable verify users home machine.'; + } + } # End of creation of new user +# ---------------------------------------------------------------------- Add ID + if ($uid) { + $uid=~tr/A-Z/a-z/; + my %uidhash=&idrget($udom,$uname); + if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/) + && (!$forceid)) { + unless ($uid eq $uidhash{$uname}) { + return 'error: user id "'.$uid.'" does not match '. + 'current user id "'.$uidhash{$uname}.'".'; + } + } else { + &idput($udom,($uname => $uid)); + } + } +# -------------------------------------------------------------- Add names, etc + my @tmp=&get('environment', + ['firstname','middlename','lastname','generation'], + $udom,$uname); + my %names; + if ($tmp[0] =~ m/^error:.*/) { + %names=(); + } else { + %names = @tmp; + } +# +# Make sure to not trash student environment if instructor does not bother +# to supply name and email information +# + if ($first) { $names{'firstname'} = $first; } + if (defined($middle)) { $names{'middlename'} = $middle; } + if ($last) { $names{'lastname'} = $last; } + if (defined($gene)) { $names{'generation'} = $gene; } + if ($email) { $names{'notification'} = $email; + $names{'critnotification'} = $email; } + + my $reply = &put('environment', \%names, $udom,$uname); + if ($reply ne 'ok') { return 'error: '.$reply; } + &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '. + $umode.', '.$first.', '.$middle.', '. + $last.', '.$gene.' by '. + $ENV{'user.name'}.' at '.$ENV{'user.domain'}); + return 'ok'; +} + +# -------------------------------------------------------------- Modify student + +sub modifystudent { + my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, + $end,$start,$forceid,$desiredhome,$email)=@_; + my $cid=''; + unless ($cid=$ENV{'request.course.id'}) { + return 'not_in_class'; + } +# --------------------------------------------------------------- Make the user + my $reply=&modifyuser + ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid, + $desiredhome,$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); + return $reply; +} + +sub modify_student_enrollment { + my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start) = @_; + # Get the course id from the environment + my $cid=''; + unless ($cid=$ENV{'request.course.id'}) { + return 'not_in_class'; + } + # Make sure the user exists + my $uhome=&homeserver($uname,$udom); + if (($uhome eq '') || ($uhome eq 'no_host')) { + return 'error: no such user'; + } + # + # 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=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'. + $ENV{'course.'.$cid.'.num'}.':classlist:'. + &escape($uname.':'.$udom).'='. + &escape(join(':',$end,$start,$uid,$usec,$fullname)), + $ENV{'course.'.$cid.'.home'}); + unless (($reply eq 'ok') || ($reply eq 'delayed')) { + return 'error: '.$reply; + } + # Add student role to user + my $uurl='/'.$cid; + $uurl=~s/\_/\//g; + if ($usec) { + $uurl.='/'.$usec; + } + return &assignrole($udom,$uname,$uurl,'st',$end,$start); +} + +# ------------------------------------------------- Write to course preferences + +sub writecoursepref { + my ($courseid,%prefs)=@_; + $courseid=~s/^\///; + $courseid=~s/\_/\//g; + my ($cdomain,$cnum)=split(/\//,$courseid); + my $chome=homeserver($cnum,$cdomain); + if (($chome eq '') || ($chome eq 'no_host')) { + return 'error: no such course'; + } + my $cstring=''; + foreach (keys %prefs) { + $cstring.=escape($_).'='.escape($prefs{$_}).'&'; + } + $cstring=~s/\&$//; + return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome); +} + +# ---------------------------------------------------------- Make/modify course + +sub createcourse { + my ($udom,$description,$url,$course_server,$nonstandard)=@_; + $url=&declutter($url); + my $cid=''; + unless (&allowed('ccc',$udom)) { + return 'refused'; + } +# ------------------------------------------------------------------- Create ID + my $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)). + unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; +# ----------------------------------------------- Make sure that does not exist + my $uhome=&homeserver($uname,$udom,'true'); + unless (($uhome eq '') || ($uhome eq 'no_host')) { + $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)). + unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; + $uhome=&homeserver($uname,$udom,'true'); + unless (($uhome eq '') || ($uhome eq 'no_host')) { + return 'error: unable to generate unique course-ID'; + } + } +# ------------------------------------------------ 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::', + $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 existance + &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description), + $uhome); + &flushcourselogs(); +# set toplevel url + my $topurl=$url; + unless ($nonstandard) { +# ------------------------------------------ For standard courses, make top url + my $mapurl=&clutter($url); + if ($mapurl eq '/res/') { $mapurl=''; } + $ENV{'form.initmap'}=(< + + + + + + +ENDINITMAP + $topurl=&declutter( + &finishuserfileupload($uname,$udom,$uhome,'initmap','default.sequence') + ); + } +# ----------------------------------------------------------- Write preferences + &writecoursepref($udom.'_'.$uname, + ('description' => $description, + 'url' => $topurl)); + return '/'.$udom.'/'.$uname; +} + +# ---------------------------------------------------------- Assign Custom Role + +sub assigncustomrole { + my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag)=@_; + return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename, + $end,$start,$deleteflag); +} + +# ----------------------------------------------------------------- Revoke Role + +sub revokerole { + my ($udom,$uname,$url,$role,$deleteflag)=@_; + my $now=time; + return &assignrole($udom,$uname,$url,$role,$now,$deleteflag); +} + +# ---------------------------------------------------------- Revoke Custom Role + +sub revokecustomrole { + my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag)=@_; + my $now=time; + return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now, + $deleteflag); +} + +# ------------------------------------------------------------ Directory lister + +sub dirlist { + my ($uri,$userdomain,$username,$alternateDirectoryRoot)=@_; + + $uri=~s/^\///; + $uri=~s/\/$//; + my ($udom, $uname); + (undef,$udom,$uname)=split(/\//,$uri); + if(defined($userdomain)) { + $udom = $userdomain; + } + if(defined($username)) { + $uname = $username; + } + + my $dirRoot = $perlvar{'lonDocRoot'}; + if(defined($alternateDirectoryRoot)) { + $dirRoot = $alternateDirectoryRoot; + $dirRoot =~ s/\/$//; + } + + if($udom) { + if($uname) { + my $listing=reply('ls:'.$dirRoot.'/'.$uri, + homeserver($uname,$udom)); + return split(/:/,$listing); + } elsif(!defined($alternateDirectoryRoot)) { + my $tryserver; + my %allusers=(); + foreach $tryserver (keys %libserv) { + if($hostdom{$tryserver} eq $udom) { + my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'. + $udom, $tryserver); + if (($listing ne 'no_such_dir') && ($listing ne 'empty') + && ($listing ne 'con_lost')) { + foreach (split(/:/,$listing)) { + my ($entry,@stat)=split(/&/,$_); + $allusers{$entry}=1; + } + } + } + } + my $alluserstr=''; + foreach (sort keys %allusers) { + $alluserstr.=$_.'&user:'; + } + $alluserstr=~s/:$//; + return split(/:/,$alluserstr); + } else { + my @emptyResults = (); + push(@emptyResults, 'missing user name'); + return split(':',@emptyResults); + } + } elsif(!defined($alternateDirectoryRoot)) { + my $tryserver; + my %alldom=(); + foreach $tryserver (keys %libserv) { + $alldom{$hostdom{$tryserver}}=1; + } + my $alldomstr=''; + foreach (sort keys %alldom) { + $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'/&domain:'; + } + $alldomstr=~s/:$//; + return split(/:/,$alldomstr); + } else { + my @emptyResults = (); + push(@emptyResults, 'missing domain'); + return split(':',@emptyResults); + } +} + +# --------------------------------------------- GetFileTimestamp +# This function utilizes dirlist and returns the date stamp for +# when it was last modified. It will also return an error of -1 +# if an error occurs + +## +## FIXME: This subroutine assumes its caller knows something about the +## directory structure of the home server for the student ($root). +## Not a good assumption to make. Since this is for looking up files +## in user directories, the full path should be constructed by lond, not +## whatever machine we request data from. +## +sub GetFileTimestamp { + my ($studentDomain,$studentName,$filename,$root)=@_; + $studentDomain=~s/\W//g; + $studentName=~s/\W//g; + my $subdir=$studentName.'__'; + $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; + my $proname="$studentDomain/$subdir/$studentName"; + $proname .= '/'.$filename; + my ($fileStat) = &Apache::lonnet::dirlist($proname, $studentDomain, + $studentName, $root); + my @stats = split('&', $fileStat); + if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') { + # @stats contains first the filename, then the stat output + return $stats[10]; # so this is 10 instead of 9. + } else { + return -1; + } +} + +# -------------------------------------------------------- Value of a Condition + +sub directcondval { + my $number=shift; + if ($ENV{'user.state.'.$ENV{'request.course.id'}}) { + return substr($ENV{'user.state.'.$ENV{'request.course.id'}},$number,1); + } else { + return 2; + } +} + +sub condval { + my $condidx=shift; + my $result=0; + my $allpathcond=''; + foreach (split(/\|/,$condidx)) { + if (defined($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_})) { + $allpathcond.= + '('.$ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_}.')|'; + } + } + $allpathcond=~s/\|$//; + if ($ENV{'request.course.id'}) { + if ($allpathcond) { + my $operand='|'; + my @stack; + foreach ($allpathcond=~/(\d+|\(|\)|\&|\|)/g) { + if ($_ eq '(') { + push @stack,($operand,$result) + } elsif ($_ eq ')') { + my $before=pop @stack; + if (pop @stack eq '&') { + $result=$result>$before?$before:$result; + } else { + $result=$result>$before?$result:$before; + } + } elsif (($_ eq '&') || ($_ eq '|')) { + $operand=$_; + } else { + my $new=directcondval($_); + if ($operand eq '&') { + $result=$result>$new?$new:$result; + } else { + $result=$result>$new?$result:$new; + } + } + } + } + } + return $result; +} + +# ---------------------------------------------------- Devalidate courseresdata + +sub devalidatecourseresdata { + my ($coursenum,$coursedomain)=@_; + my $hashid=$coursenum.':'.$coursedomain; + &devalidate_cache(\%courseresdatacache,$hashid,'courseres'); +} + +# --------------------------------------------------- Course Resourcedata Query + +sub courseresdata { + my ($coursenum,$coursedomain,@which)=@_; + my $coursehom=&homeserver($coursenum,$coursedomain); + my $hashid=$coursenum.':'.$coursedomain; + my ($result,$cached)=&is_cached(\%courseresdatacache,$hashid,'courseres'); + unless (defined($cached)) { + my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum); + $result=\%dumpreply; + my ($tmp) = keys(%dumpreply); + if ($tmp !~ /^(con_lost|error|no_such_host)/i) { + &do_cache(\%courseresdatacache,$hashid,$result,'courseres'); + } elsif ($tmp =~ /^(con_lost|no_such_host)/) { + return $tmp; + } elsif ($tmp =~ /^(error)/) { + $result=undef; + &do_cache(\%courseresdatacache,$hashid,$result,'courseres'); + } + } + foreach my $item (@which) { + if (defined($result->{$item})) { + return $result->{$item}; + } + } + return undef; +} + +# +# EXT resource caching routines +# + +sub clear_EXT_cache_status { + &delenv('cache.EXT.'); +} + +sub EXT_cache_status { + my ($target_domain,$target_user) = @_; + my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain; + if (exists($ENV{$cachename}) && ($ENV{$cachename}+600) > time) { + # We know already the user has no data + return 1; + } else { + return 0; + } +} + +sub EXT_cache_set { + my ($target_domain,$target_user) = @_; + my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain; + &appenv($cachename => time); +} + +# --------------------------------------------------------- Value of a Variable +sub EXT { + my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_; + + unless ($varname) { return ''; } + #get real user name/domain, courseid and symb + my $courseid; + my $publicuser; + if ($symbparm) { + $symbparm=&get_symb_from_alias($symbparm); + } + if (!($uname && $udom)) { + (my $cursymb,$courseid,$udom,$uname,$publicuser)= + &Apache::lonxml::whichuser($symbparm); + if (!$symbparm) { $symbparm=$cursymb; } + } else { + $courseid=$ENV{'request.course.id'}; + } + my ($realm,$space,$qualifier,@therest)=split(/\./,$varname); + my $rest; + if (defined($therest[0])) { + $rest=join('.',@therest); + } else { + $rest=''; + } + + my $qualifierrest=$qualifier; + if ($rest) { $qualifierrest.='.'.$rest; } + my $spacequalifierrest=$space; + if ($qualifierrest) { $spacequalifierrest.='.'.$qualifierrest; } + if ($realm eq 'user') { +# --------------------------------------------------------------- user.resource + if ($space eq 'resource') { + if (defined($Apache::lonhomework::parsing_a_problem)) { + return $Apache::lonhomework::history{$qualifierrest}; + } else { + my %restored; + if ($publicuser || $ENV{'request.state'} eq 'construct') { + %restored=&tmprestore($symbparm,$courseid,$udom,$uname); + } else { + %restored=&restore($symbparm,$courseid,$udom,$uname); + } + return $restored{$qualifierrest}; + } +# ----------------------------------------------------------------- user.access + } elsif ($space eq 'access') { + # FIXME - not supporting calls for a specific user + return &allowed($qualifier,$rest); +# ------------------------------------------ user.preferences, user.environment + } elsif (($space eq 'preferences') || ($space eq 'environment')) { + if (($uname eq $ENV{'user.name'}) && + ($udom eq $ENV{'user.domain'})) { + return $ENV{join('.',('environment',$qualifierrest))}; + } else { + my %returnhash; + if (!$publicuser) { + %returnhash=&userenvironment($udom,$uname, + $qualifierrest); + } + return $returnhash{$qualifierrest}; + } +# ----------------------------------------------------------------- user.course + } elsif ($space eq 'course') { + # FIXME - not supporting calls for a specific user + return $ENV{join('.',('request.course',$qualifier))}; +# ------------------------------------------------------------------- user.role + } elsif ($space eq 'role') { + # FIXME - not supporting calls for a specific user + my ($role,$where)=split(/\./,$ENV{'request.role'}); + if ($qualifier eq 'value') { + return $role; + } elsif ($qualifier eq 'extent') { + return $where; + } +# ----------------------------------------------------------------- user.domain + } elsif ($space eq 'domain') { + return $udom; +# ------------------------------------------------------------------- user.name + } elsif ($space eq 'name') { + return $uname; +# ---------------------------------------------------- Any other user namespace + } else { + my %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'}, + [$spacequalifierrest]); + return $ENV{'form.'.$spacequalifierrest}; + } elsif ($realm eq 'request') { +# ------------------------------------------------------------- request.browser + if ($space eq 'browser') { + if ($qualifier eq 'textremote') { + if (&mt('textual_remote_display') eq 'on') { + return 1; + } else { + return 0; + } + } else { + return $ENV{'browser.'.$qualifier}; + } +# ------------------------------------------------------------ request.filename + } else { + return $ENV{'request.'.$spacequalifierrest}; + } + } elsif ($realm eq 'course') { +# ---------------------------------------------------------- course.description + return $ENV{'course.'.$courseid.'.'.$spacequalifierrest}; + } elsif ($realm eq 'resource') { + + 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=(&decode_symb($symbp))[0]; + + my $symbparm=$symbp.'.'.$spacequalifierrest; + my $mapparm=$mapp.'___(all).'.$spacequalifierrest; + + if (($ENV{'user.name'} eq $uname) && + ($ENV{'user.domain'} eq $udom)) { + $section=$ENV{'request.course.sec'}; + } else { + if (! defined($usection)) { + $section=&usection($udom,$uname,$courseid); + } else { + $section = $usection; + } + } + + my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; + my $seclevelr=$courseid.'.['.$section.'].'.$symbparm; + my $seclevelm=$courseid.'.['.$section.'].'.$mapparm; + + my $courselevel=$courseid.'.'.$spacequalifierrest; + my $courselevelr=$courseid.'.'.$symbparm; + my $courselevelm=$courseid.'.'.$mapparm; + +# ----------------------------------------------------------- first, check user + #most student don\'t have any data set, check if there is some data + if (! &EXT_cache_status($udom,$uname)) { + my $hashid="$udom:$uname"; + my ($result,$cached)=&is_cached(\%userresdatacache,$hashid, + 'userres'); + if (!defined($cached)) { + my %resourcedata=&get('resourcedata', + [$courselevelr,$courselevelm, + $courselevel],$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 { + if ($tmp!~/No such file/) { + &logthis("WARNING:". + " Trying to get resource data for ". + $uname." at ".$udom.": ". + $tmp.""); + } elsif ($tmp=~/error:No such file/) { + &EXT_cache_set($udom,$uname); + } elsif ($tmp =~ /^(con_lost|no_such_host)/) { + return $tmp; + } + } + } + +# -------------------------------------------------------- second, check course + + my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'}, + $ENV{'course.'.$courseid.'.domain'}, + ($seclevelr,$seclevelm,$seclevel, + $courselevelr,$courselevelm, + $courselevel)); + if (defined($coursereply)) { return $coursereply; } + +# ------------------------------------------------------ third, check map parms + my %parmhash=(); + my $thisparm=''; + if (tie(%parmhash,'GDBM_File', + $ENV{'request.course.fn'}.'_parms.db', + &GDBM_READER(),0640)) { + $thisparm=$parmhash{$symbparm}; + untie(%parmhash); + } + if ($thisparm) { return $thisparm; } + } +# --------------------------------------------- last, look in resource metadata + + $spacequalifierrest=~s/\./\_/; + my $filename; + if (!$symbparm) { $symbparm=&symbread(); } + if ($symbparm) { + $filename=(&decode_symb($symbparm))[2]; + } else { + $filename=$ENV{'request.filename'}; + } + my $metadata=&metadata($filename,$spacequalifierrest); + if (defined($metadata)) { return $metadata; } + $metadata=&metadata($filename,'parameter_'.$spacequalifierrest); + if (defined($metadata)) { return $metadata; } + +# ------------------------------------------------------------------ Cascade up + unless ($space eq '0') { + my @parts=split(/_/,$space); + my $id=pop(@parts); + my $part=join('_',@parts); + if ($part eq '') { $part='0'; } + my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, + $symbparm,$udom,$uname,$section,1); + if (defined($partgeneral)) { return $partgeneral; } + } + if ($recurse) { return undef; } + my $pack_def=&packages_tab_default($filename,$varname); + if (defined($pack_def)) { return $pack_def; } + +# ---------------------------------------------------- Any other user namespace + } elsif ($realm eq 'environment') { +# ----------------------------------------------------------------- environment + if (($uname eq $ENV{'user.name'})&&($udom eq $ENV{'user.domain'})) { + return $ENV{'environment.'.$spacequalifierrest}; + } else { + my %returnhash=&userenvironment($udom,$uname, + $spacequalifierrest); + return $returnhash{$spacequalifierrest}; + } + } elsif ($realm eq 'system') { +# ----------------------------------------------------------------- system.time + if ($space eq 'time') { + return time; + } + } + return ''; +} + +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 ($pack_part eq $part) { + return $packagetab{"$pack_type&$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 ''; + } + my $filename=$uri; + $uri=~s/\.meta$//; +# +# Is the metadata already cached? +# Look at timestamp of caching +# Everything is cached by the main uri, libraries are never directly cached +# + 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? +# + my %lcmetacache; + if ($liburi) { + $liburi=&declutter($liburi); + $filename=$liburi; + } else { + &devalidate_cache(\%metacache,$uri,'meta'); + } + my %metathesekeys=(); + unless ($filename=~/\.meta$/) { $filename.='.meta'; } + my $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'})) { +# +# This is a package - get package info +# + my $package=$token->[2]->{'package'}; + my $keyroot=&add_prefix_and_part($prefix,$token->[2]->{'part'}); + if (defined($token->[2]->{'id'})) { + $keyroot.='_'.$token->[2]->{'id'}; + } + if ($lcmetacache{':packages'}) { + $lcmetacache{':packages'}.=','.$package.$keyroot; + } else { + $lcmetacache{':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.']'; + } + $lcmetacache{':'.$unikey.'.part'}=$part; + $metathesekeys{$unikey}=1; + unless (defined($lcmetacache{':'.$unikey.'.'.$subp})) { + $lcmetacache{':'.$unikey.'.'.$subp}=$value; + } + if (defined($lcmetacache{':'.$unikey.'.default'})) { + $lcmetacache{':'.$unikey}= + $lcmetacache{':'.$unikey.'.default'}; + } + } + } + } else { +# +# This is not a package - some other kind of start tag +# + my $entry=$token->[1]; + my $unikey; + if ($entry eq 'import') { + $unikey=''; + } else { + $unikey=$entry; + } + $unikey.=&add_prefix_and_part($prefix,$token->[2]->{'part'}); + + if (defined($token->[2]->{'id'})) { + $unikey.='_'.$token->[2]->{'id'}; + } + + if ($entry eq 'import') { +# +# Importing a library here +# + if ($depthcount<20) { + my $location=$parser->get_text('/import'); + my $dir=$filename; + $dir=~s|[^/]*$||; + $location=&filelocation($dir,$location); + foreach (sort(split(/\,/,&metadata($uri,'keys', + $location,$unikey, + $depthcount+1)))) { + $metathesekeys{$_}=1; + } + } + } else { + + if (defined($token->[2]->{'name'})) { + $unikey.='_'.$token->[2]->{'name'}; + } + $metathesekeys{$unikey}=1; + foreach (@{$token->[3]}) { + $lcmetacache{':'.$unikey.'.'.$_}=$token->[2]->{$_}; + } + my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry)); + my $default=$lcmetacache{':'.$unikey.'.default'}; + if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) { + # only ws inside the tag, and not in default, so use default + # as value + $lcmetacache{':'.$unikey}=$default; + } else { + # either something interesting inside the tag or default + # uninteresting + $lcmetacache{':'.$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" + } + } +# are there custom rights to evaluate + if ($lcmetacache{':copyright'} eq 'custom') { + + # + # Importing a rights file here + # + unless ($depthcount) { + my $location=$lcmetacache{':customdistributionfile'}; + my $dir=$filename; + $dir=~s|[^/]*$||; + $location=&filelocation($dir,$location); + foreach (sort(split(/\,/,&metadata($uri,'keys', + $location,'_rights', + $depthcount+1)))) { + $metathesekeys{$_}=1; + } + } + } + $lcmetacache{':keys'}=join(',',keys %metathesekeys); + &metadata_generate_part0(\%metathesekeys,\%lcmetacache,$uri); + $lcmetacache{':allpossiblekeys'}=join(',',keys %metathesekeys); + &do_cache(\%metacache,$uri,\%lcmetacache,'meta'); +# this is the end of "was not already recently cached + } + return $metacache{$uri}->{':'.$what}; +} + +sub metadata_generate_part0 { + my ($metadata,$metacache,$uri) = @_; + my %allnames; + foreach my $metakey (sort keys %$metadata) { + if ($metakey=~/^parameter\_(.*)/) { + my $part=$$metacache{':'.$metakey.'.part'}; + my $name=$$metacache{':'.$metakey.'.name'}; + if (! exists($$metadata{'parameter_0_'.$name.'.name'})) { + $allnames{$name}=$part; + } + } + } + foreach my $name (keys(%allnames)) { + $$metadata{"parameter_0_$name"}=1; + my $key=":parameter_0_$name"; + $$metacache{"$key.part"}='0'; + $$metacache{"$key.name"}=$name; + $$metacache{"$key.type"}=$$metacache{':parameter_'. + $allnames{$name}.'_'.$name. + '.type'}; + my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name. + '.display'}; + my $expr='\\[Part: '.$allnames{$name}.'\\]'; + $olddis=~s/$expr/\[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=&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)) { + foreach (keys %newhash) { + $hash{declutter($_)}=$mapname.'___'.&deversion($newhash{$_}); + } + if (untie(%hash)) { + return 'ok'; + } + } + } + return 'error'; +} + +# --------------------------------------------------------------- Verify a symb + +sub symbverify { + my ($symb,$thisfn)=@_; + $thisfn=&declutter($thisfn); +# direct jump to resource in page or to a sequence - will construct own symbs + if ($thisfn=~/\.(page|sequence)$/) { return 1; } +# check URL part + my ($map,$resid,$url)=&decode_symb($symb); + + unless ($url eq $thisfn) { return 0; } + + $symb=&symbclean($symb); + $thisfn=&deversion($thisfn); + + my %bighash; + my $okay=0; + + if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', + &GDBM_READER(),0640)) { + my $ids=$bighash{'ids_'.&clutter($thisfn)}; + unless ($ids) { + $ids=$bighash{'ids_/'.$thisfn}; + } + if ($ids) { +# ------------------------------------------------------------------- Has ID(s) + foreach (split(/\,/,$ids)) { + my ($mapid,$resid)=split(/\./,$_); + if ( + &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) + eq $symb) { + $okay=1; + } + } + } + untie(%bighash); + } + return $okay; +} + +# --------------------------------------------------------------- Clean-up symb + +sub symbclean { + my $symb=shift; + +# remove version from map + $symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/; + +# remove version from URL + $symb=~s/\.(\d+)\.(\w+)$/\.$2/; + + return $symb; +} + +# ---------------------------------------------- Split symb to find map and url + +sub encode_symb { + my ($map,$resid,$url)=@_; + return &symbclean(&declutter($map).'___'.$resid.'___'.&declutter($url)); +} + +sub decode_symb { + my ($map,$resid,$url)=split(/\_\_\_/,shift); + return (&fixversion($map),$resid,&fixversion($url)); +} + +sub fixversion { + my $fn=shift; + if ($fn=~/^(adm|uploaded|public)/) { return $fn; } + my %bighash; + my $uri=&clutter($fn); + my $key=$ENV{'request.course.id'}.'_'.$uri; +# is this cached? + my ($result,$cached)=&is_cached(\%courseresversioncache,$key, + 'courseresversion',600); + if (defined($cached)) { return $result; } +# unfortunately not cached, or expired + if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', + &GDBM_READER(),0640)) { + if ($bighash{'version_'.$uri}) { + my $version=$bighash{'version_'.$uri}; + unless (($version eq 'mostrecent') || + ($version==&getversion($uri))) { + $uri=~s/\.(\w+)$/\.$version\.$1/; + } + } + untie %bighash; + } + return &do_cache + (\%courseresversioncache,$key,&declutter($uri),'courseresversion'); +} + +sub deversion { + my $url=shift; + $url=~s/\.\d+\.(\w+)$/\.$1/; + return $url; +} + +# ------------------------------------------------------ Return symb list entry + +sub symbread { + my ($thisfn,$donotrecurse)=@_; +# no filename provided? try from environment + unless ($thisfn) { + if ($ENV{'request.symb'}) { return &symbclean($ENV{'request.symb'}); } + $thisfn=$ENV{'request.filename'}; + } +# is that filename actually a symb? Verify, clean, and return + if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) { + if (&symbverify($thisfn,$1)) { return &symbclean($thisfn); } + } + $thisfn=declutter($thisfn); + my %hash; + my %bighash; + my $syval=''; + if (($ENV{'request.course.fn'}) && ($thisfn)) { + if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', + &GDBM_READER(),0640)) { + $syval=$hash{$thisfn}; + untie(%hash); + } +# ---------------------------------------------------------- There was an entry + if ($syval) { + unless ($syval=~/\_\d+$/) { + unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) { + &appenv('request.ambiguous' => $thisfn); + return ''; + } + $syval.=$1; + } + } else { +# ------------------------------------------------------- Was not in symb table + if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', + &GDBM_READER(),0640)) { +# ---------------------------------------------- Get ID(s) for current resource + my $ids=$bighash{'ids_'.&clutter($thisfn)}; + unless ($ids) { + $ids=$bighash{'ids_/'.$thisfn}; + } + unless ($ids) { +# alias? + $ids=$bighash{'mapalias_'.$thisfn}; + } + if ($ids) { +# ------------------------------------------------------------------- Has ID(s) + my @possibilities=split(/\,/,$ids); + if ($#possibilities==0) { +# ----------------------------------------------- There is only one possibility + my ($mapid,$resid)=split(/\./,$ids); + $syval=declutter($bighash{'map_id_'.$mapid}).'___'.$resid; + } elsif (!$donotrecurse) { +# ------------------------------------------ There is more than one possibility + my $realpossible=0; + foreach (@possibilities) { + my $file=$bighash{'src_'.$_}; + if (&allowed('bre',$file)) { + my ($mapid,$resid)=split(/\./,$_); + if ($bighash{'map_type_'.$mapid} ne 'page') { + $realpossible++; + $syval=declutter($bighash{'map_id_'.$mapid}). + '___'.$resid; + } + } + } + if ($realpossible!=1) { $syval=''; } + } else { + $syval=''; + } + } + untie(%bighash) + } + } + if ($syval) { + return &symbclean($syval.'___'.$thisfn); + } + } + &appenv('request.ambiguous' => $thisfn); + return ''; +} + +# ---------------------------------------------------------- Return random seed + +sub numval { + my $txt=shift; + $txt=~tr/A-J/0-9/; + $txt=~tr/a-j/0-9/; + $txt=~tr/K-T/0-9/; + $txt=~tr/k-t/0-9/; + $txt=~tr/U-Z/0-5/; + $txt=~tr/u-z/0-5/; + $txt=~s/\D//g; + return int($txt); +} + +sub latest_rnd_algorithm_id { + return '64bit2'; +} + +sub rndseed { + my ($symb,$courseid,$domain,$username)=@_; + + my ($wsymb,$wcourseid,$wdomain,$wusername)=&Apache::lonxml::whichuser(); + if (!$symb) { + unless ($symb=$wsymb) { return time; } + } + if (!$courseid) { $courseid=$wcourseid; } + if (!$domain) { $domain=$wdomain; } + if (!$username) { $username=$wusername } + my $which=$ENV{"course.$courseid.rndseed"}; + my $CODE=$ENV{'scantron.CODE'}; + if (defined($CODE)) { + &rndseed_CODE_64bit($symb,$courseid,$domain,$username); + } elsif ($which eq '64bit2') { + return &rndseed_64bit2($symb,$courseid,$domain,$username); + } elsif ($which eq '64bit') { + return &rndseed_64bit($symb,$courseid,$domain,$username); + } + return &rndseed_32bit($symb,$courseid,$domain,$username); +} + +sub rndseed_32bit { + my ($symb,$courseid,$domain,$username)=@_; + { + use integer; + my $symbchck=unpack("%32C*",$symb) << 27; + my $symbseed=numval($symb) << 22; + my $namechck=unpack("%32C*",$username) << 17; + my $nameseed=numval($username) << 12; + my $domainseed=unpack("%32C*",$domain) << 7; + my $courseseed=unpack("%32C*",$courseid); + my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck; + #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); + #&Apache::lonxml::debug("rndseed :$num:$symb"); + return $num; + } +} + +sub rndseed_64bit { + my ($symb,$courseid,$domain,$username)=@_; + { + use integer; + my $symbchck=unpack("%32S*",$symb) << 21; + my $symbseed=numval($symb) << 10; + my $namechck=unpack("%32S*",$username); + + my $nameseed=numval($username) << 21; + my $domainseed=unpack("%32S*",$domain) << 10; + my $courseseed=unpack("%32S*",$courseid); + + my $num1=$symbchck+$symbseed+$namechck; + my $num2=$nameseed+$domainseed+$courseseed; + #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); + #&Apache::lonxml::debug("rndseed :$num:$symb"); + return "$num1,$num2"; + } +} + +sub rndseed_64bit2 { + my ($symb,$courseid,$domain,$username)=@_; + { + use integer; + # strings need to be an even # of cahracters long, it it is odd the + # last characters gets thrown away + my $symbchck=unpack("%32S*",$symb.' ') << 21; + my $symbseed=numval($symb) << 10; + my $namechck=unpack("%32S*",$username.' '); + + my $nameseed=numval($username) << 21; + my $domainseed=unpack("%32S*",$domain.' ') << 10; + my $courseseed=unpack("%32S*",$courseid.' '); + + my $num1=$symbchck+$symbseed+$namechck; + my $num2=$nameseed+$domainseed+$courseseed; + #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); + #&Apache::lonxml::debug("rndseed :$num:$symb"); + return "$num1,$num2"; + } +} + +sub rndseed_CODE_64bit { + my ($symb,$courseid,$domain,$username)=@_; + { + use integer; + my $symbchck=unpack("%32S*",$symb.' ') << 16; + my $symbseed=numval($symb); + my $CODEseed=numval($ENV{'scantron.CODE'}) << 16; + my $courseseed=unpack("%32S*",$courseid.' '); + my $num1=$symbseed+$CODEseed; + my $num2=$courseseed+$symbchck; + #&Apache::lonxml::debug("$symbseed:$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 ireceipt { + my ($funame,$fudom,$fucourseid,$fusymb)=@_; + my $cuname=unpack("%32C*",$funame); + my $cudom=unpack("%32C*",$fudom); + my $cucourseid=unpack("%32C*",$fucourseid); + my $cusymb=unpack("%32C*",$fusymb); + my $cunique=unpack("%32C*",$perlvar{'lonReceipt'}); + return unpack("%32C*",$perlvar{'lonHostID'}).'-'. + ($cunique%$cuname+ + $cunique%$cudom+ + $cusymb%$cuname+ + $cusymb%$cudom+ + $cucourseid%$cuname+ + $cucourseid%$cudom); +} + +sub receipt { + my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser(); + return &ireceipt($name,$domain,$courseid,$symb); +} + +# ------------------------------------------------------------ Serves up a file +# returns either the contents of the file or a -1 +sub getfile { + my $file=shift; + if ($file=~/^\/*uploaded\//) { # user file + 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; + } + } else { # normal file from res space + &repcopy($file); + if (! -e $file ) { return -1; }; + my $fh=Apache::File->new($file); + my $a=''; + while (<$fh>) { $a .=$_; } + return $a; + } +} + +sub filelocation { + my ($dir,$file) = @_; + my $location; + $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces + if ($file=~m:^/~:) { # is a contruction space reference + $location = $file; + $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; + } elsif ($file=~/^\/*uploaded/) { # is an uploaded file + $location=$file; + } else { + $file=~s/^$perlvar{'lonDocRoot'}//; + $file=~s:^/*res::; + if ( !( $file =~ m:^/:) ) { + $location = $dir. '/'.$file; + } else { + $location = '/home/httpd/html/res'.$file; + } + } + $location=~s://+:/:g; # remove duplicate / + while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/.. + return $location; +} +sub hreflocation { + my ($dir,$file)=@_; + unless (($file=~/^http:\/\//i) || ($file=~/^\//)) { + my $finalpath=filelocation($dir,$file); + $finalpath=~s/^\/home\/httpd\/html//; + $finalpath=~s-/home/(\w+)/public_html/-/~$1/-; + return $finalpath; + } else { + return $file; + } +} + +# ------------------------------------------------------------- Declutters URLs + +sub declutter { + my $thisfn=shift; + $thisfn=~s/^$perlvar{'lonDocRoot'}//; + $thisfn=~s/^\///; + $thisfn=~s/^res\///; + $thisfn=~s/\?.+$//; + return $thisfn; +} + +# ------------------------------------------------------------- Clutter up URLs + +sub clutter { + my $thisfn='/'.&declutter(shift); + unless ($thisfn=~/^\/(uploaded|adm|userfiles|ext|raw|priv)\//) { + $thisfn='/res'.$thisfn; + } + return $thisfn; +} + +# -------------------------------------------------------- Escape Special Chars + +sub escape { + my $str=shift; + $str =~ s/(\W)/"%".unpack('H2',$1)/eg; + return $str; +} + +# ----------------------------------------------------- Un-Escape Special Chars + +sub unescape { + my $str=shift; + $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; + return $str; +} + +sub mod_perl_version { + if (defined($perlvar{'MODPERL2'})) { + return 2; + } + return 1; +} + +sub correct_line_ends { + my ($result)=@_; + $$result =~s/\r\n/\n/mg; + $$result =~s/\r/\n/mg; +} # ================================================================ Main Program -sub BEGIN { -if ($readit ne 'done') { -# ------------------------------------------------------------ Read access.conf +sub goodbye { + &logthis("Starting Shut down"); +#not converted to using infrastruture and probably shouldn't be + &logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache))); +#converted + &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache))); + &logthis(sprintf("%-20s is %s",'%homecache',scalar(%homecache))); + &logthis(sprintf("%-20s is %s",'%titlecache',scalar(%titlecache))); + &logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache))); +#1.1 only + &logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache))); + &logthis(sprintf("%-20s is %s",'%usectioncache',scalar(%usectioncache))); + &logthis(sprintf("%-20s is %s",'%courseresversioncache',scalar(%courseresversioncache))); + &logthis(sprintf("%-20s is %s",'%resversioncache',scalar(%resversioncache))); + &flushcourselogs(); + &logthis("Shutting down"); + return DONE; +} + +BEGIN { +# ----------------------------------- Read loncapa.conf and loncapa_apache.conf + unless ($readit) { { - my $config=Apache::File->new("/etc/httpd/conf/access.conf"); + my $config=Apache::File->new("/etc/httpd/conf/loncapa.conf"); while (my $configline=<$config>) { - if ($configline =~ /PerlSetVar/) { + if ($configline =~ /^[^\#]*PerlSetVar/) { my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); + chomp($varvalue); $perlvar{$varname}=$varvalue; } } } +{ + my $config=Apache::File->new("/etc/httpd/conf/loncapa_apache.conf"); + + while (my $configline=<$config>) { + if ($configline =~ /^[^\#]*PerlSetVar/) { + my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); + chomp($varvalue); + $perlvar{$varname}=$varvalue; + } + } +} + +# ------------------------------------------------------------ Read domain file +{ + my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. + '/domain.tab'); + %domaindescription = (); + %domain_auth_def = (); + %domain_auth_arg_def = (); + if ($fh) { + 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} ); + } + } +} + # ------------------------------------------------------------- Read hosts file { my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab"); while (my $configline=<$config>) { - my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); - $hostname{$id}=$name; - $hostdom{$id}=$domain; - if ($role eq 'library') { $libserv{$id}=$name; } + next if ($configline =~ /^(\#|\s*$)/); + chomp($configline); + my ($id,$domain,$role,$name,$ip,$domdescr)=split(/:/,$configline); + if ($id && $domain && $role && $name && $ip) { + $hostname{$id}=$name; + $hostdom{$id}=$domain; + $hostip{$id}=$ip; + $iphost{$ip}=$id; + if ($role eq 'library') { $libserv{$id}=$name; } + } else { + if ($configline) { + &logthis("Skipping hosts.tab line -$configline-"); + } + } } } @@ -261,16 +4525,872 @@ if ($readit ne 'done') { while (my $configline=<$config>) { chomp($configline); - if (($configline) && ($configline ne $perlvar{'lonHostID'})) { + if ($configline) { $spareid{$configline}=1; } } } -$readit='done'; -&logthis('Read configuration'); +# ------------------------------------------------------------ Read permissions +{ + my $config=Apache::File->new("$perlvar{'lonTabDir'}/roles.tab"); + + while (my $configline=<$config>) { + chomp($configline); + if ($configline) { + my ($role,$perm)=split(/ /,$configline); + if ($perm ne '') { $pr{$role}=$perm; } + } + } +} + +# -------------------------------------------- Read plain texts for permissions +{ + my $config=Apache::File->new("$perlvar{'lonTabDir'}/rolesplain.tab"); + + while (my $configline=<$config>) { + chomp($configline); + if ($configline) { + my ($short,$plain)=split(/:/,$configline); + if ($plain ne '') { $prp{$short}=$plain; } + } + } +} + +# ---------------------------------------------------------- Read package table +{ + my $config=Apache::File->new("$perlvar{'lonTabDir'}/packages.tab"); + + while (my $configline=<$config>) { + chomp($configline); + my ($short,$plain)=split(/:/,$configline); + my ($pack,$name)=split(/\&/,$short); + if ($plain ne '') { + $packagetab{$pack.'&'.$name.'&name'}=$name; + $packagetab{$short}=$plain; + } + } +} + +# ------------- set up temporary directory +{ + $tmpdir = $perlvar{'lonDaemons'}.'/tmp/'; + +} + +%metacache=(); + +$processmarker='_'.time.'_'.$perlvar{'lonHostID'}; +$dumpcount=0; + +&logtouch(); +&logthis('INFO: Read configuration'); +$readit=1; } } + 1; +__END__ + +=pod + +=head1 NAME + +Apache::lonnet - Subroutines to ask questions about things in the network. + +=head1 SYNOPSIS + +Invoked by other LON-CAPA modules, when they need to talk to or about objects in the network. + + &Apache::lonnet::SUBROUTINENAME(ARGUMENTS); + +Common parameters: + +=over 4 + +=item * + +$uname : an internal username (if $cname expecting a course Id specifically) + +=item * + +$udom : a domain (if $cdom expecting a course's domain specifically) + +=item * + +$symb : a resource instance identifier + +=item * + +$namespace : the name of a .db file that contains the data needed or +being set. + +=back + +=head1 OVERVIEW + +lonnet provides subroutines which interact with the +lonc/lond (TCP) network layer of LON-CAPA. They can be used to ask +about classes, users, and resources. + +For many of these objects you can also use this to store data about +them or modify them in various ways. + +=head2 Symbs + +To identify a specific instance of a resource, LON-CAPA uses symbols +or "symbs"X. These identifiers are built from the URL of the +map, the resource number of the resource in the map, and the URL of +the resource itself. The latter is somewhat redundant, but might help +if maps change. + +An example is + + msu/korte/parts/part1.sequence___19___msu/korte/tests/part12.problem + +The respective map entry is + + + + +Symbs are used by the random number generator, as well as to store and +restore data specific to a certain instance of for example a problem. + +=head2 Storing And Retrieving Data + +XXXThree of the most important functions +in C are C<&Apache::lonnet::cstore()>, +C<&Apache::lonnet:restore()>, and C<&Apache::lonnet::store()>, which +is is the non-critical message twin of cstore. These functions are for +handlers to store a perl hash to a user's permanent data space in an +easy manner, and to retrieve it again on another call. It is expected +that a handler would use this once at the beginning to retrieve data, +and then again once at the end to send only the new data back. + +The data is stored in the user's data directory on the user's +homeserver under the ID of the course. + +The hash that is returned by restore will have all of the previous +value for all of the elements of the hash. + +Example: + + #creating a hash + my %hash; + $hash{'foo'}='bar'; + + #storing it + &Apache::lonnet::cstore(\%hash); + + #changing a value + $hash{'foo'}='notbar'; + + #adding a new value + $hash{'bar'}='foo'; + &Apache::lonnet::cstore(\%hash); + + #retrieving the hash + my %history=&Apache::lonnet::restore(); + + #print the hash + foreach my $key (sort(keys(%history))) { + print("\%history{$key} = $history{$key}"); + } + +Will print out: + + %history{1:foo} = bar + %history{1:keys} = foo:timestamp + %history{1:timestamp} = 990455579 + %history{2:bar} = foo + %history{2:foo} = notbar + %history{2:keys} = foo:bar:timestamp + %history{2:timestamp} = 990455580 + %history{bar} = foo + %history{foo} = notbar + %history{timestamp} = 990455580 + %history{version} = 2 + +Note that the special hash entries C, C and +C were added to the hash. C will be equal to the +total number of versions of the data that have been stored. The +C attribute will be the UNIX time the hash was +stored. C is available in every historical section to list which +keys were added or changed at a specific historical revision of a +hash. + +B: do not store the hash that restore returns directly. This +will cause a mess since it will restore the historical keys as if the +were new keys. I.E. 1:foo will become 1:1:foo etc. + +Calling convention: + + my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname,$home); + &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$home); + +For more detailed information, see lonnet specific documentation. + +=head1 RETURN MESSAGES + +=over 4 + +=item * B: unable to contact remote host + +=item * B: unable to contact remote host, message will be delivered +when the connection is brought back up + +=item * B: unable to contact remote host and unable to save message +for later delivery + +=item * B: an error a occured, a description of the error follows the : + +=item * B: unable to fund a host associated with the user/domain +that was requested + +=back + +=head1 PUBLIC SUBROUTINES + +=head2 Session Environment Functions + +=over 4 + +=item * +X +B: the value of %hash is written to +the user envirnoment file, and will be restored for each access this +user makes during this session, also modifies the %ENV for the current +process + +=item * +X +B: removes all items from the session +environment file that matches the regular expression in $regexp. The +values are also delted from the current processes %ENV. + +=back + +=head2 User Information + +=over 4 + +=item * +X +B: try to determine user's current +authentication scheme + +=item * +X +B: try to +authenticate user from domain's lib servers (first use the current +one). C<$upass> should be the users password. + +=item * +X +B: find the server which has +the user's directory and files (there must be only one), this caches +the answer, and also caches if there is a borken connection. + +=item * +X +B: find the usernames behind a list of IDs +(IDs are a unique resource in a domain, there must be only 1 ID per +username, and only 1 username per ID in a specific domain) (returns +hash: id=>name,id=>name) + +=item * +X +B: find the IDs behind a list of +usernames (returns hash: name=>id,name=>id) + +=item * +X +B: store away a list of names and associated IDs + +=item * +X +B: get user privileges + +=item * +X +B: finds the section of student in the +course $cname, return section name/number or '' for "not in course" +and '-1' for "no section" + +=item * +X +B: gets the values of the keys +passed in @what from the requested user's environment, returns a hash + +=back + +=head2 User Roles + +=over 4 + +=item * + +allowed($priv,$uri) : check for a user privilege; returns codes for allowed +actions + F: full access + U,I,K: authentication modes (cxx only) + '': forbidden + 1: user needs to choose course + 2: browse allowed + +=item * + +definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom +role rolename set privileges in format of lonTabs/roles.tab for system, domain, +and course level + +=item * + +plaintext($short) : return value in %prp hash (rolesplain.tab); plain text +explanation of a user role term + +=back + +=head2 User Modification + +=over 4 + +=item * + +assignrole($udom,$uname,$url,$role,$end,$start) : assign role; give a role to a +user for the level given by URL. Optional start and end dates (leave empty +string or zero for "no date") + +=item * + +changepass($uname,$udom,$currentpass,$newpass,$server) : attempts to +change a users, password, possible return values are: ok, +pwchange_failure, non_authorized, auth_mode_error, unknown_user, +refused + +=item * + +modifyuserauth($udom,$uname,$umode,$upass) : modify user authentication + +=item * + +modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) : +modify user + +=item * + +modifystudent + +modify a students enrollment and identification information. +The course id is resolved based on the current users environment. +This means the envoking user must be a course coordinator or otherwise +associated with a course. + +This call is essentially a wrapper for lonnet::modifyuser and +lonnet::modify_student_enrollment + +Inputs: + +=over 4 + +=item B<$udom> Students loncapa domain + +=item B<$uname> Students loncapa login name + +=item B<$uid> Students id/student number + +=item B<$umode> Students authentication mode + +=item B<$upass> Students password + +=item B<$first> Students first name + +=item B<$middle> Students middle name + +=item B<$last> Students last name + +=item B<$gene> Students generation + +=item B<$usec> Students section in course + +=item B<$end> Unix time of the roles expiration + +=item B<$start> Unix time of the roles start date + +=item B<$forceid> If defined, allow $uid to be changed + +=item B<$desiredhome> server to use as home server for student + +=back + +=item * + +modify_student_enrollment + +Change a students enrollment status in a class. The environment variable +'role.request.course' must be defined for this function to proceed. + +Inputs: + +=over 4 + +=item $udom, students domain + +=item $uname, students name + +=item $uid, students user id + +=item $first, students first name + +=item $middle + +=item $last + +=item $gene + +=item $usec + +=item $end + +=item $start + +=back + + +=item * + +assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start) : assign +custom role; give a custom role to a user for the level given by URL. Specify +name and domain of role author, and role name + +=item * + +revokerole($udom,$uname,$url,$role) : revoke a role for url + +=item * + +revokecustomrole($udom,$uname,$url,$role) : revoke a custom role + +=back + +=head2 Course Infomation + +=over 4 + +=item * + +coursedescription($courseid) : course description + +=item * + +courseresdata($coursenum,$coursedomain,@which) : request for current +parameter setting for a specific course, @what should be a list of +parameters to ask about. This routine caches answers for 5 minutes. + +=back + +=head2 Course Modification + +=over 4 + +=item * + +writecoursepref($courseid,%prefs) : write preferences (environment +database) for a course + +=item * + +createcourse($udom,$description,$url) : make/modify course + +=back + +=head2 Resource Subroutines + +=over 4 + +=item * + +subscribe($fname) : subscribe to a resource, returns URL if possible (probably should use repcopy instead) + +=item * + +repcopy($filename) : subscribes to the requested file, and attempts to +replicate from the owning library server, Might return +HTTP_SERVICE_UNAVAILABLE, HTTP_NOT_FOUND, FORBIDDEN, OK, or +HTTP_BAD_REQUEST, also attempts to grab the metadata for the +resource. Expects the local filesystem pathname +(/home/httpd/html/res/....) + +=back + +=head2 Resource Information + +=over 4 + +=item * + +EXT($varname,$symb,$udom,$uname) : evaluates and returns the value of +a vairety of different possible values, $varname should be a request +string, and the other parameters can be used to specify who and what +one is asking about. + +Possible values for $varname are environment.lastname (or other item +from the envirnment hash), user.name (or someother aspect about the +user), resource.0.maxtries (or some other part and parameter of a +resource) + +=item * + +directcondval($number) : get current value of a condition; reads from a state +string + +=item * + +condval($condidx) : value of condition index based on state + +=item * + +metadata($uri,$what,$liburi,$prefix,$depthcount) : request a +resource's metadata, $what should be either a specific key, or either +'keys' (to get a list of possible keys) or 'packages' to get a list of +packages that this resource currently uses, the last 3 arguments are only used internally for recursive metadata. + +this function automatically caches all requests + +=item * + +metadata_query($query,$custom,$customshow) : make a metadata query against the +network of library servers; returns file handle of where SQL and regex results +will be stored for query + +=item * + +symbread($filename) : return symbolic list entry (filename argument optional); +returns the data handle + +=item * + +symbverify($symb,$thisfn) : verifies that $symb actually exists and is +a possible symb for the URL in $thisfn, returns a 1 on success, 0 on +failure, user must be in a course, as it assumes the existance of the +course initi hash, and uses $ENV('request.course.id'} + + +=item * + +symbclean($symb) : removes versions numbers from a symb, returns the +cleaned symb + +=item * + +is_on_map($uri) : checks if the $uri is somewhere on the current +course map, user must be in a course for it to work. + +=item * + +numval($salt) : return random seed value (addend for rndseed) + +=item * + +rndseed($symb,$courseid,$udom,$uname) : create a random sum; returns +a random seed, all arguments are optional, if they aren't sent it uses the +environment to derive them. Note: if symb isn't sent and it can't get one +from &symbread it will use the current time as its return value + +=item * + +ireceipt($funame,$fudom,$fucourseid,$fusymb) : return unique, +unfakeable, receipt + +=item * + +receipt() : API to ireceipt working off of ENV values; given out to users + +=item * + +countacc($url) : count the number of accesses to a given URL + +=item * + +checkout($symb,$tuname,$tudom,$tcrsid) : creates a record of a user having looked at an item, most likely printed out or otherwise using a resource + +=item * + +checkin($token) : updates that a resource has beeen returned (a hard copy version for instance) and returns the data that $token was Checkout with ($symb, $tuname, $tudom, and $tcrsid) + +=item * + +expirespread($uname,$udom,$stype,$usymb) : set expire date for spreadsheet + +=item * + +devalidate($symb) : devalidate temporary spreadsheet calculations, +forcing spreadsheet to reevaluate the resource scores next time. + +=back + +=head2 Storing/Retreiving Data + +=over 4 + +=item * + +store($storehash,$symb,$namespace,$udom,$uname) : stores hash permanently +for this url; hashref needs to be given and should be a \%hashname; the +remaining args aren't required and if they aren't passed or are '' they will +be derived from the ENV + +=item * + +cstore($storehash,$symb,$namespace,$udom,$uname) : same as store but +uses critical subroutine + +=item * + +restore($symb,$namespace,$udom,$uname) : returns hash for this symb; +all args are optional + +=item * + +tmpstore($storehash,$symb,$namespace,$udom,$uname) : storage that +works very similar to store/cstore, but all data is stored in a +temporary location and can be reset using tmpreset, $storehash should +be a hash reference, returns nothing on success + +=item * + +tmprestore($symb,$namespace,$udom,$uname) : storage that works very +similar to restore, but all data is stored in a temporary location and +can be reset using tmpreset. Returns a hash of values on success, +error string otherwise. + +=item * + +tmpreset($symb,$namespace,$udom,$uname) : temporary storage reset, +deltes all keys for $symb form the temporary storage hash. + +=item * + +get($namespace,$storearr,$udom,$uname) : returns hash with keys from array +reference filled in from namesp ($udom and $uname are optional) + +=item * + +del($namespace,$storearr,$udom,$uname) : deletes keys out of array from +namesp ($udom and $uname are optional) + +=item * + +dump($namespace,$udom,$uname,$regexp) : +dumps the complete (or key matching regexp) namespace into a hash +($udom, $uname and $regexp are optional) + +=item * + +put($namespace,$storehash,$udom,$uname) : stores hash in namesp +($udom and $uname are optional) + +=item * + +cput($namespace,$storehash,$udom,$uname) : critical put +($udom and $uname are optional) + +=item * + +eget($namespace,$storearr,$udom,$uname) : returns hash with keys from array +reference filled in from namesp (encrypts the return communication) +($udom and $uname are optional) + +=item * + +log($udom,$name,$home,$message) : write to permanent log for user; use +critical subroutine + +=back + +=head2 Network Status Functions + +=over 4 + +=item * + +dirlist($uri) : return directory list based on URI + +=item * + +spareserver() : find server with least workload from spare.tab + +=back + +=head2 Apache Request + +=over 4 + +=item * + +ssi($url,%hash) : server side include, does a complete request cycle on url to +localhost, posts hash + +=back + +=head2 Data to String to Data + +=over 4 + +=item * + +hash2str(%hash) : convert a hash into a string complete with escaping and '=' +and '&' separators, supports elements that are arrayrefs and hashrefs + +=item * + +hashref2str($hashref) : convert a hashref into a string complete with +escaping and '=' and '&' separators, supports elements that are +arrayrefs and hashrefs + +=item * + +arrayref2str($arrayref) : convert an arrayref into a string complete +with escaping and '&' separators, supports elements that are arrayrefs +and hashrefs + +=item * + +str2hash($string) : convert string to hash using unescaping and +splitting on '=' and '&', supports elements that are arrayrefs and +hashrefs + +=item * + +str2array($string) : convert string to hash using unescaping and +splitting on '&', supports elements that are arrayrefs and hashrefs + +=back + +=head2 Logging Routines + +=over 4 + +These routines allow one to make log messages in the lonnet.log and +lonnet.perm logfiles. + +=item * + +logtouch() : make sure the logfile, lonnet.log, exists + +=item * + +logthis() : append message to the normal lonnet.log file, it gets +preiodically rolled over and deleted. + +=item * + +logperm() : append a permanent message to lonnet.perm.log, this log +file never gets deleted by any automated portion of the system, only +messages of critical importance should go in here. + +=back + +=head2 General File Helper Routines + +=over 4 + +=item * + +getfile($file) : returns the entire contents of a file or -1; it +properly subscribes to and replicates the file if neccessary. + +=item * + +filelocation($dir,$file) : returns file system location of a file +based on URI; meant to be "fairly clean" absolute reference, $dir is a +directory that relative $file lookups are to looked in ($dir of /a/dir +and a file of ../bob will become /a/bob) + +=item * + +hreflocation($dir,$file) : returns file system location or a URL; same as +filelocation except for hrefs + +=item * + +declutter() : declutters URLs (remove docroot, beginning slashes, 'res' etc) + +=back + +=head2 HTTP Helper Routines + +=over 4 + +=item * + +escape() : unpack non-word characters into CGI-compatible hex codes + +=item * + +unescape() : pack CGI-compatible hex codes into actual non-word ASCII character + +=back + +=head1 PRIVATE SUBROUTINES + +=head2 Underlying communication routines (Shouldn't call) + +=over 4 + +=item * + +subreply() : tries to pass a message to lonc, returns con_lost if incapable + +=item * + +reply() : uses subreply to send a message to remote machine, logs all failures + +=item * + +critical() : passes a critical message to another server; if cannot +get through then place message in connection buffer directory and +returns con_delayed, if incapable of saving message, returns +con_failed + +=item * + +reconlonc() : tries to reconnect lonc client processes. + +=back + +=head2 Resource Access Logging + +=over 4 + +=item * + +flushcourselogs() : flush (save) buffer logs and access logs + +=item * + +courselog($what) : save message for course in hash + +=item * + +courseacclog($what) : save message for course using &courselog(). Perform +special processing for specific resource types (problems, exams, quizzes, etc). + +=item * + +goodbye() : flush course logs and log shutting down; it is called in srm.conf +as a PerlChildExitHandler + +=back + +=head2 Other + +=over 4 + +=item * +symblist($mapname,%newhash) : update symbolic storage links +=back +=cut