--- loncom/lonnet/perl/lonnet.pm 2000/12/13 22:45:22 1.80
+++ loncom/lonnet/perl/lonnet.pm 2001/01/11 10:43:09 1.95
@@ -81,7 +81,11 @@
# 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 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
package Apache::lonnet;
@@ -95,6 +99,7 @@ use IO::Socket;
use GDBM_File;
use Apache::Constants qw(:common :http);
use HTML::TokeParser;
+use Fcntl qw(:flock);
# --------------------------------------------------------------------- Logging
@@ -177,6 +182,11 @@ sub reconlonc {
sub critical {
my ($cmd,$server)=@_;
+ unless ($hostname{$server}) {
+ &logthis("<font color=blue>WARNING:".
+ " Critical message to unknown server ($server)</font>");
+ return 'no_such_host';
+ }
my $answer=reply($cmd,$server);
if ($answer eq 'con_lost') {
my $pingreply=reply('ping',$server);
@@ -235,6 +245,18 @@ sub appenv {
$ENV{$_}=$newenv{$_};
}
} keys %newenv;
+
+ my $lockfh;
+ unless ($lockfh=Apache::File->new("$ENV{'user.environment'}")) {
+ return 'error';
+ }
+ unless (flock($lockfh,LOCK_EX)) {
+ &logthis("<font color=blue>WARNING: ".
+ 'Could not obtain exclusive lock in appenv: '.$!);
+ $lockfh->close();
+ return 'error: '.$!;
+ }
+
my @oldenv;
{
my $fh;
@@ -242,6 +264,7 @@ sub appenv {
return 'error';
}
@oldenv=<$fh>;
+ $fh->close();
}
for (my $i=0; $i<=$#oldenv; $i++) {
chomp($oldenv[$i]);
@@ -261,7 +284,10 @@ sub appenv {
foreach $newname (keys %newenv) {
print $fh "$newname=$newenv{$newname}\n";
}
+ $fh->close();
}
+
+ $lockfh->close();
return 'ok';
}
# ----------------------------------------------------- Delete from Environment
@@ -280,16 +306,30 @@ sub delenv {
unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {
return 'error';
}
+ unless (flock($fh,LOCK_SH)) {
+ &logthis("<font color=blue>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("<font color=blue>WARNING: ".
+ 'Could not obtain exclusive lock in delenv: '.$!);
+ $fh->close();
+ return 'error: '.$!;
+ }
map {
unless ($_=~/^$delthis/) { print $fh $_; }
} @oldenv;
+ $fh->close();
}
return 'ok';
}
@@ -901,7 +941,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;
}
@@ -943,7 +985,7 @@ sub allowed {
$checkreferer=0;
}
}
-
+
if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) {
my $refuri=$ENV{'HTTP_REFERER'};
$refuri=~s/^http\:\/\/$ENV{'request.host'}//i;
@@ -1001,6 +1043,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;
@@ -1164,49 +1207,46 @@ sub filedescription {
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));
}
-# ----------------------------------------------------------------- Make a user
+# --------------------------------------------------------------- Modify a user
-sub makeuser {
+sub modifyuser {
my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene)=@_;
- &logthis('Call to make user '.$udom.', '.$uname.', '.$uid.', '.
+ &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') {
+ 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'};
- } elsif ($ENV{'user.domain'} eq $udom) {
- $unhome=$ENV{'user.home'};
} else {
my $tryserver;
- my $loadm=999999;
+ my $loadm=10000000;
foreach $tryserver (keys %libserv) {
if ($hostdom{$tryserver} eq $udom) {
my $answer=reply('load',$tryserver);
@@ -1247,10 +1287,10 @@ sub makeuser {
':environment:firstname&middlename&lastname&generation',
$uhome);
my ($efirst,$emiddle,$elast,$egene)=split(/\&/,$names);
- unless ($efirst) { $efirst = &escape($first); }
- unless ($emiddle) { $emiddle = &escape($middle); }
- unless ($elast) { $elast = &escape($last); }
- unless ($egene) { $egene = &escape($gene); }
+ 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.
@@ -1259,28 +1299,104 @@ sub makeuser {
if ($reply ne 'ok') {
return 'error: '.$reply;
}
- &logthis('Success making user '.$udom.', '.$uname.', '.$uid.', '.
+ &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
$umode.', '.$first.', '.$middle.', '.
$last.', '.$gene.' by '.
$ENV{'user.name'}.' at '.$ENV{'user.domain'});
return 'ok';
}
-# -------------------------------------------------------------- Make a student
+# -------------------------------------------------------------- Modify student
-sub makestudent {
- my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec)=@_;
- unless ($ENV{'request.course.id'}) {
+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=&makeuser
+ 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
@@ -1479,6 +1595,9 @@ sub EXT {
if ($ENV{'request.course.id'}) {
# ----------------------------------------------------- Cascading lookup scheme
my $symbp=&symbread();
+ unless ($symbp) {
+ &logthis('No symb for '.$ENV{'request.filename'});
+ }
my $mapp=(split(/\_\_\_/,$symbp))[0];
my $symbparm=$symbp.'.'.$spacequalifierrest;
@@ -1501,11 +1620,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}; }
@@ -1513,7 +1632,15 @@ sub EXT {
return $resourcedata{$courselevelm}; }
if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; }
+ } else {
+ if ($resourcedata{$courselevelr}!~/No such file/) {
+ &logthis("<font color=blue>WARNING:".
+ " Trying to get resource data for ".$ENV{'user.name'}." at "
+ .$ENV{'user.domain'}.": ".$resourcedata{$courselevelr}.
+ "</font>");
+ }
}
+
# -------------------------------------------------------- second, check course
my $section='';
if ($ENV{'request.course.sec'}) {
@@ -1531,7 +1658,16 @@ sub EXT {
if ($_) { return &unescape($_); }
} split(/\&/,$reply);
}
-
+ if (($reply=~/^con_lost/) || ($reply=~/^error\:/)) {
+ &logthis("<font color=blue>WARNING:".
+ " Getting ".$reply." asking for ".$varname." for ".
+ $ENV{'course.'.$ENV{'request.course.id'}.$section.'.num'}.
+ ' at '.
+ $ENV{'course.'.$ENV{'request.course.id'}.$section.'.domain'}.
+ ' from '.
+ $ENV{'course.'.$ENV{'request.course.id'}.$section.'.home'}.
+ "</font>");
+ }
# ------------------------------------------------------ third, check map parms
my %parmhash=();
my $thisparm='';