--- loncom/lonnet/perl/lonnet.pm 2001/01/05 20:45:09 1.87 +++ loncom/lonnet/perl/lonnet.pm 2001/06/01 19:32:40 1.128 @@ -3,6 +3,9 @@ # # Functions for use by content handlers: # +# metadata_query(sql-query-string,custom-metadata-regex) : +# returns file handle of where sql and +# regex results will be stored for query # plaintext(short) : plain text explanation of short term # fileembstyle(ext) : embed style in page for file extension # filedescription(ext) : descriptor text for file extension @@ -13,7 +16,7 @@ # 1: user needs to choose course # 2: browse allowed # definerole(rolename,sys,dom,cou) : define a custom role rolename -# set priviledges in format of lonTabs/roles.tab for +# set privileges in format of lonTabs/roles.tab for # system, domain and course level, # assignrole(udom,uname,url,role,end,start) : give a role to a user for the # level given by url. Optional start and end dates @@ -25,9 +28,18 @@ # revokecustomrole (udom,uname,url,rdom,rnam,rolename) : Revoke a custom role # appenv(hash) : adds hash to session environment # delenv(varname) : deletes all environment entries starting with varname -# store(hash) : stores hash permanently for this url -# cstore(hash) : critical store -# restore : returns hash for this url +# store(hashref,symb,courseid,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 +# cstore(hashref,symb,courseid,udom,uname) +# : same as store but uses the critical interface to +# guarentee a store +# restore(symb,courseid,udom,uname) +# : returns hash for this symb, all args are optional +# if they aren't given they will be derived from the +# current enviroment # eget(namesp,array) : returns hash with keys from array filled in from namesp # get(namesp,array) : returns hash with keys from array filled in from namesp # del(namesp,array) : deletes keys out of array from namesp @@ -49,7 +61,7 @@ # receipt() : returns a receipt to be given out to users # getfile(filename) : returns the contents of filename, or a -1 if it can't # be found, replicates and subscribes to the file -# filelocation(dir,file) : returns a farily clean absolute reference to file +# filelocation(dir,file) : returns a fairly clean absolute reference to file # from the directory dir # hreflocation(dir,file) : same as filelocation, but for hrefs # log(domain,user,home,msg) : write to permanent log for user @@ -83,7 +95,18 @@ # 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 Gerd Kortemeyer +# 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 +# package Apache::lonnet; @@ -97,6 +120,7 @@ use IO::Socket; use GDBM_File; use Apache::Constants qw(:common :http); use HTML::TokeParser; +use Fcntl qw(:flock); # --------------------------------------------------------------------- Logging @@ -179,6 +203,11 @@ sub reconlonc { sub critical { my ($cmd,$server)=@_; + unless ($hostname{$server}) { + &logthis("WARNING:". + " Critical message to unknown server ($server)"); + return 'no_such_host'; + } my $answer=reply($cmd,$server); if ($answer eq 'con_lost') { my $pingreply=reply('ping',$server); @@ -237,13 +266,26 @@ sub appenv { $ENV{$_}=$newenv{$_}; } } keys %newenv; + + my $lockfh; + unless ($lockfh=Apache::File->new("$ENV{'user.environment'}")) { + return 'error: '.$!; + } + unless (flock($lockfh,LOCK_EX)) { + &logthis("WARNING: ". + 'Could not obtain exclusive lock in appenv: '.$!); + $lockfh->close(); + return 'error: '.$!; + } + my @oldenv; { my $fh; unless ($fh=Apache::File->new("$ENV{'user.environment'}")) { - return 'error'; + return 'error: '.$!; } @oldenv=<$fh>; + $fh->close(); } for (my $i=0; $i<=$#oldenv; $i++) { chomp($oldenv[$i]); @@ -260,12 +302,13 @@ sub appenv { return 'error'; } my $newname; - flock($fh,'LOCK_EX'); foreach $newname (keys %newenv) { print $fh "$newname=$newenv{$newname}\n"; } $fh->close(); } + + $lockfh->close(); return 'ok'; } # ----------------------------------------------------- Delete from Environment @@ -284,14 +327,26 @@ sub delenv { unless ($fh=Apache::File->new("$ENV{'user.environment'}")) { return 'error'; } + unless (flock($fh,LOCK_SH)) { + &logthis("WARNING: ". + 'Could not obtain shared lock in delenv: '.$!); + $fh->close(); + return 'error: '.$!; + } @oldenv=<$fh>; + $fh->close(); } { my $fh; unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) { return 'error'; } - flock($fh,'LOCK_EX'); + unless (flock($fh,LOCK_EX)) { + &logthis("WARNING: ". + 'Could not obtain exclusive lock in delenv: '.$!); + $fh->close(); + return 'error: '.$!; + } map { unless ($_=~/^$delthis/) { print $fh $_; } } @oldenv; @@ -588,52 +643,126 @@ sub log { return critical("log:$dom:$nam:$what",$hom); } +# --------------------------------------------- Set Expire Date for Spreadsheet + +sub expirespread { + my ($uname,$udom,$stype,$usymb)=@_; + my $cid=$ENV{'request.course.id'}; + if ($cid) { + my $now=time; + my $key=$uname.':'.$udom.':'.$stype.':'.$usymb; + return &reply('put:'.$ENV{'course.'.$cid.'.domain'}.':'. + $ENV{'course.'.$cid.'.num'}. + ':nohist_expirationdates:'. + &escape($key).'='.$now, + $ENV{'course.'.$cid.'.home'}) + } + return 'ok'; +} + +# ----------------------------------------------------- Devalidate Spreadsheets + +sub devalidate { + my $symb=shift; + my $cid=$ENV{'request.course.id'}; + if ($cid) { + my $key=$ENV{'user.name'}.':'.$ENV{'user.domain'}.':'; + my $status= + &reply('del:'.$ENV{'course.'.$cid.'.domain'}.':'. + $ENV{'course.'.$cid.'.num'}. + ':nohist_calculatedsheets:'. + &escape($key.'studentcalc:'), + $ENV{'course.'.$cid.'.home'}) + .' '. + &reply('del:'.$ENV{'user.domain'}.':'. + $ENV{'user.name'}. + ':nohist_calculatedsheets_'.$cid.':'. + &escape($key.'assesscalc:'.$symb), + $ENV{'user.home'}); + unless ($status eq 'ok ok') { + &logthis('Could not devalidate spreadsheet '. + $ENV{'user.name'}.' at '.$ENV{'user.domain'}.' for '. + $symb.': '.$status); + } + } +} + # ----------------------------------------------------------------------- Store sub store { - my %storehash=@_; - my $symb; - unless ($symb=escape(&symbread())) { return ''; } - my $namespace; - unless ($namespace=$ENV{'request.course.id'}) { return ''; } + my ($storehash,$symb,$namespace,$domain,$stuname) = @_; + my $home=''; + + 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 (!$domain) { $domain=$ENV{'user.domain'}; } + if (!$stuname) { $stuname=$ENV{'user.name'}; } + if (!$home) { $home=$ENV{'user.home'}; } my $namevalue=''; map { - $namevalue.=escape($_).'='.escape($storehash{$_}).'&'; - } keys %storehash; + $namevalue.=escape($_).'='.escape($$storehash{$_}).'&'; + } keys %$storehash; $namevalue=~s/\&$//; - return reply( - "store:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$symb:$namevalue", - "$ENV{'user.home'}"); + return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home"); } # -------------------------------------------------------------- Critical Store sub cstore { - my %storehash=@_; - my $symb; - unless ($symb=escape(&symbread())) { return ''; } - my $namespace; - unless ($namespace=$ENV{'request.course.id'}) { return ''; } + my ($storehash,$symb,$namespace,$domain,$stuname) = @_; + my $home=''; + + 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 (!$domain) { $domain=$ENV{'user.domain'}; } + if (!$stuname) { $stuname=$ENV{'user.name'}; } + if (!$home) { $home=$ENV{'user.home'}; } + my $namevalue=''; map { - $namevalue.=escape($_).'='.escape($storehash{$_}).'&'; - } keys %storehash; + $namevalue.=escape($_).'='.escape($$storehash{$_}).'&'; + } keys %$storehash; $namevalue=~s/\&$//; - return critical( - "store:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$symb:$namevalue", - "$ENV{'user.home'}"); + return critical("store:$domain:$stuname:$namespace:$symb:$namevalue","$home"); } # --------------------------------------------------------------------- Restore sub restore { - my $symb; - unless ($symb=escape(&symbread())) { return ''; } - my $namespace; - unless ($namespace=$ENV{'request.course.id'}) { return ''; } - my $answer=reply( - "restore:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$symb", - "$ENV{'user.home'}"); + my ($symb,$namespace,$domain,$stuname) = @_; + my $home=''; + + 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 (!$domain) { $domain=$ENV{'user.domain'}; } + if (!$stuname) { $stuname=$ENV{'user.name'}; } + if (!$home) { $home=$ENV{'user.home'}; } + my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home"); + my %returnhash=(); map { my ($name,$value)=split(/\=/,$_); @@ -659,8 +788,7 @@ sub coursedescription { if ($chome ne 'no_host') { my $rep=reply("dump:$cdomain:$cnum:environment",$chome); if ($rep ne 'con_lost') { - my $normalid=$courseid; - $normalid=~s/\//\_/g; + my $normalid=$cdomain.'_'.$cnum; my %envhash=(); my %returnhash=('home' => $chome, 'domain' => $cdomain, @@ -686,7 +814,7 @@ sub coursedescription { return (); } -# -------------------------------------------------------- Get user priviledges +# -------------------------------------------------------- Get user privileges sub rolesinit { my ($domain,$username,$authhost)=@_; @@ -756,16 +884,20 @@ sub rolesinit { } } } split(/&/,$rolesdump); + my $adv=0; + my $author=0; map { %thesepriv=(); + if ($_!~/^st/) { $adv=1; } + if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; } map { if ($_ ne '') { - my ($priviledge,$restrictions)=split(/&/,$_); + my ($privilege,$restrictions)=split(/&/,$_); if ($restrictions eq '') { - $thesepriv{$priviledge}='F'; + $thesepriv{$privilege}='F'; } else { - if ($thesepriv{$priviledge} ne 'F') { - $thesepriv{$priviledge}.=$restrictions; + if ($thesepriv{$privilege} ne 'F') { + $thesepriv{$privilege}.=$restrictions; } } } @@ -774,6 +906,9 @@ sub rolesinit { map { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } keys %thesepriv; $userroles.='user.priv.'.$_.'='.$thesestr."\n"; } keys %allroles; + $userroles.='user.adv='.$adv."\n". + 'user.author='.$author."\n"; + $ENV{'user.adv'}=$adv; } return $userroles; } @@ -875,7 +1010,7 @@ sub eget { return %returnhash; } -# ------------------------------------------------- Check for a user priviledge +# ------------------------------------------------- Check for a user privilege sub allowed { my ($priv,$uri)=@_; @@ -926,7 +1061,7 @@ sub allowed { return $thisallowed; } # -# Gathered so far: system, domain and course wide priviledges +# Gathered so far: system, domain and course wide privileges # # Course: See if uri or referer is an individual resource that is part of # the course @@ -977,7 +1112,7 @@ sub allowed { } # -# Gathered now: all priviledges that could apply, and condition number +# Gathered now: all privileges that could apply, and condition number # # # Full or no access? @@ -1009,6 +1144,7 @@ sub allowed { if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) { my $courseid=$2; my $roleid=$1.'.'.$2; + $courseid=~s/^\///; my $expiretime=600; if ($ENV{'request.role'} eq $roleid) { $expiretime=120; @@ -1146,6 +1282,27 @@ sub definerole { } } +# ---------------- Make a metadata query against the network of library servers + +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) { + my $reply=&reply("querysend:".&escape($query),$server); + $rhash{$server}=$reply; + } + else { + my $reply=&reply("querysend:".&escape($query).':'. + &escape($custom).':'.&escape($customshow), + $server); + $rhash{$server}=$reply; + } + } + return \%rhash; +} + # ------------------------------------------------------------------ Plain Text sub plaintext { @@ -1173,12 +1330,22 @@ sub assignrole { my ($udom,$uname,$url,$role,$end,$start)=@_; my $mrole; if ($role =~ /^cr\//) { - unless (&allowed('ccr',$url)) { return 'refused'; } + unless (&allowed('ccr',$url)) { + &logthis('Refused custom assignrole: '. + $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. + $ENV{'user.name'}.' at '.$ENV{'user.domain'}); + return 'refused'; + } $mrole='cr'; } else { my $cwosec=$url; $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/; - unless (&allowed('c'.$role,$cwosec)) { return 'refused'; } + unless (&allowed('c'.$role,$cwosec)) { + &logthis('Refused assignrole: '. + $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. + $ENV{'user.name'}.' at '.$ENV{'user.domain'}); + return 'refused'; + } $mrole=$role; } my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:". @@ -1509,7 +1676,7 @@ sub EXT { if ($realm eq 'user') { # --------------------------------------------------------------- user.resource if ($space eq 'resource') { - my %restored=&restore; + my %restored=&restore(); return $restored{$qualifierrest}; # ----------------------------------------------------------------- user.access } elsif ($space eq 'access') { @@ -1550,69 +1717,79 @@ sub EXT { } } elsif ($realm eq 'course') { # ---------------------------------------------------------- course.description - my $section=''; - if ($ENV{'request.course.sec'}) { - $section='_'.$ENV{'request.course.sec'}; - } - return $ENV{'course.'.$ENV{'request.course.id'}.$section.'.'. + return $ENV{'course.'.$ENV{'request.course.id'}.'.'. $spacequalifierrest}; } elsif ($realm eq 'resource') { - if ($ENV{'request.course.id'}) { + if ($ENV{'request.course.id'}) { # ----------------------------------------------------- Cascading lookup scheme - my $symbp=&symbread(); - my $mapp=(split(/\_\_\_/,$symbp))[0]; + my $symbp=&symbread(); + my $mapp=(split(/\_\_\_/,$symbp))[0]; - my $symbparm=$symbp.'.'.$spacequalifierrest; - my $mapparm=$mapp.'___(all).'.$spacequalifierrest; + my $symbparm=$symbp.'.'.$spacequalifierrest; + my $mapparm=$mapp.'___(all).'.$spacequalifierrest; - my $seclevel= + my $seclevel= $ENV{'request.course.id'}.'.['. $ENV{'request.course.sec'}.'].'.$spacequalifierrest; - my $seclevelr= + my $seclevelr= $ENV{'request.course.id'}.'.['. $ENV{'request.course.sec'}.'].'.$symbparm; - my $seclevelm= + my $seclevelm= $ENV{'request.course.id'}.'.['. $ENV{'request.course.sec'}.'].'.$mapparm; - my $courselevel= + my $courselevel= $ENV{'request.course.id'}.'.'.$spacequalifierrest; - my $courselevelr= + my $courselevelr= $ENV{'request.course.id'}.'.'.$symbparm; - my $courselevelm= + my $courselevelm= $ENV{'request.course.id'}.'.'.$mapparm; - # ----------------------------------------------------------- first, check user - my %resourcedata=get('resourcedata', + my %resourcedata=get('resourcedata', ($courselevelr,$courselevelm,$courselevel)); - if ($resourcedata{$courselevelr}!~/^error\:/) { + 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}; } + 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 ".$ENV{'user.name'}." at " + .$ENV{'user.domain'}.": ".$resourcedata{$courselevelr}. + ""); + } } + # -------------------------------------------------------- second, check course - my $section=''; - if ($ENV{'request.course.sec'}) { - $section='_'.$ENV{'request.course.sec'}; - } + my $reply=&reply('get:'. - $ENV{'course.'.$ENV{'request.course.id'}.$section.'.domain'}.':'. - $ENV{'course.'.$ENV{'request.course.id'}.$section.'.num'}. + $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'. + $ENV{'course.'.$ENV{'request.course.id'}.'.num'}. ':resourcedata:'. &escape($seclevelr).'&'.&escape($seclevelm).'&'.&escape($seclevel).'&'. &escape($courselevelr).'&'.&escape($courselevelm).'&'.&escape($courselevel), - $ENV{'course.'.$ENV{'request.course.id'}.$section.'.home'}); + $ENV{'course.'.$ENV{'request.course.id'}.'.home'}); if ($reply!~/^error\:/) { map { if ($_) { return &unescape($_); } } split(/\&/,$reply); } - + if (($reply=~/^con_lost/) || ($reply=~/^error\:/)) { + &logthis("WARNING:". + " Getting ".$reply." asking for ".$varname." for ". + $ENV{'course.'.$ENV{'request.course.id'}.'.num'}. + ' at '. + $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}. + ' from '. + $ENV{'course.'.$ENV{'request.course.id'}.'.home'}. + ""); + } # ------------------------------------------------------ third, check map parms my %parmhash=(); my $thisparm=''; @@ -1636,7 +1813,7 @@ sub EXT { # ---------------------------------------------------- Any other user namespace } elsif ($realm eq 'environment') { # ----------------------------------------------------------------- environment - return $ENV{$spacequalifierrest}; + return $ENV{'environment.'.$spacequalifierrest}; } elsif ($realm eq 'system') { # ----------------------------------------------------------------- system.time if ($space eq 'time') { @@ -1795,16 +1972,20 @@ sub numval { sub rndseed { my $symb; unless ($symb=&symbread()) { return time; } - my $symbchck=unpack("%32C*",$symb); - my $symbseed=numval($symb)%$symbchck; - my $namechck=unpack("%32C*",$ENV{'user.name'}); - my $nameseed=numval($ENV{'user.name'})%$namechck; - return int( $symbseed - .$nameseed - .unpack("%32C*",$ENV{'user.domain'}) - .unpack("%32C*",$ENV{'request.course.id'}) - .$namechck - .$symbchck); + { + use integer; + my $symbchck=unpack("%32C*",$symb) << 27; + my $symbseed=numval($symb) << 22; + my $namechck=unpack("%32C*",$ENV{'user.name'}) << 17; + my $nameseed=numval($ENV{'user.name'}) << 12; + my $domainseed=unpack("%32C*",$ENV{'user.domain'}) << 7; + my $courseseed=unpack("%32C*",$ENV{'request.course.id'}); + my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck; + #uncommenting these lines can break things! + #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); + #&Apache::lonxml::debug("rndseed :$num:$symb"); + return $num; + } } sub ireceipt { 500 Internal Server Error

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.

More information about this error may be available in the server error log.