From: fextracker Date: Thu, 27 Aug 2015 02:00:07 +0000 (+0200) Subject: Original release 20150826 X-Git-Tag: 20150826 X-Git-Url: https://git.treefish.org/fex.git/commitdiff_plain/20150826?ds=sidebyside;hp=97b87610331f53e756d032ad21db786037f921a1 Original release 20150826 2015-08-26: fur: fixed bug no registration possible 2015-08-25: fup: fixed bug uninitialized value when called by sup.html 2015-08-25: fac: option -q quota=0 means use default quota 2015-08-24: better detection of UTF8 in comment 2015-08-14: fixed bug "Wide character in print at (...)/fex.pp" in function pq() --- diff --git a/bin/fac b/bin/fac index b17d026..1458ef8 100755 --- a/bin/fac +++ b/bin/fac @@ -43,7 +43,7 @@ unless ($<) { umask 077; # import from fex.pp -our ($FEXHOME,$FHS,$hostname,$spooldir,@logdir,$akeydir,$docdir); +our ($FEXHOME,$FHS,$hostname,$spooldir,@logdir,$logdir,$akeydir,$docdir); our ($durl,@durl,$mdomain,$admin,$mailmode); our ($autodelete,$keep_default,$keep_max,$recipient_quota,$sender_quota); our (@local_rdomains); @@ -79,7 +79,7 @@ warn "WARNING: $spooldir with owner=root !?\n" unless $stat[4]; if (abs_path($spooldir) ne abs_path("$FEXHOME/spool")) { warn "WARNING: \$spooldir differs from $FEXHOME/spool !\n"; } - + getopts('hcvlLwuMRE/q:r:d:a:n:k:m:y:S:C:A:V:D:P:') or usage(2); usage(0) if $opt_h; examples() if $opt_E; @@ -97,7 +97,7 @@ if (${'opt_/'}) { close $aa or die "$0: cannot write $aa - $!\n"; my $fph = "$FEXLIB/fex.ph"; $_ = slurp($fph) or die "$0: cannot read $fph\n"; - s/^\s*\$admin\s*=.*/\$admin = '$admin';/m or + s/^\s*\$admin\s*=.*/\$admin = '$admin';/m or $_ = "\$admin = '$admin';\n".$_; open $fph,">$fph.new" or die "$0: cannot write $fph.new\n"; print {$fph} $_; @@ -159,14 +159,14 @@ if ($opt_m) { if ($opt_M) { my ($mtime,$comment,$file,$keep); local $_; - + if (@ARGV) { foreach $file (glob("@ARGV")) { $mtime = mtime("$file/data") or next; $comment = slurp("$file/comment")||''; next if $comment =~ /NOMAIL/; - $keep = readlink "$file/keep" - || readlink "$file/../../\@KEEP" + $keep = readlink "$file/keep" + || readlink "$file/../../\@KEEP" || $keep_default; $keep = $keep - int((time-mtime("$file/data"))/60/60/24); @@ -198,7 +198,7 @@ if ($opt_M) { # show logfile if ($opt_w) { - $log = $logdir[0]."/fexsrv.log"; + $log = "$logdir/fexsrv.log"; warn "$0: polling $log\n\n"; exec "$FEXHOME/bin/logwatch",$log; die "$0: logwatch not found\n"; @@ -209,8 +209,8 @@ if ($opt_l) { my ($file,$dkey,@L); chdir $spooldir or die "$0: $spooldir - $!\n"; foreach $file (glob "*/*/*") { - if (-s "$file/data" and - $dkey = readlink("$file/dkey") and + if (-s "$file/data" and + $dkey = readlink("$file/dkey") and -l ".dkeys/$dkey" ) { push @L,sprintf "%2\$s --> %1\$s : $durl/$dkey/%3\$s\n",split "/",$file; @@ -225,7 +225,7 @@ if ($opt_L) { my $filter = shift; my ($comment,$file,$keep,$old,$size,$download); local $_; - + foreach $file (glob "*/*/*/data") { next if $file =~ m:(.+?)/: and -l $1; $size = -s $file or next; @@ -238,7 +238,7 @@ if ($opt_L) { $download = join(' & ',split("\n",(slurp("$file/download")||''))); print "\n$file\n"; printf " comment: %s\n",decode_utf8($comment); - printf " size: %s\n",d3($size); + printf " size: %s\n",d3($size); printf " sender ip: %s\n",readlink("$file/ip")||''; printf " expire in: %s days\n",$keep-$old; printf " upload speed: %s kB/s\n",readlink("$file/speed")||0; @@ -248,7 +248,7 @@ if ($opt_L) { exit; } -# delete user +# delete user if ($opt_d) { $idf = "$spooldir/$opt_d/\@"; die "$0: no such user $opt_d\n" unless -f $idf; @@ -297,7 +297,7 @@ if ($opt_r) { EOD } elsif ($opt_r eq 'UPLOAD_HOSTS') { print {$rf}<>$spooldir/$user/\@DISABLED"; - close $user; - print "$user is now disabled\n"; - } elsif (/^n/i) { + $_ = $ARGV[0] || ''; + if (/^no?$/i) { unlink "$spooldir/$user/\@DISABLED"; print "$user is now enabled\n"; } else { - die "usage: $0 -D user yes\n". - "usage: $0 -D user no\n". - "example: $0 -D framstag\@rus.uni-stuttgart.de no\n"; + open $user,">>$spooldir/$user/\@DISABLED"; + print {$user} "@ARGV\n"; + close $user; + print "$user is now disabled\n"; } exit; } @@ -655,14 +652,19 @@ sub showuser { print "login: DELETED\n"; } } + my $disabled = 'no'; + if (-e "$spooldir/$user/\@DISABLED") { + $disabled = slurp("$spooldir/$user/\@DISABLED"); + chomp $disabled; + $disabled ||= 'yes'; + } printf "fex yourself web default: %s\n", -e "$spooldir/$user/\@FEXYOURSELF" ? 'yes' : 'no'; printf "persistent: %s\n", -e "$spooldir/$user/\@PERSISTENT" ? 'yes' : 'no'; printf "captive: %s\n", -e "$spooldir/$user/\@CAPTIVE" ? 'yes' : 'no'; - printf "disabled: %s\n", - -e "$spooldir/$user/\@DISABLED" ? 'yes' : 'no'; + printf "disabled: %s\n",$disabled; printf "recipients restrictions: %s\n", -e "$spooldir/$user/\@ALLOWED_RECIPIENTS" ? 'yes' : 'no'; printf "upload restrictions: %s\n", @@ -702,17 +704,13 @@ sub quota { $squota = $1 if /^s.*:(\d*)/i; } open $qf,'>',$qf or die "$0: cannot write $qf - $!\n"; - print {$qf} "recipient:$rquota\n" if $rquota =~ /\d/; - print {$qf} "sender:$squota\n" if $squota =~ /\d/; + print {$qf} "recipient:$rquota\n" if $rquota; + print {$qf} "sender:$squota\n" if $squota; close $qf; } - $rquota = $recipient_quota if $rquota !~ /\d/; - $squota = $sender_quota if $squota !~ /\d/; - printf "recpient quota (used): %d (%d) MB\n", - check_recipient_quota($user) if $rquota; - printf "sender quota (used): %d (%d) MB\n", - check_sender_quota($user) if $squota; + printf "recpient quota (used): %d (%d) MB\n",check_recipient_quota($user); + printf "sender quota (used): %d (%d) MB\n",check_sender_quota($user); } @@ -721,7 +719,7 @@ sub fupstat { my ($log,$u,$d,$z); my $Z = 0; - if (-t) { $log = $logdir[0].'/fup.log' } + if (-t) { $log = "$logdir/fup.log" } else { $log = '>&=STDIN' } open $log,$log or die "$0: cannot open $log - $!\n"; @@ -758,7 +756,7 @@ sub fopstat { my ($log,$u,$d,$z); my (%user,%domain,%du); - if (-t) { $log = $logdir[0].'/fop.log' } + if (-t) { $log = "$logdir/fop.log" } else { $log = '>&=STDIN' } open $log,$log or die "$0: cannot open $log - $!\n"; @@ -799,7 +797,7 @@ sub cpa { sub check_admin { - + my $admin_id = slurp("$spooldir/$admin/@") or die "$0: no admin account - you have to create it with:\n". "$0 -/ $admin ".randstring(8)."\n"; @@ -824,7 +822,7 @@ sub check_admin { warn "$0: moving $fid to ${fid}_save\n"; rename $fid,$fid.'_save'; } - } + } unless (-f $fid) { mkdir dirname($fid); open $fid,'>',$fid or die "$0: cannot create $fid - $!\n"; @@ -869,7 +867,8 @@ $0 -rr user # edit user recipients restriction $0 -ru user # edit user upload restriction $0 -rd user # edit user download restriction $0 -d user # delete user -$0 -D user [yn] # disable user (yes,no) +$0 -D user "reason" # disable user +$0 -D user "no" # re-enable user $0 -P user [yn] # make user persistent = no account expiration (yes,no) $0 -a user [ynd] # set user autodelete default (yes,no,delay) $0 -n user [dbn] # set user notification default (detailed,brief,no) diff --git a/bin/fbm b/bin/fbm index d285a1e..f1d71d0 100755 --- a/bin/fbm +++ b/bin/fbm @@ -20,7 +20,7 @@ use constant M => 2**20; our ($SH,$windoof,$sigpipe,$useragent); our ($FEXSERVER); -our $version = 20150729; +our $version = 20150826; # server defaults my $server = 'fex.rus.uni-stuttgart.de'; diff --git a/bin/fexget b/bin/fexget index 109c64d..8e00119 100755 --- a/bin/fexget +++ b/bin/fexget @@ -30,7 +30,7 @@ our $SH; our ($fexhome,$idf,$tmpdir,$windoof,$useragent); our ($xv,%autoview); our $bs = 2**16; # blocksize for tcp-reading and writing file -our $version = 20150729; +our $version = 20150826; our $CTYPE = 'ISO-8859-1'; our $fexsend = $ENV{FEXSEND} || 'fexsend'; @@ -115,7 +115,7 @@ SSLCIPHERLIST=HIGH:!3DES # see http://www.openssl.org/docs/apps/ciphers.html You can set these environment variables also in $HOME/.fex/config.pl, as well as the $opt_* variables, e.g.: - + $ENV{SSLVERSION} = 'TLSv1'; ${'opt_+'} = 1; $opt_m = 200; @@ -163,12 +163,12 @@ my $ffl = "$tmpdir/fexget"; # F*EX files list (cache) my @rcamel = ( ' -(_*) _ _ +(_*) _ _ \\\\/ \\/ \\ \ __ )=* - //\\\\//\\\\ + //\\\\//\\\\ ', -' \\\\/\\\\/ +' \\\\/\\\\/ ', ' //\\\\//\\\\ '); @@ -324,7 +324,7 @@ URL: foreach my $url (@ARGV) { exit if $opt_s eq '-'; unlink $download unless -s $download; exit 2 unless -f $download; - + if ($windoof) { print "READY\n"; exit; @@ -346,7 +346,7 @@ URL: foreach my $url (@ARGV) { } unless ($opt_X) { - + foreach my $a (keys %autoview) { if ($download =~ /$a$/i and $autoview{$a}) { printf "run \"%s %s\" [Yn] ? ",$autoview{$a},basename($download); @@ -355,7 +355,7 @@ URL: foreach my $url (@ARGV) { next URL; } } - + if ($ENV{DISPLAY} and $download =~ /\.(gif|jpg|png|tiff?)$/i) { # see also mimeopen and xdg-mime if (my $xv = $xv || pathsearch('xv') || pathsearch('xdg-open')) { @@ -365,11 +365,11 @@ URL: foreach my $url (@ARGV) { next URL; } } - + if ($download =~ /$atype/) { if ($download =~ /\.(tgz|tar.gz)$/) { extract('tar tvzf','tar xvzf') } - elsif ($download =~ /\.tar$/) { extract('tar tvf','tar xvf') } - elsif ($download =~ /\.zip$/i) { extract('unzip -l','unzip') } + elsif ($download =~ /\.tar$/) { extract('tar tvf','tar xvf') } + elsif ($download =~ /\.zip$/i) { extract('unzip -l','unzip') } elsif ($download =~ /\.7z$/i) { extract('7z l','7z x') } else { die "$0: unknown archive \"$download\"\n" } if ($? == 0) { @@ -390,7 +390,7 @@ sub extract { my $d = $download; my $xd = '.'; local $_; - + if (-t and not $windoof) { print "Files in archive:\n"; system(split(' ',$l),$download); @@ -402,7 +402,7 @@ sub extract { if ($xd eq '-') { print "keeping $download\n"; exit; - } + } if ($xd !~ s/!$//) { if (-d $xd) { print "directory $xd does already exist, add \"!\" to overwrite\n"; @@ -469,16 +469,16 @@ sub forward { "GET $uri?COPY HTTP/1.1", "User-Agent: $useragent", ); - + $_ = <$SH>; die "$0: no reply from fex server $server\n" unless $_; warn "<-- $_" if $opt_v; - + unless (/^HTTP.*200/) { s/^HTTP.... \d+ //; die "$0: $_"; } - + while (<$SH>) { s/\r//; last if /^\n/; # ignore HTML output @@ -501,7 +501,7 @@ sub forward { } } close $list; - + if ($n) { $cmd = "fexsend -d $n >/dev/null 2>&1"; print "$cmd\n" if $opt_v; @@ -721,7 +721,7 @@ sub download { } close $SH; close X; - + print $rcamel[2] if ${'opt_+'}; $tt = $t2-$t0; @@ -799,20 +799,20 @@ sub locale { sub pathsearch { my $prg = shift; - + foreach my $dir (split(':',$ENV{PATH})) { return "$dir/$prg" if -x "$dir/$prg"; } } - + sub quote { local $_ = shift; s/([^\w¡-ÿ_%\/=~:.,-])/\\$1/g; return $_; } - + { my $tty; @@ -830,7 +830,7 @@ sub quote { if (defined(&TIOCSTI) and $tty and open($tty,'>',$tty)) { print $prompt; - foreach my $a (split("",$default)) { ioctl($tty,&TIOCSTI,$a) } + foreach my $a (split("",$default)) { ioctl($tty,&TIOCSTI,$a) } chomp($_ = ||''); } else { $prompt =~ s/([\?:=]\s*)/ [$default]$1/ or $prompt .= " [$default]"; @@ -844,8 +844,8 @@ sub quote { } return $_; - } -} + } +} ### common functions ### @@ -869,9 +869,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); @@ -914,13 +914,13 @@ 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) { @@ -948,12 +948,12 @@ sub serverconnect { # set up tcp/ip connection sub tcpconnect { my ($server,$port) = @_; - + if ($SH) { close $SH; undef $SH; } - + if ($port == 443) { # eval "use IO::Socket::SSL qw(debug3)"; eval "use IO::Socket::SSL"; @@ -971,13 +971,13 @@ 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; } @@ -986,9 +986,9 @@ 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"; @@ -1000,12 +1000,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) { @@ -1013,7 +1013,7 @@ sub nvtsend { return 0; } } - + return 1; } @@ -1023,7 +1023,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+/|; diff --git a/bin/fexsend b/bin/fexsend index 16235b7..e746b66 100755 --- a/bin/fexsend +++ b/bin/fexsend @@ -37,7 +37,7 @@ our ($tpid,$frecipient); our ($FEXID,$FEXXX,$HOME); our (%alias); our $chunksize = 0; -our $version = 20150729; +our $version = 20150826; our $_0 = $0; our $DEBUG; @@ -84,7 +84,7 @@ my %AB = (); # server based address book 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); @@ -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"; } @@ -499,8 +499,8 @@ $port = 443 if $server =~ s{https://}{}; $port = $1 if $server =~ s/:(\d+)//; 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"; + # $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; } @@ -525,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"; @@ -536,7 +536,7 @@ if ($xx) { &send_xx($transferfile); } exit; -} +} # regular fexsend @@ -560,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 } @@ -581,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"; } @@ -621,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 = ; @@ -643,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) { @@ -783,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' } @@ -798,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 / @@ -831,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, @@ -843,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); @@ -852,7 +852,7 @@ sub send_xx { print "wget -O- $2 | tar xvzf -\n"; } } - + unlink $transferfile; } @@ -867,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; @@ -906,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; @@ -987,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; @@ -996,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"; @@ -1021,8 +1021,8 @@ sub list { } } close $fexlist; - } - + } + # list received files if ($opt_L) { foreach (@r) { @@ -1049,12 +1049,12 @@ sub show_URL { sub get_log { my (@r); local $_; - + @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; @@ -1071,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'; @@ -1098,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 (.+\@.+) :/) { @@ -1149,7 +1149,7 @@ sub send_fex { my $transferfile; my @transferfiles; local $_; - + if ($from =~ /^SUBUSER|GROUPMEMBER$/) { $to = '_'; } else { @@ -1185,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; @@ -1212,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"; @@ -1223,7 +1223,7 @@ sub send_fex { if ($from eq 'GROUPMEMBER') { $gkey = $sid; } - + if ($to eq '.') { @to = ($from); $opt_C ||= 'NOMAIL'; @@ -1257,25 +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) { $to = get_mutt_alias($to); } } } - + $to = join(',',grep /./,@to) or exit; # warn "Server/User: $fexcgi/$from\n" unless $opt_q; - + if ( not $skey and not $gkey and $from ne $to - and $features =~ /CHECKRECIPIENT/ + and $features =~ /CHECKRECIPIENT/ and $opt_C !~ /^(DELETE|LIST|RECEIVEDLOG|SENDLOG|FOPLOG)$/ ) { checkrecipient($from,$to); @@ -1371,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; @@ -1397,7 +1397,7 @@ sub send_fex { die $usage; } } - + foreach (@ARGV) { my $file = $_; unless ($opt_d) { @@ -1422,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) { @@ -1437,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) { @@ -1468,7 +1468,7 @@ 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"; @@ -1488,7 +1488,7 @@ sub send_fex { } } } - + # delete transfer tmp file unlink $transferfile if $transferfile; } @@ -1499,7 +1499,7 @@ sub forward { my ($to,$n,$dkey,$file,$req); my ($status,$fp); local $_; - + # look for single @ in arguments for (my $i=1; $i<$#ARGV; $i++) { if ($ARGV[$i] eq '@') { @@ -1529,7 +1529,7 @@ sub forward { } } close $fexlist; - + unless ($n) { die "$0: file #$opt_f not found in fexlist\n"; } @@ -1538,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; @@ -1551,11 +1551,11 @@ sub forward { $fp = $file; $fp =~ s/[^\w_.-]/.+/g; # because of UTF8 filename $status = 1; - while (<$SH>) { + while (<$SH>) { $status = 0 if /"$fp"/; print if $opt_v or /"$fp"/; } - + if ($status) { die "$0: server failed, rerun command with option -v\n"; } @@ -1579,7 +1579,7 @@ sub renotify { } } close $fexlist; - + unless ($n) { die "$0: file #$opt_N not found in fexlist\n"; } @@ -1588,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"; @@ -1603,7 +1603,7 @@ sub renotify { $file = $3; } } - + if ($file) { print "notification e-mail for $file has been resent to $recipient\n"; } else { @@ -1613,7 +1613,7 @@ sub renotify { die "$0: server failed, rerun command with option -v\n"; } } - + exit; } @@ -1622,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) { @@ -1637,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; @@ -1655,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; } @@ -1671,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; @@ -1737,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); @@ -1752,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); @@ -1773,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; @@ -1825,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/.*\\//; @@ -1858,14 +1858,14 @@ sub formdatapost { } } } - + } else { $file = $filename = ''; $filesize = 0; } FORMDATAPOST: - + @hh = (); # HTTP header @hb = (); # HTTP body @r = (); @@ -1877,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}, @@ -1900,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" @@ -1915,7 +1915,7 @@ sub formdatapost { } $boundary = randstring(48); - + $P{seek} = $seek; $P{filesize} = $filesize; @@ -1938,7 +1938,7 @@ sub formdatapost { push @hb,encode_utf8($P{$v}); } } - + # at last, POST the file if ($file) { push @hb,"--$boundary"; @@ -2003,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"; @@ -2055,10 +2055,10 @@ sub formdatapost { } binmode $file; } - + $bytes = 0; autoflush $SH 0; - + print $rcamel[0] if ${'opt_+'}; $SIG{ALRM} = sub { retry("timed out") }; @@ -2114,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)", @@ -2170,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"; @@ -2193,7 +2193,7 @@ sub formdatapost { } return "X-Location: $location\n"; } - + if ($flink) { $bytes = -s $flink; if ($bytes>2*M) { @@ -2208,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"; } @@ -2219,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; @@ -2227,7 +2227,7 @@ sub formdatapost { goto FORMDATAPOST; } } - + return @r; } @@ -2305,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; } @@ -2318,7 +2318,7 @@ sub zip { sub getline { my $file = shift; local $_; - + while (<$file>) { chomp; s/^#.*//; @@ -2338,7 +2338,7 @@ sub query_file { my ($head,$location); my ($response,$fexsrv); local $_; - + $to =~ s/,.*//; $to =~ s/:\w+=.*//; $to = $AB{$to} if $AB{$to}; @@ -2381,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); } @@ -2392,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; @@ -2400,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"; @@ -2408,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.'~'; } @@ -2438,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>; @@ -2465,7 +2465,7 @@ sub query_address_book { last if /^$/; $cl = $1 if /^Content-Length: (\d+)/; } - + if ($cl) { while (<$SH>) { $b += length; @@ -2495,9 +2495,9 @@ sub query_address_book { last if $b >= $cl; } } - + $AB{ADDRESS_BOOK} = $ab; - + return %AB; } @@ -2528,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); @@ -2555,13 +2555,13 @@ sub query_sid { serverconnect($server,$port); $sid = $id; } - + # warn "proxy: $proxy\n"; if ($proxy) { serverconnect($server,$port); $sid = $id; } - + } @@ -2587,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; @@ -2607,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; } @@ -2618,7 +2618,7 @@ sub ts { my ($b,$tb) = @_; return sprintf("transferred: %d MB (%d%%)",int($b/M),int($b/$tb*100)); } - + sub sigpipehandler { retry("died"); @@ -2627,7 +2627,7 @@ sub sigpipehandler { sub retry { my $reason = shift; local $SIG{ALRM} = sub { }; - + if (fileno $SH) { alarm(1); my @r = <$SH>; @@ -2654,7 +2654,7 @@ sub checkrecipient { my ($from,$to) = @_; my @r; local $_; - + @r = formdatapost( from => $from, to => $to, @@ -2736,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; } } @@ -2757,7 +2757,7 @@ sub get_mutt_alias { my $ma = $HOME.'/.mutt/aliases'; my $alias; local $_; - + open $ma,$ma or return $to; while (<$ma>) { if (/^alias \Q$to\E\s/i) { @@ -2788,7 +2788,7 @@ sub fmd { my @files = @_; my ($file,$dir); my $fmd = ''; - + foreach $file (@files) { if (not -l $file and -d $file) { $dir = $file; @@ -2807,7 +2807,7 @@ sub fmd { $fmd .= $file.fileid($file); } } - + return $fmd; } @@ -2817,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+/| -_|; @@ -2897,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>; @@ -2942,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); @@ -2987,7 +2987,7 @@ sub serverconnect { my ($server,$port) = @_; my $connect = "CONNECT $server:$port HTTP/1.1"; local $_; - + if ($proxy) { tcpconnect(split(':',$proxy)); if ($https) { @@ -3014,12 +3014,12 @@ sub serverconnect { # set up tcp/ip connection sub tcpconnect { my ($server,$port) = @_; - + if ($SH) { close $SH; undef $SH; } - + if ($https) { # eval "use IO::Socket::SSL qw(debug3)"; &enable_ssl; @@ -3036,13 +3036,13 @@ 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; } @@ -3063,9 +3063,9 @@ 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"; @@ -3077,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) { @@ -3090,7 +3090,7 @@ sub nvtsend { return 0; } } - + return 1; } @@ -3100,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+/|; diff --git a/bin/fexsrv b/bin/fexsrv index 11911ff..6a3e80e 100755 --- a/bin/fexsrv +++ b/bin/fexsrv @@ -11,7 +11,7 @@ use IO::Handle; use Fcntl qw':flock :seek'; use warnings; -BEGIN { +BEGIN { # stunnel workaround $SIG{CHLD} = "DEFAULT"; $ENV{PERLINIT} = q{ @@ -63,7 +63,7 @@ if (@ARGV and $ARGV[0] eq 'stunnel' and $ENV{REMOTE_HOST} =~ /(.+)/) { } # KEEP_ALIVE <== callback from CGI -if ($ENV{KEEP_ALIVE}) { +if ($ENV{KEEP_ALIVE}) { $keep_alive = $ENV{KEEP_ALIVE}; } else { %ENV = ( PERLINIT => $ENV{PERLINIT} ); # clean environment @@ -107,7 +107,7 @@ our $hid = ''; # header ID our @log; $0 = untaint($0); - + $ENV{GATEWAY_INTERFACE} = 'CGI/1.1f'; $ENV{SERVER_NAME} = $hostname; $ENV{REQUEST_METHOD} = ''; @@ -134,12 +134,12 @@ if ($keep_alive) { } $ra = $ENV{REMOTE_ADDR}; $rh = $ENV{REMOTE_HOST}; -} +} # new session else { my $iaddr; - + # HTTPS connect if ($ssl_ra) { $ENV{PROTO} = 'https'; @@ -156,7 +156,7 @@ else { $rh ||= '-'; $port = 443; # print {$log} "X-SSL-Remote-Host: $ssl_ra\n"; - } + } # HTTP connect else { @@ -182,7 +182,7 @@ else { $ENV{REMOTE_HOST} = $rh || ''; - $ENV{HTTP_HOST} = ($port == 80 or $port == 443) + $ENV{HTTP_HOST} = ($port == 80 or $port == 443) ? $hostname : "$hostname:$port"; $ENV{PORT} = $port; @@ -213,7 +213,7 @@ REQUEST: while (*STDIN) { if (defined $ENV{REQUESTCOUNT}) { $ENV{REQUESTCOUNT}++ } else { $ENV{REQUESTCOUNT} = 0 } - + $connect = sprintf "%s:%s %s %s %s [%s_%s]", $keep_alive ? 'CONTINUE' : 'CONNECT', $port, @@ -246,7 +246,7 @@ REQUEST: while (*STDIN) { fexlog($connect,@log,"OVERRUN"); http_error(413); } - + if (/^(GET \/|X-Forwarded-For|User-Agent)/i) { $hid .= $_."\n"; } @@ -265,11 +265,11 @@ REQUEST: while (*STDIN) { exit unless @header; exit if $header =~ /^\s*$/; - + $ENV{HTTP_HEADER} = $header; debuglog($header); # http_die("
$header
"); - + $ENV{'HTTP_HEADER_LENGTH'} = $hl; $ENV{REQUEST_URI} = $uri = ''; $cgi = ''; @@ -281,7 +281,7 @@ REQUEST: while (*STDIN) { badlog("no HTTP request: $request"); exit; } - + if ($force_https and $port != 443 and $request =~ /^(GET|HEAD|POST)\s+(.+)\s+(HTTP\/[\d\.]+$)/i) { $request = $2; @@ -368,7 +368,7 @@ REQUEST: while (*STDIN) { } while ($_ = shift @header) { - + # header inquisition! &$header_hook($connect,$_,$ra) if $header_hook; @@ -383,11 +383,11 @@ REQUEST: while (*STDIN) { if ($header =~ /\nRange:/ and /^User-Agent: (FDM)/) { disconnect($1,"499 Download Manager $1 Not Supported",30); } - + if (/^User-Agent: (Java\/[\d\.]+)/) { disconnect($1,"499 User-Agent $1 Not Supported",30); } - + if (/^Range:.*,/) { disconnect("Range a,b","416 Requested Range Not Satisfiable",30); } @@ -460,7 +460,7 @@ REQUEST: while (*STDIN) { &$header_hook($connect,$header,$ra) if $header_hook; exit unless $cgi; - + # extra download request? (request http://fexserver//xkey) if ($cgi =~ m{^//([^/]+)$}) { my $xkey = $1; @@ -492,7 +492,7 @@ REQUEST: while (*STDIN) { # get locale if (($ENV{QUERY_STRING} =~ /.*locale=([\w-]+)/ or - $ENV{HTTP_COOKIE} =~ /.*locale=([\w-]+)/) + $ENV{HTTP_COOKIE} =~ /.*locale=([\w-]+)/) and -d "$FEXHOME/locale/$1") { $ENV{LOCALE} = $locale = $1; } else { @@ -520,7 +520,7 @@ REQUEST: while (*STDIN) { $locale = $default_locale; } } - + # prepare document file name if ($ENV{REQUEST_METHOD} =~ /^GET|HEAD$/) { if (%redirect) { @@ -622,17 +622,17 @@ REQUEST: while (*STDIN) { bintar(qw'afex asex fexget fexsend xx sexsend sexget sexxx zz ezz'); } # URL ends with ".html!" or ".html?!" - if ($doc =~ s/(\.html)!$/$1/ or - $doc =~ /\.html$/ and $ENV{'QUERY_STRING'} eq '!') + if ($doc =~ s/(\.html)!$/$1/ or + $doc =~ /\.html$/ and $ENV{'QUERY_STRING'} eq '!') { $htmlsource = $doc } else { $htmlsource = '' } - if (-f $doc + if (-f $doc or $doc =~ /(.+)\.(tar|tgz|zip)$/ and lstat("$1.stream") or $doc =~ /(.+)\.tgz$/ and -f "$1.tar" or $doc =~ /(.+)\.gz$/ and -f $1) { unlink "$spooldir/.error/$ra"; - delete $ENV{SCRIPT_FILENAME}; + delete $ENV{SCRIPT_FILENAME}; $ENV{DOCUMENT_FILENAME} = $doc; require "$FEXLIB/dop"; fexlog($connect,@log); @@ -670,7 +670,7 @@ REQUEST: while (*STDIN) { } # neither document nor CGI ==> error - + if ($status) { fexlog($connect,@log,"FAILED to exec $cgi : $status"); http_error(666); @@ -711,7 +711,7 @@ sub getaline { sub fexlog { my @log = @_; - + foreach my $logdir (@logdir) { if (open $log,'>>',"$logdir/$log") { flock $log,LOCK_EX; @@ -727,7 +727,7 @@ sub fexlog { sub badchar { my $bc = shift; - + fexlog($connect,@log,"DISCONNECT: bad characters in URL"); debuglog("DISCONNECT: bad characters in URL $uri"); badlog($request); @@ -738,7 +738,7 @@ sub badchar { sub bintar { my $tmpdir = "$FEXHOME/tmp"; my $fs = "$ENV{PROTO}://$ENV{HTTP_HOST}"; - + if (chdir "$FEXHOME/bin") { fexlog($connect,@log); chdir $fstb if $fstb; @@ -802,7 +802,7 @@ sub disconnect { my $info = shift; my $error = shift; my $wait = shift||0; - + # &$header_hook($connect,$_,$ra) while ($header_hook and $_ = shift @header); fexlog($connect,@log,"DISCONNECT: $info"); debuglog("DISCONNECT: $info"); @@ -818,7 +818,7 @@ sub disconnect { sub http_error_header { my $error = shift; my $uri = $ENV{REQUEST_URI}; - + errorlog("$uri ==> $error") if $uri; nvt_print( "HTTP/1.1 $error", @@ -839,24 +839,24 @@ sub redirect { my $r = shift; my $rr = $redirect{$r}; my $newurl; - + $uri =~ s/\Q$r//; if ($rr =~ s/^!//) { $newurl = $rr.$uri; - nvt_print( - "HTTP/1.1 301 Moved Permanently", - "Location: $newurl", - "Content-Length: 0", - "" - ); + nvt_print( + "HTTP/1.1 301 Moved Permanently", + "Location: $newurl", + "Content-Length: 0", + "" + ); } else { if ($rr =~ /^http/) { $newurl = $rr.$uri; } else { $newurl = "$ENV{PROTO}://$ENV{HTTP_HOST}$rr$uri"; } - + http_header("200 OK"); print html_header("$hostname page has moved"); pq(qq( @@ -877,13 +877,13 @@ sub badlog { my @n; my $ed = "$spooldir/.error"; local $_; - + if (@ignore_error) { foreach (@ignore_error) { return if $request =~ /$_/; } } - + if ($ra and $max_error and $max_error_handler) { mkdir($ed) unless -d $ed; diff --git a/bin/sexsend b/bin/sexsend index 8a2a799..ff3f1ed 100755 --- a/bin/sexsend +++ b/bin/sexsend @@ -12,14 +12,14 @@ use Getopt::Std; use Socket; use IO::Handle; use IO::Socket::INET; -use Digest::MD5 qw(md5_hex); # encypted ID / SID +use Digest::MD5 qw(md5_hex); # encypted ID / SID use constant k => 2**10; use constant M => 2**20; eval 'use Net::INET6Glue::INET_is_INET6'; -our $version = 20150729; +our $version = 20150826; my %SSL = (SSL_version => 'TLSv1'); my $sigpipe; @@ -32,7 +32,7 @@ $0 =~ s:.*/::; $| = 1; # sexsend is default -$usage = +$usage = "usage: ... | $0 [options] [SEX-URL/]recipient [stream]\n". "options: -v verbose mode\n". " -g show transfer rate\n". @@ -43,7 +43,7 @@ $usage = "example: tail -f /var/log/syslog | $0 fex.flupp.org/admin log\n"; if ($0 eq 'sexget' or $0 eq 'fuckme') { - $usage = + $usage = "usage: $0 [options] [[SEX-URL/]user:ID] [stream]\n". "options: -v verbose mode\n". " -g show transfer rate\n". @@ -56,7 +56,7 @@ if ($0 eq 'sexget' or $0 eq 'fuckme') { } if ($0 eq 'sexxx') { - $usage = + $usage = "usage: $0 [-v] [-g] [-c] [-u [SEX-URL/]user] [-s stream] [files...]\n". "usage: $0 [-v] [-g] [-u [SEX-URL/]user] [-s stream] | ...\n". "options: -v verbose mode\n". @@ -102,7 +102,7 @@ $opt_u = $opt_s = $opt_c = $opt_t = ''; $_ = "$fexhome/config.pl"; require if -f; if ($0 eq 'sexxx') { - + # xx server URL, user and auth-ID if ($FEXXX = $ENV{FEXXX}) { $FEXXX = decode_b64($FEXXX) if $FEXXX !~ /\s/; @@ -118,7 +118,7 @@ if ($0 eq 'sexxx') { } close $idf; } - + getopts('hgvcu:s:') or die $usage; die $usage if $opt_h; die $usage unless -t; @@ -140,7 +140,7 @@ if ($0 eq 'sexxx') { unless ($user) { die "$0: no xx user found, use \"$0 -u user\"\n"; } - + } elsif ($0 eq 'sexget' or $0 eq 'fuckme') { getopts('hgvVdu:') or die $usage; die $usage if $opt_h; @@ -150,11 +150,11 @@ if ($0 eq 'sexxx') { print "Version: $version\n"; exit unless @ARGV; } - + if (not $opt_u and @ARGV and $ARGV[0] =~ m{^anonymous|/|:}) { $opt_u = shift @ARGV; } - + if ($opt_u) { $fexcgi = $1 if $opt_u =~ s:(.+)/::; ($user,$id) = split(':',$opt_u); @@ -168,13 +168,13 @@ if ($0 eq 'sexxx') { unless ($fexcgi) { die "$0: no SEX URL found, use \"$0 -u SEX-URL/recipient\" or \"fexsend -I\"\n"; } - + unless ($user) { die "$0: no recipient found, use \"$0 -u SEX-URL/recipient\" or \"fexsend -I\"\n"; } - + } else { # sexsend - + $opt_g = 1; getopts('hguvqVTt:') or die $usage; die $usage if $opt_h; @@ -183,7 +183,7 @@ if ($0 eq 'sexxx') { print "Version: $version\n"; exit unless @ARGV; } - + if ($opt_t and $opt_t =~ /^\d+$/) { $timeout = "&timeout=$opt_t"; } @@ -191,7 +191,7 @@ if ($0 eq 'sexxx') { my $save_user = $user; $user = shift or die $usage; $fexcgi = $1 if $user =~ s:(.+)/::; - + if ($user =~ /^anonymous/) { die "$0: need SEX-URL with anonymous SEX\n" unless $fexcgi; $mode = 'anonymous'; @@ -211,7 +211,7 @@ if ($0 eq 'sexxx') { die "$0: no SEX URL found, use \"$0 SEX-URL/recipient\" or \"fexsend -I\"\n"; } } - + } &get_ssl_env; @@ -220,14 +220,14 @@ $fexcgi =~ s(^http://)()i; $fexcgi =~ s(/fup.*)(); $server = $fexcgi; -if ($server =~ s(^https://)()i) { $port = 443 } -elsif ($server =~ /:(\d+)/) { $port = $1 } -else { $port = 80 } +if ($server =~ s(^https://)()i) { $port = 443 } +elsif ($server =~ /:(\d+)/) { $port = $1 } +else { $port = 80 } $server =~ s([:/].*)(); ## set up tcp/ip connection -# $iaddr = gethostbyname($server) +# $iaddr = gethostbyname($server) # or die "$0: cannot find ip-address for $server $!\n"; # socket(SH,PF_INET,SOCK_STREAM,getprotobyname('tcp')) or die "$0: socket $!\n"; # connect(SH,sockaddr_in($port,$iaddr)) or die "$0: connect $!\n"; @@ -240,21 +240,21 @@ if ($port == 443) { } eval "use IO::Socket::SSL"; die "$0: cannot load IO::Socket::SSL\n" if $@; - $SH = IO::Socket::SSL->new( - PeerAddr => $server, - PeerPort => $port, + $SH = IO::Socket::SSL->new( + PeerAddr => $server, + PeerPort => $port, Proto => 'tcp', %SSL - ); -} else { + ); +} else { $SH = IO::Socket::INET->new( PeerAddr => $server, PeerPort => $port, - Proto => 'tcp', - ); + Proto => 'tcp', + ); } -die "cannot connect $server:$port - $!\n" unless $SH; +die "cannot connect $server:$port - $!\n" unless $SH; warn "TCPCONNECT to $server:$port\n" if $opt_v; # autoflush $SH 1; @@ -331,7 +331,7 @@ request("POST /sex?BS=$bs&user=$user$mode$type$timeout$stream HTTP/1.0"); print STDERR "==> (streaming ...)\n" if $opt_v; transfer(STDIN,$SH); - + exit; @@ -340,7 +340,7 @@ sub transfer { my $destination = shift; my ($t0,$t1,$tt); my ($B,$b,$bt); - + $t0 = $t2 = time; $tt = $t0-1; $t1 = 0; @@ -370,9 +370,9 @@ sub transfer { } die "$0: no stream data\n" unless $B; - + $tt = (time-$t0)||1; - + if ($opt_v or $opt_g) { if ($B>2097152) { printf STDERR "transfered: %d MB in %d s with %d kB/s\n", @@ -385,13 +385,13 @@ sub transfer { $B,$tt,int($B/1024/$tt); } } - + } sub request { my $req = shift; - + print STDERR "==> $req\n" if $opt_v; syswrite $SH,"$req\r\n\r\n"; for (;;) { @@ -456,12 +456,12 @@ sub query_sid { my ($server,$port,$id) = @_; my $req; local $_; - + $req = "GET SID HTTP/1.1"; print STDERR "==> $req\n" if $opt_v; syswrite $SH,"$req\r\n\r\n"; $_ = &getline; - unless (defined $_ and /\w/) { + unless (defined $_ and /\w/) { print STDERR "\n" if $opt_v; die "$0: no response from server\n"; } @@ -469,7 +469,7 @@ sub query_sid { if (/^HTTP.* 201 (.+)/) { print STDERR "<== $_" if $opt_v; $id = 'MD5H:'.md5_hex($id.$1); - while (defined($_ = &getline)) { + while (defined($_ = &getline)) { s/\r//; last if /^\n/; print STDERR "<== $_" if $opt_v; @@ -480,7 +480,7 @@ sub query_sid { return $id; } -sub sigpipehandler { +sub sigpipehandler { local $_ = ''; $SIG{ALRM} = sub { }; alarm(1); @@ -503,15 +503,15 @@ sub getline { local $SIG{ALRM} = sub { die "$0: timeout while waiting for server reply\n" }; alarm($opt_t||300); - + # must use sysread to avoid perl line buffering while (sysread $SH,$c,1) { $line .= $c; last if $c eq "\n"; } - + alarm(0); - + return $line; } @@ -520,7 +520,7 @@ sub decode_b64 { local $_ = shift; my $uu = ''; my ($i,$l); - + tr|A-Za-z0-9+=/||cd; s/=+$//; tr|A-Za-z0-9+/| -_|; @@ -559,9 +559,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); @@ -604,13 +604,13 @@ 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) { @@ -638,12 +638,12 @@ sub serverconnect { # set up tcp/ip connection sub tcpconnect { my ($server,$port) = @_; - + if ($SH) { close $SH; undef $SH; } - + if ($port == 443) { # eval "use IO::Socket::SSL qw(debug3)"; eval "use IO::Socket::SSL"; @@ -661,13 +661,13 @@ 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; } @@ -676,9 +676,9 @@ 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"; @@ -690,12 +690,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) { @@ -703,7 +703,7 @@ sub nvtsend { return 0; } } - + return 1; } @@ -713,7 +713,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+/|; diff --git a/cgi-bin/fac b/cgi-bin/fac index 410eb6b..6a41ab7 100755 --- a/cgi-bin/fac +++ b/cgi-bin/fac @@ -79,7 +79,7 @@ my @backup_files = qw( ); # backup goes first -if ($action eq "backup") { +if ($action eq "backup") { &backup; exit; } @@ -90,14 +90,14 @@ $_ = html_header("F*EX Admin Control for $hostname"); s:: (logout):; print; -my $nav_user = +my $nav_user = "
  • Create new user\n". "
  • Change user auth-ID\n". "
  • Edit user restrictions file\n". "
  • Delete existing user\n". "
  • Manage disk quota\n"; -my $nav_log = +my $nav_log = "
  • Get fup.log\n". "
  • Get fop.log\n". "
  • Get error.log\n"; @@ -109,7 +109,7 @@ if (-f "$logdir/fexsrv.log") { $nav_log; } -my $nav_backup = +my $nav_backup = "
  • Download backup
    (config only)    \n". "
  • Restore backup\n"; @@ -118,8 +118,8 @@ my $nav_show = "
  • Show quotas (sender/recipient)\n". "
  • Show server config\n". "
  • Show user config\n"; - -my $nav_edit = + +my $nav_edit = "
  • Edit config\n". "
  • Edit index.html\n"; @@ -143,24 +143,24 @@ pq(qq( my @user_items = &userList; -if ($action eq "create") { &createUserForm } -elsif ($action eq "change-auth") { &changeAuthForm } -elsif ($action eq "edit") { &editRestrictionsForm } -elsif ($action eq "delete") { &deleteUserForm } -elsif ($action eq "quota") { &changeQuotaForm } +if ($action eq "create") { &createUserForm } +elsif ($action eq "change-auth") { &changeAuthForm } +elsif ($action eq "edit") { &editRestrictionsForm } +elsif ($action eq "delete") { &deleteUserForm } +elsif ($action eq "quota") { &changeQuotaForm } elsif ($action eq "list") { &listFiles } -elsif ($action eq "showquota") { &showQuota } -elsif ($action eq "showconfig") { &showConfig } -elsif ($action eq "userconfig") { &userConfigForm } -elsif ($action eq "watch") { &watchLog } -elsif ($action eq "fexsrv.log") { &getlog("fexsrv.log") } +elsif ($action eq "showquota") { &showQuota } +elsif ($action eq "showconfig") { &showConfig } +elsif ($action eq "userconfig") { &userConfigForm } +elsif ($action eq "watch") { &watchLog } +elsif ($action eq "fexsrv.log") { &getlog("fexsrv.log") } elsif ($action eq "fup.log") { &getlog("fup.log") } -elsif ($action eq "fop.log") { &getlog("fop.log") } -elsif ($action eq "error.log") { &getlog("error.log") } -elsif ($action eq "editconfig") { &editFile("$FEXLIB/fex.ph") } -elsif ($action eq "editindex") { &editFile("$docdir/index.html") } -elsif ($action eq "backup") { &backup } -elsif ($action eq "restore") { &restoreForm } +elsif ($action eq "fop.log") { &getlog("fop.log") } +elsif ($action eq "error.log") { &getlog("error.log") } +elsif ($action eq "editconfig") { &editFile("$FEXLIB/fex.ph") } +elsif ($action eq "editindex") { &editFile("$docdir/index.html") } +elsif ($action eq "backup") { &backup } +elsif ($action eq "restore") { &restoreForm } if (defined $PARAM{"createUser"}) { createUser($PARAM{"createUser"}, $PARAM{"authID"}); @@ -308,7 +308,7 @@ sub editRestrictionsForm { } # formular for choosing user, who shall be removed -# required arguments: - +# required arguments: - sub deleteUserForm { my @option = map { "\n" } @user_items; @@ -333,7 +333,7 @@ sub changeQuotaForm { my @option; my $rquota = ''; my $squota = ''; - + if ($user = $PARAM{"user"}) { $user = normalize_user($user); @@ -398,21 +398,21 @@ sub restoreForm { sub createUser { my ($user,$id) = @_; my $idf; - + http_die("not enough arguments in createUser") unless $id; - + $user = normalize_user($user); unless (-d "$user") { mkdir "$user",0755 or http_die("cannot mkdir $user - $!"); } - + $idf = "$user/@"; if (-f $idf) { html_error($error,"There is already an user $user!"); } - + open $idf,'>',$idf or http_die("cannot write $idf - $!"); print {$idf} $id,"\n"; close $idf or http_die("cannot write $idf - $!"); @@ -429,15 +429,15 @@ sub createUser { # required arguments: username, auth-id sub changeUser { my ($user,$id) = @_; - + http_die("not enough arguments in changeUser") unless $id; - + $id = despace($id); $user = normalize_user($user); my $idf = "$user/@"; print "\n"; print "$idf

    "; - + open $idf,'>',$idf or http_die("cannot write $idf - $!"); print {$idf} $id,"\n"; close $idf or http_die("cannot write $idf - $!"); @@ -456,7 +456,7 @@ sub showUserConfig { http_die("not enough arguments in showUserConfig!") unless $user; $user = normalize_user($user); - + chdir "$user" or http_die("could not change directory $user - $!"); print h2("Config files of $user"); @@ -478,7 +478,7 @@ sub showUserConfig { sub editUser { my $user = shift; my $content; - + http_die("not enough arguments in editUser") unless $user; $user = normalize_user($user); http_die("no user $user") unless -d $user; @@ -511,7 +511,7 @@ EOD # required arguments: list of Files sub deleteFiles { http_die("not enough arguments in deleteFiles") unless (my @files = @_); - + foreach (@files) { if (-e) { if (unlink $_) { @@ -531,9 +531,9 @@ sub deleteFiles { sub saveFile { my ($rf,$ar) = @_; my $new; - + http_die("not enough arguments in saveFile") unless $ar; - + if ($ar eq 'index.html') { $ar = "$docdir/index.html" } elsif ($ar eq 'fex.ph') { @@ -543,7 +543,7 @@ sub saveFile { } else { http_die("unknown file $ar") } - + $new = $ar.'_new'; if ($ar =~ /fex.ph$/) { open $new,'>',$new or http_die("cannot open ${ar}_new - $!"); @@ -601,7 +601,7 @@ sub alterQuota { $user = normalize_user($user); http_die("$user is not a F*EX user") unless -d $user; - + $rquota = $squota = ''; $qf = "$user/\@QUOTA"; if (open $qf,$qf) { @@ -612,14 +612,14 @@ sub alterQuota { } close $qf; } - + $rquota = $1 if $rq and $rq =~ /(\d+)/; $squota = $1 if $sq and $sq =~ /(\d+)/; open $qf,'>',$qf or http_die("cannot write $qf - $!"); print {$qf} "recipient:$rquota\n" if $rquota; print {$qf} "sender:$squota\n" if $squota; close $qf or http_die("cannot write $qf - $!"); - + $rquota = $recipient_quota unless $rquota; $squota = $sender_quota unless $squota; print h3("New quotas for $user"); @@ -653,7 +653,7 @@ sub listFiles { sub watchLog { if (-f "$logdir/fexsrv.log") { print h2("polling fexsrv.log"),"\n"; - open my $log,"$FEXHOME/bin/logwatch|" + open my $log,"$FEXHOME/bin/logwatch|" or http_die("cannot run $FEXHOME/bin/logwatch - $!"); dumpfile($log); } else { @@ -666,7 +666,7 @@ sub watchLog { # required arguments: logfile-name sub getlog { my $log = shift or http_die("not enough arguments in getLog"); - + print h2("show $log"); if (open $log,"$logdir/$log") { dumpfile($log); @@ -688,19 +688,19 @@ sub backup { my $home = $FEXHOME; $home = $1 if $ENV{VHOST} and $ENV{VHOST} =~ /:(.+)/; - + chdir $home or http_die("$home - $!"); - + unless (-d "backup") { mkdir "backup",0700 or http_die("cannot mkdir backup - $!"); } - + system "tar -cf $backup @backup_files 2>/dev/null"; - + $size = -s $backup or http_die("backup file empty"); - + open $backup,'<',$backup or http_die("cannot open $backup - $!"); - + nvt_print( 'HTTP/1.1 200 OK', "Content-Length: $size", @@ -708,11 +708,11 @@ sub backup { "Content-Disposition: attachment; filename=\"fex-backup-$date.tar\"", "", ); - + while (read($backup,my $b,$bs)) { print $b or last; } - + exit; } @@ -752,9 +752,9 @@ sub restore { sub editFile { my $ar = shift; my $file; - + $file = dehtml(slurp($ar)); - + $ar =~ s:.*/::; print h2("edit $ar"); @@ -864,7 +864,7 @@ sub require_akey { } elsif ($akey) { # correct akey? return if $akey eq md5_hex("$admin:$rid"); - } + } http_header('200 OK'); print html_header("F*EX Admin Control for $hostname"); @@ -898,10 +898,10 @@ sub require_akey { # function for checking simple HTTP authentication # (not used any more, replaced with require_akey) sub require_auth { - if ($ENV{HTTP_AUTHORIZATION} and $ENV{HTTP_AUTHORIZATION} =~ /Basic\s+(.+)/) + if ($ENV{HTTP_AUTHORIZATION} and $ENV{HTTP_AUTHORIZATION} =~ /Basic\s+(.+)/) { @http_auth = split(':',decode_b64($1)) } if ( - @http_auth != 2 + @http_auth != 2 or $http_auth[0] !~ /^(fexmaster|admin|\Q$admin\E)$/ or $http_auth[1] ne $admin_pw ) { @@ -965,15 +965,15 @@ sub domainsort { s/@/@./; $_ = join('.',reverse(split /\./)); } - + @d = sort { lc $a cmp lc $b } @d; - + foreach (@d) { $_ = join('.',reverse(split /\./)); s/,/./g; s/@\./@/; } - + return @d; } @@ -983,12 +983,12 @@ sub userList { my (@u,@list); my $domain = ''; my $u; - + foreach $u (glob('*@*')) { next if -l $u; push @u,$u if -f "$u/@"; } - + foreach (domainsort(@u)) { if (/@(.+)/) { if ($1 ne $domain) { @@ -998,14 +998,14 @@ sub userList { $domain = $1; } } - + return @list; } sub dumpfile { my $file = shift; - + print "

    \n";
   while (<$file>) { print dehtml($_) }
   print "\n
    \n"; diff --git a/cgi-bin/foc b/cgi-bin/foc index f384784..daf83f3 100755 --- a/cgi-bin/foc +++ b/cgi-bin/foc @@ -24,7 +24,7 @@ my $error = 'F*EX operation control ERROR'; chdir $spooldir or die "$spooldir - $!\n"; -$akeydir = "$spooldir/.akeys"; +$akeydir = "$spooldir/.akeys"; $user = $id = ''; # look for CGI parameters @@ -33,7 +33,7 @@ our %PARAM; foreach my $v (keys %PARAM) { my $vv = $PARAM{$v}; # debuglog("Param: $v=\"$vv\""); - if ($v =~ /^akey$/i and $vv =~ /^(\w+)$/) { + if ($v =~ /^akey$/i and $vv =~ /^(\w+)$/) { $akey = $1; } elsif ($v =~ /^(from|user)$/i) { $user = normalize_email($vv); diff --git a/cgi-bin/fop b/cgi-bin/fop index a0eb824..fb37261 100755 --- a/cgi-bin/fop +++ b/cgi-bin/fop @@ -90,11 +90,11 @@ if ($file =~ m:^([^/]+)/[^/]+$:) { if ($ENV{REQUEST_METHOD} eq 'GET' and $file =~ m:.+/(.+)/.+:) { $from = lc $1; - if (-s "$from/\@ALLOWED_RECIPIENTS") { + if (-s "$from/\@ALLOWED_RECIPIENTS") { http_die("$from is a restricted user"); } } - + # add mail-domain to addresses if necessary if ($mdomain and $file =~ s:(.+)/(.+)/(.+):$3:) { $to = lc $1; @@ -140,7 +140,7 @@ if ($qs = $ENV{QUERY_STRING}) { # workaround for broken F*IX $qs =~ s/&ID=skey:\w+//; - + # subuser with skey? if ($qs =~ s/&*SKEY=([\w:]+)//i) { $skey = $1; @@ -172,7 +172,7 @@ if ($qs = $ENV{QUERY_STRING}) { http_die("wrong SKEY authentification"); } } - + # group member with gkey? if ($qs =~ s/&*GKEY=([\w:]+)//i) { $gkey = $1; @@ -213,12 +213,12 @@ if ($qs = $ENV{QUERY_STRING}) { http_die("wrong GKEY authentification"); } } - + # check for ID in query elsif ($qs =~ s/\&*\bID=([^&]+)//i) { $id = $1; $fop_auth = 0; - + if ($id eq 'PUBLIC') { http_header('403 Forbidden'); exit; @@ -241,7 +241,7 @@ if ($qs = $ENV{QUERY_STRING}) { } # public or anonymous recipient? (needs no auth-ID for sender) - if ($anonymous or $id eq 'PUBLIC' and + if ($anonymous or $id eq 'PUBLIC' and @public_recipients and grep /^\Q$to\E$/i,@public_recipients) { $rid = $id; } else { @@ -250,12 +250,12 @@ if ($qs = $ENV{QUERY_STRING}) { close $idf; $rid = sidhash($rid,$id); } - + unless ($id eq $rid) { debuglog("real id=$rid, id sent by user=$id"); http_die("wrong auth-ID"); } - + # set akey link for HTTP sessions # (need original id for consistant non-moving akey) if (-d $akeydir and open $idf,'<',"$from/@" and my $id = getline($idf)) { @@ -263,7 +263,7 @@ if ($qs = $ENV{QUERY_STRING}) { unlink "$akeydir/$akey"; symlink "../$from","$akeydir/$akey"; } - + my %to; COLLECTTO: foreach my $to (split(',',$to)) { if ($to !~ /.@./ and open my $AB,'<',"$from/\@ADDRESS_BOOK") { @@ -305,9 +305,9 @@ if ($qs = $ENV{QUERY_STRING}) { http_die("$to is not a legal e-mail address"); } } - + } - + if ($qs =~ /\&?KEEP=(\d+)/i) { $keep = $1; $filename = filename($file); @@ -332,15 +332,15 @@ if ($qs = $ENV{QUERY_STRING}) { "\n"; } exit; - } elsif ($qs =~ s/\&?KEEP//i) { + } elsif ($qs =~ s/\&?KEEP//i) { check_captive($file); $autodelete = 'NO'; } - + if ($qs =~ s/\&?FILEID=(\w+)//i) { $fileid = $1 } if ($qs =~ s/\&?IGNOREWARNING//i) { $ignorewarning = 1 } - + if ($qs eq 'LIST') { http_header('200 OK','Content-Type: text/plain'); print "$file :\n"; @@ -372,7 +372,7 @@ if ($qs = $ENV{QUERY_STRING}) { http_die("File $file already exists in your outgoing spool."); } mkdirp("$to/$to/$file"); - link "$to/$from/$file/data","$to/$to/$file/data" + link "$to/$from/$file/data","$to/$to/$file/data" or http_die("cannot link to $to/$to/$file/data - $!\n"); my $fkey = copy("$to/$from/$file/filename","$to/$to/$file/filename"); open my $notify,'>',"$to/$to/$file/notify"; @@ -387,7 +387,7 @@ if ($qs = $ENV{QUERY_STRING}) { "\n"; exit; } - + # ex and hopp? if ($qs =~ s/(^|&)DELETE//i) { if (unlink $data) { @@ -410,12 +410,12 @@ if ($qs = $ENV{QUERY_STRING}) { "

    $filename deleted

    \n", "\n"; exit; - } else { + } else { http_die("no such file"); } exit; - } - + } + # wipe out!? (for anonymous upload) if ($qs =~ s/(^|&)PURGE//i) { $filename = filename($file); @@ -434,15 +434,15 @@ if ($qs = $ENV{QUERY_STRING}) { print html_header($head), "

    $filename purged

    \n", "\n"; - } else { + } else { http_die("no such file"); } - } else { + } else { http_die("you are not allowed to purge $filename"); } exit; - } - + } + # request for file size? if ($qs eq '?') { sendsize($file); @@ -509,7 +509,7 @@ if ($range = $ENV{HTTP_RANGE}) { if (not $autodelete or $autodelete ne 'NO') { $autodelete = readlink "$file/autodelete" || 'YES'; } - + if ($from and $file eq "$from/$from/ADDRESS_BOOK") { if (open my $AB,'<',"$from/\@ADDRESS_BOOK") { my $ab = ''; @@ -550,7 +550,7 @@ if (-f $data) { and $file !~ /\/STDFEX$/ # xx is ok! and (slurp("$file/comment")||'') !~ /^!\*!/ # multi download allow flag and not($dkey and ($ENV{HTTP_COOKIE}||'') =~ /dkey=$dkey/) - and open $file,'<',"$file/download") + and open $file,'<',"$file/download") { $_ = <$file> || ''; close $file; @@ -587,14 +587,14 @@ debuglog(sprintf("%s %s %d %d %d", isodate(time),$file,$sb||0,$seek,-s $data||0)); if ($sb+$seek == -s $data) { - + # note successfull download $download = "$file/download"; if (open $download,'>>',$download) { printf {$download} "%s %s\n",isodate(time),$ENV{REMOTE_ADDR}; close $download; } - + # delete file after grace period if ($autodelete eq 'YES') { $grace_time = 60 unless defined $grace_time; @@ -613,26 +613,26 @@ if ($sb+$seek == -s $data) { close $error; } } - + } exit; - + sub sendfile { my ($file,$seek,$stop) = @_; my ($filename,$size,$total_size,$fileid,$filetype); my ($data,$download,$header,$buf,$range,$s,$b,$t0); my $type = ''; - + # swap to and from for special senders, see fup storage swap! $file =~ s:^(_?anonymous_.*)/(anonymous.*)/:$2/$1/:; $file =~ s:^(_?fexmail_.*)/(fexmail.*)/:$2/$1/:; - + $data = $file.'/data'; $download = $file.'/download'; $header = $file.'/header'; - + # fallback defaults, should be set later with better values $filename = filename($file); $total_size = -s $data || 0; @@ -675,12 +675,12 @@ sub sendfile { } } $size = $total_size - $seek - ($stop ? $total_size-$stop-1 : 0); - } elsif ($ENV{REQUEST_METHOD} eq 'HEAD') { + } elsif ($ENV{REQUEST_METHOD} eq 'HEAD') { $size = -s $data || 0; - } else { + } else { http_die("unknown HTTP request method $ENV{REQUEST_METHOD}"); } - + # read MIME entity header (what the client said) if (open $header,'<',$header) { while (<$header>) { @@ -692,9 +692,9 @@ sub sendfile { close $header; $type =~ s/\s//g; } - + $fileid = readlink "$file/id" || ''; - + # determine own MIME entity header for download my $mime = $file; $mime =~ s:/.*:/\@MIME:; @@ -717,7 +717,7 @@ sub sendfile { } # reset to default MIME type else { $type = 'application/octet-stream' } - + # HTML is not allowed for security reasons! (embedded javascript, etc) $type =~ s/html/plain/i; @@ -747,7 +747,7 @@ sub sendfile { } nvt_print(''); } else { - # another stupid IE bug-workaround + # another stupid IE bug-workaround # http://drupal.org/node/163445 # http://support.microsoft.com/kb/323308 if ($http_client =~ /MSIE/ and not $nowarning) { @@ -813,7 +813,7 @@ sub sendfile { # control back to fexsrv for further HTTP handling &reexec; } - + if ($ENV{REQUEST_METHOD} eq 'GET') { if (@throttle) { @@ -829,7 +829,7 @@ sub sendfile { $bwl = $limit; last; } - } + } # throttle e-mail address? else { # allow wildcard *, but not regexps @@ -843,7 +843,7 @@ sub sendfile { } } } - + foreach my $sig (keys %SIG) { local $SIG{$sig} = \&sigexit } local $SIG{ALRM} = sub { die "TIMEOUT\n" }; @@ -859,7 +859,7 @@ sub sendfile { $b = $size-$s; $buf = substr($buf,0,$b) } - $s += $b; + $s += $b; alarm($timeout*10); syswrite STDOUT,$buf or last; # client still alive? if ($bwl) { @@ -867,14 +867,14 @@ sub sendfile { sleep 1 while $s/(time-$t0||1)/1024 > $bwl; } } - + close $data; alarm(0); - + fdlog($log,$file,$s,$size); } close $download; - + return $s; } @@ -884,13 +884,13 @@ sub sendsize { my ($file,$upload,$to,$from,$dkey); my $size = 0; local $_; - + $path =~ s:^/::; ($to,$from,$file) = split('/',$path); $to =~ s/,.*//; $to = lc $to; $from = lc $from; - + # swap to and from for special senders, see fup storage swap! ($from,$to) = ($to,$from) if $from =~ /^(fexmail|anonymous)/; @@ -905,7 +905,7 @@ sub sendsize { if ($to eq '*' and $fileid) { foreach my $fd (glob "*/$from/$file") { - if (-f "$fd/data" + if (-f "$fd/data" and -l "$fd/id" and readlink "$fd/id" eq $fileid and $dkey = readlink "$fd/dkey") { $to = $fd; @@ -929,12 +929,12 @@ sub sendsize { } close $AB; } - + if (-f "$to/$from/$file/data") { $dkey = readlink "$to/$from/$file/dkey"; $fkey = slurp("$to/$from/$file/filename")||$file; } - + $upload = -s "$to/$from/$file/upload" || -s "$to/$from/$file/data" || 0; $size = readlink "$to/$from/$file/size" || 0; $fileid = readlink "$to/$from/$file/id" || ''; @@ -1000,11 +1000,11 @@ sub check_auth { if ($path =~ m:(.+)/(.+)/(.+):) { ($to,$from,$file) = ($1,$2,$3); - } elsif ($path =~ m:(.+)/(.+):) { + } elsif ($path =~ m:(.+)/(.+):) { ($dkey,$file) = ($1,$2); $path = readlink "$dkeydir/$dkey" or http_die('no such file'); (undef,$to,$from,$file) = split('/',$path); - } else { + } else { http_die("wrong URL format for download"); } @@ -1028,15 +1028,15 @@ sub check_auth { debuglog("$user mismatch: id=$id, auth=$auth"); &require_auth; } - } + } # check for sub user elsif (open $idf,'<',"$from/\@SUBUSER") { while (<$idf>) { chomp; s/#.*//; ($subuser,$subid) = split ':'; - if ($subid and $subid eq $auth - and ($user eq $subuser + if ($subid and $subid eq $auth + and ($user eq $subuser or $subuser eq '*@*' or $subuser =~ /^\*\@(.+)/ and $user =~ /\@\Q$1\E$/i or $subuser =~ /(.+)\@\*$/ and $user =~ /^\Q$1\E\@/i)) { @@ -1053,7 +1053,7 @@ sub check_auth { debuglog("no $to/@ and no $from/@"); &require_auth; } - + } @@ -1070,7 +1070,7 @@ sub check_captive { sub sigexit { my ($sig) = @_; my $msg; - + $msg = @_ ? "@_" : '???'; $msg =~ s/\n/ /g; $msg =~ s/\s+$//; diff --git a/cgi-bin/fuc b/cgi-bin/fuc index c18aa45..661c897 100755 --- a/cgi-bin/fuc +++ b/cgi-bin/fuc @@ -1,6 +1,6 @@ #!/usr/bin/perl -wT -# FEX CGI for user control +# FEX CGI for user control # (subuser, groups, address book, one time upload key, auth-ID, etc) # # Author: Ulli Horlacher @@ -91,11 +91,11 @@ if ($akey) { # sid is not set with web browser my $idf = "$akeydir/$akey/@"; - + if (open $akey,'<',$idf and $id = getline($akey)) { close $akey; $idf =~ /(.*)\/\@/; - $user = readlink $1 + $user = readlink $1 or http_die("internal server error: no $akey symlink $1"); $user =~ s:.*/::; $user = untaint($user); @@ -123,7 +123,7 @@ if ($user and $akey and $qs and $qs =~ /info=(.+?)&skey=(.+)/) { if ($user and $id) { - if (-e "$user/\@CAPTIVE") { html_error($error,"captive user") } + if (-e "$user/\@CAPTIVE") { html_error($error,"captive user") } unless (open $idf,'<',"$user/@") { faillog("user $from, id $id"); html_error($error,"wrong user or auth-ID"); @@ -153,9 +153,9 @@ if ($user and $id) { } # empty POST? ==> back to foc -if ($ENV{REQUEST_METHOD} eq 'POST' and not +if ($ENV{REQUEST_METHOD} eq 'POST' and not ($subuser or $notify or $nid or $ssid or $group or $ab or $gm or $tools - or $disclaimer or $encryption or $pubkey)) + or $disclaimer or $encryption or $pubkey)) { nvt_print( "HTTP/1.1 302 Found", @@ -224,7 +224,7 @@ if ($subuser and $otuser) { my $okey = randstring(8); my $okeyd = "$user/\@OKEY"; mkdir $okeyd; - symlink $otuser,"$okeyd/$okey" + symlink $otuser,"$okeyd/$okey" or http_die("cannot create OKEY $okeyd/$okey : $!\n"); my $url = "$fup?to=$user&okey=$okey"; pq(qq( @@ -359,7 +359,7 @@ if ($user and $akey and defined $ab) { } else { $ab =~ s/[\r<>]//g; $ab =~ s/\s*$/\n/; - + foreach (split(/\n/,$ab)) { s/^\s+//; s/\s+$//; @@ -379,7 +379,7 @@ if ($user and $akey and defined $ab) { push @badalias,$_; } } - + if (@badalias) { print "

    ERROR: bad aliases:

    \n