--- loncom/lonnet/perl/lonnet.pm 2002/04/04 20:06:20 1.206 +++ loncom/lonnet/perl/lonnet.pm 2002/08/23 21:31:09 1.273 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.206 2002/04/04 20:06:20 matthew Exp $ +# $Id: lonnet.pm,v 1.273 2002/08/23 21:31:09 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -77,14 +77,14 @@ use Apache::File; use LWP::UserAgent(); use HTTP::Headers; use vars -qw(%perlvar %hostname %homecache %hostip %spareid %hostdom +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); -use HTML::TokeParser; +use HTML::LCParser; use Fcntl qw(:flock); my $readit; @@ -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:". @@ -481,19 +481,23 @@ sub authenticate { # ---------------------- Find the homebase for a user from domain's lib servers sub homeserver { - my ($uname,$udom)=@_; - + my ($uname,$udom,$ignoreBadCache)=@_; my $index="$uname:$udom"; - if ($homecache{$index}) { return "$homecache{$index}"; } - + if ($homecache{$index}) { + return "$homecache{$index}"; + } my $tryserver; foreach $tryserver (keys %libserv) { + next if ($ignoreBadCache ne 'true' && + exists($badServerCache{$tryserver})); if ($hostdom{$tryserver} eq $udom) { my $answer=reply("home:$udom:$uname",$tryserver); if ($answer eq 'found') { - $homecache{$index}=$tryserver; + $homecache{$index}=$tryserver; return $tryserver; - } + } elsif ($answer eq 'no_host') { + $badServerCache{$tryserver}=1; + } } } return 'no_host'; @@ -604,6 +608,18 @@ sub userenvironment { return %returnhash; } +# -------------------------------------------------------------------- New chat + +sub chatsend { + my ($newentry,$anon)=@_; + my $cnum=$ENV{'course.'.$ENV{'request.course.id'}.'.num'}; + my $cdom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}; + my $chome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'}; + &reply('chatsend:'.$cdom.':'.$cnum.':'. + &escape($ENV{'user.domain'}.':'.$ENV{'user.name'}.':'.$anon.':'. + &escape($newentry)),$chome); +} + # ----------------------------- Subscribe to a resource, return URL if possible sub subscribe { @@ -627,6 +643,7 @@ sub subscribe { sub repcopy { my $filename=shift; $filename=~s/\/+/\//g; + if ($filename=~/^\/home\/httpd\/html\/adm\//) { return OK; } my $transname="$filename.in.transfer"; if ((-e $filename) || (-e $transname)) { return OK; } my $remoteurl=subscribe($filename); @@ -703,6 +720,81 @@ 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'}; + } + return + &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname); +} + +sub finishuserfileupload { + my ($docuname,$docudom,$docuhome,$formname,$fname)=@_; + 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 +# + if +(&reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,$docuhome) eq 'ok') + { +# +# Return the URL to it + return '/uploaded/'.$path.$fname; + } else { + return '/adm/notfound.html'; + } +} + # ------------------------------------------------------------------------- Log sub log { @@ -716,7 +808,6 @@ sub flushcourselogs { &logthis('Flushing course log buffers'); foreach (keys %courselogs) { my $crsid=$_; - &logthis(":$crsid:$coursehombuf{$crsid}"); if (&reply('log:'.$coursedombuf{$crsid}.':'. &escape($courselogs{$crsid}), $coursehombuf{$crsid}) eq 'ok') { @@ -735,7 +826,7 @@ sub flushcourselogs { my $entry=$_; $entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/; my %temphash=($entry => $accesshash{$entry}); - if (&Apache::lonnet::put('resevaldata',\%temphash,$1,$2) eq 'ok') { + if (&Apache::lonnet::put('nohist_resevaldata',\%temphash,$1,$2) eq 'ok') { delete $accesshash{$entry}; } } @@ -795,6 +886,7 @@ sub checkout { my $now=time; my $lonhost=$perlvar{'lonHostID'}; my $infostr=&escape( + 'CHECKOUTTOKEN&'. $tuname.'&'. $tudom.'&'. $tcrsid.'&'. @@ -844,7 +936,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)) { @@ -914,97 +1006,195 @@ sub devalidate { } } +sub get_scalar { + my ($string,$end) = @_; + my $value; + if ($$string =~ s/^([^&]*?)($end)/$2/) { + $value = $1; + } elsif ($$string =~ s/^([^&]*?)&//) { + $value = $1; + } + return &unescape($value); +} + +sub array2str { + my (@array) = @_; + my $result=&arrayref2str(\@array); + $result=~s/^__ARRAY_REF__//; + $result=~s/__END_ARRAY_REF__$//; + return $result; +} + sub arrayref2str { my ($arrayref) = @_; - my $result='_ARRAY_REF__'; + my $result='__ARRAY_REF__'; foreach my $elem (@$arrayref) { - if (ref($elem) eq 'ARRAY') { - $result.=&escape(&arrayref2str($elem)).'&'; - } elsif (ref($elem) eq 'HASH') { - $result.=&escape(&hashref2str($elem)).'&'; - } elsif (ref($elem)) { - &logthis("Got a ref of ".(ref($elem))." skipping."); + if(ref($elem) eq 'ARRAY') { + $result.=&arrayref2str($elem).'&'; + } elsif(ref($elem) eq 'HASH') { + $result.=&hashref2str($elem).'&'; + } elsif(ref($elem)) { + #print("Got a ref of ".(ref($elem))." skipping."); } else { $result.=&escape($elem).'&'; } } $result=~s/\&$//; + $result .= '__END_ARRAY_REF__'; return $result; } sub hash2str { my (%hash) = @_; my $result=&hashref2str(\%hash); - $result=~s/^_HASH_REF__//; + $result=~s/^__HASH_REF__//; + $result=~s/__END_HASH_REF__$//; return $result; } sub hashref2str { my ($hashref)=@_; - my $result='_HASH_REF__'; + my $result='__HASH_REF__'; foreach (keys(%$hashref)) { if (ref($_) eq 'ARRAY') { - $result.=&escape(&arrayref2str($_)).'='; + $result.=&arrayref2str($_).'='; } elsif (ref($_) eq 'HASH') { - $result.=&escape(&hashref2str($_)).'='; + $result.=&hashref2str($_).'='; } elsif (ref($_)) { - &logthis("Got a ref of ".(ref($_))." skipping."); + $result.='='; + #print("Got a ref of ".(ref($_))." skipping."); } else { - $result.=&escape($_).'='; + if ($_) {$result.=&escape($_).'=';} else { last; } } - if (ref($$hashref{$_}) eq 'ARRAY') { - $result.=&escape(&arrayref2str($$hashref{$_})).'&'; - } elsif (ref($$hashref{$_}) eq 'HASH') { - $result.=&escape(&hashref2str($$hashref{$_})).'&'; - } elsif (ref($$hashref{$_})) { - &logthis("Got a ref of ".(ref($$hashref{$_}))." skipping."); + if(ref($hashref->{$_}) eq 'ARRAY') { + $result.=&arrayref2str($hashref->{$_}).'&'; + } elsif(ref($hashref->{$_}) eq 'HASH') { + $result.=&hashref2str($hashref->{$_}).'&'; + } elsif(ref($hashref->{$_})) { + $result.='&'; + #print("Got a ref of ".(ref($hashref->{$_}))." skipping."); } else { - $result.=&escape($$hashref{$_}).'&'; + $result.=&escape($hashref->{$_}).'&'; } } $result=~s/\&$//; + $result .= '__END_HASH_REF__'; return $result; } sub str2hash { + my ($string)=@_; + my ($hash)=&str2hashref('__HASH_REF__'.$string.'__END_HASH_REF__'); + return %$hash; +} + +sub str2hashref { my ($string) = @_; - my %returnhash; - foreach (split(/\&/,$string)) { - my ($name,$value)=split(/\=/,$_); - $name=&unescape($name); - $value=&unescape($value); - if ($value =~ /^_HASH_REF__/) { - $value =~ s/^_HASH_REF__//; - my %hash=&str2hash($value); - $value=\%hash; - } elsif ($value =~ /^_ARRAY_REF__/) { - $value =~ s/^_ARRAY_REF__//; - my @array=&str2array($value); - $value=\@array; - } - $returnhash{$name}=$value; + + my %hash; + + if($string !~ /^__HASH_REF__/) { + if (! ($string eq '' || !defined($string))) { + $hash{'error'}='Not hash reference'; + } + return (\%hash, $string); + } + + $string =~ s/^__HASH_REF__//; + + while($string !~ /^__END_HASH_REF__/) { + #key + my $key=''; + if($string =~ /^__HASH_REF__/) { + ($key, $string)=&str2hashref($string); + if(defined($key->{'error'})) { + $hash{'error'}='Bad data'; + return (\%hash, $string); + } + } elsif($string =~ /^__ARRAY_REF__/) { + ($key, $string)=&str2arrayref($string); + if($key->[0] eq 'Array reference error') { + $hash{'error'}='Bad data'; + return (\%hash, $string); + } + } else { + $string =~ s/^(.*?)=//; + $key=&unescape($1); + } + $string =~ s/^=//; + + #value + my $value=''; + if($string =~ /^__HASH_REF__/) { + ($value, $string)=&str2hashref($string); + if(defined($value->{'error'})) { + $hash{'error'}='Bad data'; + return (\%hash, $string); + } + } elsif($string =~ /^__ARRAY_REF__/) { + ($value, $string)=&str2arrayref($string); + if($value->[0] eq 'Array reference error') { + $hash{'error'}='Bad data'; + return (\%hash, $string); + } + } else { + $value=&get_scalar(\$string,'__END_HASH_REF__'); + } + $string =~ s/^&//; + + $hash{$key}=$value; } - return (%returnhash); + + $string =~ s/^__END_HASH_REF__//; + + return (\%hash, $string); } sub str2array { + my ($string)=@_; + my ($array)=&str2arrayref('__ARRAY_REF__'.$string.'__END_ARRAY_REF__'); + return @$array; +} + +sub str2arrayref { my ($string) = @_; - my @returnarray; - foreach my $value (split(/\&/,$string)) { - $value=&unescape($value); - if ($value =~ /^_HASH_REF__/) { - $value =~ s/^_HASH_REF__//; - my %hash=&str2hash($value); - $value=\%hash; - } elsif ($value =~ /^_ARRAY_REF__/) { - $value =~ s/^_ARRAY_REF__//; - my @array=&str2array($value); - $value=\@array; - } - push(@returnarray,$value); + my @array; + + if($string !~ /^__ARRAY_REF__/) { + if (! ($string eq '' || !defined($string))) { + $array[0]='Array reference error'; + } + return (\@array, $string); } - return (@returnarray); + + $string =~ s/^__ARRAY_REF__//; + + while($string !~ /^__END_ARRAY_REF__/) { + my $value=''; + if($string =~ /^__HASH_REF__/) { + ($value, $string)=&str2hashref($string); + if(defined($value->{'error'})) { + $array[0] ='Array reference error'; + return (\@array, $string); + } + } elsif($string =~ /^__ARRAY_REF__/) { + ($value, $string)=&str2arrayref($string); + if($value->[0] eq 'Array reference error') { + $array[0] ='Array reference error'; + return (\@array, $string); + } + } else { + $value=&get_scalar(\$string,'__END_ARRAY_REF__'); + } + $string =~ s/^&//; + + push(@array, $value); + } + + $string =~ s/^__END_ARRAY_REF__//; + + return (\@array, $string); } # -------------------------------------------------------------------Temp Store @@ -1028,7 +1218,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}); @@ -1064,7 +1254,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=''; @@ -1108,7 +1298,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; @@ -1139,6 +1329,7 @@ sub store { if ($stuname) { $home=&homeserver($stuname,$domain); } + $symb=&symbclean($symb); if (!$symb) { unless ($symb=&symbread()) { return ''; } } &devalidate($symb); @@ -1169,6 +1360,7 @@ sub cstore { if ($stuname) { $home=&homeserver($stuname,$domain); } + $symb=&symbclean($symb); if (!$symb) { unless ($symb=&symbread()) { return ''; } } &devalidate($symb); @@ -1204,7 +1396,7 @@ sub restore { if (!$symb) { unless ($symb=escape(&symbread())) { return ''; } } else { - $symb=&escape($symb); + $symb=&escape(&symbclean($symb)); } if (!$namespace) { unless ($namespace=$ENV{'request.course.id'}) { @@ -1249,7 +1441,7 @@ sub coursedescription { while (my ($name,$value) = each %returnhash) { $envhash{'course.'.$normalid.'.'.$name}=$value; } - $returnhash{'url'}='/res/'.declutter($returnhash{'url'}); + $returnhash{'url'}=&clutter($returnhash{'url'}); $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'. $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum; $envhash{'course.'.$normalid.'.last_cache'}=time; @@ -1377,6 +1569,9 @@ sub get { my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome); my @pairs=split(/\&/,$rep); + if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) { + return @pairs; + } my %returnhash=(); my $i=0; foreach (@$storearr) { @@ -1494,7 +1689,32 @@ 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 ''; + } + } + if ($ENV{'request.role'}=~ /li\.\//) { + # Library role, so allow browsing of resources in this domain. + return 'F'; + } + } + # Domain coordinator is trying to create a course + if (($priv eq 'ccc') && ($ENV{'request.role'} =~ /^dc\./)) { + # uri is the requested domain in this case. + # comparison to 'request.role.domain' shows if the user has selected + # a role of dc for the domain in question. + return 'F' if ($uri eq $ENV{'request.role.domain'}); } my $thisallowed=''; @@ -1542,19 +1762,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; @@ -1564,7 +1781,6 @@ sub allowed { if ($checkreferer) { my $refuri=$ENV{'httpref.'.$orguri}; - unless ($refuri) { foreach (keys %ENV) { if ($_=~/^httpref\..*\*/) { @@ -1578,15 +1794,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; @@ -1645,7 +1858,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'}); @@ -1656,7 +1869,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'}); @@ -1684,6 +1897,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'}, @@ -1691,6 +1905,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 @@ -1714,9 +1936,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 { @@ -1727,6 +1955,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 { @@ -1772,9 +2017,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; @@ -1789,6 +2036,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 { @@ -1841,7 +2146,8 @@ sub modifyuserauth { my $uhome=&homeserver($uname,$udom); unless (&allowed('mau',$udom)) { return 'refused'; } &logthis('Call to modify user authentication '.$udom.', '.$uname.', '. - $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}); + $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}. + ' in domain '.$ENV{'request.role.domain'}); my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'. &escape($upass),$uhome); &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'}, @@ -1872,16 +2178,17 @@ sub modifyuser { $last.', '.$gene.'(forceid: '.$forceid.')'. (defined($desiredhome) ? ' desiredhome = '.$desiredhome : ' desiredhome not specified'). - ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}); - my $uhome=&homeserver($uname,$udom); + ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}. + ' in domain '.$ENV{'request.role.domain'}); + my $uhome=&homeserver($uname,$udom,'true'); # ----------------------------------------------------------------- Create User if (($uhome eq 'no_host') && ($umode) && ($upass)) { my $unhome=''; - if ($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $udom) { - $unhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'}; - } elsif (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) { + if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) { $unhome = $desiredhome; - } else { + } 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) { @@ -1903,11 +2210,11 @@ sub modifyuser { unless ($reply eq 'ok') { return 'error: '.$reply; } - $uhome=&homeserver($uname,$udom); + $uhome=&homeserver($uname,$udom,'true'); if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) { return 'error: verify home'; } - } + } # End of creation of new user # ---------------------------------------------------------------------- Add ID if ($uid) { $uid=~tr/A-Z/a-z/; @@ -1925,6 +2232,7 @@ sub modifyuser { my %names=&get('environment', ['firstname','middlename','lastname','generation'], $udom,$uname); + if ($names{'firstname'} =~ m/^error:.*/) { %names=(); } if ($first) { $names{'firstname'} = $first; } if ($middle) { $names{'middlename'} = $middle; } if ($last) { $names{'lastname'} = $last; } @@ -1942,14 +2250,15 @@ sub modifyuser { sub modifystudent { my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, - $end,$start,$forceid)=@_; + $end,$start,$forceid,$desiredhome)=@_; my $cid=''; unless ($cid=$ENV{'request.course.id'}) { return 'not_in_class'; } # --------------------------------------------------------------- Make the user my $reply=&modifyuser - ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid); + ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid, + $desiredhome); unless ($reply eq 'ok') { return $reply; } my $uhome=&homeserver($uname,$udom); if (($uhome eq '') || ($uhome eq 'no_host')) { @@ -1995,39 +2304,60 @@ sub writecoursepref { # ---------------------------------------------------------- Make/modify course sub createcourse { - my ($udom,$description,$url)=@_; + my ($udom,$description,$url,$course_server,$nonstandard)=@_; $url=&declutter($url); my $cid=''; - unless (&allowed('ccc',$ENV{'user.domain'})) { - return 'refused'; - } - unless ($udom eq $ENV{'user.domain'}) { + unless (&allowed('ccc',$udom)) { return 'refused'; } # ------------------------------------------------------------------- Create ID my $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)). unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; # ----------------------------------------------- Make sure that does not exist - my $uhome=&homeserver($uname,$udom); + my $uhome=&homeserver($uname,$udom,'true'); unless (($uhome eq '') || ($uhome eq 'no_host')) { $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)). unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; - $uhome=&homeserver($uname,$udom); + $uhome=&homeserver($uname,$udom,'true'); unless (($uhome eq '') || ($uhome eq 'no_host')) { return 'error: unable to generate unique course-ID'; } } +# ------------------------------------------------ Check supplied server name + $course_server = $ENV{'user.homeserver'} if (! defined($course_server)); + if (! exists($libserv{$course_server})) { + return 'error:bad server name '.$course_server; + } # ------------------------------------------------------------- Make the course my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::', - $ENV{'user.home'}); + $course_server); unless ($reply eq 'ok') { return 'error: '.$reply; } - $uhome=&homeserver($uname,$udom); + $uhome=&homeserver($uname,$udom,'true'); if (($uhome eq '') || ($uhome eq 'no_host')) { return 'error: no such course'; } +# ----------------------------------------------------------------- Course made + my $topurl=$url; + unless ($nonstandard) { +# ------------------------------------------ For standard courses, make top url + my $mapurl=&clutter($url); + $ENV{'form.initmap'}=(< + + + + + + +ENDINITMAP + $topurl=&declutter( + &finishuserfileupload($uname,$udom,$uhome,'initmap','default.sequence') + ); + } +# ----------------------------------------------------------- Write preferences &writecoursepref($udom.'_'.$uname, ('description' => $description, - 'url' => $url)); + 'url' => $topurl)); return '/'.$udom.'/'.$uname; } @@ -2058,51 +2388,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 @@ -2163,37 +2516,44 @@ 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 sub EXT { - my ($varname,$symbparm)=@_; + my ($varname,$symbparm,$udom,$uname)=@_; + unless ($varname) { return ''; } + + #get real user name/domain, courseid and symb + my $courseid; + if (!($uname && $udom)) { + (my $cursymb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); + if (!$symbparm) { $symbparm=$cursymb; } + } else { + $courseid=$ENV{'request.course.id'}; + } + my ($realm,$space,$qualifier,@therest)=split(/\./,$varname); my $rest; if ($therest[0]) { @@ -2208,19 +2568,28 @@ sub EXT { if ($realm eq 'user') { # --------------------------------------------------------------- user.resource if ($space eq 'resource') { - my %restored=&restore(); + my %restored=&restore(undef,undef,$udom,$uname); return $restored{$qualifierrest}; # ----------------------------------------------------------------- user.access } elsif ($space eq 'access') { + # FIXME - not supporting calls for a specific user return &allowed($qualifier,$rest); # ------------------------------------------ user.preferences, user.environment } elsif (($space eq 'preferences') || ($space eq 'environment')) { - return $ENV{join('.',('environment',$qualifierrest))}; + if (($uname eq $ENV{'user.name'}) && + ($udom eq $ENV{'user.domain'})) { + return $ENV{join('.',('environment',$qualifierrest))}; + } else { + my %returnhash=&userenvironment($udom,$uname,$qualifierrest); + return $returnhash{$qualifierrest}; + } # ----------------------------------------------------------------- user.course } elsif ($space eq 'course') { + # FIXME - not supporting calls for a specific user return $ENV{join('.',('request.course',$qualifier))}; # ------------------------------------------------------------------- user.role } elsif ($space eq 'role') { + # FIXME - not supporting calls for a specific user my ($role,$where)=split(/\./,$ENV{'request.role'}); if ($qualifier eq 'value') { return $role; @@ -2229,17 +2598,21 @@ sub EXT { } # ----------------------------------------------------------------- user.domain } elsif ($space eq 'domain') { - return $ENV{'user.domain'}; + return $udom; # ------------------------------------------------------------------- user.name } elsif ($space eq 'name') { - return $ENV{'user.name'}; + return $uname; # ---------------------------------------------------- Any other user namespace } else { my $item=($rest)?$qualifier.'.'.$rest:$qualifier; 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}; @@ -2249,112 +2622,112 @@ sub EXT { } } elsif ($realm eq 'course') { # ---------------------------------------------------------- course.description - return $ENV{'course.'.$ENV{'request.course.id'}.'.'. - $spacequalifierrest}; + return $ENV{'course.'.$courseid.'.'.$spacequalifierrest}; } elsif ($realm eq 'resource') { - if ($ENV{'request.course.id'}) { -# print '
'.$space.' - '.$qualifier.' - '.$spacequalifierrest; + if ($courseid eq $ENV{'request.course.id'}) { + #print '
'.$space.' - '.$qualifier.' - '.$spacequalifierrest; # ----------------------------------------------------- Cascading lookup scheme - my $symbp; - if ($symbparm) { - $symbp=$symbparm; - } else { - $symbp=&symbread(); - } - my $mapp=(split(/\_\_\_/,$symbp))[0]; - - my $symbparm=$symbp.'.'.$spacequalifierrest; - my $mapparm=$mapp.'___(all).'.$spacequalifierrest; - - my $seclevel= - $ENV{'request.course.id'}.'.['. - $ENV{'request.course.sec'}.'].'.$spacequalifierrest; - my $seclevelr= - $ENV{'request.course.id'}.'.['. - $ENV{'request.course.sec'}.'].'.$symbparm; - my $seclevelm= - $ENV{'request.course.id'}.'.['. - $ENV{'request.course.sec'}.'].'.$mapparm; - - my $courselevel= - $ENV{'request.course.id'}.'.'.$spacequalifierrest; - my $courselevelr= - $ENV{'request.course.id'}.'.'.$symbparm; - my $courselevelm= - $ENV{'request.course.id'}.'.'.$mapparm; + if (!$symbparm) { $symbparm=&symbread(); } + my $symbp=$symbparm; + my $mapp=(split(/\_\_\_/,$symbp))[0]; + + my $symbparm=$symbp.'.'.$spacequalifierrest; + my $mapparm=$mapp.'___(all).'.$spacequalifierrest; + + my $section; + if (($ENV{'user.name'} eq $uname) && + ($ENV{'user.domain'} eq $udom)) { + $section=$ENV{'request.course.sec'}; + } else { + $section=&usection($udom,$uname,$courseid); + } -# ----------------------------------------------------------- first, check user - my %resourcedata=get('resourcedata', - [$courselevelr,$courselevelm,$courselevel]); - if (($resourcedata{$courselevelr}!~/^error\:/) && - ($resourcedata{$courselevelr}!~/^con_lost/)) { - - if ($resourcedata{$courselevelr}) { - return $resourcedata{$courselevelr}; } - if ($resourcedata{$courselevelm}) { - return $resourcedata{$courselevelm}; } - if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; } + my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; + my $seclevelr=$courseid.'.['.$section.'].'.$symbparm; + my $seclevelm=$courseid.'.['.$section.'].'.$mapparm; + + my $courselevel=$courseid.'.'.$spacequalifierrest; + my $courselevelr=$courseid.'.'.$symbparm; + my $courselevelm=$courseid.'.'.$mapparm; - } else { - if ($resourcedata{$courselevelr}!~/No such file/) { - &logthis("WARNING:". - " Trying to get resource data for ".$ENV{'user.name'}." at " - .$ENV{'user.domain'}.": ".$resourcedata{$courselevelr}. - ""); - } - } +# ----------------------------------------------------------- first, check user + my %resourcedata=&get('resourcedata', + [$courselevelr,$courselevelm,$courselevel], + $udom,$uname); + if (($resourcedata{$courselevelr}!~/^error\:/) && + ($resourcedata{$courselevelr}!~/^con_lost/)) { + + if ($resourcedata{$courselevelr}) { + return $resourcedata{$courselevelr}; } + if ($resourcedata{$courselevelm}) { + return $resourcedata{$courselevelm}; } + if ($resourcedata{$courselevel}) { + return $resourcedata{$courselevel}; } + } else { + if ($resourcedata{$courselevelr}!~/No such file/) { + &logthis("WARNING:". + " Trying to get resource data for ". + $uname." at ".$udom.": ". + $resourcedata{$courselevelr}.""); + } + } # -------------------------------------------------------- second, check course - my $coursereply=&courseresdata( - $ENV{'course.'.$ENV{'request.course.id'}.'.num'}, - $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}, - ($seclevelr,$seclevelm,$seclevel, - $courselevelr,$courselevelm,$courselevel)); - if ($coursereply) { return $coursereply; } + my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'}, + $ENV{'course.'.$courseid.'.domain'}, + ($seclevelr,$seclevelm,$seclevel, + $courselevelr,$courselevelm, + $courselevel)); + if ($coursereply) { return $coursereply; } # ------------------------------------------------------ third, check map parms - my %parmhash=(); - my $thisparm=''; - if (tie(%parmhash,'GDBM_File', - $ENV{'request.course.fn'}.'_parms.db',&GDBM_READER,0640)) { - $thisparm=$parmhash{$symbparm}; - untie(%parmhash); - } - if ($thisparm) { return $thisparm; } - } - + my %parmhash=(); + my $thisparm=''; + if (tie(%parmhash,'GDBM_File', + $ENV{'request.course.fn'}.'_parms.db', + &GDBM_READER(),0640)) { + $thisparm=$parmhash{$symbparm}; + untie(%parmhash); + } + if ($thisparm) { return $thisparm; } + } # --------------------------------------------- last, look in resource metadata - $spacequalifierrest=~s/\./\_/; - my $metadata=&metadata($ENV{'request.filename'},$spacequalifierrest); - if ($metadata) { return $metadata; } - $metadata=&metadata($ENV{'request.filename'}, - 'parameter_'.$spacequalifierrest); - if ($metadata) { return $metadata; } + $spacequalifierrest=~s/\./\_/; + my $metadata=&metadata($ENV{'request.filename'},$spacequalifierrest); + if ($metadata) { return $metadata; } + $metadata=&metadata($ENV{'request.filename'}, + 'parameter_'.$spacequalifierrest); + if ($metadata) { return $metadata; } # ------------------------------------------------------------------ Cascade up - - unless ($space eq '0') { - my ($part,$id)=split(/\_/,$space); - if ($id) { - my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, - $symbparm); - if ($partgeneral) { return $partgeneral; } - } else { - my $resourcegeneral=&EXT('resource.0.'.$qualifierrest, - $symbparm); - if ($resourcegeneral) { return $resourcegeneral; } - } - } + unless ($space eq '0') { + my ($part,$id)=split(/\_/,$space); + if ($id) { + my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, + $symbparm,$udom,$uname); + if ($partgeneral) { return $partgeneral; } + } else { + my $resourcegeneral=&EXT('resource.0.'.$qualifierrest, + $symbparm,$udom,$uname); + if ($resourcegeneral) { return $resourcegeneral; } + } + } # ---------------------------------------------------- Any other user namespace } elsif ($realm eq 'environment') { # ----------------------------------------------------------------- environment - return $ENV{'environment.'.$spacequalifierrest}; + if (($uname eq $ENV{'user.name'})&&($udom eq $ENV{'user.domain'})) { + return $ENV{'environment.'.$spacequalifierrest}; + } else { + my %returnhash=&userenvironment($udom,$uname, + $spacequalifierrest); + return $returnhash{$spacequalifierrest}; + } } elsif ($realm eq 'system') { # ----------------------------------------------------------------- system.time if ($space eq 'time') { @@ -2388,7 +2761,7 @@ sub metadata { my %metathesekeys=(); unless ($filename=~/\.meta$/) { $filename.='.meta'; } my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename); - my $parser=HTML::TokeParser->new(\$metastring); + my $parser=HTML::LCParser->new(\$metastring); my $token; undef %metathesekeys; while ($token=$parser->get_token) { @@ -2477,7 +2850,7 @@ sub metadata { $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_}; } unless ( - $metacache{$uri.':'.$unikey}=$parser->get_text('/'.$entry) + $metacache{$uri.':'.$unikey}=&HTML::Entities::decode($parser->get_text('/'.$entry)) ) { $metacache{$uri.':'.$unikey}= $metacache{$uri.':'.$unikey.'.default'}; } @@ -2488,6 +2861,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 @@ -2495,6 +2869,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 { @@ -2503,7 +2905,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{$_}; } @@ -2515,21 +2917,77 @@ sub symblist { return 'error'; } +# --------------------------------------------------------------- Verify a symb + +sub symbverify { + my ($symb,$thisfn)=@_; + $thisfn=&declutter($thisfn); +# direct jump to resource in page or to a sequence - will construct own symbs + if ($thisfn=~/\.(page|sequence)$/) { return 1; } +# check URL part + my ($map,$resid,$url)=split(/\_\_\_/,$symb); + unless (&symbclean($url) eq &symbclean($thisfn)) { return 0; } + + $symb=&symbclean($symb); + + my %bighash; + my $okay=0; + if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', + &GDBM_READER(),0640)) { + my $ids=$bighash{'ids_/res/'.$thisfn}; + unless ($ids) { + $ids=$bighash{'ids_/'.$thisfn}; + } + if ($ids) { +# ------------------------------------------------------------------- Has ID(s) + foreach (split(/\,/,$ids)) { + my ($mapid,$resid)=split(/\./,$_); + if ( + &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) + eq $symb) { + $okay=1; + } + } + } + untie(%bighash); + } + return $okay; +} + +# --------------------------------------------------------------- Clean-up symb + +sub symbclean { + my $symb=shift; + +# remove version from map + $symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/; + +# remove version from URL + $symb=~s/\.(\d+)\.(\w+)$/\.$2/; + + return $symb; +} + # ------------------------------------------------------ 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 $ENV{'request.symb'}; } + 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); } @@ -2545,12 +3003,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); @@ -2558,7 +3020,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) { @@ -2573,13 +3035,15 @@ sub symbread { } } if ($realpossible!=1) { $syval=''; } + } else { + $syval=''; } } untie(%bighash) } } if ($syval) { - return $syval.'___'.$thisfn; + return &symbclean($syval.'___'.$thisfn); } } &appenv('request.ambiguous' => $thisfn); @@ -2641,20 +3105,31 @@ 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 { - my $file=shift; + my $file=shift; + if ($file=~/^\/*uploaded\//) { # user file + my $ua=new LWP::UserAgent; + my $request=new HTTP::Request('GET',&tokenwrapper($file)); + my $response=$ua->request($request); + if ($response->is_success()) { + return $response->content; + } else { + return -1; + } + } else { # normal file from res space &repcopy($file); if (! -e $file ) { return -1; }; my $fh=Apache::File->new($file); my $a=''; while (<$fh>) { $a .=$_; } - return $a + return $a; + } } sub filelocation { @@ -2664,6 +3139,8 @@ sub filelocation { if ($file=~m:^/~:) { # is a contruction space reference $location = $file; $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; + } elsif ($file=~/^\/*uploaded/) { # is an uploaded file + $location=$file; } else { $file=~s/^$perlvar{'lonDocRoot'}//; $file=~s:^/*res::; @@ -2683,6 +3160,7 @@ sub hreflocation { unless (($file=~/^http:\/\//i) || ($file=~/^\//)) { my $finalpath=filelocation($dir,$file); $finalpath=~s/^\/home\/httpd\/html//; + $finalpath=~s-/home/(\w+)/public_html/-/~$1/-; return $finalpath; } else { return $file; @@ -2696,6 +3174,17 @@ sub declutter { $thisfn=~s/^$perlvar{'lonDocRoot'}//; $thisfn=~s/^\///; $thisfn=~s/^res\///; + $thisfn=~s/\?.+$//; + return $thisfn; +} + +# ------------------------------------------------------------- Clutter up URLs + +sub clutter { + my $thisfn='/'.&declutter(shift); + unless ($thisfn=~/^\/(uploaded|adm|userfiles|ext|raw|priv)\//) { + $thisfn='/res'.$thisfn; + } return $thisfn; } @@ -2724,13 +3213,24 @@ sub goodbye { } BEGIN { -# ------------------------------------------------------------ Read access.conf +# ----------------------------------- Read loncapa.conf and loncapa_apache.conf unless ($readit) { { - my $config=Apache::File->new("/etc/httpd/conf/access.conf"); + my $config=Apache::File->new("/etc/httpd/conf/loncapa.conf"); + + while (my $configline=<$config>) { + if ($configline =~ /^[^\#]*PerlSetVar/) { + my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); + chomp($varvalue); + $perlvar{$varname}=$varvalue; + } + } +} +{ + my $config=Apache::File->new("/etc/httpd/conf/loncapa_apache.conf"); while (my $configline=<$config>) { - if ($configline =~ /PerlSetVar/) { + if ($configline =~ /^[^\#]*PerlSetVar/) { my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); chomp($varvalue); $perlvar{$varname}=$varvalue; @@ -2744,11 +3244,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-"); + } + } } } @@ -2818,75 +3325,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 * @@ -2896,16 +3433,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 * @@ -2919,226 +3459,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 * + +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 * + +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 * + +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 * -userenvironment($domain,$user,$what) : puts out any environment parameter -for a user +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 * -subscribe($fname) : subscribe to a resource, return URL if possible +plaintext($short) : return value in %prp hash (rolesplain.tab); plain text +explanation of a user role term + +=back + +=head2 User Modification + +=over 4 =item * -repcopy($filename) : replicate file +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 * -ssi($url,%hash) : server side include, does a complete request cycle on url to -localhost, posts 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 * -log($domain,$name,$home,$message) : write to permanent log for user; use -critical subroutine +modifyuserauth($udom,$uname,$umode,$upass) : modify user authentication =item * -flushcourselogs() : flush (save) buffer logs and access logs +modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) : +modify user =item * -courselog($what) : save message for course in hash +modifystudent($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,$end,$start) : modify student =item * -courseacclog($what) : save message for course using &courselog(). Perform -special processing for specific resource types (problems, exams, quizzes, etc). +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 * -countacc($url) : count the number of accesses to a given URL +revokerole($udom,$uname,$url,$role) : revoke a role for url =item * -sub checkout($symb,$tuname,$tudom,$tcrsid) : check out an item +revokecustomrole($udom,$uname,$url,$role) : revoke a custom role + +=back + +=head2 Course Infomation + +=over 4 =item * -sub checkin($token) : check in an item +coursedescription($courseid) : course description =item * -sub expirespread($uname,$udom,$stype,$usymb) : set expire date for spreadsheet +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 * -devalidate($symb) : devalidate spreadsheets +writecoursepref($courseid,%prefs) : write preferences (environment +database) for a course =item * -hash2str(%hash) : convert a hash into a string complete with escaping and '=' -and '&' separators, supports elements that are arrayrefs and hashrefs +createcourse($udom,$description,$url) : make/modify course + +=back + +=head2 Resource Subroutines + +=over 4 =item * -hashref2str($hashref) : convert a hashref into a string complete with -escaping and '=' and '&' separators, supports elements that are -arrayrefs and hashrefs +subscribe($fname) : subscribe to a resource, returns URL if possible (probably should use repcopy instead) =item * -arrayref2str($arrayref) : convert an arrayref into a string complete -with escaping and '&' separators, supports elements that are arrayrefs -and hashrefs +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 * -str2hash($string) : convert string to hash using unescaping and -splitting on '=' and '&', supports elements that are arrayrefs and -hashrefs +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 * -str2array($string) : convert string to hash using unescaping and -splitting on '&', supports elements that are arrayrefs and hashrefs +directcondval($number) : get current value of a condition; reads from a state +string =item * -tmpreset($symb,$namespace,$domain,$stuname) : temporary storage +condval($condidx) : value of condition index based on state =item * -tmprestore($symb,$namespace,$domain,$stuname) : temporary restore +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 * -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 +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 * -cstore($storehash,$symb,$namespace,$domain,$stuname) : same as store but -uses critical subroutine +symbread($filename) : return symbolic list entry (filename argument optional); +returns the data handle =item * -restore($symb,$namespace,$domain,$stuname) : returns hash for this symb; -all args 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 * -coursedescription($courseid) : course description +symbclean($symb) : removes versions numbers from a symb, returns the +cleaned symb =item * -rolesinit($domain,$username,$authhost) : get user privileges +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 * -get($namespace,$storearr,$udomain,$uname) : returns hash with keys from array -reference filled in from namesp ($udomain and $uname are optional) +numval($salt) : return random seed value (addend for rndseed) =item * -del($namespace,$storearr,$udomain,$uname) : deletes keys out of array from -namesp ($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 * -dump($namespace,$udomain,$uname,$regexp) : -dumps the complete (or key matching regexp) namespace into a hash -($udomain, $uname and $regexp are optional) +ireceipt($funame,$fudom,$fucourseid,$fusymb) : return unique, +unfakeable, receipt =item * -put($namespace,$storehash,$udomain,$uname) : stores hash in namesp -($udomain and $uname are optional) +receipt() : API to ireceipt working off of ENV values; given out to users =item * -cput($namespace,$storehash,$udomain,$uname) : critical put -($udomain and $uname are optional) +countacc($url) : count the number of accesses to a given URL =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) +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 * -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 +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 * -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 +expirespread($uname,$udom,$stype,$usymb) : set expire date for spreadsheet =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 +devalidate($symb) : devalidate temporary spreadsheet calculations, +forcing spreadsheet to reevaluate the resource scores next time. + +=back + +=head2 Storing/Retreiving Data + +=over 4 =item * -plaintext($short) : return value in %prp hash (rolesplain.tab); plain text -explanation of a user role term +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 * -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") +cstore($storehash,$symb,$namespace,$udom,$uname) : same as store but +uses critical subroutine =item * -modifyuserauth($udom,$uname,$umode,$upass) : modify user authentication +restore($symb,$namespace,$udom,$uname) : returns hash for this symb; +all args are optional =item * -modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) : -modify user +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 * -modifystudent($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, -$end,$start) : modify student +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 * -writecoursepref($courseid,%prefs) : write preferences for a course +tmpreset($symb,$namespace,$udom,$uname) : temporary storage reset, +deltes all keys for $symb form the temporary storage hash. =item * -createcourse($udom,$description,$url) : make/modify course +get($namespace,$storearr,$udom,$uname) : returns hash with keys from array +reference filled in from namesp ($udom and $uname are optional) =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 +del($namespace,$storearr,$udom,$uname) : deletes keys out of array from +namesp ($udom and $uname are optional) =item * -revokerole($udom,$uname,$url,$role) : revoke a role for url +dump($namespace,$udom,$uname,$regexp) : +dumps the complete (or key matching regexp) namespace into a hash +($udom, $uname and $regexp are optional) =item * -revokecustomrole($udom,$uname,$url,$role) : revoke a custom role +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 * @@ -3146,60 +3792,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 +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 * @@ -3210,6 +3890,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 @@ -3218,6 +3904,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 @@ -3225,4 +3957,14 @@ as a PerlChildExitHandler =back +=head2 Other + +=over 4 + +=item * + +symblist($mapname,%newhash) : update symbolic storage links + +=back + =cut