--- loncom/lonnet/perl/lonnet.pm 2002/06/24 19:41:41 1.243 +++ loncom/lonnet/perl/lonnet.pm 2002/07/30 21:20:27 1.257 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.243 2002/06/24 19:41:41 albertel Exp $ +# $Id: lonnet.pm,v 1.257 2002/07/30 21:20:27 www 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); @@ -708,6 +708,33 @@ 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; + my $token=&reply('tmpput:'.&escape($uri),$perlvar{'lonHostID'}); + return $uri.(($uri=~/\?/)?'&':'?'). + 'token='.$token.'&server='.$perlvar{'lonHostID'}; +} + +# --------------- Take an uploaded file and put it into the userfiles directory +# input: name of form element +# output: url of file in userspace + +sub userfileupload { + my $formname=shift; + my $fname=$ENV{'form.'.$formname.'.filename'}; + $fname=~s/\\/\//g; + $fname=~s/^.*\/([^\/]+)$/$1/; + unless ($fname) { return 'error: no uploaded file'; } + chop($ENV{'form.'.$formname}); + my $path='/userfiles/'.$ENV{'user.domain'}.'/'.$ENV{'user.name'}.'/'; +# +# FIXME: actually save file +# + return 'http;//'.$ENV{'SERVER_NAME'}.$path.$fname; +} + # ------------------------------------------------------------------------- Log sub log { @@ -1033,7 +1060,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}); @@ -1069,7 +1096,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=''; @@ -1113,7 +1140,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; @@ -1737,9 +1764,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 { @@ -1812,9 +1845,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; @@ -2158,51 +2193,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 @@ -2263,30 +2321,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 @@ -2391,7 +2445,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); } @@ -2440,7 +2494,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); } @@ -2627,7 +2681,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{$_}; } @@ -2655,7 +2709,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}; @@ -2693,7 +2747,7 @@ 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'}); } @@ -2709,7 +2763,7 @@ sub symbread { 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); } @@ -2725,7 +2779,7 @@ 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) { @@ -2742,7 +2796,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) { @@ -2757,6 +2811,8 @@ sub symbread { } } if ($realpossible!=1) { $syval=''; } + } else { + $syval=''; } } untie(%bighash) @@ -2941,11 +2997,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-"); + } + } } }