--- loncom/lonnet/perl/lonnet.pm 2000/12/14 21:44:06 1.81 +++ loncom/lonnet/perl/lonnet.pm 2001/03/27 13:37:43 1.117 @@ -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 @@ -81,7 +84,16 @@ # 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 Gerd Kortemeyer +# 12/02,12/12,12/13,12/14,12/28,12/29 Gerd Kortemeyer +# 05/01/01 Guy Albertelli +# 05/01,06/01,09/01 Gerd Kortemeyer +# 09/01 Guy Albertelli +# 09/01,10/01,11/01 Gerd Kortemeyer +# 02/27/01 Scott Harrison +# 3/2 Gerd Kortemeyer +# 3/15 Scott Harrison +# 3/19,3/20 Gerd Kortemeyer +# 3/22 Scott Harrison package Apache::lonnet; @@ -95,6 +107,7 @@ use IO::Socket; use GDBM_File; use Apache::Constants qw(:common :http); use HTML::TokeParser; +use Fcntl qw(:flock); # --------------------------------------------------------------------- Logging @@ -177,6 +190,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); @@ -235,13 +253,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]); @@ -261,7 +292,10 @@ sub appenv { foreach $newname (keys %newenv) { print $fh "$newname=$newenv{$newname}\n"; } + $fh->close(); } + + $lockfh->close(); return 'ok'; } # ----------------------------------------------------- Delete from Environment @@ -280,16 +314,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'; } @@ -582,12 +630,60 @@ 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 ''; } + unless ($symb=&symbread()) { return ''; } + + &devalidate($symb); + + $symb=escape($symb); my $namespace; unless ($namespace=$ENV{'request.course.id'}) { return ''; } my $namevalue=''; @@ -605,7 +701,11 @@ sub store { sub cstore { my %storehash=@_; my $symb; - unless ($symb=escape(&symbread())) { return ''; } + unless ($symb=&symbread()) { return ''; } + + &devalidate($symb); + + $symb=escape($symb); my $namespace; unless ($namespace=$ENV{'request.course.id'}) { return ''; } my $namevalue=''; @@ -653,8 +753,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, @@ -680,7 +779,7 @@ sub coursedescription { return (); } -# -------------------------------------------------------- Get user priviledges +# -------------------------------------------------------- Get user privileges sub rolesinit { my ($domain,$username,$authhost)=@_; @@ -754,12 +853,12 @@ sub rolesinit { %thesepriv=(); 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; } } } @@ -869,7 +968,7 @@ sub eget { return %returnhash; } -# ------------------------------------------------- Check for a user priviledge +# ------------------------------------------------- Check for a user privilege sub allowed { my ($priv,$uri)=@_; @@ -901,8 +1000,9 @@ 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'}.'./'.$courseuri} + if ($ENV{'user.priv.'.$ENV{'request.role'}.'.'.$courseuri} =~/$priv\&([^\:]*)/) { $thisallowed.=$1; } @@ -919,7 +1019,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 @@ -944,7 +1044,7 @@ sub allowed { $checkreferer=0; } } - + if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) { my $refuri=$ENV{'HTTP_REFERER'}; $refuri=~s/^http\:\/\/$ENV{'request.host'}//i; @@ -970,7 +1070,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? @@ -1002,6 +1102,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; @@ -1139,6 +1240,24 @@ 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 list + unless ($custom or $customshow) { + my $reply=&reply("querysend:".&escape($query),'msul3'); + return $reply; + } + else { + my $reply=&reply("querysend:".&escape($query).':'. + &escape($custom).':'.&escape($customshow),'msul3'); + return $reply; + } + my ($query)=@_; + my $reply=&reply("querysend:".&escape($query),'msul3'); +} + # ------------------------------------------------------------------ Plain Text sub plaintext { @@ -1165,12 +1284,23 @@ sub filedescription { sub assignrole { my ($udom,$uname,$url,$role,$end,$start)=@_; my $mrole; - $url=declutter($url); 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 { - unless (&allowed('c'.$role,$url)) { 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'}:". @@ -1290,7 +1420,7 @@ sub modifystudent { return 'error: '.$reply; } # ---------------------------------------------------- Add student role to user - my $uurl=$cid; + my $uurl='/'.$cid; $uurl=~s/\_/\//g; if ($usec) { $uurl.='/'.$usec; @@ -1298,6 +1428,64 @@ sub modifystudent { 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 { @@ -1516,11 +1704,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}; } @@ -1528,25 +1716,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'}. + $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=''; @@ -1729,16 +1931,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 {