version 1.1344, 2017/05/09 03:04:32
|
version 1.1353, 2017/08/27 13:48:52
|
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 2953 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 2965 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 3028 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 3046 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 3069 sub externalssi {
|
Line 3171 sub externalssi {
|
} |
} |
} |
} |
|
|
|
sub remove_stale_resfile { |
|
my ($url) = @_; |
|
my $stale; |
|
if ($url=~m{^/res/($match_domain)/($match_username)/}) { |
|
my $audom = $1; |
|
my $auname = $2; |
|
unless (($url =~ /\.\d+\.\w+$/) || ($url =~ m{^/res/lib/templates/})) { |
|
my $homeserver = &homeserver($auname,$audom); |
|
unless (($homeserver eq 'no_host') || |
|
(grep { $_ eq $homeserver } ¤t_machine_ids())) { |
|
my $fname = &filelocation('',$url); |
|
if (-e $fname) { |
|
my $protocol = $protocol{$homeserver}; |
|
$protocol = 'http' if ($protocol ne 'https'); |
|
my $hostname = &hostname($homeserver); |
|
if ($hostname) { |
|
my $uri = &declutter($url); |
|
my $request=new HTTP::Request('HEAD',$protocol.'://'.$hostname.'/raw/'.$uri); |
|
my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,5,0,1); |
|
if ($response->is_success()) { |
|
my $remmodtime = &HTTP::Date::str2time( $response->header('Last-modified') ); |
|
my $locmodtime = (stat($fname))[9]; |
|
if ($locmodtime < $remmodtime) { |
|
unlink($fname); |
|
if ($uri!~/\.meta$/) { |
|
unlink($fname.'.meta'); |
|
} |
|
&reply("unsub:$fname",$homeserver); |
|
$stale = 1; |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
return $stale; |
|
} |
|
|
# -------------------------------- Allow a /uploaded/ URI to be vouched for |
# -------------------------------- Allow a /uploaded/ URI to be vouched for |
|
|
sub allowuploaded { |
sub allowuploaded { |
Line 3592 sub userfileupload {
|
Line 3733 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 12760 sub repcopy_userfile {
|
Line 12901 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 12770 sub repcopy_userfile {
|
Line 12910 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 12814 sub getuploaded {
|
Line 12954 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 13104 sub get_dns {
|
Line 13243 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 13265 sub fetch_dns_checksums {
|
Line 13402 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)) { |