--- loncom/lonnet/perl/lonnet.pm 2005/03/17 21:02:00 1.611 +++ loncom/lonnet/perl/lonnet.pm 2006/09/28 18:23:32 1.782.2.2 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.611 2005/03/17 21:02:00 albertel Exp $ +# $Id: lonnet.pm,v 1.782.2.2 2006/09/28 18:23:32 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -37,23 +37,33 @@ use HTTP::Date; use vars qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom %libserv %pr %prp $memcache %packagetab - %courselogs %accesshash %userrolehash $processmarker $dumpcount - %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf + %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount + %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf %domaindescription %domain_auth_def %domain_auth_arg_def - %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit); + %domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary + $tmpdir $_64bit %env); use IO::Socket; use GDBM_File; -use Apache::Constants qw(:common :http); use HTML::LCParser; +use HTML::Parser; use Fcntl qw(:flock); -use Apache::lonlocal; use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze); use Time::HiRes qw( gettimeofday tv_interval ); use Cache::Memcached; +use Digest::MD5; +use lib '/home/httpd/lib/perl'; +use LONCAPA; +use LONCAPA::Configuration; + my $readit; my $max_connection_retries = 10; # Or some such value. +require Exporter; + +our @ISA = qw (Exporter); +our @EXPORT = qw(%env); + =pod =head1 Package Variables @@ -78,6 +88,29 @@ delayed. # --------------------------------------------------------------------- Logging +{ + my $logid; + sub instructor_log { + my ($hash_name,$storehash,$delflag,$uname,$udom)=@_; + $logid++; + my $id=time().'00000'.$$.'00000'.$logid; + return &Apache::lonnet::put('nohist_'.$hash_name, + { $id => { + 'exe_uname' => $env{'user.name'}, + 'exe_udom' => $env{'user.domain'}, + 'exe_time' => time(), + 'exe_ip' => $ENV{'REMOTE_ADDR'}, + 'delflag' => $delflag, + 'logentry' => $storehash, + 'uname' => $uname, + 'udom' => $udom, + } + }, + $env{'course.'.$env{'request.course.id'}.'.domain'}, + $env{'course.'.$env{'request.course.id'}.'.num'} + ); + } +} sub logtouch { my $execdir=$perlvar{'lonDaemons'}; @@ -116,7 +149,7 @@ sub logperm { # -------------------------------------------------- Non-critical communication sub subreply { my ($cmd,$server)=@_; - my $peerfile="$perlvar{'lonSockDir'}/$server"; + my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server}; # # 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 @@ -144,7 +177,7 @@ sub subreply { } my $answer; if ($client) { - print $client "$cmd\n"; + print $client "sethost:$server:$cmd\n"; $answer=<$client>; if (!$answer) { $answer="con_lost"; } chomp($answer); @@ -159,7 +192,7 @@ sub reply { unless (defined($hostname{$server})) { return 'no_such_host'; } my $answer=subreply($cmd,$server); if (($answer=~/^refused/) || ($answer=~/^rejected/)) { - &logthis("WARNING:". + &logthis("WARNING:". " $cmd to $server returned $answer"); } return $answer; @@ -183,14 +216,14 @@ sub reconlonc { sleep 5; if (-e "$peerfile") { return; } &logthis( - "WARNING: $peerfile still not there, giving up"); + "WARNING: $peerfile still not there, giving up"); } else { &logthis( - "WARNING:". + "WARNING:". " lonc at pid $loncpid not responding, giving up"); } } else { - &logthis('WARNING: lonc not running, giving up'); + &logthis('WARNING: lonc not running, giving up'); } } @@ -199,7 +232,7 @@ sub reconlonc { sub critical { my ($cmd,$server)=@_; unless ($hostname{$server}) { - &logthis("WARNING:". + &logthis("WARNING:". " Critical message to unknown server ($server)"); return 'no_such_host'; } @@ -233,12 +266,12 @@ sub critical { } chomp($wcmd); if ($wcmd eq $cmd) { - &logthis("WARNING: ". + &logthis("WARNING: ". "Connection buffer $dfilename: $cmd"); &logperm("D:$server:$cmd"); return 'con_delayed'; } else { - &logthis("CRITICAL:" + &logthis("CRITICAL:" ." Critical connection failed: $server $cmd"); &logperm("F:$server:$cmd"); return 'con_failed'; @@ -248,24 +281,30 @@ sub critical { return $answer; } -# -# -------------- Remove all key from the env that start witha lowercase letter -# (Which is always a lon-capa value) +# ------------------------------------------- check if return value is an error -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}); - } +sub error { + my ($result) = @_; + if ($result =~ /^(con_lost|no_such_host|error: (\d+) (.*))/) { + if ($2 == 2) { return undef; } + return $1; } + return undef; } - -# ------------------------------------------- Transfer profile into environment +# ------------------------------------------- Transfer profile into environment +my $env_loaded; sub transfer_profile_to_env { + if ($env_loaded) { return; } + my ($lonidsdir,$handle)=@_; + if (!defined($lonidsdir)) { + $lonidsdir = $perlvar{'lonIDsDir'}; + } + if (!defined($handle)) { + ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| ); + } + my @profile; { open(my $idf,"$lonidsdir/$handle.id"); @@ -277,15 +316,18 @@ sub transfer_profile_to_env { my %Remove; for ($envi=0;$envi<=$#profile;$envi++) { chomp($profile[$envi]); - my ($envname,$envvalue)=split(/=/,$profile[$envi]); - $ENV{$envname} = $envvalue; + my ($envname,$envvalue)=split(/=/,$profile[$envi],2); + $envname=&unescape($envname); + $envvalue=&unescape($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"; + $env_loaded=1; foreach my $expired_key (keys(%Remove)) { &delenv($expired_key); } @@ -295,23 +337,28 @@ sub transfer_profile_to_env { sub appenv { my %newenv=@_; - foreach (keys %newenv) { - if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) { - &logthis("WARNING: ". - "Attempt to modify environment ".$_." to ".$newenv{$_} + foreach my $key (keys(%newenv)) { + if (($newenv{$key}=~/^user\.role/) || ($newenv{$key}=~/^user\.priv/)) { + &logthis("WARNING: ". + "Attempt to modify environment ".$key." to ".$newenv{$key} .''); - delete($newenv{$_}); + delete($newenv{$key}); } else { - $ENV{$_}=$newenv{$_}; + $env{$key}=$newenv{$key}; } } + foreach my $key (keys(%newenv)) { + my $value = &escape($newenv{$key}); + delete($newenv{$key}); + $newenv{&escape($key)}=$value; + } my $lockfh; - unless (open($lockfh,"$ENV{'user.environment'}")) { + unless (open($lockfh,"$env{'user.environment'}")) { return 'error: '.$!; } unless (flock($lockfh,LOCK_EX)) { - &logthis("WARNING: ". + &logthis("WARNING: ". 'Could not obtain exclusive lock in appenv: '.$!); close($lockfh); return 'error: '.$!; @@ -320,7 +367,7 @@ sub appenv { my @oldenv; { my $fh; - unless (open($fh,"$ENV{'user.environment'}")) { + unless (open($fh,"$env{'user.environment'}")) { return 'error: '.$!; } @oldenv=<$fh>; @@ -329,7 +376,7 @@ sub appenv { for (my $i=0; $i<=$#oldenv; $i++) { chomp($oldenv[$i]); if ($oldenv[$i] ne '') { - my ($name,$value)=split(/=/,$oldenv[$i]); + my ($name,$value)=split(/=/,$oldenv[$i],2); unless (defined($newenv{$name})) { $newenv{$name}=$value; } @@ -337,12 +384,12 @@ sub appenv { } { my $fh; - unless (open($fh,">$ENV{'user.environment'}")) { + unless (open($fh,">$env{'user.environment'}")) { return 'error'; } my $newname; foreach $newname (keys %newenv) { - print $fh "$newname=$newenv{$newname}\n"; + print $fh $newname.'='.$newenv{$newname}."\n"; } close($fh); } @@ -354,20 +401,19 @@ sub appenv { sub delenv { my $delthis=shift; - my %newenv=(); if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) { - &logthis("WARNING: ". + &logthis("WARNING: ". "Attempt to delete from environment ".$delthis); return 'error'; } my @oldenv; { my $fh; - unless (open($fh,"$ENV{'user.environment'}")) { + unless (open($fh,"$env{'user.environment'}")) { return 'error'; } unless (flock($fh,LOCK_SH)) { - &logthis("WARNING: ". + &logthis("WARNING: ". 'Could not obtain shared lock in delenv: '.$!); close($fh); return 'error: '.$!; @@ -377,21 +423,23 @@ sub delenv { } { my $fh; - unless (open($fh,">$ENV{'user.environment'}")) { + unless (open($fh,">$env{'user.environment'}")) { return 'error'; } unless (flock($fh,LOCK_EX)) { - &logthis("WARNING: ". + &logthis("WARNING: ". 'Could not obtain exclusive lock in delenv: '.$!); close($fh); return 'error: '.$!; } - foreach (@oldenv) { - if ($_=~/^$delthis/) { - my ($key,undef) = split('=',$_); - delete($ENV{$key}); + foreach my $cur_key (@oldenv) { + my $unescaped_cur_key = &unescape($cur_key); + if ($unescaped_cur_key=~/^$delthis/) { + my ($key) = split('=',$cur_key,2); + $key = &unescape($key); + delete($env{$key}); } else { - print $fh $_; + print $fh $cur_key; } } close($fh); @@ -450,38 +498,61 @@ sub overloaderror { # ------------------------------ Find server with least workload from spare.tab sub spareserver { - my ($loadpercent,$userloadpercent) = @_; - my $tryserver; - my $spareserver=''; + my ($loadpercent,$userloadpercent,$want_server_name) = @_; + my $spare_server; if ($userloadpercent !~ /\d/) { $userloadpercent=0; } - my $lowestserver=$loadpercent > $userloadpercent? - $loadpercent : $userloadpercent; - foreach $tryserver (keys %spareid) { - my $loadans=reply('load',$tryserver); - my $userloadans=reply('userload',$tryserver); - if ($loadans !~ /\d/ && $userloadans !~ /\d/) { - next; #didn't get a number from the server - } - my $answer; - if ($loadans =~ /\d/) { - if ($userloadans =~ /\d/) { - #both are numbers, pick the bigger one - $answer=$loadans > $userloadans? - $loadans : $userloadans; - } else { - $answer = $loadans; - } - } else { - $answer = $userloadans; - } - if (($answer =~ /\d/) && ($answer<$lowestserver)) { - $spareserver="http://$hostname{$tryserver}"; - $lowestserver=$answer; + my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent + : $userloadpercent; + + foreach my $try_server (@{ $spareid{'primary'} }) { + ($spare_server, $lowest_load) = + &compare_server_load($try_server, $spare_server, $lowest_load); + } + + my $found_server = ($spare_server ne '' && $lowest_load < 100); + + if (!$found_server) { + foreach my $try_server (@{ $spareid{'default'} }) { + ($spare_server, $lowest_load) = + &compare_server_load($try_server, $spare_server, $lowest_load); } } - return $spareserver; + + if (!$want_server_name) { + $spare_server="http://$hostname{$spare_server}"; + } + return $spare_server; } +sub compare_server_load { + my ($try_server, $spare_server, $lowest_load) = @_; + + my $loadans = &reply('load', $try_server); + my $userloadans = &reply('userload',$try_server); + + if ($loadans !~ /\d/ && $userloadans !~ /\d/) { + next; #didn't get a number from the server + } + + my $load; + if ($loadans =~ /\d/) { + if ($userloadans =~ /\d/) { + #both are numbers, pick the bigger one + $load = ($loadans > $userloadans) ? $loadans + : $userloadans; + } else { + $load = $loadans; + } + } else { + $load = $userloadans; + } + + if (($load =~ /\d/) && ($load < $lowest_load)) { + $spare_server = $try_server; + $lowest_load = $load; + } + return ($spare_server,$lowest_load); +} # --------------------------------------------- Try to change a user's password sub changepass { @@ -652,15 +723,15 @@ sub assign_access_key { # my ($ckey,$kdom,$knum,$cdom,$cnum,$udom,$uname,$logentry)=@_; $kdom= - $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($kdom)); + $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($kdom)); $knum= - $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($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)); + $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum)); + $udom=$env{'user.name'} unless (defined($udom)); + $uname=$env{'user.domain'} unless (defined($uname)); my %existing=&get('accesskeys',[$ckey],$kdom,$knum); if (($existing{$ckey}=~/^\#(.*)$/) || # - new key ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#(.*)$/)) { @@ -702,9 +773,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; @@ -726,9 +797,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; } @@ -747,14 +818,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; } @@ -764,16 +835,23 @@ 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.domain'} unless (defined($udom)); - $uname=$ENV{'user.name'} 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}=~/^\Q$uname\E\:\Q$udom\E\#/); } # ------------------------------------- Find the section of student in a course +sub devalidate_getsection_cache { + my ($udom,$unam,$courseid)=@_; + $courseid=~s/\_/\//g; + $courseid=~s/^(\w)/\/$1/; + my $hashid="$udom:$unam:$courseid"; + &devalidate_cache_new('getsection',$hashid); +} sub getsection { my ($udom,$unam,$courseid)=@_; @@ -836,6 +914,9 @@ sub getsection { sub save_cache { &purge_remembered(); + #&Apache::loncommon::validate_page(); + undef(%env); + undef($env_loaded); } my $to_remember=-1; @@ -882,6 +963,9 @@ sub do_cache_new { 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 @@ -931,16 +1015,66 @@ sub userenvironment { return %returnhash; } +# ---------------------------------------------------------- Get a studentphoto +sub studentphoto { + my ($udom,$unam,$ext) = @_; + my $home=&Apache::lonnet::homeserver($unam,$udom); + if (defined($env{'request.course.id'})) { + if ($env{'course.'.$env{'request.course.id'}.'.internal.showphoto'}) { + if ($udom eq $env{'course.'.$env{'request.course.id'}.'.domain'}) { + return(&retrievestudentphoto($udom,$unam,$ext)); + } else { + my ($result,$perm_reqd)= + &Apache::lonnet::auto_photo_permission($unam,$udom); + if ($result eq 'ok') { + if (!($perm_reqd eq 'yes')) { + return(&retrievestudentphoto($udom,$unam,$ext)); + } + } + } + } + } else { + my ($result,$perm_reqd) = + &Apache::lonnet::auto_photo_permission($unam,$udom); + if ($result eq 'ok') { + if (!($perm_reqd eq 'yes')) { + return(&retrievestudentphoto($udom,$unam,$ext)); + } + } + } + return '/adm/lonKaputt/lonlogo_broken.gif'; +} + +sub retrievestudentphoto { + my ($udom,$unam,$ext,$type) = @_; + my $home=&Apache::lonnet::homeserver($unam,$udom); + my $ret=&Apache::lonnet::reply("studentphoto:$udom:$unam:$ext:$type",$home); + if ($ret eq 'ok') { + my $url="/uploaded/$udom/$unam/internal/studentphoto.$ext"; + if ($type eq 'thumbnail') { + $url="/uploaded/$udom/$unam/internal/studentphoto_tn.$ext"; + } + my $tokenurl=&Apache::lonnet::tokenwrapper($url); + return $tokenurl; + } else { + if ($type eq 'thumbnail') { + return '/adm/lonKaputt/genericstudent_tn.gif'; + } else { + return '/adm/lonKaputt/lonlogo_broken.gif'; + } + } +} + # -------------------------------------------------------------------- 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 ($newentry,$anon,$group)=@_; + my $cnum=$env{'course.'.$env{'request.course.id'}.'.num'}; + my $cdom=$env{'course.'.$env{'request.course.id'}.'.domain'}; + my $chome=$env{'course.'.$env{'request.course.id'}.'.home'}; &reply('chatsend:'.$cdom.':'.$cnum.':'. - &escape($ENV{'user.domain'}.':'.$ENV{'user.name'}.':'.$anon.':'. - &escape($newentry)),$chome); + &escape($env{'user.domain'}.':'.$env{'user.name'}.':'.$anon.':'. + &escape($newentry)).':'.$group,$chome); } # ------------------------------------------ Find current version of a resource @@ -1040,7 +1174,7 @@ sub repcopy { if ($response->is_error()) { unlink($transname); my $message=$response->status_line; - &logthis("WARNING:" + &logthis("WARNING:" ." LWP get: $message: $filename"); return 'unavailable'; } else { @@ -1050,7 +1184,7 @@ sub repcopy { if ($mresponse->is_error()) { unlink($filename.'.meta'); &logthis( - "INFO: No metadata: $filename"); + "INFO: No metadata: $filename"); } } rename($transname,$filename); @@ -1068,7 +1202,7 @@ sub ssi_body { } my $output=($filelink=~/^http\:/?&externalssi($filelink): &ssi($filelink,%form)); - $output=~s|//(\s*)?\s||gs; + $output=~s|//(\s*)?\s||gs; $output=~s/^.*?\]*\>//si; $output=~s/(.*)\<\/body\s*\>.*?$/$1/si; return $output; @@ -1076,6 +1210,15 @@ sub ssi_body { # --------------------------------------------------------- Server Side Include +sub absolute_url { + my ($host_name) = @_; + my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://'); + if ($host_name eq '') { + $host_name = $ENV{'SERVER_NAME'}; + } + return $protocol.$host_name; +} + sub ssi { my ($fn,%form)=@_; @@ -1083,12 +1226,14 @@ sub ssi { my $ua=new LWP::UserAgent; my $request; - + + $form{'no_update_last_known'}=1; + if (%form) { - $request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn); + $request=new HTTP::Request('POST',&absolute_url().$fn); $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form)); } else { - $request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn); + $request=new HTTP::Request('GET',&absolute_url().$fn); } $request->header(Cookie => $ENV{'HTTP_COOKIE'}); @@ -1119,8 +1264,11 @@ sub allowuploaded { } # --------- 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. +# input: action, courseID, current domain, intended +# path to file, source of file, instruction to parse file for objects, +# ref to hash for embedded objects, +# ref to hash for codebase of java objects. +# # output: url to file (if action was uploaddoc), # ok if successful, or diagnostic message otherwise (if action was propagate or copy) # @@ -1139,34 +1287,25 @@ sub allowuploaded { # 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 +# 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 ($action,$docuname,$docudom,$file,$source,$parser,$allfiles,$codebase)=@_; my $fetchresult; + my $home=&homeserver($docuname,$docudom); if ($action eq 'propagate') { - $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file - ,$docuhome); + $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, + $home); } else { - my $fetchresult = ''; my $fpath = ''; my $fname = $file; ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|); $fpath=$docudom.'/'.$docuname.'/'.$fpath; - my $filepath=$perlvar{'lonDocRoot'}.'/userfiles'; - unless ($fpath eq '') { - my @parts=split('/',$fpath); - foreach my $part (@parts) { - $filepath.= '/'.$part; - if ((-e $filepath)!=1) { - mkdir($filepath,0777); - } - } - } + my $filepath = &build_filepath($fpath); if ($action eq 'copy') { if ($source eq '') { $fetchresult = 'no source file'; @@ -1175,30 +1314,75 @@ sub process_coursefile { my $destination = $filepath.'/'.$fname; rename($source,$destination); $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, - $docuhome); + $home); } } elsif ($action eq 'uploaddoc') { open(my $fh,'>'.$filepath.'/'.$fname); - print $fh $ENV{'form.'.$source}; + print $fh $env{'form.'.$source}; close($fh); + if ($parser eq 'parse') { + my $parse_result = &extract_embedded_items($filepath,$fname,$allfiles,$codebase); + unless ($parse_result eq 'ok') { + &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result); + } + } $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, - $docuhome); + $home); if ($fetchresult eq 'ok') { return '/uploaded/'.$fpath.'/'.$fname; } else { &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file. - ' to host '.$docuhome.': '.$fetchresult); + ' to host '.$home.': '.$fetchresult); return '/adm/notfound.html'; } } } unless ( $fetchresult eq 'ok') { &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file. - ' to host '.$docuhome.': '.$fetchresult); + ' to host '.$home.': '.$fetchresult); } return $fetchresult; } +sub build_filepath { + my ($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); + } + } + } + return $filepath; +} + +sub store_edited_file { + my ($primary_url,$content,$docudom,$docuname,$fetchresult) = @_; + my $file = $primary_url; + $file =~ s#^/uploaded/$docudom/$docuname/##; + my $fpath = ''; + my $fname = $file; + ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|); + $fpath=$docudom.'/'.$docuname.'/'.$fpath; + my $filepath = &build_filepath($fpath); + open(my $fh,'>'.$filepath.'/'.$fname); + print $fh $content; + close($fh); + my $home=&homeserver($docuname,$docudom); + $$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, + $home); + if ($$fetchresult eq 'ok') { + return '/uploaded/'.$fpath.'/'.$fname; + } else { + &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file. + ' to host '.$home.': '.$$fetchresult); + return '/adm/notfound.html'; + } +} + sub clean_filename { my ($fname)=@_; # Replace Windows backslashes by forward slashes @@ -1216,18 +1400,25 @@ sub clean_filename { } # --------------- 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 +# input: $formname - the contents of the file are in $env{"form.$formname"} +# the desired filenam is in $env{"form.$formname.filename"} +# $coursedoc - if true up to the current course +# if false +# $subdir - directory in userfile to store the file into +# $parser, $allfiles, $codebase - unknown +# +# output: url of file in userspace, or error: +# or /adm/notfound.html if failure to upload occurse sub userfileupload { - my ($formname,$coursedoc,$subdir)=@_; + my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,$destudom)=@_; if (!defined($subdir)) { $subdir='unknown'; } - my $fname=$ENV{'form.'.$formname.'.filename'}; + 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; @@ -1240,35 +1431,61 @@ sub userfileupload { } } open(my $fh,'>'.$fullpath.'/'.$fname); - print $fh $ENV{'form.'.$formname}; + print $fh $env{'form.'.$formname}; + close($fh); + return $fullpath.'/'.$fname; + } elsif (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) { #files uploaded to create course page are handled differently + my $filepath = 'tmp/addcourse/'.$destudom.'/web/'.$env{'user.name'}. + '_'.$env{'user.domain'}.'/pending'; + 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; + 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'}; - if ($ENV{'form.folder'} =~ m/^default/) { - return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname); + my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; + my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; + if ($env{'form.folder'} =~ m/^(default|supplemental)/) { + return &finishuserfileupload($docuname,$docudom, + $formname,$fname,$parser,$allfiles, + $codebase); } else { - $fname=$ENV{'form.folder'}.'/'.$fname; - return &process_coursefile('uploaddoc',$docuname,$docudom,$docuhome,$fname,$formname); + $fname=$env{'form.folder'}.'/'.$fname; + return &process_coursefile('uploaddoc',$docuname,$docudom, + $fname,$formname,$parser, + $allfiles,$codebase); + } + } elsif (defined($destuname)) { + my $docuname=$destuname; + my $docudom=$destudom; + return &finishuserfileupload($docuname,$docudom,$formname, + $fname,$parser,$allfiles,$codebase); + + } else { + my $docuname=$env{'user.name'}; + my $docudom=$env{'user.domain'}; + if (exists($env{'form.group'})) { + $docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; + $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; } - } else { - $docuname=$ENV{'user.name'}; - $docudom=$ENV{'user.domain'}; - $docuhome=$ENV{'user.home'}; - return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname); + return &finishuserfileupload($docuname,$docudom,$formname, + $fname,$parser,$allfiles,$codebase); } } sub finishuserfileupload { - my ($docuname,$docudom,$docuhome,$formname,$fname)=@_; + my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase) = @_; my $path=$docudom.'/'.$docuname.'/'; my $filepath=$perlvar{'lonDocRoot'}; my ($fnamepath,$file); @@ -1287,13 +1504,29 @@ sub finishuserfileupload { } # Save the file { - open(FH,'>'.$filepath.'/'.$file); - print FH $ENV{'form.'.$formname}; + if (!open(FH,'>'.$filepath.'/'.$file)) { + &logthis('Failed to create '.$filepath.'/'.$file); + print STDERR ('Failed to create '.$filepath.'/'.$file."\n"); + return '/adm/notfound.html'; + } + if (!print FH ($env{'form.'.$formname})) { + &logthis('Failed to write to '.$filepath.'/'.$file); + print STDERR ('Failed to write to '.$filepath.'/'.$file."\n"); + return '/adm/notfound.html'; + } close(FH); } + if ($parser eq 'parse') { + my $parse_result = &extract_embedded_items($filepath,$file,$allfiles, + $codebase); + unless ($parse_result eq 'ok') { + &logthis('Failed to parse '.$filepath.$file. + ' for embedded media: '.$parse_result); + } + } # Notify homeserver to grep it # - &Apache::lonnet::logthis("fetching ".$path.$file); + my $docuhome=&homeserver($docuname,$docudom); my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome); if ($fetchresult eq 'ok') { # @@ -1306,10 +1539,118 @@ sub finishuserfileupload { } } +sub extract_embedded_items { + my ($filepath,$file,$allfiles,$codebase,$content) = @_; + my @state = (); + my %javafiles = ( + codebase => '', + code => '', + archive => '' + ); + my %mediafiles = ( + src => '', + movie => '', + ); + my $p; + if ($content) { + $p = HTML::LCParser->new($content); + } else { + $p = HTML::LCParser->new($filepath.'/'.$file); + } + while (my $t=$p->get_token()) { + if ($t->[0] eq 'S') { + my ($tagname, $attr) = ($t->[1],$t->[2]); + push (@state, $tagname); + if (lc($tagname) eq 'allow') { + &add_filetype($allfiles,$attr->{'src'},'src'); + } + if (lc($tagname) eq 'img') { + &add_filetype($allfiles,$attr->{'src'},'src'); + } + if (lc($tagname) eq 'script') { + if ($attr->{'archive'} =~ /\.jar$/i) { + &add_filetype($allfiles,$attr->{'archive'},'archive'); + } else { + &add_filetype($allfiles,$attr->{'src'},'src'); + } + } + if (lc($tagname) eq 'link') { + if (lc($attr->{'rel'}) eq 'stylesheet') { + &add_filetype($allfiles,$attr->{'href'},'href'); + } + } + if (lc($tagname) eq 'object' || + (lc($tagname) eq 'embed' && lc($state[-2]) ne 'object')) { + foreach my $item (keys(%javafiles)) { + $javafiles{$item} = ''; + } + } + if (lc($state[-2]) eq 'object' && lc($tagname) eq 'param') { + my $name = lc($attr->{'name'}); + foreach my $item (keys(%javafiles)) { + if ($name eq $item) { + $javafiles{$item} = $attr->{'value'}; + last; + } + } + foreach my $item (keys(%mediafiles)) { + if ($name eq $item) { + &add_filetype($allfiles, $attr->{'value'}, 'value'); + last; + } + } + } + if (lc($tagname) eq 'embed' || lc($tagname) eq 'applet') { + foreach my $item (keys(%javafiles)) { + if ($attr->{$item}) { + $javafiles{$item} = $attr->{$item}; + last; + } + } + foreach my $item (keys(%mediafiles)) { + if ($attr->{$item}) { + &add_filetype($allfiles,$attr->{$item},$item); + last; + } + } + } + } elsif ($t->[0] eq 'E') { + my ($tagname) = ($t->[1]); + if ($javafiles{'codebase'} ne '') { + $javafiles{'codebase'} .= '/'; + } + if (lc($tagname) eq 'applet' || + lc($tagname) eq 'object' || + (lc($tagname) eq 'embed' && lc($state[-2]) ne 'object') + ) { + foreach my $item (keys(%javafiles)) { + if ($item ne 'codebase' && $javafiles{$item} ne '') { + my $file=$javafiles{'codebase'}.$javafiles{$item}; + &add_filetype($allfiles,$file,$item); + } + } + } + pop @state; + } + } + return 'ok'; +} + +sub add_filetype { + my ($allfiles,$file,$type)=@_; + if (exists($allfiles->{$file})) { + unless (grep/^\Q$type\E$/, @{$allfiles->{$file}}) { + push(@{$allfiles->{$file}}, &escape($type)); + } + } else { + @{$allfiles->{$file}} = (&escape($type)); + } +} + sub removeuploadedurl { my ($url)=@_; my (undef,undef,$udom,$uname,$fname)=split('/',$url,5); - return &Apache::lonnet::removeuserfile($uname,$udom,$fname); + return &removeuserfile($uname,$udom,$fname); } sub removeuserfile { @@ -1363,7 +1704,7 @@ sub flushcourselogs { } else { &logthis('Failed to flush log buffer for '.$crsid); if (length($courselogs{$crsid})>40000) { - &logthis("WARNING: Buffer for ".$crsid. + &logthis("WARNING: Buffer for ".$crsid. " exceeded maximum size, deleting."); delete $courselogs{$crsid}; } @@ -1371,11 +1712,11 @@ sub flushcourselogs { if ($courseidbuffer{$coursehombuf{$crsid}}) { $courseidbuffer{$coursehombuf{$crsid}}.='&'. &escape($crsid).'='.&escape($coursedescrbuf{$crsid}). - ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}); + ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid}); } else { $courseidbuffer{$coursehombuf{$crsid}}= &escape($crsid).'='.&escape($coursedescrbuf{$crsid}). - ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}); + ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid}); } } # @@ -1395,9 +1736,9 @@ sub flushcourselogs { ($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 $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$/); @@ -1434,56 +1775,83 @@ sub flushcourselogs { delete $userrolehash{$entry}; } } +# +# Reverse lookup of domain roles (dc, ad, li, sc, au) +# + my %domrolebuffer = (); + foreach my $entry (keys %domainrolehash) { + my ($role,$uname,$udom,$runame,$rudom,$rsec)=split/:/,$entry; + if ($domrolebuffer{$rudom}) { + $domrolebuffer{$rudom}.='&'.&escape($entry). + '='.&escape($domainrolehash{$entry}); + } else { + $domrolebuffer{$rudom}.=&escape($entry). + '='.&escape($domainrolehash{$entry}); + } + delete $domainrolehash{$entry}; + } + foreach my $dom (keys(%domrolebuffer)) { + foreach my $tryserver (keys %libserv) { + if ($hostdom{$tryserver} eq $dom) { + unless (&reply('domroleput:'.$dom.':'. + $domrolebuffer{$dom},$tryserver) eq 'ok') { + &logthis('Put of domain roles failed for '.$dom.' and '.$tryserver); + } + } + } + } $dumpcount++; } sub courselog { my $what=shift; $what=time.':'.$what; - unless ($ENV{'request.course.id'}) { return ''; } - $coursedombuf{$ENV{'request.course.id'}}= - $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}; - $coursenumbuf{$ENV{'request.course.id'}}= - $ENV{'course.'.$ENV{'request.course.id'}.'.num'}; - $coursehombuf{$ENV{'request.course.id'}}= - $ENV{'course.'.$ENV{'request.course.id'}.'.home'}; - $coursedescrbuf{$ENV{'request.course.id'}}= - $ENV{'course.'.$ENV{'request.course.id'}.'.description'}; - $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; + 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'}; + $coursetypebuf{$env{'request.course.id'}}= + $env{'course.'.$env{'request.course.id'}.'.type'}; + 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'}})>4048) { &flushcourselogs(); } } sub courseacclog { my $fnsymb=shift; - unless ($ENV{'request.course.id'}) { return ''; } - my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'}; - if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|page)$/) { + unless ($env{'request.course.id'}) { return ''; } + my $what=$fnsymb.':'.$env{'user.name'}.':'.$env{'user.domain'}; + if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|task|page)$/) { $what.=':POST'; # FIXME: Probably ought to escape things.... - foreach (keys %ENV) { + 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') { + 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}; + $what.=':'.$element.'='.$env{'form.'.$element}; } } } @@ -1493,8 +1861,8 @@ sub courseacclog { sub countacc { my $url=&declutter(shift); return if (! defined($url) || $url eq ''); - unless ($ENV{'request.course.id'}) { return ''; } - $accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1; + unless ($env{'request.course.id'}) { return ''; } + $accesshash{$env{'request.course.id'}.'___'.$url.'___course'}=1; my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count'; $accesshash{$key}++; } @@ -1509,19 +1877,29 @@ sub linklog { sub userrolelog { my ($trole,$username,$domain,$area,$tstart,$tend)=@_; - if (($trole=~/^ca/) || ($trole=~/^in/) || - ($trole=~/^cc/) || ($trole=~/^ep/) || - ($trole=~/^cr/) || ($trole=~/^ta/)) { + if (($trole=~/^ca/) || ($trole=~/^aa/) || + ($trole=~/^in/) || ($trole=~/^cc/) || + ($trole=~/^ep/) || ($trole=~/^cr/) || + ($trole=~/^ta/)) { my (undef,$rudom,$runame,$rsec)=split(/\//,$area); $userrolehash {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} =$tend.':'.$tstart; - } + } + if (($trole=~/^dc/) || ($trole=~/^ad/) || + ($trole=~/^li/) || ($trole=~/^li/) || + ($trole=~/^au/) || ($trole=~/^dg/) || + ($trole=~/^sc/)) { + my (undef,$rudom,$runame,$rsec)=split(/\//,$area); + $domainrolehash + {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} + = $tend.':'.$tstart; + } } 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'})) { @@ -1540,6 +1918,7 @@ sub get_course_adv_roles { if ($username eq '' || $domain eq '') { next; } if ((&privileged($username,$domain)) && (!$nothide{$username.':'.$domain})) { next; } + if ($role eq 'cr') { next; } my $key=&plaintext($role); if ($section) { $key.=' (Sec/Grp '.$section.')'; } if ($returnhash{$key}) { @@ -1553,8 +1932,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=(); @@ -1609,7 +1988,7 @@ sub courseidput { } sub courseiddump { - my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$hostidflag,$hostidref)=@_; + my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter)=@_; my %returnhash=(); unless ($domfilter) { $domfilter=''; } foreach my $tryserver (keys %libserv) { @@ -1618,7 +1997,7 @@ sub courseiddump { foreach ( split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. $sincefilter.':'.&escape($descfilter).':'. - &escape($instcodefilter).':'.&escape($ownerfilter), + &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter), $tryserver))) { my ($key,$value)=split(/\=/,$_); if (($key) && ($value)) { @@ -1631,7 +2010,62 @@ sub courseiddump { return %returnhash; } -# +# ---------------------------------------------------------- DC e-mail + +sub dcmailput { + my ($domain,$msgid,$message,$server)=@_; + my $status = &Apache::lonnet::critical( + 'dcmailput:'.$domain.':'.&escape($msgid).'='. + &escape($message),$server); + return $status; +} + +sub dcmaildump { + my ($dom,$startdate,$enddate,$senders) = @_; + my %returnhash=(); + if (exists($domain_primary{$dom})) { + my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'. + &escape($enddate).':'; + my @esc_senders=map { &escape($_)} @$senders; + $cmd.=&escape(join('&',@esc_senders)); + foreach (split(/\&/,&reply($cmd,$domain_primary{$dom}))) { + my ($key,$value) = split(/\=/,$_); + if (($key) && ($value)) { + $returnhash{&unescape($key)} = &unescape($value); + } + } + } + return %returnhash; +} +# ---------------------------------------------------------- Domain roles + +sub get_domain_roles { + my ($dom,$roles,$startdate,$enddate)=@_; + if (undef($startdate) || $startdate eq '') { + $startdate = '.'; + } + if (undef($enddate) || $enddate eq '') { + $enddate = '.'; + } + my $rolelist = join(':',@{$roles}); + my %personnel = (); + foreach my $tryserver (keys(%libserv)) { + if ($hostdom{$tryserver} eq $dom) { + %{$personnel{$tryserver}}=(); + foreach ( + split(/\&/,&reply('domrolesdump:'.$dom.':'. + &escape($startdate).':'.&escape($enddate).':'. + &escape($rolelist), $tryserver))) { + my($key,$value) = split(/\=/,$_); + if (($key) && ($value)) { + $personnel{$tryserver}{&unescape($key)} = &unescape($value); + } + } + } + } + return %personnel; +} + # ----------------------------------------------------------- Check out an item sub get_first_access { @@ -1677,7 +2111,7 @@ sub checkout { $now.'&'.$ENV{'REMOTE_ADDR'}); my $token=&reply('tmpput:'.$infostr,$lonhost); if ($token=~/^error\:/) { - &logthis("WARNING: ". + &logthis("WARNING: ". "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb. ""); return ''; @@ -1693,7 +2127,7 @@ sub checkout { unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') { return ''; } else { - &logthis("WARNING: ". + &logthis("WARNING: ". "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb. ""); } @@ -1703,7 +2137,7 @@ sub checkout { $token)) ne 'ok') { return ''; } else { - &logthis("WARNING: ". + &logthis("WARNING: ". "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb. ""); } @@ -1729,7 +2163,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 ''; } @@ -1753,15 +2187,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'; } @@ -1770,7 +2204,7 @@ 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 @@ -1781,8 +2215,8 @@ sub devalidate { 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); @@ -1992,16 +2426,16 @@ 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; - 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'}; } @@ -2023,22 +2457,22 @@ 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; - 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'}; } @@ -2075,14 +2509,14 @@ 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'}; } + if (!$namespace) { $namespace=$env{'request.state'}; } - 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'}; } @@ -2127,18 +2561,18 @@ 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'}; @@ -2163,18 +2597,18 @@ 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'}; @@ -2203,13 +2637,13 @@ 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=(); @@ -2229,7 +2663,7 @@ sub restore { # ---------------------------------------------------------- Course Description sub coursedescription { - my $courseid=shift; + my ($courseid,$args)=@_; $courseid=~s/^\///; $courseid=~s/\_/\//g; my ($cdomain,$cnum)=split(/\//,$courseid); @@ -2239,25 +2673,50 @@ sub coursedescription { # trying and trying and trying to get the course description. my %envhash=(); my %returnhash=(); - $envhash{'course.'.$normalid.'.last_cache'}=time; + + my $expiretime=600; + if ($env{'request.course.id'} eq $normalid) { + $expiretime=120; + } + + my $prefix='course.'.$cdomain.'_'.$cnum.'.'; + if (!$args->{'freshen_cache'} + && ((time-$env{$prefix.'last_cache'}) < $expiretime) ) { + foreach my $key (keys(%env)) { + next if ($key !~ /^\Q$prefix\E(.*)/); + my ($setting) = $1; + $returnhash{$setting} = $env{$key}; + } + return %returnhash; + } + + # get the data agin + if (!$args->{'one_time'}) { + $envhash{'course.'.$normalid.'.last_cache'}=time; + } if ($chome ne 'no_host') { %returnhash=&dump('environment',$cdomain,$cnum); if (!exists($returnhash{'con_lost'})) { $returnhash{'home'}= $chome; $returnhash{'domain'} = $cdomain; $returnhash{'num'} = $cnum; + if (!defined($returnhash{'type'})) { + $returnhash{'type'} = 'Course'; + } while (my ($name,$value) = each %returnhash) { $envhash{'course.'.$normalid.'.'.$name}=$value; } $returnhash{'url'}=&clutter($returnhash{'url'}); $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'. - $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum; + $env{'user.name'}.'_'.$cdomain.'_'.$cnum; $envhash{'course.'.$normalid.'.home'}=$chome; $envhash{'course.'.$normalid.'.domain'}=$cdomain; $envhash{'course.'.$normalid.'.num'}=$cnum; } } - &appenv(%envhash); + if (!$args->{'one_time'}) { + &appenv(%envhash); + } return %returnhash; } @@ -2298,23 +2757,34 @@ sub rolesinit { my $rolesdump=reply("dump:$domain:$username:roles",$authhost); if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; } my %allroles=(); + my %allgroups=(); my $now=time; - my $userroles="user.login.time=$now\n"; + my %userroles = ('user.login.time' => $now); + my $group_privs; if ($rolesdump ne '') { foreach (split(/&/,$rolesdump)) { if ($_!~/^rolesdef_/) { my ($area,$role)=split(/=/,$_); $area=~s/\_\w\w$//; - - my ($trole,$tend,$tstart); + my ($trole,$tend,$tstart,$group_privs); if ($role=~/^cr/) { - ($trole,my $trest)=($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|); - ($tend,$tstart)=split('_',$trest); + if ($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|) { + ($trole,my $trest)=($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|); + ($tend,$tstart)=split('_',$trest); + } else { + $trole=$role; + } + } elsif ($role =~ m|^gr/|) { + ($trole,$tend,$tstart) = split(/_/,$role); + ($trole,$group_privs) = split(/\//,$trole); + $group_privs = &unescape($group_privs); } else { ($trole,$tend,$tstart)=split(/_/,$role); } - $userroles.=&set_arearole($trole,$area,$tstart,$tend,$domain,$username); + my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain, + $username); + @userroles{keys(%new_role)} = @new_role{keys(%new_role)}; if (($tend!=0) && ($tend<$now)) { $trole=''; } if (($tstart!=0) && ($tstart>$now)) { $trole=''; } if (($area ne '') && ($trole ne '')) { @@ -2322,25 +2792,27 @@ sub rolesinit { my ($tdummy,$tdomain,$trest)=split(/\//,$area); if ($trole =~ /^cr\//) { &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area); + } elsif ($trole eq 'gr') { + &group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart); } else { &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area); } } - } + } } - my ($author,$adv) = &set_userprivs(\$userroles,\%allroles); - $userroles.='user.adv='.$adv."\n". - 'user.author='.$author."\n"; - $ENV{'user.adv'}=$adv; + my ($author,$adv) = &set_userprivs(\%userroles,\%allroles,\%allgroups); + $userroles{'user.adv'} = $adv; + $userroles{'user.author'} = $author; + $env{'user.adv'}=$adv; } - return $userroles; + 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"; + return ('user.role.'.$trole.'.'.$area => $tstart.'.'.$tend); } sub custom_roleprivs { @@ -2370,6 +2842,17 @@ sub custom_roleprivs { } } +sub group_roleprivs { + my ($allgroups,$area,$group_privs,$tend,$tstart) = @_; + my $access = 1; + my $now = time; + if (($tend!=0) && ($tend<$now)) { $access = 0; } + if (($tstart!=0) && ($tstart>$now)) { $access=0; } + if ($access) { + my ($course,$group) = ($area =~ m|(/\w+/\w+)/([^/]+)$|); + $$allgroups{$course}{$group} .=':'.$group_privs; + } +} sub standard_roleprivs { my ($allroles,$trole,$tdomain,$spec,$trest,$area) = @_; @@ -2390,9 +2873,31 @@ sub standard_roleprivs { } sub set_userprivs { - my ($userroles,$allroles) = @_; + my ($userroles,$allroles,$allgroups) = @_; my $author=0; my $adv=0; + my %grouproles = (); + if (keys(%{$allgroups}) > 0) { + foreach my $role (keys %{$allroles}) { + my ($trole,$area,$sec,$extendedarea); + if ($role =~ m-^(\w+|cr/\w+/\w+/\w+)\.(/\w+/\w+)(/?\w*)-) { + $trole = $1; + $area = $2; + $sec = $3; + $extendedarea = $area.$sec; + if (exists($$allgroups{$area})) { + foreach my $group (keys(%{$$allgroups{$area}})) { + my $spec = $trole.'.'.$extendedarea; + $grouproles{$spec.'.'.$area.'/'.$group} = + $$allgroups{$area}{$group}; + } + } + } + } + } + foreach (keys(%grouproles)) { + $$allroles{$_} = $grouproles{$_}; + } foreach (keys %{$allroles}) { my %thesepriv=(); if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; } @@ -2409,7 +2914,7 @@ sub set_userprivs { } my $thesestr=''; foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } - $$userroles.='user.priv.'.$_.'='.$thesestr."\n"; + $userroles->{'user.priv.'.$_} = $thesestr; } return ($author,$adv); } @@ -2423,8 +2928,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); @@ -2450,8 +2955,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); @@ -2460,31 +2965,40 @@ sub del { # -------------------------------------------------------------- dump interface sub dump { - my ($namespace,$udomain,$uname,$regexp)=@_; - if (!$udomain) { $udomain=$ENV{'user.domain'}; } - if (!$uname) { $uname=$ENV{'user.name'}; } - my $uhome=&homeserver($uname,$udomain); - if ($regexp) { - $regexp=&escape($regexp); - } else { - $regexp='.'; - } - my $rep=reply("dump:$udomain:$uname:$namespace:$regexp",$uhome); - my @pairs=split(/\&/,$rep); - my %returnhash=(); - foreach (@pairs) { - my ($key,$value)=split(/=/,$_); - $returnhash{unescape($key)}=&thaw_unescape($value); - } - return %returnhash; + my ($namespace,$udomain,$uname,$regexp,$range)=@_; + if (!$udomain) { $udomain=$env{'user.domain'}; } + if (!$uname) { $uname=$env{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); + if ($regexp) { + $regexp=&escape($regexp); + } else { + $regexp='.'; + } + my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome); + my @pairs=split(/\&/,$rep); + my %returnhash=(); + foreach my $item (@pairs) { + my ($key,$value)=split(/=/,$item,2); + $key = &unescape($key); + next if ($key =~ /^error: 2 /); + $returnhash{$key}=&thaw_unescape($value); + } + return %returnhash; +} + +# --------------------------------------------------------- dumpstore interface + +sub dumpstore { + my ($namespace,$udomain,$uname,$regexp,$range)=@_; + return &dump($namespace,$udomain,$uname,$regexp,$range); } # -------------------------------------------------------------- keys interface 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=(); @@ -2497,9 +3011,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)/); @@ -2553,12 +3067,18 @@ sub convert_dump_to_currentdump{ return \%returnhash; } +# ------------------------------------------------------ critical inc interface + +sub cinc { + return &inc(@_,'critical'); +} + # --------------------------------------------------------------- inc interface sub inc { - my ($namespace,$store,$udomain,$uname) = @_; - if (!$udomain) { $udomain=$ENV{'user.domain'}; } - if (!$uname) { $uname=$ENV{'user.name'}; } + my ($namespace,$store,$udomain,$uname,$critical) = @_; + if (!$udomain) { $udomain=$env{'user.domain'}; } + if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); my $items=''; if (! ref($store)) { @@ -2574,15 +3094,19 @@ sub inc { } } $items=~s/\&$//; - return &reply("inc:$udomain:$uname:$namespace:$items",$uhome); + if ($critical) { + return &critical("inc:$udomain:$uname:$namespace:$items",$uhome); + } else { + return &reply("inc:$udomain:$uname:$namespace:$items",$uhome); + } } # --------------------------------------------------------------- put interface 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) { @@ -2592,40 +3116,83 @@ sub put { return &reply("put:$udomain:$uname:$namespace:$items",$uhome); } -# ---------------------------------------------------------- putstore interface - -sub putstore { +# ------------------------------------------------------------ newput interface + +sub newput { 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=''; - my %allitems = (); - foreach (keys %$storehash) { - if ($_ =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) { - my $key = $1.':keys:'.$2; - $allitems{$key} .= $3.':'; - } - $items.=$_.'='.&freeze_escape($$storehash{$_}).'&'; + foreach my $key (keys(%$storehash)) { + $items.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&'; } - foreach (keys %allitems) { - $allitems{$_} =~ s/\:$//; - $items.= $_.'='.$allitems{$_}.'&'; + $items=~s/\&$//; + return &reply("newput:$udomain:$uname:$namespace:$items",$uhome); +} + +# --------------------------------------------------------- putstore interface + +sub putstore { + my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_; + if (!$udomain) { $udomain=$env{'user.domain'}; } + if (!$uname) { $uname=$env{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); + my $items=''; + foreach my $key (keys(%$storehash)) { + $items.= &escape($key).'='.&freeze_escape($storehash->{$key}).'&'; } $items=~s/\&$//; - return &reply("put:$udomain:$uname:$namespace:$items",$uhome); + my $esc_symb=&escape($symb); + my $esc_v=&escape($version); + my $reply = + &reply("putstore:$udomain:$uname:$namespace:$esc_symb:$esc_v:$items", + $uhome); + if ($reply eq 'unknown_cmd') { + # gfall back to way things use to be done + return &old_putstore($namespace,$symb,$version,$storehash,$udomain, + $uname); + } + return $reply; +} + +sub old_putstore { + my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_; + if (!$udomain) { $udomain=$env{'user.domain'}; } + if (!$uname) { $uname=$env{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); + my %newstorehash; + foreach (keys %$storehash) { + my $key = $version.':'.&escape($symb).':'.$_; + $newstorehash{$key} = $storehash->{$_}; + } + my $items=''; + my %allitems = (); + foreach (keys %newstorehash) { + if ($_ =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) { + my $key = $1.':keys:'.$2; + $allitems{$key} .= $3.':'; + } + $items.=$_.'='.&freeze_escape($newstorehash{$_}).'&'; + } + foreach (keys %allitems) { + $allitems{$_} =~ s/\:$//; + $items.= $_.'='.$allitems{$_}.'&'; + } + $items=~s/\&$//; + return &reply("put:$udomain:$uname:$namespace:$items",$uhome); } # ------------------------------------------------------ critical put interface sub cput { my ($namespace,$storehash,$udomain,$uname)=@_; - if (!$udomain) { $udomain=$ENV{'user.domain'}; } - if (!$uname) { $uname=$ENV{'user.name'}; } + if (!$udomain) { $udomain=$env{'user.domain'}; } + if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); my $items=''; foreach (keys %$storehash) { - $items.=escape($_).'='.&freeze_escape($$storehash{$_}).'&'; + $items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; } $items=~s/\&$//; return &critical("put:$udomain:$uname:$namespace:$items",$uhome); @@ -2640,8 +3207,8 @@ 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); @@ -2654,11 +3221,254 @@ sub eget { return %returnhash; } +# ------------------------------------------------------------ tmpput interface +sub tmpput { + my ($storehash,$server)=@_; + my $items=''; + foreach (keys(%$storehash)) { + $items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; + } + $items=~s/\&$//; + return &reply("tmpput:$items",$server); +} + +# ------------------------------------------------------------ tmpget interface +sub tmpget { + my ($token,$server)=@_; + if (!defined($server)) { $server = $perlvar{'lonHostID'}; } + my $rep=&reply("tmpget:$token",$server); + my %returnhash; + foreach my $item (split(/\&/,$rep)) { + my ($key,$value)=split(/=/,$item); + $returnhash{&unescape($key)}=&thaw_unescape($value); + } + return %returnhash; +} + +# ------------------------------------------------------------ tmpget interface +sub tmpdel { + my ($token,$server)=@_; + if (!defined($server)) { $server = $perlvar{'lonHostID'}; } + return &reply("tmpdel:$token",$server); +} + +# -------------------------------------------------- portfolio access checking + +sub portfolio_access { + my ($requrl) = @_; + my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl); + my $result = &get_portfolio_access($udom,$unum,$file_name,$group); + if ($result eq 'ok') { + return 'F'; + } elsif ($result =~ /^[^:]+:guest_/) { + return 'A'; + } + return ''; +} + +sub get_portfolio_access { + my ($udom,$unum,$file_name,$group,$access_hash) = @_; + + if (!ref($access_hash)) { + my $current_perms = &get_portfile_permissions($udom,$unum); + my %access_controls = &get_access_controls($current_perms,$group, + $file_name); + $access_hash = $access_controls{$file_name}; + } + + my ($public,$guest,@domains,@users,@courses,@groups); + my $now = time; + if (ref($access_hash) eq 'HASH') { + foreach my $key (keys(%{$access_hash})) { + my ($num,$scope,$end,$start) = ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/); + if ($start > $now) { + next; + } + if ($end && $end<$now) { + next; + } + if ($scope eq 'public') { + $public = $key; + last; + } elsif ($scope eq 'guest') { + $guest = $key; + } elsif ($scope eq 'domains') { + push(@domains,$key); + } elsif ($scope eq 'users') { + push(@users,$key); + } elsif ($scope eq 'course') { + push(@courses,$key); + } elsif ($scope eq 'group') { + push(@groups,$key); + } + } + if ($public) { + return 'ok'; + } + if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') { + if ($guest) { + return $guest; + } + } else { + if (@domains > 0) { + foreach my $domkey (@domains) { + if (ref($access_hash->{$domkey}{'dom'}) eq 'ARRAY') { + if (grep(/^\Q$env{'user.domain'}\E$/,@{$access_hash->{$domkey}{'dom'}})) { + return 'ok'; + } + } + } + } + if (@users > 0) { + foreach my $userkey (@users) { + if (exists($access_hash->{$userkey}{'users'}{$env{'user.name'}.':'.$env{'user.domain'}})) { + return 'ok'; + } + } + } + my %roleshash; + my @courses_and_groups = @courses; + push(@courses_and_groups,@groups); + if (@courses_and_groups > 0) { + my (%allgroups,%allroles); + my ($start,$end,$role,$sec,$group); + foreach my $envkey (%env) { + if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./([^/]+)/([^/]+)/?([^/]*)$-) { + my $cid = $2.'_'.$3; + if ($1 eq 'gr') { + $group = $4; + $allgroups{$cid}{$group} = $env{$envkey}; + } else { + if ($4 eq '') { + $sec = 'none'; + } else { + $sec = $4; + } + $allroles{$cid}{$1}{$sec} = $env{$envkey}; + } + } elsif ($envkey =~ m-^user\.role\./cr/(\w+/\w+/\w*)./([^/]+)/([^/]+)/?([^/]*)$-) { + my $cid = $2.'_'.$3; + if ($4 eq '') { + $sec = 'none'; + } else { + $sec = $4; + } + $allroles{$cid}{$1}{$sec} = $env{$envkey}; + } + } + if (keys(%allroles) == 0) { + return; + } + foreach my $key (@courses_and_groups) { + my %content = %{$$access_hash{$key}}; + my $cnum = $content{'number'}; + my $cdom = $content{'domain'}; + my $cid = $cdom.'_'.$cnum; + if (!exists($allroles{$cid})) { + next; + } + foreach my $role_id (keys(%{$content{'roles'}})) { + my @sections = @{$content{'roles'}{$role_id}{'section'}}; + my @groups = @{$content{'roles'}{$role_id}{'group'}}; + my @status = @{$content{'roles'}{$role_id}{'access'}}; + my @roles = @{$content{'roles'}{$role_id}{'role'}}; + foreach my $role (keys(%{$allroles{$cid}})) { + if ((grep/^all$/,@roles) || (grep/^\Q$role\E$/,@roles)) { + foreach my $sec (keys(%{$allroles{$cid}{$role}})) { + if (&course_group_datechecker($allroles{$cid}{$role}{$sec},$now,\@status) eq 'ok') { + if (grep/^all$/,@sections) { + return 'ok'; + } else { + if (grep/^$sec$/,@sections) { + return 'ok'; + } + } + } + } + if (keys(%{$allgroups{$cid}}) == 0) { + if (grep/^none$/,@groups) { + return 'ok'; + } + } else { + if (grep/^all$/,@groups) { + return 'ok'; + } + foreach my $group (keys(%{$allgroups{$cid}})) { + if (grep/^$group$/,@groups) { + return 'ok'; + } + } + } + } + } + } + } + } + if ($guest) { + return $guest; + } + } + } + return; +} + +sub course_group_datechecker { + my ($dates,$now,$status) = @_; + my ($start,$end) = split(/\./,$dates); + if (!$start && !$end) { + return 'ok'; + } + if (grep/^active$/,@{$status}) { + if (((!$start) || ($start && $start <= $now)) && ((!$end) || ($end && $end >= $now))) { + return 'ok'; + } + } + if (grep/^previous$/,@{$status}) { + if ($end > $now ) { + return 'ok'; + } + } + if (grep/^future$/,@{$status}) { + if ($start > $now) { + return 'ok'; + } + } + return; +} + +sub parse_portfolio_url { + my ($url) = @_; + + my ($type,$udom,$unum,$group,$file_name); + + if ($url =~ m-^/*uploaded/([^/]+)/([^/]+)/portfolio(/.+)$-) { + $type = 1; + $udom = $1; + $unum = $2; + $file_name = $3; + } elsif ($url =~ m-^/*uploaded/([^/]+)/([^/]+)/groups/([^/]+)/portfolio/(.+)$-) { + $type = 2; + $udom = $1; + $unum = $2; + $group = $3; + $file_name = $3.'/'.$4; + } + if (wantarray) { + return ($type,$udom,$unum,$file_name,$group); + } + return $type; +} + +sub is_portfolio_url { + my ($url) = @_; + return scalar(&parse_portfolio_url($url)); +} + # ---------------------------------------------- Custom access rule evaluation 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; @@ -2692,47 +3502,72 @@ sub customaccess { sub allowed { my ($priv,$uri,$symb)=@_; + my $ver_orguri=$uri; $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 !~ m|/bulletinboard$|)) - || ($uri=~/\.meta$/)) && ($priv eq 'bre')) { + if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$})) + || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) + && ($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)) { + my ($space,$domain,$name,@dir)=split('/',$uri); + if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) && + ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) { return 'F'; } +# bre access to group portfolio for rgf priv in group, or mdg or vcg in course. + if (($space=~/^(uploaded|editupload)$/) && ($dir[0] eq 'groups') + && ($dir[2] eq 'portfolio') && ($priv eq 'bre')) { + if (exists($env{'request.course.id'})) { + my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; + my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; + if (($domain eq $cdom) && ($name eq $cnum)) { + my $courseprivid=$env{'request.course.id'}; + $courseprivid=~s/\_/\//; + if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid + .'/'.$dir[1]} =~/rgf\&([^\:]*)/) { + return $1; + } else { + if ($env{'request.course.sec'}) { + $courseprivid.='/'.$env{'request.course.sec'}; + } + if ($env{'user.priv.'.$env{'request.role'}.'./'. + $courseprivid} =~/(mdg|vcg)\&([^\:]*)/) { + return $2; + } + } + } + } + } + # 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'; } @@ -2741,11 +3576,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'}); + # a role of dc for the domain in question. + return 'F' if ($uri eq $env{'request.role.domain'}); } my $thisallowed=''; @@ -2754,13 +3589,13 @@ sub allowed { # Course - if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) { + if ($env{'user.priv.'.$env{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) { $thisallowed.=$1; } # Domain - if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.(split(/\//,$uri))[0].'/'} + if ($env{'user.priv.'.$env{'request.role'}.'./'.(split(/\//,$uri))[0].'/'} =~/\Q$priv\E\&([^\:]*)/) { $thisallowed.=$1; } @@ -2770,22 +3605,44 @@ sub allowed { $courseuri=~s/\_(\d)/\/$1/; $courseuri=~s/^([^\/])/\/$1/; - if ($ENV{'user.priv.'.$ENV{'request.role'}.'.'.$courseuri} + if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri} =~/\Q$priv\E\&([^\:]*)/) { $thisallowed.=$1; } -# URI is an uploaded document for this course +# URI is an uploaded document for this course, default permissions don't matter # not allowing 'edit' access (editupload) to uploaded course docs if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) { - my $refuri=$ENV{'httpref.'.$origuri}; - if ($refuri) { - if ($refuri =~ m|^/adm/|) { - $thisallowed='F'; - } - } + $thisallowed=''; + my ($match)=&is_on_map($uri); + if ($match) { + if ($env{'user.priv.'.$env{'request.role'}.'./'} + =~/\Q$priv\E\&([^\:]*)/) { + $thisallowed.=$1; + } + } else { + my $refuri = $env{'httpref.'.$orguri} || $env{'httpref.'.$ver_orguri}; + if ($refuri) { + if ($refuri =~ m|^/adm/|) { + $thisallowed='F'; + } else { + $refuri=&declutter($refuri); + my ($match) = &is_on_map($refuri); + if ($match) { + $thisallowed='F'; + } + } + } + } } + if ($priv eq 'bre' + && $thisallowed ne 'F' + && $thisallowed ne '2' + && &is_portfolio_url($uri)) { + $thisallowed = &portfolio_access($uri); + } + # Full access at system, domain or course-wide level? Exit. if ($thisallowed=~/F/) { @@ -2794,7 +3651,16 @@ 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:'=~/\:\Q$priv\E\:/) { + if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:caa:'=~/\:\Q$priv\E\:/) { + if (($priv eq 'cca') || ($priv eq 'caa')) { + my ($audom,$auname)=split('/',$uri); +# no author name given, so this just checks on the general right to make a co-author in this domain + unless ($auname) { return $thisallowed; } +# an author name is given, so we are about to actually make a co-author for a certain account + if (($auname ne $env{'user.name'} && $env{'request.role'} !~ /^dc\./) || + (($audom ne $env{'user.domain'} && $env{'request.role'} !~ /^dc\./) && + ($audom ne $env{'request.role.domain'}))) { return ''; } + } return $thisallowed; } # @@ -2803,18 +3669,18 @@ 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} + if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid} =~/\Q$priv\E\&([^\:]*)/) { $thisallowed.=$1; $checkreferer=0; @@ -2822,16 +3688,16 @@ sub allowed { } 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{$_}; } } } @@ -2842,7 +3708,7 @@ sub allowed { my ($match,$cond)=&is_on_map($refuri); if ($match) { my $refstatecond=$cond; - if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} + if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid} =~/\Q$priv\E\&([^\:]*)/) { $thisallowed.=$1; $uri=$refuri; @@ -2882,39 +3748,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) { - &coursedescription($courseid); + if ((time-$env{$prefix.'last_cache'})>$expiretime) { + &coursedescription($courseid,{'freshen_cache' => 1}); } - 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'}, + 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'}=~/\,\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'}, + 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 ''; } } @@ -2926,8 +3792,12 @@ sub allowed { # Rest of the restrictions depend on selected course # - unless ($ENV{'request.course.id'}) { - return '1'; + unless ($env{'request.course.id'}) { + if ($thisallowed eq 'A') { + return 'A'; + } else { + return '1'; + } } # @@ -2938,21 +3808,25 @@ 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'} + 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'}); + if ($priv ne 'pch') { + &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'. + 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. + $env{'request.course.id'}); + } return ''; } - if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.users.denied'} + 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'}); + if ($priv ne 'pch') { + &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}. + 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '. + $env{'request.course.id'}); + } return ''; } } @@ -2960,20 +3834,22 @@ sub allowed { # Resource preferences if ($thisallowed=~/R/) { - my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; + 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 ''; + if ($priv ne 'pch') { + &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'. + 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); + } + return ''; } } # Restricted by state or randomout? if ($thisallowed=~/X/) { - if ($ENV{'acc.randomout'}) { + if ($env{'acc.randomout'}) { if (!$symb) { $symb=&symbread($uri,1); } - if (($symb) && ($ENV{'acc.randomout'}=~/\&\Q$symb\E\&/)) { + if (($symb) && ($env{'acc.randomout'}=~/\&\Q$symb\E\&/)) { return ''; } } @@ -2984,21 +3860,25 @@ sub allowed { } } + if ($thisallowed eq 'A') { + return 'A'; + } return 'F'; } +sub split_uri_for_cond { + my $uri=&deversion(&declutter(shift)); + my @uriparts=split(/\//,$uri); + my $filename=pop(@uriparts); + my $pathname=join('/',@uriparts); + return ($pathname,$filename); +} # --------------------------------------------------- Is a resource on the map? sub is_on_map { - my $uri=&declutter(shift); - $uri=~s/\.\d+\.(\w+)$/\.$1/; - my @uriparts=split(/\//,$uri); - my $filename=$uriparts[$#uriparts]; - my $pathname=$uri; - $pathname=~s|/\Q$filename\E$||; - $pathname=~s/^adm\/wrapper\///; + my ($pathname,$filename) = &split_uri_for_cond(shift); #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); @@ -3017,7 +3897,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) { @@ -3062,11 +3942,11 @@ sub definerole { } } } - 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'; } @@ -3128,7 +4008,7 @@ sub fetch_enrollment_query { $cmd =~ s/%%$//; $cmd = &escape($cmd); my $query = 'fetchenrollment'; - my $queryid=&reply("querysend:".$query.':'.$dom.':'.$ENV{'user.name'}.':'.$cmd,$homeserver); + 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; @@ -3140,7 +4020,7 @@ sub fetch_enrollment_query { $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); + &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'}) { @@ -3205,14 +4085,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); } @@ -3229,7 +4109,7 @@ sub auto_run { my $response = &reply('autorun:'.$cdom,$homeserver); return $response; } - + sub auto_get_sections { my ($cnum,$cdom,$inst_coursecode) = @_; my $homeserver = &homeserver($cnum,$cdom); @@ -3240,21 +4120,21 @@ sub auto_get_sections { } 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); @@ -3269,44 +4149,266 @@ sub auto_create_password { return ($authparam,$create_passwd,$authchk); } +sub auto_photo_permission { + my ($cnum,$cdom,$students) = @_; + my $homeserver = &homeserver($cnum,$cdom); + my ($outcome,$perm_reqd,$conditions) = + split(/:/,&unescape(&reply('autophotopermission:'.$cdom,$homeserver)),3); + if ($outcome =~ /^(con_lost|unknown_cmd|no_such_host)$/) { + return (undef,undef); + } + return ($outcome,$perm_reqd,$conditions); +} + +sub auto_checkphotos { + my ($uname,$udom,$pid) = @_; + my $homeserver = &homeserver($uname,$udom); + my ($result,$resulttype); + my $outcome = &unescape(&reply('autophotocheck:'.&escape($udom).':'. + &escape($uname).':'.&escape($pid), + $homeserver)); + if ($outcome =~ /^(con_lost|unknown_cmd|no_such_host)$/) { + return (undef,undef); + } + if ($outcome) { + ($result,$resulttype) = split(/:/,$outcome); + } + return ($result,$resulttype); +} + +sub auto_photochoice { + my ($cnum,$cdom) = @_; + my $homeserver = &homeserver($cnum,$cdom); + my ($update,$comment) = split(/:/,&unescape(&reply('autophotochoice:'. + &escape($cdom), + $homeserver))); + if ($update =~ /^(con_lost|unknown_cmd|no_such_host)$/) { + return (undef,undef); + } + return ($update,$comment); +} + +sub auto_photoupdate { + my ($affiliatesref,$dom,$cnum,$photo) = @_; + my $homeserver = &homeserver($cnum,$dom); + my $host=$hostname{$homeserver}; + my $cmd = ''; + my $maxtries = 1; + foreach (keys %{$affiliatesref}) { + $cmd .= $_.'='.join(",",@{$$affiliatesref{$_}}).'%%'; + } + $cmd =~ s/%%$//; + $cmd = &escape($cmd); + my $query = 'institutionalphotos'; + my $queryid=&reply("querysend:".$query.':'.$dom.':'.$cnum.':'.$cmd,$homeserver); + unless ($queryid=~/^\Q$host\E\_/) { + &logthis('institutionalphotos: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' and course: '.$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('institutionalphotos error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' course: '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries); + } else { + my @responses = split(/:/,$reply); + my $outcome = shift(@responses); + foreach my $item (@responses) { + my ($key,$value) = split(/=/,$item); + $$photo{$key} = $value; + } + return $outcome; + } + return 'error'; +} + sub auto_instcode_format { my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_; my $courses = ''; - my $homeserver; + my @homeservers; if ($caller eq 'global') { foreach my $tryserver (keys %libserv) { if ($hostdom{$tryserver} eq $codedom) { - $homeserver = $tryserver; - last; + if (!grep/^\Q$tryserver\E$/,@homeservers) { + push(@homeservers,$tryserver); + } } } - if (($ENV{'user.name'}) && ($ENV{'user.domain'} eq $codedom)) { - $homeserver = &homeserver($ENV{'user.name'},$codedom); - } } else { - $homeserver = &homeserver($caller,$codedom); + push(@homeservers,&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); + my $ok_response = 0; + my $response; + while (@homeservers > 0 && $ok_response == 0) { + my $server = shift(@homeservers); + $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server); + if ($response !~ /(con_lost|error|no_such_host|refused)/) { + my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = + split/:/,$response; + %{$codes} = (%{$codes},&str2hash($codes_str)); + push(@{$codetitles},&str2array($codetitles_str)); + %{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str)); + %{$cat_order} = (%{$cat_order},&str2hash($cat_order_str)); + $ok_response = 1; + } + } + if ($ok_response) { return 'ok'; + } else { + return $response; } +} + +sub auto_validate_class_sec { + my ($cdom,$cnum,$owner,$inst_class) = @_; + my $homeserver = &homeserver($cnum,$cdom); + my $response=&reply('autovalidateclass_sec:'.$inst_class.':'. + &escape($owner).':'.$cdom,$homeserver); return $response; } +# ------------------------------------------------------- Course Group routines + +sub get_coursegroups { + my ($cdom,$cnum,$group) = @_; + return(&dump('coursegroups',$cdom,$cnum,$group)); +} + +sub modify_coursegroup { + my ($cdom,$cnum,$groupsettings) = @_; + return(&put('coursegroups',$groupsettings,$cdom,$cnum)); +} + +sub modify_group_roles { + my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs) = @_; + my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id; + my $role = 'gr/'.&escape($userprivs); + my ($uname,$udom) = split(/:/,$user); + my $result = &assignrole($udom,$uname,$url,$role,$end,$start); + if ($result eq 'ok') { + &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum); + } + return $result; +} + +sub modify_coursegroup_membership { + my ($cdom,$cnum,$membership) = @_; + my $result = &put('groupmembership',$membership,$cdom,$cnum); + return $result; +} + +sub get_active_groups { + my ($udom,$uname,$cdom,$cnum) = @_; + my $now = time; + my %groups = (); + foreach my $key (keys(%env)) { + if ($key =~ m-user\.role\.gr\./([^/]+)/([^/]+)/(\w+)$-) { + my ($start,$end) = split(/\./,$env{$key}); + if (($end!=0) && ($end<$now)) { next; } + if (($start!=0) && ($start>$now)) { next; } + if ($1 eq $cdom && $2 eq $cnum) { + $groups{$3} = $env{$key} ; + } + } + } + return %groups; +} + +sub get_group_membership { + my ($cdom,$cnum,$group) = @_; + return(&dump('groupmembership',$cdom,$cnum,$group)); +} + +sub get_users_groups { + my ($udom,$uname,$courseid) = @_; + my @usersgroups; + my $cachetime=1800; + $courseid=~s/\_/\//g; + $courseid=~s/^(\w)/\/$1/; + + my $hashid="$udom:$uname:$courseid"; + my ($grouplist,$cached)=&is_cached_new('getgroups',$hashid); + if (defined($cached)) { + @usersgroups = split(/:/,$grouplist); + } else { + $grouplist = ''; + my %roleshash = &dump('roles',$udom,$uname,$courseid); + my ($tmp) = keys(%roleshash); + if ($tmp=~/^error:/) { + &logthis('Error retrieving roles: '.$tmp.' for '.$uname.':'.$udom); + } else { + my $access_end = $env{'course.'.$courseid. + '.default_enrollment_end_date'}; + my $now = time; + foreach my $key (keys(%roleshash)) { + if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) { + my $group = $1; + if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) { + my $start = $2; + my $end = $1; + if ($start == -1) { next; } # deleted from group + if (($start!=0) && ($start>$now)) { next; } + if (($end!=0) && ($end<$now)) { + if ($access_end && $access_end < $now) { + if ($access_end - $end < 86400) { + push(@usersgroups,$group); + } + } + next; + } + push(@usersgroups,$group); + } + } + } + @usersgroups = &sort_course_groups($courseid,@usersgroups); + $grouplist = join(':',@usersgroups); + &do_cache_new('getgroups',$hashid,$grouplist,$cachetime); + } + } + return @usersgroups; +} + +sub devalidate_getgroups_cache { + my ($udom,$uname,$cdom,$cnum)=@_; + my $courseid = $cdom.'_'.$cnum; + $courseid=~s/\_/\//g; + $courseid=~s/^(\w)/\/$1/; + my $hashid="$udom:$uname:$courseid"; + &devalidate_cache_new('getgroups',$hashid); +} + # ------------------------------------------------------------------ Plain Text sub plaintext { - my $short=shift; - return &mt($prp{$short}); + my ($short,$type,$cid) = @_; + if ($short =~ /^cr/) { + return (split('/',$short))[-1]; + } + if (!defined($cid)) { + $cid = $env{'request.course.id'}; + } + if (defined($cid) && defined($env{'course.'.$cid.'.'.$short.'.plaintext'})) { + return &Apache::lonlocal::mt($env{'course.'.$cid.'.'.$short. + '.plaintext'}); + } + my %rolenames = ( + Course => 'std', + Group => 'alt1', + ); + if (defined($type) && + defined($rolenames{$type}) && + defined($prp{$short}{$rolenames{$type}})) { + return &Apache::lonlocal::mt($prp{$short}{$rolenames{$type}}); + } else { + return &Apache::lonlocal::mt($prp{$short}{'std'}); + } } # ----------------------------------------------------------------- Assign Role @@ -3320,22 +4422,32 @@ 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'; + } elsif ($role =~ /^gr\//) { + my $cwogrp=$url; + $cwogrp=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/; + unless (&allowed('mdg',$cwogrp)) { + &logthis('Refused group assignrole: '. + $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. + $env{'user.name'}.' at '.$env{'user.domain'}); + return 'refused'; + } + $mrole='gr'; } else { my $cwosec=$url; $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/; unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) { &logthis('Refused assignrole: '. $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. - $ENV{'user.name'}.' at '.$ENV{'user.domain'}); + $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) { @@ -3345,13 +4457,15 @@ sub assignrole { $command.='_0_'.$start; } } + my $origstart = $start; + my $origend = $end; # actually delete if ($deleteflag) { if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) { # modify command to delete the role - $command="encrypt:rolesdel:$ENV{'user.domain'}:$ENV{'user.name'}:". + $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; @@ -3361,7 +4475,12 @@ sub assignrole { my $answer=&reply($command,&homeserver($uname,$udom)); # log new user role if status is ok if ($answer eq 'ok') { - &userrolelog($mrole,$uname,$udom,$url,$start,$end); + &userrolelog($role,$uname,$udom,$url,$start,$end); +# for course roles, perform group memberships changes triggered by role change. + unless ($role =~ /^gr/) { + &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend, + $origstart); + } } return $answer; } @@ -3374,16 +4493,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); @@ -3406,8 +4525,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') && @@ -3415,8 +4534,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; @@ -3484,10 +4603,11 @@ sub modifyuser { } my $reply = &put('environment', \%names, $udom,$uname); if ($reply ne 'ok') { return 'error: '.$reply; } + &devalidate_cache_new('namescache',$uname.':'.$udom); &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'; } @@ -3497,7 +4617,7 @@ sub modifystudent { my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, $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'; } } @@ -3518,15 +4638,15 @@ sub modify_student_enrollment { my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid) = @_; my ($cdom,$cnum,$chome); if (!$cid) { - unless ($cid=$ENV{'request.course.id'}) { + 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); } @@ -3564,6 +4684,8 @@ sub modify_student_enrollment { $cdom,$cnum); unless (($reply eq 'ok') || ($reply eq 'delayed')) { return 'error: '.$reply; + } else { + &devalidate_getsection_cache($udom,$uname,$cid); } # Add student role to user my $uurl='/'.$cid; @@ -3615,14 +4737,17 @@ sub writecoursepref { # ---------------------------------------------------------- Make/modify course sub createcourse { - my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,$course_owner)=@_; + my ($udom,$description,$url,$course_server,$nonstandard,$inst_code, + $course_owner,$crstype)=@_; $url=&declutter($url); my $cid=''; unless (&allowed('ccc',$udom)) { return 'refused'; } # ------------------------------------------------------------------- Create ID - my $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)). + my $uname=int(1+rand(9)). + ('a'..'z','A'..'Z','0'..'9')[int(rand(62))]. + substr($$.time,0,5).unpack("H8",pack("I32",time)). unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; # ----------------------------------------------- Make sure that does not exist my $uhome=&homeserver($uname,$udom,'true'); @@ -3635,7 +4760,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; } @@ -3650,7 +4775,8 @@ sub createcourse { # ----------------------------------------------------------------- Course made # log existence &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description). - ':'.&escape($inst_code).':'.&escape($course_owner),$uhome); + ':'.&escape($inst_code).':'.&escape($course_owner).':'. + &escape($crstype),$uhome); &flushcourselogs(); # set toplevel url my $topurl=$url; @@ -3658,7 +4784,7 @@ sub createcourse { # ------------------------------------------ For standard courses, make top url my $mapurl=&clutter($url); if ($mapurl eq '/res/') { $mapurl=''; } - $ENV{'form.initmap'}=(< @@ -3668,7 +4794,7 @@ sub createcourse { ENDINITMAP $topurl=&declutter( - &finishuserfileupload($uname,$udom,$uhome,'initmap','default.sequence') + &finishuserfileupload($uname,$udom,'initmap','default.sequence') ); } # ----------------------------------------------------------- Write preferences @@ -3716,24 +4842,44 @@ sub is_locked { my @check; my $is_locked; push @check, $file_name; - my %locked = &Apache::lonnet::get('file_permissions',\@check, - $ENV{'user.domain'},$ENV{'user.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'; + $is_locked = 'false'; + foreach my $entry (@{$locked{$file_name}}) { + if (ref($entry) eq 'ARRAY') { + $is_locked = 'true'; + last; + } + } } else { $is_locked = 'false'; } } +sub declutter_portfile { + my ($file) = @_; + &logthis("got $file"); + $file =~ s-^(/portfolio/|portfolio/)-/-; + &logthis("ret $file"); + return $file; +} + # ------------------------------------------------------------- Mark as Read Only sub mark_as_readonly { my ($domain,$user,$files,$what) = @_; - my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user); + my %current_permissions = &dump('file_permissions',$domain,$user); + my ($tmp)=keys(%current_permissions); + if ($tmp=~/^error:/) { undef(%current_permissions); } foreach my $file (@{$files}) { + $file = &declutter_portfile($file); push(@{$current_permissions{$file}},$what); } - &Apache::lonnet::put('file_permissions',\%current_permissions,$domain,$user); + &put('file_permissions',\%current_permissions,$domain,$user); return; } @@ -3745,7 +4891,7 @@ sub save_selected_files { 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"); + print (OUT $env{'form.currentpath'}.$file."\n"); } foreach my $file (@other_files) { print (OUT $file."\n"); @@ -3806,39 +4952,195 @@ sub files_not_in_path { return (@return_files); } -#--------------------------------------------------------------Get Marked as Read Only +#----------------------------------------------Get portfolio file permissions + +sub get_portfile_permissions { + my ($domain,$user) = @_; + my %current_permissions = &dump('file_permissions',$domain,$user); + my ($tmp)=keys(%current_permissions); + if ($tmp=~/^error:/) { undef(%current_permissions); } + return \%current_permissions; +} + +#---------------------------------------------Get portfolio file access controls + +sub get_access_controls { + my ($current_permissions,$group,$file) = @_; + my %access; + my $real_file = $file; + $file =~ s/\.meta$//; + if (defined($file)) { + if (ref($$current_permissions{$file."\0".'accesscontrol'}) eq 'HASH') { + foreach my $control (keys(%{$$current_permissions{$file."\0".'accesscontrol'}})) { + $access{$real_file}{$control} = $$current_permissions{$file."\0".$control}; + } + } + } else { + foreach my $key (keys(%{$current_permissions})) { + if ($key =~ /\0accesscontrol$/) { + if (defined($group)) { + if ($key !~ m-^\Q$group\E/-) { + next; + } + } + my ($fullpath) = split(/\0/,$key); + if (ref($$current_permissions{$key}) eq 'HASH') { + foreach my $control (keys(%{$$current_permissions{$key}})) { + $access{$fullpath}{$control}=$$current_permissions{$fullpath."\0".$control}; + } + } + } + } + } + return %access; +} + +sub modify_access_controls { + my ($file_name,$changes,$domain,$user)=@_; + my ($outcome,$deloutcome); + my %store_permissions; + my %new_values; + my %new_control; + my %translation; + my @deletions = (); + my $now = time; + if (exists($$changes{'activate'})) { + if (ref($$changes{'activate'}) eq 'HASH') { + my @newitems = sort(keys(%{$$changes{'activate'}})); + my $numnew = scalar(@newitems); + for (my $i=0; $i<$numnew; $i++) { + my $newkey = $newitems[$i]; + my $newid = &Apache::loncommon::get_cgi_id(); + $newkey =~ s/^(\d+)/$newid/; + $translation{$1} = $newid; + $new_values{$file_name."\0".$newkey} = + $$changes{'activate'}{$newitems[$i]}; + $new_control{$newkey} = $now; + } + } + } + my %todelete; + my %changed_items; + foreach my $action ('delete','update') { + if (exists($$changes{$action})) { + if (ref($$changes{$action}) eq 'HASH') { + foreach my $key (keys(%{$$changes{$action}})) { + my ($itemnum) = ($key =~ /^([^:]+):/); + if ($action eq 'delete') { + $todelete{$itemnum} = 1; + } else { + $changed_items{$itemnum} = $key; + } + } + } + } + } + # get lock on access controls for file. + my $lockhash = { + $file_name."\0".'locked_access_records' => $env{'user.name'}. + ':'.$env{'user.domain'}, + }; + my $tries = 0; + my $gotlock = &newput('file_permissions',$lockhash,$domain,$user); + + while (($gotlock ne 'ok') && $tries <3) { + $tries ++; + sleep 1; + $gotlock = &newput('file_permissions',$lockhash,$domain,$user); + } + if ($gotlock eq 'ok') { + my %curr_permissions = &dump('file_permissions',$domain,$user,$file_name); + my ($tmp)=keys(%curr_permissions); + if ($tmp=~/^error:/) { undef(%curr_permissions); } + if (exists($curr_permissions{$file_name."\0".'accesscontrol'})) { + my $curr_controls = $curr_permissions{$file_name."\0".'accesscontrol'}; + if (ref($curr_controls) eq 'HASH') { + foreach my $control_item (keys(%{$curr_controls})) { + my ($itemnum) = ($control_item =~ /^([^:]+):/); + if (defined($todelete{$itemnum})) { + push(@deletions,$file_name."\0".$control_item); + } else { + if (defined($changed_items{$itemnum})) { + $new_control{$changed_items{$itemnum}} = $now; + push(@deletions,$file_name."\0".$control_item); + $new_values{$file_name."\0".$changed_items{$itemnum}} = $$changes{'update'}{$changed_items{$itemnum}}; + } else { + $new_control{$control_item} = $$curr_controls{$control_item}; + } + } + } + } + } + $deloutcome = &del('file_permissions',\@deletions,$domain,$user); + $new_values{$file_name."\0".'accesscontrol'} = \%new_control; + $outcome = &put('file_permissions',\%new_values,$domain,$user); + # remove lock + my @del_lock = ($file_name."\0".'locked_access_records'); + my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user); + } else { + $outcome = "error: could not obtain lockfile\n"; + } + return ($outcome,$deloutcome,\%new_values,\%translation); +} + +#------------------------------------------------------Get Marked as Read Only sub get_marked_as_readonly { - my ($domain,$user,$what) = @_; - my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user); + my ($domain,$user,$what,$group) = @_; + my $current_permissions = &get_portfile_permissions($domain,$user); my @readonly_files; - while (my ($file_name,$value) = each(%current_permissions)) { + my $cmp1=$what; + if (ref($what)) { $cmp1=join('',@{$what}) }; + while (my ($file_name,$value) = each(%{$current_permissions})) { + if (defined($group)) { + if ($file_name !~ m-^\Q$group\E/-) { + next; + } + } if (ref($value) eq "ARRAY"){ foreach my $stored_what (@{$value}) { - if ($stored_what eq $what) { + my $cmp2=$stored_what; + if (ref($stored_what) eq 'ARRAY') { + $cmp2=join('',@{$stored_what}); + } + if ($cmp1 eq $cmp2) { push(@readonly_files, $file_name); + last; } elsif (!defined($what)) { push(@readonly_files, $file_name); + last; } } - } + } } return @readonly_files; } #-----------------------------------------------------------Get Marked as Read Only Hash sub get_marked_as_readonly_hash { - my ($domain,$user,$what) = @_; - my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user); + my ($current_permissions,$group,$what) = @_; my %readonly_files; - while (my ($file_name,$value) = each(%current_permissions)) { + while (my ($file_name,$value) = each(%{$current_permissions})) { + if (defined($group)) { + if ($file_name !~ m-^\Q$group\E/-) { + next; + } + } 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'; - } + if (ref($stored_what) eq 'ARRAY') { + foreach my $lock_descriptor(@{$stored_what}) { + if ($lock_descriptor eq 'graded') { + $readonly_files{$file_name} = 'graded'; + } elsif ($lock_descriptor eq 'handback') { + $readonly_files{$file_name} = 'handback'; + } else { + if (!exists($readonly_files{$file_name})) { + $readonly_files{$file_name} = 'locked'; + } + } + } + } } } } @@ -3847,31 +5149,42 @@ sub get_marked_as_readonly_hash { # ------------------------------------------------------------ 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 = &Apache::lonnet::dump('file_permissions',$domain,$user); - my @readonly_files = &Apache::lonnet::get_marked_as_readonly($domain,$user,$what); - foreach my $file(@readonly_files){ - my $current_locks = $current_permissions{$file}; + # unmarks $file_name (if $file_name is defined), or all files locked by $what + # for portfolio submissions, $what contains [$symb,$crsid] + my ($domain,$user,$what,$file_name,$group) = @_; + $file_name = &declutter_portfile($file_name); + my $symb_crs = $what; + if (ref($what)) { $symb_crs=join('',@$what); } + my %current_permissions = &dump('file_permissions',$domain,$user,$group); + my ($tmp)=keys(%current_permissions); + if ($tmp=~/^error:/) { undef(%current_permissions); } + my @readonly_files = &get_marked_as_readonly($domain,$user,$what,$group); + foreach my $file (@readonly_files) { + my $clean_file = &declutter_portfile($file); + if (defined($file_name) && ($file_name ne $clean_file)) { next; } + 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); + my $compare=$locker; + if (ref($locker) eq 'ARRAY') { + $compare=join('',@{$locker}); + if ($compare ne $symb_crs) { + push(@new_locks, $locker); + } } } - if (@new_locks > 0) { + if (scalar(@new_locks) > 0) { $current_permissions{$file} = \@new_locks; } else { push(@del_keys, $file); - &Apache::lonnet::del('file_permissions',\@del_keys, $domain, $user); - delete $current_permissions{$file}; + &del('file_permissions',\@del_keys, $domain, $user); + delete($current_permissions{$file}); } } } - &Apache::lonnet::put('file_permissions',\%current_permissions,$domain,$user); + &put('file_permissions',\%current_permissions,$domain,$user); return; } @@ -3997,57 +5310,119 @@ sub GetFileTimestamp { } } +sub stat_file { + my ($uri) = @_; + $uri = &clutter($uri); + + # we want just the url part without the unneeded accessor url bits + if ($uri =~ m-^/adm/-) { + $uri=~s-^/adm/wrapper/-/-; + $uri=~s-^/adm/coursedocs/showdoc/-/-; + } + my ($udom,$uname,$file,$dir); + if ($uri =~ m-^/(uploaded|editupload)/-) { + ($udom,$uname,$file) = + ($uri =~ m-/(?:uploaded|editupload)/?([^/]*)/?([^/]*)/?(.*)-); + $file = 'userfiles/'.$file; + $dir = &propath($udom,$uname); + } + if ($uri =~ m-^/res/-) { + ($udom,$uname) = + ($uri =~ m-/(?:res)/?([^/]*)/?([^/]*)/-); + $file = $uri; + } + + if (!$udom || !$uname || !$file) { + # unable to handle the uri + return (); + } + + my ($result) = &dirlist($file,$udom,$uname,$dir); + my @stats = split('&', $result); + + if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') { + shift(@stats); #filename is first + return @stats; + } + return (); +} + # -------------------------------------------------------- Value of a Condition +# gets the value of a specific preevaluated condition +# stored in the string $env{user.state.} +# or looks up a condition reference in the bighash and if if hasn't +# already been evaluated recurses into docondval to get the value of +# the condition, then memoizing it to +# $env{user.state..} sub directcondval { my $number=shift; - if (!defined($ENV{'user.state.'.$ENV{'request.course.id'}})) { + 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); + if (exists($env{'user.state.'.$env{'request.course.id'}.".$number"})) { + return $env{'user.state.'.$env{'request.course.id'}.".$number"}; + } elsif ($number =~ /^_/) { + my $sub_condition; + if (tie(my %bighash,'GDBM_File',$env{'request.course.fn'}.'.db', + &GDBM_READER(),0640)) { + $sub_condition=$bighash{'conditions'.$number}; + untie(%bighash); + } + my $value = &docondval($sub_condition); + &appenv('user.state.'.$env{'request.course.id'}.".$number" => $value); + return $value; + } + if ($env{'user.state.'.$env{'request.course.id'}}) { + return substr($env{'user.state.'.$env{'request.course.id'}},$number,1); } else { return 2; } } +# get the collection of conditions for this resource sub condval { my $condidx=shift; - my $result=0; my $allpathcond=''; - foreach (split(/\|/,$condidx)) { - if (defined($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_})) { - $allpathcond.= - '('.$ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_}.')|'; - } + foreach my $cond (split(/\|/,$condidx)) { + if (defined($env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond})) { + $allpathcond.= + '('.$env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond}.')|'; + } } $allpathcond=~s/\|$//; - if ($ENV{'request.course.id'}) { - if ($allpathcond) { - my $operand='|'; - my @stack; - foreach ($allpathcond=~/(\d+|\(|\)|\&|\|)/g) { - if ($_ eq '(') { - push @stack,($operand,$result) - } elsif ($_ eq ')') { - my $before=pop @stack; - if (pop @stack eq '&') { - $result=$result>$before?$before:$result; - } else { - $result=$result>$before?$result:$before; - } - } elsif (($_ eq '&') || ($_ eq '|')) { - $operand=$_; - } else { - my $new=directcondval($_); - if ($operand eq '&') { - $result=$result>$new?$new:$result; - } else { - $result=$result>$new?$result:$new; - } - } - } - } + return &docondval($allpathcond); +} + +#evaluates an expression of conditions +sub docondval { + my ($allpathcond) = @_; + my $result=0; + if ($env{'request.course.id'} + && defined($allpathcond)) { + my $operand='|'; + my @stack; + foreach my $chunk ($allpathcond=~/(\d+|_\d+\.\d+|\(|\)|\&|\|)/g) { + if ($chunk eq '(') { + push @stack,($operand,$result); + } elsif ($chunk eq ')') { + my $before=pop @stack; + if (pop @stack eq '&') { + $result=$result>$before?$before:$result; + } else { + $result=$result>$before?$result:$before; + } + } elsif (($chunk eq '&') || ($chunk eq '|')) { + $operand=$chunk; + } else { + my $new=directcondval($chunk); + if ($operand eq '&') { + $result=$result>$new?$new:$result; + } else { + $result=$result>$new?$result:$new; + } + } + } } return $result; } @@ -4060,15 +5435,17 @@ sub devalidatecourseresdata { &devalidate_cache_new('courseres',$hashid); } + # --------------------------------------------------- Course Resourcedata Query -sub courseresdata { - my ($coursenum,$coursedomain,@which)=@_; +sub get_courseresdata { + my ($coursenum,$coursedomain)=@_; my $coursehom=&homeserver($coursenum,$coursedomain); my $hashid=$coursenum.':'.$coursedomain; my ($result,$cached)=&is_cached_new('courseres',$hashid); + my %dumpreply; unless (defined($cached)) { - my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum); + %dumpreply=&dump('resourcedata',$coursedomain,$coursenum); $result=\%dumpreply; my ($tmp) = keys(%dumpreply); if ($tmp !~ /^(con_lost|error|no_such_host)/i) { @@ -4080,6 +5457,54 @@ sub courseresdata { &do_cache_new('courseres',$hashid,$result,600); } } + return $result; +} + +sub devalidateuserresdata { + my ($uname,$udom)=@_; + my $hashid="$udom:$uname"; + &devalidate_cache_new('userres',$hashid); +} + +sub get_userresdata { + my ($uname,$udom)=@_; + #most student don\'t have any data set, check if there is some data + if (&EXT_cache_status($udom,$uname)) { return undef; } + + my $hashid="$udom:$uname"; + my ($result,$cached)=&is_cached_new('userres',$hashid); + if (!defined($cached)) { + my %resourcedata=&dump('resourcedata',$udom,$uname); + $result=\%resourcedata; + &do_cache_new('userres',$hashid,$result,600); + } + my ($tmp)=keys(%$result); + if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) { + return $result; + } + #error 2 occurs when the .db doesn't exist + if ($tmp!~/error: 2 /) { + &logthis("WARNING:". + " Trying to get resource data for ". + $uname." at ".$udom.": ". + $tmp.""); + } elsif ($tmp=~/error: 2 /) { + #&EXT_cache_set($udom,$uname); + &do_cache_new('userres',$hashid,undef,600); + undef($tmp); # not really an error so don't send it back + } + return $tmp; +} + +sub resdata { + my ($name,$domain,$type,@which)=@_; + my $result; + if ($type eq 'course') { + $result=&get_courseresdata($name,$domain); + } elsif ($type eq 'user') { + $result=&get_userresdata($name,$domain); + } + if (!ref($result)) { return $result; } foreach my $item (@which) { if (defined($result->{$item})) { return $result->{$item}; @@ -4099,7 +5524,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 { @@ -4110,13 +5535,13 @@ sub EXT_cache_status { sub EXT_cache_set { my ($target_domain,$target_user) = @_; my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain; - &appenv($cachename => time); + #&appenv($cachename => time); } # --------------------------------------------------------- Value of a Variable sub EXT { - my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_; + my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_; unless ($varname) { return ''; } #get real user name/domain, courseid and symb my $courseid; @@ -4129,7 +5554,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; @@ -4146,11 +5571,20 @@ sub EXT { if ($realm eq 'user') { # --------------------------------------------------------------- user.resource if ($space eq 'resource') { - if (defined($Apache::lonhomework::parsing_a_problem)) { - return $Apache::lonhomework::history{$qualifierrest}; + if ( (defined($Apache::lonhomework::parsing_a_problem) + || defined($Apache::lonhomework::parsing_a_task)) + && + ($symbparm eq &symbread()) ) { + # if we are in the middle of processing the resource the + # get the value we are planning on committing + if (defined($Apache::lonhomework::results{$qualifierrest})) { + return $Apache::lonhomework::results{$qualifierrest}; + } else { + 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); @@ -4163,9 +5597,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) { @@ -4177,11 +5611,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') { @@ -4205,54 +5639,68 @@ 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') { if ($qualifier eq 'textremote') { - if (&mt('textual_remote_display') eq 'on') { + if (&Apache::lonlocal::mt('textual_remote_display') eq 'on') { return 1; } else { 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(); } } + + if ($space eq 'title') { + if (!$symbparm) { $symbparm = $env{'request.filename'}; } + return &gettitle($symbparm); + } + + if ($space eq 'map') { + my ($map) = &decode_symb($symbparm); + return &symbread($map); + } + + my ($section, $group, @groups); my ($courselevelm,$courselevel); if ($symbparm && defined($courseid) && - $courseid eq $ENV{'request.course.id'}) { + $courseid eq $env{'request.course.id'}) { #print '
'.$space.' - '.$qualifier.' - '.$spacequalifierrest; # ----------------------------------------------------- Cascading lookup scheme my $symbp=$symbparm; - my $mapp=(&decode_symb($symbp))[0]; + my $mapp=&deversion((&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'}; + @groups = split(/:/,$env{'request.course.groups'}); + @groups=&sort_course_groups($courseid,@groups); } else { if (! defined($usection)) { $section=&getsection($udom,$uname,$courseid); } else { $section = $usection; } + @groups = &get_users_groups($udom,$uname,$courseid); } my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; @@ -4264,51 +5712,32 @@ sub EXT { $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_new('userres',$hashid); - if (!defined($cached)) { - my %resourcedata=&dump('resourcedata',$udom,$uname); - $result=\%resourcedata; - &do_cache_new('userres',$hashid,$result); - } - my ($tmp)=keys(%$result); - if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) { - if ($$result{$courselevelr}) { - return $$result{$courselevelr}; } - if ($$result{$courselevelm}) { - return $$result{$courselevelm}; } - if ($$result{$courselevel}) { - return $$result{$courselevel}; } - } else { - #error 2 occurs when the .db doesn't exist - if ($tmp!~/error: 2 /) { - &logthis("WARNING:". - " Trying to get resource data for ". - $uname." at ".$udom.": ". - $tmp.""); - } elsif ($tmp=~/error: 2 /) { - &EXT_cache_set($udom,$uname); - } elsif ($tmp =~ /^(con_lost|no_such_host)/) { - return $tmp; - } - } - } + + my $userreply=&resdata($uname,$udom,'user', + ($courselevelr,$courselevelm, + $courselevel)); + if (defined($userreply)) { return $userreply; } # ------------------------------------------------ second, check some of course + my $coursereply; + if (@groups > 0) { + $coursereply = &check_group_parms($courseid,\@groups,$symbparm, + $mapparm,$spacequalifierrest); + if (defined($coursereply)) { return $coursereply; } + } - my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'}, - $ENV{'course.'.$courseid.'.domain'}, - ($seclevelr,$seclevelm,$seclevel, - $courselevelr)); + $coursereply=&resdata($env{'course.'.$courseid.'.num'}, + $env{'course.'.$courseid.'.domain'}, + 'course', + ($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); @@ -4323,7 +5752,7 @@ 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; } @@ -4332,10 +5761,11 @@ sub EXT { # ---------------------------------------------- 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)); + $courseid eq $env{'request.course.id'}) { + my $coursereply=&resdata($env{'course.'.$courseid.'.num'}, + $env{'course.'.$courseid.'.domain'}, + 'course', + ($courselevelm,$courselevel)); if (defined($coursereply)) { return $coursereply; } } # ------------------------------------------------------------------ Cascade up @@ -4355,9 +5785,12 @@ 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 { + if ($uname eq 'anonymous' && $udom eq '') { + return ''; + } my %returnhash=&userenvironment($udom,$uname, $spacequalifierrest); return $returnhash{$spacequalifierrest}; @@ -4367,16 +5800,64 @@ sub EXT { if ($space eq 'time') { return time; } + } elsif ($realm eq 'server') { +# ----------------------------------------------------------------- system.time + if ($space eq 'name') { + return $ENV{'SERVER_NAME'}; + } } return ''; } +sub check_group_parms { + my ($courseid,$groups,$symbparm,$mapparm,$what) = @_; + my @groupitems = (); + my $resultitem; + my @levels = ($symbparm,$mapparm,$what); + foreach my $group (@{$groups}) { + foreach my $level (@levels) { + my $item = $courseid.'.['.$group.'].'.$level; + push(@groupitems,$item); + } + } + my $coursereply = &resdata($env{'course.'.$courseid.'.num'}, + $env{'course.'.$courseid.'.domain'}, + 'course',@groupitems); + return $coursereply; +} + +sub sort_course_groups { # Sort groups based on defined rankings. Default is sort(). + my ($courseid,@groups) = @_; + @groups = sort(@groups); + return @groups; +} + sub packages_tab_default { my ($uri,$varname)=@_; my (undef,$part,$name)=split(/\./,$varname); - my $packages=&metadata($uri,'packages'); - foreach my $package (split(/,/,$packages)) { + + my (@extension,@specifics,$do_default); + foreach my $package (split(/,/,&metadata($uri,'packages'))) { my ($pack_type,$pack_part)=split(/_/,$package,2); + if ($pack_type eq 'default') { + $do_default=1; + } elsif ($pack_type eq 'extension') { + push(@extension,[$package,$pack_type,$pack_part]); + } else { + push(@specifics,[$package,$pack_type,$pack_part]); + } + } + # first look for a package that matches the requested part id + foreach my $package (@specifics) { + my (undef,$pack_type,$pack_part)=@{$package}; + next if ($pack_part ne $part); + if (defined($packagetab{"$pack_type&$name&default"})) { + return $packagetab{"$pack_type&$name&default"}; + } + } + # look for any possible matching non extension_ package + foreach my $package (@specifics) { + my (undef,$pack_type,$pack_part)=@{$package}; if (defined($packagetab{"$pack_type&$name&default"})) { return $packagetab{"$pack_type&$name&default"}; } @@ -4385,6 +5866,20 @@ sub packages_tab_default { return $packagetab{$pack_type."_".$pack_part."&$name&default"}; } } + # look for any posible extension_ match + foreach my $package (@extension) { + my ($package,$pack_type)=@{$package}; + if (defined($packagetab{"$pack_type&$name&default"})) { + return $packagetab{"$pack_type&$name&default"}; + } + if (defined($packagetab{$package."&$name&default"})) { + return $packagetab{$package."&$name&default"}; + } + } + # look for a global default setting + if ($do_default && defined($packagetab{"default&$name&default"})) { + return $packagetab{"default&$name&default"}; + } return undef; } @@ -4446,7 +5941,7 @@ sub metadata { my %metathesekeys=(); unless ($filename=~/\.meta$/) { $filename.='.meta'; } my $metastring; - if ($uri !~ m -^(uploaded|editupload)/-) { + if ($uri !~ m -^(editupload)/-) { my $file=&filelocation('',&clutter($filename)); #push(@{$metaentry{$uri.'.file'}},$file); $metastring=&getfile($file); @@ -4470,16 +5965,16 @@ sub metadata { } else { $metaentry{':packages'}=$package.$keyroot; } - foreach (keys %packagetab) { + foreach my $pack_entry (keys(%packagetab)) { my $part=$keyroot; $part=~s/^\_//; - if ($_=~/^\Q$package\E\&/ || - $_=~/^\Q$package\E_0\&/) { - my ($pack,$name,$subp)=split(/\&/,$_); + if ($pack_entry=~/^\Q$package\E\&/ || + $pack_entry=~/^\Q$package\E_0\&/) { + my ($pack,$name,$subp)=split(/\&/,$pack_entry); # ignore package.tab specified default values # here &package_tab_default() will fetch those if ($subp eq 'default') { next; } - my $value=$packagetab{$_}; + my $value=$packagetab{$pack_entry}; my $unikey; if ($pack =~ /_0$/) { $unikey='parameter_0_'.$name; @@ -4527,11 +6022,12 @@ sub metadata { my $dir=$filename; $dir=~s|[^/]*$||; $location=&filelocation($dir,$location); - foreach (sort(split(/\,/,&metadata($uri,'keys', - $location,$unikey, - $depthcount+1)))) { - $metaentry{':'.$_}=$metaentry{':'.$_}; - $metathesekeys{$_}=1; + my $metadata = + &metadata($uri,'keys', $location,$unikey, + $depthcount+1); + foreach my $meta (split(',',$metadata)) { + $metaentry{':'.$meta}=$metaentry{':'.$meta}; + $metathesekeys{$meta}=1; } } } else { @@ -4540,8 +6036,9 @@ sub metadata { $unikey.='_'.$token->[2]->{'name'}; } $metathesekeys{$unikey}=1; - foreach (@{$token->[3]}) { - $metaentry{':'.$unikey.'.'.$_}=$token->[2]->{$_}; + foreach my $param (@{$token->[3]}) { + $metaentry{':'.$unikey.'.'.$param} = + $token->[2]->{$param}; } my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry)); my $default=$metaentry{':'.$unikey.'.default'}; @@ -4562,15 +6059,14 @@ sub metadata { } } my ($extension) = ($uri =~ /\.(\w+)$/); - foreach my $key (sort(keys(%packagetab))) { - #&logthis("extsion1 $extension $key !!"); + foreach my $key (keys(%packagetab)) { #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))) { + foreach my $key (keys(%packagetab)) { #no specific packages well let's get default then if ($key!~/^default&/) { next; } &metadata_create_package_def($uri,$key,'default', @@ -4588,18 +6084,25 @@ sub metadata { my $dir=$filename; $dir=~s|[^/]*$||; $location=&filelocation($dir,$location); - foreach (sort(split(/\,/,&metadata($uri,'keys', - $location,'_rights', - $depthcount+1)))) { - #$metaentry{':'.$_}=$metacache{$uri}->{':'.$_}; - $metathesekeys{$_}=1; + my $rights_metadata = + &metadata($uri,'keys',$location,'_rights', + $depthcount+1); + foreach my $rights (split(',',$rights_metadata)) { + #$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights}; + $metathesekeys{$rights}=1; } } } - $metaentry{':keys'}=join(',',keys %metathesekeys); + # uniqifiy package listing + my %seen; + my @uniq_packages = + grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'})); + $metaentry{':packages'} = join(',',@uniq_packages); + + $metaentry{':keys'} = join(',',keys(%metathesekeys)); &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys); - &do_cache_new('meta',$uri,\%metaentry); + &do_cache_new('meta',$uri,\%metaentry,60*60); # this is the end of "was not already recently cached } return $metaentry{':'.$what}; @@ -4632,7 +6135,7 @@ sub metadata_create_package_def { sub metadata_generate_part0 { my ($metadata,$metacache,$uri) = @_; my %allnames; - foreach my $metakey (sort keys %$metadata) { + foreach my $metakey (keys(%$metadata)) { if ($metakey=~/^parameter\_(.*)/) { my $part=$$metacache{':'.$metakey.'.part'}; my $name=$$metacache{':'.$metakey.'.name'}; @@ -4651,19 +6154,30 @@ sub metadata_generate_part0 { '.type'}; my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name. '.display'}; - my $expr='\\[Part: '.$allnames{$name}.'\\]'; + my $expr='[Part: '.$allnames{$name}.']'; $olddis=~s/\Q$expr\E/\[Part: 0\]/; $$metacache{"$key.display"}=$olddis; } } +# ------------------------------------------------------ Devalidate title cache + +sub devalidate_title_cache { + my ($url)=@_; + if (!$env{'request.course.id'}) { return; } + my $symb=&symbread($url); + if (!$symb) { return; } + my $key=$env{'request.course.id'}."\0".$symb; + &devalidate_cache_new('title',$key); +} + # ------------------------------------------------- Get the title of a resource sub gettitle { my $urlsymb=shift; my $symb=&symbread($urlsymb); if ($symb) { - my $key=$ENV{'request.course.id'}."\0".$symb; + my $key=$env{'request.course.id'}."\0".$symb; my ($result,$cached)=&is_cached_new('title',$key); if (defined($cached)) { return $result; @@ -4671,7 +6185,7 @@ sub gettitle { my ($map,$resid,$url)=&decode_symb($symb); my $title=''; 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 $mapid=$bighash{'map_pc_'.&clutter($map)}; $title=$bighash{'title_'.$mapid.'.'.$resid}; @@ -4687,19 +6201,45 @@ sub gettitle { 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 $key=join("\0",'slots',$cdom,$cnum,$which); + my %slotinfo; + if (exists($remembered{$key})) { + $slotinfo{$which} = $remembered{$key}; + } else { + %slotinfo=&get('slots',[$which],$cdom,$cnum); + &Apache::lonhomework::showhash(%slotinfo); + my ($tmp)=keys(%slotinfo); + if ($tmp=~/^error:/) { return (); } + $remembered{$key} = $slotinfo{$which}; + } + 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($_)}=&encode_symb($mapname,$newhash{$_}->[1], - $newhash{$_}->[0]); + foreach my $url (keys %newhash) { + next if ($url eq 'last_known' + && $env{'form.no_update_last_known'}); + $hash{declutter($url)}=&encode_symb($mapname, + $newhash{$url}->[1], + $newhash{$url}->[0]); } if (untie(%hash)) { return 'ok'; @@ -4716,6 +6256,7 @@ sub symbverify { my $thisfn=$thisurl; # wrapper not part of symbs $thisfn=~s/^\/adm\/wrapper//; + $thisfn=~s/^\/adm\/coursedocs\/showdoc\///; $thisfn=&declutter($thisfn); # direct jump to resource in page or to a sequence - will construct own symbs if ($thisfn=~/\.(page|sequence)$/) { return 1; } @@ -4731,7 +6272,7 @@ sub symbverify { 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($thisurl)}; unless ($ids) { @@ -4740,12 +6281,12 @@ sub symbverify { if ($ids) { # ------------------------------------------------------------------- Has ID(s) foreach (split(/\,/,$ids)) { - my ($mapid,$resid)=split(/\./,$_); + my ($mapid,$resid)=split(/\./,$_); if ( &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) eq $symb) { - if (($ENV{'request.role.adv'}) || - $bighash{'encrypted_'.$_} eq $ENV{'request.enc'}) { + if (($env{'request.role.adv'}) || + $bighash{'encrypted_'.$_} eq $env{'request.enc'}) { $okay=1; } } @@ -4770,6 +6311,7 @@ sub symbclean { # remove wrapper $symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/; + $symb=~s/(\_\_\_\d+\_\_\_)adm\/coursedocs\/showdoc\/(res\/)*/$1/; return $symb; } @@ -4792,12 +6334,12 @@ sub fixversion { 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_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}; @@ -4822,31 +6364,34 @@ sub deversion { sub symbread { my ($thisfn,$donotrecurse)=@_; my $cache_str='request.symbread.cached.'.$thisfn; - if (defined($ENV{$cache_str})) { return $ENV{$cache_str}; } + if (defined($env{$cache_str})) { return $env{$cache_str}; } # no filename provided? try from environment unless ($thisfn) { - if ($ENV{'request.symb'}) { - return $ENV{$cache_str}=&symbclean($ENV{'request.symb'}); + if ($env{'request.symb'}) { + return $env{$cache_str}=&symbclean($env{'request.symb'}); } - $thisfn=$ENV{'request.filename'}; + $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 $ENV{$cache_str}=&symbclean($thisfn); + return $env{$cache_str}=&symbclean($thisfn); } } $thisfn=declutter($thisfn); my %hash; my %bighash; my $syval=''; - if (($ENV{'request.course.fn'}) && ($thisfn)) { + 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', + if ($targetfn =~ m|^adm/wrapper/(ext/.*)|) { + $targetfn=$1; + } + if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db', &GDBM_READER(),0640)) { $syval=$hash{$targetfn}; untie(%hash); @@ -4854,15 +6399,15 @@ sub symbread { # ---------------------------------------------------------- There was an entry if ($syval) { #unless ($syval=~/\_\d+$/) { - #unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) { + #unless ($env{'form.request.prefix'}=~/\.(\d+)\_$/) { #&appenv('request.ambiguous' => $thisfn); - #return $ENV{$cache_str}=''; + #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)}; @@ -4879,7 +6424,8 @@ sub symbread { if ($#possibilities==0) { # ----------------------------------------------- There is only one possibility my ($mapid,$resid)=split(/\./,$ids); - $syval=declutter($bighash{'map_id_'.$mapid}).'___'.$resid; + $syval=&encode_symb($bighash{'map_id_'.$mapid}, + $resid,$thisfn); } elsif (!$donotrecurse) { # ------------------------------------------ There is more than one possibility my $realpossible=0; @@ -4889,8 +6435,8 @@ sub symbread { my ($mapid,$resid)=split(/\./,$_); if ($bighash{'map_type_'.$mapid} ne 'page') { $realpossible++; - $syval=declutter($bighash{'map_id_'.$mapid}). - '___'.$resid; + $syval=&encode_symb($bighash{'map_id_'.$mapid}, + $resid,$thisfn); } } } @@ -4903,12 +6449,11 @@ sub symbread { } } if ($syval) { - return $ENV{$cache_str}=$syval; - #return $ENV{$cache_str}=&symbclean($syval.'___'.$thisfn); + return $env{$cache_str}=$syval; } } &appenv('request.ambiguous' => $thisfn); - return $ENV{$cache_str}=''; + return $env{$cache_str}=''; } # ---------------------------------------------------------- Return random seed @@ -4959,15 +6504,44 @@ sub numval3 { return $total; } +sub digest { + my ($data)=@_; + my $digest=&Digest::MD5::md5($data); + my ($a,$b,$c,$d)=unpack("iiii",$digest); + my ($e,$f); + { + use integer; + $e=($a+$b); + $f=($c+$d); + if ($_64bit) { + $e=(($e<<32)>>32); + $f=(($f<<32)>>32); + } + } + if (wantarray) { + return ($e,$f); + } else { + my $g; + { + use integer; + $g=($e+$f); + if ($_64bit) { + $g=(($g<<32)>>32); + } + } + return $g; + } +} + sub latest_rnd_algorithm_id { - return '64bit4'; + return '64bit5'; } sub get_rand_alg { my ($courseid)=@_; if (!$courseid) { $courseid=(&Apache::lonxml::whichuser())[1]; } if ($courseid) { - return $ENV{"course.$courseid.rndseed"}; + return $env{"course.$courseid.rndseed"}; } return &latest_rnd_algorithm_id(); } @@ -4979,9 +6553,10 @@ sub validCODE { } sub getCODE { - if (&validCODE($ENV{'form.CODE'})) { return $ENV{'form.CODE'}; } - if (defined($Apache::lonhomework::parsing_a_problem) && - &validCODE($Apache::lonhomework::history{'resource.CODE'})) { + 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; @@ -4999,11 +6574,15 @@ sub rndseed { if (!$username) { $username=$wusername } my $which=&get_rand_alg(); if (defined(&getCODE())) { - if ($which eq '64bit4') { + if ($which eq '64bit5') { + return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username); + } elsif ($which eq '64bit4') { return &rndseed_CODE_64bit4($symb,$courseid,$domain,$username); } else { return &rndseed_CODE_64bit($symb,$courseid,$domain,$username); } + } elsif ($which eq '64bit5') { + return &rndseed_64bit5($symb,$courseid,$domain,$username); } elsif ($which eq '64bit4') { return &rndseed_64bit4($symb,$courseid,$domain,$username); } elsif ($which eq '64bit3') { @@ -5126,6 +6705,12 @@ sub rndseed_64bit4 { } } +sub rndseed_64bit5 { + my ($symb,$courseid,$domain,$username)=@_; + my ($num1,$num2)=&digest("$symb,$courseid,$domain,$username"); + return "$num1:$num2"; +} + sub rndseed_CODE_64bit { my ($symb,$courseid,$domain,$username)=@_; { @@ -5164,6 +6749,13 @@ sub rndseed_CODE_64bit4 { } } +sub rndseed_CODE_64bit5 { + my ($symb,$courseid,$domain,$username)=@_; + my $code = &getCODE(); + my ($num1,$num2)=&digest("$symb,$courseid,$code"); + return "$num1:$num2"; +} + sub setup_random_from_rndseed { my ($rndseed)=@_; if ($rndseed =~/([,:])/) { @@ -5181,8 +6773,8 @@ sub latest_receipt_algorithm_id { sub recunique { my $fucourseid=shift; my $unique; - if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2') { - $unique=$ENV{"course.$fucourseid.internal.encseed"}; + if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') { + $unique=$env{"course.$fucourseid.internal.encseed"}; } else { $unique=$perlvar{'lonReceipt'}; } @@ -5192,8 +6784,8 @@ sub recunique { sub recprefix { my $fucourseid=shift; my $prefix; - if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2') { - $prefix=$ENV{"course.$fucourseid.internal.encpref"}; + if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') { + $prefix=$env{"course.$fucourseid.internal.encpref"}; } else { $prefix=$perlvar{'lonHostID'}; } @@ -5209,8 +6801,8 @@ sub ireceipt { 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') { + 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)); @@ -5323,12 +6915,12 @@ sub tokenwrapper { my $uri=shift; $uri=~s|^http\://([^/]+)||; $uri=~s|^/||; - $ENV{'user.environment'}=~/\/([^\/]+)\.id/; + $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'}); + &appenv("userfile.$udom/$uname/$file" => $env{'request.course.id'}); return 'http://'.$hostname{ &homeserver($uname,$udom)}.'/'.$uri. (($uri=~/\?/)?'&':'?').'token='.$token. '&tokenissued='.$perlvar{'lonHostID'}; @@ -5370,9 +6962,17 @@ sub filelocation { my ($dir,$file) = @_; my $location; $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces + + if ($file =~ m-^/adm/-) { + $file=~s-^/adm/wrapper/-/-; + $file=~s-^/adm/coursedocs/showdoc/-/-; + } if ($file=~m:^/~:) { # is a contruction space reference $location = $file; $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; + } elsif ($file=~m:^/home/[^/]*/public_html/:) { + # is a correct contruction space reference + $location = $file; } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file my ($udom,$uname,$filename)= ($file=~m -^/+(?:uploaded|editupload)/+([^/]+)/+([^/]+)/+(.*)$-); @@ -5381,7 +6981,7 @@ sub filelocation { 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). + $location=&propath($udom,$uname). '/userfiles/'.$filename; } else { $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'. @@ -5405,14 +7005,18 @@ sub filelocation { sub hreflocation { my ($dir,$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=filelocation($dir,$file); + } elsif ($file=~m-^/adm/-) { + $file=~s-^/adm/wrapper/-/-; + $file=~s-^/adm/coursedocs/showdoc/-/-; + } + if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) { + $file=~s-^\Q$perlvar{'lonDocRoot'}\E--; + } elsif ($file=~m-/home/(\w+)/public_html/-) { $file=~s-^/home/(\w+)/public_html/-/~$1/-; - return $file; + } elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) { + $file=~s-^/home/httpd/lonUsers/([^/]*)/./././([^/]*)/userfiles/ + -/uploaded/$1/$2/-x; } return $file; } @@ -5448,6 +7052,8 @@ sub declutter { if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); } $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//; $thisfn=~s/^\///; + $thisfn=~s|^adm/wrapper/||; + $thisfn=~s|^adm/coursedocs/showdoc/||; $thisfn=~s/^res\///; $thisfn=~s/\?.+$//; return $thisfn; @@ -5460,6 +7066,30 @@ sub clutter { unless ($thisfn=~/^\/(uploaded|editupload|adm|userfiles|ext|raw|priv|public)\//) { $thisfn='/res'.$thisfn; } + if ($thisfn !~m|/adm|) { + if ($thisfn =~ m|/ext/|) { + $thisfn='/adm/wrapper'.$thisfn; + } else { + my ($ext) = ($thisfn =~ /\.(\w+)$/); + my $embstyle=&Apache::loncommon::fileembstyle($ext); + if ($embstyle eq 'ssi' + || ($embstyle eq 'hdn') + || ($embstyle eq 'rat') + || ($embstyle eq 'prv') + || ($embstyle eq 'ign')) { + #do nothing with these + } elsif (($embstyle eq 'img') + || ($embstyle eq 'emb') + || ($embstyle eq 'wrp')) { + $thisfn='/adm/wrapper'.$thisfn; + } elsif ($embstyle eq 'unk' + && $thisfn!~/\.(sequence|page)$/) { + $thisfn='/adm/coursedocs/showdoc'.$thisfn; + } else { +# &logthis("Got a blank emb style"); + } + } + } return $thisfn; } @@ -5472,21 +7102,6 @@ sub freeze_escape { return &escape($value); } -# -------------------------------------------------------- Escape Special Chars - -sub escape { - my $str=shift; - $str =~ s/(\W)/"%".unpack('H2',$1)/eg; - return $str; -} - -# ----------------------------------------------------- Un-Escape Special Chars - -sub unescape { - my $str=shift; - $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; - return $str; -} sub thaw_unescape { my ($value)=@_; @@ -5498,13 +7113,6 @@ sub thaw_unescape { return &unescape($value); } -sub mod_perl_version { - return 1; - if (defined($perlvar{'MODPERL2'})) { - return 2; - } -} - sub correct_line_ends { my ($result)=@_; $$result =~s/\r\n/\n/mg; @@ -5531,36 +7139,14 @@ sub goodbye { &logthis(sprintf("%-20s is %s",'hits',$hits)); &flushcourselogs(); &logthis("Shutting down"); - return DONE; } 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=~/\S/ && $configline =~ /^[^\#]*PerlSetVar/) { - my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); - chomp($varvalue); - $perlvar{$varname}=$varvalue; - } - } - close($config); -} -{ - open(my $config,") { - if ($configline =~ /^[^\#]*PerlSetVar/) { - my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); - chomp($varvalue); - $perlvar{$varname}=$varvalue; - } - } - close($config); + my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf'); + %perlvar = (%perlvar,%{$configvars}); } # ------------------------------------------------------------ Read domain file @@ -5575,7 +7161,7 @@ BEGIN { # next if /^\#/; chomp; my ($domain, $domain_description, $def_auth, $def_auth_arg, - $def_lang, $city, $longi, $lati) = split(/:/,$_); + $def_lang, $city, $longi, $lati, $primary) = split(/:/,$_); $domain_auth_def{$domain}=$def_auth; $domain_auth_arg_def{$domain}=$def_auth_arg; $domaindescription{$domain}=$domain_description; @@ -5583,6 +7169,7 @@ BEGIN { $domain_city{$domain}=$city; $domain_longi{$domain}=$longi; $domain_lati{$domain}=$lati; + $domain_primary{$domain}=$primary; # &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}"); # &logthis("Domain.tab: $domain ".$domaindescription{$domain} ); @@ -5608,18 +7195,27 @@ BEGIN { } } close($config); + # FIXME: dev server don't want this, production servers _do_ want this + #&get_iphost(); } sub get_iphost { if (%iphost) { return %iphost; } + my %name_to_ip; 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; + my $ip; + if (!exists($name_to_ip{$name})) { + $ip = gethostbyname($name); + if (!$ip || length($ip) ne 4) { + &logthis("Skipping host $id name $name no IP found\n"); + next; + } + $ip=inet_ntoa($ip); + $name_to_ip{$name} = $ip; + } else { + $ip = $name_to_ip{$name}; } - $ip=inet_ntoa($ip); push(@{$iphost{$ip}},$id); } return %iphost; @@ -5632,7 +7228,9 @@ sub get_iphost { while (my $configline=<$config>) { chomp($configline); if ($configline) { - $spareid{$configline}=1; + my ($host,$type) = split(':',$configline,2); + if (!defined($type) || $type eq '') { $type = 'default' }; + push(@{ $spareid{$type} }, $host); } } close($config); @@ -5658,8 +7256,14 @@ sub get_iphost { while (my $configline=<$config>) { chomp($configline); if ($configline) { - my ($short,$plain)=split(/:/,$configline); - if ($plain ne '') { $prp{$short}=$plain; } + my ($short,@plain)=split(/:/,$configline); + %{$prp{$short}} = (); + if (@plain > 0) { + $prp{$short}{'std'} = $plain[0]; + for (my $i=1; $i<@plain; $i++) { + $prp{$short}{'alt'.$i} = $plain[$i]; + } + } } } close($config); @@ -5694,7 +7298,7 @@ $processmarker='_'.time.'_'.$perlvar{'lo $dumpcount=0; &logtouch(); -&logthis('INFO: Read configuration'); +&logthis('INFO: Read configuration'); $readit=1; { use integer; @@ -5876,14 +7480,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 @@ -5954,6 +7558,7 @@ actions '': forbidden 1: user needs to choose course 2: browse allowed + A: passphrase authentication needed =item * @@ -6096,13 +7701,17 @@ revokecustomrole($udom,$uname,$url,$role =item * -coursedescription($courseid) : course description +coursedescription($courseid) : returns a hash of information about the +specified course id, including all environment settings for the +course, the description of the course will be in the hash under the +key 'description' =item * -courseresdata($coursenum,$coursedomain,@which) : request for current -parameter setting for a specific course, @what should be a list of -parameters to ask about. This routine caches answers for 5 minutes. +resdata($name,$domain,$type,@which) : request for current parameter +setting for a specific $type, where $type is either 'course' or 'user', +@what should be a list of parameters to ask about. This routine caches +answers for 5 minutes. =back @@ -6191,7 +7800,7 @@ symbverify($symb,$thisfn) : verifies tha 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'} +the course initial hash, and uses $env('request.course.id'} =item * @@ -6222,7 +7831,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 * @@ -6256,7 +7865,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 * @@ -6270,6 +7879,27 @@ all args are optional =item * +dumpstore($namespace,$udom,$uname,$regexp,$range) : +dumps the complete (or key matching regexp) namespace into a hash +($udom, $uname, $regexp, $range are optional) for a namespace that is +normally &store()ed into + +$range should be either an integer '100' (give me the first 100 + matching records) + or be two integers sperated by a - with no spaces + '30-50' (give me the 30th through the 50th matching + records) + + +=item * + +putstore($namespace,$symb,$version,$storehash,$udomain,$uname) : +replaces a &store() version of data with a replacement set of data +for a particular resource in a namespace passed in the $storehash hash +reference + +=item * + tmpstore($storehash,$symb,$namespace,$udom,$uname) : storage that works very similar to store/cstore, but all data is stored in a temporary location and can be reset using tmpreset, $storehash should @@ -6299,10 +7929,15 @@ namesp ($udom and $uname are optional) =item * -dump($namespace,$udom,$uname,$regexp) : +dump($namespace,$udom,$uname,$regexp,$range) : dumps the complete (or key matching regexp) namespace into a hash -($udom, $uname and $regexp are optional) +($udom, $uname, $regexp, $range are optional) +$range should be either an integer '100' (give me the first 100 + matching records) + or be two integers sperated by a - with no spaces + '30-50' (give me the 30th through the 50th matching + records) =item * inc($namespace,$store,$udom,$uname) : increments $store in $namespace. @@ -6318,19 +7953,33 @@ 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(). +cput($namespace,$storehash,$udom,$uname) : critical put +($udom and $uname are optional) =item * -cput($namespace,$storehash,$udom,$uname) : critical put -($udom and $uname are optional) +newput($namespace,$storehash,$udom,$uname) : + +Attempts to store the items in the $storehash, but only if they don't +currently exist, if this succeeds you can be certain that you have +successfully created a new key value pair in the $namespace db. + + +Args: + $namespace: name of database to store values to + $storehash: hashref to store to the db + $udom: (optional) domain of user containing the db + $uname: (optional) name of user caontaining the db + +Returns: + 'ok' -> succeeded in storing all keys of $storehash + 'key_exists: ' -> failed to anything out of $storehash, as at + least already existed in the db (other + requested keys may also already exist) + 'error: ' -> unable to tie the DB or other erorr occured + 'con_lost' -> unable to contact request server + 'refused' -> action was not allowed by remote machine + =item * @@ -6458,6 +8107,16 @@ getfile($file,$caller) : two cases - req - returns the entire contents of a file or -1; it properly subscribes to and replicates the file if neccessary. + +=item * + +stat_file($url) : $url is expected to be a /res/ or /uploaded/ style file + reference + +returns either a stat() list of data about the file or an empty list +if the file doesn't exist or couldn't find out about it (connection +problems or user unknown) + =item * filelocation($dir,$file) : returns file system location of a file @@ -6485,10 +8144,10 @@ declutter() : declutters URLs (remove do 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 + 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} + 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/ @@ -6517,7 +8176,6 @@ userspace, probably shouldn't be called 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 @@ -6559,6 +8217,94 @@ removeuploadedurl(): convience function Args: url: a full /uploaded/... url to delete +=item * + +get_portfile_permissions(): + Args: + domain: domain of user or course contain the portfolio files + user: name of user or num of course contain the portfolio files + Returns: + hashref of a dump of the proper file_permissions.db + + +=item * + +get_access_controls(): + +Args: + current_permissions: the hash ref returned from get_portfile_permissions() + group: (optional) the group you want the files associated with + file: (optional) the file you want access info on + +Returns: + a hash (keys are file names) of hashes containing + keys are: path to file/file_name\0uniqueID:scope_end_start (see below) + values are XML containing access control settings (see below) + +Internal notes: + + access controls are stored in file_permissions.db as key=value pairs. + key -> path to file/file_name\0uniqueID:scope_end_start + where scope -> public,guest,course,group,domains or users. + end -> UNIX time for end of access (0 -> no end date) + start -> UNIX time for start of access + + value -> XML description of access control + (type =1 of: public,guest,course,group,domains,users"> + + + + for scope type = guest + + for scope type = course or group + + + + +
+ + + + for scope type = domains + + for scope type = users + + + + + + + + Access data is also aggregated for each file in an additional key=value pair: + key -> path to file/file_name\0accesscontrol + value -> reference to hash + hash contains key = value pairs + where key = uniqueID:scope_end_start + value = UNIX time record was last updated + + Used to improve speed of look-ups of access controls for each file. + + Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays. + +modify_access_controls(): + +Modifies access controls for a portfolio file +Args +1. file name +2. reference to hash of required changes, +3. domain +4. username + where domain,username are the domain of the portfolio owner + (either a user or a course) + +Returns: +1. result of additions or updates ('ok' or 'error', with error message). +2. result of deletions ('ok' or 'error', with error message). +3. reference to hash of any new or updated access controls. +4. reference to hash used to map incoming IDs to uniqueIDs assigned to control. + key = integer (inbound ID) + value = uniqueID + =back =head2 HTTP Helper Routines