[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.1447 and 1.1453

version 1.1447, 2021/04/18 02:08:47 version 1.1453, 2021/05/10 18:13:50
Line 740  sub check_for_valid_session { Line 740  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 973  sub userload { Line 976  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 1018  sub spareserver { Line 1021  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 2778  sub get_domain_defaults { Line 2783  sub get_domain_defaults {
         }          }
     }      }
     if (ref($domconfig{'wafproxy'}) eq 'HASH') {      if (ref($domconfig{'wafproxy'}) eq 'HASH') {
         foreach my $item ('ipheader','trusted','vpnint','vpnext') {          foreach my $item ('ipheader','trusted','vpnint','vpnext','sslopt') {
             if ($domconfig{'wafproxy'}{$item}) {              if ($domconfig{'wafproxy'}{$item}) {
                 $domdefaults{'waf_'.$item} = $domconfig{'wafproxy'}{$item};                  $domdefaults{'waf_'.$item} = $domconfig{'wafproxy'}{$item};
             }              }
Line 2848  sub retrieve_instcodes { Line 2853  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 2858  sub course_portal_url { Line 2863  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 8235  sub allowed { Line 8242  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 8248  sub allowed { Line 8255  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 8526  sub allowed { Line 8533  sub allowed {
 # 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
   
     my $envkey;  
     if ($thisallowed=~/L/) {      if ($thisallowed=~/L/) {
         foreach $envkey (keys(%env)) {          my $now = time;
           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 14351  sub uses_sts { Line 14362  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 {  sub get_requestor_ip {
     my ($r,$nolookup,$noproxy) = @_;      my ($r,$nolookup,$noproxy) = @_;
     my $from_ip;      my $from_ip;
Line 14419  sub get_proxy_settings { Line 14446  sub get_proxy_settings {
                        trusted  => $domdefaults{'waf_trusted'},                         trusted  => $domdefaults{'waf_trusted'},
                        vpnint   => $domdefaults{'waf_vpnint'},                         vpnint   => $domdefaults{'waf_vpnint'},
                        vpnext   => $domdefaults{'waf_vpnext'},                         vpnext   => $domdefaults{'waf_vpnext'},
                          sslopt   => $domdefaults{'waf_sslopt'},
                     };                      };
     return $proxyinfo;      return $proxyinfo;
 }  }
Line 14433  sub ip_match { Line 14461  sub ip_match {
 }  }
   
 sub get_proxy_alias {  sub get_proxy_alias {
     my $lonhost = $perlvar{'lonHostID'};      my ($lonid) = @_;
     if ($lonhost ne '') {      if ($lonid eq '') {
         my ($alias,$cached) = &is_cached_new('proxyalias',$lonhost);          $lonid = $perlvar{'lonHostID'};
       }
       if (!defined(&hostname($lonid))) {
           return;
       }
       if ($lonid ne '') {
           my ($alias,$cached) = &is_cached_new('proxyalias',$lonid);
         if ($cached) {          if ($cached) {
             return $alias;              return $alias;
         }          }
         my $dom = &Apache::lonnet::host_domain($lonhost);          my $dom = &Apache::lonnet::host_domain($lonid);
         if ($dom ne '') {          if ($dom ne '') {
             my $cachetime = 60*60*24;              my $cachetime = 60*60*24;
             my %domconfig =              my %domconfig =
Line 14447  sub get_proxy_alias { Line 14481  sub get_proxy_alias {
             my $alias;              my $alias;
             if (ref($domconfig{'wafproxy'}) eq 'HASH') {              if (ref($domconfig{'wafproxy'}) eq 'HASH') {
                 if (ref($domconfig{'wafproxy'}{'alias'}) eq 'HASH') {                  if (ref($domconfig{'wafproxy'}{'alias'}) eq 'HASH') {
                     $alias = $domconfig{'wafproxy'}{'alias'}{$lonhost};                      $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);
                 }                  }
             }              }
             return &do_cache_new('proxyalias',$lonhost,$alias,$cachetime);              unless ($vpnint && &ip_match($remote_ip,$vpnint)) {
                   return $alias;
               }
         }          }
     }      }
     return;      return;
Removed from v.1.1447  
changed lines
  Added in v.1.1453

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