[BACK]Return to lonnet.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom / lonnet / perl

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.459.2.1 and 1.482

version 1.459.2.1, 2004/01/15 19:43:07 version 1.482, 2004/04/01 14:55:18
Line 32  package Apache::lonnet; Line 32  package Apache::lonnet;
 use strict;  use strict;
 use LWP::UserAgent();  use LWP::UserAgent();
 use HTTP::Headers;  use HTTP::Headers;
   use Date::Parse;
 use vars   use vars 
 qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom   qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom 
    %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache     %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache
Line 377  sub delenv { Line 378  sub delenv {
     return 'error: '.$!;      return 'error: '.$!;
  }   }
  foreach (@oldenv) {   foreach (@oldenv) {
     unless ($_=~/^$delthis/) { print $fh $_; }      if ($_=~/^$delthis/) { 
                   my ($key,undef) = split('=',$_);
                   delete($ENV{$key});
               } else {
                   print $fh $_; 
               }
  }   }
  close($fh);   close($fh);
     }      }
Line 524  sub authenticate { Line 530  sub authenticate {
     my ($uname,$upass,$udom)=@_;      my ($uname,$upass,$udom)=@_;
     $upass=escape($upass);      $upass=escape($upass);
     $uname=~s/\W//g;      $uname=~s/\W//g;
     if (($perlvar{'lonRole'} eq 'library') &&       my $uhome=&homeserver($uname,$udom);
         ($udom eq $perlvar{'lonDefDomain'})) {      if (!$uhome) {
     my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'});   &logthis("User $uname at $udom is unknown in authenticate");
         if ($answer =~ /authorized/) {   return 'no_host';
               if ($answer eq 'authorized') {  
                  &logthis("User $uname at $udom authorized by local server");   
                  return $perlvar{'lonHostID'};   
               }  
               if ($answer eq 'non_authorized') {  
                  &logthis("User $uname at $udom rejected by local server");   
                  return 'no_host';   
               }  
  }  
     }      }
       my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome);
     my $tryserver;      if ($answer eq 'authorized') {
     foreach $tryserver (keys %libserv) {   &logthis("User $uname at $udom authorized by $uhome"); 
  if ($hostdom{$tryserver} eq $udom) {   return $uhome; 
            my $answer=reply("encrypt:auth:$udom:$uname:$upass",$tryserver);      }
            if ($answer =~ /authorized/) {      if ($answer eq 'non_authorized') {
               if ($answer eq 'authorized') {   &logthis("User $uname at $udom rejected by $uhome");
                  &logthis("User $uname at $udom authorized by $tryserver");    return 'no_host'; 
                  return $tryserver;   
               }  
               if ($answer eq 'non_authorized') {  
                  &logthis("User $uname at $udom rejected by $tryserver");  
                  return 'no_host';  
               }   
    }  
        }  
     }      }
     &logthis("User $uname at $udom could not be authenticated");          &logthis("User $uname at $udom threw error $answer when checking authentication mechanism");
     return 'no_host';      return 'no_host';
 }  }
   
