--- loncom/lonnet/perl/lonnet.pm	2000/07/18 13:46:49	1.19
+++ loncom/lonnet/perl/lonnet.pm	2000/09/06 14:25:17	1.30
@@ -4,17 +4,40 @@
 # Functions for use by content handlers:
 #
 # plaintext(short)   : plain text explanation of short term
-# allowed(short,url) : returns codes for allowed actions
-# appendenv(hash)    : adds hash to session environment
+# fileembstyle(ext)  : embed style in page for file extension
+# filedescription(ext) : descriptor text for file extension
+# allowed(short,url) : returns codes for allowed actions 
+#                      F: full access
+#                      U,I,K: authentication modes (cxx only)
+#                      '': forbidden
+#                      1: user needs to choose course
+#                      2: browse allowed
+# definerole(rolename,sys,dom,cou) : define a custom role rolename
+#                      set priviledges in format of lonTabs/roles.tab for
+#                      system, domain and course level, 
+# assignrole(udom,uname,url,role,end,start) : give a role to a user for the
+#                      level given by url. Optional start and end dates
+#                      (leave empty string or zero for "no date") 
+# assigncustomrole (udom,uname,url,rdom,rnam,rolename,end,start) : give a
+#                      custom role to a user for the level given by url.
+#                      Specify name and domain of role author, and role name
+# revokerole (udom,uname,url,role) : Revoke a role for url
+# revokecustomrole (udom,uname,url,rdom,rnam,rolename) : Revoke a custom role
+# appenv(hash)       : adds hash to session environment
 # store(hash)        : stores hash permanently for this url
 # restore            : returns hash for this url
 # eget(namesp,array) : returns hash with keys from array filled in from namesp
 # get(namesp,array)  : returns hash with keys from array filled in from namesp
+# del(namesp,array)  : deletes keys out of arry from namesp
 # put(namesp,hash)   : stores hash in namesp
 # dump(namesp)       : dumps the complete namespace into a hash
-# ssi(url)           : does a complete request cycle on url to localhost
+# ssi(url,hash)      : does a complete request cycle on url to localhost, posts
+#                      hash
 # repcopy(filename)  : replicate file
 # dirlist(url)       : gets a directory listing
+# condval(index)     : value of condition index based on state
+# varval(name)       : value of a variable
+# refreshstate()     : refresh the state information string 
 #
 # 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,
@@ -24,7 +47,9 @@
 # 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 Gerd Kortemeyer
+# 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 Gerd Kortemeyer
 
 package Apache::lonnet;
 
@@ -33,7 +58,7 @@ use Apache::File;
 use LWP::UserAgent();
 use HTTP::Headers;
 use vars 
-qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp $readit);
+qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp %fe %fd $readit);
 use IO::Socket;
 use Apache::Constants qw(:common :http);
 
