--- loncom/lonnet/perl/lonnet.pm	2003/03/19 21:23:03	1.343
+++ loncom/lonnet/perl/lonnet.pm	2003/03/31 20:31:39	1.357
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.343 2003/03/19 21:23:03 www Exp $
+# $Id: lonnet.pm,v 1.357 2003/03/31 20:31:39 www Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -74,8 +74,8 @@ use HTTP::Headers;
 use vars 
 qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom 
    %libserv %pr %prp %metacache %packagetab %titlecache 
-   %courselogs %accesshash $processmarker $dumpcount 
-   %coursedombuf %coursehombuf %courseresdatacache 
+   %courselogs %accesshash %userrolehash $processmarker $dumpcount 
+   %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache 
    %domaindescription %domain_auth_def %domain_auth_arg_def $tmpdir);
 use IO::Socket;
 use GDBM_File;
@@ -588,6 +588,92 @@ sub idput {
     }
 }
 
+# --------------------------------------------------- Assign a key to a student
+
+sub assign_access_key {
+    my ($ckey,$cdom,$cnum,$udom,$uname)=@_;
+    $cdom=
+   $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
+    $cnum=
+   $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
+    $udom=$ENV{'user.name'} unless (defined($udom));
+    $uname=$ENV{'user.domain'} unless (defined($uname));
+    my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
+    if (($existing{$ckey}=~/^\d+$/) || # has time - new key
+        ($existing{$ckey} eq $uname.':'.$udom)) { # this should not happen,
+                                                  # unless something went wrong
+                                                  # the first time around
+# ready to assign
+    } elsif (!$existing{$ckey}) {
+        if (&put('accesskey',{$ckey=>$uname.':'.$udom},$cdom,$cnum) eq 'ok') {
+# key now belongs to user
+	    my $envkey='key.'.$cdom.'_'.$cnum;
+            if (&put('environment',{$envkey => $ckey}) eq 'ok') {
+                &appenv('environment.'.$envkey => $ckey);
+                return 'ok';
+            } else {
+                return 
+  'error: Count not permanently assign key, will need to be re-entered later.';
+	    }
+        } else {
+            return 'error: Could not assign key, try again later.';
+        }
+# the key does not exist
+	return 'error: The key does not exist';
+    } else {
+# the key is somebody else's
+	return 'error: The key is already in use';
+    }
+}
+
+# ------------------------------------------------------ Generate a set of keys
+
+sub generate_access_keys {
+    my ($number,$cdom,$cnum)=@_;
+    $cdom=
+   $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
+    $cnum=
+   $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
+    unless (&allowed('ccc',$cdom)) { return 0; }
+    unless (($cdom) && ($cnum)) { return 0; }
+    if ($number>10000) { return 0; }
+    sleep(2); # make sure don't get same seed twice
+    srand(time()^($$+($$<<15))); # from "Programming Perl"
+    my $total=0;
+    for (my $i=1;$i<=$number;$i++) {
+       my $newkey=sprintf("%lx",int(100000*rand)).'-'.
+                  sprintf("%lx",int(100000*rand)).'-'.
+                  sprintf("%lx",int(100000*rand));
+       $newkey=~s/1/g/g; # folks mix up 1 and l
+       $newkey=~s/0/h/g; # and also 0 and O
+       my %existing=&get('accesskeys',[$newkey],$cdom,$cnum);
+       if ($existing{$newkey}) {
+           $i--;
+       } else {
+	  if (&put('accesskeys',{ $newkey => time() },$cdom,$cnum) eq 'ok') {
+              $total++;
+	  }
+       }
+    }
+    &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'},
+         'Generated '.$total.' keys for '.$cnum.' at '.$cdom);
+    return $total;
+}
+
+# ------------------------------------------------------- Validate an accesskey
+
+sub validate_access_key {
+    my ($ckey,$cdom,$cnum,$udom,$uname)=@_;
+    $cdom=
+   $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
+    $cnum=
+   $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
+    $udom=$ENV{'user.name'} unless (defined($udom));
+    $uname=$ENV{'user.domain'} unless (defined($uname));
+    my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
+    return ($existing{$ckey} eq $uname.':'.$udom);
+}
+
 # ------------------------------------- Find the section of student in a course
 
 sub getsection {
@@ -941,12 +1027,24 @@ sub log {
 }
 
 # ------------------------------------------------------------------ Course Log
+#
+# This routine flushes several buffers of non-mission-critical nature
+#
 
 sub flushcourselogs {
-    &logthis('Flushing course log buffers');
+    &logthis('Flushing log buffers');
+#
+# course logs
+# This is a log of all transactions in a course, which can be used
+# for data mining purposes
+#
+# It also collects the courseid database, which lists last transaction
+# times and course titles for all courseids
+#
+    my %courseidbuffer=();
     foreach (keys %courselogs) {
         my $crsid=$_;
-        if (&reply('log:'.$coursedombuf{$crsid}.':'.
+        if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'.
 		          &escape($courselogs{$crsid}),
 		          $coursehombuf{$crsid}) eq 'ok') {
 	    delete $courselogs{$crsid};
@@ -957,9 +1055,26 @@ sub flushcourselogs {
                         " exceeded maximum size, deleting.</font>");
                delete $courselogs{$crsid};
             }
-        }        
+        }
+        if ($courseidbuffer{$coursehombuf{$crsid}}) {
+           $courseidbuffer{$coursehombuf{$crsid}}.='&'.
+			 &escape($crsid).'='.&escape($coursedescrbuf{$crsid});
+        } else {
+           $courseidbuffer{$coursehombuf{$crsid}}=
+			 &escape($crsid).'='.&escape($coursedescrbuf{$crsid});
+        }    
     }
