--- loncom/lonnet/perl/lonnet.pm	2001/08/09 19:28:47	1.147
+++ loncom/lonnet/perl/lonnet.pm	2001/11/05 22:48:19	1.168
@@ -72,7 +72,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
@@ -113,6 +118,7 @@
 # 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
@@ -122,7 +128,9 @@
 # 5/30 H. K. Ng
 # 6/1 Gerd Kortemeyer
 # July Guy Albertelli
-# 8/4,8/7,8/8,8/9 Gerd Kortemeyer
+# 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 Scott Harrison
 
 package Apache::lonnet;
 
@@ -131,7 +139,7 @@ use Apache::File;
 use LWP::UserAgent();
 use HTTP::Headers;
 use vars 
-qw(%perlvar %hostname %homecache %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 +148,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'};
@@ -276,7 +294,8 @@ sub appenv {
     map {
 	if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {
             &logthis("<font color=blue>WARNING: ".
-                "Attempt to modify environment ".$_." to ".$newenv{$_});
+                "Attempt to modify environment ".$_." to ".$newenv{$_}
+                .'</font>');
 	    delete($newenv{$_});
         } else {
             $ENV{$_}=$newenv{$_};
@@ -659,6 +678,142 @@ 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 {
+    my ($symb,$tuname,$tudom,$tcrsid)=@_;
+    my $now=time;
+    my $lonhost=$perlvar{'lonHostID'};
+    my $infostr=&escape(
+                 $tuname.'&'.
+                 $tudom.'&'.
+                 $tcrsid.'&'.
+                 $symb.'&'.
+		 $now.'&'.$ENV{'REMOTE_ADDR'});
+    my $token=&reply('tmpput:'.$infostr,$lonhost);
+    if ($token=~/^error\:/) { 
+        &logthis("<font color=blue>WARNING: ".
+                "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
+                 "</font>");
+        return ''; 
+    }
+
+    $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/;
+    $token=~tr/a-z/A-Z/;
+
+    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 '';
+    } else {
+        &logthis("<font color=blue>WARNING: ".
+                "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
+                 "</font>");
+    }    
+
+    if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
+                         &escape('Checkout '.$infostr.' - '.
+                                                 $token)) ne 'ok') {
+	return '';
+    } else {
+        &logthis("<font color=blue>WARNING: ".
+                "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
+                 "</font>");
+    }
+    return $token;
+}
+
+# ------------------------------------------------------------ Check in an item
+
+sub checkin {
+    my $token=shift;
+    my $now=time;
+    my ($ta,$tb,$lonhost)=split(/\*/,$token);
+    $lonhost=~tr/A-Z/a-z/;
+    my $dtoken=$ta.'_'.$hostip{$lonhost}.'_'.$tb;
+    $dtoken=~s/\W/\_/g;
+    my ($tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
+                 split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
+
+    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 '';
+    }    
+
+    if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
+                         &escape('Checkin - '.$token)) ne 'ok') {
+	return '';
+    }
+
+    return ($symb,$tuname,$tudom,$tcrsid);    
+}
+
 # --------------------------------------------- Set Expire Date for Spreadsheet
 
 sub expirespread {
@@ -699,15 +854,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 ''; } }
 
@@ -732,9 +1027,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 ''; } }
 
@@ -760,9 +1053,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 ''; }
@@ -1035,6 +1326,8 @@ sub eget {
 
 sub allowed {
     my ($priv,$uri)=@_;
+
+    my $orguri=$uri;
     $uri=&declutter($uri);
 
 # Free bre access to adm and meta resources
@@ -1043,6 +1336,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='';
@@ -1078,7 +1377,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;
     }
 #
@@ -1108,16 +1407,28 @@ sub allowed {
            }
        }
        
-       if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) {
-	  my $refuri=$ENV{'HTTP_REFERER'};
-          $refuri=~s/^http\:\/\/$ENV{'request.host'}//i;
-          $refuri=&declutter($refuri);
+       if ($checkreferer) {
+	  my $refuri=$ENV{'httpref.'.$orguri};
+
+            unless ($refuri) {
+                map {
+		    if ($_=~/^httpref\..*\*/) {
+			my $pattern=$_;
+                        $pattern=~s/^httpref\.\/res\///;
+                        $pattern=~s/\*/\[\^\/\]\+/g;
+                        $pattern=~s/\//\\\//g;
+                        if ($orguri=~/$pattern/) {
+			    $refuri=$ENV{$_};
+                        }
+                    }
+                } keys %ENV;
+            }
+         if ($refuri) { 
+	  $refuri=&declutter($refuri);
           my @uriparts=split(/\//,$refuri);
           my $filename=$uriparts[$#uriparts];
           my $pathname=$refuri;
           $pathname=~s/\/$filename$//;
-          my @filenameparts=split(/\./,$uri);
-          if (&fileembstyle($filenameparts[$#filenameparts]) ne 'ssi') {
             if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
               /\&$filename\:([\d\|]+)\&/) {
               my $refstatecond=$1;
@@ -1127,8 +1438,8 @@ sub allowed {
                   $uri=$refuri;
                   $statecond=$refstatecond;
               }
-            }
           }
+        }
        }
    }
 
@@ -1470,7 +1781,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),
@@ -1535,7 +1846,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';
     }
@@ -2044,16 +2355,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");
@@ -2156,7 +2472,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");
@@ -2175,9 +2491,11 @@ 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;
+       $hostip{$id}=$ip;
        if ($role eq 'library') { $libserv{$id}=$name; }
     }
 }
@@ -2199,8 +2517,10 @@ if ($readit ne 'done') {
 
     while (my $configline=<$config>) {
        chomp($configline);
+      if ($configline) {
        my ($role,$perm)=split(/ /,$configline);
        if ($perm ne '') { $pr{$role}=$perm; }
+      }
     }
 }
 
@@ -2210,8 +2530,10 @@ if ($readit ne 'done') {
 
     while (my $configline=<$config>) {
        chomp($configline);
+      if ($configline) {
        my ($short,$plain)=split(/:/,$configline);
        if ($plain ne '') { $prp{$short}=$plain; }
+      }
     }
 }
 
@@ -2247,6 +2569,7 @@ if ($readit ne 'done') {
 %metacache=();
 
 $readit='done';
+&logtouch();
 &logthis('<font color=yellow>INFO: Read configuration</font>');
 }
 }