Line 661  sub assign_access_key { Line 650  sub assign_access_key {
     $uname=$ENV{'user.domain'} unless (defined($uname));      $uname=$ENV{'user.domain'} unless (defined($uname));
     my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);      my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
     if (($existing{$ckey}=~/^\#(.*)$/) || # - new key      if (($existing{$ckey}=~/^\#(.*)$/) || # - new key
         ($existing{$ckey}=~/^$uname\:$udom\#(.*)$/)) {           ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#(.*)$/)) { 
                                                   # assigned to this person                                                    # assigned to this person
                                                   # - this should not happen,                                                    # - this should not happen,
                                                   # unless something went wrong                                                    # unless something went wrong
Line 768  sub validate_access_key { Line 757  sub validate_access_key {
     $udom=$ENV{'user.name'} unless (defined($udom));      $udom=$ENV{'user.name'} unless (defined($udom));
     $uname=$ENV{'user.domain'} unless (defined($uname));      $uname=$ENV{'user.domain'} unless (defined($uname));
     my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);      my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
     return ($existing{$ckey}=~/^$uname\:$udom\#/);      return ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#/);
 }  }
   
 # ------------------------------------- Find the section of student in a course  # ------------------------------------- Find the section of student in a course
Line 796  sub getsection { Line 785  sub getsection {
                         &homeserver($unam,$udom)))) {                          &homeserver($unam,$udom)))) {
         my ($key,$value)=split(/\=/,$_);          my ($key,$value)=split(/\=/,$_);
         $key=&unescape($key);          $key=&unescape($key);
         next if ($key !~/^$courseid(?:\/)*(\w+)*\_st$/);          next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/);
         my $section=$1;          my $section=$1;
         if ($key eq $courseid.'_st') { $section=''; }          if ($key eq $courseid.'_st') { $section=''; }
         my ($dummy,$end,$start)=split(/\_/,&unescape($value));          my ($dummy,$end,$start)=split(/\_/,&unescape($value));
Line 975  sub usection { Line 964  sub usection {
                         &homeserver($unam,$udom)))) {                          &homeserver($unam,$udom)))) {
         my ($key,$value)=split(/\=/,$_);          my ($key,$value)=split(/\=/,$_);
         $key=&unescape($key);          $key=&unescape($key);
         if ($key=~/^$courseid(?:\/)*(\w+)*\_st$/) {          if ($key=~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/) {
             my $section=$1;              my $section=$1;
             if ($key eq $courseid.'_st') { $section=''; }              if ($key eq $courseid.'_st') { $section=''; }
     my ($dummy,$end,$start)=split(/\_/,&unescape($value));      my ($dummy,$end,$start)=split(/\_/,&unescape($value));
Line 1183  sub tokenwrapper { Line 1172  sub tokenwrapper {
     $uri=~s/^\///;      $uri=~s/^\///;
     $ENV{'user.environment'}=~/\/([^\/]+)\.id/;      $ENV{'user.environment'}=~/\/([^\/]+)\.id/;
     my $token=$1;      my $token=$1;
     if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) {  #    if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) {
       if ($uri=~m|^uploaded/([^/]+)/([^/]+)/(.+)(\?\.*)*$|) {
  &appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'});   &appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'});
         return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri.          return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri.
                (($uri=~/\?/)?'&':'?').'token='.$token.                 (($uri=~/\?/)?'&':'?').'token='.$token.
Line 1192  sub tokenwrapper { Line 1182  sub tokenwrapper {
  return '/adm/notfound.html';   return '/adm/notfound.html';
     }      }
 }  }
       
   # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course
   # input: action, courseID, current domain, home server for course, intended
   #        path to file, source of file.
   # output: ok if successful, diagnostic message otherwise
   #
   # Allows directory structure to be used within lonUsers/../userfiles/ for a 
   # course.
   #
   # action = propagate - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
   #          will be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles in
   #          course's home server.
   #
   # action = copy - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file will
   #          be copied from $source (current location) to 
   #          /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
   #         and will then be copied to
   #          /home/httpd/lonUsers/$domain/1/2/3/$course/userfiles/$file in
   #         course's home server.
   # action = uploaddoc - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
   #         will be retrived from $ENV{form.$source} via DOCS interface to
   #         /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
   #         and will then be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles/$file
   #         in course's home server.
   
   
   sub process_coursefile {
       my ($action,$docuname,$docudom,$docuhome,$file,$source)=@_;
       my $fetchresult;
       if ($action eq 'propagate') {
           $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file
                               ,$docuhome);
       } else {
           my $fetchresult = '';
           my $fpath = '';
           my $fname = $file;
           ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);
           $fpath=$docudom.'/'.$docuname.'/'.$fpath;
           my $filepath=$perlvar{'lonDocRoot'}.'/userfiles';
           unless ($fpath eq '') {
               my @parts=split('/',$fpath);
               foreach my $part (@parts) {
                   $filepath.= '/'.$part;
                   if ((-e $filepath)!=1) {
                       mkdir($filepath,0777);
                   }
               }
           }
           if ($action eq 'copy') {
               if ($source eq '') {
                   $fetchresult = 'no source file';
                   return $fetchresult;
               } else {
                   my $destination = $filepath.'/'.$fname;
                   rename($source,$destination);
                   $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
                                    $docuhome);
               }
           } elsif ($action eq 'uploaddoc') {
               open(my $fh,'>'.$filepath.'/'.$fname);
               print $fh $ENV{'form.'.$source};
               close($fh);
               $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
                                    $docuhome);
               if ($fetchresult eq 'ok') {
                   return '/uploaded/'.$fpath.'/'.$fname;
               } else {
                   &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
                           ' to host '.$docuhome.': '.$fetchresult);
                   return '/adm/notfound.html';
               }
           }
       }
       unless ( ($fetchresult eq 'ok') || ($fetchresult eq 'no source file') ) {
           &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
                ' to host '.$docuhome.': '.$fetchresult);
       }
       return $fetchresult;
   }
   
 # --------------- Take an uploaded file and put it into the userfiles directory  # --------------- Take an uploaded file and put it into the userfiles directory
 # input: name of form element, coursedoc=1 means this is for the course  # input: name of form element, coursedoc=1 means this is for the course
 # output: url of file in userspace  # output: url of file in userspace
