--- loncom/lonnet/perl/lonnet.pm 2001/10/16 21:16:01 1.166 +++ loncom/lonnet/perl/lonnet.pm 2001/12/07 20:17:44 1.188 @@ -1,6 +1,73 @@ # The LearningOnline Network # TCP networking package # +# $Id: lonnet.pm,v 1.188 2001/12/07 20:17:44 www Exp $ +# +# Copyright Michigan State University Board of Trustees +# +# This file is part of the LearningOnline Network with CAPA (LON-CAPA). +# +# LON-CAPA is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# LON-CAPA is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with LON-CAPA; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +# +# /home/httpd/html/adm/gpl.txt +# +# http://www.lon-capa.org/ +# +# 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30, +# 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19, +# 11/8,11/16,11/18,11/22,11/23,12/22, +# 01/06,01/13,02/24,02/28,02/29, +# 03/01,03/02,03/06,03/07,03/13, +# 04/05,05/29,05/31,06/01, +# 06/05,06/26 Gerd Kortemeyer +# 06/26 Ben Tyszka +# 06/30,07/15,07/17,07/18,07/20,07/21,07/22,07/25 Gerd Kortemeyer +# 08/14 Ben Tyszka +# 08/22,08/28,08/31,09/01,09/02,09/04,09/05,09/25,09/28,09/30 Gerd Kortemeyer +# 10/04 Gerd Kortemeyer +# 10/04 Guy Albertelli +# 10/06,10/09,10/10,10/11,10/14,10/20,10/23,10/25,10/26,10/27,10/28,10/29, +# 10/30,10/31, +# 11/2,11/14,11/15,11/16,11/20,11/21,11/22,11/25,11/27, +# 12/02,12/12,12/13,12/14,12/28,12/29 Gerd Kortemeyer +# 05/01/01 Guy Albertelli +# 05/01,06/01,09/01 Gerd Kortemeyer +# 09/01 Guy Albertelli +# 09/01,10/01,11/01 Gerd Kortemeyer +# YEAR=2001 +# 02/27/01 Scott Harrison +# 3/2 Gerd Kortemeyer +# 3/15,3/19 Scott Harrison +# 3/19,3/20 Gerd Kortemeyer +# 3/22,3/27,4/2,4/16,4/17 Scott Harrison +# 5/26,5/28 Gerd Kortemeyer +# 5/30 H. K. Ng +# 6/1 Gerd Kortemeyer +# July Guy Albertelli +# 8/4,8/7,8/8,8/9,8/11,8/16,8/17,8/18,8/20,8/23,9/20,9/21,9/26, +# 10/2 Gerd Kortemeyer +# 10/5,10/10,11/13,11/15 Scott Harrison +# 11/17,11/20,11/22,11/29 Gerd Kortemeyer +# 12/5 Matthew Hall +# 12/5 Guy Albertelli +# 12/6,12/7 Gerd Kortemeyer +# +# $Id: lonnet.pm,v 1.188 2001/12/07 20:17:44 www Exp $ +# +### + # Functions for use by content handlers: # # metadata_query(sql-query-string,custom-metadata-regex) : @@ -97,40 +164,6 @@ # metadata(file,entry): returns the metadata entry for a file. entry='keys' # returns a comma separated list of keys # -# 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30, -# 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19, -# 11/8,11/16,11/18,11/22,11/23,12/22, -# 01/06,01/13,02/24,02/28,02/29, -# 03/01,03/02,03/06,03/07,03/13, -# 04/05,05/29,05/31,06/01, -# 06/05,06/26 Gerd Kortemeyer -# 06/26 Ben Tyszka -# 06/30,07/15,07/17,07/18,07/20,07/21,07/22,07/25 Gerd Kortemeyer -# 08/14 Ben Tyszka -# 08/22,08/28,08/31,09/01,09/02,09/04,09/05,09/25,09/28,09/30 Gerd Kortemeyer -# 10/04 Gerd Kortemeyer -# 10/04 Guy Albertelli -# 10/06,10/09,10/10,10/11,10/14,10/20,10/23,10/25,10/26,10/27,10/28,10/29, -# 10/30,10/31, -# 11/2,11/14,11/15,11/16,11/20,11/21,11/22,11/25,11/27, -# 12/02,12/12,12/13,12/14,12/28,12/29 Gerd Kortemeyer -# 05/01/01 Guy Albertelli -# 05/01,06/01,09/01 Gerd Kortemeyer -# 09/01 Guy Albertelli -# 09/01,10/01,11/01 Gerd Kortemeyer -# YEAR=2001 -# 02/27/01 Scott Harrison -# 3/2 Gerd Kortemeyer -# 3/15,3/19 Scott Harrison -# 3/19,3/20 Gerd Kortemeyer -# 3/22,3/27,4/2,4/16,4/17 Scott Harrison -# 5/26,5/28 Gerd Kortemeyer -# 5/30 H. K. Ng -# 6/1 Gerd Kortemeyer -# July Guy Albertelli -# 8/4,8/7,8/8,8/9,8/11,8/16,8/17,8/18,8/20,8/23,9/20,9/21,9/26, -# 10/2 Gerd Kortemeyer -# 10/5,10/10 Scott Harrison package Apache::lonnet; @@ -139,7 +172,10 @@ use Apache::File; use LWP::UserAgent(); use HTTP::Headers; use vars -qw(%perlvar %hostname %homecache %hostip %spareid %hostdom %libserv %pr %prp %fe %fd $readit %metacache %packagetab %courselogs); +qw(%perlvar %hostname %homecache %hostip %spareid %hostdom + %libserv %pr %prp %fe %fd %metacache %packagetab + %courselogs %accesshash $processmarker $dumpcount + %coursedombuf %coursehombuf); use IO::Socket; use GDBM_File; use Apache::Constants qw(:common :http); @@ -406,6 +442,44 @@ sub spareserver { return $spareserver; } +# ----------------------- Try to determine user's current authentication scheme + +sub queryauthenticate { + my ($uname,$udom)=@_; + if (($perlvar{'lonRole'} eq 'library') && + ($udom eq $perlvar{'lonDefDomain'})) { + my $answer=reply("encrypt:currentauth:$udom:$uname", + $perlvar{'lonHostID'}); + unless ($answer eq 'unknown_user' or $answer eq 'refused') { + if (length($answer)) { + return $answer; + } + else { + &logthis("User $uname at $udom lacks an authentication mechanism"); + return 'no_host'; + } + } + } + + my $tryserver; + foreach $tryserver (keys %libserv) { + if ($hostdom{$tryserver} eq $udom) { + my $answer=reply("encrypt:currentauth:$udom:$uname",$tryserver); + unless ($answer eq 'unknown_user' or $answer eq 'refused') { + if (length($answer)) { + return $answer; + } + else { + &logthis("User $uname at $udom lacks an authentication mechanism"); + return 'no_host'; + } + } + } + } + &logthis("User $uname at $udom lacks an authentication mechanism"); + return 'no_host'; +} + # --------- Try to authenticate user from domain's lib servers (first this one) sub authenticate { @@ -684,10 +758,9 @@ sub flushcourselogs { &logthis('Flushing course log buffers'); map { my $crsid=$_; - if (&reply('log:'.$ENV{'course.'.$crsid.'.domain'}.':'. - $ENV{'course.'.$crsid.'.num'}.':'. - &escape($courselogs{$crsid}), - $ENV{'course.'.$crsid.'.home'}) eq 'ok') { + if (&reply('log:'.$coursedombuf{$crsid}.':'. + &escape($courselogs{$crsid}), + $coursehombuf{$crsid}) eq 'ok') { delete $courselogs{$crsid}; } else { &logthis('Failed to flush log buffer for '.$crsid); @@ -698,12 +771,27 @@ sub flushcourselogs { } } } keys %courselogs; + &logthis('Flushing access logs'); + map { + my $entry=$_; + $entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/; + my %temphash=($entry => $accesshash{$entry}); + if (&Apache::lonnet::put('resevaldata',\%temphash,$1,$2) eq 'ok') { + delete $accesshash{$entry}; + } + } keys %accesshash; + $dumpcount++; } sub courselog { my $what=shift; $what=time.':'.$what; unless ($ENV{'request.course.id'}) { return ''; } + $coursedombuf{$ENV{'request.course.id'}}= + $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'. + $ENV{'course.'.$ENV{'request.course.id'}.'.num'}; + $coursehombuf{$ENV{'request.course.id'}}= + $ENV{'course.'.$ENV{'request.course.id'}.'.home'}; if (defined $courselogs{$ENV{'request.course.id'}}) { $courselogs{$ENV{'request.course.id'}}.='&'.$what; } else { @@ -719,6 +807,7 @@ sub courseacclog { unless ($ENV{'request.course.id'}) { return ''; } my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'}; if ($what=~/(problem|exam|quiz|assess|survey|form)$/) { + $what.=':POST'; map { if ($_=~/^form\.(.*)/) { $what.=':'.$1.'='.$ENV{$_}; @@ -728,6 +817,18 @@ sub courseacclog { &courselog($what); } +sub countacc { + my $url=&declutter(shift); + unless ($ENV{'request.course.id'}) { return ''; } + $accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1; + my $key=$processmarker.'_'.$dumpcount.'___'.$url.'___count'; + if (defined($accesshash{$key})) { + $accesshash{$key}++; + } else { + $accesshash{$key}=1; + } +} + # ----------------------------------------------------------- Check out an item sub checkout { @@ -854,22 +955,166 @@ sub devalidate { } } +sub hash2str { + my (%hash)=@_; + my $result=''; + map { $result.=escape($_).'='.escape($hash{$_}).'&'; } keys %hash; + $result=~s/\&$//; + return $result; +} + +sub str2hash { + my ($string) = @_; + my %returnhash; + map { + my ($name,$value)=split(/\=/,$_); + $returnhash{&unescape($name)}=&unescape($value); + } split(/\&/,$string); + return %returnhash; +} + +# -------------------------------------------------------------------Temp Store + +sub tmpreset { + my ($symb,$namespace,$domain,$stuname) = @_; + if (!$symb) { + $symb=&symbread(); + if (!$symb) { $symb= $ENV{'REQUEST_URI'}; } + } + $symb=escape($symb); + + if (!$namespace) { $namespace=$ENV{'request.state'}; } + $namespace=~s/\//\_/g; + $namespace=~s/\W//g; + + #FIXME needs to do something for /pub resources + if (!$domain) { $domain=$ENV{'user.domain'}; } + if (!$stuname) { $stuname=$ENV{'user.name'}; } + my $path=$perlvar{'lonDaemons'}.'/tmp'; + my %hash; + if (tie(%hash,'GDBM_File', + $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', + &GDBM_WRCREAT,0640)) { + foreach my $key (keys %hash) { + if ($key=~ /:$symb/) { + delete($hash{$key}); + } + } + } +} + +sub tmpstore { + my ($storehash,$symb,$namespace,$domain,$stuname) = @_; + + if (!$symb) { + $symb=&symbread(); + if (!$symb) { $symb= $ENV{'request.url'}; } + } + $symb=escape($symb); + + if (!$namespace) { + # I don't think we would ever want to store this for a course. + # it seems this will only be used if we don't have a course. + #$namespace=$ENV{'request.course.id'}; + #if (!$namespace) { + $namespace=$ENV{'request.state'}; + #} + } + $namespace=~s/\//\_/g; + $namespace=~s/\W//g; +#FIXME needs to do something for /pub resources + if (!$domain) { $domain=$ENV{'user.domain'}; } + if (!$stuname) { $stuname=$ENV{'user.name'}; } + my $now=time; + my %hash; + my $path=$perlvar{'lonDaemons'}.'/tmp'; + if (tie(%hash,'GDBM_File', + $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', + &GDBM_WRCREAT,0640)) { + $hash{"version:$symb"}++; + my $version=$hash{"version:$symb"}; + my $allkeys=''; + foreach my $key (keys(%$storehash)) { + $allkeys.=$key.':'; + $hash{"$version:$symb:$key"}=$$storehash{$key}; + } + $hash{"$version:$symb:timestamp"}=$now; + $allkeys.='timestamp'; + $hash{"$version:keys:$symb"}=$allkeys; + if (untie(%hash)) { + return 'ok'; + } else { + return "error:$!"; + } + } else { + return "error:$!"; + } +} + +# -----------------------------------------------------------------Temp Restore + +sub tmprestore { + my ($symb,$namespace,$domain,$stuname) = @_; + + if (!$symb) { + $symb=&symbread(); + if (!$symb) { $symb= $ENV{'request.url'}; } + } + $symb=escape($symb); + + if (!$namespace) { $namespace=$ENV{'request.state'}; } + #FIXME needs to do something for /pub resources + if (!$domain) { $domain=$ENV{'user.domain'}; } + if (!$stuname) { $stuname=$ENV{'user.name'}; } + + my %returnhash; + $namespace=~s/\//\_/g; + $namespace=~s/\W//g; + my %hash; + my $path=$perlvar{'lonDaemons'}.'/tmp'; + if (tie(%hash,'GDBM_File', + $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', + &GDBM_READER,0640)) { + my $version=$hash{"version:$symb"}; + $returnhash{'version'}=$version; + my $scope; + for ($scope=1;$scope<=$version;$scope++) { + my $vkeys=$hash{"$scope:keys:$symb"}; + my @keys=split(/:/,$vkeys); + my $key; + $returnhash{"$scope:keys"}=$vkeys; + foreach $key (@keys) { + $returnhash{"$scope:$key"}=$hash{"$scope:$symb:$key"}; + $returnhash{"$key"}=$hash{"$scope:$symb:$key"}; + } + } + if (!(untie(%hash))) { + return "error:$!"; + } + } else { + return "error:$!"; + } + return %returnhash; +} + # ----------------------------------------------------------------------- Store sub store { my ($storehash,$symb,$namespace,$domain,$stuname) = @_; my $home=''; - if ($stuname) { - $home=&homeserver($stuname,$domain); - } + if ($stuname) { $home=&homeserver($stuname,$domain); } if (!$symb) { unless ($symb=&symbread()) { return ''; } } &devalidate($symb); $symb=escape($symb); - if (!$namespace) { unless ($namespace=$ENV{'request.course.id'}) { return ''; } } + if (!$namespace) { + unless ($namespace=$ENV{'request.course.id'}) { + return ''; + } + } if (!$domain) { $domain=$ENV{'user.domain'}; } if (!$stuname) { $stuname=$ENV{'user.name'}; } if (!$home) { $home=$ENV{'user.home'}; } @@ -878,6 +1123,7 @@ sub store { $namevalue.=escape($_).'='.escape($$storehash{$_}).'&'; } keys %$storehash; $namevalue=~s/\&$//; + &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue); return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home"); } @@ -887,16 +1133,18 @@ sub cstore { my ($storehash,$symb,$namespace,$domain,$stuname) = @_; my $home=''; - if ($stuname) { - $home=&homeserver($stuname,$domain); - } + if ($stuname) { $home=&homeserver($stuname,$domain); } if (!$symb) { unless ($symb=&symbread()) { return ''; } } &devalidate($symb); $symb=escape($symb); - if (!$namespace) { unless ($namespace=$ENV{'request.course.id'}) { return ''; } } + if (!$namespace) { + unless ($namespace=$ENV{'request.course.id'}) { + return ''; + } + } if (!$domain) { $domain=$ENV{'user.domain'}; } if (!$stuname) { $stuname=$ENV{'user.name'}; } if (!$home) { $home=$ENV{'user.home'}; } @@ -906,7 +1154,9 @@ sub cstore { $namevalue.=escape($_).'='.escape($$storehash{$_}).'&'; } keys %$storehash; $namevalue=~s/\&$//; - return critical("store:$domain:$stuname:$namespace:$symb:$namevalue","$home"); + &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue); + return critical + ("store:$domain:$stuname:$namespace:$symb:$namevalue","$home"); } # --------------------------------------------------------------------- Restore @@ -915,16 +1165,18 @@ sub restore { my ($symb,$namespace,$domain,$stuname) = @_; my $home=''; - if ($stuname) { - $home=&homeserver($stuname,$domain); - } + if ($stuname) { $home=&homeserver($stuname,$domain); } if (!$symb) { unless ($symb=escape(&symbread())) { return ''; } } else { $symb=&escape($symb); } - if (!$namespace) { unless ($namespace=$ENV{'request.course.id'}) { return ''; } } + if (!$namespace) { + unless ($namespace=$ENV{'request.course.id'}) { + return ''; + } + } if (!$domain) { $domain=$ENV{'user.domain'}; } if (!$stuname) { $stuname=$ENV{'user.name'}; } if (!$home) { $home=$ENV{'user.home'}; } @@ -1482,7 +1734,6 @@ sub definerole { sub metadata_query { my ($query,$custom,$customshow)=@_; - # need to put in a library server loop here and return a hash my %rhash; for my $server (keys %libserv) { unless ($custom or $customshow) { @@ -1509,14 +1760,14 @@ sub plaintext { # ------------------------------------------------------------------ Plain Text sub fileembstyle { - my $ending=shift; + my $ending=lc(shift); return $fe{$ending}; } # ------------------------------------------------------------ Description Text sub filedescription { - my $ending=shift; + my $ending=lc(shift); return $fd{$ending}; } @@ -1557,6 +1808,20 @@ sub assignrole { return &reply($command,&homeserver($uname,$udom)); } +# -------------------------------------------------- Modify user authentication +sub modifyuserauth { + my ($udom,$uname,$umode,$upass)=@_; + my $uhome=&homeserver($uname,$udom); + &logthis('Call to modify user authentication'.$udom.', '.$uname.', '. + $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}); + my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'. + &escape($upass),$uhome); + unless ($reply eq 'ok') { + return 'error: '.$reply; + } + return 'ok'; +} + # --------------------------------------------------------------- Modify a user @@ -2039,12 +2304,24 @@ sub EXT { # ---------------------------------------------------------------- Get metadata sub metadata { - my ($uri,$what)=@_; + my ($uri,$what,$liburi,$prefix,$depthcount)=@_; $uri=&declutter($uri); my $filename=$uri; $uri=~s/\.meta$//; - unless ($metacache{$uri.':keys'}) { +# +# Is the metadata already cached? +# Look at timestamp of caching +# Everything is cached by the main uri, libraries are never directly cached +# + unless (abs($metacache{$uri.':cachedtimestamp'}-time)<600) { +# +# Is this a recursive call for a library? +# + if ($liburi) { + $liburi=&declutter($liburi); + $filename=$liburi; + } my %metathesekeys=(); unless ($filename=~/\.meta$/) { $filename.='.meta'; } my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename); @@ -2054,10 +2331,17 @@ sub metadata { while ($token=$parser->get_token) { if ($token->[0] eq 'S') { if (defined($token->[2]->{'package'})) { +# +# This is a package - get package info +# my $package=$token->[2]->{'package'}; my $keyroot=''; - if (defined($token->[2]->{'part'})) { - $keyroot.='_'.$token->[2]->{'part'}; + if ($prefix) { + $keyroot.='_'.$prefix; + } else { + if (defined($token->[2]->{'part'})) { + $keyroot.='_'.$token->[2]->{'part'}; + } } if (defined($token->[2]->{'id'})) { $keyroot.='_'.$token->[2]->{'id'}; @@ -2086,14 +2370,42 @@ sub metadata { } } keys %packagetab; } else { - my $entry=$token->[1]; - my $unikey=$entry; - if (defined($token->[2]->{'part'})) { - $unikey.='_'.$token->[2]->{'part'}; +# +# This is not a package - some other kind of start tag +# + my $entry=$token->[1]; + my $unikey; + if ($entry eq 'import') { + $unikey=''; + } else { + $unikey=$entry; + } + if ($prefix) { + $unikey.=$prefix; + } else { + if (defined($token->[2]->{'part'})) { + $unikey.='_'.$token->[2]->{'part'}; + } } if (defined($token->[2]->{'id'})) { $unikey.='_'.$token->[2]->{'id'}; } + + if ($entry eq 'import') { +# +# Importing a library here +# + if (defined($depthcount)) { $depthcount++; } else + { $depthcount=0; } + if ($depthcount<20) { + map { + $metathesekeys{$_}=1; + } split(/\,/,&metadata($uri,'keys', + $parser->get_text('/import'),$unikey, + $depthcount)); + } + } else { + if (defined($token->[2]->{'name'})) { $unikey.='_'.$token->[2]->{'name'}; } @@ -2106,10 +2418,16 @@ sub metadata { ) { $metacache{$uri.':'.$unikey}= $metacache{$uri.':'.$unikey.'.default'}; } - } +# end of not-a-package not-a-library import + } +# end of not-a-package start tag + } +# the next is the end of "start tag" } } $metacache{$uri.':keys'}=join(',',keys %metathesekeys); + $metacache{$uri.':cachedtimestamp'}=time; +# this is the end of "was not already recently cached } return $metacache{$uri.':'.$what}; } @@ -2139,6 +2457,7 @@ sub symblist { sub symbread { my $thisfn=shift; unless ($thisfn) { + if ($ENV{'request.symb'}) { return $ENV{'request.symb'}; } $thisfn=$ENV{'request.filename'}; } $thisfn=declutter($thisfn); @@ -2335,8 +2654,12 @@ sub unescape { # ================================================================ Main Program -sub BEGIN { -unless ($readit) { +sub goodbye { + &flushcourselogs(); + &logthis("Shutting down"); +} + +BEGIN { # ------------------------------------------------------------ Read access.conf { my $config=Apache::File->new("/etc/httpd/conf/access.conf"); @@ -2421,10 +2744,11 @@ unless ($readit) { my $config=Apache::File->new("$perlvar{'lonTabDir'}/filetypes.tab"); while (my $configline=<$config>) { + next if ($configline =~ /^\#/); chomp($configline); my ($ending,$emb,@descr)=split(/\s+/,$configline); if ($descr[0] ne '') { - $fe{$ending}=$emb; + $fe{$ending}=lc($emb); $fd{$ending}=join(' ',@descr); } } @@ -2432,9 +2756,11 @@ unless ($readit) { %metacache=(); -$readit='done'; +$processmarker=$$.'_'.time.'_'.$perlvar{'lonHostID'}; +$dumpcount=0; + &logtouch(); &logthis('INFO: Read configuration'); } -} + 1;