[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.1343 and 1.1351

version 1.1343, 2017/05/08 14:20:26 version 1.1351, 2017/08/23 22:46:38
Line 71  delayed. Line 71  delayed.
 package Apache::lonnet;  package Apache::lonnet;
   
 use strict;  use strict;
 use LWP::UserAgent();  
 use HTTP::Date;  use HTTP::Date;
 use Image::Magick;  use Image::Magick;
   
Line 101  use LONCAPA qw(:DEFAULT :match); Line 100  use LONCAPA qw(:DEFAULT :match);
 use LONCAPA::Configuration;  use LONCAPA::Configuration;
 use LONCAPA::lonmetadata;  use LONCAPA::lonmetadata;
 use LONCAPA::Lond;  use LONCAPA::Lond;
   use LONCAPA::LWPReq;
   
 use File::Copy;  use File::Copy;
   
Line 243  sub get_servercerts_info { Line 243  sub get_servercerts_info {
             if ($1 < 6) {              if ($1 < 6) {
                 $uselocal = 0;                  $uselocal = 0;
             }              }
           }  elsif ($distro =~ /^(?:sles)(\d+)$/) {
               if ($1 < 12) {
                   $uselocal = 0;
               }
         }          }
     }      }
     if ($uselocal) {      if ($uselocal) {
Line 305  sub get_server_loncaparev { Line 309  sub get_server_loncaparev {
             $answer = &reply('serverloncaparev',$lonhost);              $answer = &reply('serverloncaparev',$lonhost);
             if (($answer eq 'unknown_cmd') || ($answer eq 'con_lost')) {              if (($answer eq 'unknown_cmd') || ($answer eq 'con_lost')) {
                 if ($caller eq 'loncron') {                  if ($caller eq 'loncron') {
                     my $ua=new LWP::UserAgent;  
                     $ua->timeout(4);  
                     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($lonhost).'/adm/about.html';
                     my $request=new HTTP::Request('GET',$url);                      my $request=new HTTP::Request('GET',$url);
                     my $response=$ua->request($request);                      my $response=&LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,4,1);
                     unless ($response->is_error()) {                      unless ($response->is_error()) {
                         my $content = $response->content;                          my $content = $response->content;
                         if ($content =~ /<p>VERSION\:\s*([\w.\-]+)<\/p>/) {                          if ($content =~ /<p>VERSION\:\s*([\w.\-]+)<\/p>/) {
Line 1596  sub internet_dom_servers { Line 1598  sub internet_dom_servers {
     return %uniqservers;      return %uniqservers;
 }  }
   
   sub trusted_domains {
       my ($cmdtype,$calldom) = @_;
       my ($trusted,$untrusted);
       if (&domain($calldom) eq '') {
           return ($trusted,$untrusted);
       }
       unless ($cmdtype =~ /^(content|shared|enroll|coaurem|domroles|catalog|reqcrs|msg)$/) {
           return ($trusted,$untrusted);
       }
       my $callprimary = &domain($calldom,'primary');
       my $intcalldom = &Apache::lonnet::internet_dom($callprimary);
       if ($intcalldom eq '') {
           return ($trusted,$untrusted);
       }
   
       my ($trustconfig,$cached)=&Apache::lonnet::is_cached_new('trust',$calldom);
       unless (defined($cached)) {
           my %domconfig = &Apache::lonnet::get_dom('configuration',['trust'],$calldom);
           &Apache::lonnet::do_cache_new('trust',$calldom,$domconfig{'trust'},3600);
           $trustconfig = $domconfig{'trust'};
       }
       if (ref($trustconfig)) {
           my (%possexc,%possinc,@allexc,@allinc); 
           if (ref($trustconfig->{$cmdtype}) eq 'HASH') {
               if (ref($trustconfig->{$cmdtype}->{'exc'}) eq 'ARRAY') {
                   map { $possexc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'exc'}}; 
               }
               if (ref($trustconfig->{$cmdtype}->{'inc'}) eq 'ARRAY') {
                   map { $possinc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'inc'}};
               }
           }
           if (keys(%possexc)) {
               if (keys(%possinc)) {
                   foreach my $key (sort(keys(%possexc))) {
                       next if ($key eq $intcalldom);
                       unless ($possinc{$key}) {
                           push(@allexc,$key);
                       }
                   }
               } else {
                   @allexc = sort(keys(%possexc));
               }
           }
           if (keys(%possinc)) {
               $possinc{$intcalldom} = 1;
               @allinc = sort(keys(%possinc));
           }
           if ((@allexc > 0) || (@allinc > 0)) {
               my %doms_by_intdom;
               my %allintdoms = &all_host_intdom();
               my %alldoms = &all_host_domain();
               foreach my $key (%allintdoms) {
                   if (ref($doms_by_intdom{$allintdoms{$key}}) eq 'ARRAY') {
                       unless (grep(/^\Q$alldoms{$key}\E$/,@{$doms_by_intdom{$allintdoms{$key}}})) {
                           push(@{$doms_by_intdom{$allintdoms{$key}}},$alldoms{$key});
                       }
                   } else {
                       $doms_by_intdom{$allintdoms{$key}} = [$alldoms{$key}]; 
                   }
               }
               foreach my $exc (@allexc) {
                   if (ref($doms_by_intdom{$exc}) eq 'ARRAY') {
                       $untrusted = $doms_by_intdom{$exc};
                   }
               }
               foreach my $inc (@allinc) {
                   if (ref($doms_by_intdom{$inc}) eq 'ARRAY') {
                       $trusted = $doms_by_intdom{$inc};
                   }
               }
           }
       }
       return ($trusted,$untrusted);
   }
   
   sub will_trust {
       my ($cmdtype,$domain,$possdom) = @_;
       return 1 if ($domain eq $possdom);
       my ($trustedref,$untrustedref) = &trusted_domains($cmdtype,$possdom);
       my $willtrust; 
       if ((ref($trustedref) eq 'ARRAY') && (@{$trustedref} > 0)) {
           if (grep(/^\Q$domain\E$/,@{$trustedref})) {
               $willtrust = 1;
           }
       } elsif ((ref($untrustedref) eq 'ARRAY') && (@{$untrustedref} > 0)) {
           unless (grep(/^\Q$domain\E$/,@{$untrustedref})) {
               $willtrust = 1;
           }
       } else {
           $willtrust = 1;
       }
       return $willtrust;
   }
   
 # ---------------------- Find the homebase for a user from domain's lib servers  # ---------------------- Find the homebase for a user from domain's lib servers
   
 my %homecache;  my %homecache;
Line 1845  sub get_dom { Line 1941  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 ($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 /) {
             return %returnhash;              return %returnhash;
Line 1889  sub put_dom { Line 1990  sub put_dom {
             $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';              $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
         }          }
         $items=~s/\&$//;          $items=~s/\&$//;
         return &reply("putdom:$udom:$namespace:$items",$uhome);          if ($namespace =~ /^enc/) {
               return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome);
           } else {
               return &reply("putdom:$udom:$namespace:$items",$uhome);
           }
     } else {      } else {
         &logthis("put_dom failed - no homeserver and/or domain");          &logthis("put_dom failed - no homeserver and/or domain");
     }      }
Line 2944  sub repcopy { Line 3049  sub repcopy {
    mkdir($path,0777);     mkdir($path,0777);
                }                 }
            }             }
            my $ua=new LWP::UserAgent;  
            my $request=new HTTP::Request('GET',"$remoteurl");             my $request=new HTTP::Request('GET',"$remoteurl");
            my $response=$ua->request($request,$transname);             my $response;
              if ($remoteurl =~ m{/raw/}) {
                  $response=&LONCAPA::LWPReq::makerequest($home,$request,$transname,\%perlvar,'',0,1);
              } else {
                  $response=&LONCAPA::LWPReq::makerequest($home,$request,$transname,\%perlvar,'',1);
              }
            if ($response->is_error()) {             if ($response->is_error()) {
        unlink($transname);         unlink($transname);
                my $message=$response->status_line;                 my $message=$response->status_line;
Line 2956  sub repcopy { Line 3065  sub repcopy {
            } else {             } else {
        if ($remoteurl!~/\.meta$/) {         if ($remoteurl!~/\.meta$/) {
                   my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');                    my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');
                   my $mresponse=$ua->request($mrequest,$filename.'.meta');                    my $mresponse;
                     if ($remoteurl =~ m{/raw/}) {
                         $mresponse = &LONCAPA::LWPReq::makerequest($home,$mrequest,$filename.'.meta',\%perlvar,'',0,1);
                     } else {
                         $mresponse = &LONCAPA::LWPReq::makerequest($home,$mrequest,$filename.'.meta',\%perlvar,'',1);
                     }
                   if ($mresponse->is_error()) {                    if ($mresponse->is_error()) {
       unlink($filename.'.meta');        unlink($filename.'.meta');
                       &logthis(                        &logthis(
Line 3019  sub absolute_url { Line 3133  sub absolute_url {
 sub ssi {  sub ssi {
   
     my ($fn,%form)=@_;      my ($fn,%form)=@_;
     my $ua=new LWP::UserAgent;  
     my $request;      my $request;
   
     $form{'no_update_last_known'}=1;      $form{'no_update_last_known'}=1;
Line 3037  sub ssi { Line 3150  sub ssi {
     }      }
   
     $request->header(Cookie => $ENV{'HTTP_COOKIE'});      $request->header(Cookie => $ENV{'HTTP_COOKIE'});
     my $response= $ua->request($request);      my $lonhost = $perlvar{'lonHostID'};
     my $content = $response->content;      my $response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar);
   
   
     if (wantarray) {      if (wantarray) {
  return ($content, $response);   return ($response->content, $response);
     } else {      } else {
  return $content;   return $response->content;
     }      }
 }  }
   
 sub externalssi {  sub externalssi {
     my ($url)=@_;      my ($url)=@_;
     my $ua=new LWP::UserAgent;  
     my $request=new HTTP::Request('GET',$url);      my $request=new HTTP::Request('GET',$url);
     my $response=$ua->request($request);      my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar);
     if (wantarray) {      if (wantarray) {
         return ($response->content, $response);          return ($response->content, $response);
     } else {      } else {
Line 3583  sub userfileupload { Line 3694  sub userfileupload {
                          '_'.$env{'user.domain'}.'/pending';                           '_'.$env{'user.domain'}.'/pending';
         } elsif (($context eq 'existingfile') || ($context eq 'canceloverwrite')) {          } elsif (($context eq 'existingfile') || ($context eq 'canceloverwrite')) {
             my ($docuname,$docudom);              my ($docuname,$docudom);
             if ($destudom) {              if ($destudom =~ /^$match_domain$/) {
                 $docudom = $destudom;                  $docudom = $destudom;
             } else {              } else {
                 $docudom = $env{'user.domain'};                  $docudom = $env{'user.domain'};
             }              }
             if ($destuname) {              if ($destuname =~ /^$match_username$/) {
                 $docuname = $destuname;                  $docuname = $destuname;
             } else {              } else {
                 $docuname = $env{'user.name'};                  $docuname = $env{'user.name'};
Line 10956  sub get_domain_ltitools { Line 11067  sub get_domain_ltitools {
         my %domconfig = &get_dom('configuration',['ltitools'],$cdom);          my %domconfig = &get_dom('configuration',['ltitools'],$cdom);
         if (ref($domconfig{'ltitools'}) eq 'HASH') {          if (ref($domconfig{'ltitools'}) eq 'HASH') {
             %ltitools = %{$domconfig{'ltitools'}};              %ltitools = %{$domconfig{'ltitools'}};
               my %encdomconfig = &get_dom('encconfig',['ltitools'],$cdom);
               if (ref($encdomconfig{'ltitools'}) eq 'HASH') {
                   foreach my $id (keys(%ltitools)) {
                       if (ref($encdomconfig{'ltitools'}{$id}) eq 'HASH') {
                           foreach my $item ('key','secret') {
                               $ltitools{$id}{$item} = $encdomconfig{'ltitools'}{$id}{$item};
                           }
                       }
                   }
               }
         }          }
         my $cachetime = 24*60*60;          my $cachetime = 24*60*60;
         &do_cache_new('ltitools',$cdom,\%ltitools,$cachetime);          &do_cache_new('ltitools',$cdom,\%ltitools,$cachetime);
Line 12741  sub repcopy_userfile { Line 12862  sub repcopy_userfile {
     }      }
 # now the path exists for sure  # now the path exists for sure
 # get a user agent  # get a user agent
     my $ua=new LWP::UserAgent;  
     my $transferfile=$file.'.in.transfer';      my $transferfile=$file.'.in.transfer';
 # FIXME: this should flock  # FIXME: this should flock
     if (-e $transferfile) { return 'ok'; }      if (-e $transferfile) { return 'ok'; }
Line 12751  sub repcopy_userfile { Line 12871  sub repcopy_userfile {
     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($homeserver).'/raw/'.$uri);
     my $response=$ua->request($request,$transferfile);      my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,$transferfile,\%perlvar,'',0,1);
 # did it work?  # did it work?
     if ($response->is_error()) {      if ($response->is_error()) {
  unlink($transferfile);   unlink($transferfile);
Line 12795  sub getuploaded { Line 12915  sub getuploaded {
     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($homeserver).'/raw/'.$uri;
     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=&LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,'',0,1);
     $$rtncode = $response->code;      $$rtncode = $response->code;
     if (! $response->is_success()) {      if (! $response->is_success()) {
  return 'failed';   return 'failed';
Line 13085  sub get_dns { Line 13204  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;  
         $ua->timeout(30);  
  my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");   my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
  my $response=$ua->request($request);          my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar,30,0);
         delete($alldns{$dns});          delete($alldns{$dns});
  next if ($response->is_error());   next if ($response->is_error());
  my @content = split("\n",$response->content);   my @content = split("\n",$response->content);
Line 13246  sub fetch_dns_checksums { Line 13363  sub fetch_dns_checksums {
     my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline);      my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline);
     $name=~s/\s//g;      $name=~s/\s//g;
     if ($id && $domain && $role && $name) {      if ($id && $domain && $role && $name) {
                   if ((exists($hostname{$id})) && ($hostname{$id} ne '')) {
                       my $curr = $hostname{$id};
                       my $skip;
                       if (ref($name_to_host{$curr}) eq 'ARRAY') {
                           if (($curr eq $name) && (@{$name_to_host{$curr}} == 1)) {
                               $skip = 1;
                           } else {
                               @{$name_to_host{$curr}} = grep { $_ ne $id } @{$name_to_host{$curr}};
                           }
                       }
                       unless ($skip) {
                           push(@{$name_to_host{$name}},$id);
                       }
                   } else {
                       push(@{$name_to_host{$name}},$id);
                   }
  $hostname{$id}=$name;   $hostname{$id}=$name;
  push(@{$name_to_host{$name}}, $id);  
  $hostdom{$id}=$domain;   $hostdom{$id}=$domain;
  if ($role eq 'library') { $libserv{$id}=$name; }   if ($role eq 'library') { $libserv{$id}=$name; }
                 if (defined($protocol)) {                  if (defined($protocol)) {
Removed from v.1.1343  
changed lines
  Added in v.1.1351

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