Original release 20150729

[fex.git] / bin / fexsend

diff --git a/bin/fexsend b/bin/fexsend
index 607d1391f9de05c5362701ae806199a02d6424a6..16235b7746f93a57cff4409813edb58cc2159260 100755 (executable)
--- a/bin/fexsend
+++ b/bin/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 = 20150729;

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


@@ -81,7 +81,7 @@ my $atype = '';               # archive type
 my $fexcgi;            # F*EX CGI URL
 my @files;             # files to send
 my %AB = ();           # server based address book
 my $fexcgi;            # F*EX CGI URL
 my @files;             # files to send
 my %AB = ();           # server based address book

-my ($server,$port,$sid);
+my ($server,$port,$sid,$https);

 my $proxy = '';
 my $proxy_prefix = '';
 my $features = ''; 
 my $proxy = '';
 my $proxy_prefix = '';
 my $features = ''; 


@@ -108,7 +108,7 @@ usage: $0 [options] file(s) [@] recipient(s)
    or: $0 -x \# [-C -k -D -K -S]
 options: -v           verbose mode
          -d           delete file on fex server
    or: $0 -x \# [-C -k -D -K -S]
 options: -v           verbose mode
          -d           delete file on fex server

-         -c           compress file
+         -c           compress file with gzip

          -g           encrypt file with gpg
          -m limit     limit throughput (kB/s)
          -i tag       use ID data [tag] from ID file
          -g           encrypt file with gpg
          -m limit     limit throughput (kB/s)
          -i tag       use ID data [tag] from ID file


@@ -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


@@ -494,9 +498,10 @@ $port = 80;
 $port = 443 if $server =~ s{https://}{};
 $port = $1  if $server =~ s/:(\d+)//;
 
 $port = 443 if $server =~ s{https://}{};
 $port = $1  if $server =~ s/:(\d+)//;
 

-if (0 and $port == 443) {
-  $opt_s and die "$0: cannot use -s with https due to stunnel bug\n"; 
-  $opt_g and die "$0: cannot use -g with https due to stunnel bug\n"; 
+if ($port == 443) {
+  # $opt_s and die "$0: cannot use -s with https due to stunnel bug\n"; 
+  # $opt_g and die "$0: cannot use -g with https due to stunnel bug\n"; 
+  $https = $port;

 }
 
 $server =~ s{http://}{};
 }
 
 $server =~ s{http://}{};


@@ -625,8 +630,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 +1008,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 +1145,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 +1263,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)$/
     ) {


@@ -1486,6 +1475,17 @@ sub send_fex {
           }
         }
       }
           }
         }
       }

+      unless ($opt_d or $location) {
+        if (scalar(@r) == 1) {
+          die "$0: server error: @r\n";
+        } else {
+          if ($r[0] !~ /HTTP.1.. 2/ and $r[0] =~ /HTTP.[\s\d.]+(.+)/) {
+            die "$0: server error: $1\n";
+          } else {
+            die "$0: server error:\n".join("\n",@r)."\n";
+          }
+        }
+      }

     }
   }
   
     }
   }
   


@@ -1497,7 +1497,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 +1512,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 +1548,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 +1722,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 +2061,15 @@ 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);
+        if ($https) {
+          print {$SH} $buf or &sigpipehandler;
+        } else {
+          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 +2621,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 +2752,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 +2862,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 +2873,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,15 +2988,9 @@ 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 ($proxy) {
     tcpconnect(split(':',$proxy));

-    if ($port == 443) {
+    if ($https) {

       printf "--> %s\n",$connect if $opt_v;
       nvtsend($connect,"");
       $_ = <$SH>;
       printf "--> %s\n",$connect if $opt_v;
       nvtsend($connect,"");
       $_ = <$SH>;


@@ -2954,14 +2999,13 @@ 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 {
     tcpconnect($server,$port);
   }
       $SH = IO::Socket::SSL->start_SSL($SH,%SSL);
     }
   } else {
     tcpconnect($server,$port);
   }

-#  if ($port == 443 and $opt_v) {
+#  if ($https and $opt_v) {

 #    printf "%s\n",$SH->get_cipher();
 #  }
 }
 #    printf "%s\n",$SH->get_cipher();
 #  }
 }


@@ -2976,10 +3020,9 @@ sub tcpconnect {
     undef $SH;
   }
   
     undef $SH;
   }
   

-  if ($port == 443) {
+  if ($https) {

     # eval "use IO::Socket::SSL qw(debug3)";
     # 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 +3047,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 = @_;