--- loncom/lonnet/perl/lonnet.pm 2001/09/20 16:09:07 1.157 +++ loncom/lonnet/perl/lonnet.pm 2001/12/05 14:48:28 1.182 @@ -1,6 +1,71 @@ # The LearningOnline Network # TCP networking package # +# $Id: lonnet.pm,v 1.182 2001/12/05 14:48:28 matthew 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 +# +# $Id: lonnet.pm,v 1.182 2001/12/05 14:48:28 matthew Exp $ +# +### + # Functions for use by content handlers: # # metadata_query(sql-query-string,custom-metadata-regex) : @@ -97,37 +162,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 -# 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 Gerd Kortemeyer package Apache::lonnet; @@ -145,6 +179,16 @@ use Fcntl qw(:flock); # --------------------------------------------------------------------- Logging +sub logtouch { + my $execdir=$perlvar{'lonDaemons'}; + unless (-e "$execdir/logs/lonnet.log") { + my $fh=Apache::File->new(">>$execdir/logs/lonnet.log"); + close $fh; + } + my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3]; + chown($wwwuid,$wwwgid,$execdir.'/logs/lonnet.log'); +} + sub logthis { my $message=shift; my $execdir=$perlvar{'lonDaemons'}; @@ -393,6 +437,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 { @@ -689,6 +771,7 @@ sub flushcourselogs { sub courselog { my $what=shift; + $what=time.':'.$what; unless ($ENV{'request.course.id'}) { return ''; } if (defined $courselogs{$ENV{'request.course.id'}}) { $courselogs{$ENV{'request.course.id'}}.='&'.$what; @@ -700,6 +783,20 @@ sub courselog { } } +sub courseacclog { + my $fnsymb=shift; + unless ($ENV{'request.course.id'}) { return ''; } + my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'}; + if ($what=~/(problem|exam|quiz|assess|survey|form)$/) { + map { + if ($_=~/^form\.(.*)/) { + $what.=':'.$1.'='.$ENV{$_}; + } + } keys %ENV; + } + &courselog($what); +} + # ----------------------------------------------------------- Check out an item sub checkout { @@ -826,15 +923,155 @@ 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 ''; } } @@ -859,9 +1096,7 @@ 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 ''; } } @@ -887,9 +1122,7 @@ 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 ''; } @@ -1172,6 +1405,12 @@ sub allowed { return 'F'; } +# Free bre to public access + + if ($priv eq 'bre') { + if (&metadata($uri,'copyright') eq 'public') { return 'F'; } + } + my $thisallowed=''; my $statecond=0; my $courseprivid=''; @@ -1207,7 +1446,7 @@ sub allowed { # If this is generating or modifying users, exit with special codes - if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:'=~/\:$priv\:/) { + if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:$priv\:/) { return $thisallowed; } # @@ -1448,7 +1687,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) { @@ -1475,14 +1713,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}; } @@ -1523,6 +1761,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 @@ -1611,7 +1863,7 @@ sub modifystudent { return 'error: no such user'; } # -------------------------------------------------- Add student to course list - my $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'. + $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'. $ENV{'course.'.$cid.'.num'}.':classlist:'. &escape($uname.':'.$udom).'='. &escape($end.':'.$start), @@ -1676,7 +1928,7 @@ sub createcourse { my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::', $ENV{'user.home'}); unless ($reply eq 'ok') { return 'error: '.$reply; } - my $uhome=&homeserver($uname,$udom); + $uhome=&homeserver($uname,$udom); if (($uhome eq '') || ($uhome eq 'no_host')) { return 'error: no such course'; } @@ -2005,12 +2257,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); @@ -2020,10 +2284,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'}; @@ -2052,14 +2323,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'}; } @@ -2072,10 +2371,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}; } @@ -2105,6 +2410,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); @@ -2301,8 +2607,7 @@ sub unescape { # ================================================================ Main Program -sub BEGIN { -if ($readit ne 'done') { +BEGIN { # ------------------------------------------------------------ Read access.conf { my $config=Apache::File->new("/etc/httpd/conf/access.conf"); @@ -2347,8 +2652,10 @@ if ($readit ne 'done') { while (my $configline=<$config>) { chomp($configline); + if ($configline) { my ($role,$perm)=split(/ /,$configline); if ($perm ne '') { $pr{$role}=$perm; } + } } } @@ -2358,8 +2665,10 @@ if ($readit ne 'done') { while (my $configline=<$config>) { chomp($configline); + if ($configline) { my ($short,$plain)=split(/:/,$configline); if ($plain ne '') { $prp{$short}=$plain; } + } } } @@ -2383,10 +2692,11 @@ if ($readit ne 'done') { my $config=Apache::File->new("$perlvar{'lonTabDir'}/filetypes.tab"); while (my $configline=<$config>) { + next if (/^\#/); chomp($configline); my ($ending,$emb,@descr)=split(/\s+/,$configline); if ($descr[0] ne '') { - $fe{$ending}=$emb; + $fe{$ending}=lc($emb); $fd{$ending}=join(' ',@descr); } } @@ -2395,7 +2705,8 @@ if ($readit ne 'done') { %metacache=(); $readit='done'; +&logtouch(); &logthis('INFO: Read configuration'); } -} + 1;