--- loncom/lonnet/perl/lonnet.pm 2012/09/25 23:06:07 1.1172.2.11 +++ loncom/lonnet/perl/lonnet.pm 2012/08/19 00:18:41 1.1185 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.1172.2.11 2012/09/25 23:06:07 raeburn Exp $ +# $Id: lonnet.pm,v 1.1185 2012/08/19 00:18:41 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -75,6 +75,9 @@ use LWP::UserAgent(); use HTTP::Date; use Image::Magick; + +use Encode; + use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease %managerstab); @@ -97,6 +100,7 @@ use File::MMagic; use LONCAPA qw(:DEFAULT :match); use LONCAPA::Configuration; use LONCAPA::lonmetadata; +use LONCAPA::Lond; use File::Copy; @@ -108,33 +112,34 @@ require Exporter; our @ISA = qw (Exporter); our @EXPORT = qw(%env); -# ------------------------------------ Logging (parameters, docs, slots, roles) + +# ---------------------------------------------------------------- Role Logging { my $logid; - sub write_log { - my ($context,$hash_name,$storehash,$delflag,$uname,$udom,$cnum,$cdom)=@_; + sub write_rolelog { + my ($context,$hash_name,$storehash,$delflag,$udom,$uname,$cdom,$cnum)=@_; if ($context eq 'course') { if (($cnum eq '') || ($cdom eq '')) { $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; } } - $logid++; + $logid ++; my $now = time(); my $id=$now.'00000'.$$.'00000'.$logid; - my $logentry = { - $id => { - 'exe_uname' => $env{'user.name'}, - 'exe_udom' => $env{'user.domain'}, - 'exe_time' => $now, - 'exe_ip' => $ENV{'REMOTE_ADDR'}, - 'delflag' => $delflag, - 'logentry' => $storehash, - 'uname' => $uname, - 'udom' => $udom, - } + my $logentry = { + $id => { + 'exe_uname' => $env{'user.name'}, + 'exe_udom' => $env{'user.domain'}, + 'exe_time' => $now, + 'exe_ip' => $ENV{'REMOTE_ADDR'}, + 'delflag' => $delflag, + 'logentry' => $storehash, + 'uname' => $uname, + 'udom' => $udom, + } }; - return &put('nohist_'.$hash_name,$logentry,$cdom,$cnum); + return &put('nohist_'.$hash_name,$logentry,$cdom,$cnum); } } @@ -1385,8 +1390,8 @@ sub check_loadbalancing { $is_balancer = 0; if ($uname ne '' && $udom ne '') { if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) { - - &appenv({'user.loadbalexempt' => $lonhost, + + &appenv({'user.loadbalexempt' => $lonhost, 'user.loadbalcheck.time' => time}); } } @@ -2401,7 +2406,7 @@ sub chatsend { sub getversion { my $fname=&clutter(shift); - unless ($fname=~m{^(/adm/wrapper|)/res/}) { return -1; } + unless ($fname=~/^\/res\//) { return -1; } return ¤tversion(&filelocation('',$fname)); } @@ -2588,10 +2593,13 @@ sub ssi { $request->header(Cookie => $ENV{'HTTP_COOKIE'}); my $response= $ua->request($request); + my $content = $response->content; + + if (wantarray) { - return ($response->content, $response); + return ($content, $response); } else { - return $response->content; + return $content; } } @@ -3547,8 +3555,8 @@ sub courserolelog { } else { $storehash{'section'} = $sec; } - &write_log('course',$namespace,\%storehash,$delflag,$username, - $domain,$cnum,$cdom); + &write_rolelog('course',$namespace,\%storehash,$delflag,$domain, + $username,$cdom,$cnum); if (($trole ne 'st') || ($sec ne '')) { &devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum); } @@ -3568,8 +3576,8 @@ sub domainrolelog { end => $tend, context => $context, ); - &write_log('domain',$namespace,\%storehash,$delflag,$username, - $domain,$domconfiguser,$cdom); + &write_rolelog('domain',$namespace,\%storehash,$delflag,$domain, + $username,$cdom,$domconfiguser); } return; @@ -3587,8 +3595,8 @@ sub coauthorrolelog { end => $tend, context => $context, ); - &write_log('author',$namespace,\%storehash,$delflag,$username, - $domain,$auname,$audom); + &write_rolelog('author',$namespace,\%storehash,$delflag,$domain, + $username,$audom,$auname); } return; } @@ -3705,7 +3713,7 @@ sub get_my_roles { } my ($rolecode,$username,$domain,$section,$area); if ($context eq 'userroles') { - ($area,$rolecode) = ($entry =~ /^(.+)_([^_]+)$/); + ($area,$rolecode) = split(/_/,$entry); (undef,$domain,$username,$section) = split(/\//,$area); } else { ($role,$username,$domain,$section) = split(/\:/,$entry); @@ -3856,18 +3864,32 @@ sub courseiddump { 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.':'.&escape($cloner).':'. - &escape($cc_clone).':'.$cloneonly.':'. - &escape($createdbefore).':'.&escape($createdafter).':'. - &escape($creationcontext).':'.$domcloner, - $tryserver); + my $rep; + if (grep { $_ eq $tryserver } current_machine_ids()) { + $rep = LONCAPA::Lond::dump_course_id_handler( + join(":", (&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, + &escape($cloner), &escape($cc_clone), $cloneonly, + &escape($createdbefore), &escape($createdafter), + &escape($creationcontext), $domcloner))); + } else { + $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.':'.&escape($cloner).':'. + &escape($cc_clone).':'.$cloneonly.':'. + &escape($createdbefore).':'.&escape($createdafter).':'. + &escape($creationcontext).':'.$domcloner, + $tryserver); + } + my @pairs=split(/\&/,$rep); foreach my $item (@pairs) { my ($key,$value)=split(/\=/,$item,2); @@ -5111,12 +5133,37 @@ sub del { # -------------------------------------------------------------- dump interface +sub unserialize { + my ($rep, $escapedkeys) = @_; + + return {} if $rep =~ /^error/; + + my %returnhash=(); + foreach my $item (split /\&/, $rep) { + my ($key, $value) = split(/=/, $item, 2); + $key = unescape($key) unless $escapedkeys; + next if $key =~ /^error: 2 /; + $returnhash{$key} = Apache::lonnet::thaw_unescape($value); + } + #return %returnhash; + return \%returnhash; +} + +# see Lond::dump_with_regexp +# if $escapedkeys hash keys won't get unescaped. sub dump { - my ($namespace,$udomain,$uname,$regexp,$range)=@_; + my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys)=@_; if (!$udomain) { $udomain=$env{'user.domain'}; } if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); + my $reply; + if (grep { $_ eq $uhome } current_machine_ids()) { + # user is hosted on this machine + $reply = LONCAPA::Lond::dump_with_regexp(join(":", ($udomain, + $uname, $namespace, $regexp, $range)), $loncaparevs{$uhome}); + return %{unserialize($reply, $escapedkeys)}; + } if ($regexp) { $regexp=&escape($regexp); } else { @@ -5128,7 +5175,8 @@ sub dump { if (!($rep =~ /^error/ )) { foreach my $item (@pairs) { my ($key,$value)=split(/=/,$item,2); - $key = &unescape($key); + $key = unescape($key) unless $escapedkeys; + #$key = &unescape($key); next if ($key =~ /^error: 2 /); $returnhash{$key}=&thaw_unescape($value); } @@ -5141,23 +5189,9 @@ sub dump { sub dumpstore { my ($namespace,$udomain,$uname,$regexp,$range)=@_; - if (!$udomain) { $udomain=$env{'user.domain'}; } - if (!$uname) { $uname=$env{'user.name'}; } - my $uhome=&homeserver($uname,$udomain); - if ($regexp) { - $regexp=&escape($regexp); - } else { - $regexp='.'; - } - my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome); - my @pairs=split(/\&/,$rep); - my %returnhash=(); - foreach my $item (@pairs) { - my ($key,$value)=split(/=/,$item,2); - next if ($key =~ /^error: 2 /); - $returnhash{$key}=&thaw_unescape($value); - } - return %returnhash; + # same as dump but keys must be escaped. They may contain colon separated + # lists of values that may themself contain colons (e.g. symbs). + return &dump($namespace, $udomain, $uname, $regexp, $range, 1); } # -------------------------------------------------------------- keys interface @@ -5183,7 +5217,15 @@ sub currentdump { $sdom = $env{'user.domain'} if (! defined($sdom)); $sname = $env{'user.name'} if (! defined($sname)); my $uhome = &homeserver($sname,$sdom); - my $rep=reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome); + my $rep; + + if (grep { $_ eq $uhome } current_machine_ids()) { + $rep = LONCAPA::Lond::dump_profile_database(join(":", ($sdom, $sname, + $courseid))); + } else { + $rep = reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome); + } + return if ($rep =~ /^(error:|no_such_host)/); # my %returnhash=(); @@ -5714,7 +5756,7 @@ sub usertools_access { my ($toolstatus,$inststatus,$envkey); if ($context eq 'requestauthor') { - $envkey = $context; + $envkey = $context; } else { $envkey = $context.'.'.$tool; } @@ -7517,7 +7559,7 @@ sub assignrole { } } } elsif ($context eq 'requestauthor') { - if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) && + if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) && ($url eq '/'.$udom.'/') && ($role eq 'au')) { if ($env{'environment.requestauthor'} eq 'automatic') { $refused = ''; @@ -7525,13 +7567,13 @@ sub assignrole { my %domdefaults = &get_domain_defaults($udom); if (ref($domdefaults{'requestauthor'}) eq 'HASH') { my $checkbystatus; - if ($env{'user.adv'}) { + if ($env{'user.adv'}) { my $disposition = $domdefaults{'requestauthor'}{'_LC_adv'}; if ($disposition eq 'automatic') { $refused = ''; } elsif ($disposition eq '') { $checkbystatus = 1; - } + } } else { $checkbystatus = 1; } @@ -7618,7 +7660,7 @@ sub assignrole { $context); } elsif (($role eq 'ca') || ($role eq 'aa')) { &coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, - $context); + $context); } if ($role eq 'cc') { &autoupdate_coowners($url,$end,$start,$uname,$udom); @@ -9976,7 +10018,7 @@ sub symblist { # --------------------------------------------------------------- Verify a symb sub symbverify { - my ($symb,$thisurl,$encstate)=@_; + my ($symb,$thisurl)=@_; my $thisfn=$thisurl; $thisfn=&declutter($thisfn); # direct jump to resource in page or to a sequence - will construct own symbs @@ -10013,9 +10055,6 @@ sub symbverify { if ( &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) eq $symb) { - if (ref($encstate)) { - $$encstate = $bighash{'encrypted_'.$id}; - } if (($env{'request.role.adv'}) || ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) || ($thisurl eq '/adm/navmaps')) { @@ -12216,14 +12255,11 @@ returns the data handle =item * -symbverify($symb,$thisfn,$ecstate) : verifies that $symb actually exists -and is a possible symb for the URL in $thisfn, and if is an encrypted +symbverify($symb,$thisfn) : verifies that $symb actually exists and is +a possible symb for the URL in $thisfn, and if is an encryypted resource that the user accessed using /enc/ returns a 1 on success, 0 -on failure, user must be in a course, as it assumes the existence of -the course initial hash, and uses $env('request.course.id'}. The third -arg is an optional reference to a scalar. If this arg is passed in the -call to symbverify, it will be set to 1 if the symb has been set to be -encrypted; otherwise it will be null. +on failure, user must be in a course, as it assumes the existance of +the course initial hash, and uses $env('request.course.id'} =item *