X-Git-Url: https://git.treefish.org/fex.git/blobdiff_plain/7fa382617fbaccc0ce522b2b3adbbee9db5ad227..20150826:/htdocs/download/fexsend diff --git a/htdocs/download/fexsend b/htdocs/download/fexsend index 607d139..e746b66 100755 --- 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 $version = 20150120; +our $version = 20150826; our $_0 = $0; our $DEBUG; @@ -81,10 +81,10 @@ my $atype = ''; # archive type 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 $features = ''; my $timeout = 30; # server timeout my $fexlist = "$tmpdir/fexlist"; my ($usage,$hints); @@ -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 - -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 @@ -142,18 +142,18 @@ EOD $hints = < 1 and $ARGV[-1] =~ /(^|\/)anonymous/) { } else { $fexcgi = $opt_u if $opt_u; - + if (not -e $idf and not ($fexcgi and $from and $id)) { die "$0: no ID file $idf found, use \"fexsend -I\" to create it\n"; } - + unless ($fexcgi) { die "$0: no FEX URL found, use \"$0 -u URL\" or \"$0 -I\"\n"; } - + unless ($from and $id) { die "$0: no sender found, use \"$0 -f FROM:ID\" or \"$0 -I\"\n"; } @@ -494,9 +498,10 @@ $port = 80; $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://}{}; @@ -520,7 +525,7 @@ if ($xx) { $transferfile = "$tmpdir/xx:$1"; shift @ARGV; } - open my $lock,'>>',$transferfile + open my $lock,'>>',$transferfile or die "$0: cannot write $transferfile - $!\n"; flock($lock,LOCK_EX|LOCK_NB) or die "$0: $transferfile is locked by another process\n"; @@ -531,7 +536,7 @@ if ($xx) { &send_xx($transferfile); } exit; -} +} # regular fexsend @@ -555,16 +560,16 @@ unless ($skey or $gkey or $anonymous) { } if ($opt_V and not @ARGV) { exit } -if ($opt_f) { &forward } -elsif ($opt_x) { &modify } -elsif ($opt_N) { &renotify } -elsif ($opt_Q) { &query_quotas } -elsif ($opt_S) { &query_settings } -elsif ($opt_l or $opt_L) { &list } -elsif ($opt_U) { &show_URL } -elsif ($opt_z or $opt_Z or ${'opt_!'}) { &get_log } +if ($opt_f) { &forward } +elsif ($opt_x) { &modify } +elsif ($opt_N) { &renotify } +elsif ($opt_Q) { &query_quotas } +elsif ($opt_S) { &query_settings } +elsif ($opt_l or $opt_L) { &list } +elsif ($opt_U) { &show_URL } +elsif ($opt_z or $opt_Z or ${'opt_!'}) { &get_log } elsif ($opt_A) { edit_address_book($from) } -elsif (${'opt_@'}) { &show_address_book } +elsif (${'opt_@'}) { &show_address_book } elsif ($opt_d and $anonymous) { &purge } elsif ($opt_d and $ARGV[-1] =~ /^\d+$/) { &delete } else { &send_fex } @@ -576,14 +581,14 @@ exit; sub init_id { my $tag; my $proxy = ''; - + if ($opt_I) { $tag = shift @ARGV; die $usage if @ARGV; } - + $fexcgi = $from = $id = ''; - + unless (-d $fexhome) { mkdir $fexhome,0700 or die "$0: cannot create FEXHOME $fexhome - $!\n"; } @@ -616,7 +621,7 @@ sub init_id { } if ($tag and $tag eq '.') { exec $ENV{EDITOR}||'vi',$idf } - + if ($tag) { print "F*EX server URL for [$tag]: " } else { print "F*EX server URL: " } $fexcgi = ; @@ -625,8 +630,10 @@ sub init_id { 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\-\.\/\@\%]+$/) { @@ -636,11 +643,11 @@ sub init_id { print "proxy address (hostname:port or empty if none): "; $proxy = ; $proxy =~ s/[\s\n]//g; - if ($proxy =~ /^[\w.-]+:\d+$/) { + if ($proxy =~ /^[\w.-]+:\d+$/) { $proxy = "!$proxy"; - } elsif ($proxy =~ /\S/) { + } elsif ($proxy =~ /\S/) { die "wrong proxy address format\n"; - } else { + } else { $proxy = ""; } if ($proxy) { @@ -776,12 +783,12 @@ sub send_xx { my $transferfile = shift; my $file = ''; my (@r,@tar); - + $SIG{PIPE} = $SIG{INT} = sub { unlink $transferfile; exit 3; }; - + if ($0 eq 'xxx') { @tar = qw'tar -cv' } else { @tar = qw'tar -cvz' } @@ -791,7 +798,7 @@ sub send_xx { shelldo("cat >> $transferfile"); } elsif (@ARGV) { print "making tar transfer file $transferfile :\n"; - # single file? then add this directly + # single file? then add this directly if (scalar @ARGV == 1) { my ($dir,$file); # strip path if not ending with / @@ -824,10 +831,10 @@ sub send_xx { } die "$0: no transfer file\n" unless -s $transferfile; - + serverconnect($server,$port); query_sid($server,$port); - + @r = formdatapost( from => $from, to => $from, @@ -836,7 +843,7 @@ sub send_xx { comment => 'NOMAIL', autodelete => $transferfile =~ /STDFEX/ ? 'NO' : 'DELAY', ); - + # open P,'|w3m -T text/html -dump' or die "$0: w3m - $!\n"; # print P @r; http_response(@r); @@ -845,7 +852,7 @@ sub send_xx { print "wget -O- $2 | tar xvzf -\n"; } } - + unlink $transferfile; } @@ -860,7 +867,7 @@ sub query_quotas { from => $from, to => $from, id => $sid, - command => $opt_C, + command => $opt_C, ); die "$0: no response from fex server $server\n" unless @r; $_ = shift @r; @@ -899,12 +906,12 @@ sub query_settings { print "auth-ID: $id\n"; print "login URL: "; &show_URL; - + @r = formdatapost( from => $from, to => $from, id => $sid, - command => $opt_C, + command => $opt_C, ); die "$0: no response from fex server $server\n" unless @r; $_ = shift @r; @@ -980,7 +987,7 @@ sub list { @r = formdatapost( from => $from, to => $opt_l ? '*' : $from, - command => $opt_C, + command => $opt_C, ); } die "$0: no response from fex server $server\n" unless @r; @@ -989,7 +996,7 @@ sub list { s:HTTP/[\d\. ]+::; die "$0: server response: $_\n"; } - + # list sent files if ($opt_l) { open $fexlist,">$fexlist" or die "$0: cannot write $fexlist - $!\n"; @@ -1001,6 +1008,9 @@ sub list { else { $dkey = '' } # $_ = encode_utf8($_); s/<.*?>//g; + s/&/&/g; + s/"/\"/g; + s/</ $from, to => $from, id => $sid, - command => $opt_C, + command => $opt_C, ); die "$0: no response from fex server $server\n" unless @r; $_ = shift @r; @@ -1061,7 +1071,7 @@ sub show_address_book { my (%AB,@r); my $alias; local $_; - + %AB = query_address_book($server,$port,$from); foreach $alias (sort keys %AB) { next if $alias eq 'ADDRESS_BOOK'; @@ -1088,7 +1098,7 @@ sub delete { while (@ARGV) { $opt_d = shift @ARGV; die "$usage: $0 -d #\n" if $opt_d !~ /^\d+$/; - + open $fexlist,$fexlist or die "$0: $fexlist - $!\n"; while (<$fexlist>) { if (/^to (.+\@.+) :/) { @@ -1135,12 +1145,11 @@ sub send_fex { my @files = (); my ($data,$aname,$alias); my (@r,$r); - my $ma = $HOME.'/.mutt/aliases'; my $t0 = time; my $transferfile; my @transferfiles; local $_; - + if ($from =~ /^SUBUSER|GROUPMEMBER$/) { $to = '_'; } else { @@ -1176,7 +1185,7 @@ sub send_fex { } } @to = split(',',lc($to)); - + die $usage unless @ARGV or $opt_a or $opt_s; die $usage if $opt_s and @ARGV; @@ -1203,9 +1212,9 @@ sub send_fex { } } elsif ($public) { } else { - + query_sid($server,$port); - + if ($from eq 'SUBUSER') { $skey = $sid; # die "skey=$skey\nid=$id\nsid=$sid\n"; @@ -1214,7 +1223,7 @@ sub send_fex { if ($from eq 'GROUPMEMBER') { $gkey = $sid; } - + if ($to eq '.') { @to = ($from); $opt_C ||= 'NOMAIL'; @@ -1248,45 +1257,25 @@ sub send_fex { } } # alias in server address book? - elsif ($AB{$to}) { - # do not substitute alias with expanded addresses because then + elsif ($AB{$to}) { + # do not substitute alias with expanded addresses because then # keep and autodelete options from address book will get lost # $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; - warn "Server/User: $fexcgi/$from\n" unless $opt_q; - + # warn "Server/User: $fexcgi/$from\n" unless $opt_q; + if ( not $skey and not $gkey - and $features =~ /CHECKRECIPIENT/ + and $from ne $to + and $features =~ /CHECKRECIPIENT/ and $opt_C !~ /^(DELETE|LIST|RECEIVEDLOG|SENDLOG|FOPLOG)$/ ) { checkrecipient($from,$to); @@ -1382,25 +1371,25 @@ sub send_fex { } else { die "$0: unknown archive format \"$atype\"\n"; } - + if (@transferfiles) { - + # error in making transfer archive? if ($?) { unlink @transferfiles; die "$0: $! - aborting upload\n"; } - + # maybe timeout, so make new connect if (time-$t0 >= $timeout) { serverconnect($server,$port); query_sid($server,$port) unless $anonymous; } - + } - + } else { - + unless (@ARGV) { if ($windoof) { &inquire; @@ -1408,7 +1397,7 @@ sub send_fex { die $usage; } } - + foreach (@ARGV) { my $file = $_; unless ($opt_d) { @@ -1433,7 +1422,7 @@ sub send_fex { } } } - + foreach my $file (@files) { sleep 1; # do not overrun server! unless (-s $file or $opt_d or $opt_a or $opt_s) { @@ -1448,7 +1437,7 @@ sub send_fex { file => $file, keep => $opt_k, comment => $opt_C, - autodelete => $opt_D, + autodelete => $opt_D, ); if (not @r or not grep /\w/,@r) { @@ -1479,16 +1468,27 @@ sub send_fex { } if (/^(X-)?(Location.*)/i) { $location = $2; - if ($from eq $to or $from =~ /^\Q$to\E@/i + if ($from eq $to or $from =~ /^\Q$to\E@/i or $nomail or $anonymous or $nonot) { print "$recipient\n"; print "$location\n"; } } } + 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"; + } + } + } } } - + # delete transfer tmp file unlink $transferfile if $transferfile; } @@ -1497,9 +1497,9 @@ sub send_fex { sub forward { my (@r); my ($to,$n,$dkey,$file,$req); - my $status = 1; + my ($status,$fp); local $_; - + # look for single @ in arguments for (my $i=1; $i<$#ARGV; $i++) { if ($ARGV[$i] eq '@') { @@ -1512,6 +1512,9 @@ sub forward { # 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>) { @@ -1526,7 +1529,7 @@ sub forward { } } close $fexlist; - + unless ($n) { die "$0: file #$opt_f not found in fexlist\n"; } @@ -1535,7 +1538,7 @@ sub forward { serverconnect($server,$port); query_sid($server,$port); - + $req = "GET $proxy_prefix/fup?" ."from=$from&ID=$sid&to=$to&dkey=$dkey&command=FORWARD"; $req .= "&comment=$opt_C" if $opt_C; @@ -1545,18 +1548,14 @@ sub forward { $req .= " HTTP/1.1"; sendheader("$server:$port",$req); http_response(); - while (<$SH>) { - if ($opt_v) { - print; - $status = 0 if /\Q"$file"/; - } else { - if (/\Q"$file"/) { - print; - $status = 0; - } - } + $fp = $file; + $fp =~ s/[^\w_.-]/.+/g; # because of UTF8 filename + $status = 1; + while (<$SH>) { + $status = 0 if /"$fp"/; + print if $opt_v or /"$fp"/; } - + if ($status) { die "$0: server failed, rerun command with option -v\n"; } @@ -1580,7 +1579,7 @@ sub renotify { } } close $fexlist; - + unless ($n) { die "$0: file #$opt_N not found in fexlist\n"; } @@ -1589,7 +1588,7 @@ sub renotify { serverconnect($server,$port); query_sid($server,$port); - + $req = "GET $proxy_prefix/fup?" ."from=$from&ID=$sid&dkey=$dkey&command=RENOTIFY" ." HTTP/1.1"; @@ -1604,7 +1603,7 @@ sub renotify { $file = $3; } } - + if ($file) { print "notification e-mail for $file has been resent to $recipient\n"; } else { @@ -1614,7 +1613,7 @@ sub renotify { die "$0: server failed, rerun command with option -v\n"; } } - + exit; } @@ -1623,10 +1622,10 @@ sub modify { my (@r); my ($n,$dkey,$file,$req); local $_; - + die $usage if @ARGV; die $usage unless $opt_C or $opt_k or $opt_D; - + open $fexlist,$fexlist or die "$0: $fexlist - $!\n"; while (<$fexlist>) { if (/^\s*(\d+)\) (\w+) \[\d+ d\] (.+)/ and $1 eq $opt_x) { @@ -1638,16 +1637,16 @@ sub modify { } } close $fexlist; - + unless ($n) { die "$0: file #$opt_x not found in fexlist\n"; } female_mode("modify file #$opt_x?") if $opt_F; - + serverconnect($server,$port); query_sid($server,$port); - + $req = "GET $proxy_prefix/fup?" ."from=$from&ID=$sid&dkey=$dkey&command=MODIFY"; $req .= "&comment=$opt_C" if $opt_C; @@ -1656,14 +1655,14 @@ sub modify { $req .= " HTTP/1.1"; sendheader("$server:$port",$req); http_response(); - while (<$SH>) { + while (<$SH>) { if ($opt_v) { print "<-- $_"; } else { print if /\Q$file/; } } - + exit; } @@ -1672,31 +1671,31 @@ sub get_xx { my $transferfile = shift; my $ft = ''; local $_; - + # get transfer file from FEX server unless ($SH) { serverconnect($server,$port); query_sid($server,$port); } - + xxget($from,$sid,$transferfile); - + # empty file? unless (-s $transferfile) { unlink $transferfile; exit; } - + # no further processing if delivering to pipe exec 'cat',$transferfile unless -t STDOUT; - + if ($ft = `file $transferfile 2>/dev/null`) { if ($ft =~ /compressed/) { rename $transferfile,"$transferfile.gz"; shelldo(ws("gunzip $transferfile.gz")); } $ft = `file $transferfile`; - } + } # file command failed, so we look ourself into the file... elsif (open $transferfile,$transferfile) { read $transferfile,$_,4; @@ -1723,7 +1722,11 @@ sub get_xx { 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 { @@ -1734,7 +1737,7 @@ sub get_xx { sub formdatapost { - my %P = @_; + my %P = @_; my ($boundary,$filename,$filesize,$length,$buf,$file,$fpsize,$resume,$seek); my ($flink); my (@hh,@hb,@r,@pv,$to); @@ -1749,15 +1752,15 @@ sub formdatapost { local $_; if (defined($file = $P{file})) { - + $to = $AB{$P{to}} || $P{to}; # for gpg - + # special file: stream from STDIN if ($opt_s) { $filename = encode_utf8($file); $filesize = -1; } - + # compression? if ($opt_c) { my ($if,$of); @@ -1770,8 +1773,8 @@ sub formdatapost { $filesize = -s $transferfile; die "$0: cannot gzip $file\n" unless $filesize; $file = $transferfile; - } - + } + # special file: tar-on-the-fly if (not $windoof and $opt_a and $file =~ /(.+)\.(tar|tgz)$/) { $aname = $1; @@ -1822,12 +1825,12 @@ sub formdatapost { $file = "$aname.$atype"; $filename = encode_utf8($file); undef $SH; # force reconnect (timeout!) - } - + } + # single file else { $filename = encode_utf8(${'opt_='} || $file); - + if ($windoof) { $filename =~ s/^[a-z]://; $filename =~ s/.*\\//; @@ -1855,14 +1858,14 @@ sub formdatapost { } } } - + } else { $file = $filename = ''; $filesize = 0; } FORMDATAPOST: - + @hh = (); # HTTP header @hb = (); # HTTP body @r = (); @@ -1874,11 +1877,11 @@ sub formdatapost { serverconnect($server,$port); query_sid($server,$port) unless $anonymous; } - + $P{id} = $sid; # ugly hack! - + # ask server if this file has been already sent - if ($file and not $xx and not + if ($file and not $xx and not ($opt_s or $opt_g or $opt_o or $opt_d or $opt_l or $opt_L or ${'opt_/'})) { ($seek,$location) = query_file($server,$port,$frecipient||$P{to},$P{from}, @@ -1897,9 +1900,9 @@ sub formdatapost { serverconnect($server,$port); } } - + # file part size - if ($chunksize and $proxy and $port != 443 + if ($chunksize and $proxy and $port != 443 and $filesize - $seek > $chunksize - $bs) { if ($features !~ /MULTIPOST/) { die sprintf("$0: server does not support chunked multi-POST needed for" @@ -1912,7 +1915,7 @@ sub formdatapost { } $boundary = randstring(48); - + $P{seek} = $seek; $P{filesize} = $filesize; @@ -1935,7 +1938,7 @@ sub formdatapost { push @hb,encode_utf8($P{$v}); } } - + # at last, POST the file if ($file) { push @hb,"--$boundary"; @@ -2000,14 +2003,14 @@ sub formdatapost { sleep 3; goto FORMDATAPOST; # necessary: new $sid ==> new @hh }; - + unless ($opt_d or $flink) { - + $t0 = $t2 = int(time); $tt = $t0-1; $t1 = 0; $tc = 0; - + if ($opt_s) { if ($opt_g) { open $file,"gpg -e -r $to|" or die "$0: cannot run gpg - $!\n"; @@ -2052,14 +2055,21 @@ sub formdatapost { } binmode $file; } - + $bytes = 0; autoflush $SH 0; - + print $rcamel[0] if ${'opt_+'}; + $SIG{ALRM} = sub { retry("timed out") }; 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"; @@ -2104,21 +2114,21 @@ sub formdatapost { } close $file; # or die "$0: error while reading $file - $!\n"; $tt = ($t2-$t0)||1; - + print $rcamel[2] if ${'opt_+'}; - + # terminate tar verbose output job if ($tpid) { sleep 2; kill 9,$tpid; unlink $tarlist; } - + unless ($opt_q) { if (not $chunksize and $bytes+$seek < $filesize) { die "$0: $file filesize has shrunk while uploading\n"; } - + if ($seek or $chunksize and $chunksize < $filesize) { if ($fpsize>2*M) { printf STDERR "%s: %d MB in %d s (%d kB/s)", @@ -2160,13 +2170,13 @@ sub formdatapost { int($bytes/k/$tt); } } - + if (-t STDOUT and not ($opt_s or $opt_g)) { print STDERR "waiting for server ok..." } } } - + autoflush $SH 1; print {$SH} "\r\n--$boundary--\r\n"; @@ -2183,7 +2193,7 @@ sub formdatapost { } return "X-Location: $location\n"; } - + if ($flink) { $bytes = -s $flink; if ($bytes>2*M) { @@ -2198,8 +2208,8 @@ sub formdatapost { } # SuSe: Can't locate object method "BINMODE" via package "IO::Socket::SSL::SSL_HANDLE" - # binmode $SH,':utf8'; - + # binmode $SH,':utf8'; + if (not $opt_q and $file and -t STDOUT) { print STDERR "\r \r"; } @@ -2209,7 +2219,7 @@ sub formdatapost { last if @r and $r[0] =~ / 204 / and /^$/ or /<\/html>/i; push @r,decode_utf8($_); } - + if ($file) { close $SH; undef $SH; @@ -2217,7 +2227,7 @@ sub formdatapost { goto FORMDATAPOST; } } - + return @r; } @@ -2295,7 +2305,7 @@ sub zip { } print $cmd,"\n" if $opt_v; open $cmd,"|$cmd" or die "$0: cannot create $zip - $!\n"; - foreach (@_) { + foreach (@_) { print {$cmd} $_."\n"; print " $_\n" if $opt_v; } @@ -2308,7 +2318,7 @@ sub zip { sub getline { my $file = shift; local $_; - + while (<$file>) { chomp; s/^#.*//; @@ -2328,7 +2338,7 @@ sub query_file { my ($head,$location); my ($response,$fexsrv); local $_; - + $to =~ s/,.*//; $to =~ s/:\w+=.*//; $to = $AB{$to} if $AB{$to}; @@ -2371,7 +2381,7 @@ sub query_file { # return true seek only if file is identified $seek = 0 if $qfileid and $qfileid ne $fileid; - + return ($seek,$location); } @@ -2382,7 +2392,7 @@ sub edit_address_book { my $ab = "$fexhome/ADDRESS_BOOK"; my (%AB,@r); local $_; - + die "$0: address book not available for subusers\n" if $skey; die "$0: address book not available for group members\n" if $gkey; @@ -2390,7 +2400,7 @@ sub edit_address_book { %AB = query_address_book($server,$port,$user); if ($AB{ADDRESS_BOOK} !~ /\w/) { - $AB{ADDRESS_BOOK} = + $AB{ADDRESS_BOOK} = "# Format: alias e-mail-address # Comment\n". "# Example:\n". "framstag framstag\@rus.uni-stuttgart.de\n"; @@ -2398,22 +2408,22 @@ sub edit_address_book { open $ab,">$ab" or die "$0: cannot write to $ab - $!\n"; print {$ab} $AB{ADDRESS_BOOK}; close $ab; - + system $editor,$ab; exit unless -s $ab; $opt_o = $opt_A; - + serverconnect($server,$port); query_sid($server,$port); - + @r = formdatapost( from => $user, to => $user, id => $sid, file => $ab, ); - + unlink $ab,$ab.'~'; } @@ -2428,7 +2438,7 @@ sub query_address_book { serverconnect($server,$port); query_sid($server,$port); } - + $req = "GET $proxy_prefix/fop/$user/$user/ADDRESS_BOOK?ID=$sid HTTP/1.1"; sendheader("$server:$port",$req); $_ = <$SH>; @@ -2455,7 +2465,7 @@ sub query_address_book { last if /^$/; $cl = $1 if /^Content-Length: (\d+)/; } - + if ($cl) { while (<$SH>) { $b += length; @@ -2485,9 +2495,9 @@ sub query_address_book { last if $b >= $cl; } } - + $AB{ADDRESS_BOOK} = $ab; - + return %AB; } @@ -2518,7 +2528,7 @@ sub query_sid { } s/\r//; print "<-- $_" if $opt_v; - + if (/^HTTP.* [25]0[01] /) { if (not $proxy and $port ne 443 and /^HTTP.* 201 (.+)/) { $sid = 'MD5H:'.md5_hex($id.$1); @@ -2545,13 +2555,13 @@ sub query_sid { serverconnect($server,$port); $sid = $id; } - + # warn "proxy: $proxy\n"; if ($proxy) { serverconnect($server,$port); $sid = $id; } - + } @@ -2577,13 +2587,13 @@ sub xxget { } die "$0: no Content-Length in server-reply\n" unless $cl; - + open F,">$save" or die "$0: cannot write to $save - $!\n"; binmode F; - + $t0 = $t1 = int(time); $tso = ''; - + while ($b = read($SH,$_,$bs)) { $B += $b; print F; @@ -2597,7 +2607,7 @@ sub xxget { } sleep 1 while ($opt_m and $B/k/(time-$t0||1) > $opt_m); } - + print STDERR ts($B,$cl),"\n"; close F; } @@ -2608,24 +2618,30 @@ sub ts { my ($b,$tb) = @_; return sprintf("transferred: %d MB (%d%%)",int($b/M),int($b/$tb*100)); } - + sub sigpipehandler { - $SIG{ALRM} = sub { }; + retry("died"); +} + +sub retry { + my $reason = shift; + local $SIG{ALRM} = sub { }; + if (fileno $SH) { alarm(1); - @_ = <$SH>; + my @r = <$SH>; 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; - 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 } @@ -2638,7 +2654,7 @@ sub checkrecipient { my ($from,$to) = @_; my @r; local $_; - + @r = formdatapost( from => $from, to => $to, @@ -2720,11 +2736,11 @@ sub readahead { my $s = 0; my $n; local $_; - - while ($s < $ba) { + + while ($s < $ba) { $n = $ba-$s; - $n = $bs if $n > $bs; - $s += read $fh,$_,$n; + $n = $bs if $n > $bs; + $s += read $fh,$_,$n; } } @@ -2736,12 +2752,43 @@ 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 = @_; my ($file,$dir); my $fmd = ''; - + foreach $file (@files) { if (not -l $file and -d $file) { $dir = $file; @@ -2760,7 +2807,7 @@ sub fmd { $fmd .= $file.fileid($file); } } - + return $fmd; } @@ -2770,7 +2817,7 @@ sub decode_b64 { local $_ = shift; my $uu = ''; my ($i,$l); - + tr|A-Za-z0-9+=/||cd; s/=+$//; tr|A-Za-z0-9+/| -_|; @@ -2815,6 +2862,7 @@ sub http_response { unless (defined $_ and /\w/) { die "$0: no response from server\n"; } + print "<-- $_\n" if $opt_v; s/\r?\n//; # CGI fatalsToBrowser if (/^HTTP.* 500/) { @@ -2825,9 +2873,12 @@ sub http_response { 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"; } @@ -2846,15 +2897,15 @@ sub ws { sub update { my $cfb = '### common functions ###'; my $cfc; - + local $/; - + open $0,$0 or die "cannot read $0 - $!\n"; $_ = <$0>; close $0; s/.*\n$cfb\n//s; $cfc = $_; - + foreach my $p (qw(fexget sexsend)) { open $p,$p or die "cannot read $p - $!\n"; $_ = <$p>; @@ -2891,9 +2942,9 @@ sub get_ssl_env { $SSL{SSL_verify_mode} = $ENV{SSLVERIFY} if defined($ENV{SSLVERIFY}); foreach my $opt (qw( SSL_version - SSL_cipher_list - SSL_verify_mode - SSL_ca_path + SSL_cipher_list + SSL_verify_mode + SSL_ca_path SSL_ca_file) ) { my $env = uc($opt); @@ -2936,16 +2987,10 @@ sub serverconnect { my ($server,$port) = @_; 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 ($https) { printf "--> %s\n",$connect if $opt_v; nvtsend($connect,""); $_ = <$SH>; @@ -2954,14 +2999,13 @@ sub serverconnect { 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); } -# if ($port == 443 and $opt_v) { +# if ($https and $opt_v) { # printf "%s\n",$SH->get_cipher(); # } } @@ -2970,16 +3014,15 @@ sub serverconnect { # set up tcp/ip connection sub tcpconnect { my ($server,$port) = @_; - + if ($SH) { close $SH; undef $SH; } - - if ($port == 443) { + + if ($https) { # 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, @@ -2993,24 +3036,36 @@ sub tcpconnect { Proto => 'tcp', ); } - + if ($SH) { autoflush $SH 1; } else { die "$0: cannot connect $server:$port - $@\n"; } - + print "TCPCONNECT to $server:$port\n" if $opt_v; } +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 = @_; my $head; - + push @head,"Host: $sp"; - + foreach $head (@head) { print "--> $head\n" if $opt_v; print {$SH} $head,"\r\n"; @@ -3022,12 +3077,12 @@ sub sendheader { sub nvtsend { local $SIG{PIPE} = sub { $sigpipe = "@_" }; - + $sigpipe = ''; - + die "$0: internal error: no active network handle\n" unless $SH; die "$0: remote host has closed the link\n" unless $SH->connected; - + foreach my $line (@_) { print {$SH} $line,"\r\n"; if ($sigpipe) { @@ -3035,7 +3090,7 @@ sub nvtsend { return 0; } } - + return 1; } @@ -3045,7 +3100,7 @@ sub encode_b64 { my $res = ""; my $eol = "\n"; my $padding; - + pos($_[0]) = 0; $res = join '',map(pack('u',$_)=~ /^.(\S*)/, ($_[0]=~/(.{1,45})/gs)); $res =~ tr|` -_|AA-Za-z0-9+/|;