--- loncom/lonnet/perl/lonnet.pm 2017/02/25 20:30:57 1.1338
+++ loncom/lonnet/perl/lonnet.pm 2017/05/25 23:55:42 1.1346
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1338 2017/02/25 20:30:57 raeburn Exp $
+# $Id: lonnet.pm,v 1.1346 2017/05/25 23:55:42 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -71,7 +71,6 @@ delayed.
package Apache::lonnet;
use strict;
-use LWP::UserAgent();
use HTTP::Date;
use Image::Magick;
@@ -101,6 +100,7 @@ use LONCAPA qw(:DEFAULT :match);
use LONCAPA::Configuration;
use LONCAPA::lonmetadata;
use LONCAPA::Lond;
+use LONCAPA::LWPReq;
use File::Copy;
@@ -243,6 +243,10 @@ sub get_servercerts_info {
if ($1 < 6) {
$uselocal = 0;
}
+ } elsif ($distro =~ /^(?:sles)(\d+)$/) {
+ if ($1 < 12) {
+ $uselocal = 0;
+ }
}
}
if ($uselocal) {
@@ -305,13 +309,11 @@ sub get_server_loncaparev {
$answer = &reply('serverloncaparev',$lonhost);
if (($answer eq 'unknown_cmd') || ($answer eq 'con_lost')) {
if ($caller eq 'loncron') {
- my $ua=new LWP::UserAgent;
- $ua->timeout(4);
my $protocol = $protocol{$lonhost};
$protocol = 'http' if ($protocol ne 'https');
my $url = $protocol.'://'.&hostname($lonhost).'/adm/about.html';
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()) {
my $content = $response->content;
if ($content =~ /<p>VERSION\:\s*([\w.\-]+)<\/p>/) {
@@ -1845,7 +1847,12 @@ sub get_dom {
}
}
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;
if ($rep eq '' || $rep =~ /^error: 2 /) {
return %returnhash;
@@ -1889,7 +1896,11 @@ sub put_dom {
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
}
$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 {
&logthis("put_dom failed - no homeserver and/or domain");
}
@@ -1986,7 +1997,7 @@ sub inst_directory_query {
&escape($srch->{'srchtype'}),$homeserver);
my $host=&hostname($homeserver);
if ($queryid !~/^\Q$host\E\_/) {
- &logthis('instituional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom);
+ &logthis('institutional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.' in domain '.$udom);
return;
}
my $response = &get_query_reply($queryid);
@@ -2269,6 +2280,9 @@ sub get_domain_defaults {
$domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'};
$domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'};
$domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'};
+ $domdefaults{'intauth_cost'} = $domconfig{'defaults'}{'intauth_cost'};
+ $domdefaults{'intauth_switch'} = $domconfig{'defaults'}{'intauth_switch'};
+ $domdefaults{'intauth_check'} = $domconfig{'defaults'}{'intauth_check'};
} else {
$domdefaults{'lang_def'} = &domain($domain,'lang_def');
$domdefaults{'auth_def'} = &domain($domain,'auth_def');
@@ -2941,9 +2955,13 @@ sub repcopy {
mkdir($path,0777);
}
}
- my $ua=new LWP::UserAgent;
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()) {
unlink($transname);
my $message=$response->status_line;
@@ -2953,7 +2971,12 @@ sub repcopy {
} else {
if ($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()) {
unlink($filename.'.meta');
&logthis(
@@ -3016,7 +3039,6 @@ sub absolute_url {
sub ssi {
my ($fn,%form)=@_;
- my $ua=new LWP::UserAgent;
my $request;
$form{'no_update_last_known'}=1;
@@ -3034,22 +3056,20 @@ sub ssi {
}
$request->header(Cookie => $ENV{'HTTP_COOKIE'});
- my $response= $ua->request($request);
- my $content = $response->content;
-
+ my $lonhost = $perlvar{'lonHostID'};
+ my $response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar);
if (wantarray) {
- return ($content, $response);
+ return ($response->content, $response);
} else {
- return $content;
+ return $response->content;
}
}
sub externalssi {
my ($url)=@_;
- my $ua=new LWP::UserAgent;
my $request=new HTTP::Request('GET',$url);
- my $response=$ua->request($request);
+ my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar);
if (wantarray) {
return ($response->content, $response);
} else {
@@ -3195,7 +3215,7 @@ sub can_edit_resource {
$forceedit = 1;
}
$cfile = $resurl;
- } elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/exttools?$}) {
+ } elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) {
$incourse = 1;
if ($env{'form.forceedit'}) {
$forceview = 1;
@@ -3227,7 +3247,7 @@ sub can_edit_resource {
$forceedit = 1;
}
$cfile = $resurl;
- } elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/exttools?$}) && ($env{'form.folderpath'} =~ /^supplemental/)) {
+ } elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) && ($env{'form.folderpath'} =~ /^supplemental/)) {
$incourse = 1;
if ($env{'form.forceedit'}) {
$forceview = 1;
@@ -3245,7 +3265,7 @@ sub can_edit_resource {
} else {
$cfile = $env{'form.suppurl'};
my $escfile = &unescape($cfile);
- if ($escfile =~ m{^/adm/$cdom/$cnum/\d+/exttools?$}) {
+ if ($escfile =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) {
$cfile = '/adm/wrapper'.$escfile;
} else {
$escfile =~ s{^http://}{};
@@ -5804,9 +5824,10 @@ sub rolesinit {
}
}
- @userroles{'user.author', 'user.adv'} = &set_userprivs(\%userroles,
- \%allroles, \%allgroups);
+ @userroles{'user.author','user.adv','user.rar'} = &set_userprivs(\%userroles,
+ \%allroles, \%allgroups);
$env{'user.adv'} = $userroles{'user.adv'};
+ $env{'user.rar'} = $userroles{'user.rar'};
return (\%userroles,\%firstaccenv,\%timerintenv);
}
@@ -5930,6 +5951,7 @@ sub set_userprivs {
my ($userroles,$allroles,$allgroups,$groups_roles) = @_;
my $author=0;
my $adv=0;
+ my $rar=0;
my %grouproles = ();
if (keys(%{$allgroups}) > 0) {
my @groupkeys;
@@ -5977,6 +5999,7 @@ sub set_userprivs {
$thesepriv{$privilege}.=$restrictions;
}
if ($thesepriv{'adv'} eq 'F') { $adv=1; }
+ if ($thesepriv{'rar'} eq 'F') { $rar=1; }
}
}
my $thesestr='';
@@ -5985,7 +6008,7 @@ sub set_userprivs {
}
$userroles->{'user.priv.'.$role} = $thesestr;
}
- return ($author,$adv);
+ return ($author,$adv,$rar);
}
sub role_status {
@@ -6030,9 +6053,10 @@ sub role_status {
push(@rolecodes,$$role);
&standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where);
}
- my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups,\%groups_roles);
+ my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%allroles,\%allgroups,
+ \%groups_roles);
&appenv(\%userroles,\@rolecodes);
- &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);
+ &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec);
}
}
$$tstatus = 'is';
@@ -6151,9 +6175,9 @@ sub set_adhoc_privileges {
} else {
&standard_roleprivs(\%rolehash,$role,$dcdom,$spec,$pickedcourse,$area);
}
- my ($author,$adv)= &set_userprivs(\%userroles,\%rolehash);
+ my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%rolehash);
&appenv(\%userroles,[$role,'cm']);
- &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);
+ &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec);
unless ($caller eq 'constructaccess' && $env{'request.course.id'}) {
&appenv( {'request.role' => $spec,
'request.role.domain' => $dcdom,
@@ -6307,7 +6331,7 @@ sub currentdump {
#
my %returnhash=();
#
- if ($rep eq "unknown_cmd") {
+ if ($rep eq 'unknown_cmd') {
# an old lond will not know currentdump
# Do a dump and make it look like a currentdump
my @tmp = &dumpstore($courseid,$sdom,$sname,'.');
@@ -7241,7 +7265,7 @@ sub allowed {
if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }
# Free bre access to adm and meta resources
- if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$}))
+ if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard|ext\.tool)$}))
|| (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) ))
&& ($priv eq 'bre')) {
return 'F';
@@ -10949,6 +10973,16 @@ sub get_domain_ltitools {
my %domconfig = &get_dom('configuration',['ltitools'],$cdom);
if (ref($domconfig{'ltitools'}) eq 'HASH') {
%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;
&do_cache_new('ltitools',$cdom,\%ltitools,$cachetime);
@@ -11458,7 +11492,7 @@ sub metadata {
# if it is a non metadata possible uri return quickly
if (($uri eq '') ||
(($uri =~ m|^/*adm/|) &&
- ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard|exttools?)$})) ||
+ ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard|ext\.tool)$})) ||
($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {
return undef;
}
@@ -12734,7 +12768,6 @@ sub repcopy_userfile {
}
# now the path exists for sure
# get a user agent
- my $ua=new LWP::UserAgent;
my $transferfile=$file.'.in.transfer';
# FIXME: this should flock
if (-e $transferfile) { return 'ok'; }
@@ -12744,7 +12777,7 @@ sub repcopy_userfile {
my $protocol = $protocol{$homeserver};
$protocol = 'http' if ($protocol ne 'https');
$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?
if ($response->is_error()) {
unlink($transferfile);
@@ -12788,9 +12821,8 @@ sub getuploaded {
my $protocol = $protocol{$homeserver};
$protocol = 'http' if ($protocol ne 'https');
$uri = $protocol.'://'.&hostname($homeserver).'/raw/'.$uri;
- my $ua=new LWP::UserAgent;
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;
if (! $response->is_success()) {
return 'failed';
@@ -12991,7 +13023,7 @@ sub clutter {
# &logthis("Got a blank emb style");
}
}
- } elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/exttools?$}) {
+ } elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/ext\.tool$}) {
$thisfn='/adm/wrapper'.$thisfn;
}
return $thisfn;
@@ -13078,10 +13110,8 @@ sub get_dns {
}
while (%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 $response=$ua->request($request);
+ my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar,30,0);
delete($alldns{$dns});
next if ($response->is_error());
my @content = split("\n",$response->content);
@@ -13263,6 +13293,7 @@ sub fetch_dns_checksums {
&purge_remembered();
&reset_domain_info();
&reset_hosts_ip_info();
+ undef(%internetdom);
undef(%name_to_host);
undef(%hostname);
undef(%hostdom);
@@ -13305,6 +13336,11 @@ sub fetch_dns_checksums {
return %hostdom;
}
+ sub all_host_intdom {
+ &load_hosts_tab() if (!$loaded);
+ return %internetdom;
+ }
+
sub is_library {
&load_hosts_tab() if (!$loaded);