--- loncom/lonnet/perl/lonnet.pm 2000/10/28 19:26:07 1.53 +++ loncom/lonnet/perl/lonnet.pm 2001/10/16 08:53:19 1.164 @@ -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 @@ -24,15 +27,40 @@ # revokerole (udom,uname,url,role) : Revoke a role for url # revokecustomrole (udom,uname,url,rdom,rnam,rolename) : Revoke a custom role # appenv(hash) : adds hash to session environment -# store(hash) : stores hash permanently for this url -# cstore(hash) : critical store -# restore : returns hash for this url -# 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 -# put(namesp,hash) : stores hash in namesp -# cput(namesp,hash) : critical put -# dump(namesp) : dumps the complete namespace into a hash +# delenv(varname) : deletes all environment entries starting with varname +# 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 +# +# +# for the next 6 functions udom and uname are optional +# if supplied they use udom as the domain and uname +# as the username for the function (supply a courseid +# for the uname if you want a course database) +# if not supplied it uses %ENV and looks at +# user. attribute for the values +# +# eget(namesp,arrayref,udom,uname) +# : returns hash with keys from array reference filled +# in from namesp (encrypts the return communication) +# get(namesp,arrayref,udom,uname) +# : returns hash with keys from array reference filled +# in from namesp +# dump(namesp,udom,uname) : dumps the complete namespace into a hash +# del(namesp,array,udom,uname) : deletes keys out of array from namesp +# put(namesp,hash,udom,uname) : stores hash in namesp +# cput(namesp,hash,udom,uname) : critical put +# +# # ssi(url,hash) : does a complete request cycle on url to localhost, posts # hash # coursedescription(id) : returns and caches course description for id @@ -41,17 +69,33 @@ # directcondval(index) : reading condition value of single condition from # state string # condval(index) : value of condition index based on state -# varval(name) : value of a variable -# refreshstate() : refresh the state information string +# EXT(name) : value of a variable # symblist(map,hash) : Updates symbolic storage links # symbread([filename]) : returns the data handle (filename optional) -# rndseed() : returns a random seed +# rndseed([symb,courseid,domain,uname]) +# : returns a random seed, all arguments are optional, +# if they aren't sent it use 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 it's return +# 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 +# usection(domain,user,courseid) : output of section name/number or '' for +# "not in course" and '-1' for "no section" +# userenvironment(domain,user,what) : puts out any environment parameter +# for a user +# idput(domain,hash) : writes IDs for users from hash (name=>id,name=>id) +# idget(domain,array): returns hash with usernames (id=>name,id=>name) for +# an array of IDs +# idrget(domain,array): returns hash with IDs for usernames (name=>id,...) for +# an array of names +# 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, @@ -66,8 +110,28 @@ # 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 -# Gerd Kortemeyer +# 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 +# 10/15 Gerd Kortemeyer package Apache::lonnet; @@ -76,13 +140,25 @@ use Apache::File; use LWP::UserAgent(); use HTTP::Headers; use vars -qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp %fe %fd $readit); +qw(%perlvar %hostname %homecache %hostip %spareid %hostdom %libserv %pr %prp %fe %fd $readit %metacache %packagetab %courselogs); use IO::Socket; use GDBM_File; use Apache::Constants qw(:common :http); +use HTML::TokeParser; +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'}; @@ -122,8 +198,7 @@ sub reply { my ($cmd,$server)=@_; my $answer=subreply($cmd,$server); if ($answer eq 'con_lost') { $answer=subreply($cmd,$server); } - if (($answer=~/^error:/) || ($answer=~/^refused/) || - ($answer=~/^rejected/)) { + if (($answer=~/^refused/) || ($answer=~/^rejected/)) { &logthis("WARNING:". " $cmd to $server returned $answer"); } @@ -163,6 +238,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); @@ -215,19 +295,33 @@ sub appenv { map { if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) { &logthis("WARNING: ". - "Attempt to modify environment ".$_." to ".$newenv{$_}); + "Attempt to modify environment ".$_." to ".$newenv{$_} + .''); delete($newenv{$_}); } else { $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]); @@ -247,6 +341,52 @@ sub appenv { foreach $newname (keys %newenv) { print $fh "$newname=$newenv{$newname}\n"; } + $fh->close(); + } + + $lockfh->close(); + return 'ok'; +} +# ----------------------------------------------------- Delete from Environment + +sub delenv { + my $delthis=shift; + my %newenv=(); + if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) { + &logthis("WARNING: ". + "Attempt to delete from environment ".$delthis); + return 'error'; + } + my @oldenv; + { + my $fh; + 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'; + } + unless (flock($fh,LOCK_EX)) { + &logthis("WARNING: ". + 'Could not obtain exclusive lock in delenv: '.$!); + $fh->close(); + return 'error: '.$!; + } + map { + unless ($_=~/^$delthis/) { print $fh $_; } + } @oldenv; + $fh->close(); } return 'ok'; } @@ -328,6 +468,111 @@ sub homeserver { return 'no_host'; } +# ------------------------------------- Find the usernames behind a list of IDs + +sub idget { + my ($udom,@ids)=@_; + my %returnhash=(); + + my $tryserver; + foreach $tryserver (keys %libserv) { + if ($hostdom{$tryserver} eq $udom) { + my $idlist=join('&',@ids); + $idlist=~tr/A-Z/a-z/; + my $reply=&reply("idget:$udom:".$idlist,$tryserver); + my @answer=(); + if (($reply ne 'con_lost') && ($reply!~/^error\:/)) { + @answer=split(/\&/,$reply); + } ; + my $i; + for ($i=0;$i<=$#ids;$i++) { + if ($answer[$i]) { + $returnhash{$ids[$i]}=$answer[$i]; + } + } + } + } + return %returnhash; +} + +# ------------------------------------- Find the IDs behind a list of usernames + +sub idrget { + my ($udom,@unames)=@_; + my %returnhash=(); + map { + $returnhash{$_}=(&userenvironment($udom,$_,'id'))[1]; + } @unames; + return %returnhash; +} + +# ------------------------------- Store away a list of names and associated IDs + +sub idput { + my ($udom,%ids)=@_; + my %servers=(); + map { + my $uhom=&homeserver($_,$udom); + if ($uhom ne 'no_host') { + my $id=&escape($ids{$_}); + $id=~tr/A-Z/a-z/; + my $unam=&escape($_); + if ($servers{$uhom}) { + $servers{$uhom}.='&'.$id.'='.$unam; + } else { + $servers{$uhom}=$id.'='.$unam; + } + &critical('put:'.$udom.':'.$unam.':environment:id='.$id,$uhom); + } + } keys %ids; + map { + &critical('idput:'.$udom.':'.$servers{$_},$_); + } keys %servers; +} + +# ------------------------------------- Find the section of student in a course + +sub usection { + my ($udom,$unam,$courseid)=@_; + $courseid=~s/\_/\//g; + $courseid=~s/^(\w)/\/$1/; + map { + my ($key,$value)=split(/\=/,$_); + $key=&unescape($key); + if ($key=~/^$courseid(?:\/)*(\w+)*\_st$/) { + my $section=$1; + if ($key eq $courseid.'_st') { $section=''; } + my ($dummy,$end,$start)=split(/\_/,&unescape($value)); + my $now=time; + my $notactive=0; + if ($start) { + if ($now<$start) { $notactive=1; } + } + if ($end) { + if ($now>$end) { $notactive=1; } + } + unless ($notactive) { return $section; } + } + } split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles', + &homeserver($unam,$udom))); + return '-1'; +} + +# ------------------------------------- Read an entry from a user's environment + +sub userenvironment { + my ($udom,$unam,@what)=@_; + my %returnhash=(); + my @answer=split(/\&/, + &reply('get:'.$udom.':'.$unam.':environment:'.join('&',@what), + &homeserver($unam,$udom))); + my $i; + for ($i=0;$i<=$#what;$i++) { + $returnhash{$what[$i]}=&unescape($answer[$i]); + } + return %returnhash; +} + # ----------------------------- Subscribe to a resource, return URL if possible sub subscribe { @@ -340,6 +585,9 @@ sub subscribe { return 'not_found'; } my $answer=reply("sub:$fname",$home); + if (($answer eq 'con_lost') || ($answer eq 'rejected')) { + $answer.=' by '.$home; + } return $answer; } @@ -351,14 +599,14 @@ sub repcopy { my $transname="$filename.in.transfer"; if ((-e $filename) || (-e $transname)) { return OK; } my $remoteurl=subscribe($filename); - if ($remoteurl eq 'con_lost') { - &logthis("Subscribe returned con_lost: $filename"); + if ($remoteurl =~ /^con_lost by/) { + &logthis("Subscribe returned $remoteurl: $filename"); return HTTP_SERVICE_UNAVAILABLE; } elsif ($remoteurl eq 'not_found') { &logthis("Subscribe returned not_found: $filename"); return HTTP_NOT_FOUND; - } elsif ($remoteurl eq 'rejected') { - &logthis("Subscribe returned rejected: $filename"); + } elsif ($remoteurl =~ /^rejected by/) { + &logthis("Subscribe returned $remoteurl: $filename"); return FORBIDDEN; } elsif ($remoteurl eq 'directory') { return OK; @@ -431,60 +679,269 @@ sub log { return critical("log:$dom:$nam:$what",$hom); } +# ------------------------------------------------------------------ Course Log + +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') { + delete $courselogs{$crsid}; + } else { + &logthis('Failed to flush log buffer for '.$crsid); + if (length($courselogs{$crsid})>40000) { + &logthis("WARNING: Buffer for ".$crsid. + " exceeded maximum size, deleting."); + delete $courselogs{$crsid}; + } + } + } keys %courselogs; +} + +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; + } else { + $courselogs{$ENV{'request.course.id'}}.=$what; + } + if (length($courselogs{$ENV{'request.course.id'}})>4048) { + &flushcourselogs(); + } +} + +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 { + my ($symb,$tuname,$tudom,$tcrsid)=@_; + my $now=time; + my $lonhost=$perlvar{'lonHostID'}; + my $infostr=&escape( + $tuname.'&'. + $tudom.'&'. + $tcrsid.'&'. + $symb.'&'. + $now.'&'.$ENV{'REMOTE_ADDR'}); + my $token=&reply('tmpput:'.$infostr,$lonhost); + if ($token=~/^error\:/) { + &logthis("WARNING: ". + "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb. + ""); + return ''; + } + + $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/; + $token=~tr/a-z/A-Z/; + + my %infohash=('resource.0.outtoken' => $token, + 'resource.0.checkouttime' => $now, + 'resource.0.outremote' => $ENV{'REMOTE_ADDR'}); + + unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') { + return ''; + } else { + &logthis("WARNING: ". + "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb. + ""); + } + + if (&log($tudom,$tuname,&homeserver($tuname,$tudom), + &escape('Checkout '.$infostr.' - '. + $token)) ne 'ok') { + return ''; + } else { + &logthis("WARNING: ". + "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb. + ""); + } + return $token; +} + +# ------------------------------------------------------------ Check in an item + +sub checkin { + my $token=shift; + my $now=time; + my ($ta,$tb,$lonhost)=split(/\*/,$token); + $lonhost=~tr/A-Z/a-z/; + my $dtoken=$ta.'_'.$hostip{$lonhost}.'_'.$tb; + $dtoken=~s/\W/\_/g; + my ($tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)= + split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost))); + + unless (($tuname) && ($tudom)) { + &logthis('Check in '.$token.' ('.$dtoken.') failed'); + return ''; + } + + unless (&allowed('mgr',$tcrsid)) { + &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '. + $ENV{'user.name'}.' - '.$ENV{'user.domain'}); + return ''; + } + + my %infohash=('resource.0.intoken' => $token, + 'resource.0.checkintime' => $now, + 'resource.0.inremote' => $ENV{'REMOTE_ADDR'}); + + unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') { + return ''; + } + + if (&log($tudom,$tuname,&homeserver($tuname,$tudom), + &escape('Checkin - '.$token)) ne 'ok') { + return ''; + } + + return ($symb,$tuname,$tudom,$tcrsid); +} + +# --------------------------------------------- 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= + &del('nohist_calculatedsheet', + [$key.'studentcalc'], + $ENV{'course.'.$cid.'.domain'}, + $ENV{'course.'.$cid.'.num'}) + .' '. + &del('nohist_calculatedsheets_'.$cid, + [$key.'assesscalc:'.$symb]); + 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(/\=/,$_); $returnhash{&unescape($name)}=&unescape($value); } split(/\&/,$answer); - map { - $returnhash{$_}=$returnhash{$returnhash{'version'}.':'.$_}; - } split(/\:/,$returnhash{$returnhash{'version'}.':keys'}); + my $version; + for ($version=1;$version<=$returnhash{'version'};$version++) { + map { + $returnhash{$_}=$returnhash{$version.':'.$_}; + } split(/\:/,$returnhash{$version.':keys'}); + } return %returnhash; } @@ -495,26 +952,25 @@ sub coursedescription { $courseid=~s/^\///; $courseid=~s/\_/\//g; my ($cdomain,$cnum)=split(/\//,$courseid); - my $chome=homeserver($cnum,$cdomain); + my $chome=&homeserver($cnum,$cdomain); if ($chome ne 'no_host') { - my $rep=reply("dump:$cdomain:$cnum:environment",$chome); - if ($rep ne 'con_lost') { + my %returnhash=&dump('environment',$cdomain,$cnum); + if (!exists($returnhash{'con_lost'})) { + my $normalid=$cdomain.'_'.$cnum; my %envhash=(); - my %returnhash=('home' => $chome, - 'domain' => $cdomain, - 'num' => $cnum); - map { - my ($name,$value)=split(/\=/,$_); - $name=&unescape($name); - $value=&unescape($value); - $returnhash{$name}=$value; - my $normalid=$courseid; - $normalid=~s/\//\_/g; + $returnhash{'home'}= $chome; + $returnhash{'domain'} = $cdomain; + $returnhash{'num'} = $cnum; + while (my ($name,$value) = each %returnhash) { $envhash{'course.'.$normalid.'.'.$name}=$value; - } split(/\&/,$rep); + } $returnhash{'url'}='/res/'.declutter($returnhash{'url'}); $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'. $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum; + $envhash{'course.'.$normalid.'.last_cache'}=time; + $envhash{'course.'.$normalid.'.home'}=$chome; + $envhash{'course.'.$normalid.'.domain'}=$cdomain; + $envhash{'course.'.$normalid.'.num'}=$cnum; &appenv(%envhash); return %returnhash; } @@ -522,7 +978,7 @@ sub coursedescription { return (); } -# -------------------------------------------------------- Get user priviledges +# -------------------------------------------------------- Get user privileges sub rolesinit { my ($domain,$username,$authhost)=@_; @@ -592,16 +1048,20 @@ sub rolesinit { } } } split(/&/,$rolesdump); + my $adv=0; + my $author=0; map { %thesepriv=(); + if (($_!~/^st/) && ($_!~/^ta/) && ($_!~/^cm/)) { $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; } } } @@ -610,6 +1070,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; } @@ -617,43 +1080,51 @@ sub rolesinit { # --------------------------------------------------------------- get interface sub get { - my ($namespace,@storearr)=@_; + my ($namespace,$storearr,$udomain,$uname)=@_; my $items=''; map { $items.=escape($_).'&'; - } @storearr; + } @$storearr; $items=~s/\&$//; - my $rep=reply("get:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items", - $ENV{'user.home'}); + if (!$udomain) { $udomain=$ENV{'user.domain'}; } + if (!$uname) { $uname=$ENV{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); + + my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome); my @pairs=split(/\&/,$rep); my %returnhash=(); my $i=0; map { $returnhash{$_}=unescape($pairs[$i]); $i++; - } @storearr; + } @$storearr; return %returnhash; } # --------------------------------------------------------------- del interface sub del { - my ($namespace,@storearr)=@_; + my ($namespace,$storearr,$udomain,$uname)=@_; my $items=''; map { $items.=escape($_).'&'; - } @storearr; + } @$storearr; $items=~s/\&$//; - return reply("del:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items", - $ENV{'user.home'}); + if (!$udomain) { $udomain=$ENV{'user.domain'}; } + if (!$uname) { $uname=$ENV{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); + + return &reply("del:$udomain:$uname:$namespace:$items",$uhome); } # -------------------------------------------------------------- dump interface sub dump { - my $namespace=shift; - my $rep=reply("dump:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace", - $ENV{'user.home'}); + my ($namespace,$udomain,$uname)=@_; + if (!$udomain) { $udomain=$ENV{'user.domain'}; } + if (!$uname) { $uname=$ENV{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); + my $rep=reply("dump:$udomain:$uname:$namespace",$uhome); my @pairs=split(/\&/,$rep); my %returnhash=(); map { @@ -666,63 +1137,76 @@ sub dump { # --------------------------------------------------------------- put interface sub put { - my ($namespace,%storehash)=@_; + my ($namespace,$storehash,$udomain,$uname)=@_; + if (!$udomain) { $udomain=$ENV{'user.domain'}; } + if (!$uname) { $uname=$ENV{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); my $items=''; map { - $items.=escape($_).'='.escape($storehash{$_}).'&'; - } keys %storehash; + $items.=&escape($_).'='.&escape($$storehash{$_}).'&'; + } keys %$storehash; $items=~s/\&$//; - return reply("put:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items", - $ENV{'user.home'}); + return &reply("put:$udomain:$uname:$namespace:$items",$uhome); } # ------------------------------------------------------ critical put interface sub cput { - my ($namespace,%storehash)=@_; + my ($namespace,$storehash,$udomain,$uname)=@_; + if (!$udomain) { $udomain=$ENV{'user.domain'}; } + if (!$uname) { $uname=$ENV{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); my $items=''; map { - $items.=escape($_).'='.escape($storehash{$_}).'&'; - } keys %storehash; + $items.=escape($_).'='.escape($$storehash{$_}).'&'; + } keys %$storehash; $items=~s/\&$//; - return critical - ("put:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items", - $ENV{'user.home'}); + return &critical("put:$udomain:$uname:$namespace:$items",$uhome); } # -------------------------------------------------------------- eget interface sub eget { - my ($namespace,@storearr)=@_; + my ($namespace,$storearr,$udomain,$uname)=@_; my $items=''; map { $items.=escape($_).'&'; - } @storearr; + } @$storearr; $items=~s/\&$//; - my $rep=reply("eget:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items", - $ENV{'user.home'}); + if (!$udomain) { $udomain=$ENV{'user.domain'}; } + if (!$uname) { $uname=$ENV{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); + my $rep=&reply("eget:$udomain:$uname:$namespace:$items",$uhome); my @pairs=split(/\&/,$rep); my %returnhash=(); my $i=0; map { $returnhash{$_}=unescape($pairs[$i]); $i++; - } @storearr; + } @$storearr; return %returnhash; } -# ------------------------------------------------- Check for a user priviledge +# ------------------------------------------------- Check for a user privilege sub allowed { my ($priv,$uri)=@_; + + my $orguri=$uri; $uri=&declutter($uri); -# Free bre access to adm resources +# Free bre access to adm and meta resources - if (($uri=~/^adm\//) && ($priv eq 'bre')) { + if ((($uri=~/^adm\//) || ($uri=~/\.meta$/)) && ($priv eq 'bre')) { 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=''; @@ -741,8 +1225,11 @@ sub allowed { } # Course: uri itself is a course + my $courseuri=$uri; + $courseuri=~s/\_(\d)/\/$1/; + $courseuri=~s/^([^\/])/\/$1/; - if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$uri} + if ($ENV{'user.priv.'.$ENV{'request.role'}.'.'.$courseuri} =~/$priv\&([^\:]*)/) { $thisallowed.=$1; } @@ -759,7 +1246,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 @@ -776,7 +1263,7 @@ sub allowed { my $pathname=$uri; $pathname=~s/\/$filename$//; if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ - /\&$filename\:(\d+)\&/) { + /\&$filename\:([\d\|]+)\&/) { $statecond=$1; if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} =~/$priv\&([^\:]*)/) { @@ -784,16 +1271,31 @@ sub allowed { $checkreferer=0; } } - if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) { - my $refuri=&declutter($ENV{'HTTP_REFERER'}); + + if ($checkreferer) { + my $refuri=$ENV{'httpref.'.$orguri}; + + unless ($refuri) { + map { + if ($_=~/^httpref\..*\*/) { + my $pattern=$_; + $pattern=~s/^httpref\.\/res\///; + $pattern=~s/\*/\[\^\/\]\+/g; + $pattern=~s/\//\\\//g; + if ($orguri=~/$pattern/) { + $refuri=$ENV{$_}; + } + } + } keys %ENV; + } + if ($refuri) { + $refuri=&declutter($refuri); my @uriparts=split(/\//,$refuri); my $filename=$uriparts[$#uriparts]; my $pathname=$refuri; $pathname=~s/\/$filename$//; - my @filenameparts=split(/\./,$filename); - if (&fileembstyle($filenameparts[$#filenameparts]) ne 'ssi') { if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ - /\&$filename\:(\d+)\&/) { + /\&$filename\:([\d\|]+)\&/) { my $refstatecond=$1; if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} =~/$priv\&([^\:]*)/) { @@ -801,13 +1303,13 @@ sub allowed { $uri=$refuri; $statecond=$refstatecond; } - } } + } } } # -# Gathered now: all priviledges that could apply, and condition number +# Gathered now: all privileges that could apply, and condition number # # # Full or no access? @@ -830,37 +1332,44 @@ sub allowed { # # Possibly locked functionality, check all courses +# Locks might take effect only after 10 minutes cache expiration for other +# courses, and 2 minutes for current course my $envkey; if ($thisallowed=~/L/) { foreach $envkey (keys %ENV) { - if ($envkey=~/^user\.role\.st\.([^\.]*)/) { - my ($cdom,$cnum,$csec)=split(/\//,$1); - my %locks=(); - map { - my ($name,$value)=split(/\=/,$_); - $locks{&unescape($name)}=&unescape($value); - } split(/\&/,&reply('get:'.$cdom.':'.$cnum. - ':environment:'.&escape('priv.'.$priv.'.lock.sections'). - ':'.&escape('priv.'.$priv.'.lock.expire'). - ':'.&escape('res.'.$uri.'.lock.sections'). - ':'.&escape('res.'.$uri.'.lock.expire'), - &homeserver($cnum,$cdom))); - if (($locks{'res.'.$uri.'.lock.sections'}=~/\,$csec\,/) || - ($locks{'res.'.$uri.'.lock.sections'} eq 'all')) { - if ($locks{'res.'.$uri.'.lock.expire'}>time) { - &log('Locked by res: '.$priv.' for '.$uri.' due to '. + 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; + } + my ($cdom,$cnum,$csec)=split(/\//,$courseid); + my $prefix='course.'.$cdom.'_'.$cnum.'.'; + if ((time-$ENV{$prefix.'last_cache'})>$expiretime) { + &coursedescription($courseid); + } + if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,$csec\,/) + || ($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'}, + 'Locked by res: '.$priv.' for '.$uri.' due to '. $cdom.'/'.$cnum.'/'.$csec.' expire '. - $locks{'priv.'.$priv.'.lock.expire'}); + $ENV{$prefix.'priv.'.$priv.'.lock.expire'}); return ''; } } - if (($locks{'priv.'.$priv.'.lock.sections'}=~/\,$csec\,/) || - ($locks{'priv.'.$priv.'.lock.sections'} eq 'all')) { - if ($locks{'priv.'.$priv.'.lock.expire'}>time) { - &log('Locked by priv: '.$priv.' for '.$uri.' due to '. + if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,$csec\,/) + || ($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'}, + 'Locked by priv: '.$priv.' for '.$uri.' due to '. $cdom.'/'.$cnum.'/'.$csec.' expire '. - $locks{'priv.'.$priv.'.lock.expire'}); + $ENV{$prefix.'priv.'.$priv.'.lock.expire'}); return ''; } } @@ -884,17 +1393,35 @@ sub allowed { # Course preferences if ($thisallowed=~/C/) { -# -# Registered course preferences from environment -# + my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; + if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'} + =~/\,$rolecode\,/) { + &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, + 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. + $ENV{'request.course.id'}); + return ''; + } } # Resource preferences if ($thisallowed=~/R/) { -# -# Resource Metadata -# + my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; + my $filename=$perlvar{'lonDocRoot'}.'/res/'.$uri.'.meta'; + if (-e $filename) { + my @content; + { + my $fh=Apache::File->new($filename); + @content=<$fh>; + } + if (join('',@content)=~ + /\]*\>[^\<]*$rolecode[^\<]*\<\/roledeny\>/) { + &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, + 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); + return ''; + + } + } } # Restricted by state? @@ -910,11 +1437,6 @@ sub allowed { return 'F'; } -# ---------------------------------------------------------- Refresh State Info - -sub refreshstate { -} - # ----------------------------------------------------------------- Define Role sub definerole { @@ -957,6 +1479,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 { @@ -973,7 +1516,7 @@ sub fileembstyle { # ------------------------------------------------------------ Description Text -sub filedecription { +sub filedescription { my $ending=shift; return $fd{$ending}; } @@ -983,29 +1526,201 @@ sub filedecription { sub assignrole { my ($udom,$uname,$url,$role,$end,$start)=@_; my $mrole; - $url=declutter($url); if ($role =~ /^cr\//) { - unless ($url=~/\.course$/) { return 'invalid'; } - 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 { - unless (($url=~/\.course$/) || ($url=~/\/$/)) { return 'invalid'; } - unless (allowed('c'+$role)) { return 'refused'; } + my $cwosec=$url; + $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/; + 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'}:". "$udom:$uname:$url".'_'."$mrole=$role"; - if ($end) { $command.='_$end'; } + if ($end) { $command.='_'.$end; } if ($start) { if ($end) { - $command.='_$start'; + $command.='_'.$start; } else { - $command.='_0_$start'; + $command.='_0_'.$start; } } return &reply($command,&homeserver($uname,$udom)); } +# --------------------------------------------------------------- Modify a user + + +sub modifyuser { + my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene)=@_; + &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. + $umode.', '.$first.', '.$middle.', '. + $last.', '.$gene.' by '. + $ENV{'user.name'}.' at '.$ENV{'user.domain'}); + my $uhome=&homeserver($uname,$udom); +# ----------------------------------------------------------------- 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'}; + } else { + my $tryserver; + my $loadm=10000000; + foreach $tryserver (keys %libserv) { + if ($hostdom{$tryserver} eq $udom) { + my $answer=reply('load',$tryserver); + if (($answer=~/\d+/) && ($answer<$loadm)) { + $loadm=$answer; + $unhome=$tryserver; + } + } + } + } + if (($unhome eq '') || ($unhome eq 'no_host')) { + return 'error: find home'; + } + my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':'.$umode.':'. + &escape($upass),$unhome); + unless ($reply eq 'ok') { + return 'error: '.$reply; + } + $uhome=&homeserver($uname,$udom); + if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) { + return 'error: verify home'; + } + } +# ---------------------------------------------------------------------- Add ID + if ($uid) { + $uid=~tr/A-Z/a-z/; + my %uidhash=&idrget($udom,$uname); + if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/)) { + unless ($uid eq $uidhash{$uname}) { + return 'error: mismatch '.$uidhash{$uname}.' versus '.$uid; + } + } else { + &idput($udom,($uname => $uid)); + } + } +# -------------------------------------------------------------- Add names, etc + my %names=&get('environment', + ['firstname','middlename','lastname','generation'], + $udom,$uname); + if ($first) { $names{'firstname'} = $first; } + if ($middle) { $names{'middlename'} = $middle; } + if ($last) { $names{'lastname'} = $last; } + if ($gene) { $names{'generation'} = $gene; } + my $reply = &put('environment', \%names, $udom,$uname); + if ($reply ne 'ok') { return 'error: '.$reply; } + &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '. + $umode.', '.$first.', '.$middle.', '. + $last.', '.$gene.' by '. + $ENV{'user.name'}.' at '.$ENV{'user.domain'}); + return 'ok'; +} + +# -------------------------------------------------------------- Modify student + +sub modifystudent { + my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, + $end,$start)=@_; + 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); + unless ($reply eq 'ok') { return $reply; } + my $uhome=&homeserver($uname,$udom); + if (($uhome eq '') || ($uhome eq 'no_host')) { + return 'error: no such user'; + } +# -------------------------------------------------- Add student to course list + $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'. + $ENV{'course.'.$cid.'.num'}.':classlist:'. + &escape($uname.':'.$udom).'='. + &escape($end.':'.$start), + $ENV{'course.'.$cid.'.home'}); + unless (($reply eq 'ok') || ($reply eq 'delayed')) { + return 'error: '.$reply; + } +# ---------------------------------------------------- Add student role to user + my $uurl='/'.$cid; + $uurl=~s/\_/\//g; + if ($usec) { + $uurl.='/'.$usec; + } + return &assignrole($udom,$uname,$uurl,'st',$end,$start); +} + +# ------------------------------------------------- Write to course preferences + +sub writecoursepref { + my ($courseid,%prefs)=@_; + $courseid=~s/^\///; + $courseid=~s/\_/\//g; + my ($cdomain,$cnum)=split(/\//,$courseid); + my $chome=homeserver($cnum,$cdomain); + if (($chome eq '') || ($chome eq 'no_host')) { + return 'error: no such course'; + } + my $cstring=''; + map { + $cstring.=escape($_).'='.escape($prefs{$_}).'&'; + } keys %prefs; + $cstring=~s/\&$//; + return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome); +} + +# ---------------------------------------------------------- Make/modify course + +sub createcourse { + my ($udom,$description,$url)=@_; + $url=&declutter($url); + my $cid=''; + unless (&allowed('ccc',$ENV{'user.domain'})) { + return 'refused'; + } + unless ($udom eq $ENV{'user.domain'}) { + 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); + 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); + unless (($uhome eq '') || ($uhome eq 'no_host')) { + return 'error: unable to generate unique course-ID'; + } + } +# ------------------------------------------------------------- Make the course + my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::', + $ENV{'user.home'}); + unless ($reply eq 'ok') { return 'error: '.$reply; } + $uhome=&homeserver($uname,$udom); + if (($uhome eq '') || ($uhome eq 'no_host')) { + return 'error: no such course'; + } + &writecoursepref($udom.'_'.$uname, + ('description' => $description, + 'url' => $url)); + return '/'.$udom.'/'.$uname; +} + # ---------------------------------------------------------- Assign Custom Role sub assigncustomrole { @@ -1094,8 +1809,16 @@ sub directcondval { sub condval { my $condidx=shift; my $result=0; + my $allpathcond=''; + map { + if (defined($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_})) { + $allpathcond.= + '('.$ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_}.')|'; + } + } split(/\|/,$condidx); + $allpathcond=~s/\|$//; if ($ENV{'request.course.id'}) { - if (defined($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$condidx})) { + if ($allpathcond) { my $operand='|'; my @stack; map { @@ -1118,8 +1841,7 @@ sub condval { $result=$result>$new?$result:$new; } } - } ($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$condidx}=~ - /(\d+|\(|\)|\&|\|)/g); + } ($allpathcond=~/(\d+|\(|\)|\&|\|)/g); } } return $result; @@ -1127,8 +1849,9 @@ sub condval { # --------------------------------------------------------- Value of a Variable -sub varval { - my $varname=shift; +sub EXT { + my ($varname,$symbparm)=@_; + unless ($varname) { return ''; } my ($realm,$space,$qualifier,@therest)=split(/\./,$varname); my $rest; if ($therest[0]) { @@ -1136,15 +1859,21 @@ sub varval { } else { $rest=''; } + my $qualifierrest=$qualifier; + if ($rest) { $qualifierrest.='.'.$rest; } + my $spacequalifierrest=$space; + if ($qualifierrest) { $spacequalifierrest.='.'.$qualifierrest; } if ($realm eq 'user') { # --------------------------------------------------------------- user.resource if ($space eq 'resource') { + my %restored=&restore(); + return $restored{$qualifierrest}; # ----------------------------------------------------------------- user.access } elsif ($space eq 'access') { return &allowed($qualifier,$rest); # ------------------------------------------ user.preferences, user.environment } elsif (($space eq 'preferences') || ($space eq 'environment')) { - return $ENV{join('.',('environment',$qualifier,$rest))}; + return $ENV{join('.',('environment',$qualifierrest))}; # ----------------------------------------------------------------- user.course } elsif ($space eq 'course') { return $ENV{join('.',('request.course',$qualifier))}; @@ -1165,40 +1894,136 @@ sub varval { # ---------------------------------------------------- Any other user namespace } else { my $item=($rest)?$qualifier.'.'.$rest:$qualifier; - my %reply=&get($space,$item); + my %reply=&get($space,[$item]); return $reply{$item}; } } elsif ($realm eq 'request') { # ------------------------------------------------------------- request.browser if ($space eq 'browser') { return $ENV{'browser.'.$qualifier}; - } elsif ($space eq 'filename') { - return $ENV{'request.filename'}; +# ------------------------------------------------------------ request.filename + } else { + return $ENV{'request.'.$spacequalifierrest}; } } elsif ($realm eq 'course') { # ---------------------------------------------------------- course.description - if ($space eq 'description') { - my %reply=&coursedescription($ENV{'request.course.id'}); - return $reply{'description'}; -# ------------------------------------------------------------------- course.id - } elsif ($space eq 'id') { - return $ENV{'request.course.id'}; -# -------------------------------------------------- Any other course namespace - } else { - my ($cdom,$cnam)=split(/\_/,$ENV{'request.course.id'}); - my $chome=&homeserver($cnam,$cdom); - my $item=join('.',($qualifier,$rest)); - return &unescape - (&reply('get:'.$cdom.':'.$cnam.':'.&escape($space).':'. - &escape($item),$chome)); - } - } elsif ($realm eq 'userdata') { - my $uhome=&homeserver($qualifier,$space); -# ----------------------------------------------- userdata.domain.name.resource + return $ENV{'course.'.$ENV{'request.course.id'}.'.'. + $spacequalifierrest}; + } elsif ($realm eq 'resource') { + if ($ENV{'request.course.id'}) { +# ----------------------------------------------------- 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; + +# ----------------------------------------------------------- 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}; } + + } 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 $reply=&reply('get:'. + $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'}.'.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=''; + 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; } + +# ------------------------------------------------------------------ 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; } + } + } + # ---------------------------------------------------- Any other user namespace } elsif ($realm eq 'environment') { # ----------------------------------------------------------------- environment - return $ENV{join('.',($space,$qualifier,$rest))}; + return $ENV{'environment.'.$spacequalifierrest}; } elsif ($realm eq 'system') { # ----------------------------------------------------------------- system.time if ($space eq 'time') { @@ -1208,6 +2033,85 @@ sub varval { return ''; } +# ---------------------------------------------------------------- Get metadata + +sub metadata { + my ($uri,$what)=@_; + + $uri=&declutter($uri); + my $filename=$uri; + $uri=~s/\.meta$//; + unless ($metacache{$uri.':keys'}) { + my %metathesekeys=(); + unless ($filename=~/\.meta$/) { $filename.='.meta'; } + my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename); + my $parser=HTML::TokeParser->new(\$metastring); + my $token; + undef %metathesekeys; + while ($token=$parser->get_token) { + if ($token->[0] eq 'S') { + if (defined($token->[2]->{'package'})) { + my $package=$token->[2]->{'package'}; + my $keyroot=''; + if (defined($token->[2]->{'part'})) { + $keyroot.='_'.$token->[2]->{'part'}; + } + if (defined($token->[2]->{'id'})) { + $keyroot.='.'.$token->[2]->{'id'}; + } + if ($metacache{$uri.':packages'}) { + $metacache{$uri.':packages'}.=','.$package.$keyroot; + } else { + $metacache{$uri.':packages'}=$package.$keyroot; + } + map { + if ($_=~/^$package\&/) { + my ($pack,$name,$subp)=split(/\&/,$_); + my $value=$packagetab{$_}; + my $part=$keyroot; + $part=~s/^\_//; + $part=~s/\./\_/g; + if ($subp eq 'display') { + $value.=' [Part: '.$part.']'; + } + my $unikey='parameter'.$keyroot.'_'.$name; + $metathesekeys{$unikey}=1; + $metacache{$uri.':'.$unikey.'.part'}=$part; + unless + (defined($metacache{$uri.':'.$unikey.'.'.$subp})) { + $metacache{$uri.':'.$unikey.'.'.$subp}=$value; + } + } + } keys %packagetab; + } else { + my $entry=$token->[1]; + my $unikey=$entry; + if (defined($token->[2]->{'part'})) { + $unikey.='_'.$token->[2]->{'part'}; + } + if (defined($token->[2]->{'id'})) { + $unikey.='.'.$token->[2]->{'id'}; + } + if (defined($token->[2]->{'name'})) { + $unikey.='_'.$token->[2]->{'name'}; + } + $metathesekeys{$unikey}=1; + map { + $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_}; + } @{$token->[3]}; + unless ( + $metacache{$uri.':'.$unikey}=$parser->get_text('/'.$entry) + ) { $metacache{$uri.':'.$unikey}= + $metacache{$uri.':'.$unikey.'.default'}; + } + } + } + } + $metacache{$uri.':keys'}=join(',',keys %metathesekeys); + } + return $metacache{$uri.':'.$what}; +} + # ------------------------------------------------- Update symbolic store links sub symblist { @@ -1260,6 +2164,9 @@ sub symbread { &GDBM_READER,0640)) { # ---------------------------------------------- Get ID(s) for current resource my $ids=$bighash{'ids_/res/'.$thisfn}; + unless ($ids) { + $ids=$bighash{'ids_/'.$thisfn}; + } if ($ids) { # ------------------------------------------------------------------- Has ID(s) my @possibilities=split(/\,/,$ids); @@ -1287,7 +2194,9 @@ sub symbread { untie(%bighash) } } - if ($syval) { return $syval.'___'.$thisfn; } + if ($syval) { + return $syval.'___'.$thisfn; + } } &appenv('request.ambiguous' => $thisfn); return ''; @@ -1308,20 +2217,50 @@ 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); + my ($symb,$courseid,$domain,$username)=@_; + if (!$symb) { + unless ($symb=&symbread()) { return time; } + } + if (!$courseid) { $courseid=$ENV{'request.course.id'};} + if (!$domain) {$domain=$ENV{'user.domain'};} + if (!$username) {$username=$ENV{'user.name'};} + { + use integer; + my $symbchck=unpack("%32C*",$symb) << 27; + my $symbseed=numval($symb) << 22; + my $namechck=unpack("%32C*",$username) << 17; + my $nameseed=numval($username) << 12; + my $domainseed=unpack("%32C*",$domain) << 7; + my $courseseed=unpack("%32C*",$courseid); + 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 { + my ($funame,$fudom,$fucourseid,$fusymb)=@_; + my $cuname=unpack("%32C*",$funame); + my $cudom=unpack("%32C*",$fudom); + my $cucourseid=unpack("%32C*",$fucourseid); + my $cusymb=unpack("%32C*",$fusymb); + my $cunique=unpack("%32C*",$perlvar{'lonReceipt'}); + return unpack("%32C*",$perlvar{'lonHostID'}).'-'. + ($cunique%$cuname+ + $cunique%$cudom+ + $cusymb%$cuname+ + $cusymb%$cudom+ + $cucourseid%$cuname+ + $cucourseid%$cudom); +} + +sub receipt { + return &ireceipt($ENV{'user.name'},$ENV{'user.domain'}, + $ENV{'request.course.id'},&symbread()); +} + # ------------------------------------------------------------ Serves up a file # returns either the contents of the file or a -1 sub getfile { @@ -1338,12 +2277,17 @@ sub filelocation { my ($dir,$file) = @_; my $location; $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces - $file=~s/^$perlvar{'lonDocRoot'}//; - $file=~s:^/*res::; - if ( !( $file =~ m:^/:) ) { - $location = $dir. '/'.$file; + if ($file=~m:^/~:) { # is a contruction space reference + $location = $file; + $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; } else { - $location = '/home/httpd/html/res'.$file; + $file=~s/^$perlvar{'lonDocRoot'}//; + $file=~s:^/*res::; + if ( !( $file =~ m:^/:) ) { + $location = $dir. '/'.$file; + } else { + $location = '/home/httpd/html/res'.$file; + } } $location=~s://+:/:g; # remove duplicate / while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/.. @@ -1390,7 +2334,7 @@ sub unescape { # ================================================================ Main Program sub BEGIN { -if ($readit ne 'done') { +unless ($readit) { # ------------------------------------------------------------ Read access.conf { my $config=Apache::File->new("/etc/httpd/conf/access.conf"); @@ -1409,9 +2353,11 @@ if ($readit ne 'done') { my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab"); 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; } } } @@ -1433,8 +2379,10 @@ if ($readit ne 'done') { while (my $configline=<$config>) { chomp($configline); + if ($configline) { my ($role,$perm)=split(/ /,$configline); if ($perm ne '') { $pr{$role}=$perm; } + } } } @@ -1444,8 +2392,25 @@ if ($readit ne 'done') { while (my $configline=<$config>) { chomp($configline); + if ($configline) { my ($short,$plain)=split(/:/,$configline); if ($plain ne '') { $prp{$short}=$plain; } + } + } +} + +# ---------------------------------------------------------- Read package table +{ + my $config=Apache::File->new("$perlvar{'lonTabDir'}/packages.tab"); + + while (my $configline=<$config>) { + chomp($configline); + my ($short,$plain)=split(/:/,$configline); + my ($pack,$name)=split(/\&/,$short); + if ($plain ne '') { + $packagetab{$pack.'&'.$name.'&name'}=$name; + $packagetab{$short}=$plain; + } } } @@ -1463,8 +2428,10 @@ if ($readit ne 'done') { } } +%metacache=(); $readit='done'; +&logtouch(); &logthis('INFO: Read configuration'); } } 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.