--- loncom/lonnet/perl/lonnet.pm 2003/12/08 13:50:57 1.457 +++ loncom/lonnet/perl/lonnet.pm 2005/04/15 20:46:04 1.623 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.457 2003/12/08 13:50:57 raeburn Exp $ +# $Id: lonnet.pm,v 1.623 2005/04/15 20:46:04 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -32,24 +32,33 @@ package Apache::lonnet; use strict; 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 %courseresversioncache %resversioncache +qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom + %libserv %pr %prp $memcache %packagetab %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); + %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf + %domaindescription %domain_auth_def %domain_auth_arg_def + %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit + %env); 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(); +use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze); +use Time::HiRes qw( gettimeofday tv_interval ); +use Cache::Memcached; my $readit; +my $max_connection_retries = 10; # Or some such value. + +require Exporter; + +our @ISA = qw (Exporter); +our @EXPORT = qw(%env); =pod @@ -114,14 +123,40 @@ sub logperm { sub subreply { my ($cmd,$server)=@_; my $peerfile="$perlvar{'lonSockDir'}/$server"; - my $client=IO::Socket::UNIX->new(Peer =>"$peerfile", - Type => SOCK_STREAM, - Timeout => 10) - or return "con_lost"; - print $client "$cmd\n"; - my $answer=<$client>; - if (!$answer) { $answer="con_lost"; } - chomp($answer); + # + # With loncnew process trimming, there's a timing hole between lonc server + # process exit and the master server picking up the listen on the AF_UNIX + # socket. In that time interval, a lock file will exist: + + my $lockfile=$peerfile.".lock"; + while (-e $lockfile) { # Need to wait for the lockfile to disappear. + sleep(1); + } + # At this point, either a loncnew parent is listening or an old lonc + # or loncnew child is listening so we can connect or everything's dead. + # + # We'll give the connection a few tries before abandoning it. If + # connection is not possible, we'll con_lost back to the client. + # + my $client; + for (my $retries = 0; $retries < $max_connection_retries; $retries++) { + $client=IO::Socket::UNIX->new(Peer =>"$peerfile", + Type => SOCK_STREAM, + Timeout => 10); + if($client) { + last; # Connected! + } + sleep(1); # Try again later if failed connection. + } + my $answer; + if ($client) { + print $client "$cmd\n"; + $answer=<$client>; + if (!$answer) { $answer="con_lost"; } + chomp($answer); + } else { + $answer = 'con_lost'; # Failed connection. + } return $answer; } @@ -129,22 +164,6 @@ sub reply { my ($cmd,$server)=@_; unless (defined($hostname{$server})) { return 'no_such_host'; } my $answer=subreply($cmd,$server); - if ($answer eq 'con_lost') { - #sleep 5; - #$answer=subreply($cmd,$server); - #if ($answer eq 'con_lost') { - # &logthis("Second attempt con_lost on $server"); - # my $peerfile="$perlvar{'lonSockDir'}/$server"; - # my $client=IO::Socket::UNIX->new(Peer =>"$peerfile", - # Type => SOCK_STREAM, - # Timeout => 10) - # or return "con_lost"; - # &logthis("Killing socket"); - # print $client "close_connection_exit\n"; - #sleep 5; - # $answer=subreply($cmd,$server); - #} - } if (($answer=~/^refused/) || ($answer=~/^rejected/)) { &logthis("WARNING:". " $cmd to $server returned $answer"); @@ -192,11 +211,8 @@ sub critical { } my $answer=reply($cmd,$server); if ($answer eq 'con_lost') { - my $pingreply=reply('ping',$server); &reconlonc("$perlvar{'lonSockDir'}/$server"); - my $pongreply=reply('pong',$server); - &logthis("Ping/Pong for $server: $pingreply/$pongreply"); - $answer=reply($cmd,$server); + my $answer=reply($cmd,$server); if ($answer eq 'con_lost') { my $now=time; my $middlename=$cmd; @@ -238,20 +254,6 @@ 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 { @@ -268,14 +270,14 @@ sub transfer_profile_to_env { for ($envi=0;$envi<=$#profile;$envi++) { chomp($profile[$envi]); my ($envname,$envvalue)=split(/=/,$profile[$envi]); - $ENV{$envname} = $envvalue; + $env{$envname} = $envvalue; if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) { if ($time < time-300) { $Remove{$key}++; } } } - $ENV{'user.environment'} = "$lonidsdir/$handle.id"; + $env{'user.environment'} = "$lonidsdir/$handle.id"; foreach my $expired_key (keys(%Remove)) { &delenv($expired_key); } @@ -292,12 +294,12 @@ sub appenv { .''); delete($newenv{$_}); } else { - $ENV{$_}=$newenv{$_}; + $env{$_}=$newenv{$_}; } } my $lockfh; - unless (open($lockfh,"$ENV{'user.environment'}")) { + unless (open($lockfh,"$env{'user.environment'}")) { return 'error: '.$!; } unless (flock($lockfh,LOCK_EX)) { @@ -310,7 +312,7 @@ sub appenv { my @oldenv; { my $fh; - unless (open($fh,"$ENV{'user.environment'}")) { + unless (open($fh,"$env{'user.environment'}")) { return 'error: '.$!; } @oldenv=<$fh>; @@ -327,7 +329,7 @@ sub appenv { } { my $fh; - unless (open($fh,">$ENV{'user.environment'}")) { + unless (open($fh,">$env{'user.environment'}")) { return 'error'; } my $newname; @@ -353,7 +355,7 @@ sub delenv { my @oldenv; { my $fh; - unless (open($fh,"$ENV{'user.environment'}")) { + unless (open($fh,"$env{'user.environment'}")) { return 'error'; } unless (flock($fh,LOCK_SH)) { @@ -367,7 +369,7 @@ sub delenv { } { my $fh; - unless (open($fh,">$ENV{'user.environment'}")) { + unless (open($fh,">$env{'user.environment'}")) { return 'error'; } unless (flock($fh,LOCK_EX)) { @@ -377,7 +379,12 @@ sub delenv { return 'error: '.$!; } foreach (@oldenv) { - unless ($_=~/^$delthis/) { print $fh $_; } + if ($_=~/^$delthis/) { + my ($key,undef) = split('=',$_); + delete($env{$key}); + } else { + print $fh $_; + } } close($fh); } @@ -524,49 +531,32 @@ 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 $uhome=&homeserver($uname,$udom); + if (!$uhome) { + &logthis("User $uname at $udom is unknown in authenticate"); + 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 $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome); + if ($answer eq 'authorized') { + &logthis("User $uname at $udom authorized by $uhome"); + return $uhome; + } + if ($answer eq 'non_authorized') { + &logthis("User $uname at $udom rejected by $uhome"); + return 'no_host'; } - &logthis("User $uname at $udom could not be authenticated"); + &logthis("User $uname at $udom threw error $answer when checking authentication mechanism"); return 'no_host'; } # ---------------------- Find the homebase for a user from domain's lib servers +my %homecache; sub homeserver { my ($uname,$udom,$ignoreBadCache)=@_; my $index="$uname:$udom"; - my ($result,$cached)=&is_cached(\%homecache,$index,'home',86400); - if (defined($cached)) { return $result; } + if (exists($homecache{$index})) { return $homecache{$index}; } my $tryserver; foreach $tryserver (keys %libserv) { next if ($ignoreBadCache ne 'true' && @@ -574,7 +564,7 @@ sub homeserver { if ($hostdom{$tryserver} eq $udom) { my $answer=reply("home:$udom:$uname",$tryserver); if ($answer eq 'found') { - return &do_cache(\%homecache,$index,$tryserver,'home'); + return $homecache{$index}=$tryserver; } elsif ($answer eq 'no_host') { $badServerCache{$tryserver}=1; } @@ -627,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{$_}); @@ -637,7 +628,6 @@ sub idput { } else { $servers{$uhom}=$id.'='.$unam; } - &critical('put:'.$udom.':'.$unam.':environment:id='.$id,$uhom); } } foreach (keys %servers) { @@ -652,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)); + $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); + $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum)); + $udom=$env{'user.name'} unless (defined($udom)); + $uname=$env{'user.domain'} unless (defined($uname)); + my %existing=&get('accesskeys',[$ckey],$kdom,$knum); if (($existing{$ckey}=~/^\#(.*)$/) || # - new key - ($existing{$ckey}=~/^$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') { @@ -700,9 +694,9 @@ sub comment_access_key { # my ($ckey,$cdom,$cnum,$logentry)=@_; $cdom= - $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); + $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom)); $cnum= - $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); + $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum)); my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); if ($existing{$ckey}) { $existing{$ckey}.='; '.$logentry; @@ -724,9 +718,9 @@ sub comment_access_key { sub generate_access_keys { my ($number,$cdom,$cnum,$logentry)=@_; $cdom= - $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); + $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom)); $cnum= - $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($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; } @@ -745,14 +739,14 @@ sub generate_access_keys { } else { if (&put('accesskeys', { $newkey => '# generated '.localtime(). - ' by '.$ENV{'user.name'}.'@'.$ENV{'user.domain'}. + ' by '.$env{'user.name'}.'@'.$env{'user.domain'}. '; '.$logentry }, $cdom,$cnum) eq 'ok') { $total++; } } } - &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'}, + &log($env{'user.domain'},$env{'user.name'},$env{'user.home'}, 'Generated '.$total.' keys for '.$cnum.' at '.$cdom); return $total; } @@ -762,21 +756,27 @@ sub generate_access_keys { sub validate_access_key { my ($ckey,$cdom,$cnum,$udom,$uname)=@_; $cdom= - $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($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)); + $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum)); + $udom=$env{'user.domain'} unless (defined($udom)); + $uname=$env{'user.name'} unless (defined($uname)); my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); - return ($existing{$ckey}=~/^$uname\:$udom\#/); + return ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#/); } # ------------------------------------- Find the section of student in a course sub getsection { my ($udom,$unam,$courseid)=@_; + my $cachetime=1800; $courseid=~s/\_/\//g; $courseid=~s/^(\w)/\/$1/; + + my $hashid="$udom:$unam:$courseid"; + my ($result,$cached)=&is_cached_new('getsection',$hashid); + if (defined($cached)) { return $result; } + my %Pending; my %Expired; # @@ -796,205 +796,122 @@ 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)); my $now=time; - if (defined($end) && ($now > $end)) { + if (defined($end) && $end && ($now > $end)) { $Expired{$end}=$section; next; } - if (defined($start) && ($now < $start)) { + if (defined($start) && $start && ($now < $start)) { $Pending{$start}=$section; next; } - return $section; + return &do_cache_new('getsection',$hashid,$section,$cachetime); } # # 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}; + return &do_cache_new('getsection',$hashid,$Pending{$time},$cachetime); } if (scalar(keys(%Expired))) { my @sorted = sort {$a <=> $b} keys(%Expired); my $time = pop(@sorted); - return $Expired{$time}; + return &do_cache_new('getsection',$hashid,$Expired{$time},$cachetime); } - return '-1'; + return &do_cache_new('getsection',$hashid,'-1',$cachetime); } - -my $disk_caching_disabled=1; - -sub devalidate_cache { - my ($cache,$id,$name) = @_; - delete $$cache{$id.'.time'}; - delete $$cache{$id}; - if ($disk_caching_disabled) { return; } - my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db"; - open(DB,"$filename.lock"); - flock(DB,LOCK_EX); - my %hash; - if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) { - eval <<'EVALBLOCK'; - delete($hash{$id}); - delete($hash{$id.'.time'}); -EVALBLOCK - if ($@) { - &logthis("devalidate_cache blew up :$@:$name"); - unlink($filename); - } - } else { - if (-e $filename) { - &logthis("Unable to tie hash (devalidate cache): $name"); - unlink($filename); - } - } - untie(%hash); - flock(DB,LOCK_UN); - close(DB); -} - -sub is_cached { - my ($cache,$id,$name,$time) = @_; - if (!$time) { $time=300; } - if (!exists($$cache{$id.'.time'})) { - &load_cache_item($cache,$name,$id); - } - if (!exists($$cache{$id.'.time'})) { -# &logthis("Didn't find $id"); +sub save_cache { + &purge_remembered(); + undef(%env); +} + +my $to_remember=-1; +my %remembered; +my %accessed; +my $kicks=0; +my $hits=0; +sub devalidate_cache_new { + my ($name,$id,$debug) = @_; + if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); } + $id=&escape($name.':'.$id); + $memcache->delete($id); + delete($remembered{$id}); + delete($accessed{$id}); +} + +sub is_cached_new { + my ($name,$id,$debug) = @_; + $id=&escape($name.':'.$id); + if (exists($remembered{$id})) { + if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); } + $accessed{$id}=[&gettimeofday()]; + $hits++; + return ($remembered{$id},1); + } + my $value = $memcache->get($id); + if (!(defined($value))) { + if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); } return (undef,undef); - } else { - if (time-($$cache{$id.'.time'})>$time) { -# &logthis("Devalidating $id - ".time-($$cache{$id.'.time'})); - &devalidate_cache($cache,$id,$name); - return (undef,undef); - } - } - return ($$cache{$id},1); -} - -sub do_cache { - my ($cache,$id,$value,$name) = @_; - $$cache{$id.'.time'}=time; - $$cache{$id}=$value; -# &logthis("Caching $id as :$value:"); - &save_cache_item($cache,$name,$id); - # do_cache implictly return the set value - $$cache{$id}; -} - -sub save_cache_item { - my ($cache,$name,$id)=@_; - if ($disk_caching_disabled) { return; } - my $starttime=&Time::HiRes::time(); -# &logthis("Saving :$name:$id"); - my %hash; - my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db"; - open(DB,"$filename.lock"); - flock(DB,LOCK_EX); - if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) { - eval <<'EVALBLOCK'; - $hash{$id.'.time'}=$$cache{$id.'.time'}; - $hash{$id}=freeze({'item'=>$$cache{$id}}); -EVALBLOCK - if ($@) { - &logthis("save_cache blew up :$@:$name"); - unlink($filename); - } - } else { - if (-e $filename) { - &logthis("Unable to tie hash (save cache item): $name ($!)"); - unlink($filename); - } - } - untie(%hash); - flock(DB,LOCK_UN); - close(DB); -# &logthis("save_cache_item $name took ".(&Time::HiRes::time()-$starttime)); -} - -sub load_cache_item { - my ($cache,$name,$id)=@_; - if ($disk_caching_disabled) { return; } - my $starttime=&Time::HiRes::time(); -# &logthis("Before Loading $name for $id size is ".scalar(%$cache)); - my %hash; - my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db"; - open(DB,"$filename.lock"); - flock(DB,LOCK_SH); - if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) { - eval <<'EVALBLOCK'; - if (!%$cache) { - my $count; - while (my ($key,$value)=each(%hash)) { - $count++; - if ($key =~ /\.time$/) { - $$cache{$key}=$value; - } else { - my $hashref=thaw($value); - $$cache{$key}=$hashref->{'item'}; - } - } -# &logthis("Initial load: $count"); - } else { - my $hashref=thaw($hash{$id}); - $$cache{$id}=$hashref->{'item'}; - $$cache{$id.'.time'}=$hash{$id.'.time'}; - } -EVALBLOCK - if ($@) { - &logthis("load_cache blew up :$@:$name"); - unlink($filename); - } - } else { - if (-e $filename) { - &logthis("Unable to tie hash (load cache item): $name ($!)"); - unlink($filename); - } - } - untie(%hash); - flock(DB,LOCK_UN); - close(DB); -# &logthis("After Loading $name size is ".scalar(%$cache)); -# &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime)); -} - -sub usection { - my ($udom,$unam,$courseid)=@_; - my $hashid="$udom:$unam:$courseid"; - - my ($result,$cached)=&is_cached(\%usectioncache,$hashid,'usection'); - if (defined($cached)) { return $result; } - $courseid=~s/\_/\//g; - $courseid=~s/^(\w)/\/$1/; - foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles', - &homeserver($unam,$udom)))) { - my ($key,$value)=split(/\=/,$_); - $key=&unescape($key); - if ($key=~/^$courseid(?:\/)*(\w+)*\_st$/) { - 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'); + if ($value eq '__undef__') { + if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); } + $value=undef; + } + &make_room($id,$value,$debug); + if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); } + return ($value,1); +} + +sub do_cache_new { + my ($name,$id,$value,$time,$debug) = @_; + $id=&escape($name.':'.$id); + my $setvalue=$value; + if (!defined($setvalue)) { + $setvalue='__undef__'; + } + if (!defined($time) ) { + $time=600; + } + if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); } + $memcache->set($id,$setvalue,$time); + # need to make a copy of $value + #&make_room($id,$value,$debug); + return $value; +} + +sub make_room { + my ($id,$value,$debug)=@_; + $remembered{$id}=$value; + if ($to_remember<0) { return; } + $accessed{$id}=[&gettimeofday()]; + if (scalar(keys(%remembered)) <= $to_remember) { return; } + my $to_kick; + my $max_time=0; + foreach my $other (keys(%accessed)) { + if (&tv_interval($accessed{$other}) > $max_time) { + $to_kick=$other; + $max_time=&tv_interval($accessed{$other}); + } + } + delete($remembered{$to_kick}); + delete($accessed{$to_kick}); + $kicks++; + if ($debug) { &logthis("kicking $to_kick $max_time $kicks\n"); } + return; +} + +sub purge_remembered { + #&logthis("Tossing ".scalar(keys(%remembered))); + #&logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered)))); + undef(%remembered); + undef(%accessed); } - # ------------------------------------- Read an entry from a user's environment sub userenvironment { @@ -1010,15 +927,28 @@ sub userenvironment { return %returnhash; } +# ---------------------------------------------------------- Get a studentphoto +sub studentphoto { + my ($udom,$unam,$ext) = @_; + my $home=&Apache::lonnet::homeserver($unam,$udom); + my $ret=&Apache::lonnet::reply("studentphoto:$udom:$unam:$ext",$home); + my $url="/uploaded/$udom/$unam/internal/studentphoto.".$ext; + if ($ret ne 'ok') { + return '/adm/lonKaputt/lonlogo_broken.gif'; + } + my $tokenurl=&Apache::lonnet::tokenwrapper($url); + return $tokenurl; +} + # -------------------------------------------------------------------- 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'}; + 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($env{'user.domain'}.':'.$env{'user.name'}.':'.$anon.':'. &escape($newentry)),$chome); } @@ -1032,7 +962,7 @@ sub getversion { sub currentversion { my $fname=shift; - my ($result,$cached)=&is_cached(\%resversioncache,$fname,'resversion',600); + my ($result,$cached)=&is_cached_new('resversion',$fname); if (defined($cached)) { return $result; } my $author=$fname; $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; @@ -1045,7 +975,7 @@ sub currentversion { if (($answer eq 'con_lost') || ($answer eq 'rejected')) { return -1; } - return &do_cache(\%resversioncache,$fname,$answer,'resversion'); + return &do_cache_new('resversion',$fname,$answer,600); } # ----------------------------- Subscribe to a resource, return URL if possible @@ -1053,6 +983,7 @@ sub currentversion { sub subscribe { my $fname=shift; if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; } + $fname=~s/[\n\r]//g; my $author=$fname; $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; my ($udom,$uname)=split(/\//,$author); @@ -1072,21 +1003,27 @@ sub subscribe { sub repcopy { my $filename=shift; $filename=~s/\/+/\//g; - if ($filename=~/^\/home\/httpd\/html\/adm\//) { return OK; } + if ($filename=~m|^/home/httpd/html/adm/|) { return 'ok'; } + if ($filename=~m|^/home/httpd/html/lonUsers/|) { return 'ok'; } + if ($filename=~m|^/home/httpd/html/userfiles/| or + $filename=~m -^/*(uploaded|editupload)/-) { + return &repcopy_userfile($filename); + } + $filename=~s/[\n\r]//g; my $transname="$filename.in.transfer"; - if ((-e $filename) || (-e $transname)) { return OK; } + 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; + return 'unavailable'; } elsif ($remoteurl eq 'not_found') { #&logthis("Subscribe returned not_found: $filename"); - return HTTP_NOT_FOUND; + return 'not_found'; } elsif ($remoteurl =~ /^rejected by/) { &logthis("Subscribe returned $remoteurl: $filename"); - return FORBIDDEN; + return 'forbidden'; } elsif ($remoteurl eq 'directory') { - return OK; + return 'ok'; } else { my $author=$filename; $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; @@ -1097,7 +1034,7 @@ sub repcopy { 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; + return 'bad_request'; } my $count; for ($count=5;$count<$#parts;$count++) { @@ -1114,7 +1051,7 @@ sub repcopy { my $message=$response->status_line; &logthis("WARNING:" ." LWP get: $message: $filename"); - return HTTP_SERVICE_UNAVAILABLE; + return 'unavailable'; } else { if ($remoteurl!~/\.meta$/) { my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta'); @@ -1126,7 +1063,7 @@ sub repcopy { } } rename($transname,$filename); - return OK; + return 'ok'; } } } @@ -1135,12 +1072,14 @@ sub repcopy { # ------------------------------------------------ Get server side include body sub ssi_body { my ($filelink,%form)=@_; + if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) { + $form{'LONCAPA_INTERNAL_no_discussion'}='true'; + } my $output=($filelink=~/^http\:/?&externalssi($filelink): &ssi($filelink,%form)); + $output=~s|//(\s*)?\s||gs; $output=~s/^.*?\]*\>//si; $output=~s/(.*)\<\/body\s*\>.*?$/$1/si; - $output=~ - s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs; return $output; } @@ -1175,31 +1114,102 @@ 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 $fname=$ENV{'form.'.$formname.'.filename'}; +sub clean_filename { + my ($fname)=@_; # Replace Windows backslashes by forward slashes $fname=~s/\\/\//g; # Get rid of everything but the actual filename @@ -1208,30 +1218,74 @@ sub userfileupload { $fname=~s/\s+/\_/g; # Replace all other weird characters by nothing $fname=~s/[^\w\.\-]//g; +# Replace all .\d. sequences with _\d. so they no longer look like version +# numbers + $fname=~s/\.(\d+)(?=\.)/_$1/g; + return $fname; +} + +# --------------- Take an uploaded file and put it into the userfiles directory +# input: name of form element, coursedoc=1 means this is for the course +# output: url of file in userspace + + +sub userfileupload { + my ($formname,$coursedoc,$subdir)=@_; + if (!defined($subdir)) { $subdir='unknown'; } + my $fname=$env{'form.'.$formname.'.filename'}; + $fname=&clean_filename($fname); # See if there is anything left unless ($fname) { return 'error: no uploaded file'; } - chop($ENV{'form.'.$formname}); + chop($env{'form.'.$formname}); + if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) { #files uploaded to help request form are handled differently + my $now = time; + my $filepath = 'tmp/helprequests/'.$now; + my @parts=split(/\//,$filepath); + my $fullpath = $perlvar{'lonDaemons'}; + for (my $i=0;$i<@parts;$i++) { + $fullpath .= '/'.$parts[$i]; + if ((-e $fullpath)!=1) { + mkdir($fullpath,0777); + } + } + open(my $fh,'>'.$fullpath.'/'.$fname); + print $fh $env{'form.'.$formname}; + close($fh); + return $fullpath.'/'.$fname; + } # Create the directory if not present my $docuname=''; my $docudom=''; my $docuhome=''; + $fname="$subdir/$fname"; if ($coursedoc) { - $docuname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'}; - $docudom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}; - $docuhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'}; - } else { - $docuname=$ENV{'user.name'}; - $docudom=$ENV{'user.domain'}; - $docuhome=$ENV{'user.home'}; + $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++) { @@ -1242,26 +1296,49 @@ sub finishuserfileupload { } # Save the file { - open(my $fh,'>'.$filepath.'/'.$fname); - print $fh $ENV{'form.'.$formname}; - close($fh); + open(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 &removeuserfile($uname,$udom,$fname); +} + +sub removeuserfile { + my ($docuname,$docudom,$fname)=@_; + my $home=&homeserver($docuname,$docudom); + return &reply("removeuserfile:$docudom/$docuname/$fname",$home); +} + +sub mkdiruserfile { + my ($docuname,$docudom,$dir)=@_; + my $home=&homeserver($docuname,$docudom); + return &reply("mkdiruserfile:".&escape("$docudom/$docuname/$dir"),$home); +} + +sub renameuserfile { + my ($docuname,$docudom,$old,$new)=@_; + my $home=&homeserver($docuname,$docudom); + return &reply("renameuserfile:$docudom:$docuname:".&escape("$old").':'. + &escape("$new"),$home); +} + # ------------------------------------------------------------------------- Log sub log { @@ -1301,11 +1378,13 @@ sub flushcourselogs { } if ($courseidbuffer{$coursehombuf{$crsid}}) { $courseidbuffer{$coursehombuf{$crsid}}.='&'. - &escape($crsid).'='.&escape($coursedescrbuf{$crsid}); + &escape($crsid).'='.&escape($coursedescrbuf{$crsid}). + ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}); } else { $courseidbuffer{$coursehombuf{$crsid}}= - &escape($crsid).'='.&escape($coursedescrbuf{$crsid}); - } + &escape($crsid).'='.&escape($coursedescrbuf{$crsid}). + ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}); + } } # # Write course id database (reverse lookup) to homeserver of courses @@ -1319,8 +1398,15 @@ sub flushcourselogs { # Writes to the dynamic metadata of resources to get hit counts, etc. # foreach my $entry (keys(%accesshash)) { - my ($dom,$name,undef,$type)=($entry=~m:___(\w+)/(\w+)/(.*)___(\w+)$:); - if ($type eq 'count'){ + 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); @@ -1335,6 +1421,7 @@ sub flushcourselogs { } } } 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}; @@ -1361,35 +1448,50 @@ sub flushcourselogs { 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; + 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'}; + $courseinstcodebuf{$env{'request.course.id'}}= + $env{'course.'.$env{'request.course.id'}.'.internal.coursecode'}; + $courseownerbuf{$env{'request.course.id'}}= + $env{'course.'.$env{'request.course.id'}.'.internal.courseowner'}; + if (defined $courselogs{$env{'request.course.id'}}) { + $courselogs{$env{'request.course.id'}}.='&'.$what; } else { - $courselogs{$ENV{'request.course.id'}}.=$what; + $courselogs{$env{'request.course.id'}}.=$what; } -# if (length($courselogs{$ENV{'request.course.id'}})>4048) { - if (length($courselogs{$ENV{'request.course.id'}})>48) { + 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'}; + 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) { + # FIXME: Probably ought to escape things.... + foreach (keys %env) { if ($_=~/^form\.(.*)/) { - $what.=':'.$1.'='.$ENV{$_}; + $what.=':'.$1.'='.$env{$_}; + } + } + } elsif ($fnsymb =~ m:^/adm/searchcat:) { + # FIXME: We should not be depending on a form parameter that someone + # editing lonsearchcat.pm might change in the future. + if ($env{'form.phase'} eq 'course_search') { + $what.= ':POST'; + # FIXME: Probably ought to escape things.... + foreach my $element ('courseexp','crsfulltext','crsrelated', + 'crsdiscuss') { + $what.=':'.$element.'='.$env{'form.'.$element}; } } } @@ -1398,8 +1500,9 @@ sub courseacclog { sub countacc { my $url=&declutter(shift); - unless ($ENV{'request.course.id'}) { return ''; } - $accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1; + return if (! defined($url) || $url eq ''); + unless ($env{'request.course.id'}) { return ''; } + $accesshash{$env{'request.course.id'}.'___'.$url.'___course'}=1; my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count'; $accesshash{$key}++; } @@ -1416,7 +1519,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} @@ -1426,8 +1529,12 @@ sub userrolelog { sub get_course_adv_roles { my $cid=shift; - $cid=$ENV{'request.course.id'} unless (defined($cid)); + $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'}); @@ -1438,6 +1545,9 @@ sub get_course_adv_roles { if (($tend) && ($tend<$now)) { next; } if (($tstart) && ($now<$tstart)) { next; } my ($role,$username,$domain,$section)=split(/\:/,$_); + if ($username eq '' || $domain eq '') { next; } + if ((&privileged($username,$domain)) && + (!$nothide{$username.':'.$domain})) { next; } my $key=&plaintext($role); if ($section) { $key.=' (Sec/Grp '.$section.')'; } if ($returnhash{$key}) { @@ -1451,8 +1561,8 @@ sub get_course_adv_roles { sub get_my_roles { my ($uname,$udom)=@_; - unless (defined($uname)) { $uname=$ENV{'user.name'}; } - unless (defined($udom)) { $udom=$ENV{'user.domain'}; } + unless (defined($uname)) { $uname=$env{'user.name'}; } + unless (defined($udom)) { $udom=$env{'user.domain'}; } my %dumphash= &dump('nohist_userroles',$udom,$uname); my %returnhash=(); @@ -1488,7 +1598,7 @@ sub getannounce { if ($announcement=~/\w/) { return ''. - '
'.$announcement.'
'; + ''.$announcement.''; } else { return ''; } @@ -1507,21 +1617,23 @@ sub courseidput { } sub courseiddump { - my ($domfilter,$descfilter,$sincefilter)=@_; + my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref)=@_; 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), + if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) || (!defined($hostidflag)) ) { + if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) { + foreach ( + split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. + $sincefilter.':'.&escape($descfilter).':'. + &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter), $tryserver))) { - my ($key,$value)=split(/\=/,$_); - if (($key) && ($value)) { - $returnhash{&unescape($key)}=&unescape($value); + my ($key,$value)=split(/\=/,$_); + if (($key) && ($value)) { + $returnhash{&unescape($key)}=$value; + } } } - } } return %returnhash; @@ -1530,6 +1642,36 @@ 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=&symbread($map); + } else { + $res=$symb; + } + my %times=&get('firstaccesstimes',["$courseid\0$res"],$udom,$uname); + return $times{"$courseid\0$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=&symbread($map); + } else { + $res=$symb; + } + my $firstaccess=&get_first_access($type,$symb); + if (!$firstaccess) { + return &put('firstaccesstimes',{"$courseid\0$res"=>time},$udom,$uname); + } + return 'already_set'; +} + sub checkout { my ($symb,$tuname,$tudom,$tcrsid)=@_; my $now=time; @@ -1583,7 +1725,7 @@ sub checkin { my $now=time; my ($ta,$tb,$lonhost)=split(/\*/,$token); $lonhost=~tr/A-Z/a-z/; - my $dtoken=$ta.'_'.$hostip{$lonhost}.'_'.$tb; + my $dtoken=$ta.'_'.$hostname{$lonhost}.'_'.$tb; $dtoken=~s/\W/\_/g; my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)= split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost))); @@ -1595,7 +1737,7 @@ sub checkin { unless (&allowed('mgr',$tcrsid)) { &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '. - $ENV{'user.name'}.' - '.$ENV{'user.domain'}); + $env{'user.name'}.' - '.$env{'user.domain'}); return ''; } @@ -1619,15 +1761,15 @@ sub checkin { sub expirespread { my ($uname,$udom,$stype,$usymb)=@_; - my $cid=$ENV{'request.course.id'}; + 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'}. + return &reply('put:'.$env{'course.'.$cid.'.domain'}.':'. + $env{'course.'.$cid.'.num'}. ':nohist_expirationdates:'. &escape($key).'='.$now, - $ENV{'course.'.$cid.'.home'}) + $env{'course.'.$cid.'.home'}) } return 'ok'; } @@ -1636,18 +1778,19 @@ sub expirespread { sub devalidate { my ($symb,$uname,$udom)=@_; - my $cid=$ENV{'request.course.id'}; + 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 + # - current conditional state info my $key=$uname.':'.$udom.':'; my $status= &del('nohist_calculatedsheets', [$key.'studentcalc:'], - $ENV{'course.'.$cid.'.domain'}, - $ENV{'course.'.$cid.'.num'}) + $env{'course.'.$cid.'.domain'}, + $env{'course.'.$cid.'.num'}) .' '. &del('nohist_calculatedsheets_'.$cid, [$key.'assesscalc:'.$symb],$udom,$uname); @@ -1656,6 +1799,7 @@ sub devalidate { $uname.' at '.$udom.' for '. $symb.': '.$status); } + &delenv('user.state.'.$cid); } } @@ -1708,7 +1852,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') { @@ -1856,17 +2000,19 @@ sub tmpreset { my ($symb,$namespace,$domain,$stuname) = @_; if (!$symb) { $symb=&symbread(); - if (!$symb) { $symb= $ENV{'request.url'}; } + if (!$symb) { $symb= $env{'request.url'}; } } $symb=escape($symb); - if (!$namespace) { $namespace=$ENV{'request.state'}; } + 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'}; } + if (!$domain) { $domain=$env{'user.domain'}; } + if (!$stuname) { $stuname=$env{'user.name'}; } + if ($domain eq 'public' && $stuname eq 'public') { + $stuname=$ENV{'REMOTE_ADDR'}; + } my $path=$perlvar{'lonDaemons'}.'/tmp'; my %hash; if (tie(%hash,'GDBM_File', @@ -1885,23 +2031,25 @@ sub tmpstore { if (!$symb) { $symb=&symbread(); - if (!$symb) { $symb= $ENV{'request.url'}; } + 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'}; + #$namespace=$env{'request.course.id'}; #if (!$namespace) { - $namespace=$ENV{'request.state'}; + $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'}; } + if (!$domain) { $domain=$env{'user.domain'}; } + if (!$stuname) { $stuname=$env{'user.name'}; } + if ($domain eq 'public' && $stuname eq 'public') { + $stuname=$ENV{'REMOTE_ADDR'}; + } my $now=time; my %hash; my $path=$perlvar{'lonDaemons'}.'/tmp'; @@ -1913,7 +2061,7 @@ sub tmpstore { my $allkeys=''; foreach my $key (keys(%$storehash)) { $allkeys.=$key.':'; - $hash{"$version:$symb:$key"}=$$storehash{$key}; + $hash{"$version:$symb:$key"}=&freeze_escape($$storehash{$key}); } $hash{"$version:$symb:timestamp"}=$now; $allkeys.='timestamp'; @@ -1935,15 +2083,17 @@ sub tmprestore { if (!$symb) { $symb=&symbread(); - if (!$symb) { $symb= $ENV{'request.url'}; } + 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'}; } + if (!$namespace) { $namespace=$env{'request.state'}; } + if (!$domain) { $domain=$env{'user.domain'}; } + if (!$stuname) { $stuname=$env{'user.name'}; } + if ($domain eq 'public' && $stuname eq 'public') { + $stuname=$ENV{'REMOTE_ADDR'}; + } my %returnhash; $namespace=~s/\//\_/g; $namespace=~s/\W//g; @@ -1961,8 +2111,8 @@ sub tmprestore { my $key; $returnhash{"$scope:keys"}=$vkeys; foreach $key (@keys) { - $returnhash{"$scope:$key"}=$hash{"$scope:$symb:$key"}; - $returnhash{"$key"}=$hash{"$scope:$symb:$key"}; + $returnhash{"$scope:$key"}=&thaw_unescape($hash{"$scope:$symb:$key"}); + $returnhash{"$key"}=&thaw_unescape($hash{"$scope:$symb:$key"}); } } if (!(untie(%hash))) { @@ -1985,25 +2135,25 @@ sub store { $symb=&symbclean($symb); if (!$symb) { unless ($symb=&symbread()) { return ''; } } - if (!$domain) { $domain=$ENV{'user.domain'}; } - if (!$stuname) { $stuname=$ENV{'user.name'}; } + 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'}) { + unless ($namespace=$env{'request.course.id'}) { return ''; } } - if (!$home) { $home=$ENV{'user.home'}; } + if (!$home) { $home=$env{'user.home'}; } $$storehash{'ip'}=$ENV{'REMOTE_ADDR'}; $$storehash{'host'}=$perlvar{'lonHostID'}; my $namevalue=''; foreach (keys %$storehash) { - $namevalue.=escape($_).'='.escape($$storehash{$_}).'&'; + $namevalue.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; } $namevalue=~s/\&$//; &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue); @@ -2021,25 +2171,25 @@ sub cstore { $symb=&symbclean($symb); if (!$symb) { unless ($symb=&symbread()) { return ''; } } - if (!$domain) { $domain=$ENV{'user.domain'}; } - if (!$stuname) { $stuname=$ENV{'user.name'}; } + 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'}) { + unless ($namespace=$env{'request.course.id'}) { return ''; } } - if (!$home) { $home=$ENV{'user.home'}; } + if (!$home) { $home=$env{'user.home'}; } $$storehash{'ip'}=$ENV{'REMOTE_ADDR'}; $$storehash{'host'}=$perlvar{'lonHostID'}; my $namevalue=''; foreach (keys %$storehash) { - $namevalue.=escape($_).'='.escape($$storehash{$_}).'&'; + $namevalue.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; } $namevalue=~s/\&$//; &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue); @@ -2061,19 +2211,19 @@ sub restore { $symb=&escape(&symbclean($symb)); } if (!$namespace) { - unless ($namespace=$ENV{'request.course.id'}) { + 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'}; } + 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); + $returnhash{&unescape($name)}=&thaw_unescape($value); } my $version; for ($version=1;$version<=$returnhash{'version'};$version++) { @@ -2109,7 +2259,7 @@ sub coursedescription { } $returnhash{'url'}=&clutter($returnhash{'url'}); $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'. - $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum; + $env{'user.name'}.'_'.$cdomain.'_'.$cnum; $envhash{'course.'.$normalid.'.home'}=$chome; $envhash{'course.'.$normalid.'.domain'}=$cdomain; $envhash{'course.'.$normalid.'.num'}=$cnum; @@ -2119,6 +2269,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 { @@ -2126,112 +2306,122 @@ sub rolesinit { 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\&/) { + 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=''; - } - } + $area=~s/\_\w\w$//; + + my ($trole,$tend,$tstart); + if ($role=~/^cr/) { + ($trole,my $trest)=($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|); + ($tend,$tstart)=split('_',$trest); + } else { + ($trole,$tend,$tstart)=split(/_/,$role); + } + $userroles.=&set_arearole($trole,$area,$tstart,$tend,$domain,$username); + if (($tend!=0) && ($tend<$now)) { $trole=''; } + if (($tstart!=0) && ($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; - } - } - } - } - } + &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area); } 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'}; - } - } - } + &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area); } } } } - 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"; - } + my ($author,$adv) = &set_userprivs(\$userroles,\%allroles); $userroles.='user.adv='.$adv."\n". 'user.author='.$author."\n"; - $ENV{'user.adv'}=$adv; + $env{'user.adv'}=$adv; } return $userroles; } +sub set_arearole { + my ($trole,$area,$tstart,$tend,$domain,$username) = @_; +# log the associated role with the area + &userrolelog($trole,$username,$domain,$area,$tstart,$tend); + return 'user.role.'.$trole.'.'.$area.'='.$tstart.'.'.$tend."\n"; +} + +sub custom_roleprivs { + my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_; + 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 '') && (defined($coursepriv))) { + $$allroles{'cm.'.$area}.=':'.$coursepriv; + $$allroles{$spec.'.'.$area}.=':'.$coursepriv; + } + } + } + } +} + + +sub standard_roleprivs { + my ($allroles,$trole,$tdomain,$spec,$trest,$area) = @_; + 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 '') && (defined($pr{$trole.':c'}))) { + $$allroles{'cm.'.$area}.=':'.$pr{$trole.':c'}; + $$allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'}; + } + } +} + +sub set_userprivs { + my ($userroles,$allroles) = @_; + my $author=0; + my $adv=0; + foreach (keys %{$allroles}) { + my %thesepriv=(); + if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; } + foreach (split(/:/,$$allroles{$_})) { + if ($_ ne '') { + my ($privilege,$restrictions)=split(/&/,$_); + if ($restrictions eq '') { + $thesepriv{$privilege}='F'; + } elsif ($thesepriv{$privilege} ne 'F') { + $thesepriv{$privilege}.=$restrictions; + } + if ($thesepriv{'adv'} eq 'F') { $adv=1; } + } + } + my $thesestr=''; + foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } + $$userroles.='user.priv.'.$_.'='.$thesestr."\n"; + } + return ($author,$adv); +} + # --------------------------------------------------------------- get interface sub get { @@ -2241,8 +2431,8 @@ sub get { $items.=escape($_).'&'; } $items=~s/\&$//; - if (!$udomain) { $udomain=$ENV{'user.domain'}; } - if (!$uname) { $uname=$ENV{'user.name'}; } + 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); @@ -2253,7 +2443,7 @@ sub get { my %returnhash=(); my $i=0; foreach (@$storearr) { - $returnhash{$_}=unescape($pairs[$i]); + $returnhash{$_}=&thaw_unescape($pairs[$i]); $i++; } return %returnhash; @@ -2268,8 +2458,8 @@ sub del { $items.=escape($_).'&'; } $items=~s/\&$//; - if (!$udomain) { $udomain=$ENV{'user.domain'}; } - if (!$uname) { $uname=$ENV{'user.name'}; } + 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); @@ -2279,8 +2469,8 @@ sub del { sub dump { my ($namespace,$udomain,$uname,$regexp)=@_; - if (!$udomain) { $udomain=$ENV{'user.domain'}; } - if (!$uname) { $uname=$ENV{'user.name'}; } + if (!$udomain) { $udomain=$env{'user.domain'}; } + if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); if ($regexp) { $regexp=&escape($regexp); @@ -2292,7 +2482,7 @@ sub dump { my %returnhash=(); foreach (@pairs) { my ($key,$value)=split(/=/,$_); - $returnhash{unescape($key)}=unescape($value); + $returnhash{unescape($key)}=&thaw_unescape($value); } return %returnhash; } @@ -2301,8 +2491,8 @@ sub dump { sub getkeys { my ($namespace,$udomain,$uname)=@_; - if (!$udomain) { $udomain=$ENV{'user.domain'}; } - if (!$uname) { $uname=$ENV{'user.name'}; } + 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=(); @@ -2315,9 +2505,9 @@ sub getkeys { # --------------------------------------------------------------- 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)); + $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)/); @@ -2338,7 +2528,7 @@ sub currentdump { my ($key,$value)=split(/=/,$_); my ($symb,$param) = split(/:/,$key); $returnhash{&unescape($symb)}->{&unescape($param)} = - &unescape($value); + &thaw_unescape($value); } } return %returnhash; @@ -2375,8 +2565,8 @@ sub convert_dump_to_currentdump{ sub inc { my ($namespace,$store,$udomain,$uname) = @_; - if (!$udomain) { $udomain=$ENV{'user.domain'}; } - if (!$uname) { $uname=$ENV{'user.name'}; } + if (!$udomain) { $udomain=$env{'user.domain'}; } + if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); my $items=''; if (! ref($store)) { @@ -2399,12 +2589,36 @@ sub inc { sub put { my ($namespace,$storehash,$udomain,$uname)=@_; - if (!$udomain) { $udomain=$ENV{'user.domain'}; } - if (!$uname) { $uname=$ENV{'user.name'}; } + 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.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; + } + $items=~s/\&$//; + return &reply("put:$udomain:$uname:$namespace:$items",$uhome); +} + +# ---------------------------------------------------------- putstore interface + +sub putstore { + my ($namespace,$storehash,$udomain,$uname)=@_; + if (!$udomain) { $udomain=$env{'user.domain'}; } + if (!$uname) { $uname=$env{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); + my $items=''; + my %allitems = (); + foreach (keys %$storehash) { + if ($_ =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) { + my $key = $1.':keys:'.$2; + $allitems{$key} .= $3.':'; + } + $items.=$_.'='.&freeze_escape($$storehash{$_}).'&'; + } + foreach (keys %allitems) { + $allitems{$_} =~ s/\:$//; + $items.= $_.'='.$allitems{$_}.'&'; } $items=~s/\&$//; return &reply("put:$udomain:$uname:$namespace:$items",$uhome); @@ -2414,12 +2628,12 @@ sub put { sub cput { my ($namespace,$storehash,$udomain,$uname)=@_; - if (!$udomain) { $udomain=$ENV{'user.domain'}; } - if (!$uname) { $uname=$ENV{'user.name'}; } + 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.=escape($_).'='.&freeze_escape($$storehash{$_}).'&'; } $items=~s/\&$//; return &critical("put:$udomain:$uname:$namespace:$items",$uhome); @@ -2434,15 +2648,15 @@ sub eget { $items.=escape($_).'&'; } $items=~s/\&$//; - if (!$udomain) { $udomain=$ENV{'user.domain'}; } - if (!$uname) { $uname=$ENV{'user.name'}; } + 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]); + $returnhash{$_}=&thaw_unescape($pairs[$i]); $i++; } return %returnhash; @@ -2452,7 +2666,7 @@ sub eget { sub customaccess { my ($priv,$uri)=@_; - my ($urole,$urealm)=split(/\./,$ENV{'request.role'}); + my ($urole,$urealm)=split(/\./,$env{'request.role'}); $urealm=~s/^\W//; my ($udom,$ucrs,$usec)=split(/\//,$urealm); my $access=0; @@ -2485,39 +2699,48 @@ sub customaccess { # ------------------------------------------------- Check for a user privilege sub allowed { - my ($priv,$uri)=@_; + my ($priv,$uri,$symb)=@_; $uri=&deversion($uri); my $orguri=$uri; $uri=&declutter($uri); - - if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; } + + + + 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')) { + if (((($uri=~/^adm\//) && ($uri !~ m|/bulletinboard$|)) + || ($uri=~/\.meta$/)) && ($priv eq 'bre')) { return 'F'; } +# Free bre access to user's own portfolio contents + my ($space,$domain,$name,$dir)=split('/',$uri); + if (($space=~/^(uploaded|ediupload)$/) && ($env{'user.name'} eq $name) && + ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir)) { + return 'F'; + } + # Free bre to public access if ($priv eq 'bre') { my $copyright=&metadata($uri,'copyright'); - if (($copyright eq 'public') && (!$ENV{'request.course.id'})) { + 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)) { + 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)) { + unless (($env{'user.domain'} eq $1) || + ($env{'course.'.$env{'request.course.id'}.'.domain'} eq $1)) { return ''; } } - if ($ENV{'request.role'}=~ /li\.\//) { + if ($env{'request.role'}=~ /li\.\//) { # Library role, so allow browsing of resources in this domain. return 'F'; } @@ -2526,11 +2749,11 @@ sub allowed { } } # Domain coordinator is trying to create a course - if (($priv eq 'ccc') && ($ENV{'request.role'} =~ /^dc\./)) { + 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'}); + return 'F' if ($uri eq $env{'request.role.domain'}); } my $thisallowed=''; @@ -2539,14 +2762,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\&([^\:]*)/) { + if ($env{'user.priv.'.$env{'request.role'}.'./'.(split(/\//,$uri))[0].'/'} + =~/\Q$priv\E\&([^\:]*)/) { $thisallowed.=$1; } @@ -2555,17 +2778,22 @@ sub allowed { $courseuri=~s/\_(\d)/\/$1/; $courseuri=~s/^([^\/])/\/$1/; - if ($ENV{'user.priv.'.$ENV{'request.role'}.'.'.$courseuri} - =~/$priv\&([^\:]*)/) { + if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri} + =~/\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'; +# not allowing 'edit' access (editupload) to uploaded course docs + 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/) { @@ -2574,7 +2802,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; } # @@ -2583,35 +2811,35 @@ sub allowed { # Course: See if uri or referer is an individual resource that is part of # the course - if ($ENV{'request.course.id'}) { + if ($env{'request.course.id'}) { - $courseprivid=$ENV{'request.course.id'}; - if ($ENV{'request.course.sec'}) { - $courseprivid.='/'.$ENV{'request.course.sec'}; + $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\&([^\:]*)/) { + if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid} + =~/\Q$priv\E\&([^\:]*)/) { $thisallowed.=$1; $checkreferer=0; } } if ($checkreferer) { - my $refuri=$ENV{'httpref.'.$orguri}; + my $refuri=$env{'httpref.'.$orguri}; unless ($refuri) { - foreach (keys %ENV) { + foreach (keys %env) { if ($_=~/^httpref\..*\*/) { my $pattern=$_; $pattern=~s/^httpref\.\/res\///; $pattern=~s/\*/\[\^\/\]\+/g; $pattern=~s/\//\\\//g; if ($orguri=~/$pattern/) { - $refuri=$ENV{$_}; + $refuri=$env{$_}; } } } @@ -2622,8 +2850,8 @@ sub allowed { my ($match,$cond)=&is_on_map($refuri); if ($match) { my $refstatecond=$cond; - if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} - =~/$priv\&([^\:]*)/) { + if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid} + =~/\Q$priv\E\&([^\:]*)/) { $thisallowed.=$1; $uri=$refuri; $statecond=$refstatecond; @@ -2662,39 +2890,39 @@ sub allowed { my $envkey; if ($thisallowed=~/L/) { - foreach $envkey (keys %ENV) { + 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) { + 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) { + 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'}, + if (($env{$prefix.'res.'.$uri.'.lock.sections'}=~/\,\Q$csec\E\,/) + || ($env{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) { + if ($env{$prefix.'res.'.$uri.'.lock.expire'}>time) { + &log($env{'user.domain'},$env{'user.name'}, + $env{'user.home'}, 'Locked by res: '.$priv.' for '.$uri.' due to '. $cdom.'/'.$cnum.'/'.$csec.' expire '. - $ENV{$prefix.'priv.'.$priv.'.lock.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'}, + if (($env{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/) + || ($env{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) { + if ($env{'priv.'.$priv.'.lock.expire'}>time) { + &log($env{'user.domain'},$env{'user.name'}, + $env{'user.home'}, 'Locked by priv: '.$priv.' for '.$uri.' due to '. $cdom.'/'.$cnum.'/'.$csec.' expire '. - $ENV{$prefix.'priv.'.$priv.'.lock.expire'}); + $env{$prefix.'priv.'.$priv.'.lock.expire'}); return ''; } } @@ -2706,7 +2934,7 @@ sub allowed { # Rest of the restrictions depend on selected course # - unless ($ENV{'request.course.id'}) { + unless ($env{'request.course.id'}) { return '1'; } @@ -2718,21 +2946,21 @@ sub allowed { # 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'}, + 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'} + =~/\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'}); + $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'}, + if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'} + =~/\Q$unamedom\E/) { + &log($env{'user.domain'},$env{'user.name'},$env{'user.host'}, 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '. - $ENV{'request.course.id'}); + $env{'request.course.id'}); return ''; } } @@ -2740,9 +2968,9 @@ sub allowed { # 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'}, + my $rolecode=(split(/\./,$env{'request.role'}))[0]; + 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 ''; } @@ -2751,9 +2979,9 @@ sub allowed { # Restricted by state or randomout? if ($thisallowed=~/X/) { - if ($ENV{'acc.randomout'}) { - my $symb=&symbread($uri,1); - if (($symb) && ($ENV{'acc.randomout'}=~/\&$symb\&/)) { + if ($env{'acc.randomout'}) { + if (!$symb) { $symb=&symbread($uri,1); } + if (($symb) && ($env{'acc.randomout'}=~/\&\Q$symb\E\&/)) { return ''; } } @@ -2778,7 +3006,7 @@ sub is_on_map { $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}=~ + my $match=($env{'acc.res.'.$env{'request.course.id'}.'.'.$pathname}=~ /\&\Q$filename\E\:([\d\|]+)\&/); if ($match) { return (1,$1); @@ -2797,7 +3025,7 @@ sub get_symb_from_alias { # Must be an alias my $aliassymb=''; my %bighash; - if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', + if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db', &GDBM_READER(),0640)) { my $rid=$bighash{'mapalias_'.$symb}; if ($rid) { @@ -2817,36 +3045,36 @@ 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"; } } } - my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:". - "$ENV{'user.domain'}:$ENV{'user.name'}:". + 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'}); + return reply($command,$env{'user.home'}); } else { return 'refused'; } @@ -2884,10 +3112,79 @@ 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; + my $maxtries = 1; + if ($context eq 'automated') { + $homeserver = $perlvar{'lonHostID'}; + $maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout + } 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\_/) { + &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum); + return 'error: '.$queryid; + } + my $reply = &get_query_reply($queryid); + my $tries = 1; + while (($reply=~/^timeout/) && ($tries < $maxtries)) { + $reply = &get_query_reply($queryid); + $tries ++; + } + if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { + &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries); + } else { + 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); + if ($xml_classlist =~ /^error/) { + &logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum); + } else { + if ( open(FILE,">$destname") ) { + print FILE &unescape($xml_classlist); + close(FILE); + } else { + &logthis('fetch_enrollment_query - error opening classlist file '.$destname.' '.$context.' '.$cnum); + } + } + } + } + } + } + return 'ok'; + } + return 'error'; +} + sub get_query_reply { my $queryid=shift; my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid; @@ -2916,14 +3213,14 @@ sub courselog_query { # end: timestamp # my (%filters)=@_; - unless ($ENV{'request.course.id'}) { return 'no_course'; } + 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'}; + 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); } @@ -2932,6 +3229,87 @@ sub userlog_query { return &log_query($uname,$udom,'userlog',%filters); } +#--------- Call auto-enrollment subs in localenroll.pm for homeserver for course + +sub auto_run { + my ($cnum,$cdom) = @_; + my $homeserver = &homeserver($cnum,$cdom); + my $response = &reply('autorun:'.$cdom,$homeserver); + return $response; +} + +sub auto_get_sections { + my ($cnum,$cdom,$inst_coursecode) = @_; + my $homeserver = &homeserver($cnum,$cdom); + my @secs = (); + my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver)); + unless ($response eq 'refused') { + @secs = split/:/,$response; + } + return @secs; +} + +sub auto_new_course { + my ($cnum,$cdom,$inst_course_id,$owner) = @_; + my $homeserver = &homeserver($cnum,$cdom); + my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver)); + return $response; +} + +sub auto_validate_courseID { + my ($cnum,$cdom,$inst_course_id) = @_; + my $homeserver = &homeserver($cnum,$cdom); + my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver)); + return $response; +} + +sub auto_create_password { + my ($cnum,$cdom,$authparam) = @_; + my $homeserver = &homeserver($cnum,$cdom); + my $create_passwd = 0; + my $authchk = ''; + my $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver)); + if ($response eq 'refused') { + $authchk = 'refused'; + } else { + ($authparam,$create_passwd,$authchk) = split/:/,$response; + } + return ($authparam,$create_passwd,$authchk); +} + +sub auto_instcode_format { + my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_; + my $courses = ''; + my $homeserver; + if ($caller eq 'global') { + foreach my $tryserver (keys %libserv) { + if ($hostdom{$tryserver} eq $codedom) { + $homeserver = $tryserver; + last; + } + } + if (($env{'user.name'}) && ($env{'user.domain'} eq $codedom)) { + $homeserver = &homeserver($env{'user.name'},$codedom); + } + } else { + $homeserver = &homeserver($caller,$codedom); + } + foreach (keys %{$instcodes}) { + $courses .= &escape($_).'='.&escape($$instcodes{$_}).'&'; + } + chop($courses); + my $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$homeserver); + unless ($response =~ /(con_lost|error|no_such_host|refused)/) { + my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = split/:/,$response; + %{$codes} = &str2hash($codes_str); + @{$codetitles} = &str2array($codetitles_str); + %{$cat_titles} = &str2hash($cat_titles_str); + %{$cat_order} = &str2hash($cat_order_str); + return 'ok'; + } + return $response; +} + # ------------------------------------------------------------------ Plain Text sub plaintext { @@ -2950,7 +3328,7 @@ sub assignrole { unless (&allowed('ccr',$cwosec)) { &logthis('Refused custom assignrole: '. $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. - $ENV{'user.name'}.' at '.$ENV{'user.domain'}); + $env{'user.name'}.' at '.$env{'user.domain'}); return 'refused'; } $mrole='cr'; @@ -2960,12 +3338,12 @@ sub assignrole { 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'}); + $env{'user.name'}.' at '.$env{'user.domain'}); return 'refused'; } $mrole=$role; } - my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:". + my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:". "$udom:$uname:$url".'_'."$mrole=$role"; if ($end) { $command.='_'.$end; } if ($start) { @@ -2979,9 +3357,9 @@ sub assignrole { if ($deleteflag) { if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) { # modify command to delete the role - $command="encrypt:rolesdel:$ENV{'user.domain'}:$ENV{'user.name'}:". + $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"); + &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; @@ -3004,16 +3382,16 @@ sub modifyuserauth { my $uhome=&homeserver($uname,$udom); unless (&allowed('mau',$udom)) { return 'refused'; } &logthis('Call to modify user authentication '.$udom.', '.$uname.', '. - $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}. - ' in domain '.$ENV{'request.role.domain'}); + $umode.' by '.$env{'user.name'}.' at '.$env{'user.domain'}. + ' in domain '.$env{'request.role.domain'}); my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'. &escape($upass),$uhome); - &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'}, + &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. + 'Authentication changed by '.$env{'user.domain'}.', '. + $env{'user.name'}.', '.$umode. '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply); unless ($reply eq 'ok') { &logthis('Authentication mode error: '.$reply); @@ -3036,8 +3414,8 @@ sub modifyuser { $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'}); + ' 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') && @@ -3045,8 +3423,8 @@ sub modifyuser { 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'}; + } 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; @@ -3106,15 +3484,18 @@ sub modifyuser { 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; } - + if ($email) { + $email=~s/[^\w\@\.\-\,]//gs; + if ($email=~/\@/) { $names{'notification'} = $email; + $names{'critnotification'} = $email; + $names{'permanentemail'} = $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'}); + $env{'user.name'}.' at '.$env{'user.domain'}); return 'ok'; } @@ -3122,9 +3503,9 @@ sub modifyuser { sub modifystudent { my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, - $end,$start,$forceid,$desiredhome,$email,$type,$cid)=@_; + $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid)=@_; if (!$cid) { - unless ($cid=$ENV{'request.course.id'}) { + unless ($cid=$env{'request.course.id'}) { return 'not_in_class'; } } @@ -3137,24 +3518,23 @@ sub modifystudent { # students environment $uid = undef if (!$forceid); $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last, - $gene,$usec,$end,$start,$type,$cid); + $gene,$usec,$end,$start,$type,$locktype,$cid); return $reply; } sub modify_student_enrollment { - my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type, - $cid) = @_; + 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'}) { + unless ($cid=$env{'request.course.id'}) { return 'not_in_class'; } - $cdom=$ENV{'course.'.$cid.'.domain'}; - $cnum=$ENV{'course.'.$cid.'.num'}; + $cdom=$env{'course.'.$cid.'.domain'}; + $cnum=$env{'course.'.$cid.'.num'}; } else { ($cdom,$cnum)=split(/_/,$cid); } - $chome=$ENV{'course.'.$cid.'.home'}; + $chome=$env{'course.'.$cid.'.home'}; if (!$chome) { $chome=&homeserver($cnum,$cdom); } @@ -3185,11 +3565,11 @@ sub modify_student_enrollment { $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 $value=&escape($uname.':'.$udom).'='. - &escape(join(':',$end,$start,$uid,$usec,$fullname,$type)); - my $reply=critical('put:'.$cdom.':'.$cnum.':classlist:'.$value,$chome); + my $fullname = &format_name($first,$middle,$last,$gene,'lastname'); + 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; } @@ -3202,6 +3582,25 @@ sub modify_student_enrollment { return &assignrole($udom,$uname,$uurl,'st',$end,$start); } +sub format_name { + my ($firstname,$middlename,$lastname,$generation,$first)=@_; + my $name; + if ($first ne 'lastname') { + $name=$firstname.' '.$middlename.' '.$lastname.' '.$generation; + } else { + if ($lastname=~/\S/) { + $name.= $lastname.' '.$generation.', '.$firstname.' '.$middlename; + $name=~s/\s+,/,/; + } else { + $name.= $firstname.' '.$middlename.' '.$generation; + } + } + $name=~s/^\s+//; + $name=~s/\s+$//; + $name=~s/\s+/ /g; + return $name; +} + # ------------------------------------------------- Write to course preferences sub writecoursepref { @@ -3224,7 +3623,7 @@ sub writecoursepref { # ---------------------------------------------------------- Make/modify course sub createcourse { - my ($udom,$description,$url,$course_server,$nonstandard)=@_; + my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,$course_owner)=@_; $url=&declutter($url); my $cid=''; unless (&allowed('ccc',$udom)) { @@ -3244,7 +3643,7 @@ sub createcourse { } } # ------------------------------------------------ Check supplied server name - $course_server = $ENV{'user.homeserver'} if (! defined($course_server)); + $course_server = $env{'user.homeserver'} if (! defined($course_server)); if (! exists($libserv{$course_server})) { return 'error:bad server name '.$course_server; } @@ -3257,9 +3656,9 @@ sub createcourse { return 'error: no such course'; } # ----------------------------------------------------------------- Course made -# log existance - &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description), - $uhome); +# log existence + &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description). + ':'.&escape($inst_code).':'.&escape($course_owner),$uhome); &flushcourselogs(); # set toplevel url my $topurl=$url; @@ -3267,7 +3666,7 @@ sub createcourse { # ------------------------------------------ For standard courses, make top url my $mapurl=&clutter($url); if ($mapurl eq '/res/') { $mapurl=''; } - $ENV{'form.initmap'}=(< @@ -3312,6 +3711,193 @@ sub revokecustomrole { $deleteflag); } +# ------------------------------------------------------------ Disk usage +sub diskusage { + my ($udom,$uname,$directoryRoot)=@_; + $directoryRoot =~ s/\/$//; + my $listing=&reply('du:'.$directoryRoot,homeserver($uname,$udom)); + return $listing; +} + +sub is_locked { + my ($file_name, $domain, $user) = @_; + my @check; + my $is_locked; + push @check, $file_name; + my %locked = &get('file_permissions',\@check, + $env{'user.domain'},$env{'user.name'}); + my ($tmp)=keys(%locked); + if ($tmp=~/^error:/) { undef(%locked); } + + if (ref($locked{$file_name}) eq 'ARRAY') { + $is_locked = 'true'; + } else { + $is_locked = 'false'; + } +} + +# ------------------------------------------------------------- Mark as Read Only + +sub mark_as_readonly { + my ($domain,$user,$files,$what) = @_; + my %current_permissions = &dump('file_permissions',$domain,$user); + my ($tmp)=keys(%current_permissions); + if ($tmp=~/^error:/) { undef(%current_permissions); } + + foreach my $file (@{$files}) { + push(@{$current_permissions{$file}},$what); + } + &put('file_permissions',\%current_permissions,$domain,$user); + return; +} + +# ------------------------------------------------------------Save Selected Files + +sub save_selected_files { + my ($user, $path, @files) = @_; + my $filename = $user."savedfiles"; + my @other_files = &files_not_in_path($user, $path); + open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); + foreach my $file (@files) { + print (OUT $env{'form.currentpath'}.$file."\n"); + } + foreach my $file (@other_files) { + print (OUT $file."\n"); + } + close (OUT); + return 'ok'; +} + +sub clear_selected_files { + my ($user) = @_; + my $filename = $user."savedfiles"; + open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); + print (OUT undef); + close (OUT); + return ("ok"); +} + +sub files_in_path { + my ($user, $path) = @_; + my $filename = $user."savedfiles"; + my %return_files; + open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); + while (my $line_in = ) { + chomp ($line_in); + my @paths_and_file = split (m!/!, $line_in); + my $file_part = pop (@paths_and_file); + my $path_part = join ('/', @paths_and_file); + $path_part.='/'; + my $path_and_file = $path_part.$file_part; + if ($path_part eq $path) { + $return_files{$file_part}= 'selected'; + } + } + close (IN); + return (\%return_files); +} + +# called in portfolio select mode, to show files selected NOT in current directory +sub files_not_in_path { + my ($user, $path) = @_; + my $filename = $user."savedfiles"; + my @return_files; + my $path_part; + open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); + while () { + #ok, I know it's clunky, but I want it to work + my @paths_and_file = split m!/!, $_; + my $file_part = pop (@paths_and_file); + chomp ($file_part); + my $path_part = join ('/', @paths_and_file); + $path_part .= '/'; + my $path_and_file = $path_part.$file_part; + if ($path_part ne $path) { + push (@return_files, ($path_and_file)); + } + } + close (OUT); + return (@return_files); +} + +#--------------------------------------------------------------Get Marked as Read Only + +sub get_marked_as_readonly { + my ($domain,$user,$what) = @_; + my %current_permissions = &dump('file_permissions',$domain,$user); + my ($tmp)=keys(%current_permissions); + if ($tmp=~/^error:/) { undef(%current_permissions); } + + my @readonly_files; + while (my ($file_name,$value) = each(%current_permissions)) { + if (ref($value) eq "ARRAY"){ + foreach my $stored_what (@{$value}) { + if ($stored_what eq $what) { + push(@readonly_files, $file_name); + } elsif (!defined($what)) { + push(@readonly_files, $file_name); + } + } + } + } + return @readonly_files; +} +#-----------------------------------------------------------Get Marked as Read Only Hash + +sub get_marked_as_readonly_hash { + my ($domain,$user,$what) = @_; + my %current_permissions = &dump('file_permissions',$domain,$user); + my ($tmp)=keys(%current_permissions); + if ($tmp=~/^error:/) { undef(%current_permissions); } + + my %readonly_files; + while (my ($file_name,$value) = each(%current_permissions)) { + if (ref($value) eq "ARRAY"){ + foreach my $stored_what (@{$value}) { + if ($stored_what eq $what) { + $readonly_files{$file_name} = 'locked'; + } elsif (!defined($what)) { + $readonly_files{$file_name} = 'locked'; + } + } + } + } + return %readonly_files; +} +# ------------------------------------------------------------ Unmark as Read Only + +sub unmark_as_readonly { + # unmarks all files locked by $what + # for portfolio submissions, $what contains $crsid and $symb + my ($domain,$user,$what) = @_; + my %current_permissions = &dump('file_permissions',$domain,$user); + my ($tmp)=keys(%current_permissions); + if ($tmp=~/^error:/) { undef(%current_permissions); } + + my @readonly_files = &get_marked_as_readonly($domain,$user,$what); + foreach my $file(@readonly_files){ + my $current_locks = $current_permissions{$file}; + my @new_locks; + my @del_keys; + if (ref($current_locks) eq "ARRAY"){ + foreach my $locker (@{$current_locks}) { + unless ($locker eq $what) { + push(@new_locks, $what); + } + } + if (@new_locks > 0) { + $current_permissions{$file} = \@new_locks; + } else { + push(@del_keys, $file); + &del('file_permissions',\@del_keys, $domain, $user); + delete $current_permissions{$file}; + } + } + } + &put('file_permissions',\%current_permissions,$domain,$user); + return; +} + # ------------------------------------------------------------ Directory lister sub dirlist { @@ -3336,19 +3922,37 @@ sub dirlist { if($udom) { if($uname) { - my $listing=reply('ls:'.$dirRoot.'/'.$uri, + my $listing=reply('ls2:'.$dirRoot.'/'.$uri, homeserver($uname,$udom)); - return split(/:/,$listing); + my @listing_results; + if ($listing eq 'unknown_cmd') { + $listing=reply('ls:'.$dirRoot.'/'.$uri, + homeserver($uname,$udom)); + @listing_results = split(/:/,$listing); + } else { + @listing_results = map { &unescape($_); } split(/:/,$listing); + } + return @listing_results; } elsif(!defined($alternateDirectoryRoot)) { my $tryserver; my %allusers=(); foreach $tryserver (keys %libserv) { if($hostdom{$tryserver} eq $udom) { - my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'. + my $listing=reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'. $udom, $tryserver); - if (($listing ne 'no_such_dir') && ($listing ne 'empty') - && ($listing ne 'con_lost')) { - foreach (split(/:/,$listing)) { + my @listing_results; + if ($listing eq 'unknown_cmd') { + $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'. + $udom, $tryserver); + @listing_results = split(/:/,$listing); + } else { + @listing_results = + map { &unescape($_); } split(/:/,$listing); + } + if ($listing_results[0] ne 'no_such_dir' && + $listing_results[0] ne 'empty' && + $listing_results[0] ne 'con_lost') { + foreach (@listing_results) { my ($entry,@stat)=split(/&/,$_); $allusers{$entry}=1; } @@ -3420,8 +4024,11 @@ sub GetFileTimestamp { sub directcondval { my $number=shift; - if ($ENV{'user.state.'.$ENV{'request.course.id'}}) { - return substr($ENV{'user.state.'.$ENV{'request.course.id'}},$number,1); + if (!defined($env{'user.state.'.$env{'request.course.id'}})) { + &Apache::lonuserstate::evalstate(); + } + if ($env{'user.state.'.$env{'request.course.id'}}) { + return substr($env{'user.state.'.$env{'request.course.id'}},$number,1); } else { return 2; } @@ -3432,13 +4039,13 @@ sub condval { my $result=0; my $allpathcond=''; foreach (split(/\|/,$condidx)) { - if (defined($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_})) { + if (defined($env{'acc.cond.'.$env{'request.course.id'}.'.'.$_})) { $allpathcond.= - '('.$ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_}.')|'; + '('.$env{'acc.cond.'.$env{'request.course.id'}.'.'.$_}.')|'; } } $allpathcond=~s/\|$//; - if ($ENV{'request.course.id'}) { + if ($env{'request.course.id'}) { if ($allpathcond) { my $operand='|'; my @stack; @@ -3473,7 +4080,7 @@ sub condval { sub devalidatecourseresdata { my ($coursenum,$coursedomain)=@_; my $hashid=$coursenum.':'.$coursedomain; - &devalidate_cache(\%courseresdatacache,$hashid,'courseres'); + &devalidate_cache_new('courseres',$hashid); } # --------------------------------------------------- Course Resourcedata Query @@ -3482,18 +4089,18 @@ sub courseresdata { my ($coursenum,$coursedomain,@which)=@_; my $coursehom=&homeserver($coursenum,$coursedomain); my $hashid=$coursenum.':'.$coursedomain; - my ($result,$cached)=&is_cached(\%courseresdatacache,$hashid,'courseres'); + my ($result,$cached)=&is_cached_new('courseres',$hashid); 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'); + &do_cache_new('courseres',$hashid,$result,600); } elsif ($tmp =~ /^(con_lost|no_such_host)/) { return $tmp; } elsif ($tmp =~ /^(error)/) { $result=undef; - &do_cache(\%courseresdatacache,$hashid,$result,'courseres'); + &do_cache_new('courseres',$hashid,$result,600); } } foreach my $item (@which) { @@ -3515,7 +4122,7 @@ sub clear_EXT_cache_status { 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) { + if (exists($env{$cachename}) && ($env{$cachename}+600) > time) { # We know already the user has no data return 1; } else { @@ -3545,7 +4152,7 @@ sub EXT { &Apache::lonxml::whichuser($symbparm); if (!$symbparm) { $symbparm=$cursymb; } } else { - $courseid=$ENV{'request.course.id'}; + $courseid=$env{'request.course.id'}; } my ($realm,$space,$qualifier,@therest)=split(/\./,$varname); my $rest; @@ -3562,11 +4169,12 @@ sub EXT { if ($realm eq 'user') { # --------------------------------------------------------------- user.resource if ($space eq 'resource') { - if (defined($Apache::lonhomework::parsing_a_problem)) { + if (defined($Apache::lonhomework::parsing_a_problem) || + defined($Apache::lonhomework::parsing_a_task)) { return $Apache::lonhomework::history{$qualifierrest}; } else { my %restored; - if ($publicuser || $ENV{'request.state'} eq 'construct') { + if ($publicuser || $env{'request.state'} eq 'construct') { %restored=&tmprestore($symbparm,$courseid,$udom,$uname); } else { %restored=&restore($symbparm,$courseid,$udom,$uname); @@ -3579,9 +4187,9 @@ sub EXT { 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))}; + if (($uname eq $env{'user.name'}) && + ($udom eq $env{'user.domain'})) { + return $env{join('.',('environment',$qualifierrest))}; } else { my %returnhash; if (!$publicuser) { @@ -3593,11 +4201,11 @@ sub EXT { # ----------------------------------------------------------------- user.course } elsif ($space eq 'course') { # FIXME - not supporting calls for a specific user - return $ENV{join('.',('request.course',$qualifier))}; + 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'}); + my ($role,$where)=split(/\./,$env{'request.role'}); if ($qualifier eq 'value') { return $role; } elsif ($qualifier eq 'extent') { @@ -3621,7 +4229,7 @@ sub EXT { # ---------------------------------------------- pull stuff out of query string &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'}, [$spacequalifierrest]); - return $ENV{'form.'.$spacequalifierrest}; + return $env{'form.'.$spacequalifierrest}; } elsif ($realm eq 'request') { # ------------------------------------------------------------- request.browser if ($space eq 'browser') { @@ -3632,59 +4240,62 @@ sub EXT { return 0; } } else { - return $ENV{'browser.'.$qualifier}; + return $env{'browser.'.$qualifier}; } # ------------------------------------------------------------ request.filename } else { - return $ENV{'request.'.$spacequalifierrest}; + return $env{'request.'.$spacequalifierrest}; } } elsif ($realm eq 'course') { # ---------------------------------------------------------- course.description - return $ENV{'course.'.$courseid.'.'.$spacequalifierrest}; + return $env{'course.'.$courseid.'.'.$spacequalifierrest}; } elsif ($realm eq 'resource') { my $section; - if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) { + if (defined($courseid) && $courseid eq $env{'request.course.id'}) { + if (!$symbparm) { $symbparm=&symbread(); } + } + my ($courselevelm,$courselevel); + if ($symbparm && 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'}; + 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; - } + if (! defined($usection)) { + $section=&getsection($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; + $courselevel=$courseid.'.'.$spacequalifierrest; my $courselevelr=$courseid.'.'.$symbparm; - my $courselevelm=$courseid.'.'.$mapparm; + $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'); + my ($result,$cached)=&is_cached_new('userres',$hashid); if (!defined($cached)) { my %resourcedata=&dump('resourcedata',$udom,$uname); $result=\%resourcedata; - &do_cache(\%userresdatacache,$hashid,$result,'userres'); + &do_cache_new('userres',$hashid,$result,600); } my ($tmp)=keys(%$result); if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) { @@ -3695,40 +4306,40 @@ 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/) { - &EXT_cache_set($udom,$uname); + } elsif ($tmp=~/error: 2 /) { + &EXT_cache_set($udom,$uname); } elsif ($tmp =~ /^(con_lost|no_such_host)/) { return $tmp; } } } -# -------------------------------------------------------- second, check course +# ------------------------------------------------ second, check some of course - my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'}, - $ENV{'course.'.$courseid.'.domain'}, - ($seclevelr,$seclevelm,$seclevel, - $courselevelr,$courselevelm, - $courselevel)); + my $coursereply=&courseresdata($env{'course.'.$courseid.'.num'}, + $env{'course.'.$courseid.'.domain'}, + ($seclevelr,$seclevelm,$seclevel, + $courselevelr)); if (defined($coursereply)) { return $coursereply; } # ------------------------------------------------------ third, check map parms my %parmhash=(); my $thisparm=''; if (tie(%parmhash,'GDBM_File', - $ENV{'request.course.fn'}.'_parms.db', + $env{'request.course.fn'}.'_parms.db', &GDBM_READER(),0640)) { $thisparm=$parmhash{$symbparm}; untie(%parmhash); } if ($thisparm) { return $thisparm; } } -# --------------------------------------------- last, look in resource metadata +# ------------------------------------------ fourth, look in resource metadata $spacequalifierrest=~s/\./\_/; my $filename; @@ -3736,13 +4347,21 @@ sub EXT { if ($symbparm) { $filename=(&decode_symb($symbparm))[2]; } else { - $filename=$ENV{'request.filename'}; + $filename=$env{'request.filename'}; } my $metadata=&metadata($filename,$spacequalifierrest); if (defined($metadata)) { return $metadata; } $metadata=&metadata($filename,'parameter_'.$spacequalifierrest); if (defined($metadata)) { return $metadata; } +# ---------------------------------------------- fourth, look in rest pf course + if ($symbparm && defined($courseid) && + $courseid eq $env{'request.course.id'}) { + my $coursereply=&courseresdata($env{'course.'.$courseid.'.num'}, + $env{'course.'.$courseid.'.domain'}, + ($courselevelm,$courselevel)); + if (defined($coursereply)) { return $coursereply; } + } # ------------------------------------------------------------------ Cascade up unless ($space eq '0') { my @parts=split(/_/,$space); @@ -3760,8 +4379,8 @@ sub EXT { # ---------------------------------------------------- Any other user namespace } elsif ($realm eq 'environment') { # ----------------------------------------------------------------- environment - if (($uname eq $ENV{'user.name'})&&($udom eq $ENV{'user.domain'})) { - return $ENV{'environment.'.$spacequalifierrest}; + if (($uname eq $env{'user.name'})&&($udom eq $env{'user.domain'})) { + return $env{'environment.'.$spacequalifierrest}; } else { my %returnhash=&userenvironment($udom,$uname, $spacequalifierrest); @@ -3782,9 +4401,13 @@ 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 ($pack_type eq 'part') { $pack_part='0'; } + if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) { + return $packagetab{$pack_type."_".$pack_part."&$name&default"}; + } } return undef; } @@ -3807,14 +4430,17 @@ sub add_prefix_and_part { # ---------------------------------------------------------------- Get metadata +my %metaentry; 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|)) || + if (($uri eq '') || + (($uri =~ m|^/*adm/|) && + ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) || ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) || ($uri =~ m|home/[^/]+/public_html/|)) { - return ''; + return undef; } my $filename=$uri; $uri=~s/\.meta$//; @@ -3824,25 +4450,31 @@ sub metadata { # Everything is cached by the main uri, libraries are never directly cached # if (!defined($liburi)) { - my ($result,$cached)=&is_cached(\%metacache,$uri,'meta'); + my ($result,$cached)=&is_cached_new('meta',$uri); if (defined($cached)) { return $result->{':'.$what}; } } { # # Is this a recursive call for a library? # - if (! exists($metacache{$uri})) { - $metacache{$uri}={}; - } +# if (! exists($metacache{$uri})) { +# $metacache{$uri}={}; +# } if ($liburi) { $liburi=&declutter($liburi); $filename=$liburi; } else { - &devalidate_cache(\%metacache,$uri,'meta'); + &devalidate_cache_new('meta',$uri); + undef(%metaentry); } my %metathesekeys=(); unless ($filename=~/\.meta$/) { $filename.='.meta'; } - my $metastring=&getfile(&filelocation('',&clutter($filename))); + my $metastring; + if ($uri !~ m -^(uploaded|editupload)/-) { + my $file=&filelocation('',&clutter($filename)); + #push(@{$metaentry{$uri.'.file'}},$file); + $metastring=&getfile($file); + } my $parser=HTML::LCParser->new(\$metastring); my $token; undef %metathesekeys; @@ -3857,12 +4489,12 @@ sub metadata { if (defined($token->[2]->{'id'})) { $keyroot.='_'.$token->[2]->{'id'}; } - if ($metacache{$uri}->{':packages'}) { - $metacache{$uri}->{':packages'}.=','.$package.$keyroot; + if ($metaentry{':packages'}) { + $metaentry{':packages'}.=','.$package.$keyroot; } else { - $metacache{$uri}->{':packages'}=$package.$keyroot; + $metaentry{':packages'}=$package.$keyroot; } - foreach (keys %packagetab) { + foreach (sort keys %packagetab) { my $part=$keyroot; $part=~s/^\_//; if ($_=~/^\Q$package\E\&/ || @@ -3882,14 +4514,14 @@ sub metadata { if ($subp eq 'display') { $value.=' [Part: '.$part.']'; } - $metacache{$uri}->{':'.$unikey.'.part'}=$part; + $metaentry{':'.$unikey.'.part'}=$part; $metathesekeys{$unikey}=1; - unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) { - $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value; + unless (defined($metaentry{':'.$unikey.'.'.$subp})) { + $metaentry{':'.$unikey.'.'.$subp}=$value; } - if (defined($metacache{$uri}->{':'.$unikey.'.default'})) { - $metacache{$uri}->{':'.$unikey}= - $metacache{$uri}->{':'.$unikey.'.default'}; + if (defined($metaentry{':'.$unikey.'.default'})) { + $metaentry{':'.$unikey}= + $metaentry{':'.$unikey.'.default'}; } } } @@ -3922,7 +4554,7 @@ sub metadata { foreach (sort(split(/\,/,&metadata($uri,'keys', $location,$unikey, $depthcount+1)))) { - $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_}; + $metaentry{':'.$_}=$metaentry{':'.$_}; $metathesekeys{$_}=1; } } @@ -3933,18 +4565,18 @@ sub metadata { } $metathesekeys{$unikey}=1; foreach (@{$token->[3]}) { - $metacache{$uri}->{':'.$unikey.'.'.$_}=$token->[2]->{$_}; + $metaentry{':'.$unikey.'.'.$_}=$token->[2]->{$_}; } my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry)); - my $default=$metacache{$uri}->{':'.$unikey.'.default'}; + my $default=$metaentry{':'.$unikey.'.default'}; if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) { # only ws inside the tag, and not in default, so use default # as value - $metacache{$uri}->{':'.$unikey}=$default; + $metaentry{':'.$unikey}=$default; } else { # either something interesting inside the tag or default # uninteresting - $metacache{$uri}->{':'.$unikey}=$internaltext; + $metaentry{':'.$unikey}=$internaltext; } # end of not-a-package not-a-library import } @@ -3953,32 +4585,72 @@ 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($metaentry{':packages'})) { + foreach my $key (sort(keys(%packagetab))) { + #no specific packages well let's get default then + if ($key!~/^default&/) { next; } + &metadata_create_package_def($uri,$key,'default', + \%metathesekeys); + } + } # are there custom rights to evaluate - if ($metacache{$uri}->{':copyright'} eq 'custom') { + if ($metaentry{':copyright'} eq 'custom') { # # Importing a rights file here # unless ($depthcount) { - my $location=$metacache{$uri}->{':customdistributionfile'}; + my $location=$metaentry{':customdistributionfile'}; my $dir=$filename; $dir=~s|[^/]*$||; $location=&filelocation($dir,$location); foreach (sort(split(/\,/,&metadata($uri,'keys', $location,'_rights', $depthcount+1)))) { - $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_}; + #$metaentry{':'.$_}=$metacache{$uri}->{':'.$_}; $metathesekeys{$_}=1; } } } - $metacache{$uri}->{':keys'}=join(',',keys %metathesekeys); - &metadata_generate_part0(\%metathesekeys,$metacache{$uri},$uri); - $metacache{$uri}->{':allpossiblekeys'}=join(',',keys %metathesekeys); - &do_cache(\%metacache,$uri,$metacache{$uri},'meta'); + $metaentry{':keys'}=join(',',keys %metathesekeys); + &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); + $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys); + &do_cache_new('meta',$uri,\%metaentry,60*60*24); # this is the end of "was not already recently cached } - return $metacache{$uri}->{':'.$what}; + return $metaentry{':'.$what}; +} + +sub metadata_create_package_def { + my ($uri,$key,$package,$metathesekeys)=@_; + my ($pack,$name,$subp)=split(/\&/,$key); + if ($subp eq 'default') { next; } + + if (defined($metaentry{':packages'})) { + $metaentry{':packages'}.=','.$package; + } else { + $metaentry{':packages'}=$package; + } + my $value=$packagetab{$key}; + my $unikey; + $unikey='parameter_0_'.$name; + $metaentry{':'.$unikey.'.part'}=0; + $$metathesekeys{$unikey}=1; + unless (defined($metaentry{':'.$unikey.'.'.$subp})) { + $metaentry{':'.$unikey.'.'.$subp}=$value; + } + if (defined($metaentry{':'.$unikey.'.default'})) { + $metaentry{':'.$unikey}= + $metaentry{':'.$unikey.'.default'}; + } } sub metadata_generate_part0 { @@ -4004,7 +4676,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; } } @@ -4014,40 +4686,60 @@ sub metadata_generate_part0 { 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'); + if ($symb) { + my $key=$env{'request.course.id'}."\0".$symb; + my ($result,$cached)=&is_cached_new('title',$key); + 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_new('title',$key,$title,600); + } + $urlsymb=$url; + } + my $title=&metadata($urlsymb,'title'); + if (!$title) { $title=(split('/',$urlsymb))[-1]; } + return $title; +} + +sub get_slot { + my ($which,$cnum,$cdom)=@_; + if (!$cnum || !$cdom) { + (undef,my $courseid)=&Apache::lonxml::whichuser(); + $cdom=$env{'course.'.$courseid.'.domain'}; + $cnum=$env{'course.'.$courseid.'.num'}; + } + my %slotinfo=&get('slots',[$which],$cdom,$cnum); + &Apache::lonhomework::showhash(%slotinfo); + my ($tmp)=keys(%slotinfo); + if ($tmp=~/^error:/) { return (); } + if (ref($slotinfo{$which}) eq 'HASH') { + return %{$slotinfo{$which}}; } + return $slotinfo{$which}; } - # ------------------------------------------------- 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', + 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{$_}); + $hash{declutter($_)}=&encode_symb($mapname,$newhash{$_}->[1], + $newhash{$_}->[0]); } if (untie(%hash)) { return 'ok'; @@ -4060,7 +4752,10 @@ sub symblist { # --------------------------------------------------------------- Verify a symb sub symbverify { - my ($symb,$thisfn)=@_; + my ($symb,$thisurl)=@_; + my $thisfn=$thisurl; +# wrapper not part of symbs + $thisfn=~s/^\/adm\/wrapper//; $thisfn=&declutter($thisfn); # direct jump to resource in page or to a sequence - will construct own symbs if ($thisfn=~/\.(page|sequence)$/) { return 1; } @@ -4070,16 +4765,17 @@ sub symbverify { 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', + 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) @@ -4088,8 +4784,11 @@ sub symbverify { if ( &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) eq $symb) { - $okay=1; - } + if (($env{'request.role.adv'}) || + $bighash{'encrypted_'.$_} eq $env{'request.enc'}) { + $okay=1; + } + } } } untie(%bighash); @@ -4101,13 +4800,16 @@ sub symbverify { sub symbclean { my $symb=shift; - + if ($symb=~m|^/enc/|) { $symb=&Apache::lonenc::unencrypted($symb); } # remove version from map $symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/; # remove version from URL $symb=~s/\.(\d+)\.(\w+)$/\.$2/; +# remove wrapper + + $symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/; return $symb; } @@ -4119,22 +4821,23 @@ sub encode_symb { } sub decode_symb { - my ($map,$resid,$url)=split(/\_\_\_/,shift); + my $symb=shift; + if ($symb=~m|^/enc/|) { $symb=&Apache::lonenc::unencrypted($symb); } + my ($map,$resid,$url)=split(/___/,$symb); return (&fixversion($map),$resid,&fixversion($url)); } sub fixversion { my $fn=shift; - if ($fn=~/^(adm|uploaded|public)/) { return $fn; } + if ($fn=~/^(adm|uploaded|editupload|public)/) { return $fn; } my %bighash; my $uri=&clutter($fn); - my $key=$ENV{'request.course.id'}.'_'.$uri; + my $key=$env{'request.course.id'}.'_'.$uri; # is this cached? - my ($result,$cached)=&is_cached(\%courseresversioncache,$key, - 'courseresversion',600); + my ($result,$cached)=&is_cached_new('courseresversion',$key); if (defined($cached)) { return $result; } # unfortunately not cached, or expired - if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', + if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db', &GDBM_READER(),0640)) { if ($bighash{'version_'.$uri}) { my $version=$bighash{'version_'.$uri}; @@ -4145,8 +4848,7 @@ sub fixversion { } untie %bighash; } - return &do_cache - (\%courseresversioncache,$key,&declutter($uri),'courseresversion'); + return &do_cache_new('courseresversion',$key,&declutter($uri),600); } sub deversion { @@ -4159,37 +4861,48 @@ sub deversion { sub symbread { my ($thisfn,$donotrecurse)=@_; + my $cache_str='request.symbread.cached.'.$thisfn; + if (defined($env{$cache_str})) { return $env{$cache_str}; } # no filename provided? try from environment unless ($thisfn) { - if ($ENV{'request.symb'}) { return &symbclean($ENV{'request.symb'}); } - $thisfn=$ENV{'request.filename'}; + if ($env{'request.symb'}) { + return $env{$cache_str}=&symbclean($env{'request.symb'}); + } + $thisfn=$env{'request.filename'}; } + if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); } # is that filename actually a symb? Verify, clean, and return if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) { - if (&symbverify($thisfn,$1)) { return &symbclean($thisfn); } + if (&symbverify($thisfn,$1)) { + return $env{$cache_str}=&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', + if (($env{'request.course.fn'}) && ($thisfn)) { + my $targetfn = $thisfn; + if ( ($thisfn =~ m/^(uploaded|editupload)\//) && ($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 if ($syval) { - unless ($syval=~/\_\d+$/) { - unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) { - &appenv('request.ambiguous' => $thisfn); - return ''; - } - $syval.=$1; - } + #unless ($syval=~/\_\d+$/) { + #unless ($env{'form.request.prefix'}=~/\.(\d+)\_$/) { + #&appenv('request.ambiguous' => $thisfn); + #return $env{$cache_str}=''; + #} + #$syval.=$1; + #} } else { # ------------------------------------------------------- Was not in symb table - if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', + 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)}; @@ -4227,14 +4940,15 @@ sub symbread { } } untie(%bighash) - } + } } if ($syval) { - return &symbclean($syval.'___'.$thisfn); + return $env{$cache_str}=$syval; + #return $env{$cache_str}=&symbclean($syval.'___'.$thisfn); } } &appenv('request.ambiguous' => $thisfn); - return ''; + return $env{$cache_str}=''; } # ---------------------------------------------------------- Return random seed @@ -4248,11 +4962,70 @@ sub numval { $txt=~tr/U-Z/0-5/; $txt=~tr/u-z/0-5/; $txt=~s/\D//g; + if ($_64bit) { if ($txt > 2**32) { return -1; } } 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; } + if ($_64bit) { if ($total > 2**32) { return -1; } } + return int($total); +} + +sub numval3 { + use integer; + 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; } + if ($_64bit) { $total=(($total<<32)>>32); } + return $total; +} + sub latest_rnd_algorithm_id { - return '64bit2'; + return '64bit4'; +} + +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 validCODE { + my ($CODE)=@_; + if (defined($CODE) && $CODE ne '' && $CODE =~ /^\w+$/) { return 1; } + return 0; +} + +sub getCODE { + if (&validCODE($env{'form.CODE'})) { return $env{'form.CODE'}; } + if ( (defined($Apache::lonhomework::parsing_a_problem) || + defined($Apache::lonhomework::parsing_a_task) ) && + &validCODE($Apache::lonhomework::history{'resource.CODE'})) { + return $Apache::lonhomework::history{'resource.CODE'}; + } + return undef; } sub rndseed { @@ -4265,10 +5038,17 @@ 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())) { + if ($which eq '64bit4') { + return &rndseed_CODE_64bit4($symb,$courseid,$domain,$username); + } else { + return &rndseed_CODE_64bit($symb,$courseid,$domain,$username); + } + } elsif ($which eq '64bit4') { + return &rndseed_64bit4($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') { @@ -4290,6 +5070,7 @@ sub rndseed_32bit { my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck; #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); #&Apache::lonxml::debug("rndseed :$num:$symb"); + if ($_64bit) { $num=(($num<<32)>>32); } return $num; } } @@ -4310,6 +5091,8 @@ sub rndseed_64bit { my $num2=$nameseed+$domainseed+$courseseed; #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); #&Apache::lonxml::debug("rndseed :$num:$symb"); + if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } + if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } return "$num1,$num2"; } } @@ -4336,117 +5119,375 @@ sub rndseed_64bit2 { } } +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 :$num1:$num2:$_64bit"); + if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } + + return "$num1:$num2"; + } +} + +sub rndseed_64bit4 { + 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=numval3($symb) << 10; + my $namechck=unpack("%32S*",$username.' '); + + my $nameseed=numval3($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 :$num1:$num2:$_64bit"); + if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } + + 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 $symbseed=numval2($symb); + my $CODEchck=unpack("%32S*",&getCODE().' ') << 16; + my $CODEseed=numval(&getCODE()); my $courseseed=unpack("%32S*",$courseid.' '); - my $num1=$symbseed+$CODEseed; - my $num2=$courseseed+$symbchck; - #&Apache::lonxml::debug("$symbseed:$CODEseed|$courseseed:$symbchck"); + 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"; + if ($_64bit) { $num1=(($num1<<32)>>32); } + if ($_64bit) { $num2=(($num2<<32)>>32); } + return "$num1:$num2"; + } +} + +sub rndseed_CODE_64bit4 { + my ($symb,$courseid,$domain,$username)=@_; + { + use integer; + my $symbchck=unpack("%32S*",$symb.' ') << 16; + my $symbseed=numval3($symb); + my $CODEchck=unpack("%32S*",&getCODE().' ') << 16; + my $CODEseed=numval3(&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"); + if ($_64bit) { $num1=(($num1<<32)>>32); } + if ($_64bit) { $num2=(($num2<<32)>>32); } + 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) = @_; + if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); } + &repcopy($file); + return &readfile($file); +} + +sub repcopy_userfile { + my ($file)=@_; + if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); } + if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'ok'; } + my ($cdom,$cnum,$filename) = + ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+([^/]+)/+([^/]+)/+(.*)|); + my ($info,$rtncode); + my $uri="/uploaded/$cdom/$cnum/$filename"; + if (-e "$file") { + my @fileinfo = stat($file); + my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode); + if ($lwpresp ne 'ok') { + if ($rtncode eq '404') { + unlink($file); + } + #my $ua=new LWP::UserAgent; + #my $request=new HTTP::Request('GET',&tokenwrapper($uri)); + #my $response=$ua->request($request); + #if ($response->is_success()) { + # return $response->content; + # } else { + # return -1; + # } + return -1; + } + if ($info < $fileinfo[9]) { + return 'ok'; + } + $info = ''; + $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode); + if ($lwpresp ne 'ok') { + return -1; + } + } else { + my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode); + if ($lwpresp ne 'ok') { + my $ua=new LWP::UserAgent; + my $request=new HTTP::Request('GET',&tokenwrapper($uri)); + my $response=$ua->request($request); + if ($response->is_success()) { + $info=$response->content; + } else { + return -1; + } + } + my @parts = ($cdom,$cnum); + if ($filename =~ m|^(.+)/[^/]+$|) { + push @parts, split(/\//,$1); + } + my $path = $perlvar{'lonDocRoot'}.'/userfiles'; + foreach my $part (@parts) { + $path .= '/'.$part; + if (!-e $path) { + mkdir($path,0770); + } + } + } + open(FILE,">$file"); + print FILE $info; + close(FILE); + return 'ok'; +} + +sub tokenwrapper { + my $uri=shift; + $uri=~s|^http\://([^/]+)||; + $uri=~s|^/||; + $env{'user.environment'}=~/\/([^\/]+)\.id/; + my $token=$1; + my (undef,$udom,$uname,$file)=split('/',$uri,4); + if ($udom && $uname && $file) { + $file=~s|(\?\.*)*$||; + &appenv("userfile.$udom/$uname/$file" => $env{'request.course.id'}); + return 'http://'.$hostname{ &homeserver($uname,$udom)}.'/'.$uri. + (($uri=~/\?/)?'&':'?').'token='.$token. + '&tokenissued='.$perlvar{'lonHostID'}; + } else { + return '/adm/notfound.html'; + } +} + +sub getuploaded { + my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_; + $uri=~s/^\///; + $uri = 'http://'.$hostname{ &homeserver($cnum,$cdom)}.'/raw/'.$uri; my $ua=new LWP::UserAgent; - my $request=new HTTP::Request('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; - open($fh,"<$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 { - 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; + 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|editupload)/) { # is an uploaded file + my ($udom,$uname,$filename)= + ($file=~m -^/+(?:uploaded|editupload)/+([^/]+)/+([^/]+)/+(.*)$-); + my $home=&homeserver($uname,$udom); + my $is_me=0; + my @ids=¤t_machine_ids(); + foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } } + if ($is_me) { + $location=&Apache::loncommon::propath($udom,$uname). + '/userfiles/'.$filename; + } else { + $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'. + $udom.'/'.$uname.'/'.$filename; + } } else { - $location = '/home/httpd/html/res'.$file; + $file=~s/^\Q$perlvar{'lonDocRoot'}\E//; + $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; + $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'}//; + if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); } + $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//; $thisfn=~s/^\///; $thisfn=~s/^res\///; $thisfn=~s/\?.+$//; @@ -4457,12 +5498,21 @@ sub declutter { sub clutter { my $thisfn='/'.&declutter(shift); - unless ($thisfn=~/^\/(uploaded|adm|userfiles|ext|raw|priv)\//) { + unless ($thisfn=~/^\/(uploaded|editupload|adm|userfiles|ext|raw|priv|public)\//) { $thisfn='/res'.$thisfn; } return $thisfn; } +sub freeze_escape { + my ($value)=@_; + if (ref($value)) { + $value=&nfreeze($value); + return '__FROZEN__'.&escape($value); + } + return &escape($value); +} + # -------------------------------------------------------- Escape Special Chars sub escape { @@ -4479,11 +5529,21 @@ sub unescape { return $str; } +sub thaw_unescape { + my ($value)=@_; + if ($value =~ /^__FROZEN__/) { + substr($value,0,10,undef); + $value=&unescape($value); + return &thaw($value); + } + return &unescape($value); +} + sub mod_perl_version { + return 1; if (defined($perlvar{'MODPERL2'})) { return 2; } - return 1; } sub correct_line_ends { @@ -4496,17 +5556,20 @@ sub correct_line_ends { sub goodbye { &logthis("Starting Shut down"); #not converted to using infrastruture and probably shouldn't be - &logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache))); + &logthis(sprintf("%-20s is %s",'%badServerCache',length(&freeze(\%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))); +# &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache))); + &logthis(sprintf("%-20s is %s",'%homecache',length(&freeze(\%homecache)))); +# &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache)))); +# &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%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))); +# &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&freeze(\%userresdatacache)))); +# &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&freeze(\%getsectioncache)))); +# &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&freeze(\%courseresversioncache)))); +# &logthis(sprintf("%-20s is %s",'%resversioncache',length(&freeze(\%resversioncache)))); + &logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered)))); + &logthis(sprintf("%-20s is %s",'kicks',$kicks)); + &logthis(sprintf("%-20s is %s",'hits',$hits)); &flushcourselogs(); &logthis("Shutting down"); return DONE; @@ -4516,10 +5579,11 @@ BEGIN { # ----------------------------------- Read loncapa.conf and loncapa_apache.conf unless ($readit) { { + # FIXME: Use LONCAPA::Configuration::read_conf here and omit next block open(my $config,") { - if ($configline =~ /^[^\#]*PerlSetVar/) { + if ($configline=~/\S/ && $configline =~ /^[^\#]*PerlSetVar/) { my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); chomp($varvalue); $perlvar{$varname}=$varvalue; @@ -4576,20 +5640,32 @@ BEGIN { while (my $configline=<$config>) { next if ($configline =~ /^(\#|\s*$)/); chomp($configline); - my ($id,$domain,$role,$name,$ip,$domdescr)=split(/:/,$configline); - if ($id && $domain && $role && $name && $ip) { + my ($id,$domain,$role,$name)=split(/:/,$configline); + $name=~s/\s//g; + if ($id && $domain && $role && $name) { $hostname{$id}=$name; $hostdom{$id}=$domain; - $hostip{$id}=$ip; - $iphost{$ip}=$id; if ($role eq 'library') { $libserv{$id}=$name; } - } else { - if ($configline) { - &logthis("Skipping hosts.tab line -$configline-"); - } } } close($config); + # FIXME: dev server don't want this, production servers _do_ want this + #&get_iphost(); +} + +sub get_iphost { + if (%iphost) { return %iphost; } + foreach my $id (keys(%hostname)) { + my $name=$hostname{$id}; + my $ip = gethostbyname($name); + if (!$ip || length($ip) ne 4) { + &logthis("Skipping host $id name $name no IP found\n"); + next; + } + $ip=inet_ntoa($ip); + push(@{$iphost{$ip}},$id); + } + return %iphost; } # ------------------------------------------------------ Read spare server file @@ -4637,6 +5713,7 @@ BEGIN { open(my $config,"<$perlvar{'lonTabDir'}/packages.tab"); while (my $configline=<$config>) { + if ($configline !~ /\S/ || $configline=~/^#/) { next; } chomp($configline); my ($short,$plain)=split(/:/,$configline); my ($pack,$name)=split(/\&/,$short); @@ -4654,7 +5731,7 @@ BEGIN { } -%metacache=(); +$memcache=new Cache::Memcached({'servers'=>['127.0.0.1:11211']}); $processmarker='_'.time.'_'.$perlvar{'lonHostID'}; $dumpcount=0; @@ -4662,6 +5739,12 @@ $dumpcount=0; &logtouch(); &logthis('INFO: Read configuration'); $readit=1; + { + use integer; + my $test=(2**32)+1; + if ($test != 0) { $_64bit=1; } else { $_64bit=0; } + &logthis(" Detected 64bit platform ($_64bit)"); + } } } @@ -4836,14 +5919,14 @@ that was requested 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 +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. +values are also delted from the current processes %env. =back @@ -4889,8 +5972,8 @@ X B: get user privileges =item * -X -B: finds the section of student in the +X +B: finds the section of student in the course $cname, return section name/number or '' for "not in course" and '-1' for "no section" @@ -5093,8 +6176,8 @@ subscribe($fname) : subscribe to a resou 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 +'unavailable', 'not_found', 'forbidden', 'ok', or +'bad_request', also attempts to grab the metadata for the resource. Expects the local filesystem pathname (/home/httpd/html/res/....) @@ -5148,9 +6231,10 @@ 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'} +a possible symb for the URL in $thisfn, and if is an encryypted +resource that the user accessed using /enc/ returns a 1 on success, 0 +on failure, user must be in a course, as it assumes the existance of +the course initial hash, and uses $env('request.course.id'} =item * @@ -5181,7 +6265,7 @@ unfakeable, receipt =item * -receipt() : API to ireceipt working off of ENV values; given out to users +receipt() : API to ireceipt working off of env values; given out to users =item * @@ -5215,7 +6299,7 @@ forcing spreadsheet to reevaluate the re 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 +be derived from the env =item * @@ -5277,6 +6361,17 @@ put($namespace,$storehash,$udom,$uname) =item * +putstore($namespace,$storehash,$udomain,$uname) : stores hash in namesp +keys used in storehash include version information (e.g., 1:$symb:message etc.) as +used in records written by &store and retrieved by &restore. This function +was created for use in editing discussion posts, without incrementing the +version number included in the key for a particular post. The colon +separated list of attribute names (e.g., the value associated with the key +1:keys:$symb) is also generated and passed in the ampersand separated +items sent to lonnet::reply(). + +=item * + cput($namespace,$storehash,$udom,$uname) : critical put ($udom and $uname are optional) @@ -5382,8 +6477,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 * @@ -5403,6 +6519,91 @@ declutter() : declutters URLs (remove do =back +=head2 Usererfile file routines (/uploaded*) + +=over 4 + +=item * + +userfileupload(): main rotine for putting a file in a user or course's + filespace, arguments are, + + formname - required - this is the name of the element in $env where the + filename, and the contents of the file to create/modifed exist + the filename is in $env{'form.'.$formname.'.filename'} and the + contents of the file is located in $env{'form.'.$formname} + coursedoc - if true, store the file in the course of the active role + of the current user + subdir - required - subdirectory to put the file in under ../userfiles/ + if undefined, it will be placed in "unknown" + + (This routine calls clean_filename() to remove any dangerous + characters from the filename, and then calls finuserfileupload() to + complete the transaction) + + returns either the url of the uploaded file (/uploaded/....) if successful + and /adm/notfound.html if unsuccessful + +=item * + +clean_filename(): routine for cleaing a filename up for storage in + userfile space, argument is: + + filename - proposed filename + +returns: the new clean filename + +=item * + +finishuserfileupload(): routine that creaes and sends the file to +userspace, probably shouldn't be called directly + + docuname: username or courseid of destination for the file + docudom: domain of user/course of destination for the file + docuhome: loncapa id of the library server that is getting the file + formname: same as for userfileupload() + fname: filename (inculding subdirectories) for the file + + returns either the url of the uploaded file (/uploaded/....) if successful + and /adm/notfound.html if unsuccessful + +=item * + +renameuserfile(): renames an existing userfile to a new name + + Args: + docuname: username or courseid of destination for the file + docudom: domain of user/course of destination for the file + old: current file name (including any subdirs under userfiles) + new: desired file name (including any subdirs under userfiles) + +=item * + +mkdiruserfile(): creates a directory is a userfiles dir + + Args: + docuname: username or courseid of destination for the file + docudom: domain of user/course of destination for the file + dir: dir to create (including any subdirs under userfiles) + +=item * + +removeuserfile(): removes a file that exists in userfiles + + Args: + docuname: username or courseid of destination for the file + docudom: domain of user/course of destination for the file + fname: filname to delete (including any subdirs under userfiles) + +=item * + +removeuploadedurl(): convience function for removeuserfile() + + Args: + url: a full /uploaded/... url to delete + +=back + =head2 HTTP Helper Routines =over 4