--- loncom/lonnet/perl/lonnet.pm	2001/10/06 20:57:45	1.162
+++ loncom/lonnet/perl/lonnet.pm	2001/11/17 15:36:06	1.171
@@ -1,6 +1,47 @@
 # 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.171 2001/11/17 15:36:06 www Exp $
+#
+# 11/17 Gerd Kortemeyer
+#
+###
+
 # Functions for use by content handlers:
 #
 # metadata_query(sql-query-string,custom-metadata-regex) : 
@@ -97,40 +138,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
-# 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 Scott Harrison
 
 package Apache::lonnet;
 
@@ -148,6 +155,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'};
@@ -396,6 +413,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 {
@@ -844,15 +899,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 ''; } }
 
@@ -877,9 +1072,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 ''; } }
 
@@ -905,9 +1098,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 ''; }
@@ -1231,7 +1422,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;
     }
 #
@@ -1547,6 +1738,20 @@ 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;
+    }   
+    return 'ok';
+}
+
 # --------------------------------------------------------------- Modify a user
 
 
@@ -2029,12 +2234,16 @@ sub EXT {
 # ---------------------------------------------------------------- Get metadata
 
 sub metadata {
-    my ($uri,$what)=@_;
+    my ($uri,$what,$liburi,$prefix)=@_;
 
     $uri=&declutter($uri);
     my $filename=$uri;
     $uri=~s/\.meta$//;
     unless ($metacache{$uri.':keys'}) {
+        if ($liburi) {
+	    $liburi=&declutter($liburi);
+            $filename=$liburi;
+        }
         my %metathesekeys=();
         unless ($filename=~/\.meta$/) { $filename.='.meta'; }
 	my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);
@@ -2423,6 +2632,7 @@ unless ($readit) {
 %metacache=();
 
 $readit='done';
+&logtouch();
 &logthis('<font color=yellow>INFO: Read configuration</font>');
 }
 }