[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.1430 and 1.1460

version 1.1430, 2020/10/20 01:38:12 version 1.1460, 2021/06/15 20:52:28
Line 96  use Cache::Memcached; Line 96  use Cache::Memcached;
 use Digest::MD5;  use Digest::MD5;
 use Math::Random;  use Math::Random;
 use File::MMagic;  use File::MMagic;
   use Net::CIDR;
   use Sys::Hostname::FQDN();
 use LONCAPA qw(:DEFAULT :match);  use LONCAPA qw(:DEFAULT :match);
 use LONCAPA::Configuration;  use LONCAPA::Configuration;
 use LONCAPA::lonmetadata;  use LONCAPA::lonmetadata;
Line 128  our @EXPORT = qw(%env); Line 130  our @EXPORT = qw(%env);
  $logid ++;   $logid ++;
         my $now = time();          my $now = time();
  my $id=$now.'00000'.$$.'00000'.$logid;   my $id=$now.'00000'.$$.'00000'.$logid;
           my $ip = &get_requestor_ip();
         my $logentry = {           my $logentry = { 
                           $id => {                            $id => {
                                    'exe_uname' => $env{'user.name'},                                     'exe_uname' => $env{'user.name'},
                                    'exe_udom'  => $env{'user.domain'},                                     'exe_udom'  => $env{'user.domain'},
                                    'exe_time'  => $now,                                     'exe_time'  => $now,
                                    'exe_ip'    => $ENV{'REMOTE_ADDR'},                                     'exe_ip'    => $ip,
                                    'delflag'   => $delflag,                                     'delflag'   => $delflag,
                                    'logentry'  => $storehash,                                     'logentry'  => $storehash,
                                    'uname'     => $uname,                                     'uname'     => $uname,
Line 738  sub check_for_valid_session { Line 741  sub check_for_valid_session {
     if (ref($userhashref) eq 'HASH') {      if (ref($userhashref) eq 'HASH') {
         $userhashref->{'name'} = $disk_env{'user.name'};          $userhashref->{'name'} = $disk_env{'user.name'};
         $userhashref->{'domain'} = $disk_env{'user.domain'};          $userhashref->{'domain'} = $disk_env{'user.domain'};
           if ($disk_env{'request.role'}) {
               $userhashref->{'role'} = $disk_env{'request.role'};
           }
         $userhashref->{'lti'} = $disk_env{'request.lti.login'};          $userhashref->{'lti'} = $disk_env{'request.lti.login'};
         if ($userhashref->{'lti'}) {          if ($userhashref->{'lti'}) {
             $userhashref->{'ltitarget'} = $disk_env{'request.lti.target'};              $userhashref->{'ltitarget'} = $disk_env{'request.lti.target'};
Line 971  sub userload { Line 977  sub userload {
 # ------------------------------ Find server with least workload from spare.tab  # ------------------------------ Find server with least workload from spare.tab
   
 sub spareserver {  sub spareserver {
     my ($loadpercent,$userloadpercent,$want_server_name,$udom) = @_;      my ($r,$loadpercent,$userloadpercent,$want_server_name,$udom) = @_;
     my $spare_server;      my $spare_server;
     if ($userloadpercent !~ /\d/) { $userloadpercent=0; }      if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
     my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent       my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent 
Line 1016  sub spareserver { Line 1022  sub spareserver {
                 if ($protocol{$spare_server} eq 'https') {                  if ($protocol{$spare_server} eq 'https') {
                     $protocol = $protocol{$spare_server};                      $protocol = $protocol{$spare_server};
                 }                  }
                   my $alias = &Apache::lonnet::use_proxy_alias($r,$spare_server);
                   $hostname = $alias if ($alias ne '');
         $spare_server = $protocol.'://'.$hostname;          $spare_server = $protocol.'://'.$hostname;
             }              }
         }          }
Line 1150  sub check_for_balancer_cookie { Line 1158  sub check_for_balancer_cookie {
     return ($otherserver,$cookie);      return ($otherserver,$cookie);
 }  }
   
   sub updatebalcookie {
       my ($cookie,$balancer,$lastentry)=@_;
       if ($cookie =~ /^($match_domain)\_($match_username)\_[a-f0-9]{32}$/) {
           my ($udom,$uname) = ($1,$2);
           my $uprimary_id = &domain($udom,'primary');
           my $uintdom = &internet_dom($uprimary_id);
           my $intdom = &internet_dom($balancer);
           my $serverhomedom = &host_domain($balancer);
           if (($uintdom ne '') && ($uintdom eq $intdom)) {
               return &reply('updatebalcookie:'.&escape($cookie).':'.&escape($lastentry),$balancer);
           }
       }
       return;
   }
   
 sub delbalcookie {  sub delbalcookie {
     my ($cookie,$balancer) =@_;      my ($cookie,$balancer) =@_;
     if ($cookie =~ /^($match_domain)\_($match_username)\_[a-f0-9]{32}$/) {      if ($cookie =~ /^($match_domain)\_($match_username)\_[a-f0-9]{32}$/) {
Line 1159  sub delbalcookie { Line 1182  sub delbalcookie {
         my $intdom = &internet_dom($balancer);          my $intdom = &internet_dom($balancer);
         my $serverhomedom = &host_domain($balancer);          my $serverhomedom = &host_domain($balancer);
         if (($uintdom ne '') && ($uintdom eq $intdom)) {          if (($uintdom ne '') && ($uintdom eq $intdom)) {
             return &reply("delbalcookie:$cookie",$balancer);              return &reply('delbalcookie:'.&escape($cookie),$balancer);
         }          }
     }      }
 }  }
Line 1428  sub spare_can_host { Line 1451  sub spare_can_host {
             $canhost = 0;              $canhost = 0;
         }          }
     }      }
       if ($canhost) {
           if (ref($defdomdefaults{'offloadoth'}) eq 'HASH') {
               if ($defdomdefaults{'offloadoth'}{$try_server}) {
                   unless (&shared_institution($udom,$try_server)) {
                       $canhost = 0;
                   }
               }
           }
       }
     if (($canhost) && ($uint_dom)) {      if (($canhost) && ($uint_dom)) {
         my @intdoms;          my @intdoms;
         my $internet_names = &get_internet_names($try_server);          my $internet_names = &get_internet_names($try_server);
Line 2138  sub get_dom { Line 2170  sub get_dom {
     }      }
     if ($udom && $uhome && ($uhome ne 'no_host')) {      if ($udom && $uhome && ($uhome ne 'no_host')) {
         my $rep;          my $rep;
         if ($namespace =~ /^enc/) {          if (grep { $_ eq $uhome } &current_machine_ids()) {
             $rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome);              # domain information is hosted on this machine
               my $cmd = 'getdom';
               if ($namespace =~ /^enc/) {
                   $cmd = 'egetdom';
               }
               $rep = &LONCAPA::Lond::get_dom("$cmd:$udom:$namespace:$items");
         } else {          } else {
             $rep=&reply("getdom:$udom:$namespace:$items",$uhome);              if ($namespace =~ /^enc/) {
                   $rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome);
               } else {
                   $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
               }
         }          }
         my %returnhash;          my %returnhash;
         if ($rep eq '' || $rep =~ /^error: 2 /) {          if ($rep eq '' || $rep =~ /^error: 2 /) {
Line 2579  sub get_domain_defaults { Line 2620  sub get_domain_defaults {
                                   'coursedefaults','usersessions',                                    'coursedefaults','usersessions',
                                   'requestauthor','selfenrollment',                                    'requestauthor','selfenrollment',
                                   'coursecategories','ssl','autoenroll',                                    'coursecategories','ssl','autoenroll',
                                   'trust','helpsettings'],$domain);                                    'trust','helpsettings','wafproxy'],$domain);
     my @coursetypes = ('official','unofficial','community','textbook','placement');      my @coursetypes = ('official','unofficial','community','textbook','placement');
     if (ref($domconfig{'defaults'}) eq 'HASH') {      if (ref($domconfig{'defaults'}) eq 'HASH') {
         $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};           $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; 
Line 2672  sub get_domain_defaults { Line 2713  sub get_domain_defaults {
         if (ref($domconfig{'usersessions'}{'offloadnow'}) eq 'HASH') {          if (ref($domconfig{'usersessions'}{'offloadnow'}) eq 'HASH') {
             $domdefaults{'offloadnow'} = $domconfig{'usersessions'}{'offloadnow'};              $domdefaults{'offloadnow'} = $domconfig{'usersessions'}{'offloadnow'};
         }          }
           if (ref($domconfig{'usersessions'}{'offloadoth'}) eq 'HASH') {
               $domdefaults{'offloadoth'} = $domconfig{'usersessions'}{'offloadoth'};
           }
     }      }
     if (ref($domconfig{'selfenrollment'}) eq 'HASH') {      if (ref($domconfig{'selfenrollment'}) eq 'HASH') {
         if (ref($domconfig{'selfenrollment'}{'admin'}) eq 'HASH') {          if (ref($domconfig{'selfenrollment'}{'admin'}) eq 'HASH') {
Line 2739  sub get_domain_defaults { Line 2783  sub get_domain_defaults {
             $domdefaults{'adhocroles'} = $domconfig{'helpsettings'}{'adhoc'};              $domdefaults{'adhocroles'} = $domconfig{'helpsettings'}{'adhoc'};
         }          }
     }      }
       if (ref($domconfig{'wafproxy'}) eq 'HASH') {
           foreach my $item ('ipheader','trusted','vpnint','vpnext','sslopt') {
               if ($domconfig{'wafproxy'}{$item}) {
                   $domdefaults{'waf_'.$item} = $domconfig{'wafproxy'}{$item};
               }
           }
       } 
     &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);      &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);
     return %domdefaults;      return %domdefaults;
 }  }
Line 2803  sub retrieve_instcodes { Line 2854  sub retrieve_instcodes {
 }  }
   
 sub course_portal_url {  sub course_portal_url {
     my ($cnum,$cdom) = @_;      my ($cnum,$cdom,$r) = @_;
     my $chome = &homeserver($cnum,$cdom);      my $chome = &homeserver($cnum,$cdom);
     my $hostname = &hostname($chome);      my $hostname = &hostname($chome);
     my $protocol = $protocol{$chome};      my $protocol = $protocol{$chome};
Line 2813  sub course_portal_url { Line 2864  sub course_portal_url {
     if ($domdefaults{'portal_def'}) {      if ($domdefaults{'portal_def'}) {
         $firsturl = $domdefaults{'portal_def'};          $firsturl = $domdefaults{'portal_def'};
     } else {      } else {
           my $alias = &Apache::lonnet::use_proxy_alias($r,$chome);
           $hostname = $alias if ($alias ne '');
         $firsturl = $protocol.'://'.$hostname;          $firsturl = $protocol.'://'.$hostname;
     }      }
     return $firsturl;      return $firsturl;
Line 3437  sub ssi_body { Line 3490  sub ssi_body {
 # --------------------------------------------------------- Server Side Include  # --------------------------------------------------------- Server Side Include
   
 sub absolute_url {  sub absolute_url {
     my ($host_name) = @_;      my ($host_name,$unalias,$keep_proto) = @_;
     my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');      my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');
     if ($host_name eq '') {      if ($host_name eq '') {
  $host_name = $ENV{'SERVER_NAME'};   $host_name = $ENV{'SERVER_NAME'};
     }      }
       if ($unalias) {
           my $alias = &get_proxy_alias();
           if ($alias eq $host_name) {
               my $lonhost = $perlvar{'lonHostID'};
               my $hostname = &hostname($lonhost);
               my $lcproto; 
               if (($keep_proto) || ($hostname eq '')) {
                   $lcproto = $protocol;
               } else {
                   $lcproto = $protocol{$lonhost};
                   $lcproto = 'http' if ($lcproto ne 'https');
                   $lcproto .= '://';
               }
               unless ($hostname eq '') {
                   return $lcproto.$hostname;
               }
           }
       }
     return $protocol.$host_name;      return $protocol.$host_name;
 }  }
   
Line 3458  sub absolute_url { Line 3529  sub absolute_url {
 sub ssi {  sub ssi {
   
     my ($fn,%form)=@_;      my ($fn,%form)=@_;
     my $request;      my ($host,$request,$response);
       $host = &absolute_url('',1);
   
     $form{'no_update_last_known'}=1;      $form{'no_update_last_known'}=1;
     &Apache::lonenc::check_encrypt(\$fn);      &Apache::lonenc::check_encrypt(\$fn);
     if (%form) {      if (%form) {
       $request=new HTTP::Request('POST',&absolute_url().$fn);        $request=new HTTP::Request('POST',$host.$fn);
       $request->content(join('&',map {         $request->content(join('&',map { 
             my $name = escape($_);              my $name = escape($_);
             "$name=" . ( ref($form{$_}) eq 'ARRAY'               "$name=" . ( ref($form{$_}) eq 'ARRAY' 
Line 3471  sub ssi { Line 3543  sub ssi {
             : &escape($form{$_}) );                  : &escape($form{$_}) );    
         } keys(%form)));          } keys(%form)));
     } else {      } else {
       $request=new HTTP::Request('GET',&absolute_url().$fn);        $request=new HTTP::Request('GET',$host.$fn);
     }      }
   
     $request->header(Cookie => $ENV{'HTTP_COOKIE'});      $request->header(Cookie => $ENV{'HTTP_COOKIE'});
Line 3485  sub ssi { Line 3557  sub ssi {
                                  ($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:'')))) {                                   ($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:'')))) {
         $islocal = 1;          $islocal = 1;
     }      }
     my $response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,      $response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,
                                                 '','','',$islocal);                                               '','','',$islocal);
   
     if (wantarray) {      if (wantarray) {
  return ($response->content, $response);   return ($response->content, $response);
Line 4029  sub clean_filename { Line 4101  sub clean_filename {
 # Replace all .\d. sequences with _\d. so they no longer look like version  # Replace all .\d. sequences with _\d. so they no longer look like version
 # numbers  # numbers
     $fname=~s/\.(\d+)(?=\.)/_$1/g;      $fname=~s/\.(\d+)(?=\.)/_$1/g;
   # Replace three or more adjacent underscores with one for consistency 
   # with loncfile::filename_check() so complete url can be extracted by
   # lonnet::decode_symb()
       $fname=~s/_{3,}/_/g;
     return $fname;      return $fname;
 }  }
   
Line 4999  sub courseacclog { Line 5075  sub courseacclog {
                 if ($formitem =~ /^HWFILE(?:SIZE|TOOBIG)/) {                  if ($formitem =~ /^HWFILE(?:SIZE|TOOBIG)/) {
                     $what.=':'.$formitem.'='.$env{$key};                      $what.=':'.$formitem.'='.$env{$key};
                 } elsif ($formitem !~ /^HWFILE(?:[^.]+)$/) {                  } elsif ($formitem !~ /^HWFILE(?:[^.]+)$/) {
                     $what.=':'.$formitem.'='.$env{$key};                      if ($formitem eq 'proctorpassword') {
                           $what.=':'.$formitem.'=' . '*' x length($env{$key});
                       } else {
                           $what.=':'.$formitem.'='.$env{$key};
                       }
                 }                  }
             }              }
         }          }
Line 6081  sub tmpreset { Line 6161  sub tmpreset {
   if (!$domain) { $domain=$env{'user.domain'}; }    if (!$domain) { $domain=$env{'user.domain'}; }
   if (!$stuname) { $stuname=$env{'user.name'}; }    if (!$stuname) { $stuname=$env{'user.name'}; }
   if ($domain eq 'public' && $stuname eq 'public') {    if ($domain eq 'public' && $stuname eq 'public') {
       $stuname=$ENV{'REMOTE_ADDR'};        $stuname=&get_requestor_ip();
   }    }
   my $path=LONCAPA::tempdir();    my $path=LONCAPA::tempdir();
   my %hash;    my %hash;
Line 6118  sub tmpstore { Line 6198  sub tmpstore {
   if (!$domain) { $domain=$env{'user.domain'}; }    if (!$domain) { $domain=$env{'user.domain'}; }
   if (!$stuname) { $stuname=$env{'user.name'}; }    if (!$stuname) { $stuname=$env{'user.name'}; }
   if ($domain eq 'public' && $stuname eq 'public') {    if ($domain eq 'public' && $stuname eq 'public') {
       $stuname=$ENV{'REMOTE_ADDR'};        $stuname=&get_requestor_ip();
   }    }
   my $now=time;    my $now=time;
   my %hash;    my %hash;
Line 6162  sub tmprestore { Line 6242  sub tmprestore {
   if (!$domain) { $domain=$env{'user.domain'}; }    if (!$domain) { $domain=$env{'user.domain'}; }
   if (!$stuname) { $stuname=$env{'user.name'}; }    if (!$stuname) { $stuname=$env{'user.name'}; }
   if ($domain eq 'public' && $stuname eq 'public') {    if ($domain eq 'public' && $stuname eq 'public') {
       $stuname=$ENV{'REMOTE_ADDR'};        $stuname=&get_requestor_ip();
   }    }
   my %returnhash;    my %returnhash;
   $namespace=~s/\//\_/g;    $namespace=~s/\//\_/g;
Line 6218  sub store { Line 6298  sub store {
     }      }
     if (!$home) { $home=$env{'user.home'}; }      if (!$home) { $home=$env{'user.home'}; }
   
     $$storehash{'ip'}=$ENV{'REMOTE_ADDR'};      $$storehash{'ip'}=&get_requestor_ip();
     $$storehash{'host'}=$perlvar{'lonHostID'};      $$storehash{'host'}=$perlvar{'lonHostID'};
   
     my $namevalue='';      my $namevalue='';
Line 6254  sub cstore { Line 6334  sub cstore {
     }      }
     if (!$home) { $home=$env{'user.home'}; }      if (!$home) { $home=$env{'user.home'}; }
   
     $$storehash{'ip'}=$ENV{'REMOTE_ADDR'};      $$storehash{'ip'}=&get_requestor_ip();
     $$storehash{'host'}=$perlvar{'lonHostID'};      $$storehash{'host'}=$perlvar{'lonHostID'};
   
     my $namevalue='';      my $namevalue='';
Line 7249  sub putstore { Line 7329  sub putstore {
        foreach my $key (keys(%{$storehash})) {         foreach my $key (keys(%{$storehash})) {
            $namevalue.=&escape($key).'='.&freeze_escape($storehash->{$key}).'&';             $namevalue.=&escape($key).'='.&freeze_escape($storehash->{$key}).'&';
        }         }
        $namevalue .= 'ip='.&escape($ENV{'REMOTE_ADDR'}).         my $ip = &get_requestor_ip();
          $namevalue .= 'ip='.&escape($ip).
                      '&host='.&escape($perlvar{'lonHostID'}).                       '&host='.&escape($perlvar{'lonHostID'}).
                      '&version='.$esc_v.                       '&version='.$esc_v.
                      '&by='.&escape($env{'user.name'}.':'.$env{'user.domain'});                       '&by='.&escape($env{'user.name'}.':'.$env{'user.domain'});
Line 8053  sub allowed { Line 8134  sub allowed {
   
     if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }      if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }
 # Free bre access to adm and meta resources  # Free bre access to adm and meta resources
     if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard|ext\.tool)$}))       if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard|viewclasslist|aboutme|ext\.tool)$})) 
  || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) ))    || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) 
  && ($priv eq 'bre')) {   && ($priv eq 'bre')) {
  return 'F';   return 'F';
Line 8162  sub allowed { Line 8243  sub allowed {
                         my $adom = $1;                          my $adom = $1;
                         foreach my $key (keys(%env)) {                          foreach my $key (keys(%env)) {
                             if ($key =~ m{^user\.role\.(ca|aa)/\Q$adom\E}) {                              if ($key =~ m{^user\.role\.(ca|aa)/\Q$adom\E}) {
                                 my ($start,$end) = split('.',$env{$key});                                  my ($start,$end) = split(/\./,$env{$key});
                                 if (($now >= $start) && (!$end || $end < $now)) {                                  if (($now >= $start) && (!$end || $end > $now)) {
                                     $ownaccess = 1;                                      $ownaccess = 1;
                                     last;                                      last;
                                 }                                  }
Line 8175  sub allowed { Line 8256  sub allowed {
                         foreach my $role ('ca','aa') {                           foreach my $role ('ca','aa') { 
                             if ($env{"user.role.$role./$adom/$aname"}) {                              if ($env{"user.role.$role./$adom/$aname"}) {
                                 my ($start,$end) =                                  my ($start,$end) =
                                     split('.',$env{"user.role.$role./$adom/$aname"});                                      split(/\./,$env{"user.role.$role./$adom/$aname"});
                                 if (($now >= $start) && (!$end || $end < $now)) {                                  if (($now >= $start) && (!$end || $end > $now)) {
                                     $ownaccess = 1;                                      $ownaccess = 1;
                                     last;                                      last;
                                 }                                  }
Line 8360  sub allowed { Line 8441  sub allowed {
                =~/\Q$priv\E\&([^\:]*)/) {                 =~/\Q$priv\E\&([^\:]*)/) {
                my $value = $1;                 my $value = $1;
                if ($priv eq 'bre') {                 if ($priv eq 'bre') {
                    if ($noblockcheck) {                     my $deeplinkblock = &deeplink_check($priv,$symb,$uri);
                      if ($deeplinkblock) {
                          $thisallowed = 'D';
                      } elsif ($noblockcheck) {
                        $thisallowed.=$value;                         $thisallowed.=$value;
                    } else {                     } else {
                        my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);                         my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);
Line 8450  sub allowed { Line 8534  sub allowed {
 #  #
   
 # Possibly locked functionality, check all courses  # Possibly locked functionality, check all courses
   # In roles.tab, L (unless locked) available for bre, pch, plc, pac and sma.
 # Locks might take effect only after 10 minutes cache expiration for other  # Locks might take effect only after 10 minutes cache expiration for other
 # courses, and 2 minutes for current course  # courses, and 2 minutes for current course, in which user has st or ta role
   # which is neither expired nor a future role (unless current course).
   
     my $envkey;      my ($needlockcheck,$now,$crsonly);
     if ($thisallowed=~/L/) {      if ($thisallowed=~/L/) {
         foreach $envkey (keys(%env)) {          $now = time;
           if ($priv eq 'bre') {
               if ($uri ne '') {
                   if ($orguri =~ m{^/+res/}) {
                       if ($uri =~ m{^lib/templates/}) {
                           if ($env{'request.course.id'}) {
                               $crsonly = 1;
                               $needlockcheck = 1;
                           }
                       } else {
                           $needlockcheck = 1;
                       }
                   } elsif ($env{'request.course.id'}) {
                       my ($crsdom,$crsnum) = split('_',$env{'request.course.id'});
                       if (($uri =~ m{^(adm|uploaded|public)/$crsdom/$crsnum/}) ||
                           ($uri =~ m{^adm/$match_domain/$match_username/\d+/(smppg|bulletinboard)$})) {
                           $crsonly = 1;
                       }
                       $needlockcheck = 1;
                   }
               }
           } elsif (($priv eq 'pch') || ($priv eq 'plc') || ($priv eq 'pac') || ($priv eq 'sma')) {
               $needlockcheck = 1;
           }
       }
       if ($needlockcheck) {
           foreach my $envkey (keys(%env)) {
            if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {             if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {
                my $courseid=$2;                 my $courseid=$2;
                my $roleid=$1.'.'.$2;                 my $roleid=$1.'.'.$2;
                $courseid=~s/^\///;                 $courseid=~s/^\///;
                  unless ($env{'request.role'} eq $roleid) {
                      my ($start,$end) = split(/\./,$env{$envkey});
                      next unless (($now >= $start) && (!$end || $end > $now));
                  }
                my $expiretime=600;                 my $expiretime=600;
                if ($env{'request.role'} eq $roleid) {                 if ($env{'request.role'} eq $roleid) {
   $expiretime=120;    $expiretime=120;
Line 8482  sub allowed { Line 8598  sub allowed {
                }                 }
                if (($env{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/)                 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{$prefix.'priv.'.$priv.'.lock.expire'}>time) {
                        &log($env{'user.domain'},$env{'user.name'},                         &log($env{'user.domain'},$env{'user.name'},
                             $env{'user.home'},                              $env{'user.home'},
                             'Locked by priv: '.$priv.' for '.$uri.' due to '.                              'Locked by priv: '.$priv.' for '.$uri.' due to '.
Line 8949  sub deeplink_check { Line 9065  sub deeplink_check {
                         if ($symb eq $login) {                          if ($symb eq $login) {
                             $allow = 1;                              $allow = 1;
                         }                          }
                     } elsif ($scope eq 'map') {                      } elsif (($scope eq 'map') || ($scope eq 'rec')) {
 #FIXME Compare map for $env{'request.deeplink.login'} with map for $symb                          my ($map_from_symb) = &deversion((&decode_symb($symb))[0]);
                     } elsif ($scope eq 'rec') {                          my ($map_from_login) = &deversion((&decode_symb($login))[0]);
 #FIXME Recurse up for $env{'request.deeplink.login'} with map for $symb                          if (($map_from_symb) && ($map_from_login)) {
                               if ($map_from_symb eq $map_from_login) {
                                   $allow = 1;
                               } elsif ($scope eq 'rec') {
                                   my @recurseup = &get_map_hierarchy($map_from_symb,$env{'request.course.id'});
                                   if (grep(/^\Q$map_from_login\E$/,@recurseup)) {
                                       $allow = 1;
                                   }
                               }
                           }
                     }                      }
                 } else {                  } else {
                     my ($acctype,$item) = split(/:/,$access);                      my ($acctype,$item) = split(/:/,$access);
Line 9373  sub auto_validate_instcode { Line 9498  sub auto_validate_instcode {
     return ($outcome,$description,$defaultcredits);      return ($outcome,$description,$defaultcredits);
 }  }
   
   sub auto_validate_inst_crosslist {
       my ($cnum,$cdom,$instcode,$inst_xlist,$coowner) = @_;
       my ($homeserver,$response);
       if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) {
           $homeserver = &homeserver($cnum,$cdom);
       }
       if (!defined($homeserver)) {
           if ($cdom =~ /^$match_domain$/) {
               $homeserver = &domain($cdom,'primary');
           }
       }
       unless (($homeserver eq '') || ($homeserver eq 'no_host')) {
           $response=&reply('autovalidateinstcrosslist:'.$cdom.':'.
                            &escape($instcode).':'.&escape($inst_xlist).':'.
                            &escape($coowner),$homeserver);
       }
       return $response;
   }
   
 sub auto_create_password {  sub auto_create_password {
     my ($cnum,$cdom,$authparam,$udom) = @_;      my ($cnum,$cdom,$authparam,$udom) = @_;
     my ($homeserver,$response);      my ($homeserver,$response);
Line 9644  sub auto_validate_class_sec { Line 9788  sub auto_validate_class_sec {
     return $response;      return $response;
 }  }
   
   sub auto_instsec_reformat {
       my ($cdom,$action,$instsecref) = @_;
       return unless(($action eq 'clutter') || ($action eq 'declutter'));
       my @homeservers;
       if (defined(&domain($cdom,'primary'))) {
           push(@homeservers,&domain($cdom,'primary'));
       } else {
           my %servers = &get_servers($cdom,'library');
           foreach my $tryserver (keys(%servers)) {
               if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
                   push(@homeservers,$tryserver);
               }
           }
       }
       my $response;
       my %reformatted = %{$instsecref};
       foreach my $server (@homeservers) {
           if (ref($instsecref) eq 'HASH') {
               my $info = &freeze_escape($instsecref);
               my $response=&reply('autoinstsecreformat:'.$cdom.':'.
                                   $action.':'.$info,$server);
               next if ($response =~ /(con_lost|error|no_such_host|refused|unknown_command)/);
               my @items = split(/&/,$response);
               foreach my $item (@items) {
                   my ($key,$value) = split(/=/,$item);
                   $reformatted{&unescape($key)} = &thaw_unescape($value);
               }
           }
       }
       return %reformatted;
   }
   
 sub auto_validate_instclasses {  sub auto_validate_instclasses {
     my ($cdom,$cnum,$owners,$classesref) = @_;      my ($cdom,$cnum,$owners,$classesref) = @_;
     my ($homeserver,%validations);      my ($homeserver,%validations);
Line 10194  sub autoupdate_coowners { Line 10370  sub autoupdate_coowners {
         if ($domdesign{$cdom.'.autoassign.co-owners'}) {          if ($domdesign{$cdom.'.autoassign.co-owners'}) {
             my %coursehash = &coursedescription($cdom.'_'.$cnum);              my %coursehash = &coursedescription($cdom.'_'.$cnum);
             my $instcode = $coursehash{'internal.coursecode'};              my $instcode = $coursehash{'internal.coursecode'};
               my $xlists = $coursehash{'internal.crosslistings'};
             if ($instcode ne '') {              if ($instcode ne '') {
                 if (($start && $start <= $now) && ($end == 0) || ($end > $now)) {                  if (($start && $start <= $now) && ($end == 0) || ($end > $now)) {
                     unless ($coursehash{'internal.courseowner'} eq $uname.':'.$udom) {                      unless ($coursehash{'internal.courseowner'} eq $uname.':'.$udom) {
                         my ($delcoowners,@newcoowners,$putresult,$delresult,$coowners);                          my ($delcoowners,@newcoowners,$putresult,$delresult,$coowners);
                         my ($result,$desc) = &auto_validate_instcode($cnum,$cdom,$instcode,$uname.':'.$udom);                          my ($result,$desc) = &auto_validate_instcode($cnum,$cdom,$instcode,$uname.':'.$udom);
                           unless ($result eq 'valid') {
                               if ($xlists ne '') {
                                   foreach my $xlist (split(',',$xlists)) {
                                       my ($inst_crosslist,$lcsec) = split(':',$xlist);
                                       $result =
                                           &auto_validate_inst_crosslist($cnum,$cdom,$instcode,
                                                                         $inst_crosslist,$uname.':'.$udom);
                                       last if ($result eq 'valid');
                                   }
                               }
                           }
                         if ($result eq 'valid') {                          if ($result eq 'valid') {
                             if ($coursehash{'internal.co-owners'}) {                              if ($coursehash{'internal.co-owners'}) {
                                 foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {                                  foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {
Line 10211  sub autoupdate_coowners { Line 10399  sub autoupdate_coowners {
                             } else {                              } else {
                                 push(@newcoowners,$uname.':'.$udom);                                  push(@newcoowners,$uname.':'.$udom);
                             }                              }
                         } else {                          } elsif ($coursehash{'internal.co-owners'}) {
                             if ($coursehash{'internal.co-owners'}) {                              foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {
                                 foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {                                  unless ($coowner eq $uname.':'.$udom) {
                                     unless ($coowner eq $uname.':'.$udom) {                                      push(@newcoowners,$coowner);
                                         push(@newcoowners,$coowner);  
                                     }  
                                 }  
                                 unless (@newcoowners > 0) {  
                                     $delcoowners = 1;  
                                     $coowners = '';  
                                 }                                  }
                             }                              }
                               unless (@newcoowners > 0) {
                                   $delcoowners = 1;
                                   $coowners = '';
                               }
                         }                          }
                         if (@newcoowners || $delcoowners) {                          if (@newcoowners || $delcoowners) {
                             &store_coowners($cdom,$cnum,$coursehash{'home'},                              &store_coowners($cdom,$cnum,$coursehash{'home'},
Line 10296  sub modifyuserauth { Line 10482  sub modifyuserauth {
              ' in domain '.$env{'request.role.domain'});                 ' in domain '.$env{'request.role.domain'});  
     my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.      my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.
      &escape($upass),$uhome);       &escape($upass),$uhome);
       my $ip = &get_requestor_ip();
     &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},      &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},
         'Authentication changed for '.$udom.', '.$uname.', '.$umode.          'Authentication changed for '.$udom.', '.$uname.', '.$umode.
          '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);           '(Remote '.$ip.'): '.$reply);
     &log($udom,,$uname,$uhome,      &log($udom,,$uname,$uhome,
         'Authentication changed by '.$env{'user.domain'}.', '.          'Authentication changed by '.$env{'user.domain'}.', '.
                                      $env{'user.name'}.', '.$umode.                                       $env{'user.name'}.', '.$umode.
          '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);           '(Remote '.$ip.'): '.$reply);
     unless ($reply eq 'ok') {      unless ($reply eq 'ok') {
         &logthis('Authentication mode error: '.$reply);          &logthis('Authentication mode error: '.$reply);
  return 'error: '.$reply;   return 'error: '.$reply;
Line 10828  sub store_userdata { Line 11015  sub store_userdata {
             if (($uhome eq '') || ($uhome eq 'no_host')) {              if (($uhome eq '') || ($uhome eq 'no_host')) {
                 $result = 'error: no_host';                  $result = 'error: no_host';
             } else {              } else {
                 $storehash->{'ip'} = $ENV{'REMOTE_ADDR'};                  $storehash->{'ip'} = &get_requestor_ip();
                 $storehash->{'host'} = $perlvar{'lonHostID'};                  $storehash->{'host'} = $perlvar{'lonHostID'};
   
                 my $namevalue='';                  my $namevalue='';
Line 12377  sub EXT { Line 12564  sub EXT {
         }          }
     } elsif ($realm eq 'client') {      } elsif ($realm eq 'client') {
         if ($space eq 'remote_addr') {          if ($space eq 'remote_addr') {
             return $ENV{'REMOTE_ADDR'};              return &get_requestor_ip();
         }          }
     }      }
     return '';      return '';
Line 14187  sub default_login_domain { Line 14374  sub default_login_domain {
 }  }
   
 sub shared_institution {  sub shared_institution {
     my ($dom) = @_;      my ($dom,$lonhost) = @_;
       if ($lonhost eq '') {
           $lonhost = $perlvar{'lonHostID'};
       }
     my $same_intdom;      my $same_intdom;
     my $hostintdom = &internet_dom($perlvar{'lonHostID'});      my $hostintdom = &internet_dom($lonhost);
     if ($hostintdom ne '') {      if ($hostintdom ne '') {
         my %iphost = &get_iphost();          my %iphost = &get_iphost();
         my $primary_id = &domain($dom,'primary');          my $primary_id = &domain($dom,'primary');
Line 14245  sub uses_sts { Line 14435  sub uses_sts {
     return;      return;
 }  }
   
   sub waf_allssl {
       my ($host_name) = @_;
       my $alias = &get_proxy_alias();
       if ($host_name eq '') {
           $host_name = $ENV{'SERVER_NAME'};
       }
       if (($host_name ne '') && ($alias eq $host_name)) {
           my $serverhomedom = &host_domain($perlvar{'lonHostID'});
           my %defdomdefaults = &get_domain_defaults($serverhomedom);
           if ($defdomdefaults{'waf_sslopt'}) {
               return $defdomdefaults{'waf_sslopt'};
           }
       }
       return;
   }
   
   sub get_requestor_ip {
       my ($r,$nolookup,$noproxy) = @_;
       my $from_ip;
       if (ref($r)) {
           if ($r->can('useragent_ip')) {
               if ($noproxy && $r->can('client_ip')) {
                   $from_ip = $r->client_ip();
               } else {
                   $from_ip = $r->useragent_ip();
               }
           } elsif ($r->connection->can('remote_ip')) {
               $from_ip = $r->connection->remote_ip();
           } else {
               $from_ip = $r->get_remote_host($nolookup);
           }
       } else {
           $from_ip = $ENV{'REMOTE_ADDR'};
       }
       return $from_ip if ($noproxy); 
       # Who controls proxy settings for server
       my $dom_in_use = $Apache::lonnet::perlvar{'lonDefDomain'};
       my $proxyinfo = &get_proxy_settings($dom_in_use);
       if ((ref($proxyinfo) eq 'HASH') && ($from_ip)) {
           if ($proxyinfo->{'vpnint'}) {
               if (&ip_match($from_ip,$proxyinfo->{'vpnint'})) {
                   return $from_ip;
               }
           }
           if ($proxyinfo->{'trusted'}) {
               if (&ip_match($from_ip,$proxyinfo->{'trusted'})) {
                   my $ipheader = $proxyinfo->{'ipheader'};
                   my ($ip,$xfor);
                   if (ref($r)) {
                       if ($ipheader) {
                           $ip = $r->headers_in->{$ipheader};
                       }
                       $xfor = $r->headers_in->{'X-Forwarded-For'};
                   } else {
                       if ($ipheader) {
                           $ip = $ENV{'HTTP_'.uc($ipheader)};
                       }
                       $xfor = $ENV{'HTTP_X_FORWARDED_FOR'};
                   }
                   if (($ip eq '') && ($xfor ne '')) {
                       foreach my $poss_ip (reverse(split(/\s*,\s*/,$xfor))) {
                           unless (&ip_match($poss_ip,$proxyinfo->{'trusted'})) {
                               $ip = $poss_ip;
                               last;
                           }
                       }
                   }
                   if ($ip ne '') {
                       return $ip;
                   }
               }
           }
       }
       return $from_ip;
   }
   
   sub get_proxy_settings {
       my ($dom_in_use) = @_;
       my %domdefaults = &Apache::lonnet::get_domain_defaults($dom_in_use);
       my $proxyinfo = {
                          ipheader => $domdefaults{'waf_ipheader'},
                          trusted  => $domdefaults{'waf_trusted'},
                          vpnint   => $domdefaults{'waf_vpnint'},
                          vpnext   => $domdefaults{'waf_vpnext'},
                          sslopt   => $domdefaults{'waf_sslopt'},
                       };
       return $proxyinfo;
   }
   
   sub ip_match {
       my ($ip,$pattern_str) = @_;
       $ip=Net::CIDR::cidrvalidate($ip);
       if ($ip) {
           return Net::CIDR::cidrlookup($ip,split(/\s*,\s*/,$pattern_str));
       }
       return;
   }
   
   sub get_proxy_alias {
       my ($lonid) = @_;
       if ($lonid eq '') {
           $lonid = $perlvar{'lonHostID'};
       }
       if (!defined(&hostname($lonid))) {
           return;
       }
       if ($lonid ne '') {
           my ($alias,$cached) = &is_cached_new('proxyalias',$lonid);
           if ($cached) {
               return $alias;
           }
           my $dom = &Apache::lonnet::host_domain($lonid);
           if ($dom ne '') {
               my $cachetime = 60*60*24;
               my %domconfig =
                   &Apache::lonnet::get_dom('configuration',['wafproxy'],$dom);
               my $alias;
               if (ref($domconfig{'wafproxy'}) eq 'HASH') {
                   if (ref($domconfig{'wafproxy'}{'alias'}) eq 'HASH') {
                       $alias = $domconfig{'wafproxy'}{'alias'}{$lonid};
                   }
               }
               return &do_cache_new('proxyalias',$lonid,$alias,$cachetime);
           }
       }
       return;
   }
   
   sub use_proxy_alias {
       my ($r,$lonid) = @_;
       my $alias = &get_proxy_alias($lonid);
       if ($alias) {
           my $dom = &host_domain($lonid);
           if ($dom ne '') {
               my $proxyinfo = &get_proxy_settings($dom );
               my ($vpnint,$remote_ip);
               if (ref($proxyinfo) eq 'HASH') {
                   $vpnint = $proxyinfo->{'vpnint'};
                   if ($vpnint) {
                       $remote_ip = &get_requestor_ip($r,1,1);
                   }
               }
               unless ($vpnint && &ip_match($remote_ip,$vpnint)) {
                   return $alias;
               }
           }
       }
       return;
   }
   
 # ------------------------------------------------------------- Declutters URLs  # ------------------------------------------------------------- Declutters URLs
   
 sub declutter {  sub declutter {
Line 14384  sub get_dns { Line 14724  sub get_dns {
     }      }
     while (%alldns) {      while (%alldns) {
  my ($dns) = sort { $b cmp $a } keys(%alldns);   my ($dns) = sort { $b cmp $a } keys(%alldns);
  my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");          my ($contents,@content);
         my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar,30,0);          if ($dns eq Sys::Hostname::FQDN::fqdn()) {
         delete($alldns{$dns});              my $command = (split('/',$url))[3];
  next if ($response->is_error());              my ($dir,$file) = &parse_getdns_url($command,$url);
               delete($alldns{$dns});
               next if (($dir eq '') || ($file eq ''));
               if (open(my $config,'<',"$dir/$file")) {
                   @content = <$config>;
                   close($config);
               }
               if ($url eq '/adm/dns/loncapaCRL') {
                   $contents = join('',@content);
               }
           } else {
       my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
               my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar,30,0);
               delete($alldns{$dns});
       next if ($response->is_error());
               if ($url eq '/adm/dns/loncapaCRL') {
                   $contents = $response->content;
               } else {
                   @content = split("\n",$response->content);
               }
           }
         if ($url eq '/adm/dns/loncapaCRL') {          if ($url eq '/adm/dns/loncapaCRL') {
             return &$func($response);              return &$func($contents);
         } else {          } else {
     my @content = split("\n",$response->content);  
     unless ($nocache) {      unless ($nocache) {
         &do_cache_new('dns',$url,\@content,30*24*60*60);          &do_cache_new('dns',$url,\@content,30*24*60*60);
     }      }
Line 14479  sub fetch_crl_pemfile { Line 14838  sub fetch_crl_pemfile {
 }  }
   
 sub save_crl_pem {  sub save_crl_pem {
     my ($response) = @_;      my ($content) = @_;
     my ($msg,$hadchanges);      my ($msg,$hadchanges);
     if (ref($response)) {      if ($content ne '') {
         my $now = time;          my $now = time;
         my $lonca = $perlvar{'lonCertificateDirectory'}.'/'.$perlvar{'lonnetCertificateAuthority'};          my $lonca = $perlvar{'lonCertificateDirectory'}.'/'.$perlvar{'lonnetCertificateAuthority'};
         my $tmpcrl = $tmpdir.'/'.$perlvar{'lonnetCertRevocationList'}.'_'.$now.'.'.$$.'.tmp';          my $tmpcrl = $tmpdir.'/'.$perlvar{'lonnetCertRevocationList'}.'_'.$now.'.'.$$.'.tmp';
         if (open(my $fh,'>',"$tmpcrl")) {          if (open(my $fh,'>',"$tmpcrl")) {
             print $fh $response->content;              print $fh $content;
             close($fh);              close($fh);
             if (-e $lonca) {              if (-e $lonca) {
                 if (open(PIPE,"openssl crl -in $tmpcrl -inform pem -CAfile $lonca -noout 2>&1 |")) {                  if (open(PIPE,"openssl crl -in $tmpcrl -inform pem -CAfile $lonca -noout 2>&1 |")) {
Line 14547  sub save_crl_pem { Line 14906  sub save_crl_pem {
     return ($msg,$hadchanges);      return ($msg,$hadchanges);
 }  }
   
   sub parse_getdns_url {
       my ($command,$url) = @_;
       my $dir = $perlvar{'lonTabDir'};
       my $file;
       if ($command eq 'hosts') {
           $file = 'dns_hosts.tab';
       } elsif ($command eq 'domain') {
           $file = 'dns_domain.tab';
       } elsif ($command eq 'checksums') {
           my $version = (split('/',$url))[4];
           $file = "dns_checksums/$version.tab",
       } elsif ($command eq 'loncapaCRL') {
           $dir = $perlvar{'lonCertificateDirectory'};
           $file = $perlvar{'lonnetCertRevocationList'};
       }
       return ($dir,$file);
   }
   
 # ------------------------------------------------------------ Read domain file  # ------------------------------------------------------------ Read domain file
 {  {
     my $loaded;      my $loaded;
Removed from v.1.1430  
changed lines
  Added in v.1.1460

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