@@ -180,7 +205,9 @@ sub appenv {
         chomp($oldenv[$i]);
         if ($oldenv[$i] ne '') {
            my ($name,$value)=split(/=/,$oldenv[$i]);
-	   $newenv{$name}=$value;
+           unless (defined($newenv{$name})) {
+	      $newenv{$name}=$value;
+	   }
         }
     }
     {
@@ -292,6 +319,7 @@ sub subscribe {
 
 sub repcopy {
     my $filename=shift;
+    $filename=~s/\/+/\//g;
     my $transname="$filename.in.transfer";
     if ((-e $filename) || (-e $transname)) { return OK; }
     my $remoteurl=subscribe($filename);
@@ -301,9 +329,11 @@ sub repcopy {
     } elsif ($remoteurl eq 'not_found') {
 	   &logthis("Subscribe returned not_found: $filename");
 	   return HTTP_NOT_FOUND;
-    } elsif ($remoteurl eq 'forbidden') {
-	   &logthis("Subscribe returned forbidden: $filename");
+    } elsif ($remoteurl eq 'rejected') {
+	   &logthis("Subscribe returned rejected: $filename");
            return FORBIDDEN;
+    } elsif ($remoteurl eq 'directory') {
+           return OK;
     } else {
            my @parts=split(/\//,$filename);
            my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
@@ -347,10 +377,19 @@ sub repcopy {
 
 sub ssi {
 
-    my $fn=shift;
+    my ($fn,%form)=@_;
 
     my $ua=new LWP::UserAgent;
-    my $request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn);
+    
+    my $request;
+    
+    if (%form) {
+      $request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn);
+      $request->content(join '&', map { "$_=$form{$_}" } keys %form);
+    } else {
+      $request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn);
+    }
+
     $request->header(Cookie => $ENV{'HTTP_COOKIE'});
     my $response=$ua->request($request);
 
@@ -400,15 +439,18 @@ sub rolesinit {
     if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; }
     my %allroles=();
     my %thesepriv=();
-    my $userroles='';
     my $now=time;
+    my $userroles="user.login.time=$now\n";
     my $thesestr;
 
     if ($rolesdump ne '') {
         map {
-	  if ($_!~/rolesdef\&/) {
+	  if ($_!~/^rolesdef\&/) {
             my ($area,$role)=split(/=/,$_);
+            $area=~s/\_\w\w$//;
             my ($trole,$tend,$tstart)=split(/_/,$role);
+            $userroles.='user.role.'.$trole.'.'.$area.'='.
+                        $tstart.'.'.$tend."\n";
             if ($tend!=0) {
 	        if ($tend<$now) {
 	            $trole='';
@@ -420,19 +462,17 @@ sub rolesinit {
                 }
             }
             if (($area ne '') && ($trole ne '')) {
-               $userroles.='user.role.'.$trole.'.'.$area.'='.
-                           $tstart.'.'.$tend."\n";
                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",
+			  reply("get:$rdomain:$rauthor:roles:rolesdef_$rrole",
                                 $homsvr);
                       if (($roledef ne 'con_lost') && ($roledef ne '')) {
                          my ($syspriv,$dompriv,$coursepriv)=
-			     split(/&&/,$roledef);
+			     split(/\_/,unescape($roledef));
  	                 $allroles{'/'}.=':'.$syspriv;
                          if ($tdomain ne '') {
                              $allroles{'/'.$tdomain.'/'}.=':'.$dompriv;
@@ -491,11 +531,24 @@ sub get {
    my %returnhash=();
    map {
       my ($key,$value)=split(/=/,$_);
-      $returnhash{unespace($key)}=unescape($value);
+      $returnhash{unescape($key)}=unescape($value);
    } @pairs;
    return %returnhash;
 }
 
+# --------------------------------------------------------------- del interface
+
+sub del {
+   my ($namespace,@storearr)=@_;
+   my $items='';
+   map {
+       $items.=escape($_).'&';
+   } @storearr;
+   $items=~s/\&$//;
+   return reply("del:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
+                 $ENV{'user.home'});
+}
+
 # -------------------------------------------------------------- dump interface
 
 sub dump {
@@ -506,7 +559,7 @@ sub dump {
    my %returnhash=();
    map {
       my ($key,$value)=split(/=/,$_);
-      $returnhash{unespace($key)}=unescape($value);
+      $returnhash{unescape($key)}=unescape($value);
    } @pairs;
    return %returnhash;
 }
@@ -539,7 +592,7 @@ sub eget {
    my %returnhash=();
    map {
       my ($key,$value)=split(/=/,$_);
-      $returnhash{unespace($key)}=unescape($value);
+      $returnhash{unescape($key)}=unescape($value);
    } @pairs;
    return %returnhash;
 }
@@ -550,9 +603,15 @@ sub allowed {
     my ($priv,$uri)=@_;
     $uri=~s/^\/res//;
     $uri=~s/^\///;
-    if ($uri=~/^adm\//) {
+
+# Free bre access to adm resources
+
+    if (($uri=~/^adm\//) && ($priv eq 'bre')) {
 	return 'F';
     }
+
+# Gather priviledges over system and domain
+
     my $thisallowed='';
     if ($ENV{'user.priv./'}=~/$priv\&([^\:]*)/) {
        $thisallowed.=$1;
@@ -560,20 +619,131 @@ sub allowed {
     if ($ENV{'user.priv./'.(split(/\//,$uri))[0].'/'}=~/$priv\&([^\:]*)/) {
        $thisallowed.=$1;
     }
-    if ($ENV{'user.priv./'.$uri}=~/$priv\&([^\:]*)/) {
-       $thisallowed.=$1;
+
+# Full access at system or domain level? Exit.
+
+    if ($thisallowed=~/F/) {
+	return 'F';
+    }
+
+# The user does not have full access at system or domain level
+# Course level access control
+
+# uri itself refering to a course?
+    
+    if ($uri=~/\.course$/) {
+       if ($ENV{'user.priv./'.$uri}=~/$priv\&([^\:]*)/) {
+          $thisallowed.=$1;
+       }
+# Full access on course level? Exit.
+       if ($thisallowed=~/F/) {
+	  return 'F';
+       }
+
+# uri is refering to an individual resource; user needs to be in a course
+
+   } else {
+
+       unless(defined($ENV{'request.course.uri'})) {
+	   return '1';
+       }
+
+# Get access priviledges for course
+
+       if ($ENV{'user.priv./'.$ENV{'request.course.uri'}}=~/$priv\&([^\:]*)/) {
+          $thisallowed.=$1;
+       }
+
+# See if resource or referer is part of this course
+          
+       my @uriparts=split(/\//,$uri);
+       my $urifile=$uriparts[$#uriparts];
+       $urifile=~/\.(\w+)$/;
+       my $uritype=$1;
+       $#uriparts--;
+       my $uripath=join('/',@uriparts);
+       my $uricond=-1;
+       if ($ENV{'acc.res.'.$ENV{'request.course'}.'.'.$uripath}=~
+	   /\&$urifile\:(\d+)\&/) {
+	   $uricond=$1;
+       } elsif (($fe{$uritype} eq 'emb') || ($fe{$uritype} eq 'img')) {
+	  my $refuri=$ENV{'HTTP_REFERER'};
+          $refuri=~s/^\/res//;
+          $refuri=~s/^\///;
+          @uriparts=split(/\//,$refuri);
+          $urifile=$uriparts[$#uriparts];
+          $#uriparts--;
+          $uripath=join('/',@uriparts);
+          if ($ENV{'acc.res.'.$ENV{'request.course'}.'.'.$uripath}=~
+	     /\&$urifile\:(\d+)\&/) {
+	     $uricond=$1;
+	  }
+       }
+
+       if ($uricond>=0) {
+
+# The resource is part of the course
+# If user had full access on course level, go ahead
+
+           if ($thisallowed=~/F/) {
+	       return 'F';
+           }
+
+# Restricted by state?
+
+           if ($thisallowed=~/X/) {
+	      if (&condval($uricond)>1) {
+	         return '2';
+              } else {
+                 return '';
+              }
+	   }
+       }
     }
     return $thisallowed;
 }
 
+# ---------------------------------------------------------- Refresh State Info
+
+sub refreshstate {
+}
+
 # ----------------------------------------------------------------- Define Role
 
 sub definerole {
   if (allowed('mcr','/')) {
     my ($rolename,$sysrole,$domrole,$courole)=@_;
+    map {
+	my ($crole,$cqual)=split(/\&/,$_);
+        if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; }
+        if ($pr{'cr:s'}=~/$crole\&/) {
+	    if ($pr{'cr:s'}!~/$crole\&\w*$cqual/) { 
+               return "refused:s:$crole&$cqual"; 
+            }
+        }
+    } split('/',$sysrole);
+    map {
+	my ($crole,$cqual)=split(/\&/,$_);
+        if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; }
+        if ($pr{'cr:d'}=~/$crole\&/) {
+	    if ($pr{'cr:d'}!~/$crole\&\w*$cqual/) { 
+               return "refused:d:$crole&$cqual"; 
+            }
+        }
+    } split('/',$domrole);
+    map {
+	my ($crole,$cqual)=split(/\&/,$_);
+        if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; }
+        if ($pr{'cr:c'}=~/$crole\&/) {
+	    if ($pr{'cr:c'}!~/$crole\&\w*$cqual/) { 
+               return "refused:c:$crole&$cqual"; 
+            }
+        }
+    } split('/',$courole);
     my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".
                 "$ENV{'user.domain'}:$ENV{'user.name'}:".
-	        "rolesdef&$rolename=$sysrole&&$domrole&&$courole";
+	        "rolesdef_$rolename=".
+                escape($sysrole.'_'.$domrole.'_'.$courole);
     return reply($command,$ENV{'user.home'});
   } else {
     return 'refused';
@@ -583,12 +753,75 @@ sub definerole {
 # ------------------------------------------------------------------ Plain Text
 
 sub plaintext {
-    return $prp{$_};
+    my $short=shift;
+    return $prp{$short};
+}
+
+# ------------------------------------------------------------------ Plain Text
+
+sub fileembstyle {
+    my $ending=shift;
+    return $fe{$ending};
+}
+
+# ------------------------------------------------------------ Description Text
+
+sub filedecription {
+    my $ending=shift;
+    return $fd{$ending};
 }
 
 # ----------------------------------------------------------------- Assign Role
 
 sub assignrole {
+    my ($udom,$uname,$url,$role,$end,$start)=@_;
+    my $mrole;
+    $url=~s/^\///;
+    $url=~s/^res\///;
+    if ($role =~ /^cr\//) {
+        unless ($url=~/\.course$/) { return 'invalid'; }
+	unless (allowed('ccr',$url)) { return 'refused'; }
+        $mrole='cr';
+    } else {
+        unless (($url=~/\.course$/) || ($url=~/\/$/)) { return 'invalid'; }
+        unless (allowed('c'+$role)) { return 'refused'; }
+        $mrole=$role;
+    }
+    my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".
+                "$udom:$uname:$url".'_'."$mrole=$role";
+    if ($end) { $command.='_$end'; }
+    if ($start) {
+	if ($end) { 
+           $command.='_$start'; 
+        } else {
+           $command.='_0_$start';
+        }
+    }
+    return &reply($command,&homeserver($uname,$udom));
+}
+
+# ---------------------------------------------------------- Assign Custom Role
+
+sub assigncustomrole {
+    my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start)=@_;
+    return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,
+                       $end,$start);
+}
+
+# ----------------------------------------------------------------- Revoke Role
+
+sub revokerole {
+    my ($udom,$uname,$url,$role)=@_;
+    my $now=time;
+    return &assignrole($udom,$uname,$url,$role,$now);
+}
+
+# ---------------------------------------------------------- Revoke Custom Role
+
+sub revokecustomrole {
+    my ($udom,$uname,$url,$rdom,$rnam,$rolename)=@_;
+    my $now=time;
+    return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now);
 }
 
 # ------------------------------------------------------------ Directory lister
@@ -641,6 +874,62 @@ sub dirlist {
    }
 }
 
+# -------------------------------------------------------- Value of a Condition
+
+sub condval {
+    my $condidx=shift;
+    my $result=0;
+    if ($ENV{'request.course'}) {
+       if (defined($ENV{'acc.cond.'.$ENV{'request.course'}.'.'.$condidx})) {
+          my $operand='|';
+	  my @stack;
+          map {
+              if ($_ eq '(') {
+                 push @stack,($operand,$result)
+              } elsif ($_ eq ')') {
+                  my $before=pop @stack;
+		  if (pop @stack eq '&') {
+		      $result=$result>$before?$before:$result;
+                  } else {
+                      $result=$result>$before?$result:$before;
+                  }
+              } elsif (($_ eq '&') || ($_ eq '|')) {
+                  $operand=$_;
+              } else {
+                  my $new=
+                       substr($ENV{'user.state.'.$ENV{'request.course'}},$_,1);
+                  if ($operand eq '&') {
+                     $result=$result>$new?$new:$result;
+                  } else {
+                     $result=$result>$new?$result:$new;
+                  }                  
+              }
+          } ($ENV{'acc.cond.'.$ENV{'request.course'}.'.'.$condidx}=~
+             /(\d+|\(|\)|\&|\|)/g);
+       }
+    }
+    return $result;
+}
+
+# --------------------------------------------------------- Value of a Variable
+
+sub varval {
+    my ($realm,$space,@components)=split(/\./,shift);
+    my $value='';
+    if ($realm eq 'user') {
+	if ($space=~/^resource/) {
+	    $space=~s/^resource\[//;
+            $space=~s/\]$//;
+
+        } else {
+        }
+    } elsif ($realm eq 'course') {
+    } elsif ($realm eq 'session') {
+    } elsif ($realm eq 'system') {
+    }
+    return $value;
+}
+
 # -------------------------------------------------------- Escape Special Chars
 
 sub escape {
@@ -719,12 +1008,23 @@ if ($readit ne 'done') {
     }
 }
 
+# ------------------------------------------------------------- Read file types
+{
+    my $config=Apache::File->new("$perlvar{'lonTabDir'}/filetypes.tab");
+
+    while (my $configline=<$config>) {
+       chomp($configline);
+       my ($ending,$emb,@descr)=split(/\s+/,$configline);
+       if ($descr[0] ne '') { 
+         $fe{$ending}=$emb;
+         $fd{$ending}=join(' ',@descr);
+       }
+    }
+}
+
+
 $readit='done';
 &logthis('<font color=yellow>INFO: Read configuration</font>');
 }
 }
 1;
-
-
-
-