--- loncom/lonnet/perl/lonnet.pm 2000/12/28 19:57:30 1.82
+++ loncom/lonnet/perl/lonnet.pm 2001/01/09 23:04:15 1.92
@@ -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,12/14,12/28 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 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);
@@ -241,7 +251,14 @@ sub appenv {
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 appenv: '.$!);
+ $fh->close();
+ return 'error: '.$!;
+ }
@oldenv=<$fh>;
+ $fh->close();
}
for (my $i=0; $i<=$#oldenv; $i++) {
chomp($oldenv[$i]);
@@ -258,9 +275,16 @@ sub appenv {
return 'error';
}
my $newname;
- foreach $newname (keys %newenv) {
+ unless (flock($fh,LOCK_EX)) {
+ &logthis("<font color=blue>WARNING: ".
+ 'Could not obtain exclusive lock in appenv: '.$!);
+ $fh->close();
+ return 'error: '.$!;
+ }
+ foreach $newname (sort keys %newenv) {
print $fh "$newname=$newenv{$newname}\n";
}
+ $fh->close();
}
return 'ok';
}
@@ -280,16 +304,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,8 +939,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;
}
@@ -944,7 +983,7 @@ sub allowed {
$checkreferer=0;
}
}
-
+
if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) {
my $refuri=$ENV{'HTTP_REFERER'};
$refuri=~s/^http\:\/\/$ENV{'request.host'}//i;
@@ -1002,6 +1041,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;
@@ -1165,13 +1205,12 @@ 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'; }
$mrole='cr';
} else {
my $cwosec=$url;
- $cwosec=~s/^(\w+)\/(\w+)\/.*/$1\/$2/;
+ $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
unless (&allowed('c'.$role,$cwosec)) { return 'refused'; }
$mrole=$role;
}
@@ -1292,7 +1331,7 @@ sub modifystudent {
return 'error: '.$reply;
}
# ---------------------------------------------------- Add student role to user
- my $uurl=$cid;
+ my $uurl='/'.$cid;
$uurl=~s/\_/\//g;
if ($usec) {
$uurl.='/'.$usec;
@@ -1300,6 +1339,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 {