[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.119 and 1.1172.2.144

version 1.1172.2.119, 2020/01/20 17:48:49 version 1.1172.2.144, 2021/12/24 21:13:15
Line 95  use Cache::Memcached; Line 95  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 125  our @EXPORT = qw(%env); Line 127  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 263  sub get_server_loncaparev { Line 266  sub get_server_loncaparev {
                 if ($caller eq 'loncron') {                  if ($caller eq 'loncron') {
                     my $ua=new LWP::UserAgent;                      my $ua=new LWP::UserAgent;
                     $ua->timeout(4);                      $ua->timeout(4);
                       my $hostname = &hostname($lonhost);
                     my $protocol = $protocol{$lonhost};                      my $protocol = $protocol{$lonhost};
                     $protocol = 'http' if ($protocol ne 'https');                      $protocol = 'http' if ($protocol ne 'https');
                     my $url = $protocol.'://'.&hostname($lonhost).'/adm/about.html';                      my $url = $protocol.'://'.$hostname.'/adm/about.html';
                     my $request=new HTTP::Request('GET',$url);                      my $request=new HTTP::Request('GET',$url);
                     my $response=$ua->request($request);                      my $response=$ua->request($request);
                     unless ($response->is_error()) {                      unless ($response->is_error()) {
Line 687  sub check_for_valid_session { Line 691  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'};
           }
     }      }
     untie(%disk_env);      untie(%disk_env);
   
Line 915  sub userload { Line 922  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 953  sub spareserver { Line 960  sub spareserver {
     }      }
   
     if (!$want_server_name) {      if (!$want_server_name) {
         my $protocol = 'http';  
         if ($protocol{$spare_server} eq 'https') {  
             $protocol = $protocol{$spare_server};  
         }  
         if (defined($spare_server)) {          if (defined($spare_server)) {
             my $hostname = &hostname($spare_server);              my $hostname = &hostname($spare_server);
             if (defined($hostname)) {              if (defined($hostname)) {
                   my $protocol = 'http';
                   if ($protocol{$spare_server} eq 'https') {
                       $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 1081  sub check_for_balancer_cookie { Line 1090  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 1090  sub delbalcookie { Line 1114  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 1161  sub choose_server { Line 1185  sub choose_server {
     return ($login_host,$hostname,$portal_path,$isredirect,$lowest_load);      return ($login_host,$hostname,$portal_path,$isredirect,$lowest_load);
 }  }
   
   sub get_course_sessions {
       my ($cnum,$cdom,$lastactivity) = @_;
       my %servers = &internet_dom_servers($cdom);
       my %returnhash;
       foreach my $server (sort(keys(%servers))) {
           my $rep = &reply("coursesessions:$cdom:$cnum:$lastactivity",$server);
           my @pairs=split(/\&/,$rep);
           unless (($rep eq 'unknown_cmd') || ($rep =~ /^error/)) {
               foreach my $item (@pairs) {
                   my ($key,$value)=split(/=/,$item,2);
                   $key = &unescape($key);
                   next if ($key =~ /^error: 2 /);
                   if (exists($returnhash{$key})) {
                       next if ($value < $returnhash{$key});
                   }
                   $returnhash{$key}=$value;
               }
           }
       }
       return %returnhash;
   }
   
 # --------------------------------------------- Try to change a user's password  # --------------------------------------------- Try to change a user's password
   
 sub changepass {  sub changepass {
Line 1337  sub spare_can_host { Line 1383  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 1555  sub check_loadbalancing { Line 1610  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 1595  sub check_loadbalancing { Line 1650  sub check_loadbalancing {
                 }                  }
             }              }
         }          }
         unless ($homeintdom) {      }
             undef($setcookie);      if (($is_balancer) && (!$homeintdom)) {
         }          undef($setcookie);
     }      }
     return ($is_balancer,$otherserver,$setcookie);      return ($is_balancer,$otherserver,$setcookie);
 }  }
Line 1850  sub get_dom { Line 1905  sub get_dom {
         }          }
     }      }
     if ($udom && $uhome && ($uhome ne 'no_host')) {      if ($udom && $uhome && ($uhome ne 'no_host')) {
         my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);          my $rep;
           if (grep { $_ eq $uhome } &current_machine_ids()) {
               # domain information is hosted on this machine
               $rep = &LONCAPA::Lond::get_dom("getdom:$udom:$namespace:$items");
           } else {        
               $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
           }
         my %returnhash;          my %returnhash;
         if ($rep eq '' || $rep =~ /^error: 2 /) {          if ($rep eq '' || $rep =~ /^error: 2 /) {
             return %returnhash;              return %returnhash;
Line 1970  sub retrieve_inst_usertypes { Line 2031  sub retrieve_inst_usertypes {
   
 sub is_domainimage {  sub is_domainimage {
     my ($url) = @_;      my ($url) = @_;
     if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo)/+[^/]-) {      if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo|login)/+[^/]-) {
         if (&domain($1) ne '') {          if (&domain($1) ne '') {
             return '1';              return '1';
         }          }
Line 2333  sub get_domain_defaults { Line 2394  sub get_domain_defaults {
     }      }
     if (ref($domconfig{'coursedefaults'}) eq 'HASH') {      if (ref($domconfig{'coursedefaults'}) eq 'HASH') {
         $domdefaults{'usejsme'} = $domconfig{'coursedefaults'}{'usejsme'};          $domdefaults{'usejsme'} = $domconfig{'coursedefaults'}{'usejsme'};
           $domdefaults{'inline_chem'} = $domconfig{'coursedefaults'}{'inline_chem'};
         $domdefaults{'uselcmath'} = $domconfig{'coursedefaults'}{'uselcmath'};          $domdefaults{'uselcmath'} = $domconfig{'coursedefaults'}{'uselcmath'};
         if (ref($domconfig{'coursedefaults'}{'postsubmit'}) eq 'HASH') {          if (ref($domconfig{'coursedefaults'}{'postsubmit'}) eq 'HASH') {
             $domdefaults{'postsubmit'} = $domconfig{'coursedefaults'}{'postsubmit'}{'client'};              $domdefaults{'postsubmit'} = $domconfig{'coursedefaults'}{'postsubmit'}{'client'};
Line 2377  sub get_domain_defaults { Line 2439  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 2425  sub get_domain_defaults { Line 2490  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 3046  sub repcopy { Line 3118  sub repcopy {
     }      }
 }  }
   
   # ------------------------------------------------- Unsubscribe from a resource
   
   sub unsubscribe {
       my ($fname) = @_;
       my $answer;
       if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return $answer; }
       $fname=~s/[\n\r]//g;
       my $author=$fname;
       $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
       my ($udom,$uname)=split(/\//,$author);
       my $home=homeserver($uname,$udom);
       if ($home eq 'no_host') {
           $answer = 'no_host';
       } elsif (grep { $_ eq $home } &current_machine_ids()) {
           $answer = 'home';
       } else {
           $answer = reply("unsub:$fname",$home);
       }
       return $answer;
   }
   
 # ------------------------------------------------ Get server side include body  # ------------------------------------------------ Get server side include body
 sub ssi_body {  sub ssi_body {
     my ($filelink,%form)=@_;      my ($filelink,%form)=@_;
Line 3172  sub remove_stale_resfile { Line 3265  sub remove_stale_resfile {
                     (grep { $_ eq $homeserver } &current_machine_ids())) {                      (grep { $_ eq $homeserver } &current_machine_ids())) {
                 my $fname = &filelocation('',$url);                  my $fname = &filelocation('',$url);
                 if (-e $fname) {                  if (-e $fname) {
                     my $ua=new LWP::UserAgent;  
                     $ua->timeout(5);  
                     my $protocol = $protocol{$homeserver};  
                     $protocol = 'http' if ($protocol ne 'https');  
                     my $hostname = &hostname($homeserver);                      my $hostname = &hostname($homeserver);
                     if ($hostname) {                      if ($hostname) {
                           my $protocol = $protocol{$homeserver};
                           $protocol = 'http' if ($protocol ne 'https');
                         my $uri = $protocol.'://'.$hostname.'/raw/'.&declutter($url);                          my $uri = $protocol.'://'.$hostname.'/raw/'.&declutter($url);
                           my $ua=new LWP::UserAgent;
                           $ua->timeout(5);
                         my $request=new HTTP::Request('HEAD',$uri);                          my $request=new HTTP::Request('HEAD',$uri);
                         my $response=$ua->request($request);                          my $response=$ua->request($request);
                         if ($response->is_success()) {                          if ($response->is_success()) {
Line 3204  sub remove_stale_resfile { Line 3297  sub remove_stale_resfile {
                                     $stale = 1;                                      $stale = 1;
                                 }                                  }
                                 if ($stale) {                                  if ($stale) {
                                     unlink($fname);                                      if (unlink($fname)) {
                                     if ($uri!~/\.meta$/) {                                          if ($uri!~/\.meta$/) {
                                         unlink($fname.'.meta');                                              if (-e $fname.'.meta') {
                                                   unlink($fname.'.meta');
                                               }
                                           }
                                           my $unsubresult = &unsubscribe($fname);
                                           unless ($unsubresult eq 'ok') {
                                               &logthis("no unsub of $fname from $homeserver, reason: $unsubresult");
                                           }
                                           $removed = 1;
                                     }                                      }
                                     &reply("unsub:$fname",$homeserver);  
                                     $removed = 1;  
                                 }                                  }
                             }                              }
                         }                          }
Line 3359  sub can_edit_resource { Line 3458  sub can_edit_resource {
                         $forceedit = 1;                          $forceedit = 1;
                     }                      }
                     $cfile = $resurl;                      $cfile = $resurl;
                   } elsif (($resurl =~ m{^/ext/}) && ($symb ne '')) {
                       my ($map,$id,$res) = &decode_symb($symb);
                       if ($map =~ /\.page$/) {
                           $incourse = 1;
                           if ($env{'form.forceedit'}) {
                               $forceview = 1;
                               $cfile = $map;
                           } else {
                               $forceedit = 1;
                               $cfile =  '/adm/wrapper'.$resurl;
                           }
                       }
                 } elsif ($resurl =~ m{^/?adm/viewclasslist$}) {                  } elsif ($resurl =~ m{^/?adm/viewclasslist$}) {
                     $incourse = 1;                      $incourse = 1;
                     if ($env{'form.forceedit'}) {                      if ($env{'form.forceedit'}) {
Line 3640  sub clean_filename { Line 3751  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 4197  sub bubblesheet_converter { Line 4312  sub bubblesheet_converter {
                     next if (($num == 1) && ($csvoptions{'hdr'} == 1));                      next if (($num == 1) && ($csvoptions{'hdr'} == 1));
                     $line =~ s{[\r\n]+$}{};                      $line =~ s{[\r\n]+$}{};
                     my %found;                      my %found;
                     my @values = split(/,/,$line);                      my @values = split(/,/,$line,-1);
                     my ($qstart,$record);                      my ($qstart,$record);
                     for (my $i=0; $i<@values; $i++) {                      for (my $i=0; $i<@values; $i++) {
                         if ((($qstart ne '') && ($i > $qstart)) ||                          if ((($qstart ne '') && ($i > $qstart)) ||
Line 4501  sub flushcourselogs { Line 4616  sub flushcourselogs {
             if (! defined($dom) || $dom eq '' ||               if (! defined($dom) || $dom eq '' || 
                 ! defined($name) || $name eq '') {                  ! defined($name) || $name eq '') {
                 my $cid = $env{'request.course.id'};                  my $cid = $env{'request.course.id'};
   #
   # FIXME 11/29/2021
   # Typo in rev. 1.458 (2003/12/09)??
   # These should likely by $env{'course.'.$cid.'.domain'} and $env{'course.'.$cid.'.num'}
   #
   # While these ramain as  $env{'request.'.$cid.'.domain'} and $env{'request.'.$cid.'.num'}
   # $dom and $name will always be null, so the &inc() call will default to storing this data
   # in a nohist_accesscount.db file for the user rather than the course.
   #
   # That said there is a lot of noise in the data being stored.
   # So counts for prtspool/  and adm/ etc. are recorded.
   #
   # A review of which items ending '___count' are written to %accesshash should likely be
   # made before deciding whether to set these to 'course.' instead of 'request.'
   #
   # Under the current scheme each user receives a nohist_accesscount.db file listing
   # accesses for things which are not published resources, regardless of course, and
   # there is not a nohist_accesscount.db file in a course, which might log accesses from
   # anyone in the course for things which are not published resources.
   #
   # For an author, nohist_accesscount.db ends up having records for other items
   # mixed up with the legitimate access counts for the author's published resources.
   #
                 $dom  = $env{'request.'.$cid.'.domain'};                  $dom  = $env{'request.'.$cid.'.domain'};
                 $name = $env{'request.'.$cid.'.num'};                  $name = $env{'request.'.$cid.'.num'};
             }              }
Line 4610  sub courseacclog { Line 4748  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 5441  sub checkout { Line 5583  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 5461  sub checkout { Line 5604  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 5492  sub checkin { Line 5635  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 5508  sub checkin { Line 5652  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 5776  sub tmpreset { Line 5920  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 5813  sub tmpstore { Line 5957  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 5857  sub tmprestore { Line 6001  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 5913  sub store { Line 6057  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 5949  sub cstore { Line 6093  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 6941  sub putstore { Line 7085  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 7165  sub portfolio_access { Line 7310  sub portfolio_access {
     if ($result) {      if ($result) {
         my %setters;          my %setters;
         if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {          if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
             my ($startblock,$endblock) =              my ($startblock,$endblock,$triggerblock,$by_ip,$blockdom) =
                 &Apache::loncommon::blockcheck(\%setters,'port',$unum,$udom);                  &Apache::loncommon::blockcheck(\%setters,'port',$clientip,$unum,$udom);
             if ($startblock && $endblock) {              if (($startblock && $endblock) || ($by_ip))  {
                 return 'B';                  return 'B';
             }              }
         } else {          } else {
             my ($startblock,$endblock) =              my ($startblock,$endblock,$triggerblock,$by_ip,$blockdo) =
                 &Apache::loncommon::blockcheck(\%setters,'port');                  &Apache::loncommon::blockcheck(\%setters,'port',$clientip);
             if ($startblock && $endblock) {              if (($startblock && $endblock) || ($by_ip)) {
                 return 'B';                  return 'B';
             }              }
         }          }
Line 7722  sub customaccess { Line 7867  sub customaccess {
 # ------------------------------------------------- Check for a user privilege  # ------------------------------------------------- Check for a user privilege
   
 sub allowed {  sub allowed {
     my ($priv,$uri,$symb,$role,$clientip,$noblockcheck)=@_;      my ($priv,$uri,$symb,$role,$clientip,$noblockcheck,$ignorecache)=@_;
     my $ver_orguri=$uri;      my $ver_orguri=$uri;
     $uri=&deversion($uri);      $uri=&deversion($uri);
     my $orguri=$uri;      my $orguri=$uri;
Line 7739  sub allowed { Line 7884  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)$}))       if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard|viewclasslist|aboutme)$})) 
  || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) ))    || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) 
  && ($priv eq 'bre')) {   && ($priv eq 'bre')) {
  return 'F';   return 'F';
Line 7750  sub allowed { Line 7895  sub allowed {
     if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) &&       if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) && 
  ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {   ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {
         my %setters;          my %setters;
         my ($startblock,$endblock) =           my ($startblock,$endblock,$triggerblock,$by_ip,$blockdom) = 
             &Apache::loncommon::blockcheck(\%setters,'port');              &Apache::loncommon::blockcheck(\%setters,'port',$clientip);
         if ($startblock && $endblock) {          if (($startblock && $endblock) || ($by_ip)) {
             return 'B';              return 'B';
         } else {          } else {
             return 'F';              return 'F';
Line 7845  sub allowed { Line 7990  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 7858  sub allowed { Line 8003  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 7947  sub allowed { Line 8092  sub allowed {
                 if ($noblockcheck) {                  if ($noblockcheck) {
                     $thisallowed.=$value;                      $thisallowed.=$value;
                 } else {                  } else {
                     my @blockers = &has_comm_blocking($priv,$symb,$uri);                      my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);
                     if (@blockers > 0) {                      if (@blockers > 0) {
                         $thisallowed = 'B';                          $thisallowed = 'B';
                     } else {                      } else {
Line 7967  sub allowed { Line 8112  sub allowed {
                         if ($noblockcheck) {                          if ($noblockcheck) {
                             $thisallowed='F';                              $thisallowed='F';
                         } else {                          } else {
                             my @blockers = &has_comm_blocking($priv,$symb,$refuri);                              my @blockers = &has_comm_blocking($priv,'',$refuri,'',1);
                             if (@blockers > 0) {                              if (@blockers > 0) {
                                 $thisallowed = 'B';                                  $thisallowed = 'B';
                             } else {                              } else {
Line 8040  sub allowed { Line 8185  sub allowed {
                    if ($noblockcheck) {                     if ($noblockcheck) {
                        $thisallowed.=$value;                         $thisallowed.=$value;
                    } else {                     } else {
                        my @blockers = &has_comm_blocking($priv,$symb,$uri);                         my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);
                        if (@blockers > 0) {                         if (@blockers > 0) {
                            $thisallowed = 'B';                             $thisallowed = 'B';
                        } else {                         } else {
Line 8053  sub allowed { Line 8198  sub allowed {
                $checkreferer=0;                 $checkreferer=0;
            }             }
        }         }
          
        if ($checkreferer) {         if ($checkreferer) {
   my $refuri=$env{'httpref.'.$orguri};    my $refuri=$env{'httpref.'.$orguri};
             unless ($refuri) {              unless ($refuri) {
Line 8082  sub allowed { Line 8227  sub allowed {
                       if ($noblockcheck) {                        if ($noblockcheck) {
                           $thisallowed.=$value;                            $thisallowed.=$value;
                       } else {                        } else {
                           my @blockers = &has_comm_blocking($priv,$symb,$refuri);                            my @blockers = &has_comm_blocking($priv,'',$refuri,'',1);
                           if (@blockers > 0) {                            if (@blockers > 0) {
                               $thisallowed = 'B';                                $thisallowed = 'B';
                           } else {                            } else {
Line 8124  sub allowed { Line 8269  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 8156  sub allowed { Line 8333  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 8168  sub allowed { Line 8345  sub allowed {
    }     }
        }         }
     }      }
      
 #  #
 # Rest of the restrictions depend on selected course  # Rest of the restrictions depend on selected course
 #  #
Line 8326  sub constructaccess { Line 8503  sub constructaccess {
 #  #
 # User for whom data are being temporarily cached.  # User for whom data are being temporarily cached.
 my $cacheduser='';  my $cacheduser='';
   # Course for which data are being temporarily cached.
   my $cachedcid='';
 # Cached blockers for this user (a hash of blocking items).  # Cached blockers for this user (a hash of blocking items).
 my %cachedblockers=();  my %cachedblockers=();
 # When the data were last cached.  # When the data were last cached.
 my $cachedlast='';  my $cachedlast='';
   
 sub load_all_blockers {  sub load_all_blockers {
     my ($uname,$udom,$blocks)=@_;      my ($uname,$udom)=@_;
     if (($uname ne '') && ($udom ne '')) {      if (($uname ne '') && ($udom ne '')) {
         if (($cacheduser eq $uname.':'.$udom) &&          if (($cacheduser eq $uname.':'.$udom) &&
               ($cachedcid eq $env{'request.course.id'}) &&
             (abs($cachedlast-time)<5)) {              (abs($cachedlast-time)<5)) {
             return;              return;
         }          }
     }      }
     $cachedlast=time;      $cachedlast=time;
     $cacheduser=$uname.':'.$udom;      $cacheduser=$uname.':'.$udom;
     %cachedblockers = &get_commblock_resources($blocks);      $cachedcid=$env{'request.course.id'};
       %cachedblockers = &get_commblock_resources();
       return;
 }  }
   
 sub get_comm_blocks {  sub get_comm_blocks {
Line 8368  sub get_commblock_resources { Line 8550  sub get_commblock_resources {
     my ($blocks) = @_;      my ($blocks) = @_;
     my %blockers = ();      my %blockers = ();
     return %blockers unless ($env{'request.course.id'});      return %blockers unless ($env{'request.course.id'});
     return %blockers if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/);      my $courseurl = &courseid_to_courseurl($env{'request.course.id'});
       if ($env{'request.course.sec'}) {
           $courseurl .= '/'.$env{'request.course.sec'};
       }
       return %blockers if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseurl} =~/evb\&([^\:]*)/);
     my %commblocks;      my %commblocks;
     if (ref($blocks) eq 'HASH') {      if (ref($blocks) eq 'HASH') {
         %commblocks = %{$blocks};          %commblocks = %{$blocks};
Line 8400  sub get_commblock_resources { Line 8586  sub get_commblock_resources {
             }              }
         } elsif ($block =~ /^firstaccess____(.+)$/) {          } elsif ($block =~ /^firstaccess____(.+)$/) {
             my $item = $1;              my $item = $1;
             my @to_test;  
             if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {              if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {
                 if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {                  if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {
                     my @interval;                      my (@interval,$mapname);
                     my $type = 'map';                      my $type = 'map';
                     if ($item eq 'course') {                      if ($item eq 'course') {
                         $type = 'course';                          $type = 'course';
Line 8412  sub get_commblock_resources { Line 8597  sub get_commblock_resources {
                         if ($item =~ /___\d+___/) {                          if ($item =~ /___\d+___/) {
                             $type = 'resource';                              $type = 'resource';
                             @interval=&EXT("resource.0.interval",$item);                              @interval=&EXT("resource.0.interval",$item);
                             if (ref($navmap)) {  
                                 my $res = $navmap->getBySymb($item);  
                                 push(@to_test,$res);  
                             }  
                         } else {                          } else {
                             my $mapsymb = &symbread($item,1);                              $mapname = &deversion($item);
                             if ($mapsymb) {                              if (ref($navmap)) {
                                 if (ref($navmap)) {                                  my $timelimit = $navmap->get_mapparam(undef,$mapname,'0.interval');
                                     my $mapres = $navmap->getBySymb($mapsymb);                                  @interval = ($timelimit,'map');
                                     @to_test = $mapres->retrieveResources($mapres,undef,0,0,0,1);  
                                     foreach my $res (@to_test) {  
                                         my $symb = $res->symb();  
                                         next if ($symb eq $mapsymb);  
                                         if ($symb ne '') {  
                                             @interval=&EXT("resource.0.interval",$symb);  
                                             if ($interval[1] eq 'map') {  
                                                 last;  
                                             }  
                                         }  
                                     }  
                                 }  
                             }                              }
                         }                          }
                     }                      }
Line 8449  sub get_commblock_resources { Line 8618  sub get_commblock_resources {
                             my $timesup = $first_access+$interval[0];                              my $timesup = $first_access+$interval[0];
                             if ($timesup > $now) {                              if ($timesup > $now) {
                                 my $activeblock;                                  my $activeblock;
                                 foreach my $res (@to_test) {                                  if ($type eq 'resource') {
                                     if ($res->answerable()) {                                      if (ref($navmap)) {
                                         $activeblock = 1;                                          my $res = $navmap->getBySymb($item);
                                         last;                                          if ($res->answerable()) {
                                               $activeblock = 1;
                                           }
                                       }
                                   } elsif ($type eq 'map') {
                                       my $mapsymb = &symbread($mapname,1);
                                       if (($mapsymb) && (ref($navmap))) {
                                           my $mapres = $navmap->getBySymb($mapsymb);
                                           if (ref($mapres)) {
                                               my $first = $mapres->map_start();
                                               my $finish = $mapres->map_finish();
                                               my $it = $navmap->getIterator($first,$finish,undef,0,0);
                                               if (ref($it)) {
                                                   my $res;
                                                   while ($res = $it->next(undef,1)) {
                                                       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()) {
                                                               $activeblock = 1;
                                                               last;
                                                           }
                                                       }
                                                   }
                                               }
                                           }
                                     }                                      }
                                 }                                  }
                                 if ($activeblock) {                                  if ($activeblock) {
Line 8478  sub get_commblock_resources { Line 8674  sub get_commblock_resources {
 }  }
   
 sub has_comm_blocking {  sub has_comm_blocking {
     my ($priv,$symb,$uri,$blocks) = @_;      my ($priv,$symb,$uri,$ignoresymbdb,$noenccheck,$blocked,$blocks) = @_;
     my @blockers;      my @blockers;
     return unless ($env{'request.course.id'});      return unless ($env{'request.course.id'});
     return unless ($priv eq 'bre');      return unless ($priv eq 'bre');
     return if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/);  
     return if ($env{'request.state'} eq 'construct');      return if ($env{'request.state'} eq 'construct');
     &load_all_blockers($env{'user.name'},$env{'user.domain'},$blocks);      my $courseurl = &courseid_to_courseurl($env{'request.course.id'});
     return unless (keys(%cachedblockers) > 0);      if ($env{'request.course.sec'}) {
           $courseurl .= '/'.$env{'request.course.sec'};
       }
       return if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseurl} =~/evb\&([^\:]*)/);
       my %blockinfo;
       if (ref($blocks) eq 'HASH') {
           %blockinfo = &get_commblock_resources($blocks);
       } else {
           &load_all_blockers($env{'user.name'},$env{'user.domain'});
           %blockinfo = %cachedblockers;
       }
       return unless (keys(%blockinfo) > 0);
     my (%possibles,@symbs);      my (%possibles,@symbs);
     if (!$symb) {      if (!$symb) {
         $symb = &symbread($uri,1,1,1,\%possibles);          $symb = &symbread($uri,1,1,1,\%possibles,$ignoresymbdb,$noenccheck);
     }      }
     if ($symb) {      if ($symb) {
         @symbs = ($symb);          @symbs = ($symb);
Line 8499  sub has_comm_blocking { Line 8705  sub has_comm_blocking {
     foreach my $symb (@symbs) {      foreach my $symb (@symbs) {
         last if ($noblock);          last if ($noblock);
         my ($map,$resid,$resurl)=&decode_symb($symb);          my ($map,$resid,$resurl)=&decode_symb($symb);
         foreach my $block (keys(%cachedblockers)) {          foreach my $block (keys(%blockinfo)) {
             if ($block =~ /^firstaccess____(.+)$/) {              if ($block =~ /^firstaccess____(.+)$/) {
                 my $item = $1;                  my $item = $1;
                 if (($item eq $map) || ($item eq $symb)) {                  unless ($blocked) {
                     $noblock = 1;                      if (($item eq $map) || ($item eq $symb)) {
                     last;                          $noblock = 1;
                           last;
                       }
                 }                  }
             }              }
             if (ref($cachedblockers{$block}) eq 'HASH') {              if (ref($blockinfo{$block}) eq 'HASH') {
                 if (ref($cachedblockers{$block}{'resources'}) eq 'HASH') {                  if (ref($blockinfo{$block}{'resources'}) eq 'HASH') {
                     if ($cachedblockers{$block}{'resources'}{$symb}) {                      if ($blockinfo{$block}{'resources'}{$symb}) {
                         unless (grep(/^\Q$block\E$/,@blockers)) {                          unless (grep(/^\Q$block\E$/,@blockers)) {
                             push(@blockers,$block);                              push(@blockers,$block);
                         }                          }
                     }                      }
                 }                  }
             }                  if (ref($blockinfo{$block}{'maps'}) eq 'HASH') {
             if (ref($cachedblockers{$block}{'maps'}) eq 'HASH') {                      if ($blockinfo{$block}{'maps'}{$map}) {
                 if ($cachedblockers{$block}{'maps'}{$map}) {                          unless (grep(/^\Q$block\E$/,@blockers)) {
                     unless (grep(/^\Q$block\E$/,@blockers)) {                              push(@blockers,$block);
                         push(@blockers,$block);                          }
                     }                      }
                 }                  }
             }              }
         }          }
     }      }
     return if ($noblock);      unless ($noblock) {
     return @blockers;          return @blockers;
       }
       return;
 }  }
 }  }
   
Line 8924  sub auto_validate_instcode { Line 9134  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 9195  sub auto_validate_class_sec { Line 9424  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 9739  sub autoupdate_coowners { Line 10000  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 9756  sub autoupdate_coowners { Line 10029  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 9841  sub modifyuserauth { Line 10112  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 10363  sub store_userdata { Line 10635  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 11294  sub EXT { Line 11566  sub EXT {
     if ( (defined($Apache::lonhomework::parsing_a_problem)      if ( (defined($Apache::lonhomework::parsing_a_problem)
   || defined($Apache::lonhomework::parsing_a_task))    || defined($Apache::lonhomework::parsing_a_task))
  &&   &&
  ($symbparm eq &symbread()) ) {   ($symbparm eq &symbread()) ) {
  # if we are in the middle of processing the resource the   # if we are in the middle of processing the resource the
  # get the value we are planning on committing   # get the value we are planning on committing
                 if (defined($Apache::lonhomework::results{$qualifierrest})) {                  if (defined($Apache::lonhomework::results{$qualifierrest})) {
Line 12256  sub symbverify { Line 12528  sub symbverify {
   
     if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',      if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
                             &GDBM_READER(),0640)) {                              &GDBM_READER(),0640)) {
         my $noclutter;  
         if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) {          if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) {
             $thisurl =~ s/\?.+$//;              $thisurl =~ s/\?.+$//;
             if ($map =~ m{^uploaded/.+\.page$}) {              if ($map =~ m{^uploaded/.+\.page$}) {
                 $thisurl =~ s{^(/adm/wrapper|)/ext/}{http://};                  $thisurl =~ s{^(/adm/wrapper|)/ext/}{http://};
                 $thisurl =~ s{^\Qhttp://https://\E}{https://};                  $thisurl =~ s{^\Qhttp://https://\E}{https://};
                 $noclutter = 1;  
             }              }
         }          }
         my $ids;          my $ids;
         if ($noclutter) {          if ($map =~ m{^uploaded/.+\.page$}) {
             $ids=$bighash{'ids_'.$thisurl};              $ids=$bighash{'ids_'.&clutter_with_no_wrapper($thisurl)};
         } else {          } else {
             $ids=$bighash{'ids_'.&clutter($thisurl)};              $ids=$bighash{'ids_'.&clutter($thisurl)};
         }          }
Line 12367  sub deversion { Line 12637  sub deversion {
 # ------------------------------------------------------ Return symb list entry  # ------------------------------------------------------ Return symb list entry
   
 sub symbread {  sub symbread {
     my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles)=@_;      my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles,
           $ignoresymbdb,$noenccheck)=@_;
     my $cache_str='request.symbread.cached.'.$thisfn;      my $cache_str='request.symbread.cached.'.$thisfn;
     if (defined($env{$cache_str})) {      if (defined($env{$cache_str})) {
         if ($ignorecachednull) {          unless (ref($possibles) eq 'HASH') {
             return $env{$cache_str} unless ($env{$cache_str} eq '');              if ($ignorecachednull) {
         } else {                  return $env{$cache_str} unless ($env{$cache_str} eq '');
             return $env{$cache_str};              } else {
                   return $env{$cache_str};
               }
         }          }
     }      }
 # no filename provided? try from environment  # no filename provided? try from environment
Line 12402  sub symbread { Line 12675  sub symbread {
  if ($targetfn =~ m|^adm/wrapper/(ext/.*)|) {   if ($targetfn =~ m|^adm/wrapper/(ext/.*)|) {
     $targetfn=$1;      $targetfn=$1;
  }   }
         if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',          unless ($ignoresymbdb) {
                       &GDBM_READER(),0640)) {              if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
     $syval=$hash{$targetfn};                            &GDBM_READER(),0640)) {
             untie(%hash);          $syval=$hash{$targetfn};
                   untie(%hash);
               }
               if ($syval && $checkforblock) {
                   my @blockers = &has_comm_blocking('bre',$syval,$thisfn,$ignoresymbdb,$noenccheck);
                   if (@blockers) {
                       $syval='';
                   }
               }
         }          }
 # ---------------------------------------------------------- There was an entry  # ---------------------------------------------------------- There was an entry
         if ($syval) {          if ($syval) {
Line 12438  sub symbread { Line 12719  sub symbread {
      $syval=&encode_symb($bighash{'map_id_'.$mapid},       $syval=&encode_symb($bighash{'map_id_'.$mapid},
     $resid,$thisfn);      $resid,$thisfn);
                      if (ref($possibles) eq 'HASH') {                       if (ref($possibles) eq 'HASH') {
                          $possibles->{$syval} = 1;                           unless ($bighash{'randomout_'.$ids} || $env{'request.role.adv'}) {
                                $possibles->{$syval} = 1;
                            }
                      }                       }
                      if ($checkforblock) {                       if ($checkforblock) {
                          my @blockers = &has_comm_blocking('bre',$syval,$bighash{'src_'.$ids});                           unless ($bighash{'randomout_'.$ids} || $env{'request.role.adv'}) {
                          if (@blockers) {                               my @blockers = &has_comm_blocking('bre',$syval,$bighash{'src_'.$ids},'',$noenccheck);
                              $syval = '';                               if (@blockers) {
                              return;                                   $syval = '';
                                    untie(%bighash);
                                    return $env{$cache_str}='';
                                }
                          }                           }
                      }                       }
                  } elsif ((!$donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) {                   } elsif ((!$donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) {
Line 12463  sub symbread { Line 12749  sub symbread {
                              if ($bighash{'map_type_'.$mapid} ne 'page') {                               if ($bighash{'map_type_'.$mapid} ne 'page') {
                                  my $poss_syval=&encode_symb($bighash{'map_id_'.$mapid},                                   my $poss_syval=&encode_symb($bighash{'map_id_'.$mapid},
                                                              $resid,$thisfn);                                                               $resid,$thisfn);
                                  if (ref($possibles) eq 'HASH') {                                   next if ($bighash{'randomout_'.$id} && !$env{'request.role.adv'});
                                      $possibles->{$syval} = 1;                                   next unless (($noenccheck) || ($bighash{'encrypted_'.$id} eq $env{'request.enc'}));
                                  }  
                                  if ($checkforblock) {                                   if ($checkforblock) {
                                      my @blockers = &has_comm_blocking('bre',$poss_syval,$file);                                       my @blockers = &has_comm_blocking('bre',$poss_syval,$file,'',$noenccheck);
                                      unless (@blockers > 0) {                                       if (@blockers > 0) {
                                            $syval = '';
                                        } else {
                                          $syval = $poss_syval;                                           $syval = $poss_syval;
                                          $realpossible++;                                           $realpossible++;
                                      }                                       }
Line 12476  sub symbread { Line 12763  sub symbread {
                                      $syval = $poss_syval;                                       $syval = $poss_syval;
                                      $realpossible++;                                       $realpossible++;
                                  }                                   }
                                    if ($syval) {
                                        if (ref($possibles) eq 'HASH') {
                                            $possibles->{$syval} = 1;
                                        }
                                    }
                              }                               }
  }   }
                      }                       }
Line 13013  sub repcopy_userfile { Line 13305  sub repcopy_userfile {
     my $request;      my $request;
     $uri=~s/^\///;      $uri=~s/^\///;
     my $homeserver = &homeserver($cnum,$cdom);      my $homeserver = &homeserver($cnum,$cdom);
       my $hostname = &hostname($homeserver);
     my $protocol = $protocol{$homeserver};      my $protocol = $protocol{$homeserver};
     $protocol = 'http' if ($protocol ne 'https');      $protocol = 'http' if ($protocol ne 'https');
     $request=new HTTP::Request('GET',$protocol.'://'.&hostname($homeserver).'/raw/'.$uri);      $request=new HTTP::Request('GET',$protocol.'://'.$hostname.'/raw/'.$uri);
     my $response=$ua->request($request,$transferfile);      my $response=$ua->request($request,$transferfile);
 # did it work?  # did it work?
     if ($response->is_error()) {      if ($response->is_error()) {
Line 13039  sub tokenwrapper { Line 13332  sub tokenwrapper {
  $file=~s|(\?\.*)*$||;   $file=~s|(\?\.*)*$||;
         &appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}});          &appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}});
         my $homeserver = &homeserver($uname,$udom);          my $homeserver = &homeserver($uname,$udom);
           my $hostname = &hostname($homeserver);
         my $protocol = $protocol{$homeserver};          my $protocol = $protocol{$homeserver};
         $protocol = 'http' if ($protocol ne 'https');          $protocol = 'http' if ($protocol ne 'https');
         return $protocol.'://'.&hostname($homeserver).'/'.$uri.          return $protocol.'://'.$hostname.'/'.$uri.
                (($uri=~/\?/)?'&':'?').'token='.$token.                 (($uri=~/\?/)?'&':'?').'token='.$token.
                                '&tokenissued='.$perlvar{'lonHostID'};                                 '&tokenissued='.$perlvar{'lonHostID'};
     } else {      } else {
Line 13057  sub getuploaded { Line 13351  sub getuploaded {
     my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;      my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
     $uri=~s/^\///;      $uri=~s/^\///;
     my $homeserver = &homeserver($cnum,$cdom);      my $homeserver = &homeserver($cnum,$cdom);
       my $hostname = &hostname($homeserver);
     my $protocol = $protocol{$homeserver};      my $protocol = $protocol{$homeserver};
     $protocol = 'http' if ($protocol ne 'https');      $protocol = 'http' if ($protocol ne 'https');
     $uri = $protocol.'://'.&hostname($homeserver).'/raw/'.$uri;      $uri = $protocol.'://'.$hostname.'/raw/'.$uri;
     my $ua=new LWP::UserAgent;      my $ua=new LWP::UserAgent;
     my $request=new HTTP::Request($reqtype,$uri);      my $request=new HTTP::Request($reqtype,$uri);
     my $response=$ua->request($request);      my $response=$ua->request($request);
Line 13192  sub machine_ids { Line 13487  sub machine_ids {
   
 sub additional_machine_domains {  sub additional_machine_domains {
     my @domains;      my @domains;
     open(my $fh,"<","$perlvar{'lonTabDir'}/expected_domains.tab");      if (-e "$perlvar{'lonTabDir'}/expected_domains.tab") {
     while( my $line = <$fh>) {          if (open(my $fh,"<","$perlvar{'lonTabDir'}/expected_domains.tab")) {
         $line =~ s/\s//g;              while( my $line = <$fh>) {
         push(@domains,$line);                  chomp($line);
                   $line =~ s/\s//g;
                   push(@domains,$line);
               }
               close($fh);
           }
     }      }
     return @domains;      return @domains;
 }  }
Line 13214  sub default_login_domain { Line 13514  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 13234  sub shared_institution { Line 13537  sub shared_institution {
     return $same_intdom;      return $same_intdom;
 }  }
   
   sub uses_sts {
       my ($ignore_cache) = @_;
       my $lonhost = $perlvar{'lonHostID'};
       my $hostname = &hostname($lonhost);
       my $sts_on;
       if ($protocol{$lonhost} eq 'https') {
           my $cachetime = 12*3600;
           if (!$ignore_cache) {
               ($sts_on,my $cached)=&is_cached_new('stspolicy',$lonhost);
               if (defined($cached)) {
                   return $sts_on;
               }
           }
           my $ua=new LWP::UserAgent;
           my $url = $protocol{$lonhost}.'://'.$hostname.'/index.html';
           my $request=new HTTP::Request('HEAD',$url);
           my $response=$ua->request($request);
           if ($response->is_success) {
               my $has_sts = $response->header('Strict-Transport-Security');
               if ($has_sts eq '') {
                   $sts_on = 0;
               } else {
                   if ($has_sts =~ /\Qmax-age=\E(\d+)/) {
                       my $maxage = $1;
                       if ($maxage) {
                           $sts_on = 1;
                       } else {
                           $sts_on = 0;
                       }
                   } else {
                       $sts_on = 0;
                   }
               }
               return &do_cache_new('stspolicy',$lonhost,$sts_on,$cachetime);
           }
       }
       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);
               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;
   }
   
   sub alias_sso {
       my ($lonid) = @_;
       if ($lonid eq '') {
           $lonid = $perlvar{'lonHostID'};
       }
       if (!defined(&hostname($lonid))) {
           return;
       }
       if ($lonid ne '') {
           my ($use_alias,$cached) = &is_cached_new('proxysaml',$lonid);
           if ($cached) {
               return $use_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);
               if (ref($domconfig{'wafproxy'}) eq 'HASH') {
                   if (ref($domconfig{'wafproxy'}{'saml'}) eq 'HASH') {
                       $use_alias = $domconfig{'wafproxy'}{'saml'}{$lonid};
                   }
               }
               return &do_cache_new('proxysaml',$lonid,$use_alias,$cachetime);
           }
       }
       return;
   }
   
   sub get_saml_landing {
       my ($lonid) = @_;
       if ($lonid eq '') {
           my $defdom = &default_login_domain();
           my @hosts = &current_machine_ids();
           if (@hosts > 1) {
               foreach my $hostid (@hosts) {
                   if (&host_domain($hostid) eq $defdom) {
                       $lonid = $hostid;
                       last;
                   }
               }
           } else {
               $lonid = $perlvar{'lonHostID'};
           }
           if ($lonid) {
               unless (&Apache::lonnet::host_domain($lonid) eq $defdom) {
                   return;
               }
           } else {
               return;
           }
       } elsif (!defined(&hostname($lonid))) {
           return;
       }
       my ($landing,$cached) = &is_cached_new('samllanding',$lonid);
       if ($cached) {
           return $landing;
       }
       my $dom = &Apache::lonnet::host_domain($lonid);
       if ($dom ne '') {
           my $cachetime = 60*60*24;
           my %domconfig =
               &Apache::lonnet::get_dom('configuration',['login'],$dom);
           if (ref($domconfig{'login'}) eq 'HASH') {
               if (ref($domconfig{'login'}{'saml'}) eq 'HASH') {
                   if (ref($domconfig{'login'}{'saml'}{$lonid}) eq 'HASH') {
                       $landing = 1;
                   }
               }
           }
           return &do_cache_new('samllanding',$lonid,$landing,$cachetime);
       }
       return;
   }
   
 # ------------------------------------------------------------- Declutters URLs  # ------------------------------------------------------------- Declutters URLs
   
 sub declutter {  sub declutter {
Line 13371  sub get_dns { Line 13937  sub get_dns {
     }      }
     while (%alldns) {      while (%alldns) {
  my ($dns) = sort { $b cmp $a } keys(%alldns);   my ($dns) = sort { $b cmp $a } keys(%alldns);
  my $ua=new LWP::UserAgent;          my @content;
         $ua->timeout(30);          if ($dns eq Sys::Hostname::FQDN::fqdn()) {
  my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");              my $command = (split('/',$url))[3];
  my $response=$ua->request($request);              my ($dir,$file) = &parse_getdns_url($command,$url);
         delete($alldns{$dns});              delete($alldns{$dns});
  next if ($response->is_error());              next if (($dir eq '') || ($file eq ''));
  my @content = split("\n",$response->content);              if (open(my $config,'<',"$dir/$file")) {
                   @content = <$config>;
                   close($config);
               }
           } else {
       my $ua=new LWP::UserAgent;
               $ua->timeout(30);
       my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
       my $response=$ua->request($request);
               delete($alldns{$dns});
       next if ($response->is_error());
       @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 13449  sub fetch_dns_checksums { Line 14027  sub fetch_dns_checksums {
     return \%checksums;      return \%checksums;
 }  }
   
   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",
       }
       return ($dir,$file);
   }
   
 # ------------------------------------------------------------ Read domain file  # ------------------------------------------------------------ Read domain file
 {  {
     my $loaded;      my $loaded;
Removed from v.1.1172.2.119  
changed lines
  Added in v.1.1172.2.144

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