--- loncom/lontrans.pm	2021/10/08 14:36:51	1.36
+++ loncom/lontrans.pm	2021/11/03 01:04:03	1.37
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # URL translation for User Files
 #
-# $Id: lontrans.pm,v 1.36 2021/10/08 14:36:51 raeburn Exp $
+# $Id: lontrans.pm,v 1.37 2021/11/03 01:04:03 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -105,14 +105,15 @@ sub handler {
                 if (($uri eq '/adm/switchserver') || ($uri =~ m{^/Shibboleth.sso/})) {
                     return DECLINED;
                 }
-                unless ($uri eq '/adm/migrateuser') {
+                unless (($uri eq '/adm/migrateuser') || ($uri eq '/adm/sso')) {
                     my %user;
                     my $handle = &Apache::lonnet::check_for_valid_session($r,undef,\%user);
                     if (($handle) && ($user{'name'} ne '') && ($user{'domain'} ne '')) {
                         unless (($user{'name'} eq 'public') && ($user{'domain'} eq 'public')) {
-                            my $token = &get_token($r,$remote_ip,\%user);
+                            my $dest = '/adm/migrateuser';
+                            my $token = &set_token($r,$dest,$remote_ip,\%user);
                             unless ($token eq '') {
-                                $r->internal_redirect("/adm/migrateuser?token=$token");
+                                $r->internal_redirect("$dest?token=$token");
                                 $r->set_handlers('PerlHandler'=> undef);
                                 return DECLINED;
                             }
@@ -124,19 +125,29 @@ sub handler {
                 if ($port eq '443') {
                     $protocol = 'https';
                 }
-                my $querystring = $r->args;
                 if ($uri =~ m{^(/adm/css/)(.+)(.css)$}) {
                     $uri = $1.&escape($2).$3;
                 }
                 my $location = $protocol.'://'.$redirect.$uri;
-                if ($querystring) {
-                    $location .= "?$querystring";
+                if ($r->uri =~ m{^/tiny/$match_domain/\w+$}) {
+                    my $token = &set_token($r,$r->uri);
+                    unless ($token eq '') {
+                        $location .= '?ttoken='.$token;
+                    }
+                } elsif ($r->args) {
+                    $location .= '?'.$r->args;
                 }
                 $r->header_out(Location => $location);
                 return REDIRECT;
             }
         }
     }
+    if ($r->uri =~ m{^/tiny/$match_domain/\w+$}) {
+        my $token = &set_token($r,$r->uri);
+        unless ($token eq '') {
+            $r->args('ttoken='.$token);
+        }
+    }
     if ($r->uri=~m|^(/raw)?/uploaded/|) {
         my $fn = $r->uri();
         $fn=~s/^\/raw//;
@@ -208,40 +219,83 @@ sub redirect_raw {
     return $redirect;
 }
 
-sub get_token {
-    my ($r,$remote_ip,$userref) = @_;
-    return unless (ref($userref) eq 'HASH');
-    my %user = %{$userref};
-    my %info = ('ip' => $remote_ip,
-                'domain'    => $user{'domain'},
-                'username'  => $user{'name'},
-                'server'    => $r->dir_config('lonHostID'),
-               );
-    my $query = $r->args;
-    if ($query) {
-        foreach my $pair (split(/&/,$query)) {
+sub set_token {
+    my ($r,$dest,$remote_ip,$userref) = @_;
+    my (%info,%user);
+    if ($dest eq '/adm/migrateuser') {
+        return unless (ref($userref) eq 'HASH');
+        %user = %{$userref};
+        %info = ('ip' => $remote_ip,
+                 'domain'    => $user{'domain'},
+                 'username'  => $user{'name'},
+                 'server'    => $r->dir_config('lonHostID'),
+                );
+    }
+    if ($r->args) {
+        foreach my $pair (split(/&/,$r->args)) {
             my ($name,$value) = split(/=/,$pair);
             $name = &LONCAPA::unescape($name);
-            next unless (($name eq 'role') || ($name eq 'symb'));
+            next unless (($name eq 'role') || ($name eq 'symb') ||
+                         ($name eq 'ltoken') || ($name eq 'linkkey') ||
+                         ($name eq 'ttoken'));
             $value =~ tr/+/ /;
             $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
             $info{$name} = $value;
         }
+        if ($info{'ttoken'}) {
+            my %current = &Apache::lonnet::tmpget($info{'ttoken'});
+            delete($info{'ttoken'});
+            if ($current{'origurl'} eq $r->uri) {
+                return if (keys(%current));
+            }
+        }
     }
-    unless ($info{'role'}) {
-        if ($user{'role'} ne '') {
-            $info{'role'} = $user{'role'};
+#
+# To be able to support deep-linking for a shortened URL, i.e.,
+# /tiny/$dom/$id with (a) linkkey included in POSTed data and
+# data and (b) non-Shibboleth SSO in use, ltoken (or linkprot
+# if sending to /adm/migrateuser), or linkkey are written to a
+# .tmp file in /home/httpd/perl/tmp and the query string is
+# replaced with ttoken=tokenid.  This does mean other POSTed
+# data will be discarded.
+#
+    if ($r->uri =~ m{^/tiny/$match_domain/\w+$}) {
+        unless (($info{'ltoken'}) || ($info{'linkkey'} ne '')) {
+            &Apache::lonacc::get_posted_cgi($r,['linkkey']);
+            if ($env{'form.linkkey'} ne '') {
+                $info{'linkkey'} = $env{'form.linkkey'};
+            }
         }
     }
-    unless ($info{'symb'}) {
-        unless ($r->uri eq '/adm/roles') {
-             $info{'origurl'} = $r->uri;
+    if ($dest eq '/adm/migrateuser') {
+        if ($info{'ltoken'}) {
+            my %link_info = &Apache::lonnet::tmpget($info{'ltoken'});
+            if ($link_info{'linkprot'}) {
+                $info{'linkprot'} = $link_info{'linkprot'};
+            }
+            &Apache::lonnet::tmpdel($info{'ltoken'});;
+            delete($info{'ltoken'});
+        }
+        unless ($info{'role'}) {
+            if ($user{'role'} ne '') {
+                $info{'role'} = $user{'role'};
+            }
+        }
+        unless ($info{'symb'}) {
+            unless ($r->uri eq '/adm/roles') {
+                $info{'origurl'} = $r->uri;
+            }
         }
     }
-    my $token = &Apache::lonnet::tmpput(\%info,$r->dir_config('lonHostID'));
-    unless (($token eq 'con_lost') || ($token eq 'refused') ||
-            ($token eq 'unknown_cmd') || ($token eq 'no_such_host')) {
-        return $token;
+    if (($dest eq '/adm/migrateuser') || (keys(%info) > 0)) {
+        unless ($dest eq '/adm/migrateuser') {
+            $info{'origurl'} = $r->uri;
+        }
+        my $token = &Apache::lonnet::tmpput(\%info,$r->dir_config('lonHostID'),'link');
+        unless (($token eq 'con_lost') || ($token eq 'refused') ||
+                ($token eq 'unknown_cmd') || ($token eq 'no_such_host')) {
+            return $token;
+        }
     }
     return;
 }