Line 1211  sub userfileupload { Line 1280  sub userfileupload {
 # See if there is anything left  # See if there is anything left
     unless ($fname) { return 'error: no uploaded file'; }      unless ($fname) { return 'error: no uploaded file'; }
     chop($ENV{'form.'.$formname});      chop($ENV{'form.'.$formname});
       my $url = '';
 # Create the directory if not present  # Create the directory if not present
     my $docuname='';      my $docuname='';
     my $docudom='';      my $docudom='';
Line 1219  sub userfileupload { Line 1289  sub userfileupload {
  $docuname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'};   $docuname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'};
  $docudom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'};   $docudom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'};
  $docuhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};   $docuhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};
           if ($ENV{'form.folder'} =~ m/^default/) {
               $url = &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname);
           } else {
               $fname=$ENV{'form.folder'}.'/'.$fname;
               $url = &process_coursefile('uploaddoc',$docuname,$docudom,$docuhome,$fname,$formname);
           }
     } else {      } else {
         $docuname=$ENV{'user.name'};          $docuname=$ENV{'user.name'};
         $docudom=$ENV{'user.domain'};          $docudom=$ENV{'user.domain'};
Line 1248  sub finishuserfileupload { Line 1324  sub finishuserfileupload {
     }      }
 # Notify homeserver to grep it  # Notify homeserver to grep it
 #  #
           my $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,
     my $fetchresult=       $docuhome);
  &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,$docuhome);  
     if ($fetchresult eq 'ok') {      if ($fetchresult eq 'ok') {
 #  #
 # Return the URL to it  # Return the URL to it
Line 1424  sub userrolelog { Line 1499  sub userrolelog {
     my ($trole,$username,$domain,$area,$tstart,$tend)=@_;      my ($trole,$username,$domain,$area,$tstart,$tend)=@_;
     if (($trole=~/^ca/) || ($trole=~/^in/) ||       if (($trole=~/^ca/) || ($trole=~/^in/) || 
         ($trole=~/^cc/) || ($trole=~/^ep/) ||          ($trole=~/^cc/) || ($trole=~/^ep/) ||
         ($trole=~/^cr/)) {          ($trole=~/^cr/) || ($trole=~/^ta/)) {
        my (undef,$rudom,$runame,$rsec)=split(/\//,$area);         my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
        $userrolehash         $userrolehash
          {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}           {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
Line 1436  sub get_course_adv_roles { Line 1511  sub get_course_adv_roles {
     my $cid=shift;      my $cid=shift;
     $cid=$ENV{'request.course.id'} unless (defined($cid));      $cid=$ENV{'request.course.id'} unless (defined($cid));
     my %coursehash=&coursedescription($cid);      my %coursehash=&coursedescription($cid);
       my %nothide=();
       foreach (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
    $nothide{join(':',split(/[\@\:]/,$_))}=1;
       }
     my %returnhash=();      my %returnhash=();
     my %dumphash=      my %dumphash=
             &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});              &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
Line 1446  sub get_course_adv_roles { Line 1525  sub get_course_adv_roles {
         if (($tend) && ($tend<$now)) { next; }          if (($tend) && ($tend<$now)) { next; }
         if (($tstart) && ($now<$tstart)) { next; }          if (($tstart) && ($now<$tstart)) { next; }
         my ($role,$username,$domain,$section)=split(/\:/,$_);          my ($role,$username,$domain,$section)=split(/\:/,$_);
    if ((&privileged($username,$domain)) && 
       (!$nothide{$username.':'.$domain})) { next; }
         my $key=&plaintext($role);          my $key=&plaintext($role);
         if ($section) { $key.=' (Sec/Grp '.$section.')'; }          if ($section) { $key.=' (Sec/Grp '.$section.')'; }
         if ($returnhash{$key}) {          if ($returnhash{$key}) {
Line 2127  sub coursedescription { Line 2208  sub coursedescription {
     return %returnhash;      return %returnhash;
 }  }
   
   # -------------------------------------------------See if a user is privileged
   
   sub privileged {
       my ($username,$domain)=@_;
       my $rolesdump=&reply("dump:$domain:$username:roles",
    &homeserver($username,$domain));
       if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return 0; }
       my $now=time;
       if ($rolesdump ne '') {
           foreach (split(/&/,$rolesdump)) {
       if ($_!~/^rolesdef\&/) {
    my ($area,$role)=split(/=/,$_);
    $area=~s/\_\w\w$//;
    my ($trole,$tend,$tstart)=split(/_/,$role);
    if (($trole eq 'dc') || ($trole eq 'su')) {
       my $active=1;
       if ($tend) {
    if ($tend<$now) { $active=0; }
       }
       if ($tstart) {
    if ($tstart>$now) { $active=0; }
       }
       if ($active) { return 1; }
    }
       }
    }
       }
       return 0;
   }
   
 # -------------------------------------------------------- Get user privileges  # -------------------------------------------------------- Get user privileges
   
 sub rolesinit {  sub rolesinit {
Line 2547  sub allowed { Line 2658  sub allowed {
   
 # Course  # Course
   
     if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'}=~/$priv\&([^\:]*)/) {      if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) {
        $thisallowed.=$1;         $thisallowed.=$1;
     }      }
   
 # Domain  # Domain
   
     if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.(split(/\//,$uri))[0].'/'}      if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.(split(/\//,$uri))[0].'/'}
        =~/$priv\&([^\:]*)/) {         =~/\Q$priv\E\&([^\:]*)/) {
        $thisallowed.=$1;         $thisallowed.=$1;
     }      }
   
Line 2564  sub allowed { Line 2675  sub allowed {
     $courseuri=~s/^([^\/])/\/$1/;      $courseuri=~s/^([^\/])/\/$1/;
   
     if ($ENV{'user.priv.'.$ENV{'request.role'}.'.'.$courseuri}      if ($ENV{'user.priv.'.$ENV{'request.role'}.'.'.$courseuri}
        =~/$priv\&([^\:]*)/) {         =~/\Q$priv\E\&([^\:]*)/) {
        $thisallowed.=$1;         $thisallowed.=$1;
     }      }
   
Line 2582  sub allowed { Line 2693  sub allowed {
   
 # If this is generating or modifying users, exit with special codes  # If this is generating or modifying users, exit with special codes
   
     if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:$priv\:/) {      if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:\Q$priv\E\:/) {
  return $thisallowed;   return $thisallowed;
     }      }
 #  #
Line 2603  sub allowed { Line 2714  sub allowed {
        if ($match) {         if ($match) {
            $statecond=$cond;             $statecond=$cond;
            if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}             if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}
                =~/$priv\&([^\:]*)/) {                 =~/\Q$priv\E\&([^\:]*)/) {
                $thisallowed.=$1;                 $thisallowed.=$1;
                $checkreferer=0;                 $checkreferer=0;
            }             }
Line 2631  sub allowed { Line 2742  sub allowed {
             if ($match) {              if ($match) {
               my $refstatecond=$cond;                my $refstatecond=$cond;
               if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}                if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}
                   =~/$priv\&([^\:]*)/) {                    =~/\Q$priv\E\&([^\:]*)/) {
                   $thisallowed.=$1;                    $thisallowed.=$1;
                   $uri=$refuri;                    $uri=$refuri;
                   $statecond=$refstatecond;                    $statecond=$refstatecond;
Line 2684  sub allowed { Line 2795  sub allowed {
                if ((time-$ENV{$prefix.'last_cache'})>$expiretime) {                 if ((time-$ENV{$prefix.'last_cache'})>$expiretime) {
    &coursedescription($courseid);     &coursedescription($courseid);
                }                 }
                if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,$csec\,/)                 if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,\Q$csec\E\,/)
                 || ($ENV{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {                  || ($ENV{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {
    if ($ENV{$prefix.'res.'.$uri.'.lock.expire'}>time) {     if ($ENV{$prefix.'res.'.$uri.'.lock.expire'}>time) {
                        &log($ENV{'user.domain'},$ENV{'user.name'},                         &log($ENV{'user.domain'},$ENV{'user.name'},
Line 2695  sub allowed { Line 2806  sub allowed {
        return '';         return '';
                    }                     }
                }                 }
                if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,$csec\,/)                 if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/)
                 || ($ENV{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {                  || ($ENV{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {
    if ($ENV{'priv.'.$priv.'.lock.expire'}>time) {     if ($ENV{'priv.'.$priv.'.lock.expire'}>time) {
                        &log($ENV{'user.domain'},$ENV{'user.name'},                         &log($ENV{'user.domain'},$ENV{'user.name'},
Line 2729  sub allowed { Line 2840  sub allowed {
        my $rolecode=(split(/\./,$ENV{'request.role'}))[0];         my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
        my $unamedom=$ENV{'user.name'}.':'.$ENV{'user.domain'};         my $unamedom=$ENV{'user.name'}.':'.$ENV{'user.domain'};
        if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'}         if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'}
    =~/$rolecode/) {     =~/\Q$rolecode\E/) {
            &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},             &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
                 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.                  'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
                 $ENV{'request.course.id'});                  $ENV{'request.course.id'});
Line 2737  sub allowed { Line 2848  sub allowed {
        }         }
   
        if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.users.denied'}         if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.users.denied'}
    =~/$unamedom/) {     =~/\Q$unamedom\E/) {
            &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},             &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
                 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.                  'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
                 $ENV{'request.course.id'});                  $ENV{'request.course.id'});
Line 2749  sub allowed { Line 2860  sub allowed {
   
    if ($thisallowed=~/R/) {     if ($thisallowed=~/R/) {
        my $rolecode=(split(/\./,$ENV{'request.role'}))[0];         my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
        if (&metadata($uri,'roledeny')=~/$rolecode/) {         if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) {
   &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},    &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
                     'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);                      'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
           return '';            return '';
Line 2761  sub allowed { Line 2872  sub allowed {
    if ($thisallowed=~/X/) {     if ($thisallowed=~/X/) {
       if ($ENV{'acc.randomout'}) {        if ($ENV{'acc.randomout'}) {
          my $symb=&symbread($uri,1);           my $symb=&symbread($uri,1);
          if (($symb) && ($ENV{'acc.randomout'}=~/\&$symb\&/)) {            if (($symb) && ($ENV{'acc.randomout'}=~/\&\Q$symb\E\&/)) { 
             return '';               return ''; 
          }           }
       }        }
Line 2825  sub definerole { Line 2936  sub definerole {
     my ($rolename,$sysrole,$domrole,$courole)=@_;      my ($rolename,$sysrole,$domrole,$courole)=@_;
     foreach (split(':',$sysrole)) {      foreach (split(':',$sysrole)) {
  my ($crole,$cqual)=split(/\&/,$_);   my ($crole,$cqual)=split(/\&/,$_);
         if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; }          if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; }
         if ($pr{'cr:s'}=~/$crole\&/) {          if ($pr{'cr:s'}=~/\Q$crole\E\&/) {
     if ($pr{'cr:s'}!~/$crole\&\w*$cqual/) {       if ($pr{'cr:s'}!~/\Q$crole\E\&\w*\Q$cqual\E/) { 
                return "refused:s:$crole&$cqual";                  return "refused:s:$crole&$cqual"; 
             }              }
         }          }
     }      }
     foreach (split(':',$domrole)) {      foreach (split(':',$domrole)) {
  my ($crole,$cqual)=split(/\&/,$_);   my ($crole,$cqual)=split(/\&/,$_);
         if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; }          if ($pr{'cr:d'}!~/\Q$crole\E/) { return "refused:d:$crole"; }
         if ($pr{'cr:d'}=~/$crole\&/) {          if ($pr{'cr:d'}=~/\Q$crole\E\&/) {
     if ($pr{'cr:d'}!~/$crole\&\w*$cqual/) {       if ($pr{'cr:d'}!~/\Q$crole\W\&\w*\Q$cqual\E/) { 
                return "refused:d:$crole&$cqual";                  return "refused:d:$crole&$cqual"; 
             }              }
         }          }
     }      }
     foreach (split(':',$courole)) {      foreach (split(':',$courole)) {
  my ($crole,$cqual)=split(/\&/,$_);   my ($crole,$cqual)=split(/\&/,$_);
         if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; }          if ($pr{'cr:c'}!~/\Q$crole\E/) { return "refused:c:$crole"; }
         if ($pr{'cr:c'}=~/$crole\&/) {          if ($pr{'cr:c'}=~/\Q$crole\E\&/) {
     if ($pr{'cr:c'}!~/$crole\&\w*$cqual/) {       if ($pr{'cr:c'}!~/\Q$crole\E\&\w*\Q$cqual\E/) { 
                return "refused:c:$crole&$cqual";                  return "refused:c:$crole&$cqual"; 
             }              }
         }          }
Line 2892  sub log_query { Line 3003  sub log_query {
     my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys %filters));      my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys %filters));
     my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command,      my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command,
                        $uhome);                         $uhome);
     unless ($queryid=~/^$uhost\_/) { return 'error: '.$queryid; }      unless ($queryid=~/^\Q$uhost\E\_/) { return 'error: '.$queryid; }
     return get_query_reply($queryid);      return get_query_reply($queryid);
 }  }
   
Line 3791  sub packages_tab_default { Line 3902  sub packages_tab_default {
     my $packages=&metadata($uri,'packages');      my $packages=&metadata($uri,'packages');
     foreach my $package (split(/,/,$packages)) {      foreach my $package (split(/,/,$packages)) {
  my ($pack_type,$pack_part)=split(/_/,$package,2);   my ($pack_type,$pack_part)=split(/_/,$package,2);
  if ($pack_part eq $part) {   if (defined($packagetab{"$pack_type&$name&default"})) {
     if (defined($packagetab{"$pack_type&$name&default"})) {      return $packagetab{"$pack_type&$name&default"};
  return $packagetab{"$pack_type&$name&default"};   }
     }   if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) {
       return $packagetab{$pack_type."_".$pack_part."&$name&default"};
  }   }
     }      }
     return undef;      return undef;
Line 3824  sub metadata { Line 3936  sub metadata {
     # if it is a non metadata possible uri return quickly      # if it is a non metadata possible uri return quickly
     if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) ||      if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) ||
         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||          ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||
  ($uri =~ m|home/[^/]+/public_html/|)) {   ($uri =~ m|home/[^/]+/public_html/|) || ($uri =~ m|^uploaded/|)) {
  return '';   return undef;
     }      }
     my $filename=$uri;      my $filename=$uri;
     $uri=~s/\.meta$//;      $uri=~s/\.meta$//;
Line 4015  sub metadata_generate_part0 { Line 4127  sub metadata_generate_part0 {
       my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name.        my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name.
      '.display'};       '.display'};
       my $expr='\\[Part: '.$allnames{$name}.'\\]';        my $expr='\\[Part: '.$allnames{$name}.'\\]';
       $olddis=~s/$expr/\[Part: 0\]/;        $olddis=~s/\Q$expr\E/\[Part: 0\]/;
       $$metacache{"$key.display"}=$olddis;        $$metacache{"$key.display"}=$olddis;
     }      }
 }  }
Line 4184  sub symbread { Line 4296  sub symbread {
     my %bighash;      my %bighash;
     my $syval='';      my $syval='';
     if (($ENV{'request.course.fn'}) && ($thisfn)) {      if (($ENV{'request.course.fn'}) && ($thisfn)) {
           my $targetfn = $thisfn;
           if ( ($thisfn =~ m/^uploaded\//) && ($thisfn !~ m/\.(page|sequence)$/) ) {
               $targetfn = 'adm/wrapper/'.$thisfn;
           }
         if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',          if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
                       &GDBM_READER(),0640)) {                        &GDBM_READER(),0640)) {
     $syval=$hash{$thisfn};      $syval=$hash{$targetfn};
             untie(%hash);              untie(%hash);
         }          }
 # ---------------------------------------------------------- There was an entry  # ---------------------------------------------------------- There was an entry
Line 4238  sub symbread { Line 4354  sub symbread {
                  }                   }
       }        }
               untie(%bighash)                untie(%bighash)
            }              }
         }          }
         if ($syval) {          if ($syval) {
            return &symbclean($syval.'___'.$thisfn);              return &symbclean($syval.'___'.$thisfn); 
Line 4373  sub setup_random_from_rndseed { Line 4489  sub setup_random_from_rndseed {
     }      }
 }  }
   
   sub latest_receipt_algorithm_id {
       return 'receipt2';
   }
   
   sub recunique {
       my $fucourseid=shift;
       my $unique;
       if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2') {
    $unique=$ENV{"course.$fucourseid.internal.encseed"};
       } else {
    $unique=$perlvar{'lonReceipt'};
       }
       return unpack("%32C*",$unique);
   }
   
   sub recprefix {
       my $fucourseid=shift;
       my $prefix;
       if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2') {
    $prefix=$ENV{"course.$fucourseid.internal.encpref"};
       } else {
    $prefix=$perlvar{'lonHostID'};
       }
       return unpack("%32C*",$prefix);
   }
   
 sub ireceipt {  sub ireceipt {
     my ($funame,$fudom,$fucourseid,$fusymb)=@_;      my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_;
     my $cuname=unpack("%32C*",$funame);      my $cuname=unpack("%32C*",$funame);
     my $cudom=unpack("%32C*",$fudom);      my $cudom=unpack("%32C*",$fudom);
     my $cucourseid=unpack("%32C*",$fucourseid);      my $cucourseid=unpack("%32C*",$fucourseid);
     my $cusymb=unpack("%32C*",$fusymb);      my $cusymb=unpack("%32C*",$fusymb);
     my $cunique=unpack("%32C*",$perlvar{'lonReceipt'});      my $cunique=&recunique($fucourseid);
     return unpack("%32C*",$perlvar{'lonHostID'}).'-'.      my $cpart=unpack("%32S*",$part);
            ($cunique%$cuname+      my $return =&recprefix($fucourseid).'-';
             $cunique%$cudom+      if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2' ||
             $cusymb%$cuname+   $ENV{'request.state'} eq 'construct') {
             $cusymb%$cudom+   &Apache::lonxml::debug("doing receipt2  using parts $cpart, uname $cuname and udom $cudom gets  ".($cpart%$cuname).
             $cucourseid%$cuname+         " and ".($cpart%$cudom));
             $cucourseid%$cudom);         
    $return.= ($cunique%$cuname+
      $cunique%$cudom+
      $cusymb%$cuname+
      $cusymb%$cudom+
      $cucourseid%$cuname+
      $cucourseid%$cudom+
      $cpart%$cuname+
      $cpart%$cudom);
       } else {
    $return.= ($cunique%$cuname+
      $cunique%$cudom+
      $cusymb%$cuname+
      $cusymb%$cudom+
      $cucourseid%$cuname+
      $cucourseid%$cudom);
       }
       return $return;
 }  }
   
 sub receipt {  sub receipt {
   my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser();      my ($part)=@_;
   return &ireceipt($name,$domain,$courseid,$symb);      my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser();
       return &ireceipt($name,$domain,$courseid,$symb,$part);
 }  }
   
 # ------------------------------------------------------------ Serves up a file  # ------------------------------------------------------------ Serves up a file
 # returns either the contents of the file or a -1  # returns either the contents of the file or 
   # -1 if the file doesn't exist
   #
   # if the target is a file that was uploaded via DOCS, 
   # a check will be made to see if a current copy exists on the local server,
   # if it does this will be served, otherwise a copy will be retrieved from
   # the home server for the course and stored in /home/httpd/html/userfiles on
   # the local server.   
   
 sub getfile {  sub getfile {
  my $file=shift;      my ($file,$caller) = @_;
  if ($file=~/^\/*uploaded\//) { # user file  
       if ($file !~ m|^/*uploaded/(\w+)/(\w+)/(.+)$|) {
    # normal file from res space
    &repcopy($file);
           return &readfile($file);
       }
   
       my $info;
       my $cdom = $1;
       my $cnum = $2;
       my $filename = $3;
       my $path = $Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles';
       my ($lwpresp,$rtncode);
       my $localfile = $path.'/'.$cdom.'/'.$cnum.'/'.$filename;
       if (-e "$localfile") {
    my @fileinfo = stat($localfile);
    $lwpresp = &getuploaded('HEAD',$file,$cdom,$cnum,\$info,\$rtncode);
    if ($lwpresp ne 'ok') {
       if ($rtncode eq '404') {
    unlink($localfile);
       }
       return -1;
    }
    if ($info < $fileinfo[9]) {
       return &readfile($localfile);
    }
    $info = '';
    $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode);
    if ($lwpresp ne 'ok') {
       return -1;
    }
       } else {
    $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode);
    if ($lwpresp ne 'ok') {
       return -1;
    }
    my @parts = ($cdom,$cnum); 
    if ($filename =~ m|^(.+)/[^/]+$|) {
       push @parts, split(/\//,$1);
       }
    foreach my $part (@parts) {
       $path .= '/'.$part;
       if (!-e $path) {
    mkdir($path,0770);
       }
    }
       }
       open (FILE,">$localfile");
       print FILE $info;
       close(FILE);
       if ($caller eq 'uploadrep') {
    return 'ok';
       }
       return $info;
   }
   
   sub getuploaded {
       my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
       $uri=~s/^\///;
       $uri = 'http://'.$hostname{ &homeserver($cnum,$cdom)}.'/raw/'.$uri;
     my $ua=new LWP::UserAgent;      my $ua=new LWP::UserAgent;
     my $request=new HTTP::Request('GET',&tokenwrapper($file));      my $request=new HTTP::Request($reqtype,$uri);
     my $response=$ua->request($request);      my $response=$ua->request($request);
     if ($response->is_success()) {      $$rtncode = $response->code;
        return $response->content;      if (! $response->is_success()) {
     } else {    return 'failed';
        return -1;       }      
     }      if ($reqtype eq 'HEAD') {
  } else { # normal file from res space   $$info = &Date::Parse::str2time( $response->header('Last-modified') );
   &repcopy($file);      } elsif ($reqtype eq 'GET') {
   if (! -e $file ) { return -1; };   $$info = $response->content;
   my $fh;      }
   open($fh,"<$file");      return 'ok';
   my $a='';  }
   while (<$fh>) { $a .=$_; }  
   return $a;  sub readfile {
  }      my $file = shift;
       if ( (! -e $file ) || ($file eq '') ) { return -1; };
       my $fh;
       open($fh,"<$file");
       my $a='';
       while (<$fh>) { $a .=$_; }
       return $a;
 }  }
   
 sub filelocation {  sub filelocation {
Line 4428  sub filelocation { Line 4661  sub filelocation {
   } elsif ($file=~/^\/*uploaded/) { # is an uploaded file    } elsif ($file=~/^\/*uploaded/) { # is an uploaded file
     $location=$file;      $location=$file;
   } else {    } else {
     $file=~s/^$perlvar{'lonDocRoot'}//;      $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
     $file=~s:^/*res::;      $file=~s:^/res/:/:;
     if ( !( $file =~ m:^/:) ) {      if ( !( $file =~ m:^/:) ) {
       $location = $dir. '/'.$file;        $location = $dir. '/'.$file;
     } else {      } else {
Line 4438  sub filelocation { Line 4671  sub filelocation {
   }    }
   $location=~s://+:/:g; # remove duplicate /    $location=~s://+:/:g; # remove duplicate /
   while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..    while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..
     while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./
   return $location;    return $location;
 }  }
   
 sub hreflocation {  sub hreflocation {
     my ($dir,$file)=@_;      my ($dir,$file)=@_;
     unless (($file=~/^http:\/\//i) || ($file=~/^\//)) {      unless (($file=~m-^http://-i) || ($file=~m-^/-)) {
        my $finalpath=filelocation($dir,$file);   my $finalpath=filelocation($dir,$file);
        $finalpath=~s/^\/home\/httpd\/html//;   $finalpath=~s-^/home/httpd/html--;
        $finalpath=~s-/home/(\w+)/public_html/-/~$1/-;   $finalpath=~s-^/home/(\w+)/public_html/-/~$1/-;
        return $finalpath;   return $finalpath;
     } else {      } elsif ($file=~m-^/home-) {
        return $file;   $file=~s-^/home/httpd/html--;
    $file=~s-^/home/(\w+)/public_html/-/~$1/-;
    return $file;
       }
       return $file;
   }
   
   sub current_machine_domains {
       my $hostname=$hostname{$perlvar{'lonHostID'}};
       my @domains;
       while( my($id, $name) = each(%hostname)) {
   # &logthis("-$id-$name-$hostname-");
    if ($hostname eq $name) {
       push(@domains,$hostdom{$id});
    }
     }      }
       return @domains;
   }
   
   sub current_machine_ids {
       my $hostname=$hostname{$perlvar{'lonHostID'}};
       my @ids;
       while( my($id, $name) = each(%hostname)) {
   # &logthis("-$id-$name-$hostname-");
    if ($hostname eq $name) {
       push(@ids,$id);
    }
       }
       return @ids;
 }  }
   
 # ------------------------------------------------------------- Declutters URLs  # ------------------------------------------------------------- Declutters URLs
   
 sub declutter {  sub declutter {
     my $thisfn=shift;      my $thisfn=shift;
     $thisfn=~s/^$perlvar{'lonDocRoot'}//;      $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;
     $thisfn=~s/^\///;      $thisfn=~s/^\///;
     $thisfn=~s/^res\///;      $thisfn=~s/^res\///;
     $thisfn=~s/\?.+$//;      $thisfn=~s/\?.+$//;
Line 5393  messages of critical importance should g Line 5654  messages of critical importance should g
   
 =item *  =item *
   
 getfile($file) : returns the entire contents of a file or -1; it  getfile($file,$caller) : two cases - requests for files in /res or in /uploaded.
 properly subscribes to and replicates the file if neccessary.  (a) files in /uploaded
     (i) If a local copy of the file exists - 
         compares modification date of local copy with last-modified date for 
         definitive version stored on home server for course. If local copy is 
         stale, requests a new version from the home server and stores it. 
         If the original has been removed from the home server, then local copy 
         is unlinked.
     (ii) If local copy does not exist -
         requests the file from the home server and stores it. 
     
     If $caller is 'uploadrep':  
       This indicates a call from lonuploadrep.pm (PerlHeaderParserHandler phase)
       for request for files originally uploaded via DOCS. 
        - returns 'ok' if fresh local copy now available, -1 otherwise.
     
     Otherwise:
        This indicates a call from the content generation phase of the request.
        -  returns the entire contents of the file or -1.
        
   (b) files in /res
      - returns the entire contents of a file or -1; 
      it properly subscribes to and replicates the file if neccessary.
   
 =item *  =item *
   
Removed from v.1.459.2.1  
changed lines
  Added in v.1.482

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>