--- loncom/lonnet/perl/lonnet.pm	2021/05/10 18:13:50	1.1453
+++ loncom/lonnet/perl/lonnet.pm	2021/07/19 15:48:27	1.1461
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.1453 2021/05/10 18:13:50 raeburn Exp $
+# $Id: lonnet.pm,v 1.1461 2021/07/19 15:48:27 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -97,6 +97,7 @@ use Digest::MD5;
 use Math::Random;
 use File::MMagic;
 use Net::CIDR;
+use Sys::Hostname::FQDN();
 use LONCAPA qw(:DEFAULT :match);
 use LONCAPA::Configuration;
 use LONCAPA::lonmetadata;
@@ -8116,7 +8117,7 @@ sub customaccess {
 # ------------------------------------------------- Check for a user privilege
 
 sub allowed {
-    my ($priv,$uri,$symb,$role,$clientip,$noblockcheck,$ignorecache)=@_;
+    my ($priv,$uri,$symb,$role,$clientip,$noblockcheck,$ignorecache,$nodeeplinkcheck,$nodeeplinkout)=@_;
     my $ver_orguri=$uri;
     $uri=&deversion($uri);
     my $orguri=$uri;
@@ -8341,7 +8342,10 @@ sub allowed {
             if ($env{'user.priv.'.$env{'request.role'}.'./'}
                   =~/\Q$priv\E\&([^\:]*)/) {
                 my $value = $1;
-                my $deeplinkblock = &deeplink_check($priv,$symb,$uri);
+                my $deeplinkblock;
+                unless ($nodeeplinkcheck) {
+                    $deeplinkblock = &deeplink_check($priv,$symb,$uri);
+                }
                 if ($deeplinkblock) {
                     $thisallowed='D';
                 } elsif ($noblockcheck) {
@@ -8364,7 +8368,10 @@ sub allowed {
                     $refuri=&declutter($refuri);
                     my ($match) = &is_on_map($refuri);
                     if ($match) {
-                        my $deeplinkblock = &deeplink_check($priv,$symb,$refuri);
+                        my $deeplinkblock;
+                        unless ($nodeeplinkcheck) {
+                            $deeplinkblock = &deeplink_check($priv,$symb,$refuri);
+                        }
                         if ($deeplinkblock) {
                             $thisallowed='D';
                         } elsif ($noblockcheck) {
@@ -8440,7 +8447,13 @@ sub allowed {
                =~/\Q$priv\E\&([^\:]*)/) {
                my $value = $1;
                if ($priv eq 'bre') {
-                   if ($noblockcheck) {
+                   my $deeplinkblock;
+                   unless ($nodeeplinkcheck) {
+                       $deeplinkblock = &deeplink_check($priv,$symb,$uri);
+                   }
+                   if ($deeplinkblock) {
+                       $thisallowed = 'D';
+                   } elsif ($noblockcheck) {
                        $thisallowed.=$value;
                    } else {
                        my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);
@@ -8482,7 +8495,10 @@ sub allowed {
                   =~/\Q$priv\E\&([^\:]*)/) {
                   my $value = $1;
                   if ($priv eq 'bre') {
-                      my $deeplinkblock = &deeplink_check($priv,$symb,$refuri);
+                      my $deeplinkblock;
+                      unless ($nodeeplinkcheck) {
+                          $deeplinkblock = &deeplink_check($priv,$symb,$refuri);
+                      }
                       if ($deeplinkblock) {
                           $thisallowed = 'D';
                       } elsif ($noblockcheck) {
@@ -8530,11 +8546,39 @@ sub allowed {
 #
 
 # Possibly locked functionality, check all courses
+# In roles.tab, L (unless locked) available for bre, pch, plc, pac and sma.
 # Locks might take effect only after 10 minutes cache expiration for other
-# courses, and 2 minutes for current course
+# courses, and 2 minutes for current course, in which user has st or ta role
+# which is neither expired nor a future role (unless current course).
 
+    my ($needlockcheck,$now,$crsonly);
     if ($thisallowed=~/L/) {
-        my $now = time;
+        $now = time;
+        if ($priv eq 'bre') {
+            if ($uri ne '') {
+                if ($orguri =~ m{^/+res/}) {
+                    if ($uri =~ m{^lib/templates/}) {
+                        if ($env{'request.course.id'}) {
+                            $crsonly = 1;
+                            $needlockcheck = 1;
+                        }
+                    } else {
+                        $needlockcheck = 1;
+                    }
+                } elsif ($env{'request.course.id'}) {
+                    my ($crsdom,$crsnum) = split('_',$env{'request.course.id'});
+                    if (($uri =~ m{^(adm|uploaded|public)/$crsdom/$crsnum/}) ||
+                        ($uri =~ m{^adm/$match_domain/$match_username/\d+/(smppg|bulletinboard)$})) {
+                        $crsonly = 1;
+                    }
+                    $needlockcheck = 1;
+                }
+            }
+        } elsif (($priv eq 'pch') || ($priv eq 'plc') || ($priv eq 'pac') || ($priv eq 'sma')) {
+            $needlockcheck = 1;
+        }
+    }
+    if ($needlockcheck) {
         foreach my $envkey (keys(%env)) {
            if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {
                my $courseid=$2;
@@ -8566,7 +8610,7 @@ sub allowed {
                }
                if (($env{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/)
                 || ($env{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {
-		   if ($env{'priv.'.$priv.'.lock.expire'}>time) {
+		   if ($env{$prefix.'priv.'.$priv.'.lock.expire'}>time) {
                        &log($env{'user.domain'},$env{'user.name'},
                             $env{'user.home'},
                             'Locked by priv: '.$priv.' for '.$uri.' due to '.
@@ -8637,6 +8681,17 @@ sub allowed {
        }
    }
 
+# Restricted for deeplinked session?
+
+    if ($env{'request.deeplink.login'}) {
+        if ($env{'acc.deeplinkout'} && !$nodeeplinkout) {
+            if (!$symb) { $symb=&symbread($uri,1); }
+            if (($symb) && ($env{'acc.deeplinkout'}=~/\&\Q$symb\E\&/)) {
+                return '';
+            }
+        }
+    }
+
 # Restricted by state or randomout?
 
    if ($thisallowed=~/X/) {
@@ -8994,29 +9049,9 @@ sub deeplink_check {
         @symbs = keys(%possibles);
     }
 
-    my ($login,$switchrole,$allow);
-    if ($env{'request.deeplink.login'} =~ m{^\Q/tiny/$cdom/\E(\w+)$}) {
-        my $key = $1;
-        my $tinyurl;
-        my ($result,$cached)=&Apache::lonnet::is_cached_new('tiny',$cdom."\0".$key);
-        if (defined($cached)) {
-             $tinyurl = $result;
-        } else {
-             my $configuname = &Apache::lonnet::get_domainconfiguser($cdom);
-             my %currtiny = &Apache::lonnet::get('tiny',[$key],$cdom,$configuname);
-             if ($currtiny{$key} ne '') {
-                 $tinyurl = $currtiny{$key};
-                 &Apache::lonnet::do_cache_new('tiny',$cdom."\0".$key,$currtiny{$key},600);
-             }
-        }
-        if ($tinyurl ne '') {
-            my ($cnumreq,$posslogin) = split(/\&/,$tinyurl);
-            if ($cnumreq eq $cnum) {
-                $login = $posslogin;
-            } else {
-                $switchrole = 1;
-            }
-        }
+    my ($deeplink_symb,$allow);
+    if ($env{'request.deeplink.login'}) {
+        $deeplink_symb = &Apache::loncommon::deeplink_login_symb($cnum,$cdom);
     }
     foreach my $symb (@symbs) {
         last if ($allow);
@@ -9027,16 +9062,30 @@ sub deeplink_check {
             my ($listed,$scope,$access) = split(/,/,$deeplink);
             if ($access eq 'any') {
                 $allow = 1;
-            } elsif ($login) {
+            } elsif ($deeplink_symb) {
                 if ($access eq 'only') {
                     if ($scope eq 'res') {
-                        if ($symb eq $login) {
+                        if ($symb eq $deeplink_symb) {
                             $allow = 1;
                         }
-                    } elsif ($scope eq 'map') {
-#FIXME Compare map for $env{'request.deeplink.login'} with map for $symb
-                    } elsif ($scope eq 'rec') {
-#FIXME Recurse up for $env{'request.deeplink.login'} with map for $symb
+                    } elsif (($scope eq 'map') || ($scope eq 'rec')) {
+                        my ($map_from_symb,$map_from_login); 
+                        $map_from_symb = &deversion((&decode_symb($symb))[0]);
+                        if ($deeplink_symb =~ /\.(page|sequence)$/) {
+                            $map_from_login = &deversion((&decode_symb($deeplink_symb))[2]);
+                        } else {
+                            $map_from_login = &deversion((&decode_symb($deeplink_symb))[0]);
+                        }
+                        if (($map_from_symb) && ($map_from_login)) {
+                            if ($map_from_symb eq $map_from_login) {
+                                $allow = 1;
+                            } elsif ($scope eq 'rec') {
+                                my @recurseup = &get_map_hierarchy($map_from_symb,$env{'request.course.id'});
+                                if (grep(/^\Q$map_from_login\E$/,@recurseup)) {
+                                    $allow = 1;
+                                }
+                            }
+                        }
                     }
                 } else {
                     my ($acctype,$item) = split(/:/,$access);
@@ -9747,6 +9796,38 @@ sub auto_validate_class_sec {
     return $response;
 }
 
+sub auto_instsec_reformat {
+    my ($cdom,$action,$instsecref) = @_;
+    return unless(($action eq 'clutter') || ($action eq 'declutter'));
+    my @homeservers;
+    if (defined(&domain($cdom,'primary'))) {
+        push(@homeservers,&domain($cdom,'primary'));
+    } else {
+        my %servers = &get_servers($cdom,'library');
+        foreach my $tryserver (keys(%servers)) {
+            if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
+                push(@homeservers,$tryserver);
+            }
+        }
+    }
+    my $response;
+    my %reformatted = %{$instsecref};
+    foreach my $server (@homeservers) {
+        if (ref($instsecref) eq 'HASH') {
+            my $info = &freeze_escape($instsecref);
+            my $response=&reply('autoinstsecreformat:'.$cdom.':'.
+                                $action.':'.$info,$server);
+            next if ($response =~ /(con_lost|error|no_such_host|refused|unknown_command)/);
+            my @items = split(/&/,$response);
+            foreach my $item (@items) {
+                my ($key,$value) = split(/=/,$item);
+                $reformatted{&unescape($key)} = &thaw_unescape($value);
+            }
+        }
+    }
+    return %reformatted;
+}
+
 sub auto_validate_instclasses {
     my ($cdom,$cnum,$owners,$classesref) = @_;
     my ($homeserver,%validations);
@@ -12187,7 +12268,7 @@ sub EXT_cache_set {
 # --------------------------------------------------------- Value of a Variable
 sub EXT {
 
-    my ($varname,$symbparm,$udom,$uname,$usection,$recurse,$cid)=@_;
+    my ($varname,$symbparm,$udom,$uname,$usection,$recurse,$cid,$recurseupref)=@_;
     unless ($varname) { return ''; }
     #get real user name/domain, courseid and symb
     my $courseid;
@@ -12341,6 +12422,10 @@ sub EXT {
         }
 
 	my ($section, $group, @groups, @recurseup, $recursed);
+        if (ref($recurseupref) eq 'ARRAY') {
+            @recurseup = @{$recurseupref};
+            $recursed = 1;
+        }
 	my ($courselevelm,$courseleveli,$courselevel,$mapp);
         if (($courseid eq '') && ($cid)) {
             $courseid = $cid;
@@ -14651,14 +14736,33 @@ sub get_dns {
     }
     while (%alldns) {
 	my ($dns) = sort { $b cmp $a } keys(%alldns);
-	my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
-        my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar,30,0);
-        delete($alldns{$dns});
-	next if ($response->is_error());
+        my ($contents,@content);
+        if ($dns eq Sys::Hostname::FQDN::fqdn()) {
+            my $command = (split('/',$url))[3];
+            my ($dir,$file) = &parse_getdns_url($command,$url);
+            delete($alldns{$dns});
+            next if (($dir eq '') || ($file eq ''));
+            if (open(my $config,'<',"$dir/$file")) {
+                @content = <$config>;
+                close($config);
+            }
+            if ($url eq '/adm/dns/loncapaCRL') {
+                $contents = join('',@content);
+            }
+        } else {
+	    my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
+            my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar,30,0);
+            delete($alldns{$dns});
+	    next if ($response->is_error());
+            if ($url eq '/adm/dns/loncapaCRL') {
+                $contents = $response->content;
+            } else {
+                @content = split("\n",$response->content);
+            }
+        }
         if ($url eq '/adm/dns/loncapaCRL') {
-            return &$func($response);
+            return &$func($contents);
         } else {
-	    my @content = split("\n",$response->content);
 	    unless ($nocache) {
 	        &do_cache_new('dns',$url,\@content,30*24*60*60);
 	    }
@@ -14746,14 +14850,14 @@ sub fetch_crl_pemfile {
 }
 
 sub save_crl_pem {
-    my ($response) = @_;
+    my ($content) = @_;
     my ($msg,$hadchanges);
-    if (ref($response)) {
+    if ($content ne '') {
         my $now = time;
         my $lonca = $perlvar{'lonCertificateDirectory'}.'/'.$perlvar{'lonnetCertificateAuthority'};
         my $tmpcrl = $tmpdir.'/'.$perlvar{'lonnetCertRevocationList'}.'_'.$now.'.'.$$.'.tmp';
         if (open(my $fh,'>',"$tmpcrl")) {
-            print $fh $response->content;
+            print $fh $content;
             close($fh);
             if (-e $lonca) {
                 if (open(PIPE,"openssl crl -in $tmpcrl -inform pem -CAfile $lonca -noout 2>&1 |")) {
@@ -14814,6 +14918,24 @@ sub save_crl_pem {
     return ($msg,$hadchanges);
 }
 
+sub parse_getdns_url {
+    my ($command,$url) = @_;
+    my $dir = $perlvar{'lonTabDir'};
+    my $file;
+    if ($command eq 'hosts') {
+        $file = 'dns_hosts.tab';
+    } elsif ($command eq 'domain') {
+        $file = 'dns_domain.tab';
+    } elsif ($command eq 'checksums') {
+        my $version = (split('/',$url))[4];
+        $file = "dns_checksums/$version.tab",
+    } elsif ($command eq 'loncapaCRL') {
+        $dir = $perlvar{'lonCertificateDirectory'};
+        $file = $perlvar{'lonnetCertRevocationList'};
+    }
+    return ($dir,$file);
+}
+
 # ------------------------------------------------------------ Read domain file
 {
     my $loaded;