-    &logthis('Flushing access logs');
+#
+# Write course id database (reverse lookup) to homeserver of courses 
+# Is used in pickcourse
+#
+    foreach (keys %courseidbuffer) {
+        &courseidput($hostdom{$_},$courseidbuffer{$_},$_);
+    }
+#
+# File accesses
+# Writes to the dynamic metadata of resources to get hit counts, etc.
+#
     foreach (keys %accesshash) {
         my $entry=$_;
         $entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/;
@@ -968,6 +1083,20 @@ sub flushcourselogs {
 	    delete $accesshash{$entry};
         }
     }
+#
+# Roles
+# Reverse lookup of user roles for course faculty/staff and co-authorship
+#
+    foreach (keys %userrolehash) {
+        my $entry=$_;
+        my ($role,$uname,$udom,$runame,$rudom,$rsec)=
+	    split(/\:/,$entry);
+        if (&Apache::lonnet::put('nohist_userroles',
+             { $role.':'.$uname.':'.$udom.':'.$rsec => $userrolehash{$entry} },
+                $rudom,$runame) eq 'ok') {
+	    delete $userrolehash{$entry};
+        }
+    }
     $dumpcount++;
 }
 
@@ -976,10 +1105,13 @@ sub courselog {
     $what=time.':'.$what;
     unless ($ENV{'request.course.id'}) { return ''; }
     $coursedombuf{$ENV{'request.course.id'}}=
-       $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'.
+       $ENV{'course.'.$ENV{'request.course.id'}.'.domain'};
+    $coursenumbuf{$ENV{'request.course.id'}}=
        $ENV{'course.'.$ENV{'request.course.id'}.'.num'};
     $coursehombuf{$ENV{'request.course.id'}}=
        $ENV{'course.'.$ENV{'request.course.id'}.'.home'};
+    $coursedescrbuf{$ENV{'request.course.id'}}=
+       $ENV{'course.'.$ENV{'request.course.id'}.'.description'};
     if (defined $courselogs{$ENV{'request.course.id'}}) {
 	$courselogs{$ENV{'request.course.id'}}.='&'.$what;
     } else {
@@ -1016,7 +1148,75 @@ sub countacc {
         $accesshash{$key}=1;
     }
 }
-    
+
+sub userrolelog {
+    my ($trole,$username,$domain,$area,$tstart,$tend)=@_;
+    if (($trole=~/^ca/) || ($trole=~/^in/) || 
+        ($trole=~/^cc/) || ($trole=~/^ep/) ||
+        ($trole=~/^cr/)) {
+       my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
+       $userrolehash
+         {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
+                    =$tend.':'.$tstart;
+   }
+}
+
+sub get_course_adv_roles {
+    my $cid=shift;
+    $cid=$ENV{'request.course.id'} unless (defined($cid));
+    my %coursehash=&coursedescription($cid);
+    my %returnhash=();
+    my %dumphash=
+            &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
+    my $now=time;
+    foreach (keys %dumphash) {
+	my ($tend,$tstart)=split(/\:/,$dumphash{$_});
+        if (($tstart) && ($tstart<0)) { next; }
+        if (($tend) && ($tend<$now)) { next; }
+        if (($tstart) && ($now<$tstart)) { next; }
+        my ($role,$username,$domain,$section)=split(/\:/,$_);
+        my $key=&plaintext($role);
+        if ($section) { $key.=' (Sec/Grp '.$section.')'; }
+        if ($returnhash{$key}) {
+	    $returnhash{$key}.=','.$username.':'.$domain;
+        } else {
+            $returnhash{$key}=$username.':'.$domain;
+        }
+    }
+    return sort %returnhash;
+}
+
+# ---------------------------------------------------------- Course ID routines
+# Deal with domain's nohist_courseid.db files
+#
+
+sub courseidput {
+    my ($domain,$what,$coursehome)=@_;
+    return &reply('courseidput:'.$domain.':'.$what,$coursehome);
+}
+
+sub courseiddump {
+    my ($domfilter,$descfilter,$sincefilter)=@_;
+    my %returnhash=();
+    unless ($domfilter) { $domfilter=''; }
+    foreach my $tryserver (keys %libserv) {
+	if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) {
+	    foreach (
+             split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.
+			       $sincefilter.':'.&escape($descfilter),
+                               $tryserver))) {
+		my ($key,$value)=split(/\=/,$_);
+                if (($key) && ($value)) {
+		    $returnhash{&unescape($key)}=&unescape($value);
+                }
+            }
+
+        }
+    }
+    return %returnhash;
+}
+
+#
 # ----------------------------------------------------------- Check out an item
 
 sub checkout {
@@ -1621,6 +1821,8 @@ sub rolesinit {
             my ($trole,$tend,$tstart)=split(/_/,$role);
             $userroles.='user.role.'.$trole.'.'.$area.'='.
                         $tstart.'.'.$tend."\n";
+# log the associated role with the area
+            &userrolelog($trole,$username,$domain,$area,$tstart,$tend);
             if ($tend!=0) {
 	        if ($tend<$now) {
 	            $trole='';
@@ -1632,42 +1834,54 @@ sub rolesinit {
                 }
             }
             if (($area ne '') && ($trole ne '')) {
-	       my $spec=$trole.'.'.$area;
-               my ($tdummy,$tdomain,$trest)=split(/\//,$area);
-               if ($trole =~ /^cr\//) {
-		   my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
-                   my $homsvr=homeserver($rauthor,$rdomain);
-                   if ($hostname{$homsvr} ne '') {
-                      my $roledef=
-			  reply("get:$rdomain:$rauthor:roles:rolesdef_$rrole",
-                                $homsvr);
-                      if (($roledef ne 'con_lost') && ($roledef ne '')) {
-                         my ($syspriv,$dompriv,$coursepriv)=
-			     split(/\_/,unescape($roledef));
- 	                 $allroles{'cm./'}.=':'.$syspriv;
-                         $allroles{$spec.'./'}.=':'.$syspriv;
-                         if ($tdomain ne '') {
-                             $allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv;
-                             $allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;
-                             if ($trest ne '') {
-		                $allroles{'cm.'.$area}.=':'.$coursepriv;
-		                $allroles{$spec.'.'.$area}.=':'.$coursepriv;
-                             }
-	                 }
-                      }
-                   }
-               } else {
-	           $allroles{'cm./'}.=':'.$pr{$trole.':s'};
-	           $allroles{$spec.'./'}.=':'.$pr{$trole.':s'};
-                   if ($tdomain ne '') {
-                     $allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
-                     $allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
-                      if ($trest ne '') {
-		          $allroles{'cm.'.$area}.=':'.$pr{$trole.':c'};
-		          $allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'};
-                      }
-	           }
-	       }
+		my $spec=$trole.'.'.$area;
+		my ($tdummy,$tdomain,$trest)=split(/\//,$area);
+		if ($trole =~ /^cr\//) {
+		    my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
+		    my $homsvr=homeserver($rauthor,$rdomain);
+		    if ($hostname{$homsvr} ne '') {
+			my $roledef=
+			    reply("get:$rdomain:$rauthor:roles:rolesdef_$rrole",
+				  $homsvr);
+			if (($roledef ne 'con_lost') && ($roledef ne '')) {
+			    my ($syspriv,$dompriv,$coursepriv)=
+				split(/\_/,unescape($roledef));
+			    if (defined($syspriv)) {
+				$allroles{'cm./'}.=':'.$syspriv;
+				$allroles{$spec.'./'}.=':'.$syspriv;
+			    }
+			    if ($tdomain ne '') {
+				if (defined($dompriv)) {
+				    $allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv;
+				    $allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;
+				}
+				if ($trest ne '') {
+				    if (defined($coursepriv)) {
+					$allroles{'cm.'.$area}.=':'.$coursepriv;
+					$allroles{$spec.'.'.$area}.=':'.$coursepriv;
+				    }
+				}
+			    }
+			}
+		    }
+		} else {
+		    if (defined($pr{$trole.':s'})) {
+			$allroles{'cm./'}.=':'.$pr{$trole.':s'};
+			$allroles{$spec.'./'}.=':'.$pr{$trole.':s'};
+		    }
+		    if ($tdomain ne '') {
+			if (defined($pr{$trole.':d'})) {
+			    $allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
+			    $allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
+			}
+			if ($trest ne '') {
+			    if (defined($pr{$trole.':c'})) {
+				$allroles{'cm.'.$area}.=':'.$pr{$trole.':c'};
+				$allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'};
+			    }
+			}
+		    }
+		}
             }
           } 
         }
@@ -2336,7 +2550,7 @@ sub plaintext {
 # ----------------------------------------------------------------- Assign Role
 
 sub assignrole {
-    my ($udom,$uname,$url,$role,$end,$start)=@_;
+    my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_;
     my $mrole;
     if ($role =~ /^cr\//) {
 	unless (&allowed('ccr',$url)) {
@@ -2367,7 +2581,24 @@ sub assignrole {
            $command.='_0_'.$start;
         }
     }
-    return &reply($command,&homeserver($uname,$udom));
+# actually delete
+    if ($deleteflag) {
+	if (&allowed('dro',$udom)) {
+# modify command to delete the role
+           $command="encrypt:rolesdel:$ENV{'user.domain'}:$ENV{'user.name'}:".
+                "$udom:$uname:$url".'_'."$mrole";
+# set start and finish to negative values for userrolelog
+           $start=-1;
+           $end=-1;
+        }
+    }
+# send command
+    my $answer=&reply($command,&homeserver($uname,$udom));
+# log new user role if status is ok
+    if ($answer eq 'ok') {
+	&userrolelog($mrole,$uname,$udom,$url,$start,$end);
+    }
+    return $answer;
 }
 
 # -------------------------------------------------- Modify user authentication
@@ -2641,25 +2872,26 @@ ENDINITMAP
 # ---------------------------------------------------------- Assign Custom Role
 
 sub assigncustomrole {
-    my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start)=@_;
+    my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag)=@_;
     return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,
-                       $end,$start);
+                       $end,$start,$deleteflag);
 }
 
 # ----------------------------------------------------------------- Revoke Role
 
 sub revokerole {
-    my ($udom,$uname,$url,$role)=@_;
+    my ($udom,$uname,$url,$role,$deleteflag)=@_;
     my $now=time;
-    return &assignrole($udom,$uname,$url,$role,$now);
+    return &assignrole($udom,$uname,$url,$role,$now,$deleteflag);
 }
 
 # ---------------------------------------------------------- Revoke Custom Role
 
 sub revokecustomrole {
-    my ($udom,$uname,$url,$rdom,$rnam,$rolename)=@_;
+    my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag)=@_;
     my $now=time;
-    return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now);
+    return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now,
+           $deleteflag);
 }
 
 # ------------------------------------------------------------ Directory lister
