--- loncom/lonnet/perl/lonnet.pm 2006/06/22 13:16:09 1.753 +++ loncom/lonnet/perl/lonnet.pm 2008/08/13 08:17:57 1.964 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.753 2006/06/22 13:16:09 albertel Exp $ +# $Id: lonnet.pm,v 1.964 2008/08/13 08:17:57 bisitz Exp $ # # Copyright Michigan State University Board of Trustees # @@ -31,29 +31,26 @@ package Apache::lonnet; use strict; use LWP::UserAgent(); -use HTTP::Headers; use HTTP::Date; # use Date::Parse; -use vars -qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom - %libserv %pr %prp $memcache %packagetab - %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 %domain_primary - $tmpdir $_64bit %env); +use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir + $_64bit %env); + +my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash, + %userrolehash, $processmarker, $dumpcount, %coursedombuf, + %coursenumbuf, %coursehombuf, %coursedescrbuf, %courseinstcodebuf, + %courseownerbuf, %coursetypebuf,$locknum); use IO::Socket; use GDBM_File; use HTML::LCParser; -use HTML::Parser; use Fcntl qw(:flock); -use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze); +use Storable qw(thaw nfreeze); use Time::HiRes qw( gettimeofday tv_interval ); use Cache::Memcached; use Digest::MD5; -use lib '/home/httpd/lib/perl'; -use LONCAPA; +use Math::Random; +use LONCAPA qw(:DEFAULT :match); use LONCAPA::Configuration; my $readit; @@ -91,24 +88,26 @@ delayed. { my $logid; sub instructor_log { - my ($hash_name,$storehash,$delflag,$uname,$udom)=@_; + my ($hash_name,$storehash,$delflag,$uname,$udom,$cnum,$cdom)=@_; + if (($cnum eq '') || ($cdom eq '')) { + $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; + $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; + } $logid++; - my $id=time().'00000'.$$.'00000'.$logid; + my $now = time(); + my $id=$now.'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_time' => $now, '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'} - ); + },$cdom,$cnum); } } @@ -146,10 +145,24 @@ sub logperm { return 1; } +sub create_connection { + my ($hostname,$lonid) = @_; + my $client=IO::Socket::UNIX->new(Peer => $perlvar{'lonSockCreate'}, + Type => SOCK_STREAM, + Timeout => 10); + return 0 if (!$client); + print $client (join(':',$hostname,$lonid,&machine_ids($hostname))."\n"); + my $result = <$client>; + chomp($result); + return 1 if ($result eq 'done'); + return 0; +} + + # -------------------------------------------------- Non-critical communication sub subreply { my ($cmd,$server)=@_; - my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$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 @@ -170,10 +183,12 @@ sub subreply { $client=IO::Socket::UNIX->new(Peer =>"$peerfile", Type => SOCK_STREAM, Timeout => 10); - if($client) { + if ($client) { last; # Connected! + } else { + &create_connection(&hostname($server),$server); } - sleep(1); # Try again later if failed connection. + sleep(1); # Try again later if failed connection. } my $answer; if ($client) { @@ -189,7 +204,7 @@ sub subreply { sub reply { my ($cmd,$server)=@_; - unless (defined($hostname{$server})) { return 'no_such_host'; } + unless (defined(&hostname($server))) { return 'no_such_host'; } my $answer=subreply($cmd,$server); if (($answer=~/^refused/) || ($answer=~/^rejected/)) { &logthis("WARNING:". @@ -201,8 +216,25 @@ sub reply { # ----------------------------------------------------------- Send USR1 to lonc sub reconlonc { - my $peerfile=shift; - &logthis("Trying to reconnect for $peerfile"); + my ($lonid) = @_; + my $hostname = &hostname($lonid); + if ($lonid) { + my $peerfile="$perlvar{'lonSockDir'}/$hostname"; + if ($hostname && -e $peerfile) { + &logthis("Trying to reconnect lonc for $lonid ($hostname)"); + my $client=IO::Socket::UNIX->new(Peer => $peerfile, + Type => SOCK_STREAM, + Timeout => 10); + if ($client) { + print $client ("reset_retries\n"); + my $answer=<$client>; + #reset just this one. + } + } + return; + } + + &logthis("Trying to reconnect lonc"); my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid"; if (open(my $fh,"<$loncfile")) { my $loncpid=<$fh>; @@ -211,19 +243,13 @@ sub reconlonc { &logthis("lonc at pid $loncpid responding, sending USR1"); kill USR1 => $loncpid; sleep 1; - if (-e "$peerfile") { return; } - &logthis("$peerfile still not there, give it another try"); - sleep 5; - if (-e "$peerfile") { return; } - &logthis( - "WARNING: $peerfile still not there, giving up"); - } else { + } else { &logthis( "WARNING:". " lonc at pid $loncpid not responding, giving up"); } } else { - &logthis('WARNING: lonc not running, giving up'); + &logthis('WARNING: lonc not running, giving up'); } } @@ -231,7 +257,7 @@ sub reconlonc { sub critical { my ($cmd,$server)=@_; - unless ($hostname{$server}) { + unless (&hostname($server)) { &logthis("WARNING:". " Critical message to unknown server ($server)"); return 'no_such_host'; @@ -281,10 +307,54 @@ sub critical { return $answer; } -# ------------------------------------------- Transfer profile into environment +# ------------------------------------------- check if return value is an error -sub transfer_profile_to_env { +sub error { + my ($result) = @_; + if ($result =~ /^(con_lost|no_such_host|error: (\d+) (.*))/) { + if ($2 == 2) { return undef; } + return $1; + } + return undef; +} + +sub convert_and_load_session_env { my ($lonidsdir,$handle)=@_; + my @profile; + { + my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id"); + if (!$opened) { + return 0; + } + flock($idf,LOCK_SH); + @profile=<$idf>; + close($idf); + } + my %temp_env; + foreach my $line (@profile) { + if ($line !~ m/=/) { + return 0; + } + chomp($line); + my ($envname,$envvalue)=split(/=/,$line,2); + $temp_env{&unescape($envname)} = &unescape($envvalue); + } + unlink("$lonidsdir/$handle.id"); + if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_WRCREAT(), + 0640)) { + %disk_env = %temp_env; + @env{keys(%temp_env)} = @disk_env{keys(%temp_env)}; + untie(%disk_env); + } + return 1; +} + +# ------------------------------------------- Transfer profile into environment +my $env_loaded; +sub transfer_profile_to_env { + my ($lonidsdir,$handle,$force_transfer) = @_; + if (!$force_transfer && $env_loaded) { return; } + if (!defined($lonidsdir)) { $lonidsdir = $perlvar{'lonIDsDir'}; } @@ -292,92 +362,128 @@ sub transfer_profile_to_env { ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| ); } - my @profile; + my $convert; { - open(my $idf,"$lonidsdir/$handle.id"); + my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id"); + if (!$opened) { + return; + } flock($idf,LOCK_SH); - @profile=<$idf>; - close($idf); + if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id", + &GDBM_READER(),0640)) { + @env{keys(%disk_env)} = @disk_env{keys(%disk_env)}; + untie(%disk_env); + } else { + $convert = 1; + } + } + if ($convert) { + if (!&convert_and_load_session_env($lonidsdir,$handle)) { + &logthis("Failed to load session, or convert session."); + } } - my $envi; - my %Remove; - for ($envi=0;$envi<=$#profile;$envi++) { - chomp($profile[$envi]); - my ($envname,$envvalue)=split(/=/,$profile[$envi],2); - $envname=&unescape($envname); - $envvalue=&unescape($envvalue); - $env{$envname} = $envvalue; + + my %remove; + while ( my $envname = each(%env) ) { if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) { if ($time < time-300) { - $Remove{$key}++; + $remove{$key}++; } } } + $env{'user.environment'} = "$lonidsdir/$handle.id"; - foreach my $expired_key (keys(%Remove)) { + $env_loaded=1; + foreach my $expired_key (keys(%remove)) { &delenv($expired_key); } } -# ---------------------------------------------------------- Append Environment - -sub appenv { - my %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{$key}); - } else { - $env{$key}=$newenv{$key}; - } +# ---------------------------------------------------- Check for valid session +sub check_for_valid_session { + my ($r) = @_; + my %cookies=CGI::Cookie->parse($r->header_in('Cookie')); + my $lonid=$cookies{'lonID'}; + return undef if (!$lonid); + + my $handle=&LONCAPA::clean_handle($lonid->value); + my $lonidsdir=$r->dir_config('lonIDsDir'); + return undef if (!-e "$lonidsdir/$handle.id"); + + my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id"); + return undef if (!$opened); + + flock($idf,LOCK_SH); + my %disk_env; + if (!tie(%disk_env,'GDBM_File',"$lonidsdir/$handle.id", + &GDBM_READER(),0640)) { + return undef; } - my $lockfh; - unless (open($lockfh,"$env{'user.environment'}")) { - return 'error: '.$!; - } - unless (flock($lockfh,LOCK_EX)) { - &logthis("WARNING: ". - 'Could not obtain exclusive lock in appenv: '.$!); - close($lockfh); - return 'error: '.$!; + if (!defined($disk_env{'user.name'}) + || !defined($disk_env{'user.domain'})) { + return undef; } + return $handle; +} - my @oldenv; - { - my $fh; - unless (open($fh,"$env{'user.environment'}")) { - return 'error: '.$!; - } - @oldenv=<$fh>; - close($fh); +sub timed_flock { + my ($file,$lock_type) = @_; + my $failed=0; + eval { + local $SIG{__DIE__}='DEFAULT'; + local $SIG{ALRM}=sub { + $failed=1; + die("failed lock"); + }; + alarm(13); + flock($file,$lock_type); + alarm(0); + }; + if ($failed) { + return undef; + } else { + return 1; } - for (my $i=0; $i<=$#oldenv; $i++) { - chomp($oldenv[$i]); - if ($oldenv[$i] ne '') { - my ($name,$value)=split(/=/,$oldenv[$i],2); - $name=&unescape($name); - $value=&unescape($value); - unless (defined($newenv{$name})) { - $newenv{$name}=$value; +} + +# ---------------------------------------------------------- Append Environment + +sub appenv { + my ($newenv,$roles) = @_; + if (ref($newenv) eq 'HASH') { + foreach my $key (keys(%{$newenv})) { + my $refused = 0; + if (($key =~ /^user\.role/) || ($key =~ /^user\.priv/)) { + $refused = 1; + if (ref($roles) eq 'ARRAY') { + my ($type,$role) = ($key =~ /^user\.(role|priv)\.([^.]+)\./); + if (grep(/^\Q$role\E$/,@{$roles})) { + $refused = 0; + } + } + } + if ($refused) { + &logthis("WARNING: ". + "Attempt to modify environment ".$key." to ".$newenv->{$key} + .''); + delete($newenv->{$key}); + } else { + $env{$key}=$newenv->{$key}; + } + } + my $opened = open(my $env_file,'+<',$env{'user.environment'}); + if ($opened + && &timed_flock($env_file,LOCK_EX) + && + tie(my %disk_env,'GDBM_File',$env{'user.environment'}, + (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { + while (my ($key,$value) = each(%{$newenv})) { + $disk_env{$key} = $value; } + untie(%disk_env); } } - { - my $fh; - unless (open($fh,">$env{'user.environment'}")) { - return 'error'; - } - my $newname; - foreach $newname (keys %newenv) { - print $fh &escape($newname).'='.&escape($newenv{$newname})."\n"; - } - close($fh); - } - - close($lockfh); return 'ok'; } # ----------------------------------------------------- Delete from Environment @@ -389,49 +495,83 @@ sub delenv { "Attempt to delete from environment ".$delthis); return 'error'; } - my @oldenv; - { - my $fh; - unless (open($fh,"$env{'user.environment'}")) { - return 'error'; - } - unless (flock($fh,LOCK_SH)) { - &logthis("WARNING: ". - 'Could not obtain shared lock in delenv: '.$!); - close($fh); - return 'error: '.$!; - } - @oldenv=<$fh>; - close($fh); - } - { - my $fh; - unless (open($fh,">$env{'user.environment'}")) { - return 'error'; - } - unless (flock($fh,LOCK_EX)) { - &logthis("WARNING: ". - 'Could not obtain exclusive lock in delenv: '.$!); - close($fh); - return 'error: '.$!; - } - foreach 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 $cur_key; - } + my $opened = open(my $env_file,'+<',$env{'user.environment'}); + if ($opened + && &timed_flock($env_file,LOCK_EX) + && + tie(my %disk_env,'GDBM_File',$env{'user.environment'}, + (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { + foreach my $key (keys(%disk_env)) { + if ($key=~/^$delthis/) { + delete($env{$key}); + delete($disk_env{$key}); + } } - close($fh); + untie(%disk_env); } return 'ok'; } +sub get_env_multiple { + my ($name) = @_; + my @values; + if (defined($env{$name})) { + # exists is it an array + if (ref($env{$name})) { + @values=@{ $env{$name} }; + } else { + $values[0]=$env{$name}; + } + } + return(@values); +} + +# ------------------------------------------------------------------- Locking + +sub set_lock { + my ($text)=@_; + $locknum++; + my $id=$$.'-'.$locknum; + &appenv({'session.locks' => $env{'session.locks'}.','.$id, + 'session.lock.'.$id => $text}); + return $id; +} + +sub get_locks { + my $num=0; + my %texts=(); + foreach my $lock (split(/\,/,$env{'session.locks'})) { + if ($lock=~/\w/) { + $num++; + $texts{$lock}=$env{'session.lock.'.$lock}; + } + } + return ($num,%texts); +} + +sub remove_lock { + my ($id)=@_; + my $newlocks=''; + foreach my $lock (split(/\,/,$env{'session.locks'})) { + if (($lock=~/\w/) && ($lock ne $id)) { + $newlocks.=','.$lock; + } + } + &appenv({'session.locks' => $newlocks}); + &delenv('session.lock.'.$id); +} + +sub remove_all_locks { + my $activelocks=$env{'session.locks'}; + foreach my $lock (split(/\,/,$env{'session.locks'})) { + if ($lock=~/\w/) { + &remove_lock($lock); + } + } +} + + # ------------------------------------------ Find out current server userload -# there is a copy in lond sub userload { my $numusers=0; { @@ -439,7 +579,8 @@ sub userload { my $filename; my $curtime=time; while ($filename=readdir(LONIDS)) { - if ($filename eq '.' || $filename eq '..') {next;} + next if ($filename eq '.' || $filename eq '..'); + next if ($filename =~ /publicuser_\d+\.id/); my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9]; if ($curtime-$mtime < 1800) { $numusers++; } } @@ -482,48 +623,88 @@ sub overloaderror { sub spareserver { my ($loadpercent,$userloadpercent,$want_server_name) = @_; - my $tryserver; - my $spareserver=''; + 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; + 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); } - if (($answer =~ /\d/) && ($answer<$lowestserver)) { - if ($want_server_name) { - $spareserver=$tryserver; - } else { - $spareserver="http://$hostname{$tryserver}"; - } - $lowestserver=$answer; + } + + 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; } - return $spareserver; + + if (($load =~ /\d/) && ($load < $lowest_load)) { + $spare_server = $try_server; + $lowest_load = $load; + } + return ($spare_server,$lowest_load); +} + +# --------------------------- ask offload servers if user already has a session +sub find_existing_session { + my ($udom,$uname) = @_; + foreach my $try_server (@{ $spareid{'primary'} }, + @{ $spareid{'default'} }) { + return $try_server if (&has_user_session($try_server, $udom, $uname)); + } + return; +} + +# -------------------------------- ask if server already has a session for user +sub has_user_session { + my ($lonid,$udom,$uname) = @_; + my $result = &reply(join(':','userhassession', + map {&escape($_)} ($udom,$uname)),$lonid); + return 1 if ($result eq 'ok'); + + return 0; } # --------------------------------------------- Try to change a user's password sub changepass { - my ($uname,$udom,$currentpass,$newpass,$server)=@_; + my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_; $currentpass = &escape($currentpass); $newpass = &escape($newpass); - my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass", + my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context", $server); if (! $answer) { &logthis("No reply on password change request to $server ". @@ -571,18 +752,38 @@ sub queryauthenticate { # --------- Try to authenticate user from domain's lib servers (first this one) sub authenticate { - my ($uname,$upass,$udom)=@_; - $upass=escape($upass); - $uname=~s/\W//g; - my $uhome=&homeserver($uname,$udom); - if (!$uhome) { - &logthis("User $uname at $udom is unknown in authenticate"); - return 'no_host'; + my ($uname,$upass,$udom,$checkdefauth)=@_; + $upass=&escape($upass); + $uname= &LONCAPA::clean_username($uname); + my $uhome=&homeserver($uname,$udom,1); + my $newhome; + if ((!$uhome) || ($uhome eq 'no_host')) { +# Maybe the machine was offline and only re-appeared again recently? + &reconlonc(); +# One more + $uhome=&homeserver($uname,$udom,1); + if (($uhome eq 'no_host') && $checkdefauth) { + if (defined(&domain($udom,'primary'))) { + $newhome=&domain($udom,'primary'); + } + if ($newhome ne '') { + $uhome = $newhome; + } + } + if ((!$uhome) || ($uhome eq 'no_host')) { + &logthis("User $uname at $udom is unknown in authenticate"); + return 'no_host'; + } } - my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome); + my $answer=reply("encrypt:auth:$udom:$uname:$upass:$checkdefauth",$uhome); if ($answer eq 'authorized') { - &logthis("User $uname at $udom authorized by $uhome"); - return $uhome; + if ($newhome) { + &logthis("User $uname at $udom authorized by $uhome, but needs account"); + return 'no_account_on_host'; + } else { + &logthis("User $uname at $udom authorized by $uhome"); + return $uhome; + } } if ($answer eq 'non_authorized') { &logthis("User $uname at $udom rejected by $uhome"); @@ -600,18 +801,19 @@ sub homeserver { my $index="$uname:$udom"; if (exists($homecache{$index})) { return $homecache{$index}; } - my $tryserver; - foreach $tryserver (keys %libserv) { + + my %servers = &get_servers($udom,'library'); + foreach my $tryserver (keys(%servers)) { next if ($ignoreBadCache ne 'true' && exists($badServerCache{$tryserver})); - if ($hostdom{$tryserver} eq $udom) { - my $answer=reply("home:$udom:$uname",$tryserver); - if ($answer eq 'found') { - return $homecache{$index}=$tryserver; - } elsif ($answer eq 'no_host') { - $badServerCache{$tryserver}=1; - } - } + + my $answer=reply("home:$udom:$uname",$tryserver); + if ($answer eq 'found') { + delete($badServerCache{$tryserver}); + return $homecache{$index}=$tryserver; + } elsif ($answer eq 'no_host') { + $badServerCache{$tryserver}=1; + } } return 'no_host'; } @@ -622,24 +824,22 @@ sub idget { my ($udom,@ids)=@_; my %returnhash=(); - my $tryserver; - foreach $tryserver (keys %libserv) { - if ($hostdom{$tryserver} eq $udom) { - my $idlist=join('&',@ids); - $idlist=~tr/A-Z/a-z/; - my $reply=&reply("idget:$udom:".$idlist,$tryserver); - my @answer=(); - if (($reply ne 'con_lost') && ($reply!~/^error\:/)) { - @answer=split(/\&/,$reply); - } ; - my $i; - for ($i=0;$i<=$#ids;$i++) { - if ($answer[$i]) { - $returnhash{$ids[$i]}=$answer[$i]; - } - } - } - } + my %servers = &get_servers($udom,'library'); + foreach my $tryserver (keys(%servers)) { + my $idlist=join('&',@ids); + $idlist=~tr/A-Z/a-z/; + my $reply=&reply("idget:$udom:".$idlist,$tryserver); + my @answer=(); + if (($reply ne 'con_lost') && ($reply!~/^error\:/)) { + @answer=split(/\&/,$reply); + } ; + my $i; + for ($i=0;$i<=$#ids;$i++) { + if ($answer[$i]) { + $returnhash{$ids[$i]}=$answer[$i]; + } + } + } return %returnhash; } @@ -648,8 +848,8 @@ sub idget { sub idrget { my ($udom,@unames)=@_; my %returnhash=(); - foreach (@unames) { - $returnhash{$_}=(&userenvironment($udom,$_,'id'))[1]; + foreach my $uname (@unames) { + $returnhash{$uname}=(&userenvironment($udom,$uname,'id'))[1]; } return %returnhash; } @@ -659,23 +859,373 @@ sub idrget { sub idput { my ($udom,%ids)=@_; my %servers=(); - foreach (keys %ids) { - &cput('environment',{'id'=>$ids{$_}},$udom,$_); - my $uhom=&homeserver($_,$udom); + foreach my $uname (keys(%ids)) { + &cput('environment',{'id'=>$ids{$uname}},$udom,$uname); + my $uhom=&homeserver($uname,$udom); if ($uhom ne 'no_host') { - my $id=&escape($ids{$_}); + my $id=&escape($ids{$uname}); $id=~tr/A-Z/a-z/; - my $unam=&escape($_); + my $esc_unam=&escape($uname); if ($servers{$uhom}) { - $servers{$uhom}.='&'.$id.'='.$unam; + $servers{$uhom}.='&'.$id.'='.$esc_unam; + } else { + $servers{$uhom}=$id.'='.$esc_unam; + } + } + } + foreach my $server (keys(%servers)) { + &critical('idput:'.$udom.':'.$servers{$server},$server); + } +} + +# ------------------------------------------- get items from domain db files + +sub get_dom { + my ($namespace,$storearr,$udom,$uhome)=@_; + my $items=''; + foreach my $item (@$storearr) { + $items.=&escape($item).'&'; + } + $items=~s/\&$//; + if (!$udom) { + $udom=$env{'user.domain'}; + if (defined(&domain($udom,'primary'))) { + $uhome=&domain($udom,'primary'); + } else { + undef($uhome); + } + } else { + if (!$uhome) { + if (defined(&domain($udom,'primary'))) { + $uhome=&domain($udom,'primary'); + } + } + } + if ($udom && $uhome && ($uhome ne 'no_host')) { + my $rep=&reply("getdom:$udom:$namespace:$items",$uhome); + my %returnhash; + if ($rep eq '' || $rep =~ /^error: 2 /) { + return %returnhash; + } + my @pairs=split(/\&/,$rep); + if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) { + return @pairs; + } + my $i=0; + foreach my $item (@$storearr) { + $returnhash{$item}=&thaw_unescape($pairs[$i]); + $i++; + } + return %returnhash; + } else { + &logthis("get_dom failed - no homeserver and/or domain ($udom) ($uhome)"); + } +} + +# -------------------------------------------- put items in domain db files + +sub put_dom { + my ($namespace,$storehash,$udom,$uhome)=@_; + if (!$udom) { + $udom=$env{'user.domain'}; + if (defined(&domain($udom,'primary'))) { + $uhome=&domain($udom,'primary'); + } else { + undef($uhome); + } + } else { + if (!$uhome) { + if (defined(&domain($udom,'primary'))) { + $uhome=&domain($udom,'primary'); + } + } + } + if ($udom && $uhome && ($uhome ne 'no_host')) { + my $items=''; + foreach my $item (keys(%$storehash)) { + $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; + } + $items=~s/\&$//; + return &reply("putdom:$udom:$namespace:$items",$uhome); + } else { + &logthis("put_dom failed - no homeserver and/or domain"); + } +} + +sub retrieve_inst_usertypes { + my ($udom) = @_; + my (%returnhash,@order); + if (defined(&domain($udom,'primary'))) { + my $uhome=&domain($udom,'primary'); + my $rep=&reply("inst_usertypes:$udom",$uhome); + if ($rep =~ /^(con_lost|error|no_such_host|refused)/) { + &logthis("get_dom failed - $rep returned from $uhome in domain: $udom"); + return (\%returnhash,\@order); + } + my ($hashitems,$orderitems) = split(/:/,$rep); + my @pairs=split(/\&/,$hashitems); + foreach my $item (@pairs) { + my ($key,$value)=split(/=/,$item,2); + $key = &unescape($key); + next if ($key =~ /^error: 2 /); + $returnhash{$key}=&thaw_unescape($value); + } + my @esc_order = split(/\&/,$orderitems); + foreach my $item (@esc_order) { + push(@order,&unescape($item)); + } + } else { + &logthis("get_dom failed - no primary domain server for $udom"); + } + return (\%returnhash,\@order); +} + +sub is_domainimage { + my ($url) = @_; + if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo)/+-) { + if (&domain($1) ne '') { + return '1'; + } + } + return; +} + +sub inst_directory_query { + my ($srch) = @_; + my $udom = $srch->{'srchdomain'}; + my %results; + my $homeserver = &domain($udom,'primary'); + my $outcome; + if ($homeserver ne '') { + my $queryid=&reply("querysend:instdirsearch:". + &escape($srch->{'srchby'}).':'. + &escape($srch->{'srchterm'}).':'. + &escape($srch->{'srchtype'}),$homeserver); + my $host=&hostname($homeserver); + if ($queryid !~/^\Q$host\E\_/) { + &logthis('instituional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom); + return; + } + my $response = &get_query_reply($queryid); + my $maxtries = 5; + my $tries = 1; + while (($response=~/^timeout/) && ($tries < $maxtries)) { + $response = &get_query_reply($queryid); + $tries ++; + } + + if (!&error($response) && $response ne 'refused') { + if ($response eq 'unavailable') { + $outcome = $response; + } else { + $outcome = 'ok'; + my @matches = split(/\n/,$response); + foreach my $match (@matches) { + my ($key,$value) = split(/=/,$match); + $results{&unescape($key).':'.$udom} = &thaw_unescape($value); + } + } + } + } + return ($outcome,%results); +} + +sub usersearch { + my ($srch) = @_; + my $dom = $srch->{'srchdomain'}; + my %results; + my %libserv = &all_library(); + my $query = 'usersearch'; + foreach my $tryserver (keys(%libserv)) { + if (&host_domain($tryserver) eq $dom) { + my $host=&hostname($tryserver); + my $queryid= + &reply("querysend:".&escape($query).':'. + &escape($srch->{'srchby'}).':'. + &escape($srch->{'srchtype'}).':'. + &escape($srch->{'srchterm'}),$tryserver); + if ($queryid !~/^\Q$host\E\_/) { + &logthis('usersearch: invalid queryid: '.$queryid.' for host: '.$host.'in domain '.$dom.' and server: '.$tryserver); + next; + } + my $reply = &get_query_reply($queryid); + my $maxtries = 1; + my $tries = 1; + while (($reply=~/^timeout/) && ($tries < $maxtries)) { + $reply = &get_query_reply($queryid); + $tries ++; + } + if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { + &logthis('usersrch error: '.$reply.' for '.$dom.' - searching for : '.$srch->{'srchterm'}.' by '.$srch->{'srchby'}.' ('.$srch->{'srchtype'}.') - maxtries: '.$maxtries.' tries: '.$tries); + } else { + my @matches; + if ($reply =~ /\n/) { + @matches = split(/\n/,$reply); + } else { + @matches = split(/\&/,$reply); + } + foreach my $match (@matches) { + my ($uname,$udom,%userhash); + foreach my $entry (split(/:/,$match)) { + my ($key,$value) = + map {&unescape($_);} split(/=/,$entry); + $userhash{$key} = $value; + if ($key eq 'username') { + $uname = $value; + } elsif ($key eq 'domain') { + $udom = $value; + } + } + $results{$uname.':'.$udom} = \%userhash; + } + } + } + } + return %results; +} + +sub get_instuser { + my ($udom,$uname,$id) = @_; + my $homeserver = &domain($udom,'primary'); + my ($outcome,%results); + if ($homeserver ne '') { + my $queryid=&reply("querysend:getinstuser:".&escape($uname).':'. + &escape($id).':'.&escape($udom),$homeserver); + my $host=&hostname($homeserver); + if ($queryid !~/^\Q$host\E\_/) { + &logthis('get_instuser invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom); + return; + } + my $response = &get_query_reply($queryid); + my $maxtries = 5; + my $tries = 1; + while (($response=~/^timeout/) && ($tries < $maxtries)) { + $response = &get_query_reply($queryid); + $tries ++; + } + if (!&error($response) && $response ne 'refused') { + if ($response eq 'unavailable') { + $outcome = $response; + } else { + $outcome = 'ok'; + my @matches = split(/\n/,$response); + foreach my $match (@matches) { + my ($key,$value) = split(/=/,$match); + $results{&unescape($key)} = &thaw_unescape($value); + } + } + } + } + my %userinfo; + if (ref($results{$uname}) eq 'HASH') { + %userinfo = %{$results{$uname}}; + } + return ($outcome,%userinfo); +} + +sub inst_rulecheck { + my ($udom,$uname,$id,$item,$rules) = @_; + my %returnhash; + if ($udom ne '') { + if (ref($rules) eq 'ARRAY') { + @{$rules} = map {&escape($_);} (@{$rules}); + my $rulestr = join(':',@{$rules}); + my $homeserver=&domain($udom,'primary'); + if (($homeserver ne '') && ($homeserver ne 'no_host')) { + my $response; + if ($item eq 'username') { + $response=&unescape(&reply('instrulecheck:'.&escape($udom). + ':'.&escape($uname).':'.$rulestr, + $homeserver)); + } elsif ($item eq 'id') { + $response=&unescape(&reply('instidrulecheck:'.&escape($udom). + ':'.&escape($id).':'.$rulestr, + $homeserver)); + } elsif ($item eq 'selfcreate') { + $response=&unescape(&reply('instselfcreatecheck:'. + &escape($udom).':'.&escape($uname). + ':'.$rulestr,$homeserver)); + } + if ($response ne 'refused') { + my @pairs=split(/\&/,$response); + 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; +} + +sub inst_userrules { + my ($udom,$check) = @_; + my (%ruleshash,@ruleorder); + if ($udom ne '') { + my $homeserver=&domain($udom,'primary'); + if (($homeserver ne '') && ($homeserver ne 'no_host')) { + my $response; + if ($check eq 'id') { + $response=&reply('instidrules:'.&escape($udom), + $homeserver); + } elsif ($check eq 'email') { + $response=&reply('instemailrules:'.&escape($udom), + $homeserver); } else { - $servers{$uhom}=$id.'='.$unam; + $response=&reply('instuserrules:'.&escape($udom), + $homeserver); + } + if (($response ne 'refused') && ($response ne 'error') && + ($response ne 'unknown_cmd') && + ($response ne 'no_such_host')) { + my ($hashitems,$orderitems) = split(/:/,$response); + my @pairs=split(/\&/,$hashitems); + foreach my $item (@pairs) { + my ($key,$value)=split(/=/,$item,2); + $key = &unescape($key); + next if ($key =~ /^error: 2 /); + $ruleshash{$key}=&thaw_unescape($value); + } + my @esc_order = split(/\&/,$orderitems); + foreach my $item (@esc_order) { + push(@ruleorder,&unescape($item)); + } } } } - foreach (keys %servers) { - &critical('idput:'.$udom.':'.$servers{$_},$_); + return (\%ruleshash,\@ruleorder); +} + +# ------------------------- Get Authentication and Language Defaults for Domain + +sub get_domain_defaults { + my ($domain) = @_; + my $cachetime = 60*60*24; + my ($defauthtype,$defautharg,$deflang); + my ($result,$cached)=&is_cached_new('domdefaults',$domain); + if (defined($cached)) { + if (ref($result) eq 'HASH') { + return %{$result}; + } } + my %domdefaults; + my %domconfig = + &Apache::lonnet::get_dom('configuration',['defaults'],$domain); + if (ref($domconfig{'defaults'}) eq 'HASH') { + $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; + $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'}; + $domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'}; + } else { + $domdefaults{'lang_def'} = &domain($domain,'lang_def'); + $domdefaults{'auth_def'} = &domain($domain,'auth_def'); + $domdefaults{'auth_arg_def'} = &domain($domain,'auth_arg_def'); + } + &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults, + $cachetime); + return %domdefaults; } # --------------------------------------------------- Assign a key to a student @@ -710,7 +1260,7 @@ sub assign_access_key { # key now belongs to user my $envkey='key.'.$cdom.'_'.$cnum; if (&put('environment',{$envkey => $ckey}) eq 'ok') { - &appenv('environment.'.$envkey => $ckey); + &appenv({'environment.'.$envkey => $ckey}); return 'ok'; } else { return @@ -811,17 +1361,32 @@ sub validate_access_key { # ------------------------------------- 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 courseid_to_courseurl { + my ($courseid) = @_; + #already url style courseid + return $courseid if ($courseid =~ m{^/}); + + if (exists($env{'course.'.$courseid.'.num'})) { + my $cnum = $env{'course.'.$courseid.'.num'}; + my $cdom = $env{'course.'.$courseid.'.domain'}; + return "/$cdom/$cnum"; + } + + my %courseinfo=&Apache::lonnet::coursedescription($courseid); + if (exists($courseinfo{'num'})) { + return "/$courseinfo{'domain'}/$courseinfo{'num'}"; + } + + return undef; +} + sub getsection { my ($udom,$unam,$courseid)=@_; my $cachetime=1800; - $courseid=~s/\_/\//g; - $courseid=~s/^(\w)/\/$1/; my $hashid="$udom:$unam:$courseid"; my ($result,$cached)=&is_cached_new('getsection',$hashid); @@ -842,14 +1407,13 @@ sub getsection { # If there is more than one expired role, choose the one which ended last. # If there is a role which has expired, return it. # - foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles', - &homeserver($unam,$udom)))) { - my ($key,$value)=split(/\=/,$_); - $key=&unescape($key); + $courseid = &courseid_to_courseurl($courseid); + my %roleshash = &dump('roles',$udom,$unam,$courseid); + foreach my $key (keys(%roleshash)) { next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/); my $section=$1; if ($key eq $courseid.'_st') { $section=''; } - my ($dummy,$end,$start)=split(/\_/,&unescape($value)); + my ($dummy,$end,$start)=split(/\_/,&unescape($roleshash{$key})); my $now=time; if (defined($end) && $end && ($now > $end)) { $Expired{$end}=$section; @@ -880,6 +1444,7 @@ sub save_cache { &purge_remembered(); #&Apache::loncommon::validate_page(); undef(%env); + undef($env_loaded); } my $to_remember=-1; @@ -887,10 +1452,19 @@ my %remembered; my %accessed; my $kicks=0; my $hits=0; +sub make_key { + my ($name,$id) = @_; + if (length($id) > 65 + && length(&escape($id)) > 200) { + $id=length($id).':'.&Digest::MD5::md5_hex($id); + } + return &escape($name.':'.$id); +} + sub devalidate_cache_new { my ($name,$id,$debug) = @_; if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); } - $id=&escape($name.':'.$id); + $id=&make_key($name,$id); $memcache->delete($id); delete($remembered{$id}); delete($accessed{$id}); @@ -898,7 +1472,7 @@ sub devalidate_cache_new { sub is_cached_new { my ($name,$id,$debug) = @_; - $id=&escape($name.':'.$id); + $id=&make_key($name,$id); if (exists($remembered{$id})) { if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); } $accessed{$id}=[&gettimeofday()]; @@ -921,7 +1495,7 @@ sub is_cached_new { sub do_cache_new { my ($name,$id,$value,$time,$debug) = @_; - $id=&escape($name.':'.$id); + $id=&make_key($name,$id); my $setvalue=$value; if (!defined($setvalue)) { $setvalue='__undef__'; @@ -930,15 +1504,21 @@ sub do_cache_new { $time=600; } if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); } - $memcache->set($id,$setvalue,$time); + my $result = $memcache->set($id,$setvalue,$time); + if (! $result) { + &logthis("caching of id -> $id failed"); + $memcache->disconnect_all(); + } # need to make a copy of $value - #&make_room($id,$value,$debug); + &make_room($id,$value,$debug); return $value; } sub make_room { my ($id,$value,$debug)=@_; - $remembered{$id}=$value; + + $remembered{$id}= (ref($value)) ? &Storable::dclone($value) + : $value; if ($to_remember<0) { return; } $accessed{$id}=[&gettimeofday()]; if (scalar(keys(%remembered)) <= $to_remember) { return; } @@ -1099,6 +1679,7 @@ sub repcopy { } $filename=~s/[\n\r]//g; my $transname="$filename.in.transfer"; +# FIXME: this should flock if ((-e $filename) || (-e $transname)) { return 'ok'; } my $remoteurl=subscribe($filename); if ($remoteurl =~ /^con_lost by/) { @@ -1163,37 +1744,67 @@ sub ssi_body { if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) { $form{'LONCAPA_INTERNAL_no_discussion'}='true'; } - my $output=($filelink=~/^http\:/?&externalssi($filelink): - &ssi($filelink,%form)); - $output=~s|//(\s*)?\s||gs; + my $output=''; + my $response; + if ($filelink=~/^http\:/) { + ($output,$response)=&externalssi($filelink); + } else { + ($output,$response)=&ssi($filelink,%form); + } + $output=~s|//(\s*)?\s||gs; $output=~s/^.*?\]*\>//si; - $output=~s/(.*)\<\/body\s*\>.*?$/$1/si; - return $output; + $output=~s/\<\/body\s*\>.*?$//si; + if (wantarray) { + return ($output, $response); + } else { + return $output; + } } # --------------------------------------------------------- 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; +} + +# +# Server side include. +# Parameters: +# fn Possibly encrypted resource name/id. +# form Hash that describes how the rendering should be done +# and other things. +# Returns: +# Scalar context: The content of the response. +# Array context: 2 element list of the content and the full response object. +# sub ssi { my ($fn,%form)=@_; - my $ua=new LWP::UserAgent; - my $request; $form{'no_update_last_known'}=1; - + &Apache::lonenc::check_encrypt(\$fn); 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'}); my $response=$ua->request($request); - return $response->content; + if (wantarray) { + return ($response->content, $response); + } else { + return $response->content; + } } sub externalssi { @@ -1201,7 +1812,11 @@ sub externalssi { my $ua=new LWP::UserAgent; my $request=new HTTP::Request('GET',$url); my $response=$ua->request($request); - return $response->content; + if (wantarray) { + return ($response->content, $response); + } else { + return $response->content; + } } # -------------------------------- Allow a /uploaded/ URI to be vouched for @@ -1214,7 +1829,7 @@ sub allowuploaded { my %httpref=(); my $httpurl=&hreflocation('',$url); $httpref{'httpref.'.$httpurl}=$srcurl; - &Apache::lonnet::appenv(%httpref); + &Apache::lonnet::appenv(\%httpref); } # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course @@ -1275,7 +1890,7 @@ sub process_coursefile { print $fh $env{'form.'.$source}; close($fh); if ($parser eq 'parse') { - my $parse_result = &extract_embedded_items($filepath,$fname,$allfiles,$codebase); + 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); } @@ -1338,15 +1953,17 @@ sub store_edited_file { } sub clean_filename { - my ($fname)=@_; + my ($fname,$args)=@_; # Replace Windows backslashes by forward slashes $fname=~s/\\/\//g; -# Get rid of everything but the actual filename - $fname=~s/^.*\/([^\/]+)$/$1/; + if (!$args->{'keep_path'}) { + # Get rid of everything but the actual filename + $fname=~s/^.*\/([^\/]+)$/$1/; + } # Replace spaces by underscores $fname=~s/\s+/\_/g; # Replace all other weird characters by nothing - $fname=~s/[^\w\.\-]//g; + $fname=~s{[^/\w\.\-]}{}g; # Replace all .\d. sequences with _\d. so they no longer look like version # numbers $fname=~s/\.(\d+)(?=\.)/_$1/g; @@ -1359,14 +1976,21 @@ sub clean_filename { # $coursedoc - if true up to the current course # if false # $subdir - directory in userfile to store the file into -# $parser, $allfiles, $codebase - unknown -# +# $parser - instruction to parse file for objects ($parser = parse) +# $allfiles - reference to hash for embedded objects +# $codebase - reference to hash for codebase of java objects +# $desuname - username for permanent storage of uploaded file +# $dsetudom - domain for permanaent storage of uploaded file +# $thumbwidth - width (pixels) of thumbnail to make for uploaded image +# $thumbheight - height (pixels) of thumbnail to make for uploaded image +# # output: url of file in userspace, or error: # or /adm/notfound.html if failure to upload occurse sub userfileupload { - my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,$destudom)=@_; + my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname, + $destudom,$thumbwidth,$thumbheight)=@_; if (!defined($subdir)) { $subdir='unknown'; } my $fname=$env{'form.'.$formname.'.filename'}; $fname=&clean_filename($fname); @@ -1413,7 +2037,7 @@ sub userfileupload { if ($env{'form.folder'} =~ m/^(default|supplemental)/) { return &finishuserfileupload($docuname,$docudom, $formname,$fname,$parser,$allfiles, - $codebase); + $codebase,$thumbwidth,$thumbheight); } else { $fname=$env{'form.folder'}.'/'.$fname; return &process_coursefile('uploaddoc',$docuname,$docudom, @@ -1423,8 +2047,9 @@ sub userfileupload { } elsif (defined($destuname)) { my $docuname=$destuname; my $docudom=$destudom; - return &finishuserfileupload($docuname,$docudom,$formname, - $fname,$parser,$allfiles,$codebase); + return &finishuserfileupload($docuname,$docudom,$formname,$fname, + $parser,$allfiles,$codebase, + $thumbwidth,$thumbheight); } else { my $docuname=$env{'user.name'}; @@ -1433,16 +2058,18 @@ sub userfileupload { $docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; } - return &finishuserfileupload($docuname,$docudom,$formname, - $fname,$parser,$allfiles,$codebase); + return &finishuserfileupload($docuname,$docudom,$formname,$fname, + $parser,$allfiles,$codebase, + $thumbwidth,$thumbheight); } } sub finishuserfileupload { - my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase) = @_; + my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase, + $thumbwidth,$thumbheight) = @_; my $path=$docudom.'/'.$docuname.'/'; my $filepath=$perlvar{'lonDocRoot'}; - my ($fnamepath,$file); + my ($fnamepath,$file,$fetchthumb); $file=$fname; if ($fname=~m|/|) { ($fnamepath,$file) = ($fname =~ m|^(.*)/([^/]+)$|); @@ -1471,18 +2098,35 @@ sub finishuserfileupload { close(FH); } if ($parser eq 'parse') { - my $parse_result = &extract_embedded_items($filepath,$file,$allfiles, + 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); } } + if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) { + my $input = $filepath.'/'.$file; + my $output = $filepath.'/'.'tn-'.$file; + my $thumbsize = $thumbwidth.'x'.$thumbheight; + system("convert -sample $thumbsize $input $output"); + if (-e $filepath.'/'.'tn-'.$file) { + $fetchthumb = 1; + } + } + # Notify homeserver to grep it # my $docuhome=&homeserver($docuname,$docudom); my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome); if ($fetchresult eq 'ok') { + if ($fetchthumb) { + my $thumbresult= &reply('fetchuserfile:'.$path.'tn-'.$file,$docuhome); + if ($thumbresult ne 'ok') { + &logthis('Failed to transfer '.$path.'tn-'.$file.' to host '. + $docuhome.': '.$thumbresult); + } + } # # Return the URL to it return '/uploaded/'.$path.$file; @@ -1490,11 +2134,11 @@ sub finishuserfileupload { &logthis('Failed to transfer '.$path.$file.' to host '.$docuhome. ': '.$fetchresult); return '/adm/notfound.html'; - } + } } sub extract_embedded_items { - my ($filepath,$file,$allfiles,$codebase,$content) = @_; + my ($fullpath,$allfiles,$codebase,$content) = @_; my @state = (); my %javafiles = ( codebase => '', @@ -1509,18 +2153,21 @@ sub extract_embedded_items { if ($content) { $p = HTML::LCParser->new($content); } else { - $p = HTML::LCParser->new($filepath.'/'.$file); + $p = HTML::LCParser->new($fullpath); } while (my $t=$p->get_token()) { if ($t->[0] eq 'S') { my ($tagname, $attr) = ($t->[1],$t->[2]); - push (@state, $tagname); + 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 'a') { + &add_filetype($allfiles,$attr->{'href'},'href'); + } if (lc($tagname) eq 'script') { if ($attr->{'archive'} =~ /\.jar$/i) { &add_filetype($allfiles,$attr->{'archive'},'archive'); @@ -1610,7 +2257,20 @@ sub removeuploadedurl { sub removeuserfile { my ($docuname,$docudom,$fname)=@_; my $home=&homeserver($docuname,$docudom); - return &reply("removeuserfile:$docudom/$docuname/$fname",$home); + my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home); + if ($result eq 'ok') { + if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) { + my $metafile = $fname.'.meta'; + my $metaresult = &removeuserfile($docuname,$docudom,$metafile); + my $url = "/uploaded/$docudom/$docuname/$fname"; + my ($file,$group) = (&parse_portfolio_url($url))[3,4]; + my $sqlresult = + &update_portfolio_table($docuname,$docudom,$file, + 'portfolio_metadata',$group, + 'delete'); + } + } + return $result; } sub mkdiruserfile { @@ -1622,8 +2282,23 @@ sub mkdiruserfile { sub renameuserfile { my ($docuname,$docudom,$old,$new)=@_; my $home=&homeserver($docuname,$docudom); - return &reply("renameuserfile:$docudom:$docuname:".&escape("$old").':'. - &escape("$new"),$home); + my $result = &reply("renameuserfile:$docudom:$docuname:". + &escape("$old").':'.&escape("$new"),$home); + if ($result eq 'ok') { + if (($old !~ /\.meta$/) && (&is_portfolio_file($old))) { + my $oldmeta = $old.'.meta'; + my $newmeta = $new.'.meta'; + my $metaresult = + &renameuserfile($docuname,$docudom,$oldmeta,$newmeta); + my $url = "/uploaded/$docudom/$docuname/$old"; + my ($file,$group) = (&parse_portfolio_url($url))[3,4]; + my $sqlresult = + &update_portfolio_table($docuname,$docudom,$file, + 'portfolio_metadata',$group, + 'delete'); + } + } + return $result; } # ------------------------------------------------------------------------- Log @@ -1649,8 +2324,7 @@ sub flushcourselogs { # times and course titles for all courseids # my %courseidbuffer=(); - foreach (keys %courselogs) { - my $crsid=$_; + foreach my $crsid (keys(%courselogs)) { if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'. &escape($courselogs{$crsid}), $coursehombuf{$crsid}) eq 'ok') { @@ -1663,22 +2337,21 @@ sub flushcourselogs { delete $courselogs{$crsid}; } } - if ($courseidbuffer{$coursehombuf{$crsid}}) { - $courseidbuffer{$coursehombuf{$crsid}}.='&'. - &escape($crsid).'='.&escape($coursedescrbuf{$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($coursetypebuf{$crsid}); - } + $courseidbuffer{$coursehombuf{$crsid}}{$crsid} = { + 'description' => $coursedescrbuf{$crsid}, + 'inst_code' => $courseinstcodebuf{$crsid}, + 'type' => $coursetypebuf{$crsid}, + 'owner' => $courseownerbuf{$crsid}, + }; } # # Write course id database (reverse lookup) to homeserver of courses # Is used in pickcourse # - foreach (keys %courseidbuffer) { - &courseidput($hostdom{$_},$courseidbuffer{$_},$_); + foreach my $crs_home (keys(%courseidbuffer)) { + my $response = &courseidput(&host_domain($crs_home), + $courseidbuffer{$crs_home}, + $crs_home,'timeonly'); } # # File accesses @@ -1687,7 +2360,8 @@ sub flushcourselogs { foreach my $entry (keys(%accesshash)) { if ($entry =~ /___count$/) { my ($dom,$name); - ($dom,$name,undef)=($entry=~m:___(\w+)/(\w+)/(.*)___count$:); + ($dom,$name,undef)= + ($entry=~m{___($match_domain)/($match_name)/(.*)___count$}); if (! defined($dom) || $dom eq '' || ! defined($name) || $name eq '') { my $cid = $env{'request.course.id'}; @@ -1708,7 +2382,7 @@ sub flushcourselogs { } } } else { - my ($dom,$name) = ($entry=~m:___(\w+)/(\w+)/(.*)___(\w+)$:); + my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\w+)$}); my %temphash=($entry => $accesshash{$entry}); if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') { delete $accesshash{$entry}; @@ -1719,8 +2393,7 @@ sub flushcourselogs { # Roles # Reverse lookup of user roles for course faculty/staff and co-authorship # - foreach (keys %userrolehash) { - my $entry=$_; + foreach my $entry (keys(%userrolehash)) { my ($role,$uname,$udom,$runame,$rudom,$rsec)= split(/\:/,$entry); if (&Apache::lonnet::put('nohist_userroles', @@ -1734,7 +2407,7 @@ sub flushcourselogs { # my %domrolebuffer = (); foreach my $entry (keys %domainrolehash) { - my ($role,$uname,$udom,$runame,$rudom,$rsec)=split/:/,$entry; + my ($role,$uname,$udom,$runame,$rudom,$rsec)=split(/:/,$entry); if ($domrolebuffer{$rudom}) { $domrolebuffer{$rudom}.='&'.&escape($entry). '='.&escape($domainrolehash{$entry}); @@ -1745,13 +2418,12 @@ sub flushcourselogs { 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); - } - } + my %servers = &get_servers($dom,'library'); + foreach my $tryserver (keys(%servers)) { + unless (&reply('domroleput:'.$dom.':'. + $domrolebuffer{$dom},$tryserver) eq 'ok') { + &logthis('Put of domain roles failed for '.$dom.' and '.$tryserver); + } } } $dumpcount++; @@ -1792,9 +2464,9 @@ sub courseacclog { if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|task|page)$/) { $what.=':POST'; # FIXME: Probably ought to escape things.... - foreach (keys %env) { - if ($_=~/^form\.(.*)/) { - $what.=':'.$1.'='.$env{$_}; + foreach my $key (keys(%env)) { + if ($key=~/^form\.(.*)/) { + $what.=':'.$1.'='.$env{$key}; } } } elsif ($fnsymb =~ m:^/adm/searchcat:) { @@ -1840,6 +2512,14 @@ sub userrolelog { {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} =$tend.':'.$tstart; } + if (($env{'request.role'} =~ /dc\./) && + (($trole=~/^au/) || ($trole=~/^in/) || + ($trole=~/^cc/) || ($trole=~/^ep/) || + ($trole=~/^cr/) || ($trole=~/^ta/))) { + $userrolehash + {$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'} + =$tend.':'.$tstart; + } if (($trole=~/^dc/) || ($trole=~/^ad/) || ($trole=~/^li/) || ($trole=~/^li/) || ($trole=~/^au/) || ($trole=~/^dg/) || @@ -1851,58 +2531,165 @@ sub userrolelog { } } +sub courserolelog { + my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,$context)=@_; + if (($trole eq 'cc') || ($trole eq 'in') || + ($trole eq 'ep') || ($trole eq 'ad') || + ($trole eq 'ta') || ($trole eq 'st') || + ($trole=~/^cr/) || ($trole eq 'gr')) { + if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) { + my $cdom = $1; + my $cnum = $2; + my $sec = $3; + my $namespace = 'rolelog'; + my %storehash = ( + role => $trole, + start => $tstart, + end => $tend, + selfenroll => $selfenroll, + context => $context, + ); + if ($trole eq 'gr') { + $namespace = 'groupslog'; + $storehash{'group'} = $sec; + } else { + $storehash{'section'} = $sec; + } + &instructor_log($namespace,\%storehash,$delflag,$username,$domain,$cnum,$cdom); + } + } + return; +} + sub get_course_adv_roles { - my $cid=shift; + my ($cid,$codes) = @_; $cid=$env{'request.course.id'} unless (defined($cid)); my %coursehash=&coursedescription($cid); my %nothide=(); - foreach (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { - $nothide{join(':',split(/[\@\:]/,$_))}=1; + foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { + if ($user !~ /:/) { + $nothide{join(':',split(/[\@]/,$user))}=1; + } else { + $nothide{$user}=1; + } } my %returnhash=(); my %dumphash= &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'}); my $now=time; - foreach (keys %dumphash) { - my ($tend,$tstart)=split(/\:/,$dumphash{$_}); + foreach my $entry (keys %dumphash) { + my ($tend,$tstart)=split(/\:/,$dumphash{$entry}); if (($tstart) && ($tstart<0)) { next; } if (($tend) && ($tend<$now)) { next; } if (($tstart) && ($now<$tstart)) { next; } - my ($role,$username,$domain,$section)=split(/\:/,$_); + my ($role,$username,$domain,$section)=split(/\:/,$entry); if ($username eq '' || $domain eq '') { next; } if ((&privileged($username,$domain)) && (!$nothide{$username.':'.$domain})) { next; } if ($role eq 'cr') { next; } - my $key=&plaintext($role); - if ($role =~ /^cr/) { - $key=(split('/',$role))[3]; - } - if ($section) { $key.=' (Sec/Grp '.$section.')'; } - if ($returnhash{$key}) { - $returnhash{$key}.=','.$username.':'.$domain; + if ($codes) { + if ($section) { $role .= ':'.$section; } + if ($returnhash{$role}) { + $returnhash{$role}.=','.$username.':'.$domain; + } else { + $returnhash{$role}=$username.':'.$domain; + } } else { - $returnhash{$key}=$username.':'.$domain; + my $key=&plaintext($role); + if ($section) { $key.=' (Section '.$section.')'; } + if ($returnhash{$key}) { + $returnhash{$key}.=','.$username.':'.$domain; + } else { + $returnhash{$key}=$username.':'.$domain; + } } - } + } return %returnhash; } sub get_my_roles { - my ($uname,$udom)=@_; + my ($uname,$udom,$context,$types,$roles,$roledoms,$withsec,$hidepriv)=@_; unless (defined($uname)) { $uname=$env{'user.name'}; } unless (defined($udom)) { $udom=$env{'user.domain'}; } - my %dumphash= + my (%dumphash,%nothide); + if ($context eq 'userroles') { + %dumphash = &dump('roles',$udom,$uname); + } else { + %dumphash= &dump('nohist_userroles',$udom,$uname); + if ($hidepriv) { + my %coursehash=&coursedescription($udom.'_'.$uname); + foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { + if ($user !~ /:/) { + $nothide{join(':',split(/[\@]/,$user))} = 1; + } else { + $nothide{$user} = 1; + } + } + } + } my %returnhash=(); my $now=time; - foreach (keys %dumphash) { - my ($tend,$tstart)=split(/\:/,$dumphash{$_}); + foreach my $entry (keys(%dumphash)) { + my ($role,$tend,$tstart); + if ($context eq 'userroles') { + ($role,$tend,$tstart)=split(/_/,$dumphash{$entry}); + } else { + ($tend,$tstart)=split(/\:/,$dumphash{$entry}); + } if (($tstart) && ($tstart<0)) { next; } - if (($tend) && ($tend<$now)) { next; } - if (($tstart) && ($now<$tstart)) { next; } - my ($role,$username,$domain,$section)=split(/\:/,$_); - $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend; - } + my $status = 'active'; + if (($tend) && ($tend<=$now)) { + $status = 'previous'; + } + if (($tstart) && ($now<$tstart)) { + $status = 'future'; + } + if (ref($types) eq 'ARRAY') { + if (!grep(/^\Q$status\E$/,@{$types})) { + next; + } + } else { + if ($status ne 'active') { + next; + } + } + my ($rolecode,$username,$domain,$section,$area); + if ($context eq 'userroles') { + ($area,$rolecode) = split(/_/,$entry); + (undef,$domain,$username,$section) = split(/\//,$area); + } else { + ($role,$username,$domain,$section) = split(/\:/,$entry); + } + if (ref($roledoms) eq 'ARRAY') { + if (!grep(/^\Q$domain\E$/,@{$roledoms})) { + next; + } + } + if (ref($roles) eq 'ARRAY') { + if (!grep(/^\Q$role\E$/,@{$roles})) { + if ($role =~ /^cr\//) { + if (!grep(/^cr$/,@{$roles})) { + next; + } + } else { + next; + } + } + } + if ($hidepriv) { + if ((&privileged($username,$domain)) && + (!$nothide{$username.':'.$domain})) { + next; + } + } + if ($withsec) { + $returnhash{$username.':'.$domain.':'.$role.':'.$section} = + $tstart.':'.$tend; + } else { + $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend; + } + } return %returnhash; } @@ -1912,7 +2699,7 @@ sub get_my_roles { sub postannounce { my ($server,$text)=@_; - unless (&allowed('psa',$hostdom{$server})) { return 'refused'; } + unless (&allowed('psa',&host_domain($server))) { return 'refused'; } unless ($text=~/\w/) { $text=''; } return &reply('setannounce:'.&escape($text),$server); } @@ -1921,7 +2708,7 @@ sub getannounce { if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) { my $announcement=''; - while (<$fh>) { $announcement .=$_; } + while (my $line = <$fh>) { $announcement .= $line; } close($fh); if ($announcement=~/\w/) { return @@ -1940,26 +2727,80 @@ sub getannounce { # sub courseidput { - my ($domain,$what,$coursehome)=@_; - return &reply('courseidput:'.$domain.':'.$what,$coursehome); + my ($domain,$storehash,$coursehome,$caller) = @_; + my $outcome; + if ($caller eq 'timeonly') { + my $cids = ''; + foreach my $item (keys(%$storehash)) { + $cids.=&escape($item).'&'; + } + $cids=~s/\&$//; + $outcome = &reply('courseidputhash:'.$domain.':'.$caller.':'.$cids, + $coursehome); + } else { + my $items = ''; + foreach my $item (keys(%$storehash)) { + $items.= &escape($item).'='. + &freeze_escape($$storehash{$item}).'&'; + } + $items=~s/\&$//; + $outcome = &reply('courseidputhash:'.$domain.':'.$caller.':'.$items, + $coursehome); + } + if ($outcome eq 'unknown_cmd') { + my $what; + foreach my $cid (keys(%$storehash)) { + $what .= &escape($cid).'='; + foreach my $item ('description','inst_code','owner','type') { + $what .= &escape($storehash->{$cid}{$item}).':'; + } + $what =~ s/\:$/&/; + } + $what =~ s/\&$//; + return &reply('courseidput:'.$domain.':'.$what,$coursehome); + } else { + return $outcome; + } } sub courseiddump { - my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter)=@_; - my %returnhash=(); - unless ($domfilter) { $domfilter=''; } - foreach my $tryserver (keys %libserv) { - if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) || (!defined($hostidflag)) ) { - if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) { - foreach ( - split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. - $sincefilter.':'.&escape($descfilter).':'. - &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter), - $tryserver))) { - my ($key,$value)=split(/\=/,$_); - if (($key) && ($value)) { - $returnhash{&unescape($key)}=$value; - } + my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter, + $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok, + $selfenrollonly,$catfilter,$showhidden,$caller)=@_; + my $as_hash = 1; + my %returnhash; + if (!$domfilter) { $domfilter=''; } + my %libserv = &all_library(); + foreach my $tryserver (keys(%libserv)) { + if ( ( $hostidflag == 1 + && grep(/^\Q$tryserver\E$/,@{$hostidref}) ) + || (!defined($hostidflag)) ) { + + if (($domfilter eq '') || + (&host_domain($tryserver) eq $domfilter)) { + my $rep = + &reply('courseiddump:'.&host_domain($tryserver).':'. + $sincefilter.':'.&escape($descfilter).':'. + &escape($instcodefilter).':'.&escape($ownerfilter). + ':'.&escape($coursefilter).':'.&escape($typefilter). + ':'.&escape($regexp_ok).':'.$as_hash.':'. + &escape($selfenrollonly).':'.&escape($catfilter).':'. + $showhidden.':'.$caller,$tryserver); + my @pairs=split(/\&/,$rep); + foreach my $item (@pairs) { + my ($key,$value)=split(/\=/,$item,2); + $key = &unescape($key); + next if ($key =~ /^error: 2 /); + my $result = &thaw_unescape($value); + if (ref($result) eq 'HASH') { + $returnhash{$key}=$result; + } else { + my @responses = split(/:/,$value); + my @items = ('description','inst_code','owner','type'); + for (my $i=0; $i<@responses; $i++) { + $returnhash{$key}{$items[$i]} = &unescape($responses[$i]); + } + } } } } @@ -1980,13 +2821,14 @@ sub dcmailput { sub dcmaildump { my ($dom,$startdate,$enddate,$senders) = @_; my %returnhash=(); - if (exists($domain_primary{$dom})) { + + if (defined(&domain($dom,'primary'))) { 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(/\=/,$_); + foreach my $line (split(/\&/,&reply($cmd,&domain($dom,'primary')))) { + my ($key,$value) = split(/\=/,$line,2); if (($key) && ($value)) { $returnhash{&unescape($key)} = &unescape($value); } @@ -2004,21 +2846,24 @@ sub get_domain_roles { if (undef($enddate) || $enddate eq '') { $enddate = '.'; } - my $rolelist = join(':',@{$roles}); + my $rolelist; + if (ref($roles) eq 'ARRAY') { + $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); - } - } - } + + my %servers = &get_servers($dom,'library'); + foreach my $tryserver (keys(%servers)) { + %{$personnel{$tryserver}}=(); + foreach my $line (split(/\&/,&reply('domrolesdump:'.$dom.':'. + &escape($startdate).':'. + &escape($enddate).':'. + &escape($rolelist), $tryserver))) { + my ($key,$value) = split(/\=/,$line,2); + if (($key) && ($value)) { + $personnel{$tryserver}{&unescape($key)} = &unescape($value); + } + } } return %personnel; } @@ -2027,10 +2872,12 @@ sub get_domain_roles { sub get_first_access { my ($type,$argsymb)=@_; - my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); + my ($symb,$courseid,$udom,$uname)=&whichuser(); if ($argsymb) { $symb=$argsymb; } my ($map,$id,$res)=&decode_symb($symb); - if ($type eq 'map') { + if ($type eq 'course') { + $res='course'; + } elsif ($type eq 'map') { $res=&symbread($map); } else { $res=$symb; @@ -2041,9 +2888,11 @@ sub get_first_access { sub set_first_access { my ($type)=@_; - my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); + my ($symb,$courseid,$udom,$uname)=&whichuser(); my ($map,$id,$res)=&decode_symb($symb); - if ($type eq 'map') { + if ($type eq 'course') { + $res='course'; + } elsif ($type eq 'map') { $res=&symbread($map); } else { $res=$symb; @@ -2108,7 +2957,7 @@ sub checkin { my $now=time; my ($ta,$tb,$lonhost)=split(/\*/,$token); $lonhost=~tr/A-Z/a-z/; - my $dtoken=$ta.'_'.$hostname{$lonhost}.'_'.$tb; + my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb; $dtoken=~s/\W/\_/g; my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)= split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost))); @@ -2235,27 +3084,27 @@ sub hash2str { sub hashref2str { my ($hashref)=@_; my $result='__HASH_REF__'; - foreach (sort(keys(%$hashref))) { - if (ref($_) eq 'ARRAY') { - $result.=&arrayref2str($_).'='; - } elsif (ref($_) eq 'HASH') { - $result.=&hashref2str($_).'='; - } elsif (ref($_)) { + foreach my $key (sort(keys(%$hashref))) { + if (ref($key) eq 'ARRAY') { + $result.=&arrayref2str($key).'='; + } elsif (ref($key) eq 'HASH') { + $result.=&hashref2str($key).'='; + } elsif (ref($key)) { $result.='='; - #print("Got a ref of ".(ref($_))." skipping."); + #print("Got a ref of ".(ref($key))." skipping."); } else { - if ($_) {$result.=&escape($_).'=';} else { last; } + if ($key) {$result.=&escape($key).'=';} else { last; } } - if(ref($hashref->{$_}) eq 'ARRAY') { - $result.=&arrayref2str($hashref->{$_}).'&'; - } elsif(ref($hashref->{$_}) eq 'HASH') { - $result.=&hashref2str($hashref->{$_}).'&'; - } elsif(ref($hashref->{$_})) { + if(ref($hashref->{$key}) eq 'ARRAY') { + $result.=&arrayref2str($hashref->{$key}).'&'; + } elsif(ref($hashref->{$key}) eq 'HASH') { + $result.=&hashref2str($hashref->{$key}).'&'; + } elsif(ref($hashref->{$key})) { $result.='&'; - #print("Got a ref of ".(ref($hashref->{$_}))." skipping."); + #print("Got a ref of ".(ref($hashref->{$key}))." skipping."); } else { - $result.=&escape($hashref->{$_}).'&'; + $result.=&escape($hashref->{$key}).'&'; } } $result=~s/\&$//; @@ -2535,8 +3384,8 @@ sub store { $$storehash{'host'}=$perlvar{'lonHostID'}; my $namevalue=''; - foreach (keys %$storehash) { - $namevalue.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; + foreach my $key (keys(%$storehash)) { + $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&'; } $namevalue=~s/\&$//; &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue); @@ -2571,8 +3420,8 @@ sub cstore { $$storehash{'host'}=$perlvar{'lonHostID'}; my $namevalue=''; - foreach (keys %$storehash) { - $namevalue.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; + foreach my $key (keys(%$storehash)) { + $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&'; } $namevalue=~s/\&$//; &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue); @@ -2604,14 +3453,14 @@ sub restore { my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home"); my %returnhash=(); - foreach (split(/\&/,$answer)) { - my ($name,$value)=split(/\=/,$_); + foreach my $line (split(/\&/,$answer)) { + my ($name,$value)=split(/\=/,$line); $returnhash{&unescape($name)}=&thaw_unescape($value); } my $version; for ($version=1;$version<=$returnhash{'version'};$version++) { - foreach (split(/\:/,$returnhash{$version.':keys'})) { - $returnhash{$_}=$returnhash{$version.':'.$_}; + foreach my $item (split(/\:/,$returnhash{$version.':keys'})) { + $returnhash{$item}=$returnhash{$version.':'.$item}; } } return %returnhash; @@ -2651,6 +3500,7 @@ sub coursedescription { 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'})) { @@ -2672,7 +3522,7 @@ sub coursedescription { } } if (!$args->{'one_time'}) { - &appenv(%envhash); + &appenv(\%envhash); } return %returnhash; } @@ -2686,9 +3536,9 @@ sub privileged { if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return 0; } my $now=time; if ($rolesdump ne '') { - foreach (split(/&/,$rolesdump)) { - if ($_!~/^rolesdef_/) { - my ($area,$role)=split(/=/,$_); + foreach my $entry (split(/&/,$rolesdump)) { + if ($entry!~/^rolesdef_/) { + my ($area,$role)=split(/=/,$entry); $area=~s/\_\w\w$//; my ($trole,$tend,$tstart)=split(/_/,$role); if (($trole eq 'dc') || ($trole eq 'su')) { @@ -2720,14 +3570,14 @@ sub rolesinit { my $group_privs; if ($rolesdump ne '') { - foreach (split(/&/,$rolesdump)) { - if ($_!~/^rolesdef_/) { - my ($area,$role)=split(/=/,$_); + foreach my $entry (split(/&/,$rolesdump)) { + if ($entry!~/^rolesdef_/) { + my ($area,$role)=split(/=/,$entry); $area=~s/\_\w\w$//; my ($trole,$tend,$tstart,$group_privs); if ($role=~/^cr/) { - if ($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|) { - ($trole,my $trest)=($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|); + if ($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|) { + ($trole,my $trest)=($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|); ($tend,$tstart)=split('_',$trest); } else { $trole=$role; @@ -2776,7 +3626,7 @@ sub custom_roleprivs { my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_; my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole); my $homsvr=homeserver($rauthor,$rdomain); - if ($hostname{$homsvr} ne '') { + if (&hostname($homsvr) ne '') { my ($rdummy,$roledef)= &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor); if (($rdummy ne 'con_lost') && ($roledef ne '')) { @@ -2806,7 +3656,7 @@ sub group_roleprivs { if (($tend!=0) && ($tend<$now)) { $access = 0; } if (($tstart!=0) && ($tstart>$now)) { $access=0; } if ($access) { - my ($course,$group) = ($area =~ m|(/\w+/\w+)/([^/]+)$|); + my ($course,$group) = ($area =~ m|(/$match_domain/$match_courseid)/([^/]+)$|); $$allgroups{$course}{$group} .=':'.$group_privs; } } @@ -2837,7 +3687,7 @@ sub set_userprivs { if (keys(%{$allgroups}) > 0) { foreach my $role (keys %{$allroles}) { my ($trole,$area,$sec,$extendedarea); - if ($role =~ m|^(\w+)\.(/\w+/\w+)(/?\w*)|) { + if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) { $trole = $1; $area = $2; $sec = $3; @@ -2852,15 +3702,15 @@ sub set_userprivs { } } } - foreach (keys(%grouproles)) { - $$allroles{$_} = $grouproles{$_}; + foreach my $group (keys(%grouproles)) { + $$allroles{$group} = $grouproles{$group}; } - foreach (keys %{$allroles}) { - my %thesepriv=(); - if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; } - foreach (split(/:/,$$allroles{$_})) { - if ($_ ne '') { - my ($privilege,$restrictions)=split(/&/,$_); + foreach my $role (keys(%{$allroles})) { + my %thesepriv; + if (($role=~/^au/) || ($role=~/^ca/) || ($role=~/^aa/)) { $author=1; } + foreach my $item (split(/:/,$$allroles{$role})) { + if ($item ne '') { + my ($privilege,$restrictions)=split(/&/,$item); if ($restrictions eq '') { $thesepriv{$privilege}='F'; } elsif ($thesepriv{$privilege} ne 'F') { @@ -2870,8 +3720,10 @@ sub set_userprivs { } } my $thesestr=''; - foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } - $userroles->{'user.priv.'.$_} = $thesestr; + foreach my $priv (keys(%thesepriv)) { + $thesestr.=':'.$priv.'&'.$thesepriv{$priv}; + } + $userroles->{'user.priv.'.$role} = $thesestr; } return ($author,$adv); } @@ -2881,8 +3733,8 @@ sub set_userprivs { sub get { my ($namespace,$storearr,$udomain,$uname)=@_; my $items=''; - foreach (@$storearr) { - $items.=escape($_).'&'; + foreach my $item (@$storearr) { + $items.=&escape($item).'&'; } $items=~s/\&$//; if (!$udomain) { $udomain=$env{'user.domain'}; } @@ -2896,8 +3748,8 @@ sub get { } my %returnhash=(); my $i=0; - foreach (@$storearr) { - $returnhash{$_}=&thaw_unescape($pairs[$i]); + foreach my $item (@$storearr) { + $returnhash{$item}=&thaw_unescape($pairs[$i]); $i++; } return %returnhash; @@ -2908,8 +3760,8 @@ sub get { sub del { my ($namespace,$storearr,$udomain,$uname)=@_; my $items=''; - foreach (@$storearr) { - $items.=escape($_).'&'; + foreach my $item (@$storearr) { + $items.=&escape($item).'&'; } $items=~s/\&$//; if (!$udomain) { $udomain=$env{'user.domain'}; } @@ -2922,6 +3774,30 @@ sub del { # -------------------------------------------------------------- dump interface sub dump { + 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)=@_; if (!$udomain) { $udomain=$env{'user.domain'}; } if (!$uname) { $uname=$env{'user.name'}; } @@ -2931,23 +3807,17 @@ sub dump { } else { $regexp='.'; } - my $rep=reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome); + my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome); my @pairs=split(/\&/,$rep); my %returnhash=(); - foreach (@pairs) { - my ($key,$value)=split(/=/,$_,2); - $returnhash{unescape($key)}=&thaw_unescape($value); + foreach my $item (@pairs) { + my ($key,$value)=split(/=/,$item,2); + 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 { @@ -2957,8 +3827,9 @@ sub getkeys { my $uhome=&homeserver($uname,$udomain); my $rep=reply("keys:$udomain:$uname:$namespace",$uhome); my @keyarray=(); - foreach (split(/\&/,$rep)) { - push (@keyarray,&unescape($_)); + foreach my $key (split(/\&/,$rep)) { + next if ($key =~ /^error: 2 /); + push(@keyarray,&unescape($key)); } return @keyarray; } @@ -2978,15 +3849,15 @@ sub currentdump { if ($rep eq "unknown_cmd") { # an old lond will not know currentdump # Do a dump and make it look like a currentdump - my @tmp = &dump($courseid,$sdom,$sname,'.'); + my @tmp = &dumpstore($courseid,$sdom,$sname,'.'); return if ($tmp[0] =~ /^(error:|no_such_host)/); my %hash = @tmp; @tmp=(); %returnhash = %{&convert_dump_to_currentdump(\%hash)}; } else { my @pairs=split(/\&/,$rep); - foreach (@pairs) { - my ($key,$value)=split(/=/,$_); + foreach my $pair (@pairs) { + my ($key,$value)=split(/=/,$pair,2); my ($symb,$param) = split(/:/,$key); $returnhash{&unescape($symb)}->{&unescape($param)} = &thaw_unescape($value); @@ -3003,6 +3874,8 @@ sub convert_dump_to_currentdump{ # we might run in to problems with parameter names =~ /^v\./ while (my ($key,$value) = each(%hash)) { my ($v,$symb,$param) = split(/:/,$key); + $symb = &unescape($symb); + $param = &unescape($param); next if ($v eq 'version' || $symb eq 'keys'); next if (exists($returnhash{$symb}) && exists($returnhash{$symb}->{$param}) && @@ -3064,8 +3937,8 @@ sub put { if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); my $items=''; - foreach (keys %$storehash) { - $items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; + foreach my $item (keys(%$storehash)) { + $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; } $items=~s/\&$//; return &reply("put:$udomain:$uname:$namespace:$items",$uhome); @@ -3117,22 +3990,22 @@ sub old_putstore { if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); my %newstorehash; - foreach (keys %$storehash) { - my $key = $version.':'.&escape($symb).':'.$_; - $newstorehash{$key} = $storehash->{$_}; + foreach my $item (keys(%$storehash)) { + my $key = $version.':'.&escape($symb).':'.$item; + $newstorehash{$key} = $storehash->{$item}; } my $items=''; my %allitems = (); - foreach (keys %newstorehash) { - if ($_ =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) { + foreach my $item (keys(%newstorehash)) { + if ($item =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) { my $key = $1.':keys:'.$2; $allitems{$key} .= $3.':'; } - $items.=$_.'='.&freeze_escape($newstorehash{$_}).'&'; + $items.=$item.'='.&freeze_escape($newstorehash{$item}).'&'; } - foreach (keys %allitems) { - $allitems{$_} =~ s/\:$//; - $items.= $_.'='.$allitems{$_}.'&'; + foreach my $item (keys(%allitems)) { + $allitems{$item} =~ s/\:$//; + $items.= $item.'='.$allitems{$item}.'&'; } $items=~s/\&$//; return &reply("put:$udomain:$uname:$namespace:$items",$uhome); @@ -3146,8 +4019,8 @@ sub cput { if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); my $items=''; - foreach (keys %$storehash) { - $items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; + foreach my $item (keys(%$storehash)) { + $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; } $items=~s/\&$//; return &critical("put:$udomain:$uname:$namespace:$items",$uhome); @@ -3158,8 +4031,8 @@ sub cput { sub eget { my ($namespace,$storearr,$udomain,$uname)=@_; my $items=''; - foreach (@$storearr) { - $items.=escape($_).'&'; + foreach my $item (@$storearr) { + $items.=&escape($item).'&'; } $items=~s/\&$//; if (!$udomain) { $udomain=$env{'user.domain'}; } @@ -3169,8 +4042,8 @@ sub eget { my @pairs=split(/\&/,$rep); my %returnhash=(); my $i=0; - foreach (@$storearr) { - $returnhash{$_}=&thaw_unescape($pairs[$i]); + foreach my $item (@$storearr) { + $returnhash{$item}=&thaw_unescape($pairs[$i]); $i++; } return %returnhash; @@ -3178,12 +4051,15 @@ sub eget { # ------------------------------------------------------------ tmpput interface sub tmpput { - my ($storehash,$server)=@_; + my ($storehash,$server,$context)=@_; my $items=''; - foreach (keys(%$storehash)) { - $items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; + foreach my $item (keys(%$storehash)) { + $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; } $items=~s/\&$//; + if (defined($context)) { + $items .= ':'.&escape($context); + } return &reply("tmpput:$items",$server); } @@ -3195,6 +4071,7 @@ sub tmpget { my %returnhash; foreach my $item (split(/\&/,$rep)) { my ($key,$value)=split(/=/,$item); + next if ($key =~ /^error: 2 /); $returnhash{&unescape($key)}=&thaw_unescape($value); } return %returnhash; @@ -3207,35 +4084,294 @@ sub tmpdel { return &reply("tmpdel:$token",$server); } -# ---------------------------------------------- Custom access rule evaluation +# -------------------------------------------------- portfolio access checking -sub customaccess { - my ($priv,$uri)=@_; - my ($urole,$urealm)=split(/\./,$env{'request.role'}); - $urealm=~s/^\W//; - my ($udom,$ucrs,$usec)=split(/\//,$urealm); - my $access=0; - foreach (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) { - my ($effect,$realm,$role)=split(/\:/,$_); - if ($role) { - if ($role ne $urole) { next; } - } - foreach (split(/\s*\,\s*/,$realm)) { - my ($tdom,$tcrs,$tsec)=split(/\_/,$_); - if ($tdom) { - if ($tdom ne $udom) { next; } +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) { + my %setters; + if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') { + my ($startblock,$endblock) = + &Apache::loncommon::blockcheck(\%setters,'port',$unum,$udom); + if ($startblock && $endblock) { + return 'B'; } - if ($tcrs) { - if ($tcrs ne $ucrs) { next; } + } else { + my ($startblock,$endblock) = + &Apache::loncommon::blockcheck(\%setters,'port'); + if ($startblock && $endblock) { + return 'B'; } - if ($tsec) { - if ($tsec ne $usec) { next; } + } + } + 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; } - $access=($effect eq 'allow'); - last; + 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 (ref($access_hash->{$userkey}{'users'}) eq 'ARRAY') { + foreach my $item (@{$access_hash->{$userkey}{'users'}}) { + if (ref($item) eq 'HASH') { + if (($item->{'uname'} eq $env{'user.name'}) && + ($item->{'udom'} eq $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)\./($match_domain)/($match_courseid)/?([^/]*)$-) { + 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/($match_domain/$match_username/\w*)./($match_domain)/($match_courseid)/?([^/]*)$-) { + 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 ($realm eq '' && $role eq '') { - $access=($effect eq 'allow'); + } + 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|editupload)/($match_domain)/($match_username)/portfolio(/.+)$-) { + $type = 1; + $udom = $1; + $unum = $2; + $file_name = $3; + } elsif ($url =~ m-^/*(?:uploaded|editupload)/($match_domain)/($match_courseid)/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)); +} + +sub is_portfolio_file { + my ($file) = @_; + if (($file =~ /^portfolio/) || ($file =~ /^groups\/\w+\/portfolio/)) { + return 1; + } + return; +} + + +# ---------------------------------------------- Custom access rule evaluation + +sub customaccess { + my ($priv,$uri)=@_; + my ($urole,$urealm)=split(/\./,$env{'request.role'},2); + my (undef,$udom,$ucrs,$usec)=split(/\//,$urealm); + $udom = &LONCAPA::clean_domain($udom); + $ucrs = &LONCAPA::clean_username($ucrs); + my $access=0; + foreach my $right (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) { + my ($effect,$realm,$role,$type)=split(/\:/,$right); + if ($type eq 'user') { + foreach my $scope (split(/\s*\,\s*/,$realm)) { + my ($tdom,$tuname)=split(m{/},$scope); + if ($tdom) { + if ($tdom ne $env{'user.domain'}) { next; } + } + if ($tuname) { + if ($tuname ne $env{'user.name'}) { next; } + } + $access=($effect eq 'allow'); + last; + } + } else { + if ($role) { + if ($role ne $urole) { next; } + } + foreach my $scope (split(/\s*\,\s*/,$realm)) { + my ($tdom,$tcrs,$tsec)=split(/\_/,$scope); + if ($tdom) { + if ($tdom ne $udom) { next; } + } + if ($tcrs) { + if ($tcrs ne $ucrs) { next; } + } + if ($tsec) { + if ($tsec ne $usec) { next; } + } + $access=($effect eq 'allow'); + last; + } + if ($realm eq '' && $role eq '') { + $access=($effect eq 'allow'); + } } } return $access; @@ -3244,16 +4380,26 @@ sub customaccess { # ------------------------------------------------- Check for a user privilege sub allowed { - my ($priv,$uri,$symb)=@_; + my ($priv,$uri,$symb,$role)=@_; my $ver_orguri=$uri; $uri=&deversion($uri); my $orguri=$uri; $uri=&declutter($uri); - + + if ($priv eq 'evb') { +# Evade communication block restrictions for specified role in a course + if ($env{'user.priv.'.$role} =~/evb\&([^\:]*)/) { + return $1; + } else { + return; + } + } + 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'; } @@ -3261,10 +4407,17 @@ sub allowed { 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'; + my %setters; + my ($startblock,$endblock) = + &Apache::loncommon::blockcheck(\%setters,'port'); + if ($startblock && $endblock) { + return 'B'; + } else { + return 'F'; + } } -# bre access to group if user has rgf priv for this group and course. +# 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'})) { @@ -3276,6 +4429,14 @@ sub allowed { 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; + } } } } @@ -3344,14 +4505,6 @@ sub allowed { $thisallowed.=$1; } -# Group: uri itself is a group - my $groupuri=$uri; - $groupuri=~s/^([^\/])/\/$1/; - if ($env{'user.priv.'.$env{'request.role'}.'.'.$groupuri} - =~/\Q$priv\E\&([^\:]*)/) { - $thisallowed.=$1; - } - # 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/|)) { @@ -3378,8 +4531,14 @@ sub allowed { } } + 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/) { return 'F'; } @@ -3425,14 +4584,14 @@ sub allowed { if ($checkreferer) { my $refuri=$env{'httpref.'.$orguri}; unless ($refuri) { - foreach (keys %env) { - if ($_=~/^httpref\..*\*/) { - my $pattern=$_; + foreach my $key (keys(%env)) { + if ($key=~/^httpref\..*\*/) { + my $pattern=$key; $pattern=~s/^httpref\.\/res\///; $pattern=~s/\*/\[\^\/\]\+/g; $pattern=~s/\//\\\//g; if ($orguri=~/$pattern/) { - $refuri=$env{$_}; + $refuri=$env{$key}; } } } @@ -3528,7 +4687,13 @@ sub allowed { # unless ($env{'request.course.id'}) { - return '1'; + if ($thisallowed eq 'A') { + return 'A'; + } elsif ($thisallowed eq 'B') { + return 'B'; + } else { + return '1'; + } } # @@ -3591,6 +4756,11 @@ sub allowed { } } + if ($thisallowed eq 'A') { + return 'A'; + } elsif ($thisallowed eq 'B') { + return 'B'; + } return 'F'; } @@ -3643,8 +4813,8 @@ sub get_symb_from_alias { sub definerole { if (allowed('mcr','/')) { my ($rolename,$sysrole,$domrole,$courole)=@_; - foreach (split(':',$sysrole)) { - my ($crole,$cqual)=split(/\&/,$_); + foreach my $role (split(':',$sysrole)) { + my ($crole,$cqual)=split(/\&/,$role); if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; } if ($pr{'cr:s'}=~/\Q$crole\E\&/) { if ($pr{'cr:s'}!~/\Q$crole\E\&\w*\Q$cqual\E/) { @@ -3652,8 +4822,8 @@ sub definerole { } } } - foreach (split(':',$domrole)) { - my ($crole,$cqual)=split(/\&/,$_); + foreach my $role (split(':',$domrole)) { + my ($crole,$cqual)=split(/\&/,$role); if ($pr{'cr:d'}!~/\Q$crole\E/) { return "refused:d:$crole"; } if ($pr{'cr:d'}=~/\Q$crole\E\&/) { if ($pr{'cr:d'}!~/\Q$crole\W\&\w*\Q$cqual\E/) { @@ -3661,8 +4831,8 @@ sub definerole { } } } - foreach (split(':',$courole)) { - my ($crole,$cqual)=split(/\&/,$_); + foreach my $role (split(':',$courole)) { + my ($crole,$cqual)=split(/\&/,$role); if ($pr{'cr:c'}!~/\Q$crole\E/) { return "refused:c:$crole"; } if ($pr{'cr:c'}=~/\Q$crole\E\&/) { if ($pr{'cr:c'}!~/\Q$crole\E\&\w*\Q$cqual\E/) { @@ -3685,6 +4855,7 @@ sub definerole { sub metadata_query { my ($query,$custom,$customshow,$server_array)=@_; my %rhash; + my %libserv = &all_library(); my @server_list = (defined($server_array) ? @$server_array : keys(%libserv) ); for my $server (@server_list) { @@ -3708,14 +4879,43 @@ sub log_query { my ($uname,$udom,$query,%filters)=@_; my $uhome=&homeserver($uname,$udom); if ($uhome eq 'no_host') { return 'error: no_host'; } - my $uhost=$hostname{$uhome}; - my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys %filters)); + my $uhost=&hostname($uhome); + my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys(%filters))); my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command, $uhome); unless ($queryid=~/^\Q$uhost\E\_/) { return 'error: '.$queryid; } return get_query_reply($queryid); } +# -------------------------- Update MySQL table for portfolio file + +sub update_portfolio_table { + my ($uname,$udom,$file_name,$query,$group,$action) = @_; + my $homeserver = &homeserver($uname,$udom); + my $queryid= + &reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group). + ':'.&escape($file_name).':'.$action,$homeserver); + my $reply = &get_query_reply($queryid); + return $reply; +} + +# -------------------------- Update MySQL allusers table + +sub update_allusers_table { + my ($uname,$udom,$names) = @_; + my $homeserver = &homeserver($uname,$udom); + my $queryid= + &reply('querysend:allusers:'.&escape($uname).':'.&escape($udom).':'. + 'lastname='.&escape($names->{'lastname'}).'%%'. + 'firstname='.&escape($names->{'firstname'}).'%%'. + 'middlename='.&escape($names->{'middlename'}).'%%'. + 'generation='.&escape($names->{'generation'}).'%%'. + 'permanentemail='.&escape($names->{'permanentemail'}).'%%'. + 'id='.&escape($names->{'id'}),$homeserver); + my $reply = &get_query_reply($queryid); + return $reply; +} + # ------- Request retrieval of institutional classlists for course(s) sub fetch_enrollment_query { @@ -3728,10 +4928,10 @@ sub fetch_enrollment_query { } else { $homeserver = &homeserver($cnum,$dom); } - my $host=$hostname{$homeserver}; + my $host=&hostname($homeserver); my $cmd = ''; - foreach (keys %{$affiliatesref}) { - $cmd .= $_.'='.join(",",@{$$affiliatesref{$_}}).'%%'; + foreach my $affiliate (keys %{$affiliatesref}) { + $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%'; } $cmd =~ s/%%$//; $cmd = &escape($cmd); @@ -3750,20 +4950,20 @@ sub fetch_enrollment_query { if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries); } else { - my @responses = split/:/,$reply; + my @responses = split(/:/,$reply); if ($homeserver eq $perlvar{'lonHostID'}) { - foreach (@responses) { - my ($key,$value) = split/=/,$_; + foreach my $line (@responses) { + my ($key,$value) = split(/=/,$line,2); $$replyref{$key} = $value; } } else { my $pathname = $perlvar{'lonDaemons'}.'/tmp'; - foreach (@responses) { - my ($key,$value) = split/=/,$_; + foreach my $line (@responses) { + my ($key,$value) = split(/=/,$line); $$replyref{$key} = $value; if ($value > 0) { - foreach (@{$$affiliatesref{$key}}) { - my $filename = $dom.'_'.$key.'_'.$_.'_classlist.xml'; + foreach my $item (@{$$affiliatesref{$key}}) { + my $filename = $dom.'_'.$key.'_'.$item.'_classlist.xml'; my $destname = $pathname.'/'.$filename; my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver); if ($xml_classlist =~ /^error/) { @@ -3793,8 +4993,8 @@ sub get_query_reply { sleep 2; if (-e $replyfile.'.end') { if (open(my $fh,$replyfile)) { - $reply.=<$fh>; - close($fh); + $reply = join('',<$fh>); + close($fh); } else { return 'error: reply_file_error'; } return &unescape($reply); } @@ -3825,6 +5025,12 @@ sub courselog_query { } sub userlog_query { +# +# possible filters: +# action: log check role +# start: timestamp +# end: timestamp +# my ($uname,$udom,%filters)=@_; return &log_query($uname,$udom,'userlog',%filters); } @@ -3833,46 +5039,75 @@ sub userlog_query { sub auto_run { my ($cnum,$cdom) = @_; - my $homeserver = &homeserver($cnum,$cdom); - my $response = &reply('autorun:'.$cdom,$homeserver); + my $response = 0; + my $settings; + my %domconfig = &get_dom('configuration',['autoenroll'],$cdom); + if (ref($domconfig{'autoenroll'}) eq 'HASH') { + $settings = $domconfig{'autoenroll'}; + if ($settings->{'run'} eq '1') { + $response = 1; + } + } else { + my $homeserver; + if (&is_course($cdom,$cnum)) { + $homeserver = &homeserver($cnum,$cdom); + } else { + $homeserver = &domain($cdom,'primary'); + } + if ($homeserver ne 'no_host') { + $response = &reply('autorun:'.$cdom,$homeserver); + } + } return $response; } - + sub auto_get_sections { my ($cnum,$cdom,$inst_coursecode) = @_; my $homeserver = &homeserver($cnum,$cdom); my @secs = (); my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver)); unless ($response eq 'refused') { - @secs = split/:/,$response; + @secs = split(/:/,$response); } return @secs; } - + sub auto_new_course { my ($cnum,$cdom,$inst_course_id,$owner) = @_; my $homeserver = &homeserver($cnum,$cdom); my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver)); return $response; } - + sub auto_validate_courseID { my ($cnum,$cdom,$inst_course_id) = @_; my $homeserver = &homeserver($cnum,$cdom); my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver)); return $response; } - + sub auto_create_password { - my ($cnum,$cdom,$authparam) = @_; - my $homeserver = &homeserver($cnum,$cdom); + my ($cnum,$cdom,$authparam,$udom) = @_; + my ($homeserver,$response); my $create_passwd = 0; my $authchk = ''; - my $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver)); - if ($response eq 'refused') { - $authchk = 'refused'; + if ($udom =~ /^$match_domain$/) { + $homeserver = &domain($udom,'primary'); + } + if ($homeserver eq '') { + if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) { + $homeserver = &homeserver($cnum,$cdom); + } + } + if ($homeserver eq '') { + $authchk = 'nodomain'; } else { - ($authparam,$create_passwd,$authchk) = split/:/,$response; + $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver)); + if ($response eq 'refused') { + $authchk = 'refused'; + } else { + ($authparam,$create_passwd,$authchk) = split(/:/,$response); + } } return ($authparam,$create_passwd,$authchk); } @@ -3919,11 +5154,11 @@ sub auto_photochoice { sub auto_photoupdate { my ($affiliatesref,$dom,$cnum,$photo) = @_; my $homeserver = &homeserver($cnum,$dom); - my $host=$hostname{$homeserver}; + my $host=&hostname($homeserver); my $cmd = ''; my $maxtries = 1; - foreach (keys %{$affiliatesref}) { - $cmd .= $_.'='.join(",",@{$$affiliatesref{$_}}).'%%'; + foreach my $affiliate (keys(%{$affiliatesref})) { + $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%'; } $cmd =~ s/%%$//; $cmd = &escape($cmd); @@ -3954,43 +5189,95 @@ sub auto_photoupdate { } sub auto_instcode_format { - my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_; + 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 (($env{'user.name'}) && ($env{'user.domain'} eq $codedom)) { - $homeserver = &homeserver($env{'user.name'},$codedom); + my %servers = &get_servers($codedom,'library'); + foreach my $tryserver (keys(%servers)) { + if (!grep(/^\Q$tryserver\E$/,@homeservers)) { + push(@homeservers,$tryserver); + } } } else { - $homeserver = &homeserver($caller,$codedom); + push(@homeservers,&homeserver($caller,$codedom)); } - foreach (keys %{$instcodes}) { - $courses .= &escape($_).'='.&escape($$instcodes{$_}).'&'; + foreach my $code (keys(%{$instcodes})) { + $courses .= &escape($code).'='.&escape($$instcodes{$code}).'&'; } 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_instcode_defaults { + my ($domain,$returnhash,$code_order) = @_; + my @homeservers; + + my %servers = &get_servers($domain,'library'); + foreach my $tryserver (keys(%servers)) { + if (!grep(/^\Q$tryserver\E$/,@homeservers)) { + push(@homeservers,$tryserver); + } + } + + my $response; + foreach my $server (@homeservers) { + $response=&reply('autoinstcodedefaults:'.$domain,$server); + next if ($response =~ /(con_lost|error|no_such_host|refused)/); + + foreach my $pair (split(/\&/,$response)) { + my ($name,$value)=split(/\=/,$pair); + if ($name eq 'code_order') { + @{$code_order} = split(/\&/,&unescape($value)); + } else { + $returnhash->{&unescape($name)}=&unescape($value); + } + } + return 'ok'; } + + return $response; +} + +sub auto_validate_class_sec { + my ($cdom,$cnum,$owners,$inst_class) = @_; + my $homeserver = &homeserver($cnum,$cdom); + my $ownerlist; + if (ref($owners) eq 'ARRAY') { + $ownerlist = join(',',@{$owners}); + } else { + $ownerlist = $owners; + } + my $response=&reply('autovalidateclass_sec:'.$inst_class.':'. + &escape($ownerlist).':'.$cdom,$homeserver); return $response; } # ------------------------------------------------------- Course Group routines sub get_coursegroups { - my ($cdom,$cnum,$group) = @_; - return(&dump('coursegroups',$cdom,$cnum,$group)); + my ($cdom,$cnum,$group,$namespace) = @_; + return(&dump($namespace,$cdom,$cnum,$group)); } sub modify_coursegroup { @@ -3998,12 +5285,43 @@ sub modify_coursegroup { return(&put('coursegroups',$groupsettings,$cdom,$cnum)); } +sub toggle_coursegroup_status { + my ($cdom,$cnum,$group,$action) = @_; + my ($from_namespace,$to_namespace); + if ($action eq 'delete') { + $from_namespace = 'coursegroups'; + $to_namespace = 'deleted_groups'; + } else { + $from_namespace = 'deleted_groups'; + $to_namespace = 'coursegroups'; + } + my %curr_group = &get_coursegroups($cdom,$cnum,$group,$from_namespace); + if (my $tmp = &error(%curr_group)) { + &Apache::lonnet::logthis('Error retrieving group: '.$tmp.' in '.$cnum.':'.$cdom); + return ('read error',$tmp); + } else { + my %savedsettings = %curr_group; + my $result = &put($to_namespace,\%savedsettings,$cdom,$cnum); + my $deloutcome; + if ($result eq 'ok') { + $deloutcome = &del($from_namespace,[$group],$cdom,$cnum); + } else { + return ('write error',$result); + } + if ($deloutcome eq 'ok') { + return 'ok'; + } else { + return ('delete error',$deloutcome); + } + } +} + sub modify_group_roles { - my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs) = @_; + my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs,$selfenroll,$context) = @_; 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); + my $result = &assignrole($udom,$uname,$url,$role,$end,$start,'',$selfenroll,$context); if ($result eq 'ok') { &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum); } @@ -4021,7 +5339,7 @@ sub get_active_groups { my $now = time; my %groups = (); foreach my $key (keys(%env)) { - if ($key =~ m-user\.role\.gr\./([^/]+)/([^/]+)/(\w+)$-) { + if ($key =~ m-user\.role\.gr\./($match_domain)/($match_courseid)/(\w+)$-) { my ($start,$end) = split(/\./,$env{$key}); if (($end!=0) && ($end<$now)) { next; } if (($start!=0) && ($start>$now)) { next; } @@ -4042,8 +5360,6 @@ 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); @@ -4051,38 +5367,34 @@ sub get_users_groups { @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); - } + my $courseurl = &courseid_to_courseurl($courseid); + my %roleshash = &dump('roles',$udom,$uname,$courseurl); + my $access_end = $env{'course.'.$courseid. + '.default_enrollment_end_date'}; + my $now = time; + foreach my $key (keys(%roleshash)) { + if ($key =~ /^\Q$courseurl\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); + next; } + push(@usersgroups,$group); } } - @usersgroups = &sort_course_groups($courseid,@usersgroups); - $grouplist = join(':',@usersgroups); - &do_cache_new('getgroups',$hashid,$grouplist,$cachetime); } + @usersgroups = &sort_course_groups($courseid,@usersgroups); + $grouplist = join(':',@usersgroups); + &do_cache_new('getgroups',$hashid,$grouplist,$cachetime); } return @usersgroups; } @@ -4090,8 +5402,7 @@ sub get_users_groups { 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); } @@ -4100,6 +5411,9 @@ sub devalidate_getgroups_cache { sub plaintext { my ($short,$type,$cid) = @_; + if ($short =~ /^cr/) { + return (split('/',$short))[-1]; + } if (!defined($cid)) { $cid = $env{'request.course.id'}; } @@ -4123,11 +5437,12 @@ sub plaintext { # ----------------------------------------------------------------- Assign Role sub assignrole { - my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_; + my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll, + $context)=@_; my $mrole; if ($role =~ /^cr\//) { my $cwosec=$url; - $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/; + $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/; unless (&allowed('ccr',$cwosec)) { &logthis('Refused custom assignrole: '. $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. @@ -4137,7 +5452,7 @@ sub assignrole { $mrole='cr'; } elsif ($role =~ /^gr\//) { my $cwogrp=$url; - $cwogrp=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/; + $cwogrp=~s{^/($match_domain)/($match_courseid)/.*}{$1/$2}; unless (&allowed('mdg',$cwogrp)) { &logthis('Refused group assignrole: '. $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. @@ -4147,12 +5462,26 @@ sub assignrole { $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'}); - return 'refused'; + $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/; + if (!(&allowed('c'.$role,$cwosec)) && !(&allowed('c'.$role,$udom))) { + my $refused; + if (($env{'request.course.sec'} ne '') && ($role eq 'st')) { + if (!(&allowed('c'.$role,$url))) { + $refused = 1; + } + } else { + $refused = 1; + } + if ($refused) { + if (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { + $refused = ''; + } else { + &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url. + ' '.$role.' '.$end.' '.$start.' by '. + $env{'user.name'}.' at '.$env{'user.domain'}); + return 'refused'; + } + } } $mrole=$role; } @@ -4168,6 +5497,7 @@ sub assignrole { } my $origstart = $start; my $origend = $end; + my $delflag; # actually delete if ($deleteflag) { if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) { @@ -4178,6 +5508,7 @@ sub assignrole { # set start and finish to negative values for userrolelog $start=-1; $end=-1; + $delflag = 1; } } # send command @@ -4186,9 +5517,10 @@ sub assignrole { if ($answer eq 'ok') { &userrolelog($role,$uname,$udom,$url,$start,$end); # for course roles, perform group memberships changes triggered by role change. + &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,$selfenroll,$context); unless ($role =~ /^gr/) { &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend, - $origstart); + $origstart,$selfenroll,$context); } } return $answer; @@ -4226,9 +5558,9 @@ sub modifyuser { my ($udom, $uname, $uid, $umode, $upass, $first, $middle, $last, $gene, - $forceid, $desiredhome, $email)=@_; - $udom=~s/\W//g; - $uname=~s/\W//g; + $forceid, $desiredhome, $email, $inststatus)=@_; + $udom= &LONCAPA::clean_domain($udom); + $uname=&LONCAPA::clean_username($uname); &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. $umode.', '.$first.', '.$middle.', '. $last.', '.$gene.'(forceid: '.$forceid.')'. @@ -4241,21 +5573,19 @@ sub modifyuser { if (($uhome eq 'no_host') && (($umode && $upass) || ($umode eq 'localauth'))) { my $unhome=''; - if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) { + if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) { $unhome = $desiredhome; } elsif($env{'course.'.$env{'request.course.id'}.'.domain'} eq $udom) { $unhome=$env{'course.'.$env{'request.course.id'}.'.home'}; } else { # load balancing routine for determining $unhome - my $tryserver; my $loadm=10000000; - foreach $tryserver (keys %libserv) { - if ($hostdom{$tryserver} eq $udom) { - my $answer=reply('load',$tryserver); - if (($answer=~/\d+/) && ($answer<$loadm)) { - $loadm=$answer; - $unhome=$tryserver; - } - } + my %servers = &get_servers($udom,'library'); + foreach my $tryserver (keys(%servers)) { + my $answer=reply('load',$tryserver); + if (($answer=~/\d+/) && ($answer<$loadm)) { + $loadm=$answer; + $unhome=$tryserver; + } } } if (($unhome eq '') || ($unhome eq 'no_host')) { @@ -4288,7 +5618,8 @@ sub modifyuser { } # -------------------------------------------------------------- Add names, etc my @tmp=&get('environment', - ['firstname','middlename','lastname','generation'], + ['firstname','middlename','lastname','generation','id', + 'permanentemail','inststatus'], $udom,$uname); my %names; if ($tmp[0] =~ m/^error:.*/) { @@ -4306,17 +5637,23 @@ sub modifyuser { if (defined($gene)) { $names{'generation'} = $gene; } if ($email) { $email=~s/[^\w\@\.\-\,]//gs; - if ($email=~/\@/) { $names{'notification'} = $email; - $names{'critnotification'} = $email; - $names{'permanentemail'} = $email; } + if ($email=~/\@/) { $names{'permanentemail'} = $email; } } + if ($uid) { $names{'id'} = $uid; } + if (defined($inststatus)) { $names{'inststatus'} = $inststatus; } my $reply = &put('environment', \%names, $udom,$uname); if ($reply ne 'ok') { return 'error: '.$reply; } + my $sqlresult = &update_allusers_table($uname,$udom,\%names); &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'}); + my $logmsg = 'Success modifying user '.$udom.', '.$uname.', '.$uid.', '. + $umode.', '.$first.', '.$middle.', '. + $last.', '.$gene.', '.$email.', '.$inststatus; + if ($env{'user.name'} ne '' && $env{'user.domain'}) { + $logmsg .= ' by '.$env{'user.name'}.' at '.$env{'user.domain'}; + } else { + $logmsg .= ' during self creation'; + } + &logthis($logmsg); return 'ok'; } @@ -4324,7 +5661,8 @@ sub modifyuser { sub modifystudent { my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, - $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid)=@_; + $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid, + $selfenroll,$context)=@_; if (!$cid) { unless ($cid=$env{'request.course.id'}) { return 'not_in_class'; @@ -4339,12 +5677,12 @@ sub modifystudent { # students environment $uid = undef if (!$forceid); $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last, - $gene,$usec,$end,$start,$type,$locktype,$cid); + $gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll,$context); return $reply; } sub modify_student_enrollment { - my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid) = @_; + my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll,$context) = @_; my ($cdom,$cnum,$chome); if (!$cid) { unless ($cid=$env{'request.course.id'}) { @@ -4377,8 +5715,8 @@ sub modify_student_enrollment { ['firstname','middlename','lastname', 'generation','id'] ,$udom,$uname); - #foreach (keys(%tmp)) { - # &logthis("key $_ = ".$tmp{$_}); + #foreach my $key (keys(%tmp)) { + # &logthis("key $key = ".$tmp{$key}); #} $first = $tmp{'firstname'} if (!defined($first) || $first eq ''); $middle = $tmp{'middlename'} if (!defined($middle) || $middle eq ''); @@ -4402,7 +5740,7 @@ sub modify_student_enrollment { if ($usec) { $uurl.='/'.$usec; } - return &assignrole($udom,$uname,$uurl,'st',$end,$start); + return &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,$selfenroll,$context); } sub format_name { @@ -4436,8 +5774,8 @@ sub writecoursepref { return 'error: no such course'; } my $cstring=''; - foreach (keys %prefs) { - $cstring.=escape($_).'='.escape($prefs{$_}).'&'; + foreach my $pref (keys(%prefs)) { + $cstring.=&escape($pref).'='.&escape($prefs{$pref}).'&'; } $cstring=~s/\&$//; return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome); @@ -4470,7 +5808,7 @@ sub createcourse { } # ------------------------------------------------ Check supplied server name $course_server = $env{'user.homeserver'} if (! defined($course_server)); - if (! exists($libserv{$course_server})) { + if (! &is_library($course_server)) { return 'error:bad server name '.$course_server; } # ------------------------------------------------------------- Make the course @@ -4483,10 +5821,15 @@ sub createcourse { } # ----------------------------------------------------------------- Course made # log existence - &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description). - ':'.&escape($inst_code).':'.&escape($course_owner).':'. - &escape($crstype),$uhome); - &flushcourselogs(); + my $newcourse = { + $udom.'_'.$uname => { + description => $description, + inst_code => $inst_code, + owner => $course_owner, + type => $crstype, + }, + }; + &courseidput($udom,$newcourse,$uhome,'notime'); # set toplevel url my $topurl=$url; unless ($nonstandard) { @@ -4513,36 +5856,54 @@ ENDINITMAP return '/'.$udom.'/'.$uname; } +sub is_course { + my ($cdom,$cnum) = @_; + my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef, + undef,'.'); + if (exists($courses{$cdom.'_'.$cnum})) { + return 1; + } + return 0; +} + # ---------------------------------------------------------- Assign Custom Role sub assigncustomrole { - my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag)=@_; + my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag,$selfenroll,$context)=@_; return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename, - $end,$start,$deleteflag); + $end,$start,$deleteflag,$selfenroll,$context); } # ----------------------------------------------------------------- Revoke Role sub revokerole { - my ($udom,$uname,$url,$role,$deleteflag)=@_; + my ($udom,$uname,$url,$role,$deleteflag,$selfenroll,$context)=@_; my $now=time; - return &assignrole($udom,$uname,$url,$role,$now,$deleteflag); + return &assignrole($udom,$uname,$url,$role,$now,$deleteflag,$selfenroll,$context); } # ---------------------------------------------------------- Revoke Custom Role sub revokecustomrole { - my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag)=@_; + my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag,$selfenroll,$context)=@_; my $now=time; return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now, - $deleteflag); + $deleteflag,$selfenroll,$context); } # ------------------------------------------------------------ Disk usage sub diskusage { - my ($udom,$uname,$directoryRoot)=@_; - $directoryRoot =~ s/\/$//; - my $listing=&reply('du:'.$directoryRoot,homeserver($uname,$udom)); + my ($udom,$uname,$directorypath,$getpropath)=@_; + $directorypath =~ s/\/$//; + my $listing=&reply('du2:'.&escape($directorypath).':' + .&escape($getpropath).':'.&escape($uname).':' + .&escape($udom),homeserver($uname,$udom)); + if ($listing eq 'unknown_cmd') { + if ($getpropath) { + $directorypath = &propath($udom,$uname).'/'.$directorypath; + } + $listing = &reply('du:'.$directorypath,homeserver($uname,$udom)); + } return $listing; } @@ -4569,6 +5930,12 @@ sub is_locked { } } +sub declutter_portfile { + my ($file) = @_; + $file =~ s{^(/portfolio/|portfolio/)}{/}; + return $file; +} + # ------------------------------------------------------------- Mark as Read Only sub mark_as_readonly { @@ -4577,6 +5944,7 @@ sub mark_as_readonly { my ($tmp)=keys(%current_permissions); if ($tmp=~/^error:/) { undef(%current_permissions); } foreach my $file (@{$files}) { + $file = &declutter_portfile($file); push(@{$current_permissions{$file}},$what); } &put('file_permissions',\%current_permissions,$domain,$user); @@ -4589,7 +5957,7 @@ sub save_selected_files { my ($user, $path, @files) = @_; my $filename = $user."savedfiles"; my @other_files = &files_not_in_path($user, $path); - open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); + open (OUT, '>'.$tmpdir.$filename); foreach my $file (@files) { print (OUT $env{'form.currentpath'}.$file."\n"); } @@ -4635,20 +6003,20 @@ sub files_not_in_path { my $filename = $user."savedfiles"; my @return_files; my $path_part; - open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); - while () { + open(IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); + while (my $line = ) { #ok, I know it's clunky, but I want it to work - my @paths_and_file = split m!/!, $_; - my $file_part = pop (@paths_and_file); - chomp ($file_part); - my $path_part = join ('/', @paths_and_file); + my @paths_and_file = split(m|/|, $line); + my $file_part = pop(@paths_and_file); + chomp($file_part); + my $path_part = join('/', @paths_and_file); $path_part .= '/'; my $path_and_file = $path_part.$file_part; if ($path_part ne $path) { - push (@return_files, ($path_and_file)); + push(@return_files, ($path_and_file)); } } - close (OUT); + close(OUT); return (@return_files); } @@ -4666,11 +6034,13 @@ sub get_portfile_permissions { sub get_access_controls { my ($current_permissions,$group,$file) = @_; - my %access; + 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{$file}{$control} = $$current_permissions{$file."\0".$control}; + $access{$real_file}{$control} = $$current_permissions{$file."\0".$control}; } } } else { @@ -4693,67 +6063,6 @@ sub get_access_controls { return %access; } -sub parse_access_controls { - my ($access_item) = @_; - my %content; - my $role_id; - my $user; - my $usercount; - my $token; - my $parser=HTML::TokeParser->new(\$access_item); - while ($token=$parser->get_token) { - if ($token->[0] eq 'S') { - my $entry=$token->[1]; - if ($entry eq 'scope') { - my $type = $token->[2]{'type'}; - if (($type eq 'course') || ($type eq 'group')) { - $content{'roles'} = {}; - } - } elsif ($entry eq 'roles') { - $role_id = $token->[2]{id}; - $content{$entry}{$role_id}} = { - role => [], - access => [], - section => [], - group => [], - }; - } elsif ($entry eq 'users') { - $content{'users'} = {}; - $usercount = 0; - } elsif ($entry eq 'user') { - $user = ''; - } else { - my $value=$parser->get_text('/'.$entry); - if ($entry eq 'uname') { - $user = $value; - } elsif ($entry eq 'udom') { - $user .= ':'.$value; - $content{'users'}{$user} = $usercount; - } elsif ($entry eq 'role' || - $entry eq 'access' || - $entry eq 'section' || - $entry eq 'group') { - if ($role_id ne '') { - push(@{$content{'roles'}{$role_id}{$entry}},$value); - } - } elsif ($entry eq 'dom') { - push(@{$content{$entry}},$value); - } else { - $content{$entry}=$value; - } - } - } elsif ($token->[0] eq 'E') { - if ($token->[1] eq 'user') { - $user = ''; - $usercount ++; - } elsif ($token->[1] eq 'roles') { - $role_id = ''; - } - } - } - return %content; -} - sub modify_access_controls { my ($file_name,$changes,$domain,$user)=@_; my ($outcome,$deloutcome); @@ -4770,8 +6079,13 @@ sub modify_access_controls { 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; + if ($newkey =~ /^\d+:/) { + $newkey =~ s/^(\d+)/$newid/; + $translation{$1} = $newid; + } elsif ($newkey =~ /^\d+_\d+_\d+:/) { + $newkey =~ s/^(\d+_\d+_\d+)/$newid/; + $translation{$1} = $newid; + } $new_values{$file_name."\0".$newkey} = $$changes{'activate'}{$newitems[$i]}; $new_control{$newkey} = $now; @@ -4836,12 +6150,68 @@ sub modify_access_controls { # remove lock my @del_lock = ($file_name."\0".'locked_access_records'); my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user); + my ($file,$group); + if (&is_course($domain,$user)) { + ($group,$file) = split(/\//,$file_name,2); + } else { + $file = $file_name; + } + my $sqlresult = + &update_portfolio_table($user,$domain,$file,'portfolio_access', + $group); } else { $outcome = "error: could not obtain lockfile\n"; } return ($outcome,$deloutcome,\%new_values,\%translation); } +sub make_public_indefinitely { + my ($requrl) = @_; + my $now = time; + my $action = 'activate'; + my $aclnum = 0; + if (&is_portfolio_url($requrl)) { + my (undef,$udom,$unum,$file_name,$group) = + &parse_portfolio_url($requrl); + my $current_perms = &get_portfile_permissions($udom,$unum); + my %access_controls = &get_access_controls($current_perms, + $group,$file_name); + foreach my $key (keys(%{$access_controls{$file_name}})) { + my ($num,$scope,$end,$start) = + ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/); + if ($scope eq 'public') { + if ($start <= $now && $end == 0) { + $action = 'none'; + } else { + $action = 'update'; + $aclnum = $num; + } + last; + } + } + if ($action eq 'none') { + return 'ok'; + } else { + my %changes; + my $newend = 0; + my $newstart = $now; + my $newkey = $aclnum.':public_'.$newend.'_'.$newstart; + $changes{$action}{$newkey} = { + type => 'public', + time => { + start => $newstart, + end => $newend, + }, + }; + my ($outcome,$deloutcome,$new_values,$translation) = + &modify_access_controls($file_name,\%changes,$udom,$unum); + return $outcome; + } + } else { + return 'invalid'; + } +} + #------------------------------------------------------Get Marked as Read Only sub get_marked_as_readonly { @@ -4859,7 +6229,7 @@ sub get_marked_as_readonly { if (ref($value) eq "ARRAY"){ foreach my $stored_what (@{$value}) { my $cmp2=$stored_what; - if (ref($stored_what eq 'ARRAY')) { + if (ref($stored_what) eq 'ARRAY') { $cmp2=join('',@{$stored_what}); } if ($cmp1 eq $cmp2) { @@ -4911,6 +6281,7 @@ sub unmark_as_readonly { # 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); @@ -4918,7 +6289,8 @@ sub unmark_as_readonly { if ($tmp=~/^error:/) { undef(%current_permissions); } my @readonly_files = &get_marked_as_readonly($domain,$user,$what,$group); foreach my $file (@readonly_files) { - if (defined($file_name) && ($file_name ne $file)) { next; } + 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; @@ -4948,91 +6320,103 @@ sub unmark_as_readonly { # ------------------------------------------------------------ Directory lister sub dirlist { - my ($uri,$userdomain,$username,$alternateDirectoryRoot)=@_; - + my ($uri,$userdomain,$username,$getpropath,$getuserdir,$alternateRoot)=@_; $uri=~s/^\///; $uri=~s/\/$//; my ($udom, $uname); - (undef,$udom,$uname)=split(/\//,$uri); - if(defined($userdomain)) { + if ($getuserdir) { $udom = $userdomain; - } - if(defined($username)) { $uname = $username; + } else { + (undef,$udom,$uname)=split(/\//,$uri); + if(defined($userdomain)) { + $udom = $userdomain; + } + if(defined($username)) { + $uname = $username; + } } + my ($dirRoot,$listing,@listing_results); - my $dirRoot = $perlvar{'lonDocRoot'}; - if(defined($alternateDirectoryRoot)) { - $dirRoot = $alternateDirectoryRoot; + $dirRoot = $perlvar{'lonDocRoot'}; + if (defined($getpropath)) { + $dirRoot = &propath($udom,$uname); $dirRoot =~ s/\/$//; + } elsif (defined($getuserdir)) { + my $subdir=$uname.'__'; + $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; + $dirRoot = $Apache::lonnet::perlvar{'lonUsersDir'} + ."/$udom/$subdir/$uname"; + } elsif (defined($alternateRoot)) { + $dirRoot = $alternateRoot; } if($udom) { if($uname) { - my $listing=reply('ls2:'.$dirRoot.'/'.$uri, - homeserver($uname,$udom)); - my @listing_results; + $listing = &reply('ls3:'.&escape('/'.$uri).':'.$getpropath.':' + .$getuserdir.':'.&escape($dirRoot) + .':'.&escape($uname).':'.&escape($udom), + &homeserver($uname,$udom)); if ($listing eq 'unknown_cmd') { - $listing=reply('ls:'.$dirRoot.'/'.$uri, - homeserver($uname,$udom)); + $listing = &reply('ls2:'.$dirRoot.'/'.$uri, + &homeserver($uname,$udom)); + } else { + @listing_results = map { &unescape($_); } split(/:/,$listing); + } + if ($listing eq 'unknown_cmd') { + $listing = &reply('ls:'.$dirRoot.'/'.$uri, + &homeserver($uname,$udom)); @listing_results = split(/:/,$listing); } else { @listing_results = map { &unescape($_); } split(/:/,$listing); } return @listing_results; - } elsif(!defined($alternateDirectoryRoot)) { - my $tryserver; - my %allusers=(); - foreach $tryserver (keys %libserv) { - if($hostdom{$tryserver} eq $udom) { - my $listing=reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'. - $udom, $tryserver); - my @listing_results; - if ($listing eq 'unknown_cmd') { - $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'. - $udom, $tryserver); - @listing_results = split(/:/,$listing); - } else { - @listing_results = - map { &unescape($_); } split(/:/,$listing); - } - if ($listing_results[0] ne 'no_such_dir' && - $listing_results[0] ne 'empty' && - $listing_results[0] ne 'con_lost') { - foreach (@listing_results) { - my ($entry,@stat)=split(/&/,$_); - $allusers{$entry}=1; - } - } + } elsif(!$alternateRoot) { + my %allusers; + my %servers = &get_servers($udom,'library'); + foreach my $tryserver (keys(%servers)) { + $listing = &reply('ls3:'.&escape("/res/$udom").':::::'. + &escape($udom),$tryserver); + if ($listing eq 'unknown_cmd') { + $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'. + $udom, $tryserver); + } else { + @listing_results = map { &unescape($_); } split(/:/,$listing); } + if ($listing eq 'unknown_cmd') { + $listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'. + $udom, $tryserver); + @listing_results = split(/:/,$listing); + } else { + @listing_results = + map { &unescape($_); } split(/:/,$listing); + } + if ($listing_results[0] ne 'no_such_dir' && + $listing_results[0] ne 'empty' && + $listing_results[0] ne 'con_lost') { + foreach my $line (@listing_results) { + my ($entry) = split(/&/,$line,2); + $allusers{$entry} = 1; + } + } } my $alluserstr=''; - foreach (sort keys %allusers) { - $alluserstr.=$_.'&user:'; + foreach my $user (sort(keys(%allusers))) { + $alluserstr.=$user.'&user:'; } $alluserstr=~s/:$//; return split(/:/,$alluserstr); } else { - my @emptyResults = (); - push(@emptyResults, 'missing user name'); - return split(':',@emptyResults); - } - } elsif(!defined($alternateDirectoryRoot)) { - my $tryserver; - my %alldom=(); - foreach $tryserver (keys %libserv) { - $alldom{$hostdom{$tryserver}}=1; - } - my $alldomstr=''; - foreach (sort keys %alldom) { - $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'/&domain:'; - } - $alldomstr=~s/:$//; - return split(/:/,$alldomstr); - } else { - my @emptyResults = (); - push(@emptyResults, 'missing domain'); - return split(':',@emptyResults); + return ('missing user name'); + } + } elsif(!defined($getpropath)) { + my @all_domains = sort(&all_domains()); + foreach my $domain (@all_domains) { + $domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain'; + } + return @all_domains; + } else { + return ('missing domain'); } } @@ -5041,23 +6425,13 @@ sub dirlist { # when it was last modified. It will also return an error of -1 # if an error occurs -## -## FIXME: This subroutine assumes its caller knows something about the -## directory structure of the home server for the student ($root). -## Not a good assumption to make. Since this is for looking up files -## in user directories, the full path should be constructed by lond, not -## whatever machine we request data from. -## sub GetFileTimestamp { - my ($studentDomain,$studentName,$filename,$root)=@_; - $studentDomain=~s/\W//g; - $studentName=~s/\W//g; - my $subdir=$studentName.'__'; - $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; - my $proname="$studentDomain/$subdir/$studentName"; - $proname .= '/'.$filename; - my ($fileStat) = &Apache::lonnet::dirlist($proname, $studentDomain, - $studentName, $root); + my ($studentDomain,$studentName,$filename,$getuserdir)=@_; + $studentDomain = &LONCAPA::clean_domain($studentDomain); + $studentName = &LONCAPA::clean_username($studentName); + my ($fileStat) = + &Apache::lonnet::dirlist($filename,$studentDomain,$studentName, + undef,$getuserdir); my @stats = split('&', $fileStat); if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') { # @stats contains first the filename, then the stat output @@ -5069,23 +6443,17 @@ sub GetFileTimestamp { sub stat_file { my ($uri) = @_; - $uri = &clutter($uri); + $uri = &clutter_with_no_wrapper($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); + my ($udom,$uname,$file); if ($uri =~ m-^/(uploaded|editupload)/-) { ($udom,$uname,$file) = - ($uri =~ m-/(?:uploaded|editupload)/?([^/]*)/?([^/]*)/?(.*)-); + ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-); $file = 'userfiles/'.$file; - $dir = &propath($udom,$uname); } if ($uri =~ m-^/res/-) { ($udom,$uname) = - ($uri =~ m-/(?:res)/?([^/]*)/?([^/]*)/-); + ($uri =~ m-/(?:res)/?($match_domain)/?($match_username)/-); $file = $uri; } @@ -5093,8 +6461,11 @@ sub stat_file { # unable to handle the uri return (); } - - my ($result) = &dirlist($file,$udom,$uname,$dir); + my $getpropath; + if ($file =~ /^userfiles\//) { + $getpropath = 1; + } + my ($result) = &dirlist($file,$udom,$uname,$getpropath); my @stats = split('&', $result); if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') { @@ -5127,7 +6498,7 @@ sub directcondval { untie(%bighash); } my $value = &docondval($sub_condition); - &appenv('user.state.'.$env{'request.course.id'}.".$number" => $value); + &appenv({'user.state.'.$env{'request.course.id'}.".$number" => $value}); return $value; } if ($env{'user.state.'.$env{'request.course.id'}}) { @@ -5192,7 +6563,15 @@ sub devalidatecourseresdata { &devalidate_cache_new('courseres',$hashid); } + # --------------------------------------------------- Course Resourcedata Query +# +# Parameters: +# $coursenum - Number of the course. +# $coursedomain - Domain at which the course was created. +# Returns: +# A hash of the course parameters along (I think) with timestamps +# and version info. sub get_courseresdata { my ($coursenum,$coursedomain)=@_; @@ -5251,7 +6630,21 @@ sub get_userresdata { } return $tmp; } - +#----------------------------------------------- resdata - return resource data +# Purpose: +# Return resource data for either users or for a course. +# Parameters: +# $name - Course/user name. +# $domain - Name of the domain the user/course is registered on. +# $type - Type of thing $name is (must be 'course' or 'user' +# @which - Array of names of resources desired. +# Returns: +# The value of the first reasource in @which that is found in the +# resource hash. +# Exceptional Conditions: +# If the $type passed in is not valid (not the string 'course' or +# 'user', an undefined reference is returned. +# If none of the resources are found, an undef is returned sub resdata { my ($name,$domain,$type,@which)=@_; my $result; @@ -5262,8 +6655,8 @@ sub resdata { } if (!ref($result)) { return $result; } foreach my $item (@which) { - if (defined($result->{$item})) { - return $result->{$item}; + if (defined($result->{$item->[0]})) { + return [$result->{$item->[0]},$item->[1]]; } } return undef; @@ -5291,7 +6684,7 @@ 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 @@ -5306,8 +6699,7 @@ sub EXT { $symbparm=&get_symb_from_alias($symbparm); } if (!($uname && $udom)) { - (my $cursymb,$courseid,$udom,$uname,$publicuser)= - &Apache::lonxml::whichuser($symbparm); + (my $cursymb,$courseid,$udom,$uname,$publicuser)= &whichuser($symbparm); if (!$symbparm) { $symbparm=$cursymb; } } else { $courseid=$env{'request.course.id'}; @@ -5430,6 +6822,12 @@ sub EXT { my ($map) = &decode_symb($symbparm); return &symbread($map); } + if ($space eq 'filename') { + if ($symbparm) { + return &clutter((&decode_symb($symbparm))[2]); + } + return &hreflocation('',$env{'request.filename'}); + } my ($section, $group, @groups); my ($courselevelm,$courselevel); @@ -5470,24 +6868,27 @@ sub EXT { # ----------------------------------------------------------- first, check user my $userreply=&resdata($uname,$udom,'user', - ($courselevelr,$courselevelm, - $courselevel)); - if (defined($userreply)) { return $userreply; } + ([$courselevelr,'resource'], + [$courselevelm,'map' ], + [$courselevel, 'course' ])); + if (defined($userreply)) { return &get_reply($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; } + if (defined($coursereply)) { return &get_reply($coursereply); } } $coursereply=&resdata($env{'course.'.$courseid.'.num'}, - $env{'course.'.$courseid.'.domain'}, - 'course', - ($seclevelr,$seclevelm,$seclevel, - $courselevelr)); - if (defined($coursereply)) { return $coursereply; } + $env{'course.'.$courseid.'.domain'}, + 'course', + ([$seclevelr, 'resource'], + [$seclevelm, 'map' ], + [$seclevel, 'course' ], + [$courselevelr,'resource'])); + if (defined($coursereply)) { return &get_reply($coursereply); } # ------------------------------------------------------ third, check map parms my %parmhash=(); @@ -5498,7 +6899,7 @@ sub EXT { $thisparm=$parmhash{$symbparm}; untie(%parmhash); } - if ($thisparm) { return $thisparm; } + if ($thisparm) { return &get_reply([$thisparm,'resource']); } } # ------------------------------------------ fourth, look in resource metadata @@ -5511,18 +6912,19 @@ sub EXT { $filename=$env{'request.filename'}; } my $metadata=&metadata($filename,$spacequalifierrest); - if (defined($metadata)) { return $metadata; } + if (defined($metadata)) { return &get_reply([$metadata,'resource']); } $metadata=&metadata($filename,'parameter_'.$spacequalifierrest); - if (defined($metadata)) { return $metadata; } + if (defined($metadata)) { return &get_reply([$metadata,'resource']); } -# ---------------------------------------------- fourth, look in rest pf course +# ---------------------------------------------- fourth, look in rest of course if ($symbparm && defined($courseid) && $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; } + ([$courselevelm,'map' ], + [$courselevel, 'course'])); + if (defined($coursereply)) { return &get_reply($coursereply); } } # ------------------------------------------------------------------ Cascade up unless ($space eq '0') { @@ -5530,20 +6932,22 @@ sub EXT { my $id=pop(@parts); my $part=join('_',@parts); if ($part eq '') { $part='0'; } - my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, + my @partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, $symbparm,$udom,$uname,$section,1); - if (defined($partgeneral)) { return $partgeneral; } + if (defined($partgeneral[0])) { return &get_reply(\@partgeneral); } } if ($recurse) { return undef; } my $pack_def=&packages_tab_default($filename,$varname); - if (defined($pack_def)) { return $pack_def; } - + if (defined($pack_def)) { return &get_reply([$pack_def,'resource']); } # ---------------------------------------------------- Any other user namespace } elsif ($realm eq 'environment') { # ----------------------------------------------------------------- environment if (($uname eq $env{'user.name'})&&($udom eq $env{'user.domain'})) { return $env{'environment.'.$spacequalifierrest}; } else { + if ($uname eq 'anonymous' && $udom eq '') { + return ''; + } my %returnhash=&userenvironment($udom,$uname, $spacequalifierrest); return $returnhash{$spacequalifierrest}; @@ -5562,15 +6966,27 @@ sub EXT { return ''; } +sub get_reply { + my ($reply_value) = @_; + if (ref($reply_value) eq 'ARRAY') { + if (wantarray) { + return @$reply_value; + } + return $reply_value->[0]; + } else { + return $reply_value; + } +} + sub check_group_parms { my ($courseid,$groups,$symbparm,$mapparm,$what) = @_; my @groupitems = (); my $resultitem; - my @levels = ($symbparm,$mapparm,$what); + my @levels = ([$symbparm,'resource'],[$mapparm,'map'],[$what,'course']); foreach my $group (@{$groups}) { foreach my $level (@levels) { - my $item = $courseid.'.['.$group.'].'.$level; - push(@groupitems,$item); + my $item = $courseid.'.['.$group.'].'.$level->[0]; + push(@groupitems,[$item,$level->[1]]); } } my $coursereply = &resdata($env{'course.'.$courseid.'.num'}, @@ -5596,7 +7012,8 @@ sub packages_tab_default { $do_default=1; } elsif ($pack_type eq 'extension') { push(@extension,[$package,$pack_type,$pack_part]); - } else { + } elsif ($pack_part eq $part || $pack_type eq 'part') { + # only look at packages defaults for packages that this id is push(@specifics,[$package,$pack_type,$pack_part]); } } @@ -5662,8 +7079,11 @@ sub metadata { if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) || - ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) || - ($uri =~ m|home/[^/]+/public_html/|)) { + ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) ) { + return undef; + } + if (($uri =~ /^~/ || $uri =~ m{home/$match_username/public_html/}) + && &Apache::lonxml::get_state('target') =~ /^(|meta)$/) { return undef; } my $filename=$uri; @@ -5684,6 +7104,7 @@ sub metadata { # if (! exists($metacache{$uri})) { # $metacache{$uri}={}; # } + my $cachetime = 60*60; if ($liburi) { $liburi=&declutter($liburi); $filename=$liburi; @@ -5694,7 +7115,13 @@ sub metadata { my %metathesekeys=(); unless ($filename=~/\.meta$/) { $filename.='.meta'; } my $metastring; - if ($uri !~ m -^(uploaded|editupload)/-) { + if ($uri =~ /^~/ || $uri =~ m{home/$match_username/public_html/}) { + my $which = &hreflocation('','/'.($liburi || $uri)); + $metastring = + &Apache::lonnet::ssi_body($which, + ('grade_target' => 'meta')); + $cachetime = 1; # only want this cached in the child not long term + } elsif ($uri !~ m -^(editupload)/-) { my $file=&filelocation('',&clutter($filename)); #push(@{$metaentry{$uri.'.file'}},$file); $metastring=&getfile($file); @@ -5799,10 +7226,11 @@ sub metadata { # only ws inside the tag, and not in default, so use default # as value $metaentry{':'.$unikey}=$default; - } else { - # either something interesting inside the tag or default - # uninteresting + } elsif ( $internaltext =~ /\S/ ) { + # something interesting inside the tag $metaentry{':'.$unikey}=$internaltext; + } else { + # no interesting values, don't set a default } # end of not-a-package not-a-library import } @@ -5812,13 +7240,18 @@ sub metadata { } } my ($extension) = ($uri =~ /\.(\w+)$/); + $extension = lc($extension); + if ($extension eq 'htm') { $extension='html'; } + 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'})) { + + if (!exists($metaentry{':packages'}) + || $packagetab{"import_defaults&extension_$extension"}) { foreach my $key (keys(%packagetab)) { #no specific packages well let's get default then if ($key!~/^default&/) { next; } @@ -5855,7 +7288,7 @@ sub metadata { $metaentry{':keys'} = join(',',keys(%metathesekeys)); &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys); - &do_cache_new('meta',$uri,\%metaentry,60*60); + &do_cache_new('meta',$uri,\%metaentry,$cachetime); # this is the end of "was not already recently cached } return $metaentry{':'.$what}; @@ -5913,6 +7346,17 @@ sub metadata_generate_part0 { } } +# ------------------------------------------------------ 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 { @@ -5926,12 +7370,15 @@ sub gettitle { } my ($map,$resid,$url)=&decode_symb($symb); my $title=''; - my %bighash; - if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db', - &GDBM_READER(),0640)) { - my $mapid=$bighash{'map_pc_'.&clutter($map)}; - $title=$bighash{'title_'.$mapid.'.'.$resid}; - untie %bighash; + if (!$map && $resid == 0 && $url =~/default\.sequence$/) { + $title = $env{'course.'.$env{'request.course.id'}.'.description'}; + } else { + if (tie(my %bighash,'GDBM_File',$env{'request.course.fn'}.'.db', + &GDBM_READER(),0640)) { + my $mapid=$bighash{'map_pc_'.&clutter($map)}; + $title=$bighash{'title_'.$mapid.'.'.$resid}; + untie(%bighash); + } } $title=~s/\&colon\;/\:/gs; if ($title) { @@ -5947,7 +7394,7 @@ sub gettitle { sub get_slot { my ($which,$cnum,$cdom)=@_; if (!$cnum || !$cdom) { - (undef,my $courseid)=&Apache::lonxml::whichuser(); + (undef,my $courseid)=&whichuser(); $cdom=$env{'course.'.$courseid.'.domain'}; $cnum=$env{'course.'.$courseid.'.num'}; } @@ -5996,9 +7443,6 @@ sub symblist { sub symbverify { my ($symb,$thisurl)=@_; 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; } @@ -6022,13 +7466,13 @@ sub symbverify { } if ($ids) { # ------------------------------------------------------------------- Has ID(s) - foreach (split(/\,/,$ids)) { - my ($mapid,$resid)=split(/\./,$_); + foreach my $id (split(/\,/,$ids)) { + my ($mapid,$resid)=split(/\./,$id); if ( &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) eq $symb) { if (($env{'request.role.adv'}) || - $bighash{'encrypted_'.$_} eq $env{'request.enc'}) { + $bighash{'encrypted_'.$id} eq $env{'request.enc'}) { $okay=1; } } @@ -6142,7 +7586,7 @@ sub symbread { if ($syval) { #unless ($syval=~/\_\d+$/) { #unless ($env{'form.request.prefix'}=~/\.(\d+)\_$/) { - #&appenv('request.ambiguous' => $thisfn); + #&appenv({'request.ambiguous' => $thisfn}); #return $env{$cache_str}=''; #} #$syval.=$1; @@ -6171,10 +7615,10 @@ sub symbread { } elsif (!$donotrecurse) { # ------------------------------------------ There is more than one possibility my $realpossible=0; - foreach (@possibilities) { - my $file=$bighash{'src_'.$_}; + foreach my $id (@possibilities) { + my $file=$bighash{'src_'.$id}; if (&allowed('bre',$file)) { - my ($mapid,$resid)=split(/\./,$_); + my ($mapid,$resid)=split(/\./,$id); if ($bighash{'map_type_'.$mapid} ne 'page') { $realpossible++; $syval=&encode_symb($bighash{'map_id_'.$mapid}, @@ -6194,7 +7638,7 @@ sub symbread { return $env{$cache_str}=$syval; } } - &appenv('request.ambiguous' => $thisfn); + &appenv({'request.ambiguous' => $thisfn}); return $env{$cache_str}=''; } @@ -6281,7 +7725,7 @@ sub latest_rnd_algorithm_id { sub get_rand_alg { my ($courseid)=@_; - if (!$courseid) { $courseid=(&Apache::lonxml::whichuser())[1]; } + if (!$courseid) { $courseid=(&whichuser())[1]; } if ($courseid) { return $env{"course.$courseid.rndseed"}; } @@ -6306,15 +7750,15 @@ sub getCODE { sub rndseed { my ($symb,$courseid,$domain,$username)=@_; - - my ($wsymb,$wcourseid,$wdomain,$wusername)=&Apache::lonxml::whichuser(); - if (!$symb) { + my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser(); + if (!defined($symb)) { unless ($symb=$wsymb) { return time; } } if (!$courseid) { $courseid=$wcourseid; } if (!$domain) { $domain=$wdomain; } if (!$username) { $username=$wusername } my $which=&get_rand_alg(); + if (defined(&getCODE())) { if ($which eq '64bit5') { return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username); @@ -6348,8 +7792,8 @@ sub rndseed_32bit { my $domainseed=unpack("%32C*",$domain) << 7; my $courseseed=unpack("%32C*",$courseid); my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck; - #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); - #&Apache::lonxml::debug("rndseed :$num:$symb"); + #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); + #&logthis("rndseed :$num:$symb"); if ($_64bit) { $num=(($num<<32)>>32); } return $num; } @@ -6369,9 +7813,8 @@ sub rndseed_64bit { my $num1=$symbchck+$symbseed+$namechck; my $num2=$nameseed+$domainseed+$courseseed; - #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); - #&Apache::lonxml::debug("rndseed :$num:$symb"); - if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } + #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); + #&logthis("rndseed :$num:$symb"); if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } return "$num1,$num2"; } @@ -6393,8 +7836,9 @@ sub rndseed_64bit2 { my $num1=$symbchck+$symbseed+$namechck; my $num2=$nameseed+$domainseed+$courseseed; - #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); - #&Apache::lonxml::debug("rndseed :$num:$symb"); + #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); + #&logthis("rndseed :$num:$symb"); + if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } return "$num1,$num2"; } } @@ -6415,8 +7859,8 @@ sub rndseed_64bit3 { my $num1=$symbchck+$symbseed+$namechck; my $num2=$nameseed+$domainseed+$courseseed; - #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); - #&Apache::lonxml::debug("rndseed :$num1:$num2:$_64bit"); + #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); + #&logthis("rndseed :$num1:$num2:$_64bit"); if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } return "$num1:$num2"; @@ -6439,8 +7883,8 @@ sub rndseed_64bit4 { my $num1=$symbchck+$symbseed+$namechck; my $num2=$nameseed+$domainseed+$courseseed; - #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); - #&Apache::lonxml::debug("rndseed :$num1:$num2:$_64bit"); + #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); + #&logthis("rndseed :$num1:$num2:$_64bit"); if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } return "$num1:$num2"; @@ -6464,8 +7908,8 @@ sub rndseed_CODE_64bit { my $courseseed=unpack("%32S*",$courseid.' '); my $num1=$symbseed+$CODEchck; my $num2=$CODEseed+$courseseed+$symbchck; - #&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck"); - #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb"); + #&logthis("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck"); + #&logthis("rndseed :$num1:$num2:$symb"); if ($_64bit) { $num1=(($num1<<32)>>32); } if ($_64bit) { $num2=(($num2<<32)>>32); } return "$num1:$num2"; @@ -6483,8 +7927,8 @@ sub rndseed_CODE_64bit4 { my $courseseed=unpack("%32S*",$courseid.' '); my $num1=$symbseed+$CODEchck; my $num2=$CODEseed+$courseseed+$symbchck; - #&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck"); - #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb"); + #&logthis("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck"); + #&logthis("rndseed :$num1:$num2:$symb"); if ($_64bit) { $num1=(($num1<<32)>>32); } if ($_64bit) { $num2=(($num2<<32)>>32); } return "$num1:$num2"; @@ -6509,13 +7953,14 @@ sub setup_random_from_rndseed { } sub latest_receipt_algorithm_id { - return 'receipt2'; + return 'receipt3'; } sub recunique { my $fucourseid=shift; my $unique; - if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') { + if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' || + $env{"course.$fucourseid.receiptalg"} eq 'receipt3' ) { $unique=$env{"course.$fucourseid.internal.encseed"}; } else { $unique=$perlvar{'lonReceipt'}; @@ -6526,7 +7971,8 @@ sub recunique { sub recprefix { my $fucourseid=shift; my $prefix; - if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') { + if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2'|| + $env{"course.$fucourseid.receiptalg"} eq 'receipt3' ) { $prefix=$env{"course.$fucourseid.internal.encpref"}; } else { $prefix=$perlvar{'lonHostID'}; @@ -6536,17 +7982,24 @@ sub recprefix { sub ireceipt { my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_; + + my $return =&recprefix($fucourseid).'-'; + + if ($env{"course.$fucourseid.receiptalg"} eq 'receipt3' || + $env{'request.state'} eq 'construct') { + $return .= (&digest("$funame,$fudom,$fucourseid,$fusymb,$part")%10000); + return $return; + } + my $cuname=unpack("%32C*",$funame); my $cudom=unpack("%32C*",$fudom); my $cucourseid=unpack("%32C*",$fucourseid); my $cusymb=unpack("%32C*",$fusymb); my $cunique=&recunique($fucourseid); my $cpart=unpack("%32S*",$part); - my $return =&recprefix($fucourseid).'-'; - if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' || - $env{'request.state'} eq 'construct') { - &Apache::lonxml::debug("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname). - " and ".($cpart%$cudom)); + if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') { + + #&logthis("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname)." and ".($cpart%$cudom)); $return.= ($cunique%$cuname+ $cunique%$cudom+ @@ -6569,10 +8022,48 @@ sub ireceipt { sub receipt { my ($part)=@_; - my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser(); + my ($symb,$courseid,$domain,$name) = &whichuser(); return &ireceipt($name,$domain,$courseid,$symb,$part); } +sub whichuser { + my ($passedsymb)=@_; + my ($symb,$courseid,$domain,$name,$publicuser); + if (defined($env{'form.grade_symb'})) { + my ($tmp_courseid)=&get_env_multiple('form.grade_courseid'); + my $allowed=&allowed('vgr',$tmp_courseid); + if (!$allowed && + exists($env{'request.course.sec'}) && + $env{'request.course.sec'} !~ /^\s*$/) { + $allowed=&allowed('vgr',$tmp_courseid. + '/'.$env{'request.course.sec'}); + } + if ($allowed) { + ($symb)=&get_env_multiple('form.grade_symb'); + $courseid=$tmp_courseid; + ($domain)=&get_env_multiple('form.grade_domain'); + ($name)=&get_env_multiple('form.grade_username'); + return ($symb,$courseid,$domain,$name,$publicuser); + } + } + if (!$passedsymb) { + $symb=&symbread(); + } else { + $symb=$passedsymb; + } + $courseid=$env{'request.course.id'}; + $domain=$env{'user.domain'}; + $name=$env{'user.name'}; + if ($name eq 'public' && $domain eq 'public') { + if (!defined($env{'form.username'})) { + $env{'form.username'}.=time.rand(10000000); + } + $name.=$env{'form.username'}; + } + return ($symb,$courseid,$domain,$name,$publicuser); + +} + # ------------------------------------------------------------ Serves up a file # returns either the contents of the file or # -1 if the file doesn't exist @@ -6595,61 +8086,60 @@ sub repcopy_userfile { if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); } if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'ok'; } my ($cdom,$cnum,$filename) = - ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+([^/]+)/+([^/]+)/+(.*)|); - my ($info,$rtncode); + ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|); my $uri="/uploaded/$cdom/$cnum/$filename"; if (-e "$file") { +# we already have a local copy, check it out my @fileinfo = stat($file); + my $rtncode; + my $info; my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode); if ($lwpresp ne 'ok') { +# there is no such file anymore, even though we had a local copy if ($rtncode eq '404') { unlink($file); } - #my $ua=new LWP::UserAgent; - #my $request=new HTTP::Request('GET',&tokenwrapper($uri)); - #my $response=$ua->request($request); - #if ($response->is_success()) { - # return $response->content; - # } else { - # return -1; - # } return -1; } if ($info < $fileinfo[9]) { +# nice, the file we have is up-to-date, just say okay return 'ok'; + } else { +# the file is outdated, get rid of it + unlink($file); } - $info = ''; - $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode); - if ($lwpresp ne 'ok') { - return -1; - } - } else { - my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode); - if ($lwpresp ne 'ok') { - my $ua=new LWP::UserAgent; - my $request=new HTTP::Request('GET',&tokenwrapper($uri)); - my $response=$ua->request($request); - if ($response->is_success()) { - $info=$response->content; - } else { - return -1; - } - } - my @parts = ($cdom,$cnum); - if ($filename =~ m|^(.+)/[^/]+$|) { - push @parts, split(/\//,$1); - } - my $path = $perlvar{'lonDocRoot'}.'/userfiles'; - foreach my $part (@parts) { - $path .= '/'.$part; - if (!-e $path) { - mkdir($path,0770); - } + } +# one way or the other, at this point, we don't have the file +# construct the correct path for the file + my @parts = ($cdom,$cnum); + if ($filename =~ m|^(.+)/[^/]+$|) { + push @parts, split(/\//,$1); + } + my $path = $perlvar{'lonDocRoot'}.'/userfiles'; + foreach my $part (@parts) { + $path .= '/'.$part; + if (!-e $path) { + mkdir($path,0770); } } - open(FILE,">$file"); - print FILE $info; - close(FILE); +# now the path exists for sure +# get a user agent + my $ua=new LWP::UserAgent; + my $transferfile=$file.'.in.transfer'; +# FIXME: this should flock + if (-e $transferfile) { return 'ok'; } + my $request; + $uri=~s/^\///; + $request=new HTTP::Request('GET','http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri); + my $response=$ua->request($request,$transferfile); +# did it work? + if ($response->is_error()) { + unlink($transferfile); + &logthis("Userfile repcopy failed for $uri"); + return -1; + } +# worked, rename the transfer file + rename($transferfile,$file); return 'ok'; } @@ -6662,8 +8152,8 @@ sub tokenwrapper { my (undef,$udom,$uname,$file)=split('/',$uri,4); if ($udom && $uname && $file) { $file=~s|(\?\.*)*$||; - &appenv("userfile.$udom/$uname/$file" => $env{'request.course.id'}); - return 'http://'.$hostname{ &homeserver($uname,$udom)}.'/'.$uri. + &appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}}); + return 'http://'.&hostname(&homeserver($uname,$udom)).'/'.$uri. (($uri=~/\?/)?'&':'?').'token='.$token. '&tokenissued='.$perlvar{'lonHostID'}; } else { @@ -6671,10 +8161,14 @@ sub tokenwrapper { } } +# call with reqtype HEAD: get last modification time +# call with reqtype GET: get the file contents +# Do not call this with reqtype GET for large files! It loads everything into memory +# sub getuploaded { my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_; $uri=~s/^\///; - $uri = 'http://'.$hostname{ &homeserver($cnum,$cdom)}.'/raw/'.$uri; + $uri = 'http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri; my $ua=new LWP::UserAgent; my $request=new HTTP::Request($reqtype,$uri); my $response=$ua->request($request); @@ -6696,7 +8190,7 @@ sub readfile { my $fh; open($fh,"<$file"); my $a=''; - while (<$fh>) { $a .=$_; } + while (my $line = <$fh>) { $a .= $line; } return $a; } @@ -6709,26 +8203,30 @@ sub filelocation { $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/:) { + } elsif ($file=~m{^/home/$match_username/public_html/}) { # is a correct contruction space reference $location = $file; + } elsif ($file =~ m-^\Q$Apache::lonnet::perlvar{'lonTabDir'}\E/-) { + $location = $file; } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file my ($udom,$uname,$filename)= - ($file=~m -^/+(?:uploaded|editupload)/+([^/]+)/+([^/]+)/+(.*)$-); + ($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_name)/+(.*)$-); my $home=&homeserver($uname,$udom); my $is_me=0; my @ids=¤t_machine_ids(); foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } } if ($is_me) { - $location=&propath($udom,$uname). - '/userfiles/'.$filename; + $location=&propath($udom,$uname).'/userfiles/'.$filename; } else { $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'. $udom.'/'.$uname.'/'.$filename; } + } elsif ($file =~ m-^/adm/-) { + $location = $perlvar{'lonDocRoot'}.'/'.$file; } else { $file=~s/^\Q$perlvar{'lonDocRoot'}\E//; $file=~s:^/res/:/:; @@ -6739,7 +8237,13 @@ sub filelocation { } } $location=~s://+:/:g; # remove duplicate / - while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/.. + while ($location=~m{/\.\./}) { + if ($location =~ m{/[^/]+/\.\./}) { + $location=~ s{/[^/]+/\.\./}{/}g; + } else { + $location=~ s{/\.\./}{/}g; + } + } #remove dir/.. while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./ return $location; } @@ -6754,37 +8258,71 @@ sub hreflocation { } 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/-; + } elsif ($file=~m-/home/($match_username)/public_html/-) { + $file=~s-^/home/($match_username)/public_html/-/~$1/-; } elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) { - $file=~s-^/home/httpd/lonUsers/([^/]*)/./././([^/]*)/userfiles/ + $file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/ -/uploaded/$1/$2/-x; } + if ($file=~ m{^/userfiles/}) { + $file =~ s{^/userfiles/}{/uploaded/}; + } return $file; } sub current_machine_domains { - my $hostname=$hostname{$perlvar{'lonHostID'}}; + return &machine_domains(&hostname($perlvar{'lonHostID'})); +} + +sub machine_domains { + my ($hostname) = @_; my @domains; + my %hostname = &all_hostnames(); while( my($id, $name) = each(%hostname)) { # &logthis("-$id-$name-$hostname-"); if ($hostname eq $name) { - push(@domains,$hostdom{$id}); + push(@domains,&host_domain($id)); } } return @domains; } sub current_machine_ids { - my $hostname=$hostname{$perlvar{'lonHostID'}}; + return &machine_ids(&hostname($perlvar{'lonHostID'})); +} + +sub machine_ids { + my ($hostname) = @_; + $hostname ||= &hostname($perlvar{'lonHostID'}); my @ids; - while( my($id, $name) = each(%hostname)) { -# &logthis("-$id-$name-$hostname-"); - if ($hostname eq $name) { - push(@ids,$id); - } + my %name_to_host = &all_names(); + if (ref($name_to_host{$hostname}) eq 'ARRAY') { + return @{ $name_to_host{$hostname} }; + } + return; +} + +sub additional_machine_domains { + my @domains; + open(my $fh,"<$perlvar{'lonTabDir'}/expected_domains.tab"); + while( my $line = <$fh>) { + $line =~ s/\s//g; + push(@domains,$line); } - return @ids; + return @domains; +} + +sub default_login_domain { + my $domain = $perlvar{'lonDefDomain'}; + my $testdomain=(split(/\./,$ENV{'HTTP_HOST'}))[0]; + foreach my $posdom (¤t_machine_domains(), + &additional_machine_domains()) { + if (lc($posdom) eq lc($testdomain)) { + $domain=$posdom; + last; + } + } + return $domain; } # ------------------------------------------------------------- Declutters URLs @@ -6805,7 +8343,8 @@ sub declutter { sub clutter { my $thisfn='/'.&declutter(shift); - unless ($thisfn=~/^\/(uploaded|editupload|adm|userfiles|ext|raw|priv|public)\//) { + if ($thisfn !~ m{^/(uploaded|editupload|adm|userfiles|ext|raw|priv|public)/} + || $thisfn =~ m{^/adm/(includes|pages)} ) { $thisfn='/res'.$thisfn; } if ($thisfn !~m|/adm|) { @@ -6835,6 +8374,15 @@ sub clutter { return $thisfn; } +sub clutter_with_no_wrapper { + my $uri = &clutter(shift); + if ($uri =~ m-^/adm/-) { + $uri =~ s-^/adm/wrapper/-/-; + $uri =~ s-^/adm/coursedocs/showdoc/-/-; + } + return $uri; +} + sub freeze_escape { my ($value)=@_; if (ref($value)) { @@ -6865,125 +8413,332 @@ sub correct_line_ends { sub goodbye { &logthis("Starting Shut down"); #not converted to using infrastruture and probably shouldn't be - &logthis(sprintf("%-20s is %s",'%badServerCache',length(&freeze(\%badServerCache)))); + &logthis(sprintf("%-20s is %s",'%badServerCache',length(&nfreeze(\%badServerCache)))); #converted # &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache))); - &logthis(sprintf("%-20s is %s",'%homecache',length(&freeze(\%homecache)))); -# &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache)))); -# &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%courseresdatacache)))); + &logthis(sprintf("%-20s is %s",'%homecache',length(&nfreeze(\%homecache)))); +# &logthis(sprintf("%-20s is %s",'%titlecache',length(&nfreeze(\%titlecache)))); +# &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&nfreeze(\%courseresdatacache)))); #1.1 only -# &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&freeze(\%userresdatacache)))); -# &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&freeze(\%getsectioncache)))); -# &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&freeze(\%courseresversioncache)))); -# &logthis(sprintf("%-20s is %s",'%resversioncache',length(&freeze(\%resversioncache)))); - &logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered)))); +# &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&nfreeze(\%userresdatacache)))); +# &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&nfreeze(\%getsectioncache)))); +# &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&nfreeze(\%courseresversioncache)))); +# &logthis(sprintf("%-20s is %s",'%resversioncache',length(&nfreeze(\%resversioncache)))); + &logthis(sprintf("%-20s is %s",'%remembered',length(&nfreeze(\%remembered)))); &logthis(sprintf("%-20s is %s",'kicks',$kicks)); &logthis(sprintf("%-20s is %s",'hits',$hits)); &flushcourselogs(); &logthis("Shutting down"); } -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; - } + my %alldns; + open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); + foreach my $dns (<$config>) { + next if ($dns !~ /^\^(\S*)/x); + $alldns{$1} = 1; + } + while (%alldns) { + my ($dns) = keys(%alldns); + delete($alldns{$dns}); + my $ua=new LWP::UserAgent; + my $request=new HTTP::Request('GET',"http://$dns$url"); + my $response=$ua->request($request); + next if ($response->is_error()); + my @content = split("\n",$response->content); + &Apache::lonnet::do_cache_new('dns',$url,\@content,30*24*60*60); + &$func(\@content); + return; } close($config); + my $which = (split('/',$url))[3]; + &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n"); + open($config,"<$perlvar{'lonTabDir'}/dns_$which.tab"); + my @content = <$config>; + &$func(\@content); + return; } +# ------------------------------------------------------------ Read domain file { - open(my $config,") { - if ($configline =~ /^[^\#]*PerlSetVar/) { - my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); - chomp($varvalue); - $perlvar{$varname}=$varvalue; - } + sub parse_domain_tab { + my ($lines) = @_; + foreach my $line (@$lines) { + next if ($line =~ /^(\#|\s*$ )/x); + + chomp($line); + my ($name,@elements) = split(/:/,$line,9); + my %this_domain; + foreach my $field ('description', 'auth_def', 'auth_arg_def', + 'lang_def', 'city', 'longi', 'lati', + 'primary') { + $this_domain{$field} = shift(@elements); + } + $domain{$name} = \%this_domain; + } } - close($config); -} -# ------------------------------------------------------------ Read domain file -{ - %domaindescription = (); - %domain_auth_def = (); - %domain_auth_arg_def = (); - my $fh; - if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) { - while (<$fh>) { - next if (/^(\#|\s*$)/); -# next if /^\#/; - chomp; - my ($domain, $domain_description, $def_auth, $def_auth_arg, - $def_lang, $city, $longi, $lati, $primary) = split(/:/,$_); - $domain_auth_def{$domain}=$def_auth; - $domain_auth_arg_def{$domain}=$def_auth_arg; - $domaindescription{$domain}=$domain_description; - $domain_lang_def{$domain}=$def_lang; - $domain_city{$domain}=$city; - $domain_longi{$domain}=$longi; - $domain_lati{$domain}=$lati; - $domain_primary{$domain}=$primary; + sub reset_domain_info { + undef($loaded); + undef(%domain); + } - # &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}"); -# &logthis("Domain.tab: $domain ".$domaindescription{$domain} ); + sub load_domain_tab { + my ($ignore_cache) = @_; + &get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache); + my $fh; + if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) { + my @lines = <$fh>; + &parse_domain_tab(\@lines); + } + close($fh); + $loaded = 1; + } + + sub domain { + &load_domain_tab() if (!$loaded); + + my ($name,$what) = @_; + return if ( !exists($domain{$name}) ); + + if (!$what) { + return $domain{$name}{'description'}; } + return $domain{$name}{$what}; } - close ($fh); } # ------------------------------------------------------------- Read hosts file { - open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); + my %hostname; + my %hostdom; + my %libserv; + my $loaded; + my %name_to_host; + + sub parse_hosts_tab { + my ($file) = @_; + foreach my $configline (@$file) { + next if ($configline =~ /^(\#|\s*$ )/x); + next if ($configline =~ /^\^/); + chomp($configline); + my ($id,$domain,$role,$name)=split(/:/,$configline); + $name=~s/\s//g; + if ($id && $domain && $role && $name) { + $hostname{$id}=$name; + push(@{$name_to_host{$name}}, $id); + $hostdom{$id}=$domain; + if ($role eq 'library') { $libserv{$id}=$name; } + } + } + } + + sub reset_hosts_info { + &purge_remembered(); + &reset_domain_info(); + &reset_hosts_ip_info(); + undef(%name_to_host); + undef(%hostname); + undef(%hostdom); + undef(%libserv); + undef($loaded); + } - while (my $configline=<$config>) { - next if ($configline =~ /^(\#|\s*$)/); - chomp($configline); - my ($id,$domain,$role,$name)=split(/:/,$configline); - $name=~s/\s//g; - if ($id && $domain && $role && $name) { - $hostname{$id}=$name; - $hostdom{$id}=$domain; - if ($role eq 'library') { $libserv{$id}=$name; } - } + sub load_hosts_tab { + my ($ignore_cache) = @_; + &get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache); + open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); + my @config = <$config>; + &parse_hosts_tab(\@config); + close($config); + $loaded=1; + } + + sub hostname { + &load_hosts_tab() if (!$loaded); + + my ($lonid) = @_; + return $hostname{$lonid}; + } + + sub all_hostnames { + &load_hosts_tab() if (!$loaded); + + return %hostname; + } + + sub all_names { + &load_hosts_tab() if (!$loaded); + + return %name_to_host; + } + + sub is_library { + &load_hosts_tab() if (!$loaded); + + return exists($libserv{$_[0]}); + } + + sub all_library { + &load_hosts_tab() if (!$loaded); + + return %libserv; + } + + sub get_servers { + &load_hosts_tab() if (!$loaded); + + my ($domain,$type) = @_; + my %possible_hosts = ($type eq 'library') ? %libserv + : %hostname; + my %result; + if (ref($domain) eq 'ARRAY') { + while ( my ($host,$hostname) = each(%possible_hosts)) { + if (grep(/^\Q$hostdom{$host}\E$/,@$domain)) { + $result{$host} = $hostname; + } + } + } else { + while ( my ($host,$hostname) = each(%possible_hosts)) { + if ($hostdom{$host} eq $domain) { + $result{$host} = $hostname; + } + } + } + return %result; + } + + sub host_domain { + &load_hosts_tab() if (!$loaded); + + my ($lonid) = @_; + return $hostdom{$lonid}; + } + + sub all_domains { + &load_hosts_tab() if (!$loaded); + + my %seen; + my @uniq = grep(!$seen{$_}++, values(%hostdom)); + return @uniq; } - close($config); - # FIXME: dev server don't want this, production servers _do_ want this - #&get_iphost(); } -sub get_iphost { - if (%iphost) { return %iphost; } +{ + my %iphost; my %name_to_ip; - foreach my $id (keys(%hostname)) { - my $name=$hostname{$id}; - 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; + my %lonid_to_ip; + + sub get_hosts_from_ip { + my ($ip) = @_; + my %iphosts = &get_iphost(); + if (ref($iphosts{$ip})) { + return @{$iphosts{$ip}}; + } + return; + } + + sub reset_hosts_ip_info { + undef(%iphost); + undef(%name_to_ip); + undef(%lonid_to_ip); + } + + sub get_host_ip { + my ($lonid) = @_; + if (exists($lonid_to_ip{$lonid})) { + return $lonid_to_ip{$lonid}; + } + my $name=&hostname($lonid); + my $ip = gethostbyname($name); + return if (!$ip || length($ip) ne 4); + $ip=inet_ntoa($ip); + $name_to_ip{$name} = $ip; + $lonid_to_ip{$lonid} = $ip; + return $ip; + } + + sub get_iphost { + my ($ignore_cache) = @_; + + if (!$ignore_cache) { + if (%iphost) { + return %iphost; + } + my ($ip_info,$cached)= + &Apache::lonnet::is_cached_new('iphost','iphost'); + if ($cached) { + %iphost = %{$ip_info->[0]}; + %name_to_ip = %{$ip_info->[1]}; + %lonid_to_ip = %{$ip_info->[2]}; + return %iphost; } - $ip=inet_ntoa($ip); - $name_to_ip{$name} = $ip; - } else { - $ip = $name_to_ip{$name}; } - push(@{$iphost{$ip}},$id); + + # get yesterday's info for fallback + my %old_name_to_ip; + my ($ip_info,$cached)= + &Apache::lonnet::is_cached_new('iphost','iphost'); + if ($cached) { + %old_name_to_ip = %{$ip_info->[1]}; + } + + my %name_to_host = &all_names(); + foreach my $name (keys(%name_to_host)) { + my $ip; + if (!exists($name_to_ip{$name})) { + $ip = gethostbyname($name); + if (!$ip || length($ip) ne 4) { + if (defined($old_name_to_ip{$name})) { + $ip = $old_name_to_ip{$name}; + &logthis("Can't find $name defaulting to old $ip"); + } else { + &logthis("Name $name no IP found"); + next; + } + } else { + $ip=inet_ntoa($ip); + } + $name_to_ip{$name} = $ip; + } else { + $ip = $name_to_ip{$name}; + } + foreach my $id (@{ $name_to_host{$name} }) { + $lonid_to_ip{$id} = $ip; + } + push(@{$iphost{$ip}},@{$name_to_host{$name}}); + } + &Apache::lonnet::do_cache_new('iphost','iphost', + [\%iphost,\%name_to_ip,\%lonid_to_ip], + 48*60*60); + + return %iphost; } - return %iphost; } +BEGIN { + +# ----------------------------------- Read loncapa.conf and loncapa_apache.conf + unless ($readit) { +{ + my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf'); + %perlvar = (%perlvar,%{$configvars}); +} + + # ------------------------------------------------------ Read spare server file { open(my $config,"<$perlvar{'lonTabDir'}/spare.tab"); @@ -6991,7 +8746,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); @@ -7053,10 +8810,13 @@ sub get_iphost { } -$memcache=new Cache::Memcached({'servers'=>['127.0.0.1:11211']}); +$memcache=new Cache::Memcached({'servers' => ['127.0.0.1:11211'], + 'compress_threshold'=> 20_000, + }); $processmarker='_'.time.'_'.$perlvar{'lonHostID'}; $dumpcount=0; +$locknum=0; &logtouch(); &logthis('INFO: Read configuration'); @@ -7239,10 +8999,12 @@ that was requested =item * X -B: the value of %hash is written to +B: the value of %{$hashref} is written to the user envirnoment file, and will be restored for each access this user makes during this session, also modifies the %env for the current -process +process. Optional rolesarrayref - if defined contains a reference to an array +of roles which are exempt from the restriction on modifying user.role entries +in the user's environment.db and in %env. =item * X @@ -7250,6 +9012,13 @@ B: removes all items fr environment file that matches the regular expression in $regexp. The values are also delted from the current processes %env. +=item * get_env_multiple($name) + +gets $name from the %env hash, it seemlessly handles the cases where multiple +values may be defined and end up as an array ref. + +returns an array of values + =back =head2 User Information @@ -7304,6 +9073,16 @@ X B: gets the values of the keys passed in @what from the requested user's environment, returns a hash +=item * +X +B: retrieves data from a user's +activity.log file. %filters defines filters applied when parsing the +log file. These can be start or end timestamps, or the type of action +- log to look for Login or Logout events, check for Checkin or +Checkout, role for role selection. The response is in the form +timestamp1:hostid1:event1×tamp2:hostid2:event2 where events are +escaped strings of the action recorded in the activity.log file. + =back =head2 User Roles @@ -7312,13 +9091,13 @@ passed in @what from the requested user' =item * -allowed($priv,$uri) : check for a user privilege; returns codes for allowed -actions +allowed($priv,$uri,$symb,$role) : check for a user privilege; returns codes for allowed actions F: full access U,I,K: authentication modes (cxx only) '': forbidden 1: user needs to choose course 2: browse allowed + A: passphrase authentication needed =item * @@ -7331,6 +9110,22 @@ and course level plaintext($short) : return value in %prp hash (rolesplain.tab); plain text explanation of a user role term +=item * + +get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec) : +All arguments are optional. Returns a hash of a roles, either for +co-author/assistant author roles for a user's Construction Space +(default), or if $context is 'userroles', roles for the user himself, +In the hash, keys are set to colon-separated $uname,$udom,$role, and +(optionally) if $withsec is true, a fourth colon-separated item - $section. +For each key, value is set to colon-separated start and end times for +the role. If no username and domain are specified, will default to +current user/domain. Types, roles, and roledoms are references to arrays +of role statuses (active, future or previous), roles +(e.g., cc,in, st etc.) and domains of the roles which can be used +to restrict the list of roles reported. If no array ref is +provided for types, will default to return only active roles. + =back =head2 User Modification @@ -7339,7 +9134,7 @@ explanation of a user role term =item * -assignrole($udom,$uname,$url,$role,$end,$start) : assign role; give a role to a +assignrole($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,$context) : assign role; give a role to a user for the level given by URL. Optional start and end dates (leave empty string or zero for "no date") @@ -7356,14 +9151,15 @@ modifyuserauth($udom,$uname,$umode,$upas =item * -modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) : +modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene, + $forceid,$desiredhome,$email,$inststatus) : modify user =item * modifystudent -modify a students enrollment and identification information. +modify a student's enrollment and identification information. The course id is resolved based on the current users environment. This means the envoking user must be a course coordinator or otherwise associated with a course. @@ -7375,25 +9171,25 @@ Inputs: =over 4 -=item B<$udom> Students loncapa domain +=item B<$udom> Student's loncapa domain -=item B<$uname> Students loncapa login name +=item B<$uname> Student's loncapa login name -=item B<$uid> Students id/student number +=item B<$uid> Student/Employee ID -=item B<$umode> Students authentication mode +=item B<$umode> Student's authentication mode -=item B<$upass> Students password +=item B<$upass> Student's password -=item B<$first> Students first name +=item B<$first> Student's first name -=item B<$middle> Students middle name +=item B<$middle> Student's middle name -=item B<$last> Students last name +=item B<$last> Student's last name -=item B<$gene> Students generation +=item B<$gene> Student's generation -=item B<$usec> Students section in course +=item B<$usec> Student's section in course =item B<$end> Unix time of the roles expiration @@ -7403,6 +9199,20 @@ Inputs: =item B<$desiredhome> server to use as home server for student +=item B<$email> Student's permanent e-mail address + +=item B<$type> Type of enrollment (auto or manual) + +=item B<$locktype> boolean - enrollment type locked to prevent Autoenroll.pl changing manual to auto + +=item B<$cid> courseID - needed if a course role is assigned by a user whose current role is DC + +=item B<$selfenroll> boolean - 1 if user role change occurred via self-enrollment + +=item B<$context> role change context (shown in User Management Logs display in a course) + +=item B<$inststatus> institutional status of user - : separated string of escaped status types + =back =item * @@ -7436,6 +9246,16 @@ Inputs: =item $start +=item $type + +=item $locktype + +=item $cid + +=item $selfenroll + +=item $context + =back @@ -7473,6 +9293,14 @@ setting for a specific $type, where $typ @what should be a list of parameters to ask about. This routine caches answers for 5 minutes. +=item * + +get_courseresdata($courseid, $domain) : dump the entire course resource +data base, returning a hash that is keyed by the resource name and has +values that are the resource value. I believe that the timestamps and +versions are also returned. + + =back =head2 Course Modification @@ -7752,6 +9580,30 @@ reference filled in from namesp (encrypt log($udom,$name,$home,$message) : write to permanent log for user; use critical subroutine +=item * + +get_dom($namespace,$storearr,$udom,$uhome) : returns hash with keys from +array reference filled in from namespace found in domain level on either +specified domain server ($uhome) or primary domain server ($udom and $uhome are optional). + +=item * + +put_dom($namespace,$storehash,$udom,$uhome) : stores hash in namespace at +domain level either on specified domain server ($uhome) or primary domain +server ($udom and $uhome are optional) + +=item * + +get_domain_defaults($target_domain) : returns hash with defaults for +authentication and language in the domain. Keys are: auth_def, auth_arg_def, +lang_def; corresponsing values are authentication type (internal, krb4, krb5, +or localauth), initial password or a kerberos realm, language (e.g., en-us). +Values are retrieved from cache (if current), or from domain's configuration.db +(if available), or lastly from values in lonTabs/dns_domain,tab, +or lonTabs/domain.tab. + +%domdefaults = &get_auth_defaults($target_domain); + =back =head2 Network Status Functions @@ -8046,15 +9898,6 @@ Internal notes: Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays. -parse_access_controls(): - -Parses XML of an access control record -Args -1. Text string (XML) of access comtrol record - -Returns: -1. Hash of access control settings. - modify_access_controls(): Modifies access controls for a portfolio file @@ -8152,3 +9995,4 @@ symblist($mapname,%newhash) : update sym =back =cut + 500 Internal Server Error

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.

More information about this error may be available in the server error log.