--- loncom/lonnet/perl/lonnet.pm 2000/11/28 02:48:25 1.73 +++ loncom/lonnet/perl/lonnet.pm 2001/01/11 11:11:27 1.97 @@ -45,7 +45,8 @@ # 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() : returns a random seed +# 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 @@ -79,7 +80,12 @@ # 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 Gerd Kortemeyer +# 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 package Apache::lonnet; @@ -93,6 +99,7 @@ use IO::Socket; use GDBM_File; use Apache::Constants qw(:common :http); use HTML::TokeParser; +use Fcntl qw(:flock); # --------------------------------------------------------------------- Logging @@ -175,6 +182,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); @@ -233,13 +245,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]); @@ -259,7 +284,10 @@ sub appenv { foreach $newname (keys %newenv) { print $fh "$newname=$newenv{$newname}\n"; } + $fh->close(); } + + $lockfh->close(); return 'ok'; } # ----------------------------------------------------- Delete from Environment @@ -278,16 +306,30 @@ 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'; } + 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'; } @@ -382,7 +424,7 @@ sub idget { $idlist=~tr/A-Z/a-z/; my $reply=&reply("idget:$udom:".$idlist,$tryserver); my @answer=(); - if ($reply ne 'con_lost') { + if (($reply ne 'con_lost') && ($reply!~/^error\:/)) { @answer=split(/\&/,$reply); } ; my $i; @@ -631,9 +673,12 @@ sub restore { 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; } @@ -648,8 +693,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, @@ -896,7 +940,9 @@ sub allowed { # Course: uri itself is a course my $courseuri=$uri; $courseuri=~s/\_(\d)/\/$1/; - if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseuri} + $courseuri=~s/^([^\/])/\/$1/; + + if ($ENV{'user.priv.'.$ENV{'request.role'}.'.'.$courseuri} =~/$priv\&([^\:]*)/) { $thisallowed.=$1; } @@ -938,7 +984,7 @@ sub allowed { $checkreferer=0; } } - + if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) { my $refuri=$ENV{'HTTP_REFERER'}; $refuri=~s/^http\:\/\/$ENV{'request.host'}//i; @@ -996,6 +1042,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; @@ -1149,7 +1196,7 @@ sub fileembstyle { # ------------------------------------------------------------ Description Text -sub filedecription { +sub filedescription { my $ending=shift; return $fd{$ending}; } @@ -1159,29 +1206,198 @@ 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)) { 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)) { 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=&reply('get:'.$udom.':'.$uname. + ':environment:firstname&middlename&lastname&generation', + $uhome); + my ($efirst,$emiddle,$elast,$egene)=split(/\&/,$names); + if ($first) { $efirst = &escape($first); } + if ($middle) { $emiddle = &escape($middle); } + if ($last) { $elast = &escape($last); } + if ($gene) { $egene = &escape($gene); } + my $reply=&reply('put:'.$udom.':'.$uname. + ':environment:firstname='.$efirst. + '&middlename='.$emiddle. + '&lastname='.$elast. + '&generation='.$egene,$uhome); + 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 + my $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; } + my $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 { @@ -1400,11 +1616,11 @@ sub EXT { my $courselevelm= $ENV{'request.course.id'}.'.'.$mapparm; - # ----------------------------------------------------------- first, check user 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}; } @@ -1412,37 +1628,39 @@ sub EXT { 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'}. - ':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'}.'.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 { - my ($name,$value)=split(/\=/,$_); - $resourcedata{unescape($name)}=unescape($value); - } split(/\&/,$reply); - - if ($resourcedata{$seclevelr}) { return $resourcedata{$seclevelr}; } - if ($resourcedata{$seclevelm}) { return $resourcedata{$seclevelm}; } - if ($resourcedata{$seclevel}) { return $resourcedata{$seclevel}; } - - if ($resourcedata{$courselevelr}) { - return $resourcedata{$courselevelr}; } - if ($resourcedata{$courselevelm}) { - return $resourcedata{$courselevelm}; } - if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; } - + 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=''; @@ -1456,8 +1674,12 @@ sub EXT { # --------------------------------------------- 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; } # ---------------------------------------------------- Any other user namespace } elsif ($realm eq 'environment') { @@ -1476,6 +1698,7 @@ sub EXT { sub metadata { my ($uri,$what)=@_; + $uri=&declutter($uri); my $filename=$uri; $uri=~s/\.meta$//; @@ -1502,7 +1725,11 @@ sub metadata { map { $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_}; } @{$token->[3]}; - $metacache{$uri.':'.$unikey}=$parser->get_text('/'.$entry); + unless ( + $metacache{$uri.':'.$unikey}=$parser->get_text('/'.$entry) + ) { $metacache{$uri.':'.$unikey}= + $metacache{$uri.':'.$unikey.'.default'}; + } } } } @@ -1628,6 +1855,27 @@ sub rndseed { .$symbchck); } +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 {