[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.1172.2.118.2.9 and 1.1172.2.118.2.18

version 1.1172.2.118.2.9, 2020/10/06 20:02:55 version 1.1172.2.118.2.18, 2021/02/10 15:48:14
Line 125  our @EXPORT = qw(%env); Line 125  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 1082  sub check_for_balancer_cookie { Line 1083  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 1091  sub delbalcookie { Line 1107  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 1360  sub spare_can_host { Line 1376  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 1578  sub check_loadbalancing { Line 1603  sub check_loadbalancing {
     if ($domneedscache) {      if ($domneedscache) {
         &do_cache_new('loadbalancing',$domneedscache,$is_balancer,$cachetime);          &do_cache_new('loadbalancing',$domneedscache,$is_balancer,$cachetime);
     }      }
     if ($is_balancer) {      if (($is_balancer) && ($caller ne 'switchserver')) {
         my $lowest_load = 30000;          my $lowest_load = 30000;
         if (ref($offloadto) eq 'HASH') {          if (ref($offloadto) eq 'HASH') {
             if (ref($offloadto->{'primary'}) eq 'ARRAY') {              if (ref($offloadto->{'primary'}) eq 'ARRAY') {
Line 1618  sub check_loadbalancing { Line 1643  sub check_loadbalancing {
                 }                  }
             }              }
         }          }
         unless ($homeintdom) {      }
             undef($setcookie);      if (($is_balancer) && (!$homeintdom)) {
         }          undef($setcookie);
     }      }
     return ($is_balancer,$otherserver,$setcookie);      return ($is_balancer,$otherserver,$setcookie);
 }  }
Line 1874  sub get_dom { Line 1899  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 2409  sub get_domain_defaults { Line 2443  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 4718  sub courseacclog { Line 4755  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 5550  sub checkout { Line 5591  sub checkout {
     my ($symb,$tuname,$tudom,$tcrsid)=@_;      my ($symb,$tuname,$tudom,$tcrsid)=@_;
     my $now=time;      my $now=time;
     my $lonhost=$perlvar{'lonHostID'};      my $lonhost=$perlvar{'lonHostID'};
       my $ip = &get_requestor_ip();
     my $infostr=&escape(      my $infostr=&escape(
                  'CHECKOUTTOKEN&'.                   'CHECKOUTTOKEN&'.
                  $tuname.'&'.                   $tuname.'&'.
                  $tudom.'&'.                   $tudom.'&'.
                  $tcrsid.'&'.                   $tcrsid.'&'.
                  $symb.'&'.                   $symb.'&'.
                  $now.'&'.$ENV{'REMOTE_ADDR'});                   $now.'&'.$ip);
     my $token=&reply('tmpput:'.$infostr,$lonhost);      my $token=&reply('tmpput:'.$infostr,$lonhost);
     if ($token=~/^error\:/) {      if ($token=~/^error\:/) {
         &logthis("<font color=\"blue\">WARNING: ".          &logthis("<font color=\"blue\">WARNING: ".
Line 5570  sub checkout { Line 5612  sub checkout {
   
     my %infohash=('resource.0.outtoken' => $token,      my %infohash=('resource.0.outtoken' => $token,
                   'resource.0.checkouttime' => $now,                    'resource.0.checkouttime' => $now,
                   'resource.0.outremote' => $ENV{'REMOTE_ADDR'});                    'resource.0.outremote' => $ip);
   
     unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {      unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
        return '';         return '';
Line 5601  sub checkin { Line 5643  sub checkin {
     $lonhost=~tr/A-Z/a-z/;      $lonhost=~tr/A-Z/a-z/;
     my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb;      my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb;
     $dtoken=~s/\W/\_/g;      $dtoken=~s/\W/\_/g;
       my $ip = &get_requestor_ip();
     my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=      my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
                  split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));                   split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
   
Line 5617  sub checkin { Line 5660  sub checkin {
   
     my %infohash=('resource.0.intoken' => $token,      my %infohash=('resource.0.intoken' => $token,
                   'resource.0.checkintime' => $now,                    'resource.0.checkintime' => $now,
                   'resource.0.inremote' => $ENV{'REMOTE_ADDR'});                    'resource.0.inremote' => $ip);
   
     unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {      unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
        return '';         return '';
Line 5885  sub tmpreset { Line 5928  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 5922  sub tmpstore { Line 5965  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 5966  sub tmprestore { Line 6009  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 6022  sub store { Line 6065  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 6058  sub cstore { Line 6101  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 7050  sub putstore { Line 7093  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 7848  sub allowed { Line 7892  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 8535  sub get_commblock_resources { Line 8579  sub get_commblock_resources {
                             if ($mapsymb) {                              if ($mapsymb) {
                                 if (ref($navmap)) {                                  if (ref($navmap)) {
                                     my $mapres = $navmap->getBySymb($mapsymb);                                      my $mapres = $navmap->getBySymb($mapsymb);
                                     @to_test = $mapres->retrieveResources($mapres,undef,0,0,0,1);                                      if (ref($mapres)) {
                                     foreach my $res (@to_test) {                                          my $first = $mapres->map_start();
                                         my $symb = $res->symb();                                          my $finish = $mapres->map_finish();
                                         next if ($symb eq $mapsymb);                                          my $it = $navmap->getIterator($first,$finish,undef,0,0);
                                         if ($symb ne '') {                                          if (ref($it)) {
                                             @interval=&EXT("resource.0.interval",$symb);                                              my $res;
                                             if ($interval[1] eq 'map') {                                              while ($res = $it->next(undef,1)) {
                                                 last;                                                  next unless (ref($res));
                                                   my $symb = $res->symb();
                                                   next if (($symb eq $mapsymb) || ($symb eq ''));
                                                   @interval=&EXT("resource.0.interval",$symb);
                                                   if ($interval[1] eq 'map') {
                                                       if ($res->answerable()) {
                                                           push(@to_test,$res);
                                                           last;
                                                       }
                                                   }
                                             }                                              }
                                         }                                          }
                                     }                                      }
Line 9966  sub modifyuserauth { Line 10019  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 10493  sub store_userdata { Line 10547  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 11344  sub resdata { Line 11398  sub resdata {
     return undef;      return undef;
 }  }
   
 sub get_domain_ltitools {  sub get_domain_lti {
     my ($cdom) = @_;      my ($cdom,$context) = @_;
     my %ltitools;      my ($name,%lti);
     my ($result,$cached)=&is_cached_new('ltitools',$cdom);      if ($context eq 'consumer') {
           $name = 'ltitools';
       } elsif ($context eq 'provider') {
           $name = 'lti';
       } else {
           return %lti;
       }
       my ($result,$cached)=&is_cached_new($name,$cdom);
     if (defined($cached)) {      if (defined($cached)) {
         if (ref($result) eq 'HASH') {          if (ref($result) eq 'HASH') {
             %ltitools = %{$result};              %lti = %{$result};
         }          }
     } else {      } else {
         my %domconfig = &get_dom('configuration',['ltitools'],$cdom);          my %domconfig = &get_dom('configuration',[$name],$cdom);
         if (ref($domconfig{'ltitools'}) eq 'HASH') {          if (ref($domconfig{$name}) eq 'HASH') {
             %ltitools = %{$domconfig{'ltitools'}};              %lti = %{$domconfig{$name}};
             my %encdomconfig = &get_dom('encconfig',['ltitools'],$cdom);              my %encdomconfig = &get_dom('encconfig',[$name],$cdom);
             if (ref($encdomconfig{'ltitools'}) eq 'HASH') {              if (ref($encdomconfig{$name}) eq 'HASH') {
                 foreach my $id (keys(%ltitools)) {                  foreach my $id (keys(%lti)) {
                     if (ref($encdomconfig{'ltitools'}{$id}) eq 'HASH') {                      if (ref($encdomconfig{$name}{$id}) eq 'HASH') {
                         foreach my $item ('key','secret') {                          foreach my $item ('key','secret') {
                             $ltitools{$id}{$item} = $encdomconfig{'ltitools'}{$id}{$item};                              $lti{$id}{$item} = $encdomconfig{$name}{$id}{$item};
                         }                          }
                     }                      }
                 }                  }
             }              }
         }          }
         my $cachetime = 24*60*60;          my $cachetime = 24*60*60;
         &do_cache_new('ltitools',$cdom,\%ltitools,$cachetime);          &do_cache_new($name,$cdom,\%lti,$cachetime);
     }      }
     return %ltitools;      return %lti;
 }  }
   
 sub get_numsuppfiles {  sub get_numsuppfiles {
Line 13396  sub default_login_domain { Line 13457  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 13455  sub uses_sts { Line 13519  sub uses_sts {
     return;      return;
 }  }
   
   sub get_requestor_ip {
       my ($r,$nolookup,$noproxy) = @_;
       my $from_ip;
       if (ref($r)) {
           $from_ip = $r->get_remote_host($nolookup);
       } else {
           $from_ip = $ENV{'REMOTE_ADDR'};
       }
       return $from_ip;
   }
   
 # ------------------------------------------------------------- Declutters URLs  # ------------------------------------------------------------- Declutters URLs
   
 sub declutter {  sub declutter {
Removed from v.1.1172.2.118.2.9  
changed lines
  Added in v.1.1172.2.118.2.18

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