--- loncom/lonnet/perl/lonnet.pm 2002/05/22 13:56:43 1.231 +++ loncom/lonnet/perl/lonnet.pm 2002/08/05 21:02:07 1.261 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.231 2002/05/22 13:56:43 stredwic Exp $ +# $Id: lonnet.pm,v 1.261 2002/08/05 21:02:07 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -80,7 +80,7 @@ use vars qw(%perlvar %hostname %homecache %badServerCache %hostip %spareid %hostdom %libserv %pr %prp %metacache %packagetab %courselogs %accesshash $processmarker $dumpcount - %coursedombuf %coursehombuf %courseresdatacache); + %coursedombuf %coursehombuf %courseresdatacache %domaindescription); use IO::Socket; use GDBM_File; use Apache::Constants qw(:common :http); @@ -140,20 +140,20 @@ sub reply { unless (defined($hostname{$server})) { return 'no_such_host'; } my $answer=subreply($cmd,$server); if ($answer eq 'con_lost') { - sleep 5; - $answer=subreply($cmd,$server); - if ($answer eq 'con_lost') { - &logthis("Second attempt con_lost on $server"); - my $peerfile="$perlvar{'lonSockDir'}/$server"; - my $client=IO::Socket::UNIX->new(Peer =>"$peerfile", - Type => SOCK_STREAM, - Timeout => 10) - or return "con_lost"; - &logthis("Killing socket"); - print $client "close_connection_exit\n"; - sleep 5; - $answer=subreply($cmd,$server); - } + #sleep 5; + #$answer=subreply($cmd,$server); + #if ($answer eq 'con_lost') { + # &logthis("Second attempt con_lost on $server"); + # my $peerfile="$perlvar{'lonSockDir'}/$server"; + # my $client=IO::Socket::UNIX->new(Peer =>"$peerfile", + # Type => SOCK_STREAM, + # Timeout => 10) + # or return "con_lost"; + # &logthis("Killing socket"); + # print $client "close_connection_exit\n"; + #sleep 5; + # $answer=subreply($cmd,$server); + #} } if (($answer=~/^refused/) || ($answer=~/^rejected/)) { &logthis("WARNING:". @@ -708,6 +708,70 @@ sub ssi { return $response->content; } +# ------- Add a token to a remote URI's query string to vouch for access rights + +sub tokenwrapper { + my $uri=shift; + $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. + (($uri=~/\?/)?'&':'?').'token='.$token; + } else { + return '/adm/notfound.html'; + } +} + +# --------------- Take an uploaded file and put it into the userfiles directory +# input: name of form element, coursedoc=1 means this is for the course +# output: url of file in userspace + +sub userfileupload { + my ($formname,$coursedoc)=@_; + my $fname=$ENV{'form.'.$formname.'.filename'}; + $fname=~s/\\/\//g; + $fname=~s/^.*\/([^\/]+)$/$1/; + unless ($fname) { return 'error: no uploaded file'; } + chop($ENV{'form.'.$formname}); +# Create the directory if not present + my $docuname=''; + my $docudom=''; + my $docuhome=''; + if ($coursedoc) { + $docuname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'}; + $docudom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}; + $docuhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'}; + } else { + $docuname=$ENV{'user.name'}; + $docudom=$ENV{'user.domain'}; + $docuhome=$ENV{'user.home'}; + } + my $path=$docudom.'/'.$docuname.'/'; + my $filepath=$perlvar{'lonDocRoot'}; + my @parts=split(/\//,$filepath.'/userfiles/'.$path); + my $count; + for ($count=4;$count<=$#parts;$count++) { + $filepath.="/$parts[$count]"; + if ((-e $filepath)!=1) { + mkdir($filepath,0777); + } + } +# Save the file + { + my $fh=Apache::File->new('>'.$filepath.'/'.$fname); + print $fh $ENV{'form.'.$formname}; + } +# Notify homeserver to grep it +# +# FIXME - this still needs to happen +# +# Return the URL to it + return '/uploaded/'.$path.$fname; +} + # ------------------------------------------------------------------------- Log sub log { @@ -799,6 +863,7 @@ sub checkout { my $now=time; my $lonhost=$perlvar{'lonHostID'}; my $infostr=&escape( + 'CHECKOUTTOKEN&'. $tuname.'&'. $tudom.'&'. $tcrsid.'&'. @@ -848,7 +913,7 @@ sub checkin { $lonhost=~tr/A-Z/a-z/; my $dtoken=$ta.'_'.$hostip{$lonhost}.'_'.$tb; $dtoken=~s/\W/\_/g; - my ($tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)= + my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)= split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost))); unless (($tuname) && ($tudom)) { @@ -1032,7 +1097,7 @@ sub tmpreset { my %hash; if (tie(%hash,'GDBM_File', $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', - &GDBM_WRCREAT,0640)) { + &GDBM_WRCREAT(),0640)) { foreach my $key (keys %hash) { if ($key=~ /:$symb/) { delete($hash{$key}); @@ -1068,7 +1133,7 @@ sub tmpstore { my $path=$perlvar{'lonDaemons'}.'/tmp'; if (tie(%hash,'GDBM_File', $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', - &GDBM_WRCREAT,0640)) { + &GDBM_WRCREAT(),0640)) { $hash{"version:$symb"}++; my $version=$hash{"version:$symb"}; my $allkeys=''; @@ -1112,7 +1177,7 @@ sub tmprestore { my $path=$perlvar{'lonDaemons'}.'/tmp'; if (tie(%hash,'GDBM_File', $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', - &GDBM_READER,0640)) { + &GDBM_READER(),0640)) { my $version=$hash{"version:$symb"}; $returnhash{'version'}=$version; my $scope; @@ -1500,7 +1565,21 @@ sub allowed { # Free bre to public access if ($priv eq 'bre') { - if (&metadata($uri,'copyright') eq 'public') { return 'F'; } + my $copyright=&metadata($uri,'copyright'); + if ($copyright eq 'public') { return 'F'; } + if ($copyright eq 'priv') { + $uri=~/([^\/]+)\/([^\/]+)\//; + unless (($ENV{'user.name'} eq $2) && ($ENV{'user.domain'} eq $1)) { + return ''; + } + } + if ($copyright eq 'domain') { + $uri=~/([^\/]+)\/([^\/]+)\//; + unless (($ENV{'user.domain'} eq $1) || + ($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $1)) { + return ''; + } + } } my $thisallowed=''; @@ -1548,19 +1627,16 @@ sub allowed { # the course if ($ENV{'request.course.id'}) { + $courseprivid=$ENV{'request.course.id'}; if ($ENV{'request.course.sec'}) { $courseprivid.='/'.$ENV{'request.course.sec'}; } $courseprivid=~s/\_/\//; my $checkreferer=1; - my @uriparts=split(/\//,$uri); - my $filename=$uriparts[$#uriparts]; - my $pathname=$uri; - $pathname=~s/\/$filename$//; - if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ - /\&$filename\:([\d\|]+)\&/) { - $statecond=$1; + my ($match,$cond)=&is_on_map($uri); + if ($match) { + $statecond=$cond; if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} =~/$priv\&([^\:]*)/) { $thisallowed.=$1; @@ -1570,7 +1646,6 @@ sub allowed { if ($checkreferer) { my $refuri=$ENV{'httpref.'.$orguri}; - unless ($refuri) { foreach (keys %ENV) { if ($_=~/^httpref\..*\*/) { @@ -1584,15 +1659,12 @@ sub allowed { } } } + if ($refuri) { $refuri=&declutter($refuri); - my @uriparts=split(/\//,$refuri); - my $filename=$uriparts[$#uriparts]; - my $pathname=$refuri; - $pathname=~s/\/$filename$//; - if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ - /\&$filename\:([\d\|]+)\&/) { - my $refstatecond=$1; + my ($match,$cond)=&is_on_map($refuri); + if ($match) { + my $refstatecond=$cond; if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} =~/$priv\&([^\:]*)/) { $thisallowed.=$1; @@ -1651,7 +1723,7 @@ sub allowed { || ($ENV{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) { if ($ENV{$prefix.'res.'.$uri.'.lock.expire'}>time) { &log($ENV{'user.domain'},$ENV{'user.name'}, - $ENV{'user.host'}, + $ENV{'user.home'}, 'Locked by res: '.$priv.' for '.$uri.' due to '. $cdom.'/'.$cnum.'/'.$csec.' expire '. $ENV{$prefix.'priv.'.$priv.'.lock.expire'}); @@ -1662,7 +1734,7 @@ sub allowed { || ($ENV{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) { if ($ENV{'priv.'.$priv.'.lock.expire'}>time) { &log($ENV{'user.domain'},$ENV{'user.name'}, - $ENV{'user.host'}, + $ENV{'user.home'}, 'Locked by priv: '.$priv.' for '.$uri.' due to '. $cdom.'/'.$cnum.'/'.$csec.' expire '. $ENV{$prefix.'priv.'.$priv.'.lock.expire'}); @@ -1690,6 +1762,7 @@ sub allowed { if ($thisallowed=~/C/) { my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; + my $unamedom=$ENV{'user.name'}.':'.$ENV{'user.domain'}; if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'} =~/$rolecode/) { &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, @@ -1697,6 +1770,14 @@ sub allowed { $ENV{'request.course.id'}); return ''; } + + if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.users.denied'} + =~/$unamedom/) { + &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, + 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '. + $ENV{'request.course.id'}); + return ''; + } } # Resource preferences @@ -1720,9 +1801,15 @@ sub allowed { } } -# Restricted by state? +# Restricted by state or randomout? if ($thisallowed=~/X/) { + if ($ENV{'acc.randomout'}) { + my $symb=&symbread($uri,1); + if (($symb) && ($ENV{'acc.randomout'}=~/\&$symb\&/)) { + return ''; + } + } if (&condval($statecond)) { return '2'; } else { @@ -1733,6 +1820,23 @@ sub allowed { return 'F'; } +# --------------------------------------------------- Is a resource on the map? + +sub is_on_map { + my $uri=&declutter(shift); + my @uriparts=split(/\//,$uri); + my $filename=$uriparts[$#uriparts]; + my $pathname=$uri; + $pathname=~s/\/$filename$//; + my $match=($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ + /\&$filename\:([\d\|]+)\&/); + if ($match) { + return (1,$1); + } else { + return (0,0); + } +} + # ----------------------------------------------------------------- Define Role sub definerole { @@ -1778,9 +1882,11 @@ sub definerole { # ---------------- Make a metadata query against the network of library servers sub metadata_query { - my ($query,$custom,$customshow)=@_; + my ($query,$custom,$customshow,$server_array)=@_; my %rhash; - for my $server (keys %libserv) { + my @server_list = (defined($server_array) ? @$server_array + : keys(%libserv) ); + for my $server (@server_list) { unless ($custom or $customshow) { my $reply=&reply("querysend:".&escape($query),$server); $rhash{$server}=$reply; @@ -1795,6 +1901,64 @@ sub metadata_query { return \%rhash; } +# ----------------------------------------- Send log queries and wait for reply + +sub log_query { + my ($uname,$udom,$query,%filters)=@_; + my $uhome=&homeserver($uname,$udom); + if ($uhome eq 'no_host') { return 'error: no_host'; } + my $uhost=$hostname{$uhome}; + my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys %filters)); + my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command, + $uhome); + unless ($queryid=~/^$uhost\_/) { return 'error: '.$queryid; } + return get_query_reply($queryid); +} + +sub get_query_reply { + my $queryid=shift; + my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid; + my $reply=''; + for (1..100) { + sleep 2; + if (-e $replyfile.'.end') { + if (my $fh=Apache::File->new($replyfile)) { + $reply.=<$fh>; + $fh->close; + } else { return 'error: reply_file_error'; } + return &unescape($reply); + } + } + return 'timeout:'.$queryid; +} + +sub courselog_query { +# +# possible filters: +# url: url or symb +# username +# domain +# action: view, submit, grade +# start: timestamp +# end: timestamp +# + my (%filters)=@_; + unless ($ENV{'request.course.id'}) { return 'no_course'; } + if ($filters{'url'}) { + $filters{'url'}=&symbclean(&declutter($filters{'url'})); + $filters{'url'}=~s/\.(\w+)$/(\\.\\d+)*\\.$1/; + $filters{'url'}=~s/\.(\w+)\_\_\_/(\\.\\d+)*\\.$1/; + } + my $cname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'}; + my $cdom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}; + return &log_query($cname,$cdom,'courselog',%filters); +} + +sub userlog_query { + my ($uname,$udom,%filters)=@_; + return &log_query($uname,$udom,'userlog',%filters); +} + # ------------------------------------------------------------------ Plain Text sub plaintext { @@ -2066,51 +2230,74 @@ sub revokecustomrole { # ------------------------------------------------------------ Directory lister sub dirlist { - my $uri=shift; + my ($uri,$userdomain,$username,$alternateDirectoryRoot)=@_; + $uri=~s/^\///; $uri=~s/\/$//; - my ($res,$udom,$uname,@rest)=split(/\//,$uri); - if ($udom) { - if ($uname) { - my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/'.$uri, - homeserver($uname,$udom)); - return split(/:/,$listing); - } else { - my $tryserver; - my %allusers=(); - foreach $tryserver (keys %libserv) { - if ($hostdom{$tryserver} eq $udom) { - my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.$udom, - $tryserver); - if (($listing ne 'no_such_dir') && ($listing ne 'empty') - && ($listing ne 'con_lost')) { - foreach (split(/:/,$listing)) { - my ($entry,@stat)=split(/&/,$_); - $allusers{$entry}=1; + my ($udom, $uname); + (undef,$udom,$uname)=split(/\//,$uri); + if(defined($userdomain)) { + $udom = $userdomain; + } + if(defined($username)) { + $uname = $username; + } + + my $dirRoot = $perlvar{'lonDocRoot'}; + if(defined($alternateDirectoryRoot)) { + $dirRoot = $alternateDirectoryRoot; + $dirRoot =~ s/\/$//; + } + + if($udom) { + if($uname) { + my $listing=reply('ls:'.$dirRoot.'/'.$uri, + homeserver($uname,$udom)); + return split(/:/,$listing); + } elsif(!defined($alternateDirectoryRoot)) { + my $tryserver; + my %allusers=(); + foreach $tryserver (keys %libserv) { + if($hostdom{$tryserver} eq $udom) { + my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'. + $udom, $tryserver); + if (($listing ne 'no_such_dir') && ($listing ne 'empty') + && ($listing ne 'con_lost')) { + foreach (split(/:/,$listing)) { + my ($entry,@stat)=split(/&/,$_); + $allusers{$entry}=1; + } + } } - } - } - } - my $alluserstr=''; - foreach (sort keys %allusers) { - $alluserstr.=$_.'&user:'; - } - $alluserstr=~s/:$//; - return split(/:/,$alluserstr); - } - } else { - my $tryserver; - my %alldom=(); - foreach $tryserver (keys %libserv) { - $alldom{$hostdom{$tryserver}}=1; - } - my $alldomstr=''; - foreach (sort keys %alldom) { - $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:'; - } - $alldomstr=~s/:$//; - return split(/:/,$alldomstr); - } + } + my $alluserstr=''; + foreach (sort keys %allusers) { + $alluserstr.=$_.'&user:'; + } + $alluserstr=~s/:$//; + return split(/:/,$alluserstr); + } else { + my @emptyResults = (); + push(@emptyResults, 'missing user name'); + return split(':',@emptyResults); + } + } elsif(!defined($alternateDirectoryRoot)) { + my $tryserver; + my %alldom=(); + foreach $tryserver (keys %libserv) { + $alldom{$hostdom{$tryserver}}=1; + } + my $alldomstr=''; + foreach (sort keys %alldom) { + $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:'; + } + $alldomstr=~s/:$//; + return split(/:/,$alldomstr); + } else { + my @emptyResults = (); + push(@emptyResults, 'missing domain'); + return split(':',@emptyResults); + } } # -------------------------------------------------------- Value of a Condition @@ -2171,30 +2358,26 @@ sub courseresdata { my ($coursenum,$coursedomain,@which)=@_; my $coursehom=&homeserver($coursenum,$coursedomain); my $hashid=$coursenum.':'.$coursedomain; - unless (defined($courseresdatacache{$hashid.'.time'})) { - unless (time-$courseresdatacache{$hashid.'.time'}<300) { - my $coursehom=&homeserver($coursenum,$coursedomain); - if ($coursehom) { - my $dumpreply=&reply('dump:'.$coursedomain.':'.$coursenum. - ':resourcedata:.',$coursehom); - unless ($dumpreply=~/^error\:/) { - $courseresdatacache{$hashid.'.time'}=time; - $courseresdatacache{$hashid}=$dumpreply; - } - } - } + my $dodump=0; + if (!defined($courseresdatacache{$hashid.'.time'})) { + $dodump=1; + } else { + if (time-$courseresdatacache{$hashid.'.time'}>300) { $dodump=1; } } - my @pairs=split(/\&/,$courseresdatacache{$hashid}); - my %returnhash=(); - foreach (@pairs) { - my ($key,$value)=split(/=/,$_); - $returnhash{unescape($key)}=unescape($value); - } - my $item; - foreach $item (@which) { - if ($returnhash{$item}) { return $returnhash{$item}; } - } - return ''; + if ($dodump) { + my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum); + my ($tmp) = keys(%dumpreply); + if ($tmp !~ /^(con_lost|error|no_such_host)/i) { + $courseresdatacache{$hashid.'.time'}=time; + $courseresdatacache{$hashid}=\%dumpreply; + } + } + foreach my $item (@which) { + if ($courseresdatacache{$hashid}->{$item}) { + return $courseresdatacache{$hashid}->{$item}; + } + } + return ''; } # --------------------------------------------------------- Value of a Variable @@ -2267,7 +2450,11 @@ sub EXT { my %reply=&get($space,[$item]); return $reply{$item}; } - } elsif ($realm eq 'request') { + } elsif ($realm eq 'query') { +# ---------------------------------------------- pull stuff out of query string + &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},[$space]); + return $ENV{'form.'.$space}; + } elsif ($realm eq 'request') { # ------------------------------------------------------------- request.browser if ($space eq 'browser') { return $ENV{'browser.'.$qualifier}; @@ -2295,7 +2482,7 @@ sub EXT { my $section; if (($ENV{'user.name'} eq $uname) && ($ENV{'user.domain'} eq $udom)) { - $section={'request.course.sec'}; + $section=$ENV{'request.course.sec'}; } else { $section=&usection($udom,$uname,$courseid); } @@ -2344,7 +2531,7 @@ sub EXT { my $thisparm=''; if (tie(%parmhash,'GDBM_File', $ENV{'request.course.fn'}.'_parms.db', - &GDBM_READER,0640)) { + &GDBM_READER(),0640)) { $thisparm=$parmhash{$symbparm}; untie(%parmhash); } @@ -2516,6 +2703,7 @@ sub metadata { # the next is the end of "start tag" } } + &metadata_generate_part0(\%metathesekeys,\%metacache,$uri); $metacache{$uri.':keys'}=join(',',keys %metathesekeys); $metacache{$uri.':cachedtimestamp'}=time; # this is the end of "was not already recently cached @@ -2523,6 +2711,34 @@ sub metadata { return $metacache{$uri.':'.$what}; } +sub metadata_generate_part0 { + my ($metadata,$metacache,$uri) = @_; + my %allnames; + foreach my $metakey (sort keys %$metadata) { + if ($metakey=~/^parameter\_(.*)/) { + my $part=$$metacache{$uri.':'.$metakey.'.part'}; + my $name=$$metacache{$uri.':'.$metakey.'.name'}; + if (! exists($$metadata{'parameter_0_'.$name})) { + $allnames{$name}=$part; + } + } + } + foreach my $name (keys(%allnames)) { + $$metadata{"parameter_0_$name"}=1; + my $key="$uri:parameter_0_$name"; + $$metacache{"$key.part"}='0'; + $$metacache{"$key.name"}=$name; + $$metacache{"$key.type"}=$$metacache{$uri.':parameter_'. + $allnames{$name}.'_'.$name. + '.type'}; + my $olddis=$$metacache{$uri.':parameter_'.$allnames{$name}.'_'.$name. + '.display'}; + my $expr='\\[Part: '.$allnames{$name}.'\\]'; + $olddis=~s/$expr/\[Part: 0\]/; + $$metacache{"$key.display"}=$olddis; + } +} + # ------------------------------------------------- Update symbolic store links sub symblist { @@ -2531,7 +2747,7 @@ sub symblist { my %hash; if (($ENV{'request.course.fn'}) && (%newhash)) { if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', - &GDBM_WRCREAT,0640)) { + &GDBM_WRCREAT(),0640)) { foreach (keys %newhash) { $hash{declutter($_)}=$mapname.'___'.$newhash{$_}; } @@ -2559,7 +2775,7 @@ sub symbverify { my %bighash; my $okay=0; if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', - &GDBM_READER,0640)) { + &GDBM_READER(),0640)) { my $ids=$bighash{'ids_/res/'.$thisfn}; unless ($ids) { $ids=$bighash{'ids_/'.$thisfn}; @@ -2597,18 +2813,23 @@ sub symbclean { # ------------------------------------------------------ Return symb list entry sub symbread { - my $thisfn=shift; + my ($thisfn,$donotrecurse)=@_; +# no filename provided? try from environment unless ($thisfn) { if ($ENV{'request.symb'}) { return &symbclean($ENV{'request.symb'}); } $thisfn=$ENV{'request.filename'}; } +# is that filename actually a symb? Verify, clean, and return + if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) { + if (&symbverify($thisfn,$1)) { return &symbclean($thisfn); } + } $thisfn=declutter($thisfn); my %hash; my %bighash; my $syval=''; if (($ENV{'request.course.fn'}) && ($thisfn)) { if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', - &GDBM_READER,0640)) { + &GDBM_READER(),0640)) { $syval=$hash{$thisfn}; untie(%hash); } @@ -2624,12 +2845,16 @@ sub symbread { } else { # ------------------------------------------------------- Was not in symb table if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', - &GDBM_READER,0640)) { + &GDBM_READER(),0640)) { # ---------------------------------------------- Get ID(s) for current resource my $ids=$bighash{'ids_/res/'.$thisfn}; unless ($ids) { $ids=$bighash{'ids_/'.$thisfn}; } + unless ($ids) { +# alias? + $ids=$bighash{'mapalias_'.$thisfn}; + } if ($ids) { # ------------------------------------------------------------------- Has ID(s) my @possibilities=split(/\,/,$ids); @@ -2637,7 +2862,7 @@ sub symbread { # ----------------------------------------------- There is only one possibility my ($mapid,$resid)=split(/\./,$ids); $syval=declutter($bighash{'map_id_'.$mapid}).'___'.$resid; - } else { + } elsif (!$donotrecurse) { # ------------------------------------------ There is more than one possibility my $realpossible=0; foreach (@possibilities) { @@ -2652,6 +2877,8 @@ sub symbread { } } if ($realpossible!=1) { $syval=''; } + } else { + $syval=''; } } untie(%bighash) @@ -2720,10 +2947,10 @@ sub ireceipt { } sub receipt { - return &ireceipt($ENV{'user.name'},$ENV{'user.domain'}, - $ENV{'request.course.id'},&symbread()); + my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser(); + return &ireceipt($name,$domain,$courseid,$symb); } - + # ------------------------------------------------------------ Serves up a file # returns either the contents of the file or a -1 sub getfile { @@ -2776,6 +3003,7 @@ sub declutter { $thisfn=~s/^$perlvar{'lonDocRoot'}//; $thisfn=~s/^\///; $thisfn=~s/^res\///; + $thisfn=~s/\?.+$//; return $thisfn; } @@ -2835,11 +3063,18 @@ BEGIN { while (my $configline=<$config>) { chomp($configline); - my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); - $hostname{$id}=$name; - $hostdom{$id}=$domain; - $hostip{$id}=$ip; - if ($role eq 'library') { $libserv{$id}=$name; } + my ($id,$domain,$role,$name,$ip,$domdescr)=split(/:/,$configline); + if ($id && $domain && $role && $name && $ip) { + $hostname{$id}=$name; + $hostdom{$id}=$domain; + $hostip{$id}=$ip; + if ($domdescr) { $domaindescription{$domain}=$domdescr; } + if ($role eq 'library') { $libserv{$id}=$name; } + } else { + if ($configline) { + &logthis("Skipping hosts.tab line -$configline-"); + } + } } } @@ -2909,75 +3144,105 @@ $readit=1; 1; __END__ +=pod + =head1 NAME -Apache::lonnet - TCP networking package +Apache::lonnet - Subroutines to ask questions about things in the network. =head1 SYNOPSIS -Invoked by other LON-CAPA modules. +Invoked by other LON-CAPA modules, when they need to talk to or about objects in the network. &Apache::lonnet::SUBROUTINENAME(ARGUMENTS); +Common parameters: + +=over 4 + +=item * + +$uname : an internal username (if $cname expecting a course Id specifically) + +=item * + +$udom : a domain (if $cdom expecting a course's domain specifically) + +=item * + +$symb : a resource instance identifier + +=item * + +$namespace : the name of a .db file that contains the data needed or +being set. + +=back + =head1 INTRODUCTION This module provides subroutines which interact with the -lonc/lond (TCP) network layer of LON-CAPA. +lonc/lond (TCP) network layer of LON-CAPA. And Can be used to ask about +- classes +- users +- resources + +For many of these objects you can also use this to store data about +them or modify them in various ways. This is part of the LearningOnline Network with CAPA project described at http://www.lon-capa.org. -=head1 HANDLER SUBROUTINE - -There is no handler routine for this module. - -=head1 OTHER SUBROUTINES +=head1 RETURN MESSAGES =over 4 =item * -logtouch() : make sure the logfile, lonnet.log, exists +con_lost : unable to contact remote host =item * -logthis() : append message to lonnet.log +con_delayed : unable to contact remote host, message will be delivered +when the connection is brought back up =item * -logperm() : append a permanent message to lonnet.perm.log +con_failed : unable to contact remote host and unable to save message +for later delivery =item * -subreply() : non-critical communication, called by &reply +error: : an error a occured, a description of the error follows the : =item * -reply() : makes two attempts to pass message; logs refusals and rejections +no_such_host : unable to fund a host associated with the user/domain +that was requested -=item * +=back -reconlonc() : tries to reconnect lonc client processes. +=head1 PUBLIC SUBROUTINES -=item * +=head2 Session Environment Functions -critical() : passes a critical message to another server; if cannot get -through then place message in connection buffer +=over 4 =item * -appenv(%hash) : read in current user environment, append new environment -values to make new user environment +appenv(%hash) : the value of %hash is written to the user envirnoment +file, and will be restored for each access this user makes during this +session, also modifies the %ENV for the current process =item * -delenv($varname) : read in current user environment, remove all values -beginning with $varname, write new user environment (note: flock is used -to prevent conflicting shared read/writes with file) +delenv($regexp) : 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. -=item * +=back -spareserver() : find server with least workload from spare.tab +=head2 User Information + +=over 4 =item * @@ -2987,16 +3252,19 @@ authentication scheme =item * authenticate($uname,$upass,$udom) : try to authenticate user from domain's lib -servers (first use the current one) +servers (first use the current one), $upass should be the users password =item * -homeserver($uname,$udom) : find the homebase for a user from domain's lib -servers +homeserver($uname,$udom) : find the server which has the user's +directory and files (there must be only one), this caches the answer, +and also caches if there is a borken connection. =item * -idget($udom,@ids) : find the usernames behind a list of IDs (returns hash: +idget($udom,@ids) : find the usernames behind a list of IDs (IDs are a +unique resource in a domain, there must be only 1 ID per username, and +only 1 username per ID in a specific domain) (returns hash: id=>name,id=>name) =item * @@ -3010,226 +3278,332 @@ idput($udom,%ids) : store away a list of =item * -usection($domain,$user,$courseid) : output of section name/number or '' for -"not in course" and '-1' for "no section" +rolesinit($udom,$username,$authhost) : get user privileges =item * -userenvironment($domain,$user,$what) : puts out any environment parameter -for a user +usection($udom,$uname,$cname) : finds the section of student in the +course $cname, return section name/number or '' for "not in course" +and '-1' for "no section" =item * -subscribe($fname) : subscribe to a resource, return URL if possible +userenvironment($udom,$uname,@what) : gets the values of the keys +passed in @what from the requested user's environment, returns a hash + +=back + +=head2 User Roles + +=over 4 =item * -repcopy($filename) : replicate file +allowed($priv,$uri) : check for a user privilege; returns codes for allowed +actions + F: full access + U,I,K: authentication modes (cxx only) + '': forbidden + 1: user needs to choose course + 2: browse allowed =item * -ssi($url,%hash) : server side include, does a complete request cycle on url to -localhost, posts hash +definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom +role rolename set privileges in format of lonTabs/roles.tab for system, domain, +and course level =item * -log($domain,$name,$home,$message) : write to permanent log for user; use -critical subroutine +plaintext($short) : return value in %prp hash (rolesplain.tab); plain text +explanation of a user role term + +=back + +=head2 User Modification + +=over 4 =item * -flushcourselogs() : flush (save) buffer logs and access logs +assignrole($udom,$uname,$url,$role,$end,$start) : 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") =item * -courselog($what) : save message for course in hash +changepass($uname,$udom,$currentpass,$newpass,$server) : attempts to +change a users, password, possible return values are: ok, +pwchange_failure, non_authorized, auth_mode_error, unknown_user, +refused =item * -courseacclog($what) : save message for course using &courselog(). Perform -special processing for specific resource types (problems, exams, quizzes, etc). +modifyuserauth($udom,$uname,$umode,$upass) : modify user authentication =item * -countacc($url) : count the number of accesses to a given URL +modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) : +modify user =item * -sub checkout($symb,$tuname,$tudom,$tcrsid) : check out an item +modifystudent($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,$end,$start) : modify student =item * -sub checkin($token) : check in an item +assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start) : assign +custom role; give a custom role to a user for the level given by URL. Specify +name and domain of role author, and role name =item * -sub expirespread($uname,$udom,$stype,$usymb) : set expire date for spreadsheet +revokerole($udom,$uname,$url,$role) : revoke a role for url =item * -devalidate($symb) : devalidate spreadsheets +revokecustomrole($udom,$uname,$url,$role) : revoke a custom role + +=back + +=head2 Course Infomation + +=over 4 =item * -hash2str(%hash) : convert a hash into a string complete with escaping and '=' -and '&' separators, supports elements that are arrayrefs and hashrefs +coursedescription($courseid) : course description =item * -hashref2str($hashref) : convert a hashref into a string complete with -escaping and '=' and '&' separators, supports elements that are -arrayrefs and hashrefs +courseresdata($coursenum,$coursedomain,@which) : request for current +parameter setting for a specific course, @what should be a list of +parameters to ask about. This routine caches answers for 5 minutes. + +=back + +=head2 Course Modification + +=over 4 =item * -arrayref2str($arrayref) : convert an arrayref into a string complete -with escaping and '&' separators, supports elements that are arrayrefs -and hashrefs +writecoursepref($courseid,%prefs) : write preferences (environment +database) for a course =item * -str2hash($string) : convert string to hash using unescaping and -splitting on '=' and '&', supports elements that are arrayrefs and -hashrefs +createcourse($udom,$description,$url) : make/modify course + +=back + +=head2 Resource Subroutines + +=over 4 =item * -str2array($string) : convert string to hash using unescaping and -splitting on '&', supports elements that are arrayrefs and hashrefs +subscribe($fname) : subscribe to a resource, returns URL if possible (probably should use repcopy instead) =item * -tmpreset($symb,$namespace,$domain,$stuname) : temporary storage +repcopy($filename) : subscribes to the requested file, and attempts to +replicate from the owning library server, Might return +HTTP_SERVICE_UNAVAILABLE, HTTP_NOT_FOUND, FORBIDDEN, OK, or +HTTP_BAD_REQUEST, also attempts to grab the metadata for the +resource. Expects the local filesystem pathname +(/home/httpd/html/res/....) + +=back + +=head2 Resource Information + +=over 4 =item * -tmprestore($symb,$namespace,$domain,$stuname) : temporary restore +EXT($varname,$symb,$udom,$uname) : evaluates and returns the value of +a vairety of different possible values, $varname should be a request +string, and the other parameters can be used to specify who and what +one is asking about. + +Possible values for $varname are environment.lastname (or other item +from the envirnment hash), user.name (or someother aspect about the +user), resource.0.maxtries (or some other part and parameter of a +resource) =item * -store($storehash,$symb,$namespace,$domain,$stuname) : stores hash permanently -for this url; hashref needs to be given and should be a \%hashname; the -remaining args aren't required and if they aren't passed or are '' they will -be derived from the ENV +directcondval($number) : get current value of a condition; reads from a state +string =item * -cstore($storehash,$symb,$namespace,$domain,$stuname) : same as store but -uses critical subroutine +condval($condidx) : value of condition index based on state =item * -restore($symb,$namespace,$domain,$stuname) : returns hash for this symb; -all args are optional +metadata($uri,$what,$liburi,$prefix,$depthcount) : request a +resource's metadata, $what should be either a specific key, or either +'keys' (to get a list of possible keys) or 'packages' to get a list of +packages that this resource currently uses, the last 3 arguments are only used internally for recursive metadata. + +this function automatically caches all requests =item * -coursedescription($courseid) : course description +metadata_query($query,$custom,$customshow) : make a metadata query against the +network of library servers; returns file handle of where SQL and regex results +will be stored for query =item * -rolesinit($domain,$username,$authhost) : get user privileges +symbread($filename) : return symbolic list entry (filename argument optional); +returns the data handle =item * -get($namespace,$storearr,$udomain,$uname) : returns hash with keys from array -reference filled in from namesp ($udomain and $uname are optional) +symbverify($symb,$thisfn) : verifies that $symb actually exists and is +a possible symb for the URL in $thisfn, returns a 1 on success, 0 on +failure, user must be in a course, as it assumes the existance of the +course initi hash, and uses $ENV('request.course.id'} + =item * -del($namespace,$storearr,$udomain,$uname) : deletes keys out of array from -namesp ($udomain and $uname are optional) +symbclean($symb) : removes versions numbers from a symb, returns the +cleaned symb =item * -dump($namespace,$udomain,$uname,$regexp) : -dumps the complete (or key matching regexp) namespace into a hash -($udomain, $uname and $regexp are optional) +is_on_map($uri) : checks if the $uri is somewhere on the current +course map, user must be in a course for it to work. =item * -put($namespace,$storehash,$udomain,$uname) : stores hash in namesp -($udomain and $uname are optional) +numval($salt) : return random seed value (addend for rndseed) =item * -cput($namespace,$storehash,$udomain,$uname) : critical put -($udomain and $uname are optional) +rndseed($symb,$courseid,$udom,$uname) : create a random sum; returns +a random seed, all arguments are optional, if they aren't sent it uses the +environment to derive them. Note: if symb isn't sent and it can't get one +from &symbread it will use the current time as its return value =item * -eget($namespace,$storearr,$udomain,$uname) : returns hash with keys from array -reference filled in from namesp (encrypts the return communication) -($udomain and $uname are optional) +ireceipt($funame,$fudom,$fucourseid,$fusymb) : return unique, +unfakeable, receipt =item * -allowed($priv,$uri) : check for a user privilege; returns codes for allowed -actions - F: full access - U,I,K: authentication modes (cxx only) - '': forbidden - 1: user needs to choose course - 2: browse allowed +receipt() : API to ireceipt working off of ENV values; given out to users =item * -definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom -role rolename set privileges in format of lonTabs/roles.tab for system, domain, -and course level +countacc($url) : count the number of accesses to a given URL =item * -metadata_query($query,$custom,$customshow) : make a metadata query against the -network of library servers; returns file handle of where SQL and regex results -will be stored for query +checkout($symb,$tuname,$tudom,$tcrsid) : creates a record of a user having looked at an item, most likely printed out or otherwise using a resource =item * -plaintext($short) : return value in %prp hash (rolesplain.tab); plain text -explanation of a user role term +checkin($token) : updates that a resource has beeen returned (a hard copy version for instance) and returns the data that $token was Checkout with ($symb, $tuname, $tudom, and $tcrsid) =item * -assignrole($udom,$uname,$url,$role,$end,$start) : 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") +expirespread($uname,$udom,$stype,$usymb) : set expire date for spreadsheet =item * -modifyuserauth($udom,$uname,$umode,$upass) : modify user authentication +devalidate($symb) : devalidate temporary spreadsheet calculations, +forcing spreadsheet to reevaluate the resource scores next time. + +=back + +=head2 Storing/Retreiving Data + +=over 4 =item * -modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) : -modify user +store($storehash,$symb,$namespace,$udom,$uname) : stores hash permanently +for this url; hashref needs to be given and should be a \%hashname; the +remaining args aren't required and if they aren't passed or are '' they will +be derived from the ENV =item * -modifystudent($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, -$end,$start) : modify student +cstore($storehash,$symb,$namespace,$udom,$uname) : same as store but +uses critical subroutine =item * -writecoursepref($courseid,%prefs) : write preferences for a course +restore($symb,$namespace,$udom,$uname) : returns hash for this symb; +all args are optional =item * -createcourse($udom,$description,$url) : make/modify course +tmpstore($storehash,$symb,$namespace,$udom,$uname) : storage that +works very similar to store/cstore, but all data is stored in a +temporary location and can be reset using tmpreset, $storehash should +be a hash reference, returns nothing on success =item * -assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start) : assign -custom role; give a custom role to a user for the level given by URL. Specify -name and domain of role author, and role name +tmprestore($symb,$namespace,$udom,$uname) : storage that works very +similar to restore, but all data is stored in a temporary location and +can be reset using tmpreset. Returns a hash of values on success, +error string otherwise. =item * -revokerole($udom,$uname,$url,$role) : revoke a role for url +tmpreset($symb,$namespace,$udom,$uname) : temporary storage reset, +deltes all keys for $symb form the temporary storage hash. =item * -revokecustomrole($udom,$uname,$url,$role) : revoke a custom role +get($namespace,$storearr,$udom,$uname) : returns hash with keys from array +reference filled in from namesp ($udom and $uname are optional) + +=item * + +del($namespace,$storearr,$udom,$uname) : deletes keys out of array from +namesp ($udom and $uname are optional) + +=item * + +dump($namespace,$udom,$uname,$regexp) : +dumps the complete (or key matching regexp) namespace into a hash +($udom, $uname and $regexp are optional) + +=item * + +put($namespace,$storehash,$udom,$uname) : stores hash in namesp +($udom and $uname are optional) + +=item * + +cput($namespace,$storehash,$udom,$uname) : critical put +($udom and $uname are optional) + +=item * + +eget($namespace,$storearr,$udom,$uname) : returns hash with keys from array +reference filled in from namesp (encrypts the return communication) +($udom and $uname are optional) + +=item * + +log($udom,$name,$home,$message) : write to permanent log for user; use +critical subroutine + +=back + +=head2 Network Status Functions + +=over 4 =item * @@ -3237,60 +3611,94 @@ dirlist($uri) : return directory list ba =item * -directcondval($number) : get current value of a condition; reads from a state -string +spareserver() : find server with least workload from spare.tab + +=back + +=head2 Apache Request + +=over 4 =item * -condval($condidx) : value of condition index based on state +ssi($url,%hash) : server side include, does a complete request cycle on url to +localhost, posts hash + +=back + +=head2 Data to String to Data + +=over 4 =item * -EXT($varname,$symbparm) : value of a variable +hash2str(%hash) : convert a hash into a string complete with escaping and '=' +and '&' separators, supports elements that are arrayrefs and hashrefs =item * -metadata($uri,$what,$liburi,$prefix,$depthcount) : get metadata; returns the -metadata entry for a file; entry='keys', returns a comma separated list of keys +hashref2str($hashref) : convert a hashref into a string complete with +escaping and '=' and '&' separators, supports elements that are +arrayrefs and hashrefs =item * -symblist($mapname,%newhash) : update symbolic storage links +arrayref2str($arrayref) : convert an arrayref into a string complete +with escaping and '&' separators, supports elements that are arrayrefs +and hashrefs =item * -symbread($filename) : return symbolic list entry (filename argument optional); -returns the data handle +str2hash($string) : convert string to hash using unescaping and +splitting on '=' and '&', supports elements that are arrayrefs and +hashrefs =item * -numval($salt) : return random seed value (addend for rndseed) +str2array($string) : convert string to hash using unescaping and +splitting on '&', supports elements that are arrayrefs and hashrefs + +=back + +=head2 Logging Routines + +=over 4 + +These routines allow one to make log messages in the lonnet.log and +lonnet.perm logfiles. =item * -rndseed($symb,$courseid,$domain,$username) : create a random sum; returns -a random seed, all arguments are optional, if they aren't sent it uses the -environment to derive them. Note: if symb isn't sent and it can't get one -from &symbread it will use the current time as its return value +logtouch() : make sure the logfile, lonnet.log, exists =item * -ireceipt($funame,$fudom,$fucourseid,$fusymb) : return unique, -unfakeable, receipt +logthis() : append message to the normal lonnet.log file, it gets +preiodically rolled over and deleted. =item * -receipt() : API to ireceipt working off of ENV values; given out to users +logperm() : append a permanent message to lonnet.perm.log, this log +file never gets deleted by any automated portion of the system, only +messages of critical importance should go in here. + +=back + +=head2 General File Helper Routines + +=over 4 =item * -getfile($file) : serves up a file, returns the contents of a file or -1; -replicates and subscribes to the file +getfile($file) : returns the entire contents of a file or -1; it +properly subscribes to and replicates the file if neccessary. =item * -filelocation($dir,$file) : returns file system location of a file based on URI; -meant to be "fairly clean" absolute reference, $dir is a directory that relative $file lookups are to looked in ($dir of /a/dir and a file of ../bob will become /a/bob) +filelocation($dir,$file) : returns file system location of a file +based on URI; meant to be "fairly clean" absolute reference, $dir is a +directory that relative $file lookups are to looked in ($dir of /a/dir +and a file of ../bob will become /a/bob) =item * @@ -3301,6 +3709,12 @@ filelocation except for hrefs declutter() : declutters URLs (remove docroot, beginning slashes, 'res' etc) +=back + +=head2 HTTP Helper Routines + +=over 4 + =item * escape() : unpack non-word characters into CGI-compatible hex codes @@ -3309,6 +3723,52 @@ escape() : unpack non-word characters in unescape() : pack CGI-compatible hex codes into actual non-word ASCII character +=back + +=head1 PRIVATE SUBROUTINES + +=head2 Underlying communication routines (Shouldn't call) + +=over 4 + +=item * + +subreply() : tries to pass a message to lonc, returns con_lost if incapable + +=item * + +reply() : uses subreply to send a message to remote machine, logs all failures + +=item * + +critical() : passes a critical message to another server; if cannot +get through then place message in connection buffer directory and +returns con_delayed, if incapable of saving message, returns +con_failed + +=item * + +reconlonc() : tries to reconnect lonc client processes. + +=back + +=head2 Resource Access Logging + +=over 4 + +=item * + +flushcourselogs() : flush (save) buffer logs and access logs + +=item * + +courselog($what) : save message for course in hash + +=item * + +courseacclog($what) : save message for course using &courselog(). Perform +special processing for specific resource types (problems, exams, quizzes, etc). + =item * goodbye() : flush course logs and log shutting down; it is called in srm.conf @@ -3316,4 +3776,14 @@ as a PerlChildExitHandler =back +=head2 Other + +=over 4 + +=item * + +symblist($mapname,%newhash) : update symbolic storage links + +=back + =cut