@@ -3138,16 +3370,20 @@ sub metadata {
 				$value.=' [Part: '.$part.']';
 			    }
 			    my $unikey='parameter'.$keyroot.'_'.$name;
-			    if ($subp eq 'default') { $unikey='parameter_0_'.$name; }
-			    $metathesekeys{$unikey}=1;
-			    $metacache{$uri.':'.$unikey.'.part'}=$part;
+			    if ($subp eq 'default') {
+				$unikey='parameter_0_'.$name;
+				$metacache{$uri.':'.$unikey.'.part'}='0';
+			    } else {
+				$metacache{$uri.':'.$unikey.'.part'}=$part;
+				$metathesekeys{$unikey}=1;
+			    }
 			    unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) {
 				$metacache{$uri.':'.$unikey.'.'.$subp}=$value;
 			    }
 			    if (defined($metacache{$uri.':'.$unikey.'.default'})) {
 				$metacache{$uri.':'.$unikey}=
-				    $metacache{$uri.':'.$unikey.'.default'}
-				}
+				    $metacache{$uri.':'.$unikey.'.default'};
+			    }
 			}
 		    }
 		} else {
@@ -3243,7 +3479,7 @@ sub metadata_generate_part0 {
 	if ($metakey=~/^parameter\_(.*)/) {
 	  my $part=$$metacache{$uri.':'.$metakey.'.part'};
 	  my $name=$$metacache{$uri.':'.$metakey.'.name'};
-	  if (! exists($$metadata{'parameter_0_'.$name})) {
+	  if (! exists($$metadata{'parameter_0_'.$name.'.name'})) {
 	    $allnames{$name}=$part;
 	  }
 	}