--- loncom/lonnet/perl/lonnet.pm 2004/10/12 20:37:04 1.545.2.3 +++ loncom/lonnet/perl/lonnet.pm 2004/10/26 17:20:09 1.554 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.545.2.3 2004/10/12 20:37:04 albertel Exp $ +# $Id: lonnet.pm,v 1.554 2004/10/26 17:20:09 www Exp $ # # Copyright Michigan State University Board of Trustees # @@ -36,10 +36,10 @@ use HTTP::Date; # use Date::Parse; use vars qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom - %libserv %pr %prp $metacache %packagetab %titlecache %courseresversioncache %resversioncache + %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache %courselogs %accesshash %userrolehash $processmarker $dumpcount %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseresdatacache - %userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def + %userresdatacache %getsectioncache %domaindescription %domain_auth_def %domain_auth_arg_def %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir); use IO::Socket; @@ -51,8 +51,8 @@ use Apache::loncoursedata; use Apache::lonlocal; use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw); use Time::HiRes qw( gettimeofday tv_interval ); -use Cache::Memcached; my $readit; +my $max_connection_retries = 10; # Or some such value. =pod @@ -117,14 +117,40 @@ sub logperm { sub subreply { my ($cmd,$server)=@_; my $peerfile="$perlvar{'lonSockDir'}/$server"; - my $client=IO::Socket::UNIX->new(Peer =>"$peerfile", - Type => SOCK_STREAM, - Timeout => 10) - or return "con_lost"; - print $client "$cmd\n"; - my $answer=<$client>; - if (!$answer) { $answer="con_lost"; } - chomp($answer); + # + # With loncnew process trimming, there's a timing hole between lonc server + # process exit and the master server picking up the listen on the AF_UNIX + # socket. In that time interval, a lock file will exist: + + my $lockfile=$peerfile.".lock"; + while (-e $lockfile) { # Need to wait for the lockfile to disappear. + sleep(1); + } + # At this point, either a loncnew parent is listening or an old lonc + # or loncnew child is listening so we can connect or everything's dead. + # + # We'll give the connection a few tries before abandoning it. If + # connection is not possible, we'll con_lost back to the client. + # + my $client; + for (my $retries = 0; $retries < $max_connection_retries; $retries++) { + $client=IO::Socket::UNIX->new(Peer =>"$peerfile", + Type => SOCK_STREAM, + Timeout => 10); + if($client) { + last; # Connected! + } + sleep(1); # Try again later if failed connection. + } + my $answer; + if ($client) { + print $client "$cmd\n"; + $answer=<$client>; + if (!$answer) { $answer="con_lost"; } + chomp($answer); + } else { + $answer = 'con_lost'; # Failed connection. + } return $answer; } @@ -435,7 +461,7 @@ sub overloaderror { if ($overload>0) { $r->err_headers_out->{'Retry-After'}=$overload; $r->log_error('Overload of '.$overload.' on '.$checkserver); - return 409; + return 413; } return ''; } @@ -772,6 +798,11 @@ sub getsection { my ($udom,$unam,$courseid)=@_; $courseid=~s/\_/\//g; $courseid=~s/^(\w)/\/$1/; + + my $hashid="$udom:$unam:$courseid"; + my ($result,$cached)=&is_cached(\%getsectioncache,$hashid,'getsection'); + if (defined($cached)) { return $result; } + my %Pending; my %Expired; # @@ -796,29 +827,29 @@ sub getsection { if ($key eq $courseid.'_st') { $section=''; } my ($dummy,$end,$start)=split(/\_/,&unescape($value)); my $now=time; - if (defined($end) && ($now > $end)) { + if (defined($end) && $end && ($now > $end)) { $Expired{$end}=$section; next; } - if (defined($start) && ($now < $start)) { + if (defined($start) && $start && ($now < $start)) { $Pending{$start}=$section; next; } - return $section; + return &do_cache(\%getsectioncache,$hashid,$section,'getsection'); } # # Presumedly there will be few matching roles from the above # loop and the sorting time will be negligible. if (scalar(keys(%Pending))) { my ($time) = sort {$a <=> $b} keys(%Pending); - return $Pending{$time}; + return &do_cache(\%getsectioncache,$hashid,$Pending{$time},'getsection'); } if (scalar(keys(%Expired))) { my @sorted = sort {$a <=> $b} keys(%Expired); my $time = pop(@sorted); - return $Expired{$time}; + return &do_cache(\%getsectioncache,$hashid,$Expired{$time},'getsection'); } - return '-1'; + return &do_cache(\%getsectioncache,$hashid,'-1','getsection'); } @@ -874,7 +905,7 @@ sub is_cached { # &logthis("Upping $mtime - ".$$cache{$id.'.time'}. # "$id because of $filename"); } else { -# &logthis("Devalidating $filename $id - ".(time-($$cache{$id.'.time'}))); + &logthis("Devalidating $filename $id - ".(time-($$cache{$id.'.time'}))); &devalidate_cache($cache,$id,$name); return (undef,undef); } @@ -1009,84 +1040,6 @@ EVALBLOCK # &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime)); } -sub devalidate_cache_new { - my ($cache,$name,$id) = @_; - if (0) { &Apache::lonnet::logthis("deleting $name:$id"); } - $cache->delete(&escape($name.':'.$id)); -} - -my $lastone; -my $lastname; -sub is_cached_new { - my ($cache,$name,$id,$debug) = @_; - $debug=0; - $id=&escape($name.':'.$id); - if ($lastname eq $id) { - if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $lastone <= $lastname "); } - return ($lastone,1); - } - undef($lastone); - undef($lastname); - my $value = $cache->get($id); - if (!(defined($value))) { - if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); } - return (undef,undef); - } - $lastname=$id; - if ($value eq '__undef__') { - if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); } - return (undef,1); - } - if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); } - $lastone=$value; - return ($value,1); -} - -sub do_cache_new { - my ($cache,$name,$id,$value,$time,$debug) = @_; - $debug=0; - $id=&escape($name.':'.$id); - my $setvalue=$value; - if (!defined($setvalue)) { - $setvalue='__undef__'; - } - if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); } - $cache->set($id,$setvalue,300); - return $value; -} - -sub usection { - my ($udom,$unam,$courseid)=@_; - my $hashid="$udom:$unam:$courseid"; - - my ($result,$cached)=&is_cached(\%usectioncache,$hashid,'usection'); - if (defined($cached)) { return $result; } - $courseid=~s/\_/\//g; - $courseid=~s/^(\w)/\/$1/; - foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles', - &homeserver($unam,$udom)))) { - my ($key,$value)=split(/\=/,$_); - $key=&unescape($key); - if ($key=~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/) { - my $section=$1; - if ($key eq $courseid.'_st') { $section=''; } - my ($dummy,$end,$start)=split(/\_/,&unescape($value)); - my $now=time; - my $notactive=0; - if ($start) { - if ($now<$start) { $notactive=1; } - } - if ($end) { - if ($now>$end) { $notactive=1; } - } - unless ($notactive) { - return &do_cache(\%usectioncache,$hashid,$section,'usection'); - } - } - } - return &do_cache(\%usectioncache,$hashid,'-1','usection'); -} - # ------------------------------------- Read an entry from a user's environment sub userenvironment { @@ -1920,6 +1873,7 @@ sub devalidate { # - the student level sheet of this user in course's homespace # - the assessment level sheet for this resource # for this user in user's homespace + # - current conditional state info my $key=$uname.':'.$udom.':'; my $status= &del('nohist_calculatedsheets', @@ -1934,6 +1888,7 @@ sub devalidate { $uname.' at '.$udom.' for '. $symb.': '.$status); } + &delenv('user.state.'.$cid); } } @@ -2253,6 +2208,7 @@ sub tmprestore { } # ----------------------------------------------------------------------- Store + sub store { my ($storehash,$symb,$namespace,$domain,$stuname) = @_; my $home=''; @@ -2266,6 +2222,7 @@ sub store { if (!$stuname) { $stuname=$ENV{'user.name'}; } &devalidate($symb,$stuname,$domain); + $symb=escape($symb); if (!$namespace) { unless ($namespace=$ENV{'request.course.id'}) { @@ -2301,6 +2258,7 @@ sub cstore { if (!$stuname) { $stuname=$ENV{'user.name'}; } &devalidate($symb,$stuname,$domain); + $symb=escape($symb); if (!$namespace) { unless ($namespace=$ENV{'request.course.id'}) { @@ -2343,7 +2301,6 @@ sub restore { if (!$domain) { $domain=$ENV{'user.domain'}; } if (!$stuname) { $stuname=$ENV{'user.name'}; } if (!$home) { $home=$ENV{'user.home'}; } - my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home"); my %returnhash=(); @@ -2830,12 +2787,14 @@ sub allowed { } # Free bre access to user's own portfolio contents - $uri=~m:([^/]+)/([^/]+)/([^/]+)/([^/]+)/:; - if (('uploaded' eq $1)&&($ENV{'user.name'} eq $3) && ($ENV{'user.domain'} eq $2) && ('portfolio' eq $4)) { + my ($space,$domain,$name,$dir)=split('/',$uri); + if (('uploaded' eq $space) && ($ENV{'user.name'} eq $name) && + ($ENV{'user.domain'} eq $domain) && ('portfolio' eq $dir)) { return 'F'; } # Free bre to public access + if ($priv eq 'bre') { my $copyright=&metadata($uri,'copyright'); if (($copyright eq 'public') && (!$ENV{'request.course.id'})) { @@ -3099,6 +3058,9 @@ sub allowed { return ''; } } + if (!defined($ENV{'user.state.'.$ENV{'request.course.id'}})) { + &Apache::lonuserstate::evalstate(); + } if (&condval($statecond)) { return '2'; } else { @@ -3235,8 +3197,10 @@ sub log_query { sub fetch_enrollment_query { my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_; my $homeserver; + my $maxtries = 1; if ($context eq 'automated') { $homeserver = $perlvar{'lonHostID'}; + $maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout } else { $homeserver = &homeserver($cnum,$dom); } @@ -3254,8 +3218,13 @@ sub fetch_enrollment_query { return 'error: '.$queryid; } my $reply = &get_query_reply($queryid); + my $tries = 1; + while (($reply=~/^timeout/) && ($tries < $maxtries)) { + $reply = &get_query_reply($queryid); + $tries ++; + } if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { - &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$ENV{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum); + &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$ENV{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries); } else { my @responses = split/:/,$reply; if ($homeserver eq $perlvar{'lonHostID'}) { @@ -4151,7 +4120,7 @@ sub EXT { $section=$ENV{'request.course.sec'}; } else { if (! defined($usection)) { - $section=&usection($udom,$uname,$courseid); + $section=&getsection($udom,$uname,$courseid); } else { $section = $usection; } @@ -4301,7 +4270,6 @@ sub add_prefix_and_part { # ---------------------------------------------------------------- Get metadata -my %metaentry; sub metadata { my ($uri,$what,$liburi,$prefix,$depthcount)=@_; $uri=&declutter($uri); @@ -4321,29 +4289,28 @@ sub metadata { # Everything is cached by the main uri, libraries are never directly cached # if (!defined($liburi)) { - my ($result,$cached)=&is_cached_new($metacache,'meta',$uri); + my ($result,$cached)=&is_cached(\%metacache,$uri,'meta'); if (defined($cached)) { return $result->{':'.$what}; } } { # # Is this a recursive call for a library? # -# if (! exists($metacache{$uri})) { -# $metacache{$uri}={}; -# } + if (! exists($metacache{$uri})) { + $metacache{$uri}={}; + } if ($liburi) { $liburi=&declutter($liburi); $filename=$liburi; } else { - &devalidate_cache_new($metacache,'meta',$uri); - undef(%metaentry); + &devalidate_cache(\%metacache,$uri,'meta'); } my %metathesekeys=(); unless ($filename=~/\.meta$/) { $filename.='.meta'; } my $metastring; if ($uri !~ m|^uploaded/|) { my $file=&filelocation('',&clutter($filename)); - #push(@{$metaentry{$uri.'.file'}},$file); + push(@{$metacache{$uri.'.file'}},$file); $metastring=&getfile($file); } my $parser=HTML::LCParser->new(\$metastring); @@ -4360,10 +4327,10 @@ sub metadata { if (defined($token->[2]->{'id'})) { $keyroot.='_'.$token->[2]->{'id'}; } - if ($metaentry{':packages'}) { - $metaentry{':packages'}.=','.$package.$keyroot; + if ($metacache{$uri}->{':packages'}) { + $metacache{$uri}->{':packages'}.=','.$package.$keyroot; } else { - $metaentry{':packages'}=$package.$keyroot; + $metacache{$uri}->{':packages'}=$package.$keyroot; } foreach (keys %packagetab) { my $part=$keyroot; @@ -4385,14 +4352,14 @@ sub metadata { if ($subp eq 'display') { $value.=' [Part: '.$part.']'; } - $metaentry{':'.$unikey.'.part'}=$part; + $metacache{$uri}->{':'.$unikey.'.part'}=$part; $metathesekeys{$unikey}=1; - unless (defined($metaentry{':'.$unikey.'.'.$subp})) { - $metaentry{':'.$unikey.'.'.$subp}=$value; + unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) { + $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value; } - if (defined($metaentry{':'.$unikey.'.default'})) { - $metaentry{':'.$unikey}= - $metaentry{':'.$unikey.'.default'}; + if (defined($metacache{$uri}->{':'.$unikey.'.default'})) { + $metacache{$uri}->{':'.$unikey}= + $metacache{$uri}->{':'.$unikey.'.default'}; } } } @@ -4425,7 +4392,7 @@ sub metadata { foreach (sort(split(/\,/,&metadata($uri,'keys', $location,$unikey, $depthcount+1)))) { - $metaentry{':'.$_}=$metaentry{':'.$_}; + $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_}; $metathesekeys{$_}=1; } } @@ -4436,18 +4403,18 @@ sub metadata { } $metathesekeys{$unikey}=1; foreach (@{$token->[3]}) { - $metaentry{':'.$unikey.'.'.$_}=$token->[2]->{$_}; + $metacache{$uri}->{':'.$unikey.'.'.$_}=$token->[2]->{$_}; } my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry)); - my $default=$metaentry{':'.$unikey.'.default'}; + my $default=$metacache{$uri}->{':'.$unikey.'.default'}; if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) { # only ws inside the tag, and not in default, so use default # as value - $metaentry{':'.$unikey}=$default; + $metacache{$uri}->{':'.$unikey}=$default; } else { # either something interesting inside the tag or default # uninteresting - $metaentry{':'.$unikey}=$internaltext; + $metacache{$uri}->{':'.$unikey}=$internaltext; } # end of not-a-package not-a-library import } @@ -4464,7 +4431,7 @@ sub metadata { &metadata_create_package_def($uri,$key,'extension_'.$extension, \%metathesekeys); } - if (!exists($metaentry{':packages'})) { + if (!exists($metacache{$uri}->{':packages'})) { foreach my $key (sort(keys(%packagetab))) { #no specific packages well let's get default then if ($key!~/^default&/) { next; } @@ -4473,31 +4440,31 @@ sub metadata { } } # are there custom rights to evaluate - if ($metaentry{':copyright'} eq 'custom') { + if ($metacache{$uri}->{':copyright'} eq 'custom') { # # Importing a rights file here # unless ($depthcount) { - my $location=$metaentry{':customdistributionfile'}; + my $location=$metacache{$uri}->{':customdistributionfile'}; my $dir=$filename; $dir=~s|[^/]*$||; $location=&filelocation($dir,$location); foreach (sort(split(/\,/,&metadata($uri,'keys', $location,'_rights', $depthcount+1)))) { - #$metaentry{':'.$_}=$metacache{$uri}->{':'.$_}; + $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_}; $metathesekeys{$_}=1; } } } - $metaentry{':keys'}=join(',',keys %metathesekeys); - &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); - $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys); - &do_cache_new($metacache,'meta',$uri,\%metaentry); + $metacache{$uri}->{':keys'}=join(',',keys %metathesekeys); + &metadata_generate_part0(\%metathesekeys,$metacache{$uri},$uri); + $metacache{$uri}->{':allpossiblekeys'}=join(',',keys %metathesekeys); + &do_cache(\%metacache,$uri,$metacache{$uri},'meta'); # this is the end of "was not already recently cached } - return $metaentry{':'.$what}; + return $metacache{$uri}->{':'.$what}; } sub metadata_create_package_def { @@ -4505,22 +4472,22 @@ sub metadata_create_package_def { my ($pack,$name,$subp)=split(/\&/,$key); if ($subp eq 'default') { next; } - if (defined($metaentry{':packages'})) { - $metaentry{':packages'}.=','.$package; + if (defined($metacache{$uri}->{':packages'})) { + $metacache{$uri}->{':packages'}.=','.$package; } else { - $metaentry{':packages'}=$package; + $metacache{$uri}->{':packages'}=$package; } my $value=$packagetab{$key}; my $unikey; $unikey='parameter_0_'.$name; - $metaentry{':'.$unikey.'.part'}=0; + $metacache{$uri}->{':'.$unikey.'.part'}=0; $$metathesekeys{$unikey}=1; - unless (defined($metaentry{':'.$unikey.'.'.$subp})) { - $metaentry{':'.$unikey.'.'.$subp}=$value; + unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) { + $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value; } - if (defined($metaentry{':'.$unikey.'.default'})) { - $metaentry{':'.$unikey}= - $metaentry{':'.$unikey.'.default'}; + if (defined($metacache{$uri}->{':'.$unikey.'.default'})) { + $metacache{$uri}->{':'.$unikey}= + $metacache{$uri}->{':'.$unikey.'.default'}; } } @@ -5129,13 +5096,15 @@ sub repcopy_userfile { sub tokenwrapper { my $uri=shift; - $uri=~s/^http\:\/\/([^\/]+)//; - $uri=~s/^\///; + $uri=~s|^http\://([^/]+)||; + $uri=~s|^/||; $ENV{'user.environment'}=~/\/([^\/]+)\.id/; my $token=$1; - if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) { - &appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'}); - return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri. + my (undef,$udom,$uname,$file)=split('/',$uri,4); + if ($udom && $uname && $file) { + $file=~s|(\?\.*)*$||; + &appenv("userfile.$udom/$uname/$file" => $ENV{'request.course.id'}); + return 'http://'.$hostname{ &homeserver($uname,$udom)}.'/'.$uri. (($uri=~/\?/)?'&':'?').'token='.$token. '&tokenissued='.$perlvar{'lonHostID'}; } else { @@ -5303,13 +5272,13 @@ sub goodbye { #not converted to using infrastruture and probably shouldn't be &logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache))); #converted -# &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache))); + &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache))); &logthis(sprintf("%-20s is %s",'%homecache',scalar(%homecache))); &logthis(sprintf("%-20s is %s",'%titlecache',scalar(%titlecache))); &logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache))); #1.1 only &logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache))); - &logthis(sprintf("%-20s is %s",'%usectioncache',scalar(%usectioncache))); + &logthis(sprintf("%-20s is %s",'%getsectioncache',scalar(%getsectioncache))); &logthis(sprintf("%-20s is %s",'%courseresversioncache',scalar(%courseresversioncache))); &logthis(sprintf("%-20s is %s",'%resversioncache',scalar(%resversioncache))); &flushcourselogs(); @@ -5456,7 +5425,7 @@ BEGIN { } -$metacache=new Cache::Memcached({'servers'=>['127.0.0.1:11211']}); +%metacache=(); $processmarker='_'.time.'_'.$perlvar{'lonHostID'}; $dumpcount=0; @@ -5691,8 +5660,8 @@ X B: get user privileges =item * -X -B: finds the section of student in the +X +B: finds the section of student in the course $cname, return section name/number or '' for "not in course" and '-1' for "no section"