Original release 20150615

[fex.git] / htdocs / download / fexsend

diff --git a/htdocs/download/fexsend b/htdocs/download/fexsend
index 607d1391f9de05c5362701ae806199a02d6424a6..a0eabe189aadc858c4d80a7dfa06c5a29ebae23a 100755 (executable)
--- a/htdocs/download/fexsend
+++ b/htdocs/download/fexsend
@@ -37,7 +37,7 @@ our ($tpid,$frecipient);
 our ($FEXID,$FEXXX,$HOME);
 our (%alias);
 our $chunksize = 0;
 our ($FEXID,$FEXXX,$HOME);
 our (%alias);
 our $chunksize = 0;

-our $version = 20150120;
+our $version = 20150615;

 our $_0 = $0;
 our $DEBUG;
 
 our $_0 = $0;
 our $DEBUG;
 


@@ -199,6 +199,10 @@ and then copy-forward it with:
   $0 -b # other\@address
 Where # is the file number.
 
   $0 -b # other\@address
 Where # is the file number.
 

+You can list an uploaded file in more detail with
+  $0 -l #
+Where # is the file number.
+  

 If you want to modify the keep time, comment or auto-delete behaviour of an
 already uploaded file then you first have to query the file number with:
   $0 -l
 If you want to modify the keep time, comment or auto-delete behaviour of an
 already uploaded file then you first have to query the file number with:
   $0 -l


