[LON-CAPA-cvs] cvs: loncom(version_2_11_X) /lonnet/perl lonnet.pm
raeburn
raeburn at source.lon-capa.org
Tue Jan 21 09:01:55 EST 2020
raeburn Tue Jan 21 14:01:55 2020 EDT
Modified files: (Branch: version_2_11_X)
/loncom/lonnet/perl lonnet.pm
Log:
- For 2.11
Backport 1.1397, 1.1398
Index: loncom/lonnet/perl/lonnet.pm
diff -u loncom/lonnet/perl/lonnet.pm:1.1172.2.119 loncom/lonnet/perl/lonnet.pm:1.1172.2.120
--- loncom/lonnet/perl/lonnet.pm:1.1172.2.119 Mon Jan 20 17:48:49 2020
+++ loncom/lonnet/perl/lonnet.pm Tue Jan 21 14:01:54 2020
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1172.2.119 2020/01/20 17:48:49 raeburn Exp $
+# $Id: lonnet.pm,v 1.1172.2.120 2020/01/21 14:01:54 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -263,9 +263,10 @@
if ($caller eq 'loncron') {
my $ua=new LWP::UserAgent;
$ua->timeout(4);
+ my $hostname = &hostname($lonhost);
my $protocol = $protocol{$lonhost};
$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 $response=$ua->request($request);
unless ($response->is_error()) {
@@ -953,13 +954,13 @@
}
if (!$want_server_name) {
- my $protocol = 'http';
- if ($protocol{$spare_server} eq 'https') {
- $protocol = $protocol{$spare_server};
- }
if (defined($spare_server)) {
my $hostname = &hostname($spare_server);
if (defined($hostname)) {
+ my $protocol = 'http';
+ if ($protocol{$spare_server} eq 'https') {
+ $protocol = $protocol{$spare_server};
+ }
$spare_server = $protocol.'://'.$hostname;
}
}
@@ -3172,13 +3173,13 @@
(grep { $_ eq $homeserver } ¤t_machine_ids())) {
my $fname = &filelocation('',$url);
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);
if ($hostname) {
+ my $protocol = $protocol{$homeserver};
+ $protocol = 'http' if ($protocol ne 'https');
my $uri = $protocol.'://'.$hostname.'/raw/'.&declutter($url);
+ my $ua=new LWP::UserAgent;
+ $ua->timeout(5);
my $request=new HTTP::Request('HEAD',$uri);
my $response=$ua->request($request);
if ($response->is_success()) {
@@ -13013,9 +13014,10 @@
my $request;
$uri=~s/^\///;
my $homeserver = &homeserver($cnum,$cdom);
+ my $hostname = &hostname($homeserver);
my $protocol = $protocol{$homeserver};
$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);
# did it work?
if ($response->is_error()) {
@@ -13039,9 +13041,10 @@
$file=~s|(\?\.*)*$||;
&appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}});
my $homeserver = &homeserver($uname,$udom);
+ my $hostname = &hostname($homeserver);
my $protocol = $protocol{$homeserver};
$protocol = 'http' if ($protocol ne 'https');
- return $protocol.'://'.&hostname($homeserver).'/'.$uri.
+ return $protocol.'://'.$hostname.'/'.$uri.
(($uri=~/\?/)?'&':'?').'token='.$token.
'&tokenissued='.$perlvar{'lonHostID'};
} else {
@@ -13057,9 +13060,10 @@
my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
$uri=~s/^\///;
my $homeserver = &homeserver($cnum,$cdom);
+ my $hostname = &hostname($homeserver);
my $protocol = $protocol{$homeserver};
$protocol = 'http' if ($protocol ne 'https');
- $uri = $protocol.'://'.&hostname($homeserver).'/raw/'.$uri;
+ $uri = $protocol.'://'.$hostname.'/raw/'.$uri;
my $ua=new LWP::UserAgent;
my $request=new HTTP::Request($reqtype,$uri);
my $response=$ua->request($request);
@@ -13234,6 +13238,44 @@
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 $url = $protocol{$lonhost}.'://'.$hostname.'/index.html';
+ my $request=new HTTP::Request('HEAD',$url);
+ my $response=&LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,'','','',1);
+ 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;
+}
+
# ------------------------------------------------------------- Declutters URLs
sub declutter {
More information about the LON-CAPA-cvs
mailing list