--- loncom/lonnet/perl/lonnet.pm 2007/01/25 21:10:51 1.824.2.1 +++ loncom/lonnet/perl/lonnet.pm 2009/05/06 12:13:26 1.996 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.824.2.1 2007/01/25 21:10:51 albertel Exp $ +# $Id: lonnet.pm,v 1.996 2009/05/06 12:13:26 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -27,44 +27,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); +=pod -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 Time::HiRes qw( gettimeofday tv_interval ); -use Cache::Memcached; -use Digest::MD5; -use Math::Random; -use LONCAPA qw(:DEFAULT :match); -use LONCAPA::Configuration; +=head1 NAME -my $readit; -my $max_connection_retries = 10; # Or some such value. +Apache::lonnet.pm -require Exporter; +=head1 SYNOPSIS -our @ISA = qw (Exporter); -our @EXPORT = qw(%env); +This file is an interface to the lonc processes of +the LON-CAPA network as well as set of elaborated functions for handling information +necessary for navigating through a given cluster of LON-CAPA machines within a +domain. There are over 40 specialized functions in this module which handle the +reading and transmission of metadata, user information (ids, names, environments, roles, +logs), file information (storage, reading, directories, extensions, replication, embedded +styles and descriptors), educational resources (course descriptions, section names and +numbers), url hashing (to assign roles on a url basis), and translating abbreviated symbols to +and from more descriptive phrases or explanations. -=pod +This is part of the LearningOnline Network with CAPA project +described at http://www.lon-capa.org. =head1 Package Variables @@ -86,29 +68,68 @@ delayed. =cut +package Apache::lonnet; + +use strict; +use LWP::UserAgent(); +use HTTP::Date; +use Image::Magick; + +use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir + $_64bit %env %protocol); + +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 Fcntl qw(:flock); +use Storable qw(thaw nfreeze); +use Time::HiRes qw( gettimeofday tv_interval ); +use Cache::Memcached; +use Digest::MD5; +use Math::Random; +use LONCAPA qw(:DEFAULT :match); +use LONCAPA::Configuration; + +my $readit; +my $max_connection_retries = 10; # Or some such value. + +my $upload_photo_form = 0; #Variable to check when user upload a photo 0=not 1=true + +require Exporter; + +our @ISA = qw (Exporter); +our @EXPORT = qw(%env); + # --------------------------------------------------------------------- Logging { 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); } } @@ -128,7 +149,8 @@ sub logthis { my $now=time; my $local=localtime($now); if (open(my $fh,">>$execdir/logs/lonnet.log")) { - print $fh "$local ($$): $message\n"; + my $logstring = $local. " ($$): ".$message."\n"; # Keep any \'s in string. + print $fh $logstring; close($fh); } return 1; @@ -146,10 +168,65 @@ 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; +} + +sub get_server_timezone { + my ($cnum,$cdom) = @_; + my $home=&homeserver($cnum,$cdom); + if ($home ne 'no_host') { + my $cachetime = 24*3600; + my ($timezone,$cached)=&is_cached_new('servertimezone',$home); + if (defined($cached)) { + return $timezone; + } else { + my $timezone = &reply('servertimezone',$home); + return &do_cache_new('servertimezone',$home,$timezone,$cachetime); + } + } +} + +sub get_server_loncaparev { + my ($dom,$lonhost) = @_; + if (defined($lonhost)) { + if (!defined(&hostname($lonhost))) { + undef($lonhost); + } + } + if (!defined($lonhost)) { + if (defined(&domain($dom,'primary'))) { + $lonhost=&domain($dom,'primary'); + if ($lonhost eq 'no_host') { + undef($lonhost); + } + } + } + if (defined($lonhost)) { + my $cachetime = 24*3600; + my ($loncaparev,$cached)=&is_cached_new('serverloncaparev',$lonhost); + if (defined($cached)) { + return $loncaparev; + } else { + my $loncaparev = &reply('serverloncaparev',$lonhost); + return &do_cache_new('serverloncaparev',$lonhost,$loncaparev,$cachetime); + } + } +} + # -------------------------------------------------- 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 +247,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 +268,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 +280,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 +307,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 +321,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'; @@ -296,7 +386,10 @@ sub convert_and_load_session_env { my ($lonidsdir,$handle)=@_; my @profile; { - open(my $idf,"$lonidsdir/$handle.id"); + my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id"); + if (!$opened) { + return 0; + } flock($idf,LOCK_SH); @profile=<$idf>; close($idf); @@ -335,7 +428,10 @@ sub transfer_profile_to_env { my $convert; { - open(my $idf,"$lonidsdir/$handle.id"); + my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id"); + if (!$opened) { + return; + } flock($idf,LOCK_SH); if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id", &GDBM_READER(),0640)) { @@ -367,6 +463,34 @@ sub transfer_profile_to_env { } } +# ---------------------------------------------------- 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; + } + + if (!defined($disk_env{'user.name'}) + || !defined($disk_env{'user.domain'})) { + return undef; + } + return $handle; +} + sub timed_flock { my ($file,$lock_type) = @_; my $failed=0; @@ -390,47 +514,68 @@ sub timed_flock { # ---------------------------------------------------------- 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}; + 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); } - } - open(my $env_file,$env{'user.environment'}); - if (&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); } return 'ok'; } # ----------------------------------------------------- Delete from Environment sub delenv { - my $delthis=shift; + my ($delthis,$regexp) = @_; if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) { &logthis("WARNING: ". "Attempt to delete from environment ".$delthis); return 'error'; } - open(my $env_file,$env{'user.environment'}); - if (&timed_flock($env_file,LOCK_EX) + 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}); + if ($regexp) { + if ($key=~/^$delthis/) { + delete($env{$key}); + delete($disk_env{$key}); + } + } else { + if ($key=~/^\Q$delthis\E/) { + delete($env{$key}); + delete($disk_env{$key}); + } } } untie(%disk_env); @@ -452,8 +597,52 @@ sub get_env_multiple { 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; { @@ -461,7 +650,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++; } } @@ -524,7 +714,11 @@ sub spareserver { } if (!$want_server_name) { - $spare_server="http://$hostname{$spare_server}"; + my $protocol = 'http'; + if ($protocol{$spare_server} eq 'https') { + $protocol = $protocol{$spare_server}; + } + $spare_server = $protocol.'://'.&hostname($spare_server); } return $spare_server; } @@ -558,6 +752,27 @@ sub compare_server_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 { @@ -612,18 +827,38 @@ sub queryauthenticate { # --------- Try to authenticate user from domain's lib servers (first this one) sub authenticate { - my ($uname,$upass,$udom)=@_; + my ($uname,$upass,$udom,$checkdefauth)=@_; $upass=&escape($upass); $uname= &LONCAPA::clean_username($uname); - my $uhome=&homeserver($uname,$udom); - if (!$uhome) { - &logthis("User $uname at $udom is unknown in authenticate"); - return 'no_host'; + 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"); @@ -641,18 +876,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'; } @@ -663,24 +899,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; } @@ -722,21 +956,36 @@ sub idput { # ------------------------------------------- get items from domain db files sub get_dom { - my ($namespace,$storearr,$udom)=@_; + my ($namespace,$storearr,$udom,$uhome)=@_; my $items=''; foreach my $item (@$storearr) { $items.=&escape($item).'&'; } $items=~s/\&$//; - if (!$udom) { $udom=$env{'user.domain'}; } - if (exists($domain_primary{$udom})) { - my $uhome=$domain_primary{$udom}; + 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 %returnhash=(); my $i=0; foreach my $item (@$storearr) { $returnhash{$item}=&thaw_unescape($pairs[$i]); @@ -744,17 +993,29 @@ sub get_dom { } return %returnhash; } else { - &logthis("get_dom failed - no primary domain server for $udom"); + &logthis("get_dom failed - no homeserver and/or domain ($udom) ($uhome)"); } } # -------------------------------------------- put items in domain db files sub put_dom { - my ($namespace,$storehash,$udom)=@_; - if (!$udom) { $udom=$env{'user.domain'}; } - if (exists($domain_primary{$udom})) { - my $uhome=$domain_primary{$udom}; + 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}).'&'; @@ -762,10 +1023,318 @@ sub put_dom { $items=~s/\&$//; return &reply("putdom:$udom:$namespace:$items",$uhome); } else { - &logthis("put_dom failed - no primary domain server for $udom"); + &logthis("put_dom failed - no homeserver and/or domain"); } } +sub retrieve_inst_usertypes { + my ($udom) = @_; + my (%returnhash,@order); + my %domdefs = &Apache::lonnet::get_domain_defaults($udom); + if ((ref($domdefs{'inststatustypes'}) eq 'HASH') && + (ref($domdefs{'inststatusorder'}) eq 'ARRAY')) { + %returnhash = %{$domdefs{'inststatustypes'}}; + @order = @{$domdefs{'inststatusorder'}}; + } else { + 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 { + $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)); + } + } + } + } + return (\%ruleshash,\@ruleorder); +} + +# ------------- Get Authentication, Language and User Tools Defaults for Domain + +sub get_domain_defaults { + my ($domain) = @_; + my $cachetime = 60*60*24; + 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','quotas', + 'requestcourses','inststatus'],$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'}; + $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'}; + $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_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'); + } + if (ref($domconfig{'quotas'}) eq 'HASH') { + if (ref($domconfig{'quotas'}{'defaultquota'}) eq 'HASH') { + $domdefaults{'defaultquota'} = $domconfig{'quotas'}{'defaultquota'}; + } else { + $domdefaults{'defaultquota'} = $domconfig{'quotas'}; + } + my @usertools = ('aboutme','blog','portfolio'); + foreach my $item (@usertools) { + if (ref($domconfig{'quotas'}{$item}) eq 'HASH') { + $domdefaults{$item} = $domconfig{'quotas'}{$item}; + } + } + } + if (ref($domconfig{'requestcourses'}) eq 'HASH') { + foreach my $item ('official','unofficial') { + $domdefaults{$item} = $domconfig{'requestcourses'}{$item}; + } + } + if (ref($domconfig{'inststatus'}) eq 'HASH') { + foreach my $item ('inststatustypes','inststatusorder') { + $domdefaults{$item} = $domconfig{'inststatus'}{$item}; + } + } + &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults, + $cachetime); + return %domdefaults; +} + # --------------------------------------------------- Assign a key to a student sub assign_access_key { @@ -798,7 +1367,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 @@ -990,10 +1559,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}); @@ -1001,7 +1579,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()]; @@ -1024,7 +1602,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__'; @@ -1033,15 +1611,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; } @@ -1070,9 +1654,14 @@ sub purge_remembered { sub userenvironment { my ($udom,$unam,@what)=@_; + my $items; + foreach my $item (@what) { + $items.=&escape($item).'&'; + } + $items=~s/\&$//; my %returnhash=(); my @answer=split(/\&/, - &reply('get:'.$udom.':'.$unam.':environment:'.join('&',@what), + &reply('get:'.$udom.':'.$unam.':environment:'.$items, &homeserver($unam,$udom))); my $i; for ($i=0;$i<=$#what;$i++) { @@ -1202,6 +1791,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/) { @@ -1266,12 +1856,21 @@ 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)); + my $output=''; + my $response; + if ($filelink=~/^https?\:/) { + ($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 @@ -1285,16 +1884,24 @@ sub absolute_url { 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',&absolute_url().$fn); $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form)); @@ -1305,7 +1912,11 @@ sub ssi { $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 { @@ -1313,7 +1924,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 @@ -1326,7 +1941,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 @@ -1387,7 +2002,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); } @@ -1450,20 +2065,48 @@ 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; return $fname; } +#This Function check if a Image max 400px width and height 500px. If not then scale the image down +sub resizeImage { + my($img_url) = @_; + my $ima = Image::Magick->new; + $ima->Read($img_url); + if($ima->Get('width') > 400) + { + my $factor = $ima->Get('width')/400; + $ima->Scale( width=>400, height=>$ima->Get('height')/$factor ); + } + if($ima->Get('height') > 500) + { + my $factor = $ima->Get('height')/500; + $ima->Scale( width=>$ima->Get('width')/$factor, height=>500); + } + + $ima->Write($img_url); +} + +#Wrapper function for userphotoupload +sub userphotoupload +{ + my($formname,$subdir) = @_; + $upload_photo_form = 1; + return &userfileupload($formname,undef,$subdir); +} # --------------- Take an uploaded file and put it into the userfiles directory # input: $formname - the contents of the file are in $env{"form.$formname"} @@ -1471,14 +2114,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); @@ -1516,16 +2166,19 @@ sub userfileupload { close($fh); return $fullpath.'/'.$fname; } - + if ($subdir eq 'scantron') { + $fname = 'scantron_orig_'.$fname; + } else { # Create the directory if not present - $fname="$subdir/$fname"; + $fname="$subdir/$fname"; + } if ($coursedoc) { my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; if ($env{'form.folder'} =~ m/^(default|supplemental)/) { return &finishuserfileupload($docuname,$docudom, $formname,$fname,$parser,$allfiles, - $codebase); + $codebase,$thumbwidth,$thumbheight); } else { $fname=$env{'form.folder'}.'/'.$fname; return &process_coursefile('uploaddoc',$docuname,$docudom, @@ -1535,8 +2188,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'}; @@ -1545,16 +2199,19 @@ 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|^(.*)/([^/]+)$|); @@ -1568,6 +2225,7 @@ sub finishuserfileupload { mkdir($filepath,0777); } } + # Save the file { if (!open(FH,'>'.$filepath.'/'.$file)) { @@ -1581,20 +2239,42 @@ sub finishuserfileupload { return '/adm/notfound.html'; } close(FH); + if($upload_photo_form==1) + { + resizeImage($filepath.'/'.$file); + $upload_photo_form = 0; + } } 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 $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; @@ -1602,11 +2282,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 => '', @@ -1621,18 +2301,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'); @@ -1714,21 +2397,21 @@ sub add_filetype { } sub removeuploadedurl { - my ($url)=@_; - my (undef,undef,$udom,$uname,$fname)=split('/',$url,5); + my ($url)=@_; + my (undef,undef,$udom,$uname,$fname)=split('/',$url,5); return &removeuserfile($uname,$udom,$fname); } sub removeuserfile { my ($docuname,$docudom,$fname)=@_; - my $home=&homeserver($docuname,$docudom); + my $home=&homeserver($docuname,$docudom); my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home); - if ($result eq 'ok') { + 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 ($file,$group) = (&parse_portfolio_url($url))[3,4]; my $sqlresult = &update_portfolio_table($docuname,$docudom,$file, 'portfolio_metadata',$group, @@ -1789,7 +2472,7 @@ sub flushcourselogs { # times and course titles for all courseids # my %courseidbuffer=(); - foreach my $crsid (keys %courselogs) { + foreach my $crsid (keys(%courselogs)) { if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'. &escape($courselogs{$crsid}), $coursehombuf{$crsid}) eq 'ok') { @@ -1802,22 +2485,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 my $crsid (keys(%courseidbuffer)) { - &courseidput($hostdom{$crsid},$courseidbuffer{$crsid},$crsid); + foreach my $crs_home (keys(%courseidbuffer)) { + my $response = &courseidput(&host_domain($crs_home), + $courseidbuffer{$crs_home}, + $crs_home,'timeonly'); } # # File accesses @@ -1873,7 +2555,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}); @@ -1884,13 +2566,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++; @@ -1933,7 +2614,12 @@ sub courseacclog { # FIXME: Probably ought to escape things.... foreach my $key (keys(%env)) { if ($key=~/^form\.(.*)/) { - $what.=':'.$1.'='.$env{$key}; + my $formitem = $1; + if ($formitem =~ /^HWFILE(?:SIZE|TOOBIG)/) { + $what.=':'.$formitem.'='.$env{$key}; + } elsif ($formitem !~ /^HWFILE(?:[^.]+)$/) { + $what.=':'.$formitem.'='.$env{$key}; + } } } } elsif ($fnsymb =~ m:^/adm/searchcat:) { @@ -1979,6 +2665,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/) || @@ -1990,13 +2684,51 @@ 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); + if (($trole ne 'st') || ($sec ne '')) { + &devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum); + } + } + } + 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 $crstype = &Apache::loncommon::course_type($cid); my %nothide=(); foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { - $nothide{join(':',split(/[\@\:]/,$user))}=1; + if ($user !~ /:/) { + $nothide{join(':',split(/[\@]/,$user))}=1; + } else { + $nothide{$user}=1; + } } my %returnhash=(); my %dumphash= @@ -2012,33 +2744,109 @@ sub get_course_adv_roles { if ((&privileged($username,$domain)) && (!$nothide{$username.':'.$domain})) { next; } if ($role eq 'cr') { next; } - my $key=&plaintext($role); - if ($section) { $key.=' (Sec/Grp '.$section.')'; } - if ($returnhash{$key}) { - $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,$crstype); + if ($section) { $key.=' ('.&Apache::lonlocal::mt('Section [_1]',$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 my $entry (keys(%dumphash)) { - my ($tend,$tstart)=split(/\:/,$dumphash{$entry}); + 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(/\:/,$entry); - $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; } @@ -2048,7 +2856,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); } @@ -2076,26 +2884,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,$regexp_ok)=@_; - 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 my $line ( - split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. - $sincefilter.':'.&escape($descfilter).':'. - &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter).':'.&escape($regexp_ok), - $tryserver))) { - my ($key,$value)=split(/\=/,$line,2); - 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]); + } + } } } } @@ -2116,12 +2978,13 @@ 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 my $line (split(/\&/,&reply($cmd,$domain_primary{$dom}))) { + foreach my $line (split(/\&/,&reply($cmd,&domain($dom,'primary')))) { my ($key,$value) = split(/\=/,$line,2); if (($key) && ($value)) { $returnhash{&unescape($key)} = &unescape($value); @@ -2140,21 +3003,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 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); - } - } - } + + 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; } @@ -2166,7 +3032,9 @@ sub get_first_access { 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; @@ -2179,7 +3047,9 @@ sub set_first_access { my ($type)=@_; 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; @@ -2244,7 +3114,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))); @@ -2809,7 +3679,7 @@ sub coursedescription { } } if (!$args->{'one_time'}) { - &appenv(%envhash); + &appenv(\%envhash); } return %returnhash; } @@ -2848,12 +3718,13 @@ sub privileged { sub rolesinit { my ($domain,$username,$authhost)=@_; + my %userroles; my $rolesdump=reply("dump:$domain:$username:roles",$authhost); - if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; } + if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return \%userroles; } my %allroles=(); my %allgroups=(); my $now=time; - my %userroles = ('user.login.time' => $now); + %userroles = ('user.login.time' => $now); my $group_privs; if ($rolesdump ne '') { @@ -2913,7 +3784,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 '')) { @@ -2974,7 +3845,7 @@ sub set_userprivs { if (keys(%{$allgroups}) > 0) { foreach my $role (keys %{$allroles}) { my ($trole,$area,$sec,$extendedarea); - if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)-) { + if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) { $trole = $1; $area = $2; $sec = $3; @@ -2994,7 +3865,7 @@ sub set_userprivs { } foreach my $role (keys(%{$allroles})) { my %thesepriv; - if (($role=~/^au/) || ($role=~/^ca/)) { $author=1; } + if (($role=~/^au/) || ($role=~/^ca/) || ($role=~/^aa/)) { $author=1; } foreach my $item (split(/:/,$$allroles{$role})) { if ($item ne '') { my ($privilege,$restrictions)=split(/&/,$item); @@ -3015,6 +3886,67 @@ sub set_userprivs { return ($author,$adv); } +sub role_status { + my ($rolekey,$then,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_; + my @pwhere = (); + if (exists($env{$rolekey}) && $env{$rolekey} ne '') { + (undef,undef,$$role,@pwhere)=split(/\./,$rolekey); + unless (!defined($$role) || $$role eq '') { + $$where=join('.',@pwhere); + $$trolecode=$$role.'.'.$$where; + ($$tstart,$$tend)=split(/\./,$env{$rolekey}); + $$tstatus='is'; + if ($$tstart && $$tstart>$then) { + $$tstatus='future'; + if ($$tstart<$now) { $$tstatus='will'; } + } + if ($$tend) { + if ($$tend<$then) { + $$tstatus='expired'; + } elsif ($$tend<$now) { + $$tstatus='will_not'; + } + } + } + } +} + +sub check_adhoc_privs { + my ($cdom,$cnum,$then,$now,$checkrole) = @_; + my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum; + if ($env{$cckey}) { + my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend); + &role_status($cckey,$then,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend); + unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) { + &set_adhoc_privileges($cdom,$cnum,$checkrole); + } + } else { + &set_adhoc_privileges($cdom,$cnum,$checkrole); + } +} + +sub set_adhoc_privileges { +# role can be cc or ca + my ($dcdom,$pickedcourse,$role) = @_; + my $area = '/'.$dcdom.'/'.$pickedcourse; + my $spec = $role.'.'.$area; + my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'}, + $env{'user.name'}); + my %ccrole = (); + &standard_roleprivs(\%ccrole,$role,$dcdom,$spec,$pickedcourse,$area); + my ($author,$adv)= &set_userprivs(\%userroles,\%ccrole); + &appenv(\%userroles,[$role,'cm']); + &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role); + &appenv( {'request.role' => $spec, + 'request.role.domain' => $dcdom, + 'request.course.sec' => '' + } + ); + my $tadv=0; + if (&allowed('adv') eq 'F') { $tadv=1; } + &appenv({'request.role.adv' => $tadv}); +} + # --------------------------------------------------------------- get interface sub get { @@ -3050,11 +3982,11 @@ sub del { foreach my $item (@$storearr) { $items.=&escape($item).'&'; } + $items=~s/\&$//; if (!$udomain) { $udomain=$env{'user.domain'}; } if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); - return &reply("del:$udomain:$uname:$namespace:$items",$uhome); } @@ -3358,6 +4290,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; @@ -3455,9 +4388,16 @@ sub get_portfolio_access { } if (@users > 0) { foreach my $userkey (@users) { - if (exists($access_hash->{$userkey}{'users'}{$env{'user.name'}.':'.$env{'user.domain'}})) { - return 'ok'; - } + 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; @@ -3606,6 +4546,148 @@ sub is_portfolio_file { return; } +sub usertools_access { + my ($uname,$udom,$tool,$action,$context) = @_; + my ($access,%tools); + if ($context eq '') { + $context = 'tools'; + } + if ($context eq 'requestcourses') { + %tools = ( + official => 1, + unofficial => 1, + ); + } else { + %tools = ( + aboutme => 1, + blog => 1, + portfolio => 1, + ); + } + return if (!defined($tools{$tool})); + + if ((!defined($udom)) || (!defined($uname))) { + $udom = $env{'user.domain'}; + $uname = $env{'user.name'}; + } + + if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { + if ($action ne 'reload') { + if ($context eq 'requestcourses') { + return $env{'environment.canrequest.'.$tool}; + } else { + return $env{'environment.availabletools.'.$tool}; + } + } + } + + my ($toolstatus,$inststatus); + + if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) && + ($action ne 'reload')) { + $toolstatus = $env{'environment.'.$context.'.'.$tool}; + $inststatus = $env{'environment.inststatus'}; + } else { + my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool); + $toolstatus = $userenv{$context.'.'.$tool}; + $inststatus = $userenv{'inststatus'}; + } + + if ($toolstatus ne '') { + if ($toolstatus) { + $access = 1; + } else { + $access = 0; + } + return $access; + } + + my $is_adv = &is_advanced_user($udom,$uname); + my %domdef = &get_domain_defaults($udom); + if (ref($domdef{$tool}) eq 'HASH') { + if ($is_adv) { + if ($domdef{$tool}{'_LC_adv'} ne '') { + if ($domdef{$tool}{'_LC_adv'}) { + $access = 1; + } else { + $access = 0; + } + return $access; + } + } + if ($inststatus ne '') { + my ($hasaccess,$hasnoaccess); + foreach my $affiliation (split(/:/,$inststatus)) { + if ($domdef{$tool}{$affiliation} ne '') { + if ($domdef{$tool}{$affiliation}) { + $hasaccess = 1; + } else { + $hasnoaccess = 1; + } + } + } + if ($hasaccess || $hasnoaccess) { + if ($hasaccess) { + $access = 1; + } elsif ($hasnoaccess) { + $access = 0; + } + return $access; + } + } else { + if ($domdef{$tool}{'default'} ne '') { + if ($domdef{$tool}{'default'}) { + $access = 1; + } elsif ($domdef{$tool}{'default'} == 0) { + $access = 0; + } + return $access; + } + } + } else { + if ($context eq 'tools') { + $access = 1; + } else { + $access = 0; + } + return $access; + } +} + +sub is_advanced_user { + my ($udom,$uname) = @_; + my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1); + my %allroles; + my $is_adv; + foreach my $role (keys(%roleshash)) { + my ($trest,$tdomain,$trole,$sec) = split(/:/,$role); + my $area = '/'.$tdomain.'/'.$trest; + if ($sec ne '') { + $area .= '/'.$sec; + } + if (($area ne '') && ($trole ne '')) { + my $spec=$trole.'.'.$area; + if ($trole =~ /^cr\//) { + &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area); + } elsif ($trole ne 'gr') { + &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area); + } + } + } + foreach my $role (keys(%allroles)) { + last if ($is_adv); + foreach my $item (split(/:/,$allroles{$role})) { + if ($item ne '') { + my ($privilege,$restrictions)=split(/&/,$item); + if ($privilege eq 'adv') { + $is_adv = 1; + last; + } + } + } + } + return $is_adv; +} # ---------------------------------------------- Custom access rule evaluation @@ -3617,26 +4699,40 @@ sub customaccess { $ucrs = &LONCAPA::clean_username($ucrs); my $access=0; foreach my $right (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) { - my ($effect,$realm,$role)=split(/\:/,$right); - 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'); + 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; @@ -3804,7 +4900,6 @@ sub allowed { } # Full access at system, domain or course-wide level? Exit. - if ($thisallowed=~/F/) { return 'F'; } @@ -4121,6 +5216,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) { @@ -4144,7 +5240,7 @@ 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 $uhost=&hostname($uhome); my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys(%filters))); my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command, $uhome); @@ -4156,6 +5252,9 @@ sub log_query { sub update_portfolio_table { my ($uname,$udom,$file_name,$query,$group,$action) = @_; + if ($group ne '') { + $file_name =~s /^\Q$group\E//; + } my $homeserver = &homeserver($uname,$udom); my $queryid= &reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group). @@ -4164,6 +5263,23 @@ sub update_portfolio_table { 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 { @@ -4176,7 +5292,7 @@ sub fetch_enrollment_query { } else { $homeserver = &homeserver($cnum,$dom); } - my $host=$hostname{$homeserver}; + my $host=&hostname($homeserver); my $cmd = ''; foreach my $affiliate (keys %{$affiliatesref}) { $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%'; @@ -4198,7 +5314,7 @@ 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 my $line (@responses) { my ($key,$value) = split(/=/,$line,2); @@ -4241,8 +5357,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); } @@ -4273,6 +5389,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); } @@ -4281,8 +5403,25 @@ 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; } @@ -4292,7 +5431,7 @@ sub auto_get_sections { my @secs = (); my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver)); unless ($response eq 'refused') { - @secs = split/:/,$response; + @secs = split(/:/,$response); } return @secs; } @@ -4312,15 +5451,27 @@ sub auto_validate_courseID { } 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); } @@ -4367,7 +5518,7 @@ 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 my $affiliate (keys(%{$affiliatesref})) { @@ -4407,12 +5558,11 @@ sub auto_instcode_format { my $courses = ''; my @homeservers; if ($caller eq 'global') { - foreach my $tryserver (keys(%libserv)) { - if ($hostdom{$tryserver} eq $codedom) { - if (!grep(/^\Q$tryserver\E$/,@homeservers)) { - push(@homeservers,$tryserver); - } - } + my %servers = &get_servers($codedom,'library'); + foreach my $tryserver (keys(%servers)) { + if (!grep(/^\Q$tryserver\E$/,@homeservers)) { + push(@homeservers,$tryserver); + } } } else { push(@homeservers,&homeserver($caller,$codedom)); @@ -4428,7 +5578,7 @@ sub auto_instcode_format { $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; + split(/:/,$response); %{$codes} = (%{$codes},&str2hash($codes_str)); push(@{$codetitles},&str2array($codetitles_str)); %{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str)); @@ -4446,42 +5596,44 @@ sub auto_instcode_format { sub auto_instcode_defaults { my ($domain,$returnhash,$code_order) = @_; my @homeservers; - foreach my $tryserver (keys(%libserv)) { - if ($hostdom{$tryserver} eq $domain) { - if (!grep(/^\Q$tryserver\E$/,@homeservers)) { - push(@homeservers,$tryserver); - } - } + + my %servers = &get_servers($domain,'library'); + foreach my $tryserver (keys(%servers)) { + if (!grep(/^\Q$tryserver\E$/,@homeservers)) { + push(@homeservers,$tryserver); + } } - my $ok_response = 0; + my $response; - while (@homeservers > 0 && $ok_response == 0) { - my $server = shift(@homeservers); + foreach my $server (@homeservers) { $response=&reply('autoinstcodedefaults:'.$domain,$server); - 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); - } - } - $ok_response = 1; - } - } - if ($ok_response) { - return 'ok'; - } else { - return $response; + 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,$owner,$inst_class) = @_; + 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($owner).':'.$cdom,$homeserver); + &escape($ownerlist).':'.$cdom,$homeserver); return $response; } @@ -4529,11 +5681,11 @@ sub toggle_coursegroup_status { } 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); } @@ -4622,16 +5774,19 @@ sub devalidate_getgroups_cache { # ------------------------------------------------------------------ Plain Text sub plaintext { - my ($short,$type,$cid) = @_; + my ($short,$type,$cid,$forcedefault) = @_; if ($short =~ /^cr/) { return (split('/',$short))[-1]; } if (!defined($cid)) { $cid = $env{'request.course.id'}; } - if (defined($cid) && defined($env{'course.'.$cid.'.'.$short.'.plaintext'})) { - return &Apache::lonlocal::mt($env{'course.'.$cid.'.'.$short. - '.plaintext'}); + if (defined($cid) && ($env{'course.'.$cid.'.'.$short.'.plaintext'} ne '')) { + unless ($forcedefault) { + my $roletext = $env{'course.'.$cid.'.'.$short.'.plaintext'}; + &Apache::lonlocal::mt_escape(\$roletext); + return &Apache::lonlocal::mt($roletext); + } } my %rolenames = ( Course => 'std', @@ -4649,7 +5804,8 @@ 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; @@ -4674,11 +5830,25 @@ sub assignrole { } else { my $cwosec=$url; $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$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'; + 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; } @@ -4694,6 +5864,7 @@ sub assignrole { } my $origstart = $start; my $origend = $end; + my $delflag; # actually delete if ($deleteflag) { if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) { @@ -4704,6 +5875,7 @@ sub assignrole { # set start and finish to negative values for userrolelog $start=-1; $end=-1; + $delflag = 1; } } # send command @@ -4712,9 +5884,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; @@ -4752,7 +5925,7 @@ sub modifyuser { my ($udom, $uname, $uid, $umode, $upass, $first, $middle, $last, $gene, - $forceid, $desiredhome, $email)=@_; + $forceid, $desiredhome, $email, $inststatus)=@_; $udom= &LONCAPA::clean_domain($udom); $uname=&LONCAPA::clean_username($uname); &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. @@ -4767,21 +5940,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')) { @@ -4814,7 +5985,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:.*/) { @@ -4832,17 +6004,37 @@ 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'} = ''; + my ($usertypes,$typesorder) = &retrieve_inst_usertypes($udom); + if (ref($usertypes) eq 'HASH') { + my @okstatuses; + foreach my $item (split(/:/,$inststatus)) { + if (defined($usertypes->{$item})) { + push(@okstatuses,$item); + } + } + if (@okstatuses) { + $names{'inststatus'} = join(':', map { &escape($_); } @okstatuses); + } + } } 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'; } @@ -4850,7 +6042,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,$inststatus)=@_; if (!$cid) { unless ($cid=$env{'request.course.id'}) { return 'not_in_class'; @@ -4859,18 +6052,18 @@ sub modifystudent { # --------------------------------------------------------------- Make the user my $reply=&modifyuser ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid, - $desiredhome,$email); + $desiredhome,$email,$inststatus); unless ($reply eq 'ok') { return $reply; } # This will cause &modify_student_enrollment to get the uid from the # students environment $uid = undef if (!$forceid); $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last, - $gene,$usec,$end,$start,$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'}) { @@ -4928,7 +6121,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 { @@ -4996,7 +6189,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 @@ -5009,10 +6202,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) { @@ -5052,33 +6250,41 @@ sub is_course { # ---------------------------------------------------------- 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,undef,$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; } @@ -5107,9 +6313,7 @@ sub is_locked { sub declutter_portfile { my ($file) = @_; - &logthis("got $file"); - $file =~ s-^(/portfolio/|portfolio/)-/-; - &logthis("ret $file"); + $file =~ s{^(/portfolio/|portfolio/)}{/}; return $file; } @@ -5134,7 +6338,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"); } @@ -5321,20 +6525,18 @@ sub modify_access_controls { } } } + my ($group); + if (&is_course($domain,$user)) { + ($group,my $file) = split(/\//,$file_name,2); + } $deloutcome = &del('file_permissions',\@deletions,$domain,$user); $new_values{$file_name."\0".'accesscontrol'} = \%new_control; $outcome = &put('file_permissions',\%new_values,$domain,$user); # remove lock my @del_lock = ($file_name."\0".'locked_access_records'); my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user); - 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', + &update_portfolio_table($user,$domain,$file_name,'portfolio_access', $group); } else { $outcome = "error: could not obtain lockfile\n"; @@ -5342,6 +6544,53 @@ sub modify_access_controls { 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 { @@ -5450,30 +6699,49 @@ 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('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)); @@ -5482,30 +6750,34 @@ sub dirlist { @listing_results = map { &unescape($_); } split(/:/,$listing); } return @listing_results; - } elsif(!defined($alternateDirectoryRoot)) { + } elsif(!$alternateRoot) { my %allusers; - foreach my $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 my $line (@listing_results) { - my ($entry) = split(/&/,$line,2); - $allusers{$entry} = 1; - } - } + 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 my $user (sort(keys(%allusers))) { @@ -5516,18 +6788,12 @@ sub dirlist { } else { return ('missing user name'); } - } elsif(!defined($alternateDirectoryRoot)) { - my $tryserver; - my %alldom=(); - foreach $tryserver (keys(%libserv)) { - $alldom{$hostdom{$tryserver}}=1; - } - my $alldomstr=''; - foreach my $domain (sort(keys(%alldom))) { - $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain:'; + } elsif(!defined($getpropath)) { + my @all_domains = sort(&all_domains()); + foreach my $domain (@all_domains) { + $domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain'; } - $alldomstr=~s/:$//; - return split(/:/,$alldomstr); + return @all_domains; } else { return ('missing domain'); } @@ -5538,23 +6804,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)=@_; + my ($studentDomain,$studentName,$filename,$getuserdir)=@_; $studentDomain = &LONCAPA::clean_domain($studentDomain); $studentName = &LONCAPA::clean_username($studentName); - 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 ($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 @@ -5568,12 +6824,11 @@ sub stat_file { my ($uri) = @_; $uri = &clutter_with_no_wrapper($uri); - my ($udom,$uname,$file,$dir); + my ($udom,$uname,$file); if ($uri =~ m-^/(uploaded|editupload)/-) { ($udom,$uname,$file) = ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-); $file = 'userfiles/'.$file; - $dir = &propath($udom,$uname); } if ($uri =~ m-^/res/-) { ($udom,$uname) = @@ -5585,8 +6840,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') { @@ -5619,7 +6877,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'}}) { @@ -5686,6 +6944,13 @@ sub devalidatecourseresdata { # --------------------------------------------------- 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)=@_; @@ -5744,7 +7009,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; @@ -5755,8 +7034,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; @@ -5784,7 +7063,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 @@ -5922,6 +7201,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); @@ -5962,24 +7247,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=(); @@ -5990,7 +7278,7 @@ sub EXT { $thisparm=$parmhash{$symbparm}; untie(%parmhash); } - if ($thisparm) { return $thisparm; } + if ($thisparm) { return &get_reply([$thisparm,'resource']); } } # ------------------------------------------ fourth, look in resource metadata @@ -6003,18 +7291,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') { @@ -6022,14 +7311,13 @@ 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 @@ -6057,15 +7345,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'}, @@ -6091,7 +7391,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]); } } @@ -6157,8 +7458,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/$match_username/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; @@ -6179,6 +7483,7 @@ sub metadata { # if (! exists($metacache{$uri})) { # $metacache{$uri}={}; # } + my $cachetime = 60*60; if ($liburi) { $liburi=&declutter($liburi); $filename=$liburi; @@ -6189,7 +7494,13 @@ sub metadata { my %metathesekeys=(); unless ($filename=~/\.meta$/) { $filename.='.meta'; } my $metastring; - if ($uri !~ m -^(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); @@ -6294,10 +7605,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 } @@ -6307,13 +7619,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; } @@ -6350,7 +7667,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}; @@ -6432,12 +7749,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) { @@ -6645,7 +7965,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; @@ -6697,7 +8017,7 @@ sub symbread { return $env{$cache_str}=$syval; } } - &appenv('request.ambiguous' => $thisfn); + &appenv({'request.ambiguous' => $thisfn}); return $env{$cache_str}=''; } @@ -6809,9 +8129,8 @@ sub getCODE { sub rndseed { my ($symb,$courseid,$domain,$username)=@_; - my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser(); - if (!$symb) { + if (!defined($symb)) { unless ($symb=$wsymb) { return time; } } if (!$courseid) { $courseid=$wcourseid; } @@ -7013,13 +8332,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'}; @@ -7030,7 +8350,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'}; @@ -7040,15 +8361,23 @@ 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') { + 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+ @@ -7137,74 +8466,79 @@ sub repcopy_userfile { if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'ok'; } my ($cdom,$cnum,$filename) = ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|); - my ($info,$rtncode); 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/^\///; + my $homeserver = &homeserver($cnum,$cdom); + my $protocol = $protocol{$homeserver}; + $protocol = 'http' if ($protocol ne 'https'); + $request=new HTTP::Request('GET',$protocol.'://'.&hostname($homeserver).'/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'; } sub tokenwrapper { my $uri=shift; - $uri=~s|^http\://([^/]+)||; + $uri=~s|^https?\://([^/]+)||; $uri=~s|^/||; $env{'user.environment'}=~/\/([^\/]+)\.id/; my $token=$1; my (undef,$udom,$uname,$file)=split('/',$uri,4); if ($udom && $uname && $file) { $file=~s|(\?\.*)*$||; - &appenv("userfile.$udom/$uname/$file" => $env{'request.course.id'}); - return 'http://'.$hostname{ &homeserver($uname,$udom)}.'/'.$uri. + &appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}}); + my $homeserver = &homeserver($uname,$udom); + my $protocol = $protocol{$homeserver}; + $protocol = 'http' if ($protocol ne 'https'); + return $protocol.'://'.&hostname($homeserver).'/'.$uri. (($uri=~/\?/)?'&':'?').'token='.$token. '&tokenissued='.$perlvar{'lonHostID'}; } else { @@ -7212,10 +8546,17 @@ 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; + my $homeserver = &homeserver($cnum,$cdom); + my $protocol = $protocol{$homeserver}; + $protocol = 'http' if ($protocol ne 'https'); + $uri = $protocol.'://'.&hostname($homeserver).'/raw/'.$uri; my $ua=new LWP::UserAgent; my $request=new HTTP::Request($reqtype,$uri); my $response=$ua->request($request); @@ -7250,12 +8591,15 @@ 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/$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)/+($match_domain)/+($match_name)/+(.*)$-); @@ -7264,12 +8608,13 @@ sub filelocation { 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/:/:; @@ -7280,14 +8625,20 @@ 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; } sub hreflocation { my ($dir,$file)=@_; - unless (($file=~m-^http://-i) || ($file=~m-^/-)) { + unless (($file=~m-^https?\://-i) || ($file=~m-^/-)) { $file=filelocation($dir,$file); } elsif ($file=~m-^/adm/-) { $file=~s-^/adm/wrapper/-/-; @@ -7301,31 +8652,42 @@ sub hreflocation { $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 @ids; + return; } sub additional_machine_domains { @@ -7369,7 +8731,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|) { @@ -7438,104 +8801,382 @@ 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) { -{ - my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf'); - %perlvar = (%perlvar,%{$configvars}); -} +sub get_dns { + my ($url,$func,$ignore_cache) = @_; + if (!$ignore_cache) { + my ($content,$cached)= + &Apache::lonnet::is_cached_new('dns',$url); + if ($cached) { + &$func($content); + return; + } + } + my %alldns; + open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); + foreach my $dns (<$config>) { + next if ($dns !~ /^\^(\S*)/x); + my $line = $1; + my ($host,$protocol) = split(/:/,$line); + if ($protocol ne 'https') { + $protocol = 'http'; + } + $alldns{$host} = $protocol; + } + while (%alldns) { + my ($dns) = keys(%alldns); + my $ua=new LWP::UserAgent; + my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url"); + my $response=$ua->request($request); + delete($alldns{$dns}); + 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 { - %domaindescription = (); - %domain_auth_def = (); - %domain_auth_arg_def = (); - my $fh; - if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) { - while (my $line = <$fh>) { - next if ($line =~ /^(\#|\s*$)/); -# next if /^\#/; - chomp $line; - my ($domain, $domain_description, $def_auth, $def_auth_arg, - $def_lang, $city, $longi, $lati, $primary) = split(/:/,$line,9); - $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; + my $loaded; + my %domain; - # &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}"); -# &logthis("Domain.tab: $domain ".$domaindescription{$domain} ); + 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 ($fh); + + sub reset_domain_info { + undef($loaded); + undef(%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}; + } + + sub domain_info { + &load_domain_tab() if (!$loaded); + return %domain; + } + } # ------------------------------------------------------------- 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,$protocol)=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; } + if (defined($protocol)) { + if ($protocol eq 'https') { + $protocol{$id} = $protocol; + } else { + $protocol{$id} = 'http'; + } + } else { + $protocol{$id} = 'http'; + } + } + } + } + + 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 all_host_domain { + &load_hosts_tab() if (!$loaded); + return %hostdom; + } + + 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; + } + + # + # Given a DNS returns the loncapa host name for that DNS + # + sub host_from_dns { + my ($dns) = @_; + my @hosts; + my $ip; + + if (exists($name_to_ip{$dns})) { + $ip = $name_to_ip{$dns}; + } + if (!$ip) { + $ip = gethostbyname($dns); # Initial translation to IP is in net order. + if (length($ip) == 4) { + $ip = &IO::Socket::inet_ntoa($ip); + } + } + if ($ip) { + @hosts = get_hosts_from_ip($ip); + return $hosts[0]; + } + return undef; } - 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"); @@ -7613,6 +9254,7 @@ $memcache=new Cache::Memcached({'servers $processmarker='_'.time.'_'.$perlvar{'lonHostID'}; $dumpcount=0; +$locknum=0; &logtouch(); &logthis('INFO: Read configuration'); @@ -7780,7 +9422,7 @@ when the connection is brought back up =item * B: unable to contact remote host and unable to save message for later delivery -=item * B: an error a occured, a description of the error follows the : +=item * B: an error a occurred, a description of the error follows the : =item * B: unable to fund a host associated with the user/domain that was requested @@ -7795,16 +9437,20 @@ 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 -B: removes all items from the session -environment file that matches the regular expression in $regexp. The -values are also delted from the current processes %env. +B: removes all items from the session +environment file that begin with $delthis. If the +optional second arg - $regexp - is true, $delthis is treated as a +regular expression, otherwise \Q$delthis\E is used. +The values are also deleted from the current processes %env. =item * get_env_multiple($name) @@ -7867,6 +9513,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 @@ -7891,8 +9547,29 @@ and course level =item * -plaintext($short) : return value in %prp hash (rolesplain.tab); plain text -explanation of a user role term +plaintext($short,$type,$cid,$forcedefault) : return value in %prp hash +(rolesplain.tab); plain text explanation of a user role term. +$type is Course (default) or Group. +If $forcedefault evaluates to true, text returned will be default +text for $type. Otherwise, if this is a course, the text returned +will be a custom name for the role (if defined in the course's +environment). If no custom name is defined the default is returned. + +=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 @@ -7902,7 +9579,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") @@ -7919,14 +9596,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. @@ -7938,25 +9616,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 @@ -7966,6 +9644,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 * @@ -7999,6 +9691,16 @@ Inputs: =item $start +=item $type + +=item $locktype + +=item $cid + +=item $selfenroll + +=item $context + =back @@ -8036,6 +9738,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 @@ -8299,7 +10009,7 @@ Returns: 'key_exists: ' -> failed to anything out of $storehash, as at least already existed in the db (other requested keys may also already exist) - 'error: ' -> unable to tie the DB or other erorr occured + 'error: ' -> unable to tie the DB or other error occurred 'con_lost' -> unable to contact request server 'refused' -> action was not allowed by remote machine @@ -8317,12 +10027,27 @@ critical subroutine =item * -get_dom($namespace,$storearr,$udomain) : returns hash with keys from array -reference filled in from namespace found in domain level on primary domain server ($udomain is optional) +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,$udomain) : stores hash in namespace at domain level on primary domain server ($udomain is optional) +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 @@ -8338,8 +10063,15 @@ dirlist($uri) : return directory list ba spareserver() : find server with least workload from spare.tab + +=item * + +host_from_dns($dns) : Returns the loncapa hostname corresponding to a DNS name or undef +if there is no corresponding loncapa host. + =back + =head2 Apache Request =over 4 @@ -8715,3 +10447,4 @@ symblist($mapname,%newhash) : update sym =back =cut +