@@ -625,8 +629,10 @@ sub init_id {
   if ($fexcgi =~ /\?/) {
     $from = $1 if $fexcgi =~ /\bfrom=(.+?)(&|$)/i;
     $id   = $1 if $fexcgi =~ /\bid=(.+?)(&|$)/i;
   if ($fexcgi =~ /\?/) {
     $from = $1 if $fexcgi =~ /\bfrom=(.+?)(&|$)/i;
     $id   = $1 if $fexcgi =~ /\bid=(.+?)(&|$)/i;

-    $skey = $1 if $fexcgi =~ /\bskey=(.+?)(&|$)/i;
-    $gkey = $1 if $fexcgi =~ /\bgkey=(.+?)(&|$)/i;
+    # $skey = $1 if $fexcgi =~ /\bskey=(.+?)(&|$)/i;
+    # $gkey = $1 if $fexcgi =~ /\bgkey=(.+?)(&|$)/i;
+    die "$0: cannot use GKEY URL in ID file\n" if $fexcgi =~ /gkey=/i;
+    die "$0: cannot use SKEY URL in ID file\n" if $fexcgi =~ /skey=/i;

     $fexcgi =~ s/\?.*//;
   }
   unless ($fexcgi =~ /^[_:=\w\-\.\/\@\%]+$/) {
     $fexcgi =~ s/\?.*//;
   }
   unless ($fexcgi =~ /^[_:=\w\-\.\/\@\%]+$/) {


@@ -1001,6 +1007,9 @@ sub list {
       else                              { $dkey = '' }
 #      $_ = encode_utf8($_);
       s/<.*?>//g;
       else                              { $dkey = '' }
 #      $_ = encode_utf8($_);
       s/<.*?>//g;

+      s/&amp;/&/g;
+      s/&quot;/\"/g;
+      s/&lt;/</g;

       if (/^(to .* :)/) {
         print "\n$1\n";
         print {$fexlist} "\n$1\n";
       if (/^(to .* :)/) {
         print "\n$1\n";
         print {$fexlist} "\n$1\n";


@@ -1135,7 +1144,6 @@ sub send_fex {
   my @files = ();
   my ($data,$aname,$alias);
   my (@r,$r);
   my @files = ();
   my ($data,$aname,$alias);
   my (@r,$r);

-  my $ma = $HOME.'/.mutt/aliases';

   my $t0 = time;
   my $transferfile;
   my @transferfiles;
   my $t0 = time;
   my $transferfile;
   my @transferfiles;


@@ -1254,38 +1262,18 @@ sub send_fex {
           # $to = $AB{$to};
         } 
         # look for mutt aliases
           # $to = $AB{$to};
         } 
         # look for mutt aliases

-        elsif ($to !~ /@/ and $to ne $from and open $ma,$ma) {
-          $alias = $to;
-          while (<$ma>) {
-            if (/^alias \Q$to\E\s/i) {
-              chomp;
-              s/\s*#.*//;
-              s/\(.*?\)//;
-              s/\s+$//;
-              s/.*\s+//;
-              s/[<>]//g;
-              if (/,/) {
-                warn "$0: ignoring mutt multi-alias $to = $alias\n";
-                last;
-              }
-              if (/@/) {
-                $alias = $_;
-                warn "$0: found mutt alias $to = $alias\n";
-                last;
-              }
-            }
-          }
-          close $ma;
-          $to = $alias;
+        elsif ($to !~ /@/ and $to ne $from) {
+          $to = get_mutt_alias($to);

         }
       }
     }
   
     $to = join(',',grep /./,@to) or exit;
         }
       }
     }
   
     $to = join(',',grep /./,@to) or exit;

-    warn "Server/User: $fexcgi/$from\n" unless $opt_q;
+    # warn "Server/User: $fexcgi/$from\n" unless $opt_q;

   
     if (
       not $skey and not $gkey
   
     if (
       not $skey and not $gkey

+      and $from ne $to

       and $features =~ /CHECKRECIPIENT/ 
       and $opt_C !~ /^(DELETE|LIST|RECEIVEDLOG|SENDLOG|FOPLOG)$/
     ) {
       and $features =~ /CHECKRECIPIENT/ 
       and $opt_C !~ /^(DELETE|LIST|RECEIVEDLOG|SENDLOG|FOPLOG)$/
     ) {


@@ -1497,7 +1485,7 @@ sub send_fex {
 sub forward {
   my (@r);
   my ($to,$n,$dkey,$file,$req);
 sub forward {
   my (@r);
   my ($to,$n,$dkey,$file,$req);

-  my $status = 1;
+  my ($status,$fp);

   local $_;
   
   # look for single @ in arguments
   local $_;
   
   # look for single @ in arguments


@@ -1512,6 +1500,9 @@ sub forward {
   # if ($windoof and not @ARGV) { &inquire }
   $to = pop @ARGV or die $usage;
   $to = $from if $to eq '.';
   # if ($windoof and not @ARGV) { &inquire }
   $to = pop @ARGV or die $usage;
   $to = $from if $to eq '.';

+  if ($to !~ /@/ and $to ne $from) {
+    $to = get_mutt_alias($to);
+  }

 
   open $fexlist,$fexlist or die "$0: $fexlist - $!\n";
   while (<$fexlist>) {
 
   open $fexlist,$fexlist or die "$0: $fexlist - $!\n";
   while (<$fexlist>) {


@@ -1545,16 +1536,12 @@ sub forward {
   $req .= " HTTP/1.1";
   sendheader("$server:$port",$req);
   http_response();
   $req .= " HTTP/1.1";
   sendheader("$server:$port",$req);
   http_response();

+  $fp = $file;
+  $fp =~ s/[^\w_.-]/.+/g; # because of UTF8 filename
+  $status = 1;

   while (<$SH>) { 
   while (<$SH>) { 

-    if ($opt_v) {
-      print;
-      $status = 0 if /\Q"$file"/;
-    } else {
-      if (/\Q"$file"/) {
-        print;
-        $status = 0;
-      }
-    }
+    $status = 0 if /"$fp"/;
+    print if $opt_v or /"$fp"/;

   }
   
   if ($status) {
   }
   
   if ($status) {


@@ -1723,7 +1710,11 @@ sub get_xx {
     if (/^n/i) {
       print "keeping $transferfile\n";
     } else {
     if (/^n/i) {
       print "keeping $transferfile\n";
     } else {

-      system("tar xvf $transferfile && rm $transferfile");
+      my $untar = "tar xvf";
+      # if ($> == 0 and `tar --help 2>&1` =~ /gnu/) {
+      #  $untar = "tar --no-same-owner -xvf";
+      # }
+      system("$untar $transferfile && rm $transferfile");

       die "$0: error while untaring, see $transferfile\n" if -f $transferfile;
     }
   } else {
       die "$0: error while untaring, see $transferfile\n" if -f $transferfile;
     }
   } else {


@@ -2058,8 +2049,11 @@ sub formdatapost {
       
       print $rcamel[0] if ${'opt_+'};
 
       
       print $rcamel[0] if ${'opt_+'};
 

+      $SIG{ALRM} = sub { retry("timed out") };

       while (my $b = read $file,$buf,$bs) {
       while (my $b = read $file,$buf,$bs) {

-        print {$SH} $buf or &sigpipehandler;
+        alarm($timeout*2);
+        syswrite $SH,$buf or &sigpipehandler;
+        alarm(0);

         $bytes += $b;
         if ($filesize > 0 and $bytes+$seek > $filesize) {
           die "$0: $file filesize has grown while uploading\n";
         $bytes += $b;
         if ($filesize > 0 and $bytes+$seek > $filesize) {
           die "$0: $file filesize has grown while uploading\n";


@@ -2611,21 +2605,27 @@ sub ts {
   
 
 sub sigpipehandler {
   
 
 sub sigpipehandler {

-  $SIG{ALRM} = sub { };
+  retry("died");
+}
+
+sub retry {
+  my $reason = shift;
+  local $SIG{ALRM} = sub { };
+  

   if (fileno $SH) {
     alarm(1);
   if (fileno $SH) {
     alarm(1);

-    @_ = <$SH>;
+    my @r = <$SH>;

     alarm(0);
     kill 9,$tpid if $tpid;
     alarm(0);
     kill 9,$tpid if $tpid;

-    if (@_ and $opt_v) {
-      die "\n$0: ($$) server error: @_\n";
+    if (@r and $opt_v) {
+      die "\n$0: ($$) server error: @r\n";

     }
     }

-    if (@_ and $_[0] =~ /^HTTP.* \d+ (.*)/) {
+    if (@r and $r[0] =~ /^HTTP.* \d+ (.*)/) {

       die "\n$0: server error: $1\n";
     }
   }
   $timeout *= 2;
       die "\n$0: server error: $1\n";
     }
   }
   $timeout *= 2;

-  warn "\n$0: connection to $server died\n";
+  warn "\n$0: connection to $server $reason\n";

   warn "retrying after $timeout seconds...\n";
   sleep $timeout;
   if ($windoof) { exec $^X,$0,@_ARGV }
   warn "retrying after $timeout seconds...\n";
   sleep $timeout;
   if ($windoof) { exec $^X,$0,@_ARGV }


@@ -2736,6 +2736,37 @@ sub fileid {
 }
 
 
 }
 
 

+sub get_mutt_alias {
+  my $to = shift;
+  my $ma = $HOME.'/.mutt/aliases';
+  my $alias;
+  local $_;
+  
+  open $ma,$ma or return $to;
+  while (<$ma>) {
+    if (/^alias \Q$to\E\s/i) {
+      chomp;
+      s/\s*#.*//;
+      s/\(.*?\)//;
+      s/\s+$//;
+      s/.*\s+//;
+      s/[<>]//g;
+      if (/,/) {
+        warn "$0: ignoring mutt multi-alias $to = $alias\n";
+        last;
+      }
+      if (/@/) {
+        $alias = $_;
+        warn "$0: found mutt alias $to = $alias\n";
+        last;
+      }
+    }
+  }
+  close $ma;
+  return ($alias||$to);
+}
+
+

 # collect file meta data (filename, inode, mtime)
 sub fmd {
   my @files = @_;
 # collect file meta data (filename, inode, mtime)
 sub fmd {
   my @files = @_;


@@ -2815,6 +2846,7 @@ sub http_response {
   unless (defined $_ and /\w/) {
     die "$0: no response from server\n";
   }
   unless (defined $_ and /\w/) {
     die "$0: no response from server\n";
   }

+  print "<-- $_\n" if $opt_v;

   s/\r?\n//;
   # CGI fatalsToBrowser
   if (/^HTTP.* 500/) {
   s/\r?\n//;
   # CGI fatalsToBrowser
   if (/^HTTP.* 500/) {


@@ -2825,9 +2857,12 @@ sub http_response {
   unless (/^HTTP.* 200/) {
     $error = $_;
     $error =~ s/HTTP.[\s\d.]+//;
   unless (/^HTTP.* 200/) {
     $error = $_;
     $error =~ s/HTTP.[\s\d.]+//;

-    if ($opt_v) {
-      print "<-- $_";
-      print "<-- $_" while <$SH>;
+    @r = <$SH> unless @r;
+    @r = ()    unless @r;
+    foreach (@r) {
+      chomp;
+      $error .= "\n".$_ if /^Location/;
+      print "<-- $_\n" if $opt_v;

     }
     die "$0: server error: $error\n";
   }
     }
     die "$0: server error: $error\n";
   }


@@ -2937,12 +2972,6 @@ sub serverconnect {
   my $connect = "CONNECT $server:$port HTTP/1.1";
   local $_;
   
   my $connect = "CONNECT $server:$port HTTP/1.1";
   local $_;
   

-  if ($opt_v and $port == 443 and %SSL) {
-    foreach my $v (keys %SSL) {
-      printf "%s => %s\n",$v,$SSL{$v};
-    }
-  }
-  

   if ($proxy) {
     tcpconnect(split(':',$proxy));
     if ($port == 443) {
   if ($proxy) {
     tcpconnect(split(':',$proxy));
     if ($port == 443) {


@@ -2954,8 +2983,7 @@ sub serverconnect {
       unless (/^HTTP.1.. 200/) {
         die "$0: proxy error : $_";
       }
       unless (/^HTTP.1.. 200/) {
         die "$0: proxy error : $_";
       }

-      eval "use IO::Socket::SSL";
-      die "$0: cannot load IO::Socket::SSL\n" if $@;
+      &enable_ssl;

       $SH = IO::Socket::SSL->start_SSL($SH,%SSL);
     }
   } else {
       $SH = IO::Socket::SSL->start_SSL($SH,%SSL);
     }
   } else {


@@ -2978,8 +3006,7 @@ sub tcpconnect {
   
   if ($port == 443) {
     # eval "use IO::Socket::SSL qw(debug3)";
   
   if ($port == 443) {
     # eval "use IO::Socket::SSL qw(debug3)";

-    eval "use IO::Socket::SSL";
-    die "$0: cannot load IO::Socket::SSL\n" if $@;
+    &enable_ssl;

     $SH = IO::Socket::SSL->new(
       PeerAddr => $server,
       PeerPort => $port,
     $SH = IO::Socket::SSL->new(
       PeerAddr => $server,
       PeerPort => $port,


@@ -3004,6 +3031,18 @@ sub tcpconnect {
 }
 
 
 }
 
 

+sub enable_ssl {
+  eval "use IO::Socket::SSL";
+  die "$0: cannot load IO::Socket::SSL\n" if $@;
+  eval '$SSL{SSL_verify_mode} = 0 if Net::SSLeay::SSLeay() <= 9470143';
+  if ($opt_v) {
+    foreach my $v (keys %SSL) {
+      printf "%s => %s\n",$v,$SSL{$v};
+    }
+  }
+}
+
+

 sub sendheader {
   my $sp = shift;
   my @head = @_;
 sub sendheader {
   my $sp = shift;
   my @head = @_;