--- loncom/lonnet/perl/lonnet.pm	2020/01/20 18:05:38	1.1172.2.118.2.2
+++ loncom/lonnet/perl/lonnet.pm	2020/09/08 02:08:27	1.1172.2.118.2.7
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.1172.2.118.2.2 2020/01/20 18:05:38 raeburn Exp $
+# $Id: lonnet.pm,v 1.1172.2.118.2.7 2020/09/08 02:08:27 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -263,9 +263,10 @@ sub get_server_loncaparev {
                 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 @@ sub spareserver {
     }
 
     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;
             }
         }
@@ -1161,6 +1162,28 @@ sub choose_server {
     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
 
 sub changepass {
@@ -3071,6 +3094,27 @@ 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
 sub ssi_body {
     my ($filelink,%form)=@_;
@@ -3197,13 +3241,13 @@ sub remove_stale_resfile {
                     (grep { $_ eq $homeserver } &current_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()) {
@@ -3229,12 +3273,18 @@ sub remove_stale_resfile {
                                     $stale = 1;
                                 }
                                 if ($stale) {
-                                    unlink($fname);
-                                    if ($uri!~/\.meta$/) {
-                                        unlink($fname.'.meta');
+                                    if (unlink($fname)) {
+                                        if ($uri!~/\.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;
                                 }
                             }
                         }
@@ -3384,6 +3434,18 @@ sub can_edit_resource {
                         $forceedit = 1;
                     }
                     $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/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) {
                     $incourse = 1;
                     if ($env{'form.forceedit'}) {
@@ -10220,14 +10282,19 @@ sub writecoursepref {
 
 sub createcourse {
     my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
-        $course_owner,$crstype,$cnum,$context,$category)=@_;
+        $course_owner,$crstype,$cnum,$context,$category,$callercontext)=@_;
     $url=&declutter($url);
     my $cid='';
     if ($context eq 'requestcourses') {
         my $can_create = 0;
         my ($ownername,$ownerdom) = split(':',$course_owner);
         if ($udom eq $ownerdom) {
-            if (&usertools_access($ownername,$ownerdom,$category,undef,
+            my $reload;
+            if (($callercontext eq 'auto') &&
+               ($ownerdom eq $env{'user.domain'}) && ($ownername eq $env{'user.name'})) {
+                $reload = 'reload';
+            }
+            if (&usertools_access($ownername,$ownerdom,$category,$reload,
                                   $context)) {
                 $can_create = 1;
             }
@@ -12335,18 +12402,16 @@ sub symbverify {
 
     if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
                             &GDBM_READER(),0640)) {
-        my $noclutter;
         if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) {
             $thisurl =~ s/\?.+$//;
             if ($map =~ m{^uploaded/.+\.page$}) {
                 $thisurl =~ s{^(/adm/wrapper|)/ext/}{http://};
                 $thisurl =~ s{^\Qhttp://https://\E}{https://};
-                $noclutter = 1;
             }
         }
         my $ids;
-        if ($noclutter) {
-            $ids=$bighash{'ids_'.$thisurl};
+        if ($map =~ m{^uploaded/.+\.page$}) {
+            $ids=$bighash{'ids_'.&clutter_with_no_wrapper($thisurl)};
         } else {
             $ids=$bighash{'ids_'.&clutter($thisurl)};
         }
@@ -13092,9 +13157,10 @@ sub repcopy_userfile {
     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()) {
@@ -13118,9 +13184,10 @@ sub tokenwrapper {
 	$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 {
@@ -13136,9 +13203,10 @@ sub getuploaded {
     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);
@@ -13313,6 +13381,45 @@ sub shared_institution {
     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;
+}
+
 # ------------------------------------------------------------- Declutters URLs
 
 sub declutter {