--- loncom/lonnet/perl/lonnet.pm	2003/03/14 15:08:20	1.339
+++ loncom/lonnet/perl/lonnet.pm	2003/03/24 18:18:09	1.349
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.339 2003/03/14 15:08:20 albertel Exp $
+# $Id: lonnet.pm,v 1.349 2003/03/24 18:18:09 www Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -74,7 +74,7 @@ use HTTP::Headers;
 use vars 
 qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom 
    %libserv %pr %prp %metacache %packagetab %titlecache 
-   %courselogs %accesshash $processmarker $dumpcount 
+   %courselogs %accesshash %userrolehash $processmarker $dumpcount 
    %coursedombuf %coursehombuf %courseresdatacache 
    %domaindescription %domain_auth_def %domain_auth_arg_def $tmpdir);
 use IO::Socket;
@@ -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 {
@@ -968,6 +1054,17 @@ sub flushcourselogs {
 	    delete $accesshash{$entry};
         }
     }
+    &logthis('Flushing role logs');
+    foreach (keys %userrolehash) {
+        my $entry=$_;
+        my ($role,$uname,$udom,$runame,$rudom)=
+	    split(/\:/,$entry);
+        if (&Apache::lonnet::put('nohist_userroles',
+                { $role.':'.$uname.':'.$udom => $userrolehash{$entry} },
+                $rudom,$runame) eq 'ok') {
+	    delete $userrolehash{$entry};
+        }
+    }
     $dumpcount++;
 }
 
@@ -1016,7 +1113,17 @@ 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)=split(/\//,$area);
+       $userrolehash{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom}
+                    =$tend.':'.$tstart;
+   }
+}    
 # ----------------------------------------------------------- Check out an item
 
 sub checkout {
@@ -1621,6 +1728,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 +1741,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'};
+			    }
+			}
+		    }
+		}
             }
           } 
         }
@@ -1870,6 +1991,37 @@ sub eget {
    return %returnhash;
 }
 
+# ---------------------------------------------- Custom access rule evaluation
+
+sub customaccess {
+    my ($priv,$uri)=@_;
+    my ($urole,$urealm)=split(/\./,$ENV{'request.role'});
+    $urealm=~s/^\W//;
+    my ($udom,$ucrs,$usec)=split(/\//,$urealm);
+    my $access=0;
+    foreach (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) {
+	my ($effect,$realm,$role)=split(/\:/,$_);
+        if ($role) {
+	   if ($role ne $urole) { next; }
+        }
+        foreach (split(/\s*\,\s*/,$realm)) {
+            my ($tdom,$tcrs,$tsec)=split(/\_/,$_);
+            if ($tdom) {
+		if ($tdom ne $udom) { next; }
+            }
+            if ($tcrs) {
+		if ($tcrs ne $ucrs) { next; }
+            }
+            if ($tsec) {
+		if ($tsec ne $usec) { next; }
+            }
+            $access=($effect eq 'allow');
+            last;
+        }
+    }
+    return $access;
+}
+
 # ------------------------------------------------- Check for a user privilege
 
 sub allowed {
@@ -1908,6 +2060,9 @@ sub allowed {
             # Library role, so allow browsing of resources in this domain.
             return 'F';
         }
+        if ($copyright eq 'custom') {
+	    unless (&customaccess($priv,$uri)) { return ''; }
+        }
     }
     # Domain coordinator is trying to create a course
     if (($priv eq 'ccc') && ($ENV{'request.role'} =~ /^dc\./)) {
@@ -2125,20 +2280,10 @@ sub allowed {
 
    if ($thisallowed=~/R/) {
        my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
-       my $filename=$perlvar{'lonDocRoot'}.'/res/'.$uri.'.meta';
-       if (-e $filename) {
-           my @content;
-           {
-	     my $fh=Apache::File->new($filename);
-             @content=<$fh>;
-	   }
-           if (join('',@content)=~
-                    /\<roledeny[^\>]*\>[^\<]*$rolecode[^\<]*\<\/roledeny\>/) {
-	       &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
+       if (&metadata($uri,'roledeny')=~/$rolecode/) {
+	  &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
                     'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
-           return '';
-
-           }
+          return '';
        }
    }
 
@@ -2343,7 +2488,11 @@ sub assignrole {
            $command.='_0_'.$start;
         }
     }
-    return &reply($command,&homeserver($uname,$udom));
+    my $answer=&reply($command,&homeserver($uname,$udom));
+    if ($answer eq 'ok') {
+	&userrolelog($mrole,$uname,$udom,$url,$start,$end);
+    }
+    return $answer;
 }
 
 # -------------------------------------------------- Modify user authentication
@@ -3114,6 +3263,7 @@ 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;
 			    unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) {