--- loncom/lonnet/perl/lonnet.pm 2001/08/18 14:17:50 1.152
+++ loncom/lonnet/perl/lonnet.pm 2001/11/16 06:21:39 1.169
@@ -1,6 +1,44 @@
# The LearningOnline Network
# TCP networking package
#
+# 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,
+# 11/8,11/16,11/18,11/22,11/23,12/22,
+# 01/06,01/13,02/24,02/28,02/29,
+# 03/01,03/02,03/06,03/07,03/13,
+# 04/05,05/29,05/31,06/01,
+# 06/05,06/26 Gerd Kortemeyer
+# 06/26 Ben Tyszka
+# 06/30,07/15,07/17,07/18,07/20,07/21,07/22,07/25 Gerd Kortemeyer
+# 08/14 Ben Tyszka
+# 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,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,11/13,11/15 Scott Harrison
+#
+# $Id: lonnet.pm,v 1.169 2001/11/16 06:21:39 harris41 Exp $
+###
+
# Functions for use by content handlers:
#
# metadata_query(sql-query-string,custom-metadata-regex) :
@@ -72,7 +110,12 @@
# 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
@@ -92,37 +135,6 @@
# 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,
-# 11/8,11/16,11/18,11/22,11/23,12/22,
-# 01/06,01/13,02/24,02/28,02/29,
-# 03/01,03/02,03/06,03/07,03/13,
-# 04/05,05/29,05/31,06/01,
-# 06/05,06/26 Gerd Kortemeyer
-# 06/26 Ben Tyszka
-# 06/30,07/15,07/17,07/18,07/20,07/21,07/22,07/25 Gerd Kortemeyer
-# 08/14 Ben Tyszka
-# 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,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
-# 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 Gerd Kortemeyer
package Apache::lonnet;
@@ -131,7 +143,7 @@ use Apache::File;
use LWP::UserAgent();
use HTTP::Headers;
use vars
-qw(%perlvar %hostname %homecache %hostip %spareid %hostdom %libserv %pr %prp %fe %fd $readit %metacache %packagetab);
+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);
@@ -140,6 +152,16 @@ 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'};
@@ -388,6 +410,44 @@ sub spareserver {
return $spareserver;
}
+# ----------------------- Try to determine user's current authentication scheme
+
+sub queryauthenticate {
+ my ($uname,$udom)=@_;
+ if (($perlvar{'lonRole'} eq 'library') &&
+ ($udom eq $perlvar{'lonDefDomain'})) {
+ my $answer=reply("encrypt:currentauth:$udom:$uname",
+ $perlvar{'lonHostID'});
+ unless ($answer eq 'unknown_user' or $answer eq 'refused') {
+ if (length($answer)) {
+ return $answer;
+ }
+ else {
+ &logthis("User $uname at $udom lacks an authentication mechanism");
+ return 'no_host';
+ }
+ }
+ }
+
+ my $tryserver;
+ foreach $tryserver (keys %libserv) {
+ if ($hostdom{$tryserver} eq $udom) {
+ my $answer=reply("encrypt:currentauth:$udom:$uname",$tryserver);
+ unless ($answer eq 'unknown_user' or $answer eq 'refused') {
+ if (length($answer)) {
+ return $answer;
+ }
+ else {
+ &logthis("User $uname at $udom lacks an authentication mechanism");
+ return 'no_host';
+ }
+ }
+ }
+ }
+ &logthis("User $uname at $udom lacks an authentication mechanism");
+ return 'no_host';
+}
+
# --------- Try to authenticate user from domain's lib servers (first this one)
sub authenticate {
@@ -660,6 +720,56 @@ 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("<font color=blue>WARNING: Buffer for ".$crsid.
+ " exceeded maximum size, deleting.</font>");
+ 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 {
@@ -683,9 +793,9 @@ sub checkout {
$token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/;
$token=~tr/a-z/A-Z/;
- my %infohash=('outtoken' => $token,
- 'checkouttime' => $now,
- 'outremote' => $ENV{'REMOTE_ADDR'});
+ 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 '';
@@ -719,9 +829,20 @@ sub checkin {
my ($tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
- my %infohash=('intoken' => $token,
- 'checkintime' => $now,
- 'inremote' => $ENV{'REMOTE_ADDR'});
+ 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 '';
@@ -775,15 +896,155 @@ sub devalidate {
}
}
+sub hash2str {
+ my (%hash)=@_;
+ my $result='';
+ map { $result.=escape($_).'='.escape($hash{$_}).'&'; } keys %hash;
+ $result=~s/\&$//;
+ return $result;
+}
+
+sub str2hash {
+ my ($string) = @_;
+ my %returnhash;
+ map {
+ my ($name,$value)=split(/\=/,$_);
+ $returnhash{&unescape($name)}=&unescape($value);
+ } split(/\&/,$string);
+ return %returnhash;
+}
+
+# -------------------------------------------------------------------Temp Store
+
+sub tmpreset {
+ my ($symb,$namespace,$domain,$stuname) = @_;
+ if (!$symb) {
+ $symb=&symbread();
+ if (!$symb) { $symb= $ENV{'REQUEST_URI'}; }
+ }
+ $symb=escape($symb);
+
+ if (!$namespace) { $namespace=$ENV{'request.state'}; }
+ $namespace=~s/\//\_/g;
+ $namespace=~s/\W//g;
+
+ #FIXME needs to do something for /pub resources
+ if (!$domain) { $domain=$ENV{'user.domain'}; }
+ if (!$stuname) { $stuname=$ENV{'user.name'}; }
+ my $path=$perlvar{'lonDaemons'}.'/tmp';
+ my %hash;
+ if (tie(%hash,'GDBM_File',
+ $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
+ &GDBM_WRCREAT,0640)) {
+ foreach my $key (keys %hash) {
+ if ($key=~ /:$symb:/) {
+ delete($hash{$key});
+ }
+ }
+ }
+}
+
+sub tmpstore {
+ my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
+
+ if (!$symb) {
+ $symb=&symbread();
+ if (!$symb) { $symb= $ENV{'request.url'}; }
+ }
+ $symb=escape($symb);
+
+ if (!$namespace) {
+ # I don't think we would ever want to store this for a course.
+ # it seems this will only be used if we don't have a course.
+ #$namespace=$ENV{'request.course.id'};
+ #if (!$namespace) {
+ $namespace=$ENV{'request.state'};
+ #}
+ }
+ $namespace=~s/\//\_/g;
+ $namespace=~s/\W//g;
+#FIXME needs to do something for /pub resources
+ if (!$domain) { $domain=$ENV{'user.domain'}; }
+ if (!$stuname) { $stuname=$ENV{'user.name'}; }
+ my $now=time;
+ my %hash;
+ my $path=$perlvar{'lonDaemons'}.'/tmp';
+ if (tie(%hash,'GDBM_File',
+ $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
+ &GDBM_WRCREAT,0640)) {
+ $hash{"version:$symb"}++;
+ my $version=$hash{"version:$symb"};
+ my $allkeys='';
+ foreach my $key (keys(%$storehash)) {
+ $allkeys.=$key.':';
+ $hash{"$version:$symb:$key"}=$$storehash{$key};
+ }
+ $hash{"$version:$symb:timestamp"}=$now;
+ $allkeys.='timestamp';
+ $hash{"$version:keys:$symb"}=$allkeys;
+ if (untie(%hash)) {
+ return 'ok';
+ } else {
+ return "error:$!";
+ }
+ } else {
+ return "error:$!";
+ }
+}
+
+# -----------------------------------------------------------------Temp Restore
+
+sub tmprestore {
+ my ($symb,$namespace,$domain,$stuname) = @_;
+
+ if (!$symb) {
+ $symb=&symbread();
+ if (!$symb) { $symb= $ENV{'request.url'}; }
+ }
+ $symb=escape($symb);
+
+ if (!$namespace) { $namespace=$ENV{'request.state'}; }
+ #FIXME needs to do something for /pub resources
+ if (!$domain) { $domain=$ENV{'user.domain'}; }
+ if (!$stuname) { $stuname=$ENV{'user.name'}; }
+
+ my %returnhash;
+ $namespace=~s/\//\_/g;
+ $namespace=~s/\W//g;
+ my %hash;
+ my $path=$perlvar{'lonDaemons'}.'/tmp';
+ if (tie(%hash,'GDBM_File',
+ $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
+ &GDBM_READER,0640)) {
+ my $version=$hash{"version:$symb"};
+ $returnhash{'version'}=$version;
+ my $scope;
+ for ($scope=1;$scope<=$version;$scope++) {
+ my $vkeys=$hash{"$scope:keys:$symb"};
+ my @keys=split(/:/,$vkeys);
+ my $key;
+ $returnhash{"$scope:keys"}=$vkeys;
+ foreach $key (@keys) {
+ $returnhash{"$scope:$key"}=$hash{"$scope:$symb:$key"};
+ $returnhash{"$key"}=$hash{"$scope:$symb:$key"};
+ }
+ }
+ if (!(untie(%hash))) {
+ return "error:$!";
+ }
+ } else {
+ return "error:$!";
+ }
+ return %returnhash;
+}
+
# ----------------------------------------------------------------------- Store
sub store {
my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
my $home='';
- if ($stuname) {
- $home=&homeserver($stuname,$domain);
- }
+ if ($stuname) { $home=&homeserver($stuname,$domain); }
if (!$symb) { unless ($symb=&symbread()) { return ''; } }
@@ -808,9 +1069,7 @@ sub cstore {
my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
my $home='';
- if ($stuname) {
- $home=&homeserver($stuname,$domain);
- }
+ if ($stuname) { $home=&homeserver($stuname,$domain); }
if (!$symb) { unless ($symb=&symbread()) { return ''; } }
@@ -836,9 +1095,7 @@ sub restore {
my ($symb,$namespace,$domain,$stuname) = @_;
my $home='';
- if ($stuname) {
- $home=&homeserver($stuname,$domain);
- }
+ if ($stuname) { $home=&homeserver($stuname,$domain); }
if (!$symb) {
unless ($symb=escape(&symbread())) { return ''; }
@@ -1121,6 +1378,12 @@ sub allowed {
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='';
@@ -1156,7 +1419,7 @@ sub allowed {
# If this is generating or modifying users, exit with special codes
- if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:'=~/\:$priv\:/) {
+ if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:$priv\:/) {
return $thisallowed;
}
#
@@ -1193,6 +1456,7 @@ sub allowed {
map {
if ($_=~/^httpref\..*\*/) {
my $pattern=$_;
+ $pattern=~s/^httpref\.\/res\///;
$pattern=~s/\*/\[\^\/\]\+/g;
$pattern=~s/\//\\\//g;
if ($orguri=~/$pattern/) {
@@ -1471,6 +1735,19 @@ sub assignrole {
return &reply($command,&homeserver($uname,$udom));
}
+# -------------------------------------------------- Modify user authentication
+sub modifyuserauth {
+ my ($udom,$uname,$umode,$upass)=@_;
+ my $uhome=&homeserver($uname,$udom);
+ &logthis('Call to modify user authentication'.$udom.', '.$uname.', '.
+ $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'});
+ my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.
+ &escape($upass),$uhome);
+ unless ($reply eq 'ok') {
+ return 'error: '.$reply;
+ }
+}
+
# --------------------------------------------------------------- Modify a user
@@ -1559,7 +1836,7 @@ sub modifystudent {
return 'error: no such user';
}
# -------------------------------------------------- Add student to course list
- my $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'.
+ $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'.
$ENV{'course.'.$cid.'.num'}.':classlist:'.
&escape($uname.':'.$udom).'='.
&escape($end.':'.$start),
@@ -1624,7 +1901,7 @@ sub createcourse {
my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
$ENV{'user.home'});
unless ($reply eq 'ok') { return 'error: '.$reply; }
- my $uhome=&homeserver($uname,$udom);
+ $uhome=&homeserver($uname,$udom);
if (($uhome eq '') || ($uhome eq 'no_host')) {
return 'error: no such course';
}
@@ -2133,16 +2410,21 @@ sub numval {
}
sub rndseed {
- my $symb;
- unless ($symb=&symbread()) { return time; }
- {
+ 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*",$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 $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");
@@ -2245,7 +2527,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");
@@ -2264,6 +2546,7 @@ 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;
@@ -2289,8 +2572,10 @@ if ($readit ne 'done') {
while (my $configline=<$config>) {
chomp($configline);
+ if ($configline) {
my ($role,$perm)=split(/ /,$configline);
if ($perm ne '') { $pr{$role}=$perm; }
+ }
}
}
@@ -2300,8 +2585,10 @@ if ($readit ne 'done') {
while (my $configline=<$config>) {
chomp($configline);
+ if ($configline) {
my ($short,$plain)=split(/:/,$configline);
if ($plain ne '') { $prp{$short}=$plain; }
+ }
}
}
@@ -2337,6 +2624,7 @@ if ($readit ne 'done') {
%metacache=();
$readit='done';
+&logtouch();
&logthis('<font color=yellow>INFO: Read configuration</font>');
}
}