--- loncom/lonnet/perl/lonnet.pm 2003/10/30 20:22:00 1.436 +++ loncom/lonnet/perl/lonnet.pm 2004/06/29 04:30:00 1.515 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.436 2003/10/30 20:22:00 albertel Exp $ +# $Id: lonnet.pm,v 1.515 2004/06/29 04:30:00 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -30,12 +30,13 @@ package Apache::lonnet; use strict; -use Apache::File; use LWP::UserAgent(); use HTTP::Headers; +use HTTP::Date; +# use Date::Parse; use vars qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom - %libserv %pr %prp %metacache %packagetab %titlecache + %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 @@ -52,12 +53,35 @@ use Storable qw(lock_store lock_nstore l use Time::HiRes(); my $readit; +=pod + +=head1 Package Variables + +These are largely undocumented, so if you decipher one please note it here. + +=over 4 + +=item $processmarker + +Contains the time this process was started and this servers host id. + +=item $dumpcount + +Counts the number of times a message log flush has been attempted (regardless +of success) by this process. Used as part of the filename when messages are +delayed. + +=back + +=cut + + # --------------------------------------------------------------------- Logging sub logtouch { my $execdir=$perlvar{'lonDaemons'}; - unless (-e "$execdir/logs/lonnet.log") { - my $fh=Apache::File->new(">>$execdir/logs/lonnet.log"); + unless (-e "$execdir/logs/lonnet.log") { + open(my $fh,">>$execdir/logs/lonnet.log"); close $fh; } my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3]; @@ -69,8 +93,10 @@ sub logthis { my $execdir=$perlvar{'lonDaemons'}; my $now=time; my $local=localtime($now); - my $fh=Apache::File->new(">>$execdir/logs/lonnet.log"); - print $fh "$local ($$): $message\n"; + if (open(my $fh,">>$execdir/logs/lonnet.log")) { + print $fh "$local ($$): $message\n"; + close($fh); + } return 1; } @@ -79,8 +105,10 @@ sub logperm { my $execdir=$perlvar{'lonDaemons'}; my $now=time; my $local=localtime($now); - my $fh=Apache::File->new(">>$execdir/logs/lonnet.perm.log"); - print $fh "$now:$message:$local\n"; + if (open(my $fh,">>$execdir/logs/lonnet.perm.log")) { + print $fh "$now:$message:$local\n"; + close($fh); + } return 1; } @@ -132,7 +160,7 @@ sub reconlonc { my $peerfile=shift; &logthis("Trying to reconnect for $peerfile"); my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid"; - if (my $fh=Apache::File->new("$loncfile")) { + if (open(my $fh,"<$loncfile")) { my $loncpid=<$fh>; chomp($loncpid); if (kill 0 => $loncpid) { @@ -180,18 +208,20 @@ sub critical { "$perlvar{'lonSockDir'}/delayed/$now.$dumpcount.$$.$middlename.$server"; $dumpcount++; { - my $dfh; - if ($dfh=Apache::File->new(">$dfilename")) { - print $dfh "$cmd\n"; - } + my $dfh; + if (open($dfh,">$dfilename")) { + print $dfh "$cmd\n"; + close($dfh); + } } sleep 2; my $wcmd=''; { - my $dfh; - if ($dfh=Apache::File->new("$dfilename")) { - $wcmd=<$dfh>; - } + my $dfh; + if (open($dfh,"<$dfilename")) { + $wcmd=<$dfh>; + close($dfh); + } } chomp($wcmd); if ($wcmd eq $cmd) { @@ -230,10 +260,10 @@ sub transfer_profile_to_env { my ($lonidsdir,$handle)=@_; my @profile; { - my $idf=Apache::File->new("$lonidsdir/$handle.id"); + open(my $idf,"$lonidsdir/$handle.id"); flock($idf,LOCK_SH); @profile=<$idf>; - $idf->close(); + close($idf); } my $envi; my %Remove; @@ -247,10 +277,10 @@ sub transfer_profile_to_env { } } } + $ENV{'user.environment'} = "$lonidsdir/$handle.id"; foreach my $expired_key (keys(%Remove)) { &delenv($expired_key); } - $ENV{'user.environment'} = "$lonidsdir/$handle.id"; } # ---------------------------------------------------------- Append Environment @@ -269,47 +299,47 @@ sub appenv { } my $lockfh; - unless ($lockfh=Apache::File->new("$ENV{'user.environment'}")) { - return 'error: '.$!; + unless (open($lockfh,"$ENV{'user.environment'}")) { + return 'error: '.$!; } unless (flock($lockfh,LOCK_EX)) { &logthis("WARNING: ". 'Could not obtain exclusive lock in appenv: '.$!); - $lockfh->close(); + close($lockfh); return 'error: '.$!; } my @oldenv; { - my $fh; - unless ($fh=Apache::File->new("$ENV{'user.environment'}")) { - return 'error: '.$!; - } - @oldenv=<$fh>; - $fh->close(); + my $fh; + unless (open($fh,"$ENV{'user.environment'}")) { + return 'error: '.$!; + } + @oldenv=<$fh>; + close($fh); } for (my $i=0; $i<=$#oldenv; $i++) { chomp($oldenv[$i]); if ($oldenv[$i] ne '') { - my ($name,$value)=split(/=/,$oldenv[$i]); - unless (defined($newenv{$name})) { - $newenv{$name}=$value; - } + my ($name,$value)=split(/=/,$oldenv[$i]); + unless (defined($newenv{$name})) { + $newenv{$name}=$value; + } } } { - my $fh; - unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) { - return 'error'; - } - my $newname; - foreach $newname (keys %newenv) { - print $fh "$newname=$newenv{$newname}\n"; - } - $fh->close(); + my $fh; + unless (open($fh,">$ENV{'user.environment'}")) { + return 'error'; + } + my $newname; + foreach $newname (keys %newenv) { + print $fh "$newname=$newenv{$newname}\n"; + } + close($fh); } - - $lockfh->close(); + + close($lockfh); return 'ok'; } # ----------------------------------------------------- Delete from Environment @@ -324,34 +354,39 @@ sub delenv { } my @oldenv; { - my $fh; - unless ($fh=Apache::File->new("$ENV{'user.environment'}")) { - return 'error'; - } - unless (flock($fh,LOCK_SH)) { - &logthis("WARNING: ". - 'Could not obtain shared lock in delenv: '.$!); - $fh->close(); - return 'error: '.$!; - } - @oldenv=<$fh>; - $fh->close(); + my $fh; + unless (open($fh,"$ENV{'user.environment'}")) { + return 'error'; + } + unless (flock($fh,LOCK_SH)) { + &logthis("WARNING: ". + 'Could not obtain shared lock in delenv: '.$!); + close($fh); + return 'error: '.$!; + } + @oldenv=<$fh>; + close($fh); } { - my $fh; - unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) { - return 'error'; - } - unless (flock($fh,LOCK_EX)) { - &logthis("WARNING: ". - 'Could not obtain exclusive lock in delenv: '.$!); - $fh->close(); - return 'error: '.$!; - } - foreach (@oldenv) { - unless ($_=~/^$delthis/) { print $fh $_; } - } - $fh->close(); + my $fh; + unless (open($fh,">$ENV{'user.environment'}")) { + return 'error'; + } + unless (flock($fh,LOCK_EX)) { + &logthis("WARNING: ". + 'Could not obtain exclusive lock in delenv: '.$!); + close($fh); + return 'error: '.$!; + } + foreach (@oldenv) { + if ($_=~/^$delthis/) { + my ($key,undef) = split('=',$_); + delete($ENV{$key}); + } else { + print $fh $_; + } + } + close($fh); } return 'ok'; } @@ -367,7 +402,7 @@ sub userload { while ($filename=readdir(LONIDS)) { if ($filename eq '.' || $filename eq '..') {next;} my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9]; - if ($curtime-$mtime < 3600) { $numusers++; } + if ($curtime-$mtime < 1800) { $numusers++; } } closedir(LONIDS); } @@ -387,10 +422,11 @@ sub overloaderror { unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; } my $loadavg; if ($checkserver eq $perlvar{'lonHostID'}) { - my $loadfile=Apache::File->new('/proc/loadavg'); + open(my $loadfile,'/proc/loadavg'); $loadavg=<$loadfile>; $loadavg =~ s/\s.*//g; $loadavg = 100*$loadavg/$perlvar{'lonLoadLim'}; + close($loadfile); } else { $loadavg=&reply('load',$checkserver); } @@ -398,7 +434,7 @@ sub overloaderror { if ($overload>0) { $r->err_headers_out->{'Retry-After'}=$overload; $r->log_error('Overload of '.$overload.' on '.$checkserver); - return 413; + return 409; } return ''; } @@ -477,38 +513,16 @@ sub changepass { sub queryauthenticate { my ($uname,$udom)=@_; - if (($perlvar{'lonRole'} eq 'library') && - ($udom eq $perlvar{'lonDefDomain'})) { - my $answer=reply("encrypt:currentauth:$udom:$uname", - $perlvar{'lonHostID'}); - unless ($answer eq 'unknown_user' or $answer eq 'refused') { - if (length($answer)) { - return $answer; - } - else { - &logthis("User $uname at $udom lacks an authentication mechanism"); - return 'no_host'; - } - } - } - - my $tryserver; - foreach $tryserver (keys %libserv) { - if ($hostdom{$tryserver} eq $udom) { - my $answer=reply("encrypt:currentauth:$udom:$uname",$tryserver); - unless ($answer eq 'unknown_user' or $answer eq 'refused') { - if (length($answer)) { - return $answer; - } - else { - &logthis("User $uname at $udom lacks an authentication mechanism"); - return 'no_host'; - } - } - } + my $uhome=&homeserver($uname,$udom); + if (!$uhome) { + &logthis("User $uname at $udom is unknown when looking for authentication mechanism"); + return 'no_host'; + } + my $answer=reply("encrypt:currentauth:$udom:$uname",$uhome); + if ($answer =~ /^(unknown_user|refused|con_lost)/) { + &logthis("User $uname at $udom threw error $answer when checking authentication mechanism"); } - &logthis("User $uname at $udom lacks an authentication mechanism"); - return 'no_host'; + return $answer; } # --------- Try to authenticate user from domain's lib servers (first this one) @@ -517,38 +531,21 @@ sub authenticate { my ($uname,$upass,$udom)=@_; $upass=escape($upass); $uname=~s/\W//g; - if (($perlvar{'lonRole'} eq 'library') && - ($udom eq $perlvar{'lonDefDomain'})) { - my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'}); - if ($answer =~ /authorized/) { - if ($answer eq 'authorized') { - &logthis("User $uname at $udom authorized by local server"); - return $perlvar{'lonHostID'}; - } - if ($answer eq 'non_authorized') { - &logthis("User $uname at $udom rejected by local server"); - return 'no_host'; - } - } - } - - my $tryserver; - foreach $tryserver (keys %libserv) { - if ($hostdom{$tryserver} eq $udom) { - my $answer=reply("encrypt:auth:$udom:$uname:$upass",$tryserver); - if ($answer =~ /authorized/) { - if ($answer eq 'authorized') { - &logthis("User $uname at $udom authorized by $tryserver"); - return $tryserver; - } - if ($answer eq 'non_authorized') { - &logthis("User $uname at $udom rejected by $tryserver"); - return 'no_host'; - } - } - } + my $uhome=&homeserver($uname,$udom); + if (!$uhome) { + &logthis("User $uname at $udom is unknown in authenticate"); + return 'no_host'; + } + my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome); + if ($answer eq 'authorized') { + &logthis("User $uname at $udom authorized by $uhome"); + return $uhome; + } + if ($answer eq 'non_authorized') { + &logthis("User $uname at $udom rejected by $uhome"); + return 'no_host'; } - &logthis("User $uname at $udom could not be authenticated"); + &logthis("User $uname at $udom threw error $answer when checking authentication mechanism"); return 'no_host'; } @@ -620,6 +617,7 @@ sub idput { my ($udom,%ids)=@_; my %servers=(); foreach (keys %ids) { + &cput('environment',{'id'=>$ids{$_}},$udom,$_); my $uhom=&homeserver($_,$udom); if ($uhom ne 'no_host') { my $id=&escape($ids{$_}); @@ -630,7 +628,6 @@ sub idput { } else { $servers{$uhom}=$id.'='.$unam; } - &critical('put:'.$udom.':'.$unam.':environment:id='.$id,$uhom); } } foreach (keys %servers) { @@ -645,24 +642,28 @@ sub assign_access_key { # a valid key looks like uname:udom#comments # comments are being appended # - my ($ckey,$cdom,$cnum,$udom,$uname,$logentry)=@_; + my ($ckey,$kdom,$knum,$cdom,$cnum,$udom,$uname,$logentry)=@_; + $kdom= + $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($kdom)); + $knum= + $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($knum)); $cdom= $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); $cnum= $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); $udom=$ENV{'user.name'} unless (defined($udom)); $uname=$ENV{'user.domain'} unless (defined($uname)); - my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); + my %existing=&get('accesskeys',[$ckey],$kdom,$knum); if (($existing{$ckey}=~/^\#(.*)$/) || # - new key - ($existing{$ckey}=~/^$uname\:$udom\#(.*)$/)) { + ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#(.*)$/)) { # assigned to this person # - this should not happen, # unless something went wrong # the first time around # ready to assign $logentry=$1.'; '.$logentry; - if (&put('accesskey',{$ckey=>$uname.':'.$udom.'#'.$logentry}, - $cdom,$cnum) eq 'ok') { + if (&put('accesskeys',{$ckey=>$uname.':'.$udom.'#'.$logentry}, + $kdom,$knum) eq 'ok') { # key now belongs to user my $envkey='key.'.$cdom.'_'.$cnum; if (&put('environment',{$envkey => $ckey}) eq 'ok') { @@ -758,10 +759,10 @@ sub validate_access_key { $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)); + $udom=$ENV{'user.domain'} unless (defined($udom)); + $uname=$ENV{'user.name'} unless (defined($uname)); my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); - return ($existing{$ckey}=~/^$uname\:$udom\#/); + return ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#/); } # ------------------------------------- Find the section of student in a course @@ -789,7 +790,7 @@ sub getsection { &homeserver($unam,$udom)))) { my ($key,$value)=split(/\=/,$_); $key=&unescape($key); - next if ($key !~/^$courseid(?:\/)*(\w+)*\_st$/); + next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/); my $section=$1; if ($key eq $courseid.'_st') { $section=''; } my ($dummy,$end,$start)=split(/\_/,&unescape($value)); @@ -819,19 +820,32 @@ sub getsection { return '-1'; } + +my $disk_caching_disabled=1; + sub devalidate_cache { my ($cache,$id,$name) = @_; delete $$cache{$id.'.time'}; delete $$cache{$id}; - my $filename=$perlvar{'lonDaemons'}.'/tmp/'.$name.".db"; + if ($disk_caching_disabled) { return; } + my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db"; open(DB,"$filename.lock"); flock(DB,LOCK_EX); my %hash; if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) { - delete($hash{$id}); - delete($hash{$id.'.time'}); + eval <<'EVALBLOCK'; + delete($hash{$id}); + delete($hash{$id.'.time'}); +EVALBLOCK + if ($@) { + &logthis("devalidate_cache blew up :$@:$name"); + unlink($filename); + } } else { - &logthis("Unable to tie hash (devalidate cache): $name"); + if (-e $filename) { + &logthis("Unable to tie hash (devalidate cache): $name"); + unlink($filename); + } } untie(%hash); flock(DB,LOCK_UN); @@ -867,69 +881,29 @@ sub do_cache { $$cache{$id}; } -sub save_cache { - my ($cache,$name)=@_; - my $starttime=&Time::HiRes::time(); -# &logthis("Saving :$name:"); - eval lock_store($cache,$perlvar{'lonDaemons'}.'/tmp/'.$name.".storable"); - if ($@) { &logthis("lock_store threw a die ".$@); } -# &logthis("save_cache took ".(&Time::HiRes::time()-$starttime)); -} - -sub load_cache { - my ($cache,$name)=@_; - my $starttime=&Time::HiRes::time(); -# &logthis("Before Loading $name size is ".scalar(%$cache)); - my $tmpcache; - eval { - $tmpcache=lock_retrieve($perlvar{'lonDaemons'}.'/tmp/'.$name.".storable"); - }; - if ($@) { &logthis("lock_retreive threw a die ".$@); return; } - if (!%$cache) { - my $count; - while (my ($key,$value)=each(%$tmpcache)) { - $count++; - $$cache{$key}=$value; - } -# &logthis("Initial load: $count"); - } else { - my $key; - my $count; - while ($key=each(%$tmpcache)) { - if ($key !~/^(.*)\.time$/) { next; } - my $name=$1; - if (exists($$cache{$key})) { - if ($$tmpcache{$key} >= $$cache{$key}) { - $$cache{$key}=$$tmpcache{$key}; - $$cache{$name}=$$tmpcache{$name}; - } else { -# &logthis("Would have overwritten $name with is set to expire at ".$$cache{$key}." with ".$$tmpcache{$key}." Whew!"); - } - } else { - $count++; - $$cache{$key}=$$tmpcache{$key}; - $$cache{$name}=$$tmpcache{$name}; - } - } -# &logthis("Additional load: $count"); - } -# &logthis("After Loading $name size is ".scalar(%$cache)); -# &logthis("load_cache took ".(&Time::HiRes::time()-$starttime)); -} - sub save_cache_item { my ($cache,$name,$id)=@_; + if ($disk_caching_disabled) { return; } my $starttime=&Time::HiRes::time(); - # &logthis("Saving :$name:$id"); +# &logthis("Saving :$name:$id"); my %hash; - my $filename=$perlvar{'lonDaemons'}.'/tmp/'.$name.".db"; + 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)) { - $hash{$id.'.time'}=$$cache{$id.'.time'}; - $hash{$id}=freeze({'item'=>$$cache{$id}}); + 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 { - &logthis("Unable to tie hash (save cache item): $name"); + if (-e $filename) { + &logthis("Unable to tie hash (save cache item): $name ($!)"); + unlink($filename); + } } untie(%hash); flock(DB,LOCK_UN); @@ -939,32 +913,42 @@ sub save_cache_item { sub load_cache_item { my ($cache,$name,$id)=@_; + if ($disk_caching_disabled) { return; } my $starttime=&Time::HiRes::time(); # &logthis("Before Loading $name for $id size is ".scalar(%$cache)); my %hash; - my $filename=$perlvar{'lonDaemons'}.'/tmp/'.$name.".db"; + 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)) { - 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'}; + 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'}; - } + } 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 { - &logthis("Unable to tie hash (load cache item): $name"); + if (-e $filename) { + &logthis("Unable to tie hash (load cache item): $name ($!)"); + unlink($filename); + } } untie(%hash); flock(DB,LOCK_UN); @@ -985,7 +969,7 @@ sub usection { &homeserver($unam,$udom)))) { my ($key,$value)=split(/\=/,$_); $key=&unescape($key); - if ($key=~/^$courseid(?:\/)*(\w+)*\_st$/) { + if ($key=~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/) { my $section=$1; if ($key eq $courseid.'_st') { $section=''; } my ($dummy,$end,$start)=split(/\_/,&unescape($value)); @@ -1042,6 +1026,8 @@ sub getversion { 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); @@ -1053,7 +1039,7 @@ sub currentversion { if (($answer eq 'con_lost') || ($answer eq 'rejected')) { return -1; } - return $answer; + return &do_cache(\%resversioncache,$fname,$answer,'resversion'); } # ----------------------------- Subscribe to a resource, return URL if possible @@ -1088,7 +1074,7 @@ sub repcopy { &logthis("Subscribe returned $remoteurl: $filename"); return HTTP_SERVICE_UNAVAILABLE; } elsif ($remoteurl eq 'not_found') { - &logthis("Subscribe returned not_found: $filename"); + #&logthis("Subscribe returned not_found: $filename"); return HTTP_NOT_FOUND; } elsif ($remoteurl =~ /^rejected by/) { &logthis("Subscribe returned $remoteurl: $filename"); @@ -1145,8 +1131,8 @@ 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/^.*?\]*\>//si; + $output=~s/(.*)\<\/body\s*\>.*?$/$1/si; $output=~ s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs; return $output; @@ -1183,30 +1169,107 @@ sub externalssi { return $response->content; } -# ------- Add a token to a remote URI's query string to vouch for access rights +# -------------------------------- Allow a /uploaded/ URI to be vouched for -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'}; +sub allowuploaded { + my ($srcurl,$url)=@_; + $url=&clutter(&declutter($url)); + my $dir=$url; + $dir=~s/\/[^\/]+$//; + my %httpref=(); + my $httpurl=&hreflocation('',$url); + $httpref{'httpref.'.$httpurl}=$srcurl; + &Apache::lonnet::appenv(%httpref); +} + +# --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course +# input: action, courseID, current domain, home server for course, intended +# path to file, source of file. +# output: url to file (if action was uploaddoc), +# ok if successful, or diagnostic message otherwise (if action was propagate or copy) +# +# Allows directory structure to be used within lonUsers/../userfiles/ for a +# course. +# +# action = propagate - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file +# will be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles in +# course's home server. +# +# action = copy - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file will +# be copied from $source (current location) to +# /home/httpd/html/userfiles/$domain/1/2/3/$course/$file +# and will then be copied to +# /home/httpd/lonUsers/$domain/1/2/3/$course/userfiles/$file in +# course's home server. +# +# action = uploaddoc - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file +# will be retrived from $ENV{form.uploaddoc} (from DOCS interface) to +# /home/httpd/html/userfiles/$domain/1/2/3/$course/$file +# and will then be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles/$file +# in course's home server. + + +sub process_coursefile { + my ($action,$docuname,$docudom,$docuhome,$file,$source)=@_; + my $fetchresult; + if ($action eq 'propagate') { + $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file + ,$docuhome); } else { - return '/adm/notfound.html'; + my $fetchresult = ''; + my $fpath = ''; + my $fname = $file; + ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|); + $fpath=$docudom.'/'.$docuname.'/'.$fpath; + my $filepath=$perlvar{'lonDocRoot'}.'/userfiles'; + unless ($fpath eq '') { + my @parts=split('/',$fpath); + foreach my $part (@parts) { + $filepath.= '/'.$part; + if ((-e $filepath)!=1) { + mkdir($filepath,0777); + } + } + } + if ($action eq 'copy') { + if ($source eq '') { + $fetchresult = 'no source file'; + return $fetchresult; + } else { + my $destination = $filepath.'/'.$fname; + rename($source,$destination); + $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, + $docuhome); + } + } elsif ($action eq 'uploaddoc') { + open(my $fh,'>'.$filepath.'/'.$fname); + print $fh $ENV{'form.'.$source}; + close($fh); + $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, + $docuhome); + if ($fetchresult eq 'ok') { + return '/uploaded/'.$fpath.'/'.$fname; + } else { + &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file. + ' to host '.$docuhome.': '.$fetchresult); + return '/adm/notfound.html'; + } + } + } + unless ( $fetchresult eq 'ok') { + &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file. + ' to host '.$docuhome.': '.$fetchresult); } + return $fetchresult; } - + # --------------- Take an uploaded file and put it into the userfiles directory # input: name of form element, coursedoc=1 means this is for the course # output: url of file in userspace sub userfileupload { - my ($formname,$coursedoc)=@_; + my ($formname,$coursedoc,$subdir)=@_; + if (!defined($subdir)) { $subdir='unknown'; } my $fname=$ENV{'form.'.$formname.'.filename'}; # Replace Windows backslashes by forward slashes $fname=~s/\\/\//g; @@ -1223,23 +1286,35 @@ sub userfileupload { my $docuname=''; my $docudom=''; my $docuhome=''; + $fname="$subdir/$fname"; if ($coursedoc) { $docuname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'}; $docudom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}; $docuhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'}; + if ($ENV{'form.folder'} =~ m/^default/) { + return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname); + } else { + $fname=$ENV{'form.folder'}.'/'.$fname; + return &process_coursefile('uploaddoc',$docuname,$docudom,$docuhome,$fname,$formname); + } } else { $docuname=$ENV{'user.name'}; $docudom=$ENV{'user.domain'}; $docuhome=$ENV{'user.home'}; + return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname); } - return - &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname); } sub finishuserfileupload { my ($docuname,$docudom,$docuhome,$formname,$fname)=@_; my $path=$docudom.'/'.$docuname.'/'; my $filepath=$perlvar{'lonDocRoot'}; + my ($fnamepath,$file); + $file=$fname; + if ($fname=~m|/|) { + ($fnamepath,$file) = ($fname =~ m|^(.*)/([^/]+)$|); + $path.=$fnamepath.'/'; + } my @parts=split(/\//,$filepath.'/userfiles/'.$path); my $count; for ($count=4;$count<=$#parts;$count++) { @@ -1250,25 +1325,37 @@ sub finishuserfileupload { } # Save the file { - my $fh=Apache::File->new('>'.$filepath.'/'.$fname); + #&Apache::lonnet::logthis("Saving to $filepath $file"); + open(my $fh,'>'.$filepath.'/'.$file); print $fh $ENV{'form.'.$formname}; + close($fh); } # Notify homeserver to grep it # - - my $fetchresult= - &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,$docuhome); + my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome); if ($fetchresult eq 'ok') { # # Return the URL to it - return '/uploaded/'.$path.$fname; + return '/uploaded/'.$path.$file; } else { - &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$fname. - ' to host '.$docuhome.': '.$fetchresult); + &logthis('Failed to transfer '.$path.$file.' to host '.$docuhome. + ': '.$fetchresult); return '/adm/notfound.html'; } } +sub removeuploadedurl { + my ($url)=@_; + my (undef,undef,$udom,$uname,$fname)=split('/',$url,5); + return &Apache::lonnet::removeuserfile($uname,$udom,$fname); +} + +sub removeuserfile { + my ($docuname,$docudom,$fname)=@_; + my $home=&homeserver($docuname,$docudom); + return &reply("removeuserfile:$docudom/$docuname/$fname",$home); +} + # ------------------------------------------------------------------------- Log sub log { @@ -1325,12 +1412,35 @@ sub flushcourselogs { # 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}; + foreach my $entry (keys(%accesshash)) { + if ($entry =~ /___count$/) { + my ($dom,$name); + ($dom,$name,undef)=($entry=~m:___(\w+)/(\w+)/(.*)___count$:); + if (! defined($dom) || $dom eq '' || + ! defined($name) || $name eq '') { + my $cid = $ENV{'request.course.id'}; + $dom = $ENV{'request.'.$cid.'.domain'}; + $name = $ENV{'request.'.$cid.'.num'}; + } + my $value = $accesshash{$entry}; + my (undef,$url,undef) = ($entry =~ /^(.*)___(.*)___count$/); + my %temphash=($url => $value); + my $result = &inc('nohist_accesscount',\%temphash,$dom,$name); + if ($result eq 'ok') { + delete $accesshash{$entry}; + } elsif ($result eq 'unknown_cmd') { + # Target server has old code running on it. + my %temphash=($entry => $value); + if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') { + delete $accesshash{$entry}; + } + } + } else { + my ($dom,$name) = ($entry=~m:___(\w+)/(\w+)/(.*)___(\w+)$:); + my %temphash=($entry => $accesshash{$entry}); + if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') { + delete $accesshash{$entry}; + } } } # @@ -1389,14 +1499,11 @@ sub courseacclog { sub countacc { my $url=&declutter(shift); + return if (! defined($url) || $url eq ''); unless ($ENV{'request.course.id'}) { return ''; } $accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1; my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count'; - if (defined($accesshash{$key})) { - $accesshash{$key}++; - } else { - $accesshash{$key}=1; - } + $accesshash{$key}++; } sub linklog { @@ -1411,7 +1518,7 @@ sub userrolelog { my ($trole,$username,$domain,$area,$tstart,$tend)=@_; if (($trole=~/^ca/) || ($trole=~/^in/) || ($trole=~/^cc/) || ($trole=~/^ep/) || - ($trole=~/^cr/)) { + ($trole=~/^cr/) || ($trole=~/^ta/)) { my (undef,$rudom,$runame,$rsec)=split(/\//,$area); $userrolehash {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} @@ -1423,6 +1530,10 @@ sub get_course_adv_roles { my $cid=shift; $cid=$ENV{'request.course.id'} unless (defined($cid)); my %coursehash=&coursedescription($cid); + my %nothide=(); + foreach (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { + $nothide{join(':',split(/[\@\:]/,$_))}=1; + } my %returnhash=(); my %dumphash= &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'}); @@ -1433,6 +1544,8 @@ sub get_course_adv_roles { if (($tend) && ($tend<$now)) { next; } if (($tstart) && ($now<$tstart)) { next; } my ($role,$username,$domain,$section)=split(/\:/,$_); + if ((&privileged($username,$domain)) && + (!$nothide{$username.':'.$domain})) { next; } my $key=&plaintext($role); if ($section) { $key.=' (Sec/Grp '.$section.')'; } if ($returnhash{$key}) { @@ -1475,10 +1588,11 @@ sub postannounce { } sub getannounce { - if (my $fh=Apache::File->new($perlvar{'lonDocRoot'}.'/announcement.txt')) { + + if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) { my $announcement=''; while (<$fh>) { $announcement .=$_; } - $fh->close(); + close($fh); if ($announcement=~/\w/) { return ''. @@ -1501,21 +1615,22 @@ sub courseidput { } sub courseiddump { - my ($domfilter,$descfilter,$sincefilter)=@_; + my ($domfilter,$descfilter,$sincefilter,$hostidflag,$hostidref)=@_; my %returnhash=(); unless ($domfilter) { $domfilter=''; } foreach my $tryserver (keys %libserv) { - if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) { - foreach ( - split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. + if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) || (!defined($hostidflag)) ) { + if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) { + foreach ( + split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. $sincefilter.':'.&escape($descfilter), $tryserver))) { - my ($key,$value)=split(/\=/,$_); - if (($key) && ($value)) { - $returnhash{&unescape($key)}=&unescape($value); + my ($key,$value)=split(/\=/,$_); + if (($key) && ($value)) { + $returnhash{&unescape($key)}=&unescape($value); + } } } - } } return %returnhash; @@ -1524,6 +1639,28 @@ sub courseiddump { # # ----------------------------------------------------------- Check out an item +sub get_first_access { + my ($type,$argsymb)=@_; + my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); + if ($argsymb) { $symb=$argsymb; } + my ($map,$id,$res)=&decode_symb($symb); + if ($type eq 'map') { $res=$map; } + my %times=&get('firstaccesstimes',[$res],$udom,$uname); + return $times{$res}; +} + +sub set_first_access { + my ($type)=@_; + my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); + my ($map,$id,$res)=&decode_symb($symb); + if ($type eq 'map') { $res=$map; } + my $firstaccess=&get_first_access($type); + if (!$firstaccess) { + return &put('firstaccesstimes',{$res=>time},$udom,$uname); + } + return 'already_set'; +} + sub checkout { my ($symb,$tuname,$tudom,$tcrsid)=@_; my $now=time; @@ -1702,7 +1839,7 @@ sub hash2str { sub hashref2str { my ($hashref)=@_; my $result='__HASH_REF__'; - foreach (keys(%$hashref)) { + foreach (sort(keys(%$hashref))) { if (ref($_) eq 'ARRAY') { $result.=&arrayref2str($_).'='; } elsif (ref($_) eq 'HASH') { @@ -1991,6 +2128,10 @@ sub store { } } if (!$home) { $home=$ENV{'user.home'}; } + + $$storehash{'ip'}=$ENV{'REMOTE_ADDR'}; + $$storehash{'host'}=$perlvar{'lonHostID'}; + my $namevalue=''; foreach (keys %$storehash) { $namevalue.=escape($_).'='.escape($$storehash{$_}).'&'; @@ -2024,6 +2165,9 @@ sub cstore { } if (!$home) { $home=$ENV{'user.home'}; } + $$storehash{'ip'}=$ENV{'REMOTE_ADDR'}; + $$storehash{'host'}=$perlvar{'lonHostID'}; + my $namevalue=''; foreach (keys %$storehash) { $namevalue.=escape($_).'='.escape($$storehash{$_}).'&'; @@ -2106,6 +2250,36 @@ sub coursedescription { return %returnhash; } +# -------------------------------------------------See if a user is privileged + +sub privileged { + my ($username,$domain)=@_; + my $rolesdump=&reply("dump:$domain:$username:roles", + &homeserver($username,$domain)); + if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return 0; } + my $now=time; + if ($rolesdump ne '') { + foreach (split(/&/,$rolesdump)) { + if ($_!~/^rolesdef\&/) { + my ($area,$role)=split(/=/,$_); + $area=~s/\_\w\w$//; + my ($trole,$tend,$tstart)=split(/_/,$role); + if (($trole eq 'dc') || ($trole eq 'su')) { + my $active=1; + if ($tend) { + if ($tend<$now) { $active=0; } + } + if ($tstart) { + if ($tstart>$now) { $active=0; } + } + if ($active) { return 1; } + } + } + } + } + return 0; +} + # -------------------------------------------------------- Get user privileges sub rolesinit { @@ -2358,6 +2532,30 @@ sub convert_dump_to_currentdump{ return \%returnhash; } +# --------------------------------------------------------------- inc interface + +sub inc { + my ($namespace,$store,$udomain,$uname) = @_; + if (!$udomain) { $udomain=$ENV{'user.domain'}; } + if (!$uname) { $uname=$ENV{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); + my $items=''; + if (! ref($store)) { + # got a single value, so use that instead + $items = &escape($store).'=&'; + } elsif (ref($store) eq 'SCALAR') { + $items = &escape($$store).'=&'; + } elsif (ref($store) eq 'ARRAY') { + $items = join('=&',map {&escape($_);} @{$store}); + } elsif (ref($store) eq 'HASH') { + while (my($key,$value) = each(%{$store})) { + $items.= &escape($key).'='.&escape($value).'&'; + } + } + $items=~s/\&$//; + return &reply("inc:$udomain:$uname:$namespace:$items",$uhome); +} + # --------------------------------------------------------------- put interface sub put { @@ -2449,7 +2647,7 @@ sub customaccess { sub allowed { my ($priv,$uri)=@_; - + $uri=&deversion($uri); my $orguri=$uri; $uri=&declutter($uri); @@ -2502,14 +2700,14 @@ sub allowed { # Course - if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'}=~/$priv\&([^\:]*)/) { + if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) { $thisallowed.=$1; } # Domain if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.(split(/\//,$uri))[0].'/'} - =~/$priv\&([^\:]*)/) { + =~/\Q$priv\E\&([^\:]*)/) { $thisallowed.=$1; } @@ -2519,16 +2717,21 @@ sub allowed { $courseuri=~s/^([^\/])/\/$1/; if ($ENV{'user.priv.'.$ENV{'request.role'}.'.'.$courseuri} - =~/$priv\&([^\:]*)/) { + =~/\Q$priv\E\&([^\:]*)/) { $thisallowed.=$1; } # URI is an uploaded document for this course - if (($priv eq 'bre') && - ($uri=~/^uploaded\/$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}\/$ENV{'course.'.$ENV{'request.course.id'}.'.num'}/)) { - return 'F'; + if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) { + my $refuri=$ENV{'httpref.'.$orguri}; + if ($refuri) { + if ($refuri =~ m|^/adm/|) { + $thisallowed='F'; + } + } } + # Full access at system, domain or course-wide level? Exit. if ($thisallowed=~/F/) { @@ -2537,7 +2740,7 @@ sub allowed { # If this is generating or modifying users, exit with special codes - if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:$priv\:/) { + if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:\Q$priv\E\:/) { return $thisallowed; } # @@ -2558,7 +2761,7 @@ sub allowed { if ($match) { $statecond=$cond; if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} - =~/$priv\&([^\:]*)/) { + =~/\Q$priv\E\&([^\:]*)/) { $thisallowed.=$1; $checkreferer=0; } @@ -2586,7 +2789,7 @@ sub allowed { if ($match) { my $refstatecond=$cond; if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} - =~/$priv\&([^\:]*)/) { + =~/\Q$priv\E\&([^\:]*)/) { $thisallowed.=$1; $uri=$refuri; $statecond=$refstatecond; @@ -2639,7 +2842,7 @@ sub allowed { if ((time-$ENV{$prefix.'last_cache'})>$expiretime) { &coursedescription($courseid); } - if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,$csec\,/) + if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,\Q$csec\E\,/) || ($ENV{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) { if ($ENV{$prefix.'res.'.$uri.'.lock.expire'}>time) { &log($ENV{'user.domain'},$ENV{'user.name'}, @@ -2650,7 +2853,7 @@ sub allowed { return ''; } } - if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,$csec\,/) + if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/) || ($ENV{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) { if ($ENV{'priv.'.$priv.'.lock.expire'}>time) { &log($ENV{'user.domain'},$ENV{'user.name'}, @@ -2684,7 +2887,7 @@ sub allowed { my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; my $unamedom=$ENV{'user.name'}.':'.$ENV{'user.domain'}; if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'} - =~/$rolecode/) { + =~/\Q$rolecode\E/) { &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. $ENV{'request.course.id'}); @@ -2692,7 +2895,7 @@ sub allowed { } if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.users.denied'} - =~/$unamedom/) { + =~/\Q$unamedom\E/) { &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '. $ENV{'request.course.id'}); @@ -2704,7 +2907,7 @@ sub allowed { if ($thisallowed=~/R/) { my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; - if (&metadata($uri,'roledeny')=~/$rolecode/) { + if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) { &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); return ''; @@ -2716,7 +2919,7 @@ sub allowed { if ($thisallowed=~/X/) { if ($ENV{'acc.randomout'}) { my $symb=&symbread($uri,1); - if (($symb) && ($ENV{'acc.randomout'}=~/\&$symb\&/)) { + if (($symb) && ($ENV{'acc.randomout'}=~/\&\Q$symb\E\&/)) { return ''; } } @@ -2780,27 +2983,27 @@ sub definerole { 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/) { + if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; } + if ($pr{'cr:s'}=~/\Q$crole\E\&/) { + if ($pr{'cr:s'}!~/\Q$crole\E\&\w*\Q$cqual\E/) { return "refused:s:$crole&$cqual"; } } } foreach (split(':',$domrole)) { my ($crole,$cqual)=split(/\&/,$_); - if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; } - if ($pr{'cr:d'}=~/$crole\&/) { - if ($pr{'cr:d'}!~/$crole\&\w*$cqual/) { + if ($pr{'cr:d'}!~/\Q$crole\E/) { return "refused:d:$crole"; } + if ($pr{'cr:d'}=~/\Q$crole\E\&/) { + if ($pr{'cr:d'}!~/\Q$crole\W\&\w*\Q$cqual\E/) { return "refused:d:$crole&$cqual"; } } } foreach (split(':',$courole)) { my ($crole,$cqual)=split(/\&/,$_); - if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; } - if ($pr{'cr:c'}=~/$crole\&/) { - if ($pr{'cr:c'}!~/$crole\&\w*$cqual/) { + if ($pr{'cr:c'}!~/\Q$crole\E/) { return "refused:c:$crole"; } + if ($pr{'cr:c'}=~/\Q$crole\E\&/) { + if ($pr{'cr:c'}!~/\Q$crole\E\&\w*\Q$cqual\E/) { return "refused:c:$crole&$cqual"; } } @@ -2847,10 +3050,63 @@ sub log_query { my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys %filters)); my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command, $uhome); - unless ($queryid=~/^$uhost\_/) { return 'error: '.$queryid; } + unless ($queryid=~/^\Q$uhost\E\_/) { return 'error: '.$queryid; } return get_query_reply($queryid); } +# ------- Request retrieval of institutional classlists for course(s) + +sub fetch_enrollment_query { + my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_; + my $homeserver; + if ($context eq 'automated') { + $homeserver = $perlvar{'lonHostID'}; + } else { + $homeserver = &homeserver($cnum,$dom); + } + my $host=$hostname{$homeserver}; + my $cmd = ''; + foreach (keys %{$affiliatesref}) { + $cmd .= $_.'='.join(",",@{$$affiliatesref{$_}}).'%%'; + } + $cmd =~ s/%%$//; + $cmd = &escape($cmd); + my $query = 'fetchenrollment'; + my $queryid=&reply("querysend:".$query.':'.$dom.':'.$ENV{'user.name'}.':'.$cmd,$homeserver); + unless ($queryid=~/^\Q$host\E\_/) { return 'error: '.$queryid; } + my $reply = &get_query_reply($queryid); + unless ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { + my @responses = split/:/,$reply; + if ($homeserver eq $perlvar{'lonHostID'}) { + foreach (@responses) { + my ($key,$value) = split/=/,$_; + $$replyref{$key} = $value; + } + } else { + my $pathname = $perlvar{'lonDaemons'}.'/tmp'; + foreach (@responses) { + my ($key,$value) = split/=/,$_; + $$replyref{$key} = $value; + if ($value > 0) { + foreach (@{$$affiliatesref{$key}}) { + my $filename = $dom.'_'.$key.'_'.$_.'_classlist.xml'; + my $destname = $pathname.'/'.$filename; + my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver); + unless ($xml_classlist =~ /^error/) { + if ( open(FILE,">$destname") ) { + print FILE &unescape($xml_classlist); + close(FILE); + } + } + } + } + } + } + return 'ok'; + } + return 'error'; +} + sub get_query_reply { my $queryid=shift; my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid; @@ -2858,9 +3114,9 @@ sub get_query_reply { for (1..100) { sleep 2; if (-e $replyfile.'.end') { - if (my $fh=Apache::File->new($replyfile)) { + if (open(my $fh,$replyfile)) { $reply.=<$fh>; - $fh->close; + close($fh); } else { return 'error: reply_file_error'; } return &unescape($reply); } @@ -2895,6 +3151,54 @@ sub userlog_query { return &log_query($uname,$udom,'userlog',%filters); } +#--------- Call auto-enrollment subs in localenroll.pm for homeserver for course + +sub auto_run { + my ($cnum,$cdom) = @_; + my $homeserver = &homeserver($cnum,$cdom); + my $response = &reply('autorun:'.$cdom,$homeserver); + return $response; +} + +sub auto_get_sections { + my ($cnum,$cdom,$inst_coursecode) = @_; + my $homeserver = &homeserver($cnum,$cdom); + my @secs = (); + my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver)); + unless ($response eq 'refused') { + @secs = split/:/,$response; + } + return @secs; +} + +sub auto_new_course { + my ($cnum,$cdom,$inst_course_id,$owner) = @_; + my $homeserver = &homeserver($cnum,$cdom); + my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver)); + return $response; +} + +sub auto_validate_courseID { + my ($cnum,$cdom,$inst_course_id) = @_; + my $homeserver = &homeserver($cnum,$cdom); + my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver)); + return $response; +} + +sub auto_create_password { + my ($cnum,$cdom,$authparam) = @_; + my $homeserver = &homeserver($cnum,$cdom); + my $create_passwd = 0; + my $authchk = ''; + my $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver)); + if ($response eq 'refused') { + $authchk = 'refused'; + } else { + ($authparam,$create_passwd,$authchk) = split/:/,$response; + } + return ($authparam,$create_passwd,$authchk); +} + # ------------------------------------------------------------------ Plain Text sub plaintext { @@ -3085,10 +3389,11 @@ sub modifyuser { 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'; + $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid)=@_; + if (!$cid) { + unless ($cid=$ENV{'request.course.id'}) { + return 'not_in_class'; + } } # --------------------------------------------------------------- Make the user my $reply=&modifyuser @@ -3098,24 +3403,33 @@ sub modifystudent { # 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); + $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last, + $gene,$usec,$end,$start,$type,$locktype,$cid); return $reply; } sub modify_student_enrollment { - my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start) = @_; - # Get the course id from the environment - my $cid=''; - unless ($cid=$ENV{'request.course.id'}) { - return 'not_in_class'; + my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid) = @_; + my ($cdom,$cnum,$chome); + if (!$cid) { + unless ($cid=$ENV{'request.course.id'}) { + return 'not_in_class'; + } + $cdom=$ENV{'course.'.$cid.'.domain'}; + $cnum=$ENV{'course.'.$cid.'.num'}; + } else { + ($cdom,$cnum)=split(/_/,$cid); + } + $chome=$ENV{'course.'.$cid.'.home'}; + if (!$chome) { + $chome=&homeserver($cnum,$cdom); } + if (!$chome) { return 'unknown_course'; } # Make sure the user exists my $uhome=&homeserver($uname,$udom); if (($uhome eq '') || ($uhome eq 'no_host')) { return 'error: no such user'; } - # # Get student data if we were not given enough information if (!defined($first) || $first eq '' || !defined($last) || $last eq '' || @@ -3128,9 +3442,9 @@ sub modify_student_enrollment { ['firstname','middlename','lastname', 'generation','id'] ,$udom,$uname); - foreach (keys(%tmp)) { - &logthis("key $_ = ".$tmp{$_}); - } + #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 ''); @@ -3139,11 +3453,10 @@ sub modify_student_enrollment { } 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'}); + my $reply=cput('classlist', + {"$uname:$udom" => + join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) }, + $cdom,$cnum); unless (($reply eq 'ok') || ($reply eq 'delayed')) { return 'error: '.$reply; } @@ -3266,6 +3579,39 @@ sub revokecustomrole { $deleteflag); } + +# ------------------------------------------------------------ Portfolio Director Lister +sub portfoliolist { +#FIXME us the ls: command instead please +#FIXME uhome should never be an argument to any lonnet functions + # returns listing of contents of user's /userfiles/portfolio/ directory + # + my ($udom,$uname,$uhome); + $uname=$ENV{'user.name'}; + $udom=$ENV{'user.domain'}; + $uhome=$ENV{'user.home'}; + my $listing = &reply('portls:'.$uname.':'.$udom, $uhome); + return $listing; +} + +sub portfoliomanage { + +#FIXME please user the existing remove userfile function instead and +#add a userfilerename functions. +#FIXME uhome should never be an argument to any lonnet functions + + # handles deleting and renaming files in user's userfiles/portfolio/ directory + # + my ($filename, $fileaction, $filenewname) = @_; + my ($udom, $uname, $uhome); + $uname=$ENV{'user.name'}; + $udom=$ENV{'user.domain'}; + $uhome=$ENV{'user.home'}; + my $listing = reply('portfoliomanage:'.$uname.':'.$udom.':'.$filename.':'.$fileaction.':'.$filenewname, $uhome); + return $listing; +} + + # ------------------------------------------------------------ Directory lister sub dirlist { @@ -3635,10 +3981,8 @@ sub EXT { my $hashid="$udom:$uname"; my ($result,$cached)=&is_cached(\%userresdatacache,$hashid, 'userres'); - if (!defined($cached)) { - my %resourcedata=&get('resourcedata', - [$courselevelr,$courselevelm, - $courselevel],$udom,$uname); + if (!defined($cached)) { + my %resourcedata=&dump('resourcedata',$udom,$uname); $result=\%resourcedata; &do_cache(\%userresdatacache,$hashid,$result,'userres'); } @@ -3651,12 +3995,13 @@ sub EXT { if ($$result{$courselevel}) { return $$result{$courselevel}; } } else { - if ($tmp!~/No such file/) { + #error 2 occurs when the .db doesn't exist + if ($tmp!~/error: 2 /) { &logthis("WARNING:". " Trying to get resource data for ". $uname." at ".$udom.": ". $tmp.""); - } elsif ($tmp=~/error:No such file/) { + } elsif ($tmp=~/error: 2 /) { &EXT_cache_set($udom,$uname); } elsif ($tmp =~ /^(con_lost|no_such_host)/) { return $tmp; @@ -3738,9 +4083,12 @@ sub packages_tab_default { my $packages=&metadata($uri,'packages'); foreach my $package (split(/,/,$packages)) { my ($pack_type,$pack_part)=split(/_/,$package,2); - if ($pack_part eq $part) { + if (defined($packagetab{"$pack_type&$name&default"})) { return $packagetab{"$pack_type&$name&default"}; } + if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) { + return $packagetab{$pack_type."_".$pack_part."&$name&default"}; + } } return undef; } @@ -3770,7 +4118,7 @@ sub metadata { if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) || ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) || ($uri =~ m|home/[^/]+/public_html/|)) { - return ''; + return undef; } my $filename=$uri; $uri=~s/\.meta$//; @@ -3787,7 +4135,9 @@ sub metadata { # # Is this a recursive call for a library? # - my %lcmetacache; + if (! exists($metacache{$uri})) { + $metacache{$uri}={}; + } if ($liburi) { $liburi=&declutter($liburi); $filename=$liburi; @@ -3796,7 +4146,10 @@ sub metadata { } my %metathesekeys=(); unless ($filename=~/\.meta$/) { $filename.='.meta'; } - my $metastring=&getfile(&filelocation('',&clutter($filename))); + my $metastring; + if ($uri !~ m|^uploaded/|) { + $metastring=&getfile(&filelocation('',&clutter($filename))); + } my $parser=HTML::LCParser->new(\$metastring); my $token; undef %metathesekeys; @@ -3811,10 +4164,10 @@ sub metadata { if (defined($token->[2]->{'id'})) { $keyroot.='_'.$token->[2]->{'id'}; } - if ($lcmetacache{':packages'}) { - $lcmetacache{':packages'}.=','.$package.$keyroot; + if ($metacache{$uri}->{':packages'}) { + $metacache{$uri}->{':packages'}.=','.$package.$keyroot; } else { - $lcmetacache{':packages'}=$package.$keyroot; + $metacache{$uri}->{':packages'}=$package.$keyroot; } foreach (keys %packagetab) { my $part=$keyroot; @@ -3836,14 +4189,14 @@ sub metadata { if ($subp eq 'display') { $value.=' [Part: '.$part.']'; } - $lcmetacache{':'.$unikey.'.part'}=$part; + $metacache{$uri}->{':'.$unikey.'.part'}=$part; $metathesekeys{$unikey}=1; - unless (defined($lcmetacache{':'.$unikey.'.'.$subp})) { - $lcmetacache{':'.$unikey.'.'.$subp}=$value; + unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) { + $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value; } - if (defined($lcmetacache{':'.$unikey.'.default'})) { - $lcmetacache{':'.$unikey}= - $lcmetacache{':'.$unikey.'.default'}; + if (defined($metacache{$uri}->{':'.$unikey.'.default'})) { + $metacache{$uri}->{':'.$unikey}= + $metacache{$uri}->{':'.$unikey.'.default'}; } } } @@ -3876,6 +4229,7 @@ sub metadata { foreach (sort(split(/\,/,&metadata($uri,'keys', $location,$unikey, $depthcount+1)))) { + $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_}; $metathesekeys{$_}=1; } } @@ -3886,18 +4240,18 @@ sub metadata { } $metathesekeys{$unikey}=1; foreach (@{$token->[3]}) { - $lcmetacache{':'.$unikey.'.'.$_}=$token->[2]->{$_}; + $metacache{$uri}->{':'.$unikey.'.'.$_}=$token->[2]->{$_}; } my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry)); - my $default=$lcmetacache{':'.$unikey.'.default'}; + my $default=$metacache{$uri}->{':'.$unikey.'.default'}; if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) { # only ws inside the tag, and not in default, so use default # as value - $lcmetacache{':'.$unikey}=$default; + $metacache{$uri}->{':'.$unikey}=$default; } else { # either something interesting inside the tag or default # uninteresting - $lcmetacache{':'.$unikey}=$internaltext; + $metacache{$uri}->{':'.$unikey}=$internaltext; } # end of not-a-package not-a-library import } @@ -3906,33 +4260,74 @@ sub metadata { # the next is the end of "start tag" } } + my ($extension) = ($uri =~ /\.(\w+)$/); + foreach my $key (sort(keys(%packagetab))) { + #&logthis("extsion1 $extension $key !!"); + #no specific packages #how's our extension + if ($key!~/^extension_\Q$extension\E&/) { next; } + &metadata_create_package_def($uri,$key,'extension_'.$extension, + \%metathesekeys); + } + if (!exists($metacache{$uri}->{':packages'})) { + foreach my $key (sort(keys(%packagetab))) { + #no specific packages well let's get default then + if ($key!~/^default&/) { next; } + &metadata_create_package_def($uri,$key,'default', + \%metathesekeys); + } + } # are there custom rights to evaluate - if ($lcmetacache{':copyright'} eq 'custom') { + if ($metacache{$uri}->{':copyright'} eq 'custom') { # # Importing a rights file here # unless ($depthcount) { - my $location=$lcmetacache{':customdistributionfile'}; + my $location=$metacache{$uri}->{':customdistributionfile'}; my $dir=$filename; $dir=~s|[^/]*$||; $location=&filelocation($dir,$location); foreach (sort(split(/\,/,&metadata($uri,'keys', $location,'_rights', $depthcount+1)))) { + $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_}; $metathesekeys{$_}=1; } } } - $lcmetacache{':keys'}=join(',',keys %metathesekeys); - &metadata_generate_part0(\%metathesekeys,\%lcmetacache,$uri); - $lcmetacache{':allpossiblekeys'}=join(',',keys %metathesekeys); - &do_cache(\%metacache,$uri,\%lcmetacache,'meta'); + $metacache{$uri}->{':keys'}=join(',',keys %metathesekeys); + &metadata_generate_part0(\%metathesekeys,$metacache{$uri},$uri); + $metacache{$uri}->{':allpossiblekeys'}=join(',',keys %metathesekeys); + &do_cache(\%metacache,$uri,$metacache{$uri},'meta'); # this is the end of "was not already recently cached } return $metacache{$uri}->{':'.$what}; } +sub metadata_create_package_def { + my ($uri,$key,$package,$metathesekeys)=@_; + my ($pack,$name,$subp)=split(/\&/,$key); + if ($subp eq 'default') { next; } + + if (defined($metacache{$uri}->{':packages'})) { + $metacache{$uri}->{':packages'}.=','.$package; + } else { + $metacache{$uri}->{':packages'}=$package; + } + my $value=$packagetab{$key}; + my $unikey; + $unikey='parameter_0_'.$name; + $metacache{$uri}->{':'.$unikey.'.part'}=0; + $$metathesekeys{$unikey}=1; + unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) { + $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value; + } + if (defined($metacache{$uri}->{':'.$unikey.'.default'})) { + $metacache{$uri}->{':'.$unikey}= + $metacache{$uri}->{':'.$unikey.'.default'}; + } +} + sub metadata_generate_part0 { my ($metadata,$metacache,$uri) = @_; my %allnames; @@ -3956,7 +4351,7 @@ sub metadata_generate_part0 { my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name. '.display'}; my $expr='\\[Part: '.$allnames{$name}.'\\]'; - $olddis=~s/$expr/\[Part: 0\]/; + $olddis=~s/\Q$expr\E/\[Part: 0\]/; $$metacache{"$key.display"}=$olddis; } } @@ -3993,13 +4388,13 @@ sub gettitle { sub symblist { my ($mapname,%newhash)=@_; - $mapname=declutter($mapname); + $mapname=&deversion(&declutter($mapname)); my %hash; if (($ENV{'request.course.fn'}) && (%newhash)) { if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', &GDBM_WRCREAT(),0640)) { foreach (keys %newhash) { - $hash{declutter($_)}=$mapname.'___'.$newhash{$_}; + $hash{declutter($_)}=$mapname.'___'.&deversion($newhash{$_}); } if (untie(%hash)) { return 'ok'; @@ -4012,24 +4407,30 @@ sub symblist { # --------------------------------------------------------------- Verify a symb sub symbverify { - my ($symb,$thisfn)=@_; - $thisfn=&symbclean(&declutter($thisfn)); + my ($symb,$thisurl)=@_; + my $thisfn=$thisurl; +# wrapper not part of symbs + $thisfn=~s/^\/adm\/wrapper//; + $thisfn=&declutter($thisfn); # direct jump to resource in page or to a sequence - will construct own symbs if ($thisfn=~/\.(page|sequence)$/) { return 1; } # check URL part my ($map,$resid,$url)=&decode_symb($symb); + unless ($url eq $thisfn) { return 0; } $symb=&symbclean($symb); + $thisurl=&deversion($thisurl); + $thisfn=&deversion($thisfn); my %bighash; my $okay=0; if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', &GDBM_READER(),0640)) { - my $ids=$bighash{'ids_'.&clutter($thisfn)}; + my $ids=$bighash{'ids_'.&clutter($thisurl)}; unless ($ids) { - $ids=$bighash{'ids_/'.$thisfn}; + $ids=$bighash{'ids_/'.$thisurl}; } if ($ids) { # ------------------------------------------------------------------- Has ID(s) @@ -4058,6 +4459,9 @@ sub symbclean { # remove version from URL $symb=~s/\.(\d+)\.(\w+)$/\.$2/; +# remove wrapper + + $symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/; return $symb; } @@ -4078,17 +4482,31 @@ sub fixversion { 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') { - $uri=~s/\.(\w+)$/\.$version\.$1/; - } - } - untie %bighash; - } - return &declutter($uri); + &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 @@ -4109,9 +4527,13 @@ sub symbread { my %bighash; my $syval=''; if (($ENV{'request.course.fn'}) && ($thisfn)) { + my $targetfn = $thisfn; + if ( ($thisfn =~ m/^uploaded\//) && ($thisfn !~ m/\.(page|sequence)$/) ) { + $targetfn = 'adm/wrapper/'.$thisfn; + } if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', &GDBM_READER(),0640)) { - $syval=$hash{$thisfn}; + $syval=$hash{$targetfn}; untie(%hash); } # ---------------------------------------------------------- There was an entry @@ -4163,7 +4585,7 @@ sub symbread { } } untie(%bighash) - } + } } if ($syval) { return &symbclean($syval.'___'.$thisfn); @@ -4187,8 +4609,41 @@ sub numval { return int($txt); } +sub numval2 { + my $txt=shift; + $txt=~tr/A-J/0-9/; + $txt=~tr/a-j/0-9/; + $txt=~tr/K-T/0-9/; + $txt=~tr/k-t/0-9/; + $txt=~tr/U-Z/0-5/; + $txt=~tr/u-z/0-5/; + $txt=~s/\D//g; + my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt); + my $total; + foreach my $val (@txts) { $total+=$val; } + return int($total); +} + sub latest_rnd_algorithm_id { - return '64bit'; + return '64bit3'; +} + +sub get_rand_alg { + my ($courseid)=@_; + if (!$courseid) { $courseid=(&Apache::lonxml::whichuser())[1]; } + if ($courseid) { + return $ENV{"course.$courseid.rndseed"}; + } + return &latest_rnd_algorithm_id(); +} + +sub getCODE { + if (defined($ENV{'form.CODE'})) { return $ENV{'form.CODE'}; } + if (defined($Apache::lonhomework::parsing_a_problem) && + defined($Apache::lonhomework::history{'resource.CODE'})) { + return $Apache::lonhomework::history{'resource.CODE'}; + } + return undef; } sub rndseed { @@ -4201,10 +4656,13 @@ sub rndseed { 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); + my $which=&get_rand_alg(); + if (defined(&getCODE())) { + return &rndseed_CODE_64bit($symb,$courseid,$domain,$username); + } elsif ($which eq '64bit3') { + return &rndseed_64bit3($symb,$courseid,$domain,$username); + } elsif ($which eq '64bit2') { + return &rndseed_64bit2($symb,$courseid,$domain,$username); } elsif ($which eq '64bit') { return &rndseed_64bit($symb,$courseid,$domain,$username); } @@ -4248,74 +4706,237 @@ sub rndseed_64bit { } } +sub rndseed_64bit2 { + my ($symb,$courseid,$domain,$username)=@_; + { + use integer; + # strings need to be an even # of cahracters long, it it is odd the + # last characters gets thrown away + my $symbchck=unpack("%32S*",$symb.' ') << 21; + my $symbseed=numval($symb) << 10; + my $namechck=unpack("%32S*",$username.' '); + + my $nameseed=numval($username) << 21; + my $domainseed=unpack("%32S*",$domain.' ') << 10; + my $courseseed=unpack("%32S*",$courseid.' '); + + my $num1=$symbchck+$symbseed+$namechck; + my $num2=$nameseed+$domainseed+$courseseed; + #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); + #&Apache::lonxml::debug("rndseed :$num:$symb"); + return "$num1,$num2"; + } +} + +sub rndseed_64bit3 { + my ($symb,$courseid,$domain,$username)=@_; + { + use integer; + # strings need to be an even # of cahracters long, it it is odd the + # last characters gets thrown away + my $symbchck=unpack("%32S*",$symb.' ') << 21; + my $symbseed=numval2($symb) << 10; + my $namechck=unpack("%32S*",$username.' '); + + my $nameseed=numval2($username) << 21; + my $domainseed=unpack("%32S*",$domain.' ') << 10; + my $courseseed=unpack("%32S*",$courseid.' '); + + my $num1=$symbchck+$symbseed+$namechck; + my $num2=$nameseed+$domainseed+$courseseed; + #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); + #&Apache::lonxml::debug("rndseed :$num:$symb"); + return "$num1:$num2"; + } +} + 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"); + my $symbchck=unpack("%32S*",$symb.' ') << 16; + my $symbseed=numval2($symb); + my $CODEchck=unpack("%32S*",&getCODE().' ') << 16; + my $CODEseed=numval(&getCODE()); + my $courseseed=unpack("%32S*",$courseid.' '); + my $num1=$symbseed+$CODEchck; + my $num2=$CODEseed+$courseseed+$symbchck; + #&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck"); #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb"); - return "$num1,$num2"; + return "$num1:$num2"; } } sub setup_random_from_rndseed { my ($rndseed)=@_; - if ($rndseed =~/,/) { - my ($num1,$num2)=split(/,/,$rndseed); + if ($rndseed =~/([,:])/) { + my ($num1,$num2)=split(/[,:]/,$rndseed); &Math::Random::random_set_seed(abs($num1),abs($num2)); } else { &Math::Random::random_set_seed_from_phrase($rndseed); } } +sub latest_receipt_algorithm_id { + return 'receipt2'; +} + +sub recunique { + my $fucourseid=shift; + my $unique; + if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2') { + $unique=$ENV{"course.$fucourseid.internal.encseed"}; + } else { + $unique=$perlvar{'lonReceipt'}; + } + return unpack("%32C*",$unique); +} + +sub recprefix { + my $fucourseid=shift; + my $prefix; + if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2') { + $prefix=$ENV{"course.$fucourseid.internal.encpref"}; + } else { + $prefix=$perlvar{'lonHostID'}; + } + return unpack("%32C*",$prefix); +} + sub ireceipt { - my ($funame,$fudom,$fucourseid,$fusymb)=@_; + my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_; my $cuname=unpack("%32C*",$funame); my $cudom=unpack("%32C*",$fudom); my $cucourseid=unpack("%32C*",$fucourseid); my $cusymb=unpack("%32C*",$fusymb); - my $cunique=unpack("%32C*",$perlvar{'lonReceipt'}); - return unpack("%32C*",$perlvar{'lonHostID'}).'-'. - ($cunique%$cuname+ - $cunique%$cudom+ - $cusymb%$cuname+ - $cusymb%$cudom+ - $cucourseid%$cuname+ - $cucourseid%$cudom); + my $cunique=&recunique($fucourseid); + my $cpart=unpack("%32S*",$part); + my $return =&recprefix($fucourseid).'-'; + if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2' || + $ENV{'request.state'} eq 'construct') { + &Apache::lonxml::debug("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname). + " and ".($cpart%$cudom)); + + $return.= ($cunique%$cuname+ + $cunique%$cudom+ + $cusymb%$cuname+ + $cusymb%$cudom+ + $cucourseid%$cuname+ + $cucourseid%$cudom+ + $cpart%$cuname+ + $cpart%$cudom); + } else { + $return.= ($cunique%$cuname+ + $cunique%$cudom+ + $cusymb%$cuname+ + $cusymb%$cudom+ + $cucourseid%$cuname+ + $cucourseid%$cudom); + } + return $return; } sub receipt { - my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser(); - return &ireceipt($name,$domain,$courseid,$symb); + my ($part)=@_; + my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser(); + return &ireceipt($name,$domain,$courseid,$symb,$part); } # ------------------------------------------------------------ Serves up a file -# returns either the contents of the file or a -1 +# returns either the contents of the file or +# -1 if the file doesn't exist +# +# if the target is a file that was uploaded via DOCS, +# a check will be made to see if a current copy exists on the local server, +# if it does this will be served, otherwise a copy will be retrieved from +# the home server for the course and stored in /home/httpd/html/userfiles on +# the local server. + sub getfile { - my $file=shift; - if ($file=~/^\/*uploaded\//) { # user file + my ($file,$caller) = @_; + + if ($file !~ m|^/*uploaded/(\w+)/(\w+)/(.+)$|) { + # normal file from res space + &repcopy($file); + return &readfile($file); + } + + my $info; + my $cdom = $1; + my $cnum = $2; + my $filename = $3; + my $path = $Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles'; + my ($lwpresp,$rtncode); + my $localfile = $path.'/'.$cdom.'/'.$cnum.'/'.$filename; + if (-e "$localfile") { + my @fileinfo = stat($localfile); + $lwpresp = &getuploaded('HEAD',$file,$cdom,$cnum,\$info,\$rtncode); + if ($lwpresp ne 'ok') { + if ($rtncode eq '404') { + unlink($localfile); + } + return -1; + } + if ($info < $fileinfo[9]) { + return &readfile($localfile); + } + $info = ''; + $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode); + if ($lwpresp ne 'ok') { + return -1; + } + } else { + $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode); + if ($lwpresp ne 'ok') { + return -1; + } + my @parts = ($cdom,$cnum); + if ($filename =~ m|^(.+)/[^/]+$|) { + push @parts, split(/\//,$1); + } + foreach my $part (@parts) { + $path .= '/'.$part; + if (!-e $path) { + mkdir($path,0770); + } + } + } + open (FILE,">$localfile"); + print FILE $info; + close(FILE); + if ($caller eq 'uploadrep') { + return 'ok'; + } + return $info; +} + +sub getuploaded { + my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_; + $uri=~s/^\///; + $uri = 'http://'.$hostname{ &homeserver($cnum,$cdom)}.'/raw/'.$uri; my $ua=new LWP::UserAgent; - my $request=new HTTP::Request('GET',&tokenwrapper($file)); + my $request=new HTTP::Request($reqtype,$uri); 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; - } + $$rtncode = $response->code; + if (! $response->is_success()) { + return 'failed'; + } + if ($reqtype eq 'HEAD') { + $$info = &HTTP::Date::str2time( $response->header('Last-modified') ); + } elsif ($reqtype eq 'GET') { + $$info = $response->content; + } + return 'ok'; +} + +sub readfile { + my $file = shift; + if ( (! -e $file ) || ($file eq '') ) { return -1; }; + my $fh; + open($fh,"<$file"); + my $a=''; + while (<$fh>) { $a .=$_; } + return $a; } sub filelocation { @@ -4328,8 +4949,8 @@ sub filelocation { } elsif ($file=~/^\/*uploaded/) { # is an uploaded file $location=$file; } else { - $file=~s/^$perlvar{'lonDocRoot'}//; - $file=~s:^/*res::; + $file=~s/^\Q$perlvar{'lonDocRoot'}\E//; + $file=~s:^/res/:/:; if ( !( $file =~ m:^/:) ) { $location = $dir. '/'.$file; } else { @@ -4338,26 +4959,54 @@ sub filelocation { } $location=~s://+:/:g; # remove duplicate / while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/.. + while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./ return $location; } sub hreflocation { my ($dir,$file)=@_; - unless (($file=~/^http:\/\//i) || ($file=~/^\//)) { - my $finalpath=filelocation($dir,$file); - $finalpath=~s/^\/home\/httpd\/html//; - $finalpath=~s-/home/(\w+)/public_html/-/~$1/-; - return $finalpath; - } else { - return $file; + unless (($file=~m-^http://-i) || ($file=~m-^/-)) { + my $finalpath=filelocation($dir,$file); + $finalpath=~s-^/home/httpd/html--; + $finalpath=~s-^/home/(\w+)/public_html/-/~$1/-; + return $finalpath; + } elsif ($file=~m-^/home-) { + $file=~s-^/home/httpd/html--; + $file=~s-^/home/(\w+)/public_html/-/~$1/-; + return $file; + } + return $file; +} + +sub current_machine_domains { + my $hostname=$hostname{$perlvar{'lonHostID'}}; + my @domains; + while( my($id, $name) = each(%hostname)) { +# &logthis("-$id-$name-$hostname-"); + if ($hostname eq $name) { + push(@domains,$hostdom{$id}); + } + } + return @domains; +} + +sub current_machine_ids { + my $hostname=$hostname{$perlvar{'lonHostID'}}; + my @ids; + while( my($id, $name) = each(%hostname)) { +# &logthis("-$id-$name-$hostname-"); + if ($hostname eq $name) { + push(@ids,$id); + } } + return @ids; } # ------------------------------------------------------------- Declutters URLs sub declutter { my $thisfn=shift; - $thisfn=~s/^$perlvar{'lonDocRoot'}//; + $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//; $thisfn=~s/^\///; $thisfn=~s/^res\///; $thisfn=~s/\?.+$//; @@ -4368,7 +5017,7 @@ sub declutter { sub clutter { my $thisfn='/'.&declutter(shift); - unless ($thisfn=~/^\/(uploaded|adm|userfiles|ext|raw|priv)\//) { + unless ($thisfn=~/^\/(uploaded|adm|userfiles|ext|raw|priv|public)\//) { $thisfn='/res'.$thisfn; } return $thisfn; @@ -4399,7 +5048,6 @@ sub mod_perl_version { sub correct_line_ends { my ($result)=@_; - &logthis("Wha $result"); $$result =~s/\r\n/\n/mg; $$result =~s/\r/\n/mg; } @@ -4407,16 +5055,18 @@ sub correct_line_ends { sub goodbye { &logthis("Starting Shut down"); -#not converted to using infrastruture - &logthis(sprintf("%-20s is %s",'%homecache',scalar(%homecache))); +#not converted to using infrastruture and probably shouldn't be &logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache))); - &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache))); #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; @@ -4426,18 +5076,19 @@ BEGIN { # ----------------------------------- Read loncapa.conf and loncapa_apache.conf unless ($readit) { { - my $config=Apache::File->new("/etc/httpd/conf/loncapa.conf"); + open(my $config,") { - if ($configline =~ /^[^\#]*PerlSetVar/) { + if ($configline=~/\S/ && $configline =~ /^[^\#]*PerlSetVar/) { my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); chomp($varvalue); $perlvar{$varname}=$varvalue; } } + close($config); } { - my $config=Apache::File->new("/etc/httpd/conf/loncapa_apache.conf"); + open(my $config,") { if ($configline =~ /^[^\#]*PerlSetVar/) { @@ -4446,16 +5097,16 @@ BEGIN { $perlvar{$varname}=$varvalue; } } + close($config); } # ------------------------------------------------------------ Read domain file { - my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. - '/domain.tab'); %domaindescription = (); %domain_auth_def = (); %domain_auth_arg_def = (); - if ($fh) { + my $fh; + if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) { while (<$fh>) { next if (/^(\#|\s*$)/); # next if /^\#/; @@ -4470,16 +5121,17 @@ BEGIN { $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, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}"); # &logthis("Domain.tab: $domain ".$domaindescription{$domain} ); - } + } } + close ($fh); } # ------------------------------------------------------------- Read hosts file { - my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab"); + open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); while (my $configline=<$config>) { next if ($configline =~ /^(\#|\s*$)/); @@ -4497,11 +5149,12 @@ BEGIN { } } } + close($config); } # ------------------------------------------------------ Read spare server file { - my $config=Apache::File->new("$perlvar{'lonTabDir'}/spare.tab"); + open(my $config,"<$perlvar{'lonTabDir'}/spare.tab"); while (my $configline=<$config>) { chomp($configline); @@ -4509,46 +5162,51 @@ BEGIN { $spareid{$configline}=1; } } + close($config); } # ------------------------------------------------------------ Read permissions { - my $config=Apache::File->new("$perlvar{'lonTabDir'}/roles.tab"); + open(my $config,"<$perlvar{'lonTabDir'}/roles.tab"); while (my $configline=<$config>) { - chomp($configline); - if ($configline) { - my ($role,$perm)=split(/ /,$configline); - if ($perm ne '') { $pr{$role}=$perm; } - } + chomp($configline); + if ($configline) { + my ($role,$perm)=split(/ /,$configline); + if ($perm ne '') { $pr{$role}=$perm; } + } } + close($config); } # -------------------------------------------- Read plain texts for permissions { - my $config=Apache::File->new("$perlvar{'lonTabDir'}/rolesplain.tab"); + open(my $config,"<$perlvar{'lonTabDir'}/rolesplain.tab"); while (my $configline=<$config>) { - chomp($configline); - if ($configline) { - my ($short,$plain)=split(/:/,$configline); - if ($plain ne '') { $prp{$short}=$plain; } - } + chomp($configline); + if ($configline) { + my ($short,$plain)=split(/:/,$configline); + if ($plain ne '') { $prp{$short}=$plain; } + } } + close($config); } # ---------------------------------------------------------- Read package table { - my $config=Apache::File->new("$perlvar{'lonTabDir'}/packages.tab"); + open(my $config,"<$perlvar{'lonTabDir'}/packages.tab"); while (my $configline=<$config>) { - chomp($configline); - my ($short,$plain)=split(/:/,$configline); - my ($pack,$name)=split(/\&/,$short); - if ($plain ne '') { - $packagetab{$pack.'&'.$name.'&name'}=$name; - $packagetab{$short}=$plain; - } + if ($configline !~ /\S/ || $configline=~/^#/) { next; } + chomp($configline); + my ($short,$plain)=split(/:/,$configline); + my ($pack,$name)=split(/\&/,$short); + if ($plain ne '') { + $packagetab{$pack.'&'.$name.'&name'}=$name; + $packagetab{$short}=$plain; + } } + close($config); } # ------------- set up temporary directory @@ -5167,6 +5825,14 @@ dumps the complete (or key matching rege =item * +inc($namespace,$store,$udom,$uname) : increments $store in $namespace. +$store can be a scalar, an array reference, or if the amount to be +incremented is > 1, a hash reference. + +($udom and $uname are optional) + +=item * + put($namespace,$storehash,$udom,$uname) : stores hash in namesp ($udom and $uname are optional) @@ -5277,8 +5943,29 @@ messages of critical importance should g =item * -getfile($file) : returns the entire contents of a file or -1; it -properly subscribes to and replicates the file if neccessary. +getfile($file,$caller) : two cases - requests for files in /res or in /uploaded. +(a) files in /uploaded + (i) If a local copy of the file exists - + compares modification date of local copy with last-modified date for + definitive version stored on home server for course. If local copy is + stale, requests a new version from the home server and stores it. + If the original has been removed from the home server, then local copy + is unlinked. + (ii) If local copy does not exist - + requests the file from the home server and stores it. + + If $caller is 'uploadrep': + This indicates a call from lonuploadrep.pm (PerlHeaderParserHandler phase) + for request for files originally uploaded via DOCS. + - returns 'ok' if fresh local copy now available, -1 otherwise. + + Otherwise: + This indicates a call from the content generation phase of the request. + - returns the entire contents of the file or -1. + +(b) files in /res + - returns the entire contents of a file or -1; + it properly subscribes to and replicates the file if neccessary. =item *