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);
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;
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} $_;
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);
# 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";
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;
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;
$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;
exit;
}
-# delete user
+# delete user
if ($opt_d) {
$idf = "$spooldir/$opt_d/\@";
die "$0: no such user $opt_d\n" unless -f $idf;
EOD
} elsif ($opt_r eq 'UPLOAD_HOSTS') {
print {$rf}<<EOD;
-# Restrict allowed upload hosts.
+# Restrict allowed upload hosts.
# Only listed addresses are allowed as upload hosts.
# Make this file COMPLETLY empty if you want to disable the restriction.
# You can add single ip adresses or ip ranges.
EOD
} elsif ($opt_r eq 'DOWNLOAD_HOSTS') {
print {$rf}<<EOD;
-# Restrict allowed download hosts.
+# Restrict allowed download hosts.
# Only listed addresses are allowed as download hosts.
# Make this file COMPLETLY empty if you want to disable the restriction.
# You can add single ip adresses or ip ranges.
# add virtual server
if ($opt_A) {
- if ($opt_A =~ /(.+):(.+)/) {
+ if ($opt_A =~ /(.+):(.+)/) {
$vhost = $1;
$hhost = $2;
- } else {
+ } else {
die "usage: $0 -A alias:hostname\n".
"example: $0 -A flupp:fex.flupp.org\n";
}
if (/^n/i) { $autodelete = 'no' }
elsif (/^y/i) { $autodelete = 'yes' }
elsif (/^d/i) { $autodelete = 'delay' }
- else {
+ else {
die "usage: $0 -a user yes\n".
"usage: $0 -a user no\n".
"usage: $0 -a user delay\n".
if (/^n/i) { $notification = 'no' }
elsif (/^[sb]/i) { $notification = 'short' }
elsif (/^[fd]/i) { $notification = '' }
- else {
+ else {
die "usage: $0 -n user no\n".
"usage: $0 -n user brief\n".
"usage: $0 -n user detailed\n".
if ($opt_D) {
$user = lc $opt_D;
$user .= '@'.$mdomain if $mdomain and $user !~ /@/;
- $_ = shift @ARGV || '';
- if (/^y/i) {
- open $user,">>$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;
}
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",
$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);
}
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";
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";
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";
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";
$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)
our ($SH,$windoof,$sigpipe,$useragent);
our ($FEXSERVER);
-our $version = 20150729;
+our $version = 20150826;
# server defaults
my $server = 'fex.rus.uni-stuttgart.de';
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';
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;
my @rcamel = (
'\e[A
-(_*) _ _
+(_*) _ _
\\\\/ \\/ \\
\ __ )=*
- //\\\\//\\\\
+ //\\\\//\\\\
',
-'\e[A \\\\/\\\\/
+'\e[A \\\\/\\\\/
',
'\e[A //\\\\//\\\\
');
exit if $opt_s eq '-';
unlink $download unless -s $download;
exit 2 unless -f $download;
-
+
if ($windoof) {
print "READY\n";
exit;
}
unless ($opt_X) {
-
+
foreach my $a (keys %autoview) {
if ($download =~ /$a$/i and $autoview{$a}) {
printf "run \"%s %s\" [Yn] ? ",$autoview{$a},basename($download);
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')) {
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) {
my $d = $download;
my $xd = '.';
local $_;
-
+
if (-t and not $windoof) {
print "Files in archive:\n";
system(split(' ',$l),$download);
if ($xd eq '-') {
print "keeping $download\n";
exit;
- }
+ }
if ($xd !~ s/!$//) {
if (-d $xd) {
print "directory $xd does already exist, add \"!\" to overwrite\n";
"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
}
}
close $list;
-
+
if ($n) {
$cmd = "fexsend -d $n >/dev/null 2>&1";
print "$cmd\n" if $opt_v;
}
close $SH;
close X;
-
+
print $rcamel[2] if ${'opt_+'};
$tt = $t2-$t0;
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;
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($_ = <STDIN>||'');
} else {
$prompt =~ s/([\?:=]\s*)/ [$default]$1/ or $prompt .= " [$default]";
}
return $_;
- }
-}
+ }
+}
### common functions ###
$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);
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) {
# 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";
Proto => 'tcp',
);
}
-
+
if ($SH) {
autoflush $SH 1;
} else {
die "$0: cannot connect $server:$port - $@\n";
}
-
+
print "TCPCONNECT to $server:$port\n" if $opt_v;
}
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";
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) {
return 0;
}
}
-
+
return 1;
}
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+/|;
our ($FEXID,$FEXXX,$HOME);
our (%alias);
our $chunksize = 0;
-our $version = 20150729;
+our $version = 20150826;
our $_0 = $0;
our $DEBUG;
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);
$hints = <<EOD;
$0 hints and more options:
-
+
usage: $0 [options] file recipient(s)
Recipient can be a comma separated address list. Example:
$0 big.file framstag\@rus.uni-stuttgart.de,webmaster\@flupp.org
-Recipient can be an alias from your server address book
+Recipient can be an alias from your server address book
(use "$0 -A" to edit it). Example:
$0 big.file framstag
Recipient can be a SKEY URL, which you have received from a regular F*EX user.
-When using this URL you are a subuser of this full user and the file will be
+When using this URL you are a subuser of this full user and the file will be
sent to him. Example:
$0 big.file http://fex.rus.uni-stuttgart.de/fup?skey=4285f8cdd881626524fba686d5f0a83a
members of this group. Example:
$0 big.file http://fex.rus.uni-stuttgart.de/fup?gkey=50d26547b1e8c1110beb8748fc1d9444
-When you use "FEX-URL/anonymous" as recipient and your F*EX administrator has
+When you use "FEX-URL/anonymous" as recipient and your F*EX administrator has
allowed anonymous upload for your IP address then no auth-ID is needed.
-
-"." as recipient means fex to yourself and show immediately the download URL
+
+"." as recipient means fex to yourself and show immediately the download URL
(no notification e-mail will be sent). Example:
$0 software.tar .
-F activates female mode
-U show authorized URL
-+ is an undocumented feature - test it :-)
-
-To manage your subuser and groups or forward or redirect files, use a
+
+To manage your subuser and groups or forward or redirect files, use a
webbrowser with the URL from "$0 -U", e.g.: firefox \$($0 -U)
If you want to copy-forward an already uploaded file to another recipient,
You can list an uploaded file in more detail with
$0 -l #
Where # is the file number.
-
+
If you want to modify the keep time, comment or auto-delete behaviour of an
already uploaded file then you first have to query the file number with:
$0 -l
Where # is the file number.
With option -a you can send several files or whole directories within a single
-archive file. The archive types tar and tgz are build on-the-fly (streaming)
+archive file. The archive types tar and tgz are build on-the-fly (streaming)
whereas archive types zip and 7z need a temporary archive file on local disk.
With option -s you can send any data coming from a pipe (STDIN) as a file
without wasting local disc space.
-
+
With option -X you can specify any parameter, e.g.: -X autodelete=yes
For HTTPS you can set the environment variables:
SSLCAPATH=/etc/ssl/certs # path to trusted (root) certificates
SSLCAFILE=/etc/ssl/cert.pem # file with trusted (root) certificates
SSLCIPHERLIST=HIGH:!3DES # see http://www.openssl.org/docs/apps/ciphers.html
-
+
Partner program xx is an internet clipboard. See: xx -h
-
+
Partner program fexget is for downloading. See: fexget -h
-
-For temporary usage of a HTTP proxy use:
+
+For temporary usage of a HTTP proxy use:
$0 -P your_proxy:port:chunksize_in_MB file recipient
Example:
$0 -P wwwproxy.uni-stuttgart.de.de:8080:1024 4GB.tar .
-
-For temporary usage of an alternative F*EX server or user use:
+
+For temporary usage of an alternative F*EX server or user use:
FEXID="FEXSERVER USER AUTHID" $0 file recipient
Example:
FEXID="fex.flupp.org gaga\@flupp.org blubb" $0 big.file framstag\@rus.uni-stuttgart.de
fexsend also respects aliases in $HOME/.mutt/aliases
The alias priority is (descending):
\$HOME/.fex/config.pl
-\$HOME/.mutt/aliases
-fexserver address book
+\$HOME/.mutt/aliases
+fexserver address book
In \$HOME/.fex/config.pl you can also set the SSL* environment variables and the
\$opt_* variables, e.g.:
-
+
\$ENV{SSLVERSION} = 'TLSv1';
\${'opt_+'} = 1;
\$opt_m = 200;
*=( __ /
\\\\/\\\\/
',
-'\e[A \\\\/\\\\/
+'\e[A \\\\/\\\\/
',
'\e[A //\\\\//\\\\
');
$opt_u = $opt_f = $opt_a = $opt_C = $opt_i = $opt_b = $opt_P = $opt_X = '';
$opt_s = $opt_r = '';
$_ = "$fexhome/config.pl"; require if -f;
- getopts('hHvcdognVDKlILUARWMFzZqQS@!+./r:m:k:u:f:a:s:C:i:b:P:x:X:N:=:#:')
+ getopts('hHvcdognVDKlILUARWMFzZqQS@!+./r:m:k:u:f:a:s:C:i:b:P:x:X:N:=:#:')
or die $usage;
if ($opt_H) {
print $hints;
exit;
}
-
+
if ($opt_V) {
print "Version: $version\n";
}
-
+
if ($opt_K and $opt_D) {
die "$0: you cannot use both options -D and -K\n";
}
}
# $opt_C is COMMENT command in F*EX protocol
- $opt_C =
+ $opt_C =
($opt_d) ? 'DELETE':
($opt_l or $opt_L) ? 'LIST':
($opt_Q) ? 'CHECKQUOTA':
($opt_z) ? 'SENDLOG':
(${'opt_!'}) ? 'FOPLOG':
$opt_C;
-
- $opt_D =
+
+ $opt_D =
($opt_D) ? 'DELAY':
($opt_K) ? 'NO':
$opt_D;
die $usage if $opt_m and $opt_m !~ /^\d+/;
-if ($opt_P) {
+if ($opt_P) {
if ($opt_P =~ /^([\w.-]+:\d+)(:(\d+))?/) {
$proxy = $1;
$chunksize = $3 || 0;
unlink $idf.'xx';
}
}
-
+
# special xx ID?
if ($FEXXX = $ENV{FEXXX}) {
$FEXXX = decode_b64($FEXXX) if $FEXXX !~ /\s/;
}
close $idf;
}
-
+
} else {
# alternativ ID?
}
if ($opt_I) {
- if ($xx) { &show_id }
+ if ($xx) { &show_id }
else { &init_id }
exit;
}
} 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";
}
$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;
}
$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";
&send_xx($transferfile);
}
exit;
-}
+}
# regular fexsend
}
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 }
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";
}
}
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 = <STDIN>;
print "proxy address (hostname:port or empty if none): ";
$proxy = <STDIN>;
$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) {
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' }
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 /
}
die "$0: no transfer file\n" unless -s $transferfile;
-
+
serverconnect($server,$port);
query_sid($server,$port);
-
+
@r = formdatapost(
from => $from,
to => $from,
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);
print "wget -O- $2 | tar xvzf -\n";
}
}
-
+
unlink $transferfile;
}
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;
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;
@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;
s:HTTP/[\d\. ]+::;
die "$0: server response: $_\n";
}
-
+
# list sent files
if ($opt_l) {
open $fexlist,">$fexlist" or die "$0: cannot write $fexlist - $!\n";
}
}
close $fexlist;
- }
-
+ }
+
# list received files
if ($opt_L) {
foreach (@r) {
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;
my (%AB,@r);
my $alias;
local $_;
-
+
%AB = query_address_book($server,$port,$from);
foreach $alias (sort keys %AB) {
next if $alias eq 'ADDRESS_BOOK';
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 (.+\@.+) :/) {
my $transferfile;
my @transferfiles;
local $_;
-
+
if ($from =~ /^SUBUSER|GROUPMEMBER$/) {
$to = '_';
} else {
}
}
@to = split(',',lc($to));
-
+
die $usage unless @ARGV or $opt_a or $opt_s;
die $usage if $opt_s and @ARGV;
}
} elsif ($public) {
} else {
-
+
query_sid($server,$port);
-
+
if ($from eq 'SUBUSER') {
$skey = $sid;
# die "skey=$skey\nid=$id\nsid=$sid\n";
if ($from eq 'GROUPMEMBER') {
$gkey = $sid;
}
-
+
if ($to eq '.') {
@to = ($from);
$opt_C ||= 'NOMAIL';
}
}
# 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);
} 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;
die $usage;
}
}
-
+
foreach (@ARGV) {
my $file = $_;
unless ($opt_d) {
}
}
}
-
+
foreach my $file (@files) {
sleep 1; # do not overrun server!
unless (-s $file or $opt_d or $opt_a or $opt_s) {
file => $file,
keep => $opt_k,
comment => $opt_C,
- autodelete => $opt_D,
+ autodelete => $opt_D,
);
if (not @r or not grep /\w/,@r) {
}
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";
}
}
}
-
+
# delete transfer tmp file
unlink $transferfile if $transferfile;
}
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 '@') {
}
}
close $fexlist;
-
+
unless ($n) {
die "$0: file #$opt_f not found in fexlist\n";
}
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;
$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";
}
}
}
close $fexlist;
-
+
unless ($n) {
die "$0: file #$opt_N not found in fexlist\n";
}
serverconnect($server,$port);
query_sid($server,$port);
-
+
$req = "GET $proxy_prefix/fup?"
."from=$from&ID=$sid&dkey=$dkey&command=RENOTIFY"
." HTTP/1.1";
$file = $3;
}
}
-
+
if ($file) {
print "notification e-mail for $file has been resent to $recipient\n";
} else {
die "$0: server failed, rerun command with option -v\n";
}
}
-
+
exit;
}
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) {
}
}
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;
$req .= " HTTP/1.1";
sendheader("$server:$port",$req);
http_response();
- while (<$SH>) {
+ while (<$SH>) {
if ($opt_v) {
print "<-- $_";
} else {
print if /\Q$file/;
}
}
-
+
exit;
}
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;
sub formdatapost {
- my %P = @_;
+ my %P = @_;
my ($boundary,$filename,$filesize,$length,$buf,$file,$fpsize,$resume,$seek);
my ($flink);
my (@hh,@hb,@r,@pv,$to);
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);
$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;
$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/.*\\//;
}
}
}
-
+
} else {
$file = $filename = '';
$filesize = 0;
}
FORMDATAPOST:
-
+
@hh = (); # HTTP header
@hb = (); # HTTP body
@r = ();
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},
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"
}
$boundary = randstring(48);
-
+
$P{seek} = $seek;
$P{filesize} = $filesize;
push @hb,encode_utf8($P{$v});
}
}
-
+
# at last, POST the file
if ($file) {
push @hb,"--$boundary";
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";
}
binmode $file;
}
-
+
$bytes = 0;
autoflush $SH 0;
-
+
print $rcamel[0] if ${'opt_+'};
$SIG{ALRM} = sub { retry("timed out") };
}
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)",
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";
}
return "X-Location: $location\n";
}
-
+
if ($flink) {
$bytes = -s $flink;
if ($bytes>2*M) {
}
# 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";
}
last if @r and $r[0] =~ / 204 / and /^$/ or /<\/html>/i;
push @r,decode_utf8($_);
}
-
+
if ($file) {
close $SH;
undef $SH;
goto FORMDATAPOST;
}
}
-
+
return @r;
}
}
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;
}
sub getline {
my $file = shift;
local $_;
-
+
while (<$file>) {
chomp;
s/^#.*//;
my ($head,$location);
my ($response,$fexsrv);
local $_;
-
+
$to =~ s/,.*//;
$to =~ s/:\w+=.*//;
$to = $AB{$to} if $AB{$to};
# return true seek only if file is identified
$seek = 0 if $qfileid and $qfileid ne $fileid;
-
+
return ($seek,$location);
}
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;
%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";
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.'~';
}
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>;
last if /^$/;
$cl = $1 if /^Content-Length: (\d+)/;
}
-
+
if ($cl) {
while (<$SH>) {
$b += length;
last if $b >= $cl;
}
}
-
+
$AB{ADDRESS_BOOK} = $ab;
-
+
return %AB;
}
}
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);
serverconnect($server,$port);
$sid = $id;
}
-
+
# warn "proxy: $proxy\n";
if ($proxy) {
serverconnect($server,$port);
$sid = $id;
}
-
+
}
}
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;
}
sleep 1 while ($opt_m and $B/k/(time-$t0||1) > $opt_m);
}
-
+
print STDERR ts($B,$cl),"\n";
close F;
}
my ($b,$tb) = @_;
return sprintf("transferred: %d MB (%d%%)",int($b/M),int($b/$tb*100));
}
-
+
sub sigpipehandler {
retry("died");
sub retry {
my $reason = shift;
local $SIG{ALRM} = sub { };
-
+
if (fileno $SH) {
alarm(1);
my @r = <$SH>;
my ($from,$to) = @_;
my @r;
local $_;
-
+
@r = formdatapost(
from => $from,
to => $to,
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;
}
}
my $ma = $HOME.'/.mutt/aliases';
my $alias;
local $_;
-
+
open $ma,$ma or return $to;
while (<$ma>) {
if (/^alias \Q$to\E\s/i) {
my @files = @_;
my ($file,$dir);
my $fmd = '';
-
+
foreach $file (@files) {
if (not -l $file and -d $file) {
$dir = $file;
$fmd .= $file.fileid($file);
}
}
-
+
return $fmd;
}
local $_ = shift;
my $uu = '';
my ($i,$l);
-
+
tr|A-Za-z0-9+=/||cd;
s/=+$//;
tr|A-Za-z0-9+/| -_|;
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>;
$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);
my ($server,$port) = @_;
my $connect = "CONNECT $server:$port HTTP/1.1";
local $_;
-
+
if ($proxy) {
tcpconnect(split(':',$proxy));
if ($https) {
# 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;
Proto => 'tcp',
);
}
-
+
if ($SH) {
autoflush $SH 1;
} else {
die "$0: cannot connect $server:$port - $@\n";
}
-
+
print "TCPCONNECT to $server:$port\n" if $opt_v;
}
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";
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) {
return 0;
}
}
-
+
return 1;
}
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+/|;
use Fcntl qw':flock :seek';
use warnings;
-BEGIN {
+BEGIN {
# stunnel workaround
$SIG{CHLD} = "DEFAULT";
$ENV{PERLINIT} = q{
}
# 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
our @log;
$0 = untaint($0);
-
+
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1f';
$ENV{SERVER_NAME} = $hostname;
$ENV{REQUEST_METHOD} = '';
}
$ra = $ENV{REMOTE_ADDR};
$rh = $ENV{REMOTE_HOST};
-}
+}
# new session
else {
my $iaddr;
-
+
# HTTPS connect
if ($ssl_ra) {
$ENV{PROTO} = 'https';
$rh ||= '-';
$port = 443;
# print {$log} "X-SSL-Remote-Host: $ssl_ra\n";
- }
+ }
# HTTP connect
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;
if (defined $ENV{REQUESTCOUNT}) { $ENV{REQUESTCOUNT}++ }
else { $ENV{REQUESTCOUNT} = 0 }
-
+
$connect = sprintf "%s:%s %s %s %s [%s_%s]",
$keep_alive ? 'CONTINUE' : 'CONNECT',
$port,
fexlog($connect,@log,"OVERRUN");
http_error(413);
}
-
+
if (/^(GET \/|X-Forwarded-For|User-Agent)/i) {
$hid .= $_."\n";
}
exit unless @header;
exit if $header =~ /^\s*$/;
-
+
$ENV{HTTP_HEADER} = $header;
debuglog($header);
# http_die("<pre>$header</pre>");
-
+
$ENV{'HTTP_HEADER_LENGTH'} = $hl;
$ENV{REQUEST_URI} = $uri = '';
$cgi = '';
badlog("no HTTP request: $request");
exit;
}
-
+
if ($force_https and $port != 443
and $request =~ /^(GET|HEAD|POST)\s+(.+)\s+(HTTP\/[\d\.]+$)/i) {
$request = $2;
}
while ($_ = shift @header) {
-
+
# header inquisition!
&$header_hook($connect,$_,$ra) if $header_hook;
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);
}
&$header_hook($connect,$header,$ra) if $header_hook;
exit unless $cgi;
-
+
# extra download request? (request http://fexserver//xkey)
if ($cgi =~ m{^//([^/]+)$}) {
my $xkey = $1;
# 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 {
$locale = $default_locale;
}
}
-
+
# prepare document file name
if ($ENV{REQUEST_METHOD} =~ /^GET|HEAD$/) {
if (%redirect) {
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);
}
# neither document nor CGI ==> error
-
+
if ($status) {
fexlog($connect,@log,"FAILED to exec $cgi : $status");
http_error(666);
sub fexlog {
my @log = @_;
-
+
foreach my $logdir (@logdir) {
if (open $log,'>>',"$logdir/$log") {
flock $log,LOCK_EX;
sub badchar {
my $bc = shift;
-
+
fexlog($connect,@log,"DISCONNECT: bad characters in URL");
debuglog("DISCONNECT: bad characters in URL $uri");
badlog($request);
sub bintar {
my $tmpdir = "$FEXHOME/tmp";
my $fs = "$ENV{PROTO}://$ENV{HTTP_HOST}";
-
+
if (chdir "$FEXHOME/bin") {
fexlog($connect,@log);
chdir $fstb if $fstb;
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");
sub http_error_header {
my $error = shift;
my $uri = $ENV{REQUEST_URI};
-
+
errorlog("$uri ==> $error") if $uri;
nvt_print(
"HTTP/1.1 $error",
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(
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;
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;
$| = 1;
# sexsend is default
-$usage =
+$usage =
"usage: ... | $0 [options] [SEX-URL/]recipient [stream]\n".
"options: -v verbose mode\n".
" -g show transfer rate\n".
"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".
}
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".
$_ = "$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/;
}
close $idf;
}
-
+
getopts('hgvcu:s:') or die $usage;
die $usage if $opt_h;
die $usage unless -t;
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;
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);
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;
print "Version: $version\n";
exit unless @ARGV;
}
-
+
if ($opt_t and $opt_t =~ /^\d+$/) {
$timeout = "&timeout=$opt_t";
}
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';
die "$0: no SEX URL found, use \"$0 SEX-URL/recipient\" or \"fexsend -I\"\n";
}
}
-
+
}
&get_ssl_env;
$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";
}
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;
print STDERR "==> (streaming ...)\n" if $opt_v;
transfer(STDIN,$SH);
-
+
exit;
my $destination = shift;
my ($t0,$t1,$tt);
my ($B,$b,$bt);
-
+
$t0 = $t2 = time;
$tt = $t0-1;
$t1 = 0;
}
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",
$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 (;;) {
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";
}
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;
return $id;
}
-sub sigpipehandler {
+sub sigpipehandler {
local $_ = '';
$SIG{ALRM} = sub { };
alarm(1);
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;
}
local $_ = shift;
my $uu = '';
my ($i,$l);
-
+
tr|A-Za-z0-9+=/||cd;
s/=+$//;
tr|A-Za-z0-9+/| -_|;
$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);
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) {
# 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";
Proto => 'tcp',
);
}
-
+
if ($SH) {
autoflush $SH 1;
} else {
die "$0: cannot connect $server:$port - $@\n";
}
-
+
print "TCPCONNECT to $server:$port\n" if $opt_v;
}
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";
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) {
return 0;
}
}
-
+
return 1;
}
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+/|;
);
# backup goes first
-if ($action eq "backup") {
+if ($action eq "backup") {
&backup;
exit;
}
s:</h1>: (<a href="?action=logout">logout</a>)</h1>:;
print;
-my $nav_user =
+my $nav_user =
"<li><a href=\"?action=create\">Create new user</a>\n".
"<li><a href=\"?action=change-auth\">Change user auth-ID</a>\n".
"<li><a href=\"?action=edit\">Edit user restrictions file</a>\n".
"<li><a href=\"?action=delete\">Delete existing user</a>\n".
"<li><a href=\"?action=quota\">Manage disk quota</a>\n";
-my $nav_log =
+my $nav_log =
"<li><a href=\"?action=fup.log\">Get fup.log</a>\n".
"<li><a href=\"?action=fop.log\">Get fop.log</a>\n".
"<li><a href=\"?action=error.log\">Get error.log</a>\n";
$nav_log;
}
-my $nav_backup =
+my $nav_backup =
"<li><a href=\"?action=backup\">Download backup<br>(config only)</a>\n".
"<li><a href=\"?action=restore\">Restore backup</a>\n";
"<li><a href=\"?action=showquota\">Show quotas (sender/recipient)</a>\n".
"<li><a href=\"?action=showconfig\">Show server config</a>\n".
"<li><a href=\"?action=userconfig\">Show user config</a>\n";
-
-my $nav_edit =
+
+my $nav_edit =
"<li><a href=\"?action=editconfig\">Edit config</a>\n".
"<li><a href=\"?action=editindex\">Edit index.html</a>\n";
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"});
}
# formular for choosing user, who shall be removed
-# required arguments: -
+# required arguments: -
sub deleteUserForm {
my @option = map { "<option value=\"$_\">$_</option>\n" } @user_items;
my @option;
my $rquota = '';
my $squota = '';
-
+
if ($user = $PARAM{"user"}) {
$user = normalize_user($user);
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 - $!");
# 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 "<code>\n";
print "$idf<p>";
-
+
open $idf,'>',$idf or http_die("cannot write $idf - $!");
print {$idf} $id,"\n";
close $idf or http_die("cannot write $idf - $!");
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 <code>$user</code>");
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;
# required arguments: list of Files
sub deleteFiles {
http_die("not enough arguments in deleteFiles") unless (my @files = @_);
-
+
foreach (@files) {
if (-e) {
if (unlink $_) {
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') {
} else {
http_die("unknown file $ar")
}
-
+
$new = $ar.'_new';
if ($ar =~ /fex.ph$/) {
open $new,'>',$new or http_die("cannot open ${ar}_new - $!");
$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) {
}
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");
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 {
# 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);
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",
"Content-Disposition: attachment; filename=\"fex-backup-$date.tar\"",
"",
);
-
+
while (read($backup,my $b,$bs)) {
print $b or last;
}
-
+
exit;
}
sub editFile {
my $ar = shift;
my $file;
-
+
$file = dehtml(slurp($ar));
-
+
$ar =~ s:.*/::;
print h2("edit <code>$ar<code>");
} 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");
# 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
) {
s/@/@./;
$_ = join('.',reverse(split /\./));
}
-
+
@d = sort { lc $a cmp lc $b } @d;
-
+
foreach (@d) {
$_ = join('.',reverse(split /\./));
s/,/./g;
s/@\./@/;
}
-
+
return @d;
}
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) {
$domain = $1;
}
}
-
+
return @list;
}
sub dumpfile {
my $file = shift;
-
+
print "<pre>\n";
while (<$file>) { print dehtml($_) }
print "\n</pre>\n";
chdir $spooldir or die "$spooldir - $!\n";
-$akeydir = "$spooldir/.akeys";
+$akeydir = "$spooldir/.akeys";
$user = $id = '';
# look for CGI parameters
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);
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;
# workaround for broken F*IX
$qs =~ s/&ID=skey:\w+//;
-
+
# subuser with skey?
if ($qs =~ s/&*SKEY=([\w:]+)//i) {
$skey = $1;
http_die("wrong SKEY authentification");
}
}
-
+
# group member with gkey?
if ($qs =~ s/&*GKEY=([\w:]+)//i) {
$gkey = $1;
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;
}
# 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 {
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)) {
unlink "$akeydir/$akey";
symlink "../$from","$akeydir/$akey";
}
-
+
my %to;
COLLECTTO: foreach my $to (split(',',$to)) {
if ($to !~ /.@./ and open my $AB,'<',"$from/\@ADDRESS_BOOK") {
http_die("$to is not a legal e-mail address");
}
}
-
+
}
-
+
if ($qs =~ /\&?KEEP=(\d+)/i) {
$keep = $1;
$filename = filename($file);
"</body></html>\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";
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";
"</body></html>\n";
exit;
}
-
+
# ex and hopp?
if ($qs =~ s/(^|&)DELETE//i) {
if (unlink $data) {
"<h3>$filename deleted</h3>\n",
"</body></html>\n";
exit;
- } else {
+ } else {
http_die("no such file");
}
exit;
- }
-
+ }
+
# wipe out!? (for anonymous upload)
if ($qs =~ s/(^|&)PURGE//i) {
$filename = filename($file);
print html_header($head),
"<h3>$filename purged</h3>\n",
"</body></html>\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);
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 = '';
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;
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;
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;
}
}
$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>) {
close $header;
$type =~ s/\s//g;
}
-
+
$fileid = readlink "$file/id" || '';
-
+
# determine own MIME entity header for download
my $mime = $file;
$mime =~ s:/.*:/\@MIME:;
}
# 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;
}
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) {
# control back to fexsrv for further HTTP handling
&reexec;
}
-
+
if ($ENV{REQUEST_METHOD} eq 'GET') {
if (@throttle) {
$bwl = $limit;
last;
}
- }
+ }
# throttle e-mail address?
else {
# allow wildcard *, but not regexps
}
}
}
-
+
foreach my $sig (keys %SIG) { local $SIG{$sig} = \&sigexit }
local $SIG{ALRM} = sub { die "TIMEOUT\n" };
$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) {
sleep 1 while $s/(time-$t0||1)/1024 > $bwl;
}
}
-
+
close $data;
alarm(0);
-
+
fdlog($log,$file,$s,$size);
}
close $download;
-
+
return $s;
}
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)/;
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;
}
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" || '';
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");
}
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)) {
debuglog("no $to/@ and no $from/@");
&require_auth;
}
-
+
}
sub sigexit {
my ($sig) = @_;
my $msg;
-
+
$msg = @_ ? "@_" : '???';
$msg =~ s/\n/ /g;
$msg =~ s/\s+$//;
#!/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 <framstag@rus.uni-stuttgart.de>
# 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);
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");
}
# 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",
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(
} else {
$ab =~ s/[\r<>]//g;
$ab =~ s/\s*$/\n/;
-
+
foreach (split(/\n/,$ab)) {
s/^\s+//;
s/\s+$//;
push @badalias,$_;
}
}
-
+
if (@badalias) {
print "<h2>ERROR: bad aliases:</h2>\n<ul>";
foreach my $ba (@badalias) { print "<li>$ba" }
));
exit;
}
-
- open my $AB,'>',"$user/\@ADDRESS_BOOK"
+
+ open my $AB,'>',"$user/\@ADDRESS_BOOK"
or http_die("cannot open $user/\@ADDRESS_BOOK - $!\n");
print {$AB} $ab;
close $AB;
my $pk;
local $/;
local $_;
-
+
open $pk,">$gf.pk" or http_die("cannot write $gf.pk - $!\n");
print {$pk} $pubkey;
close $pk;
if ($user and $encryption) {
my $gf = "$user/\@GPG";
-
+
unless(-s "$ENV{HOME}/.gnupg/pubring.gpg") {
html_error($error,"no GPG support activated");
}
if ($nid) {
$nid =~ s/^\s+//;
$nid =~ s/\s+$//;
-
+
$nid = randstring(6) if $nid eq '?';
-
+
open $idf,'>',"$user/@" or die "$user/@ - $!\n";
print {$idf} $nid,"\n";
close $idf;
$akey = untaint(md5_hex("$user:$nid"));
unlink "$akeydir/$akey";
symlink "../$user","$akeydir/$akey";
-
+
pq(qq(
'<h3>new auth-ID "<code>$nid</code>" for $user saved</h3>'
'<a href="/foc?akey=$akey">back to F*EX operation control</a>'
# update sub-users
if ($ssid) {
my ($subuser,$subid,$skey);
-
+
# delete old skeys
if (open $idf,'<',"$user/\@SUBUSER") {
while (<$idf>) {
push @badaddress,$subuser unless checkaddress($subuser);
}
}
-
+
if (@badaddress) {
print "<h2>ERROR: bad addresses:</h2>\n<ul>";
foreach my $ba (@badaddress) { print "<li>$ba" }
));
exit;
}
-
+
if ($ssid =~ /\S\@\w/) {
open $idf,'>',"$user/\@SUBUSER" or die "$user/\@SUBUSER - $!\n";
print "Your subusers upload URLs are:<p><code>\n";
));
}
print "<a href=\"/foc?akey=$akey\">back to F*EX operation control</a>\n";
- print "</body></html>\n";
+ print "</body></html>\n";
close $idf;
exit;
}
my ($user,$otuser,$url,$comment) = @_;
my $server = $hostname || $mdomain;
my $sf;
-
+
return if $nomail;
-
+
$user .= '@'.$mdomain if $mdomain and $user !~ /@/;
$sf = $sender_from ? $sender_from : $user;
open my $mail,'|-',$sendmail,'-f',$sf,$otuser,$bcc
my ($user,$subuser,$url,$comment) = @_;
my $server = $hostname || $mdomain;
my $sf;
-
+
return if $nomail;
-
+
$user .= '@'.$mdomain if $mdomain and $user !~ /@/;
$sf = $sender_from ? $sender_from : $user;
open my $mail,'|-',$sendmail,'-f',$sf,$subuser,$user,$bcc
my ($user,$gm,$group,$id,$url) = @_;
my $server = $hostname || $mdomain;
my $sf;
-
+
$user .= '@'.$mdomain if $mdomain and $user !~ /@/;
$sf = $sender_from ? $sender_from : $user;
open my $mail,'|-',$sendmail,'-f',$sf,$gm,$user,$bcc
sub mkskey {
my ($user,$subuser,$id) = @_;
my $skey = md5_hex("$user:$subuser:$id");
-
+
open my $skf,'>',"$skeydir/$skey" or die "$skeydir/$skey - $!\n";
print {$skf} "from=$subuser\n",
"to=$user\n",
sub mkgkey {
my ($user,$group,$gm,$id) = @_;
my $gkey = untaint(md5_hex("$user:$group:$gm:$id"));
-
+
open my $gkf,'>',"$gkeydir/$gkey" or die "$gkeydir/$gkey - $!\n";
print {$gkf} "from=$gm\n",
"to=\@$group\n",
sub handle_group {
my ($gf,$gd,$gl,$gid,$gkey);
-
+
$group =~ s/^@+//;
$group =~ s:[/&<>]::g;
}
$gf = untaint("$user/\@GROUP/$group");
-
+
if (defined $gm) {
if ($gm =~ /\S/) {
foreach (split /\n/,$gm) {
foreach my $ba (@badaddress) { print "<li>$ba" }
print "</ul>\n";
}
- if (@badformat or @badaddress) {
+ if (@badformat or @badaddress) {
pq(qq(
'<a href="javascript:history.back()">Go back</a>'
'</body></html>'
my $fileid; # file ID
my $captive;
my $muser; # main user fur sub or group user
-
+
# load common code, local config: $FEXLIB/fex.ph
require "$FEXLIB/fex.pp";
$locale = $ENV{LOCALE} || 'english';
foreach (
- "/var/lib/fex/locale/$locale/lib/fup.pl",
+ "/var/lib/fex/locale/$locale/lib/fup.pl",
"$FEXLIB/fup.pl",
) {
if (-f) {
# public recipients? (needs no auth-ID for sender)
if ($to and $id and $id eq 'PUBLIC' and @public_recipients) {
-
+
unless ($from) {
http_die("missing sender e-mail address");
}
}
# anonymous upload from enabled IP?
-if ($from =~ /^anonymous@/ and
+if ($from =~ /^anonymous@/ and
@anonymous_upload and ipin($ra,@anonymous_upload)) {
$id = $rid = $anonymous = 'anonymous';
if ($to =~ /^anonymous/) {
@to = ($to);
- $autodelete{$to} = $autodelete = 'NO';
+ $autodelete{$to} = $autodelete = 'NO';
}
$nomail = $anonymous;
}
# one time token
if ($okey) {
$to = "@to" or http_die("no recipient specified");
- $from = readlink "$to/\@OKEY/$okey"
+ $from = readlink "$to/\@OKEY/$okey"
or http_die("no upload key \"<code>$okey</code>\" - ".
"request another one from <code>$to</code>");
$from = untaint($from);
http_die("File not found");
}
if (-e "$to/$to/$file/data") {
- http_die("File $file already exists in your outgoing spool")
- if (readlink("$to/$to/$file/id")||$to) ne
+ http_die("File $file already exists in your outgoing spool")
+ if (readlink("$to/$to/$file/id")||$to) ne
(readlink("$to/$from/$file/id")||$from);
} else {
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");
copy("$to/$from/$file/filename","$to/$to/$file/filename");
copy("$to/$from/$file/id","$to/$to/$file/id");
""
);
&reexec;
- } else {
+ } else {
my $s = $!;
http_header('404 Not Found');
print html_header($head);
# special commands
if (($from and $id and $rid eq $id or $gkey or $skey) and $command) {
-
+
if ($command eq 'CHECKQUOTA') {
http_die("illegal command \"$command\"") if $public or $anonymous;
nvt_print('HTTP/1.1 204 OK');
$filename = <$file>;
close $file;
}
- if ($filename and length $filename) {
+ if ($filename and length $filename) {
$filename = html_quote($filename);
- } else {
+ } else {
$filename = '???';
}
if (open $file,'<',"$file/comment") {
}
my $rkeep = untaint(readlink "$file/keep"||$keep_default)
- int((time-mtime("$file/filename"))/$DS);
- if ($comment =~ /NOMAIL/ or
+ if ($comment =~ /NOMAIL/ or
(readlink "$to/\@NOTIFICATION"||'') =~ /^no/i) {
printf "%8s MB [%s d] %s/%s/%s\n",
$size,
untaint("/fup?akey=$akey&dkey=$dkey&command=RENOTIFY"),
$filename,
$comment ? qq' "$comment"' : '',
- $file eq $nfile ?
+ $file eq $nfile ?
" → notification e-mail has been resent" :
"";
}
'</body></html>'
));
exit;
- }
+ }
if ($command =~ /^LIST(RECEIVED)?$/) {
http_die("illegal command \"$command\"") if $public or $anonymous;
$filename = <$file>;
close $file;
}
- if ($filename and length $filename) {
+ if ($filename and length $filename) {
$filename = html_quote($filename);
- } else {
+ } else {
$filename = '???';
}
if (open $file,'<',"$file/comment") {
$comment = untaint(html_quote(getline($file)));
close $file;
}
- my $rkeep = untaint(readlink "$file/keep"||$keep_default)
+ my $rkeep = untaint(readlink "$file/keep"||$keep_default)
- int((time-mtime("$file/filename"))/$DS);
printf "%8s MB [%s d] <a href=\"%s\">%s</a>%s\n",
$size,
'<p><a href="javascript:history.back()">back to F*EX operation control</a>'
'</body></html>'
));
- }
+ }
# list received files
else {
$to = $from;
$filename = <$file>;
close $file;
}
- if ($filename and length $filename) {
+ if ($filename and length $filename) {
$filename = html_quote($filename);
- } else {
+ } else {
$filename = '???';
}
if (open $file,'<',"$file/comment") {
$comment = ' "'.$comment.'"';
close $file;
}
- my $rkeep = untaint(readlink "$file/keep"||$keep_default)
+ my $rkeep = untaint(readlink "$file/keep"||$keep_default)
- int((time-mtime("$file/filename"))/$DS);
printf "[<a href=\"/fup?akey=%s&dkey=%s&command=DELETE\">delete</a>] ",
$akey,$dkey;
));
}
exit;
- }
-
+ }
+
if ($command eq 'LISTSENT') {
http_die("illegal command \"$command\"") if $public or $anonymous;
- # show download URLs
+ # show download URLs
http_header('200 OK');
print html_header($head);
print "<h2>Download URLs of files you have sent\n";
));
exit;
}
-
+
if ($command eq 'FOPLOG') {
http_die("illegal command \"$command\"") if $public or $anonymous;
if (open my $log,"$logdir/fop.log") {
}
exit;
}
-
+
if ($command eq 'RECEIVEDLOG') {
http_die("illegal command \"$command\"") if $public or $anonymous;
if (open my $log,"$logdir/fup.log") {
http_header('200 OK');
while (<$log>) {
next if /\sSTDFEX\s/;
- if (/\d+$/) {
+ if (/\d+$/) {
my @F = split;
if ($F[5] eq $to) {
s/ \[[\d_]+\]//;
http_header('200 OK');
while (<$log>) {
next if /\sSTDFEX\s/;
- if (/(\S+\@\S+)/ and $1 eq $from) {
+ if (/(\S+\@\S+)/ and $1 eq $from) {
s/ \[[\d_]+\]//;
print;
}
http_die("illegal parameter <code>$del</code>");
}
$del = untaint($del);
-
+
if (unlink("$del/data") or unlink("$del/upload")) {
if (open F,'>',"$del/error") {
print F "$file has been deleted by $from\n";
http_header('200 OK',"X-File: $del");
print html_header($head);
print "<h3>$file deleted</h3>\n";
- } else {
+ } else {
http_header("404 Not Found");
print html_header($head);
print "<h3>$file not deleted</h3>\n";
}
}
-# quotas
+# quotas
if ($from and $id and $rid eq $id and @to and not $flink and not $seek) {
my ($quota,$du);
-
+
# check sender quota
($quota,$du) = check_sender_quota($muser||$from);
if ($quota and $du+$cl/$MB > $quota) {
http_die("you are overquota");
}
-
+
# check recipient quota
foreach my $to (@to) {
($quota,$du) = check_recipient_quota($to);
if (open $idf,'<',"$to/@") {
$to_reg = getline($idf);
close $idf;
- }
+ }
# sub user?
elsif (open $idf,'<',"$from/\@SUBUSER") {
while (<$idf>) {
}
$to = join(',',@to);
-
+
if ($to =~ /^@(.+)/) {
if ($nomail) {
http_die("server runs in NOMAIL mode - groups ($to) are not allowed");
# display HTML form and request user data
unless ($file) {
- if ($test) { $cgi = $test }
+ if ($test) { $cgi = $test }
else { $cgi = $ENV{SCRIPT_NAME} }
$cgi = 'fup';
-
+
# delete old cookies on logout referer
my @cookies;
if ($logout and my $cookie = $ENV{HTTP_COOKIE}) {
push @cookies,"Set-Cookie: $1=; Max-Age=0; Discard";
}
}
-
+
if (($akey or $skey or $gkey) and $from and -d $from) {
# save default locale for this user
if (not $locale and ($ENV{HTTP_COOKIE}||'') =~ /\blocale=(\w+)/) {
http_header('200 OK',@cookies);
# print html_header($head,'<img src="/fex_small.gif">');
print html_header($head);
-
+
if ($http_client =~ /(Konqueror|w3m)/) {
pq(qq(
'<p><hr><p>'
}
# default "fex yourself" setting?
- if ($from and $id and $id eq $rid and not $addto
+ if ($from and $id and $id eq $rid and not $addto
and not ($gkey or $skey or $okey or $public or $anonymous)
and (not @to or "@to" eq $from)
and -f "$from/\@FEXYOURSELF")
- {
+ {
@to = ($from);
$nomail = 'fexyourself';
}
and not ($gkey or $skey or $okey or $public or $anonymous))
{
present_locales('/fup');
-
+
@ab = ("<option></option>");
-
+
# select menu from server address book
if (open my $AB,'<',"$from/\@ADDRESS_BOOK") {
while (<$AB>) {
}
close $AB;
}
-
+
unless (@to) {
unless ($nomail) {
foreach (glob "$from/\@GROUP/*") {
}
}
}
-
+
my $ab64 = b64("from=$from&id=$id");
# '<form class="uploadform" name="upload"'
pq(qq(
'<a href="/foc?akey=$akey">user config & operation control</a>'
));
}
-
+
if ($from eq $admin ) {
pq(qq(
'<p>'
'<a href="/fac">server config & admin control</a>'
));
}
-
+
if (0 and -f "$docdir/FIX.jar") {
print "<p>\n";
if ($public) { print "<a href=\"/fix?from=$from&id=$public&to=$to\">" }
'</body></html>'
));
exit;
- }
-
+ }
+
# ask for filename
if ($from and ($id or $okey)) {
$to = $group if $group;
pq(qq(
'<script type="text/javascript">'
' function showstatus() {'
- ' var file = document.forms["upload"].elements["file"].value;'
- ' if (file != "") {'
- ' window.open('
- " '/$cgi?showstatus=$uid',"
- " 'fup_status',"
- " 'width=700,height=500'"
- ' );'
- ' return true;'
- ' }'
- ' return false;'
+ ' var file = document.forms["upload"].elements["file"].value;'
+ ' if (file == "") return false;'
+ ' window.open('
+ " '/$cgi?showstatus=$uid',"
+ " 'fup_status',"
+ " 'width=700,height=500'"
+ ' );'
+ ' return true;'
' }'
''
' function checkupload() {'
' <input type="hidden" name="from" value="$from">'
' <input type="hidden" name="filesize" value="">'
));
-
+
if ($public) {
my $toh = join('<br>',@to);
pq(qq(
));
}
}
-
+
$autodelete = lc $autodelete;
$keep = $keep_default unless $keep;
my ($quota,$du) = check_sender_quota($muser||$from);
- $quota = $quota
- ? "<tr><td>sender quota (used):<td>$quota ($du) MB</tr>"
+ $quota = $quota
+ ? "<tr><td>sender quota (used):<td>$quota ($du) MB</tr>"
: '';
-
+
$bwl = qq'<input type="text" name="bwlimit" size="8" value="$bwlimit"> kB/s';
if (@throttle) {
foreach (@throttle) {
$bwl = qq'<input type="hidden" name="bwlimit" value="$limit"> $limit kB/s';
last;
}
- }
+ }
# throttle e-mail address?
else {
# allow wildcard *, but not regexps
}
}
}
-
+
$autodelete = $autodelete{$to} if $autodelete{$to};
-
+
my $adt = '';
for ($autodelete) {
- if (/yes/i) { $adt = 'delete file after download' }
+ if (/yes/i) { $adt = 'delete file after download' }
elsif (/no/i) { $adt = 'do not delete file after download' }
- elsif (/delay/i) { $adt = 'delete file after download with delay' }
+ elsif (/delay/i) { $adt = 'delete file after download with delay' }
elsif (/^\d+$/) { $adt = "delete file $autodelete days after download" }
}
$adt .= qq'<input type="hidden" name="autodelete" value="$autodelete">';
' <p><input type="submit" value="check ID and continue"><p>'
));
if (not $nomail and (
- @local_domains and @local_hosts or
- @local_rdomains and @local_rhosts or
+ @local_domains and @local_hosts or
+ @local_rdomains and @local_rhosts or
@demo
)) {
pq(qq(
# ));
# }
print "</form>\n";
-
+
print $info_1;
if ($debug and $debug>1) {
}
print "</pre>\n";
}
-
+
print "</body></html>\n";
exit;
}
check_rr($from,$from);
@to = ($from);
$sup = 'fexyourself';
+ $keep{$from} = readlink("$from/\@KEEP")||$keep_default;
}
# all these variables should be defined here, but just to be sure...
# additional last check
unless (@group or $gkey or $skey or $public or $okey) {
foreach $to (@to) {
- checkaddress($to) or
+ checkaddress($to) or
http_die("<code>$to</code> is not a valid e-mail address");
}
}
$to = join(',',@to);
-# file overwriting for anonymous is only possible if his client has the
+# file overwriting for anonymous is only possible if his client has the
# download cookie - else request purging
if ($anonymous and not $seek and my $dkey = readlink "$to/$from/$fkey/dkey") {
if ($overwrite =~ /^n/i) {
$overwrite{$to}++ if -f $save and not -f $download;
unlink $save,$download;
rename $upload,$save or http_die("cannot rename $upload to $save - $!\n");
-
+
# log dkey
my $msg = sprintf "%s %s %s %s %s\n",
isodate(time),$dkey{$to},$from,$to,$fkey;
writelog('dkey.log',$msg);
-
+
# send notification e-mails if necessary
if (not $nomail and (readlink "$to/\@NOTIFICATION"||'') !~ /^no/i
and ($comment or not $overwrite{$to})) {
printf "%s (%s MB) received\n",$file,int($ndata/$MB);
} elsif (not $restricted and ($anonymous or $from eq $to)) {
my $size = $ndata<2*1024 ? sprintf "%s B",$ndata:
- $ndata<2*$MB ? sprintf "%s kB",int($ndata/1024):
+ $ndata<2*$MB ? sprintf "%s kB",int($ndata/1024):
sprintf "%s MB",int($ndata/$MB);
pq(qq(
'<code>$file</code> ($size) received and saved<p>'
print "Link is valid for $keep{$to} days!<p>\n";
}
}
- } elsif ($overwrite{$to} and not $comment) {
- print "(old <code>$file</code> for $to overwritten)<p>\n"
- } else {
+ } elsif ($overwrite{$to} and not $comment) {
+ print "(old <code>$file</code> for $to overwritten)<p>\n"
+ } else {
print "$to notified<p>\n"
}
}
setparam($k,$v);
}
}
-
+
# decode base64 PATH_INFO to QUERY_STRING
if ($ENV{PATH_INFO} =~ m:^/(\w+=*)$:) {
if ($qs) {
my $x = $1;
# decode URL-encoding
s/%([a-f0-9]{2})/chr(hex($1))/gie;
- setparam($x,$_);
+ setparam($x,$_);
}
}
}
);
&reexec;
}
-
+
if ($showstatus) {
&showstatus;
exit;
}
-
+
# check for akey, gkey and skey (from HTTP GET)
&check_keys;
-
+
if ($ENV{REQUEST_METHOD} eq 'POST' and $cl) {
foreach $sig (keys %SIG) {
if ($sig !~ /^(CHLD|CLD)$/) {
$cl,$ENV{REMOTE_ADDR}||'',$ENV{REMOTE_HOST}||''),"\n");
&check_space($cl) if $cl > 0;
-
+
$SIG{ALRM} = sub { die "TIMEOUT\n" };
alarm($timeout);
binmode(STDIN,':raw');
-
+
if (defined($ENV{FEX_FILENAME})) {
# JUP via HTTP header
$file = $param{'FILE'} = $ENV{FEX_FILENAME};
} else {
http_die("malformed HTTP POST (no boundary found)");
}
-
+
READPOST: while (&nvt_read) {
# the file itself - *must* be last part of POST!
if (/^Content-Disposition:\s*form-data;\s*name="file";\s*filename="(.+)"/i) {
push @header,$_;
}
# STDIN is now at begin of file, will be read later with get_file()
- last;
+ last;
}
# all other parameters
if (/^Content-Disposition:\s*form-data;\s*name="([a-z]\w*)"/i) {
}
}
}
-
+
if (length($file)) {
$file =~ s/%(\d+)/chr($1)/ge;
$file = untaint(strip_path(normalize($file)));
}
# collect multiple addresses and check for aliases (not group)
- if (@to and "@to" !~ /^@[\w-]+$/
- and not ($gkey or $addto or $command =~ /^LIST(RECEIVED)?$/))
+ if (@to and "@to" !~ /^@[\w-]+$/
+ and not ($gkey or $addto or $command =~ /^LIST(RECEIVED)?$/))
{
-
+
# read address book
if ($from and open my $AB,'<',"$from/\@ADDRESS_BOOK") {
my ($alias,$address,$autodelete,$locale,$keep);
} elsif ($autodelete{$to}) {
$autodelete{$address} = $autodelete{$to};
} else {
- $autodelete{$address} = readlink "$address/\@AUTODELETE"
+ $autodelete{$address} = readlink "$address/\@AUTODELETE"
|| $autodelete;
}
if (my $locale = readlink "$address/\@LOCALE") {
}
}
@to = keys %to;
-
+
if (scalar(@to) == 1) {
- $to = "@to";
+ $to = "@to";
$keep = $keep{$to} if $keep{$to};
$autodelete = $autodelete{$to} if $autodelete{$to};
}
-
+
# check recipients and eliminate dupes
%to = ();
foreach $to (@to) {
my ($t0,$t1,$t2,$tt,$ts,$tm);
my ($osize,$percent,$npercent);
local $_;
-
+
$wclose = '<p><a href="#" onclick="window.close()">close</a>'."\n".
'</body></html>'."\n";
$ukey = "$ukeydir/$uid";
sleep 1;
$tsize = readlink $sfile and last;
# upload error?
- # remark: stupid Internet Explorer *needs* the error represented in this
+ # remark: stupid Internet Explorer *needs* the error represented in this
# asynchronous popup window, because it cannot display the error in the
# main window on HTTP POST!
- if (-f $ukey and open $ukey,'<',$ukey or
+ if (-f $ukey and open $ukey,'<',$ukey or
-f "$ukey/error" and open $ukey,'<',"$ukey/error") {
undef $/;
unlink $ukey;
}
}
# unlink $sfile;
-
+
if (defined $tsize and $tsize == 0) {
print "<script type='text/javascript'>window.close()</script>\n";
exit;
"no file data received - does your file exist or is it >2GB?")
}
html_error($error,"file size unknown") unless $tsize =~ /^\d+$/;
-
+
http_header('200 OK');
if (open $ukey,'<',"$ukey/filename") {
local $/;
close $ukey;
}
http_die("no filename?!") unless $file;
-
+
my $ssize = $tsize;
if ($ssize<2097152) {
$ssize = sprintf "%d kB",int($ssize/1024);
} else {
$ssize = sprintf "%d MB",int($ssize/1048576);
}
-
+
pq(qq(
"<html><body>"
"<center>"
"<div style='float:left;width:0%;background:black;height:20px;' id='bar'>"
"</div></div>"
));
-
+
# wait for upload file
for (1..9) {
last if -f $upload or -f $data;
print $wclose;
exit;
}
-
+
$SIG{ALRM} = sub { die "TIMEOUT in showstatus: no (more) data received\n" };
alarm($timeout*2);
-
+
$t0 = $t1 = time;
$osize = $percent = $npercent = 0;
-
+
for ($percent = 0; $percent<100; sleep(1)) {
$t2 = time;
$nsize = -s $upload;
# so, updating more often is contra-productive
if ($t2>$t1+5 or $npercent>$percent) {
$percent = $npercent;
- $t1 = $t2;
+ $t1 = $t2;
$tm = int(($t2-$t0)/60);
$ts = $t2-$t0-$tm*60;
$tt = sprintf("%d:%02d",$tm,$ts);
)) or last;
}
}
-
+
alarm(0);
if ($npercent == 100) {
print "<h3>file successfully transferred</h3>\n";
http_die("<code>$filed</code> locked: a download is currently in progress");
}
}
-
+
# prepare upload
foreach $to (@to) {
$to =~ s/:\w+=.*//; # remove options from address
$filed = "$to/$from/$fkey";
$nupload = "$filed/upload"; # upload for next recipient
mkdirp($filed);
-
+
# upload already prepared (for first recipient)?
if ($upload) {
# link upload for next recipient
unless ($upload eq $nupload or
-r $upload and -r $nupload and
- (stat $upload)[1] == (stat $nupload)[1])
+ (stat $upload)[1] == (stat $nupload)[1])
{
unlink $nupload;
link $upload,$nupload;
}
- }
-
+ }
+
# first recipient => create upload
else {
$upload = $nupload;
symlink "../$filed","$ukeydir/$uid";
}
}
-
+
unlink "$filed/autodelete",
"$filed/error",
"$filed/restrictions",
"$filed/comment",
"$filed/notify";
unlink "$filed/size" unless $seek;
-
+
# showstatus needs file name and size
# fexsend needs full file size (+$seek)
$fh = "$filed/filename";
unless ($seek) {
if ($::filesize > 0) {
# total file size as reported by POST
- mksymlink("$filed/size",$::filesize)
+ mksymlink("$filed/size",$::filesize)
or die "cannot write $filed/size - $!\n";
} else {
# file size as counted
- mksymlink("$filed/size",$filesize)
+ mksymlink("$filed/size",$filesize)
or die "cannot write $filed/size - $!\n";
}
}
}
-
+
if ($from eq "@to") {
# special "fex yourself"
mksymlink("$filed/autodelete",'NO');
if ($replyto and $replyto =~ /.@./) {
mksymlink("$filed/replyto",$replyto);
}
-
+
my $arh = "$from/\@ALLOWED_RHOSTS";
if (-s $arh) {
copy($arh,"$filed/restrictions");
}
-
+
if (@header and open $fh,'>',"$filed/header") {
print {$fh} join("\n",@header),"\n";
close $fh;
}
-
+
if ((readlink "$to/\@NOTIFICATION"||'') =~ /^no/i) {
$nomail{$to} = 'NOTIFICATION';
}
if ($nomail) {
open $fh,'>',"$filed/notify" and close $fh;
- }
+ }
if ($comment) {
if (open $fh,'>',"$filed/comment") {
print {$fh} encode_utf8($comment);
unless ($dkey = readlink("$filed/dkey") and -l "$dkeydir/$dkey") {
$dkey = randstring(8);
unlink "$dkeydir/$dkey";
- symlink "../$filed","$dkeydir/$dkey"
+ symlink "../$filed","$dkeydir/$dkey"
or http_die("cannot symlink $dkeydir/$dkey ($!)");
unlink "$filed/dkey";
symlink $dkey,"$filed/dkey";
}
-
+
}
# extra download (XKEY)?
if ($anonymous and $fkey =~ /^afex_\d/ or
- $from eq "@to" and $comment =~ s:^//(.*)$:NOMAIL:)
+ $from eq "@to" and $comment =~ s:^//(.*)$:NOMAIL:)
{
$xkey = $1||$fkey;
$nomail = $comment;
if (-e $x) {
http_die("extra download key $xkey already exists");
}
- symlink "../$from/$from/$fkey",$x
+ symlink "../$from/$from/$fkey",$x
or http_die("cannot symlink $x - $!\n");
unlink "$x/xkey";
symlink $xkey,"$x/xkey";
}
}
-
+
}
-
+
# file link?
if ($flink) {
# upload link has been already created, no data to read any more
# at last, read (real) file data
$t0 = time();
-
+
# streaming data?
if ($cl == -1) {
alarm($timeout*2);
}
# size of transferred file, without end boundary
$ndata = untaint($fb-$ebl);
- }
-
+ }
+
# normal file with known file size
else {
-
+
if ($fpsize) {
debuglog(sprintf("still awaiting %d+%d = %d bytes",
$fpsize,$ebl,$fpsize+$ebl));
}
# read until end boundary, not EOF
while ($RB < $cl-$ebl) {
- $b = $cl-$ebl-$RB;
+ $b = $cl-$ebl-$RB;
$b = $bs if $b > $bs;
# max wait for 1 kB/s, but at least 10 s
# $timeout = $b/1024;
}
$RB += $ebl;
$ndata = untaint($fb);
- }
+ }
alarm(0);
-
+
unless ($nostore) {
close $upload; # or die "cannot close $upload - $!\n";;
-
+
# throuput in kB/s
$tt = (time-$t0) || 1;
mksymlink("$filed/speed",int($fb/1024/$tt));
-
+
unless ($ndata) {
http_die(
"No file data received!".
" File too big (browser-limit: 2 GB!)?"
);
}
-
+
$to = join(',',@to);
-
+
# streaming upload?
if ($cl == -1) {
-
+
open $upload,'<',$upload or http_die("internal error - cannot read upload");
seek $upload,$ndata+2,0;
$_ = <$upload>||'';
}
close $upload;
truncate $upload,$ndata;
-
+
} else {
-
+
# truncate boundary string
# truncate $upload,$ndata+$uss if -s $upload > $ndata+$uss;
-
+
# incomplete?
if ($cl != $RB) {
fuplog($to,$fkey,$ndata,'(aborted)');
http_die("read $RB bytes, but CONTENT_LENGTH announces $cl bytes");
}
}
-
+
# multipost, not complete
if ($::filesize > -s $upload) {
http_header('206 Partial OK');
exit;
}
-
+
# save error?
if (-s $upload > ($::filesize||$filesize)) {
fuplog($to,$fkey,$ndata,'(write error: upload > filesize)');
http_die("internal server error while writing file data");
}
-
+
}
fuplog($to,$fkey,$ndata);
debuglog("upload successfull, dkey=$dkey");
my @to = @_;
my $rr = "$from/\@ALLOWED_RECIPIENTS";
my ($allowed,$to,$ar,$rd);
-
+
if (-s $rr and open $rr,'<',$rr) {
$restricted = $rr;
chomp;
s/#.*//;
s/\s//g;
-
+
if (/^\@LOCAL_RDOMAINS/) {
$ar = '(@';
foreach (@local_rdomains) {
$ar = quotemeta $_;
$ar =~ s/\\\*/[^@]*/g;
}
-
+
if ($to =~ /^$ar$/i) {
$allowed = 1;
last;
}
-
+
}
-
+
unless ($allowed) {
fuplog("ERROR: $from not allowed to fex to $to");
debuglog("$to not in $spooldir/$from/\@ALLOWED_RECIPIENTS");
http_die("You ($from) are not allowed to fex to $to");
}
}
-
+
close $rr;
}
}
sub expand {
my @users = @_;
my @ua;
-
+
foreach my $u (my @loop = @users) {
- if ($u =~ /^anonymous(_\d+)?$/) {
+ if ($u =~ /^anonymous(_\d+)?$/) {
$u = "$u\@$hostname";
}
- if ($u eq 'nettest') {
+ if ($u eq 'nettest') {
if ($mdomain and -d "$u\@$mdomain") {
$u .= "\@$mdomain"
} elsif (-d "$u\@$hostname") {
- $u .= "\@$hostname"
+ $u .= "\@$hostname"
}
}
- if ($u =~ /@/) { push @ua,$u }
- elsif ($mdomain) { push @ua,"$u\@$mdomain" }
- elsif (-d "$u\@$hostname") { push @ua,"$u\@$hostname" }
+ if ($u =~ /@/) { push @ua,$u }
+ elsif ($mdomain) { push @ua,"$u\@$mdomain" }
+ elsif (-d "$u\@$hostname") { push @ua,"$u\@$hostname" }
else { push @ua,$u }
}
-
+
return wantarray ? @ua : join(',',@ua);
}
print html_header($head);
@to = keys %to;
-
+
foreach my $to (my @loop = @to) {
$to =~ s/:\w+=.*//; # remove options from address
$nfile = $file;
unless ($dkey = readlink("$nfile/dkey") and -l "$dkeydir/$dkey") {
$dkey = randstring(8);
unlink "$dkeydir/$dkey";
- symlink "../$nfile","$dkeydir/$dkey"
+ symlink "../$nfile","$dkeydir/$dkey"
or http_die("cannot symlink $dkeydir/$dkey");
unlink "$nfile/dkey";
- symlink $dkey,"$nfile/dkey"
+ symlink $dkey,"$nfile/dkey"
or http_die("cannot create $nfile/dkey - $!");
}
-
+
if ($nomail or $nomail{$to}) {
if ($filename) {
my $url = "$durl/$dkey/".normalize_filename($filename);
sub setparam {
my ($v,$vv) = @_;
my ($idf,$to);
-
+
$v = uc(despace($v));
# if ($vv =~ /([<>])/) {
$locale = $1;
} elsif ($v eq 'REDIRECT' and $vv =~ /^([\w?=]+)$/) {
$redirect = $1;
- } elsif (($v eq 'KEY' or $v eq 'SKEY') and $vv =~ /^([\w:]+)$/) {
+ } elsif (($v eq 'KEY' or $v eq 'SKEY') and $vv =~ /^([\w:]+)$/) {
$skey = $1;
$restricted = $v;
- } elsif ($v eq 'GKEY' and $vv =~ /^([\w:]+)$/) {
+ } elsif ($v eq 'GKEY' and $vv =~ /^([\w:]+)$/) {
$gkey = $1 unless $nomail;
$restricted = $v;
- } elsif ($v eq 'DKEY' and $vv =~ /^(\w+)$/) {
+ } elsif ($v eq 'DKEY' and $vv =~ /^(\w+)$/) {
$dkey = $1;
- } elsif ($v eq 'AKEY' and $vv =~ /^(\w+)$/) {
+ } elsif ($v eq 'AKEY' and $vv =~ /^(\w+)$/) {
$akey = $1;
- } elsif ($v eq 'FROM' or $v eq 'USER') {
+ } elsif ($v eq 'FROM' or $v eq 'USER') {
$from = normalize_email($vv);
$from = untaint(expand($from));
checkchars('from address',$from);
# maybe FROM=SUBUSER !
# checkaddress($from) or http_die("FROM $from is no legal e-mail address");
- } elsif ($v eq 'REPLYTO') {
+ } elsif ($v eq 'REPLYTO') {
$replyto = normalize_email($vv);
checkchars('replyto address',$replyto);
- checkaddress($replyto) or
+ checkaddress($replyto) or
http_die("REPLYTO $replyto is no legal e-mail address");
} elsif ($v eq 'ADDTO') {
$vv =~ s/\s.*//;
} elsif ($v eq 'SEEK' and $vv =~ /^(\d+)$/) {
$seek = $1;
} elsif ($v eq 'FILESIZE' and $vv =~ /^(\d+)$/) {
- $filesize = $1; # complete filesize!
+ $filesize = $1; # complete filesize!
&check_space($filesize-$seek);
} elsif ($v eq 'AUTODELETE' and $vv =~ /^(\w+)$/) {
$specific{'autodelete'} = $autodelete = uc($1);
$keep = $keep_max if $keep_max and $keep > $keep_max;
$specific{'keep'} = $keep;
} elsif ($v eq 'TIMEOUT' and $vv =~ /^(\d+)$/) {
- $specific{'timeout'} = $timeout = $1;
+ $specific{'timeout'} = $timeout = $1;
}
}
sub id_forgotten {
my ($id,$to,$subuser,$gm,$skey,$gkey,$url,$fup);
-
+
return if $nomail;
-
+
$fup = $durl;
$fup =~ s:/fop:/fup:;
-
+
# full user
if (open $from,'<',"$from/\@") {
$id = getline($from);
)));
exit;
}
-
+
# sub user
foreach my $skey (glob("$skeydir/*")) {
if (-f $skey and open $skey,'<',$skey) {
exit;
}
}
-
+
# group user
foreach my $gkey (glob("$gkeydir/*")) {
if (-f $gkey and open $gkey,'<',$gkey) {
# sid is not set with web browser
# akey with sid is set with schwuppdiwupp & co
$idf = "$akeydir/$akey/@";
-
+
if (open $idf,'<',$idf and $id = getline($idf)) {
close $idf;
$from = readlink "$akeydir/$akey"
my $req = shift;
my ($df,$free,$uprq);
local *P;
-
+
if (open $df,"df -k $spooldir|") {
while (<$df>) {
if (/^.+?\s+\d+\s+\d+\s+(\d+)/ and $req/1024 > $1) {
# global substitution as a function like in gawk
-sub gsub {
+sub gsub {
local $_ = shift;
- my ($p,$r) = @_;
- s/$p/$r/g;
+ my ($p,$r) = @_;
+ s/$p/$r/g;
return $_;
}
# standard log
sub fuplog {
my $msg = "@_";
-
+
$msg =~ s/\n/ /g;
$msg =~ s/\s+$//;
$msg = sprintf "%s [%s_%s] %s (%s) %s\n",
encode_Q($file||'-'),
$msg,
$RB?"(after $RB bytes)":"";
-
+
writelog($log,$msg);
-
+
if ($sig eq 'DIE') {
shift;
die "$msg\n";
my $url = shift;
my @locales = @::locales; # from fex.ph
my ($locale,$lang);
-
- if ($url =~ /\?/) {
+
+ if ($url =~ /\?/) {
$url .= "&";
$url =~ s/locale=\w+&//g;
- } else {
+ } else {
$url .= "?";
}
-
+
if (@locales) {
map { $_ = "$FEXHOME/locale/$_" } @locales;
} else {
sub check_camel {
my ($logo,$camel);
local $/;
-
+
if (open $logo,"$docdir/logo.jpg") {
$camel = md5_hex(<$logo>) eq 'ad8a95bba8dd1a61d70bd38611bc2059';
}
&check_maint;
-unless (@local_domains and @local_rdomains) {
+unless (@local_domains or @local_rdomains) {
html_error($error,
"No domains for registrations are defined.",
"Contact $ENV{SERVER_ADMIN} for details."
);
}
-unless (@local_hosts and ipin($ENV{REMOTE_ADDR}||0,@local_hosts)) {
+unless (@local_hosts and ipin($ra,@local_hosts) or
+ @local_rhosts and ipin($ra,@local_rhosts)) {
html_error($error,
- "Registrations from your host ($ENV{REMOTE_ADDR}) are not allowed.",
+ "Registrations from your host ($ra) are not allowed.",
"Contact $ENV{SERVER_ADMIN} for details."
);
}
}
# if (-f "$user/@") { http_die("$user is already activated") }
open $user,'>',"$user/@" or http_die("open $user/@ - $!\n");
- print {$user} $id,"\n";
+ print {$user} $id,"\n";
close $user or http_die("close $user/@ - $!\n");
-
+
http_header("200 OK");
print html_header($head);
my $url = "$ENV{PROTO}://$ENV{HTTP_HOST}/fup/" . b64("from=$user&id=$id");
'<p>'
'or you can use:'
'<p>'
- '<table>
+ '<table>'
' <tr><td>URL:<td><code><b>$ENV{PROTO}://$ENV{HTTP_HOST}/fup/</code></b></tr>'
' <tr><td>Sender:<td><code><b>$user</code></b></tr>'
' <tr><td>auth-ID:<td><code><b>$id</code></b></tr>'
- '</table>
+ '</table>'
'</body></html>'
));
furlog("confirm: account $user created");
' accept-charset="UTF-8"'
' enctype="multipart/form-data">'
));
-
+
if (@local_domains and @local_hosts and ipin($ra,@local_hosts)) {
$reg = $ra;
if (grep(/\*/,@local_domains)) {
));
}
}
-
- if (@local_rdomains and @local_rhosts and
+
+ if (@local_rdomains and @local_rhosts and
(not @registration_hosts or ipin($ra,@registration_hosts))) {
print " <p>or<p>\n" if $reg;
$reg = $ra;
' <p>'
));
}
-
+
if (@demo) {
print " <p>or<p>\n" if $reg;
$reg = $ra;
' <p>'
));
}
-
+
if ($reg) {
pq(qq(
' <p>'
$mydomains .= "|$mdomain" if $mdomain;
$user .= '@'.$domain if $domain and $user !~ /@/;
# $user .= '@'.$mdomain if $mdomain and $user !~ /@/;
-
+
unless (@local_hosts and ipin($ra,@local_hosts)) {
html_error($error,
"Registrations from your host ($ra) are not allowed.",
$error,
"you are already registered".
" (<a href=\"/fup?from=$user&ID_forgotten=1\">I have lost my auth-ID</a>)"
- );
+ );
}
unless (-d $user) {
print {$rf} "\@LOCAL_RHOSTS\n";
close $rf;
if (open $user,'>',"$user/.auto") {
- print {$user} "fur:external\n";
+ print {$user} "fur:external\n";
close $user;
}
} elsif ($demouser) {
printf {$quota} "sender:%d\n",$demo[0];
close $quota;
if (open $user,'>',"$user/.auto") {
- print {$user} "fur:demo\n";
+ print {$user} "fur:demo\n";
close $user;
}
open $demouser,'>',"$demouser/.demo" and close $demouser;
} else {
if (open $user,'>',"$user/.auto") {
- print {$user} "fur:internal\n";
+ print {$user} "fur:internal\n";
close $user;
}
}
if ("@local_domains" eq "*") {
open $id,'>',"$user/@" or http_die("open $user/@ - $!\n");
- print {$id} $id,"\n";
+ print {$id} $id,"\n";
close $id or http_die("close $user/@ - $!\n");
http_header("200 OK");
print html_header($head);
# from fexsend
if ($verify eq 'no') {
open $id,'>',"$user/@" or http_die("open $user/@ - $!\n");
- print {$id} $id,"\n";
+ print {$id} $id,"\n";
close $id or http_die("close $user/@ - $!\n");
http_header("200 OK",'Content-Type: text/plain');
print "$ENV{PROTO}://$ENV{HTTP_HOST}/fup?from=$user&ID=$id\n";
http_header("200 OK");
print html_header($head);
print "confirmation e-mail has been sent to <code>$user</code>\n";
-print "</body></html>\n";
+print "</body></html>\n";
furlog("confirmation request mailed to $user");
exit;
# standard log
sub furlog {
my $msg = "@_";
-
+
$msg =~ s/\n/ /g;
$msg =~ s/\s+$//;
$msg = sprintf "%s [%s_%s] %s %s\n",
isodate(time),$$,$ENV{REQUESTCOUNT},$fra,$msg;
-
+
writelog($log,$msg);
}
my $qs = $ENV{QUERY_STRING};
(my $multi) = $qs =~ s/(^|&)multi//;
-
+
# parse HTTP QUERY_STRING (parameter=value pairs)
if ($qs) {
foreach (split '&',$qs) {
ord($1)
));
}
- setparam($x,$_);
+ setparam($x,$_);
}
}
}
}
binmode(STDIN,':raw');
-
+
READPOST: while (&nvt_read) {
if (/^Content-Disposition:\s*form-data;\s*name="([a-z]\w*)"/i) {
my $x = $1;
exec($FEXHOME.'/bin/fexsrv') if $ENV{KEEP_ALIVE};
exit;
}
-
+
http_header('200 ok');
print html_header($head);
# set parameter variables
sub setparam {
my ($v,$vv) = @_;
-
+
$v = uc(despace($v));
if ($v eq 'LOCALE' and $vv =~ /^(\w+)$/) {
$locale = $1;
- } elsif ($v eq 'FROM') {
+ } elsif ($v eq 'FROM') {
$from = normalize_email($vv);
} elsif ($v eq 'TO') {
$to = normalize_email($vv);
foreach my $v (keys %PARAM) {
my $vv = $PARAM{$v};
$vv =~ s/[<>\'\`\"\000-\037]//g;
- if ($v =~ /^akey$/i and $vv =~ /^(\w+)$/) {
+ if ($v =~ /^akey$/i and $vv =~ /^(\w+)$/) {
$akey = $1;
} elsif ($v =~ /^(from|user)$/i) {
$from = normalize_address($vv);
}
if ($nto) {
-
+
# read aliases from address book
if (open my $AB,'<',"$from/\@ADDRESS_BOOK") {
while (<$AB>) {
# standard log
sub ruplog {
my $msg = "@_";
-
+
$msg =~ s/\n/ /g;
$msg =~ s/\s+$//;
$msg = sprintf "%s [%s_%s] (%s) %s\n",
my $lock = "$stream/lock";
open $lock,'>>',$lock or error(503,"Cannot open $lock : $!");
flock $lock,LOCK_EX|LOCK_NB or error(409,"$stream already in use");
-
+
chmod 0600,$fifo;
unlink "$stream/mode";
unlink "$stream/type";
symlink $pmode,"$stream/mode" if $pmode;
symlink $type, "$stream/type" if $type;
- $SIG{PIPE} = sub {
- sleep 1;
- rmrf($stream);
- exit;
+ $SIG{PIPE} = sub {
+ sleep 1;
+ rmrf($stream);
+ exit;
};
- $SIG{ALRM} = sub {
- syswrite STDOUT,".";
- exit if $!;
- $ALARM = 1;
+ $SIG{ALRM} = sub {
+ syswrite STDOUT,".";
+ exit if $!;
+ $ALARM = 1;
};
- syswrite STDOUT,"HTTP/1.9 199 Hold on";
+ syswrite STDOUT,"HTTP/1.9 199 Hold on";
for (my $i=0;$i<$timeout;$i++) {
alarm(1);
$ALARM = 0;
unless ($ALARM) { error(503,"Cannot open $fifo : $!") }
}
alarm(0);
- syswrite STDOUT,"\r\n";
-
- unless (fileno $fifo) {
+ syswrite STDOUT,"\r\n";
+
+ unless (fileno $fifo) {
rmrf($stream);
error(504,"Timeout");
}
-
+
header('200 OK');
$B = 0;
}
elsif ($mode eq 'POP') {
$stream =~ s:/STDSTR:/PUBLIC: if $id eq 'public';
- unless ($id eq 'public' and (readlink "$stream/mode"||'') eq 'PUBLIC'
+ unless ($id eq 'public' and (readlink "$stream/mode"||'') eq 'PUBLIC'
or $user =~ /^anonymous/) {
&authentificate;
}
alarm(0);
header('200 OK',$type);
sexlog($mode);
-
+
while (sysread($fifo,$_,$bs)) {
syswrite STDOUT,$_ or die $!;
}
exit;
-
-}
+
+}
else {
error(405,"Unknown Request");
}
sub setparam {
my ($v,$vv) = @_;
-
+
$v = uc(despace($v));
$vv = untaint(normalize($vv));
# $param{$v} = $vv;
- if ($v eq 'USER') { $user = lc(despace($vv)) }
- elsif ($v eq 'ID') { $id = despace($vv) }
- elsif ($v eq 'MODE') { $pmode = uc(despace($vv)) }
- elsif ($v eq 'TYPE') { $type = uc(despace($vv)) }
+ if ($v eq 'USER') { $user = lc(despace($vv)) }
+ elsif ($v eq 'ID') { $id = despace($vv) }
+ elsif ($v eq 'MODE') { $pmode = uc(despace($vv)) }
+ elsif ($v eq 'TYPE') { $type = uc(despace($vv)) }
elsif ($v eq 'STREAM') { $stream = normalize_filename($vv) }
- elsif ($v eq 'BS' and $vv =~ /(\d+)/) { $bs = $1 }
+ elsif ($v eq 'BS' and $vv =~ /(\d+)/) { $bs = $1 }
elsif ($v eq 'TIMEOUT' and $vv =~ /(\d+)/) { $timeout = $1 }
elsif ($v eq 'ANONYMOUS') { $id = $user ='anonymous'; $stream = $vv; }
}
sub sexlog {
my $msg = "@_";
-
+
$msg =~ s/\n/ /g;
$msg =~ s/\s+$//;
$msg = sprintf "%s [%s_%s] %s (%s) %s\n",
isodate(time),$$,$ENV{REQUESTCOUNT},$user,$fra,$msg;
-
+
foreach my $log (@logdir) {
if (open $log,'>>',"$log/sex.log") {
flock $log,LOCK_EX;
sub sigexit {
my ($sig) = @_;
my $msg = "@_";
-
+
$msg =~ s/\n/ /g;
$msg =~ s/\s+$//;
$msg = sprintf "%s %s (%s) caught SIGNAL %s\n",
isodate(time),$user||'-',$fra||'-',$msg;
-
+
foreach my $log (@logdir) {
if (open $log,'>>',"$log/sex.log") {
flock $log,LOCK_EX;
+2015-08-26 fur: fixed bug no registration possible
+2015-08-25 fup: fixed bug uninitialized value when called by sup.html
+ 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()
2015-07-29 install: fixed various bugs
2015-07-15 dop: symbolic links generate a HTTP 302 (temporarily redirection)
instead of a HTTP 301 (permanently redirection) response
-fex-20150729
+fex-20150826
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';
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;
my @rcamel = (
'\e[A
-(_*) _ _
+(_*) _ _
\\\\/ \\/ \\
\ __ )=*
- //\\\\//\\\\
+ //\\\\//\\\\
',
-'\e[A \\\\/\\\\/
+'\e[A \\\\/\\\\/
',
'\e[A //\\\\//\\\\
');
exit if $opt_s eq '-';
unlink $download unless -s $download;
exit 2 unless -f $download;
-
+
if ($windoof) {
print "READY\n";
exit;
}
unless ($opt_X) {
-
+
foreach my $a (keys %autoview) {
if ($download =~ /$a$/i and $autoview{$a}) {
printf "run \"%s %s\" [Yn] ? ",$autoview{$a},basename($download);
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')) {
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) {
my $d = $download;
my $xd = '.';
local $_;
-
+
if (-t and not $windoof) {
print "Files in archive:\n";
system(split(' ',$l),$download);
if ($xd eq '-') {
print "keeping $download\n";
exit;
- }
+ }
if ($xd !~ s/!$//) {
if (-d $xd) {
print "directory $xd does already exist, add \"!\" to overwrite\n";
"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
}
}
close $list;
-
+
if ($n) {
$cmd = "fexsend -d $n >/dev/null 2>&1";
print "$cmd\n" if $opt_v;
}
close $SH;
close X;
-
+
print $rcamel[2] if ${'opt_+'};
$tt = $t2-$t0;
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;
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($_ = <STDIN>||'');
} else {
$prompt =~ s/([\?:=]\s*)/ [$default]$1/ or $prompt .= " [$default]";
}
return $_;
- }
-}
+ }
+}
### common functions ###
$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);
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) {
# 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";
Proto => 'tcp',
);
}
-
+
if ($SH) {
autoflush $SH 1;
} else {
die "$0: cannot connect $server:$port - $@\n";
}
-
+
print "TCPCONNECT to $server:$port\n" if $opt_v;
}
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";
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) {
return 0;
}
}
-
+
return 1;
}
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+/|;
our ($FEXID,$FEXXX,$HOME);
our (%alias);
our $chunksize = 0;
-our $version = 20150729;
+our $version = 20150826;
our $_0 = $0;
our $DEBUG;
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);
$hints = <<EOD;
$0 hints and more options:
-
+
usage: $0 [options] file recipient(s)
Recipient can be a comma separated address list. Example:
$0 big.file framstag\@rus.uni-stuttgart.de,webmaster\@flupp.org
-Recipient can be an alias from your server address book
+Recipient can be an alias from your server address book
(use "$0 -A" to edit it). Example:
$0 big.file framstag
Recipient can be a SKEY URL, which you have received from a regular F*EX user.
-When using this URL you are a subuser of this full user and the file will be
+When using this URL you are a subuser of this full user and the file will be
sent to him. Example:
$0 big.file http://fex.rus.uni-stuttgart.de/fup?skey=4285f8cdd881626524fba686d5f0a83a
members of this group. Example:
$0 big.file http://fex.rus.uni-stuttgart.de/fup?gkey=50d26547b1e8c1110beb8748fc1d9444
-When you use "FEX-URL/anonymous" as recipient and your F*EX administrator has
+When you use "FEX-URL/anonymous" as recipient and your F*EX administrator has
allowed anonymous upload for your IP address then no auth-ID is needed.
-
-"." as recipient means fex to yourself and show immediately the download URL
+
+"." as recipient means fex to yourself and show immediately the download URL
(no notification e-mail will be sent). Example:
$0 software.tar .
-F activates female mode
-U show authorized URL
-+ is an undocumented feature - test it :-)
-
-To manage your subuser and groups or forward or redirect files, use a
+
+To manage your subuser and groups or forward or redirect files, use a
webbrowser with the URL from "$0 -U", e.g.: firefox \$($0 -U)
If you want to copy-forward an already uploaded file to another recipient,
You can list an uploaded file in more detail with
$0 -l #
Where # is the file number.
-
+
If you want to modify the keep time, comment or auto-delete behaviour of an
already uploaded file then you first have to query the file number with:
$0 -l
Where # is the file number.
With option -a you can send several files or whole directories within a single
-archive file. The archive types tar and tgz are build on-the-fly (streaming)
+archive file. The archive types tar and tgz are build on-the-fly (streaming)
whereas archive types zip and 7z need a temporary archive file on local disk.
With option -s you can send any data coming from a pipe (STDIN) as a file
without wasting local disc space.
-
+
With option -X you can specify any parameter, e.g.: -X autodelete=yes
For HTTPS you can set the environment variables:
SSLCAPATH=/etc/ssl/certs # path to trusted (root) certificates
SSLCAFILE=/etc/ssl/cert.pem # file with trusted (root) certificates
SSLCIPHERLIST=HIGH:!3DES # see http://www.openssl.org/docs/apps/ciphers.html
-
+
Partner program xx is an internet clipboard. See: xx -h
-
+
Partner program fexget is for downloading. See: fexget -h
-
-For temporary usage of a HTTP proxy use:
+
+For temporary usage of a HTTP proxy use:
$0 -P your_proxy:port:chunksize_in_MB file recipient
Example:
$0 -P wwwproxy.uni-stuttgart.de.de:8080:1024 4GB.tar .
-
-For temporary usage of an alternative F*EX server or user use:
+
+For temporary usage of an alternative F*EX server or user use:
FEXID="FEXSERVER USER AUTHID" $0 file recipient
Example:
FEXID="fex.flupp.org gaga\@flupp.org blubb" $0 big.file framstag\@rus.uni-stuttgart.de
fexsend also respects aliases in $HOME/.mutt/aliases
The alias priority is (descending):
\$HOME/.fex/config.pl
-\$HOME/.mutt/aliases
-fexserver address book
+\$HOME/.mutt/aliases
+fexserver address book
In \$HOME/.fex/config.pl you can also set the SSL* environment variables and the
\$opt_* variables, e.g.:
-
+
\$ENV{SSLVERSION} = 'TLSv1';
\${'opt_+'} = 1;
\$opt_m = 200;
*=( __ /
\\\\/\\\\/
',
-'\e[A \\\\/\\\\/
+'\e[A \\\\/\\\\/
',
'\e[A //\\\\//\\\\
');
$opt_u = $opt_f = $opt_a = $opt_C = $opt_i = $opt_b = $opt_P = $opt_X = '';
$opt_s = $opt_r = '';
$_ = "$fexhome/config.pl"; require if -f;
- getopts('hHvcdognVDKlILUARWMFzZqQS@!+./r:m:k:u:f:a:s:C:i:b:P:x:X:N:=:#:')
+ getopts('hHvcdognVDKlILUARWMFzZqQS@!+./r:m:k:u:f:a:s:C:i:b:P:x:X:N:=:#:')
or die $usage;
if ($opt_H) {
print $hints;
exit;
}
-
+
if ($opt_V) {
print "Version: $version\n";
}
-
+
if ($opt_K and $opt_D) {
die "$0: you cannot use both options -D and -K\n";
}
}
# $opt_C is COMMENT command in F*EX protocol
- $opt_C =
+ $opt_C =
($opt_d) ? 'DELETE':
($opt_l or $opt_L) ? 'LIST':
($opt_Q) ? 'CHECKQUOTA':
($opt_z) ? 'SENDLOG':
(${'opt_!'}) ? 'FOPLOG':
$opt_C;
-
- $opt_D =
+
+ $opt_D =
($opt_D) ? 'DELAY':
($opt_K) ? 'NO':
$opt_D;
die $usage if $opt_m and $opt_m !~ /^\d+/;
-if ($opt_P) {
+if ($opt_P) {
if ($opt_P =~ /^([\w.-]+:\d+)(:(\d+))?/) {
$proxy = $1;
$chunksize = $3 || 0;
unlink $idf.'xx';
}
}
-
+
# special xx ID?
if ($FEXXX = $ENV{FEXXX}) {
$FEXXX = decode_b64($FEXXX) if $FEXXX !~ /\s/;
}
close $idf;
}
-
+
} else {
# alternativ ID?
}
if ($opt_I) {
- if ($xx) { &show_id }
+ if ($xx) { &show_id }
else { &init_id }
exit;
}
} 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";
}
$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;
}
$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";
&send_xx($transferfile);
}
exit;
-}
+}
# regular fexsend
}
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 }
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";
}
}
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 = <STDIN>;
print "proxy address (hostname:port or empty if none): ";
$proxy = <STDIN>;
$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) {
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' }
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 /
}
die "$0: no transfer file\n" unless -s $transferfile;
-
+
serverconnect($server,$port);
query_sid($server,$port);
-
+
@r = formdatapost(
from => $from,
to => $from,
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);
print "wget -O- $2 | tar xvzf -\n";
}
}
-
+
unlink $transferfile;
}
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;
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;
@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;
s:HTTP/[\d\. ]+::;
die "$0: server response: $_\n";
}
-
+
# list sent files
if ($opt_l) {
open $fexlist,">$fexlist" or die "$0: cannot write $fexlist - $!\n";
}
}
close $fexlist;
- }
-
+ }
+
# list received files
if ($opt_L) {
foreach (@r) {
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;
my (%AB,@r);
my $alias;
local $_;
-
+
%AB = query_address_book($server,$port,$from);
foreach $alias (sort keys %AB) {
next if $alias eq 'ADDRESS_BOOK';
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 (.+\@.+) :/) {
my $transferfile;
my @transferfiles;
local $_;
-
+
if ($from =~ /^SUBUSER|GROUPMEMBER$/) {
$to = '_';
} else {
}
}
@to = split(',',lc($to));
-
+
die $usage unless @ARGV or $opt_a or $opt_s;
die $usage if $opt_s and @ARGV;
}
} elsif ($public) {
} else {
-
+
query_sid($server,$port);
-
+
if ($from eq 'SUBUSER') {
$skey = $sid;
# die "skey=$skey\nid=$id\nsid=$sid\n";
if ($from eq 'GROUPMEMBER') {
$gkey = $sid;
}
-
+
if ($to eq '.') {
@to = ($from);
$opt_C ||= 'NOMAIL';
}
}
# 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);
} 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;
die $usage;
}
}
-
+
foreach (@ARGV) {
my $file = $_;
unless ($opt_d) {
}
}
}
-
+
foreach my $file (@files) {
sleep 1; # do not overrun server!
unless (-s $file or $opt_d or $opt_a or $opt_s) {
file => $file,
keep => $opt_k,
comment => $opt_C,
- autodelete => $opt_D,
+ autodelete => $opt_D,
);
if (not @r or not grep /\w/,@r) {
}
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";
}
}
}
-
+
# delete transfer tmp file
unlink $transferfile if $transferfile;
}
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 '@') {
}
}
close $fexlist;
-
+
unless ($n) {
die "$0: file #$opt_f not found in fexlist\n";
}
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;
$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";
}
}
}
close $fexlist;
-
+
unless ($n) {
die "$0: file #$opt_N not found in fexlist\n";
}
serverconnect($server,$port);
query_sid($server,$port);
-
+
$req = "GET $proxy_prefix/fup?"
."from=$from&ID=$sid&dkey=$dkey&command=RENOTIFY"
." HTTP/1.1";
$file = $3;
}
}
-
+
if ($file) {
print "notification e-mail for $file has been resent to $recipient\n";
} else {
die "$0: server failed, rerun command with option -v\n";
}
}
-
+
exit;
}
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) {
}
}
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;
$req .= " HTTP/1.1";
sendheader("$server:$port",$req);
http_response();
- while (<$SH>) {
+ while (<$SH>) {
if ($opt_v) {
print "<-- $_";
} else {
print if /\Q$file/;
}
}
-
+
exit;
}
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;
sub formdatapost {
- my %P = @_;
+ my %P = @_;
my ($boundary,$filename,$filesize,$length,$buf,$file,$fpsize,$resume,$seek);
my ($flink);
my (@hh,@hb,@r,@pv,$to);
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);
$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;
$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/.*\\//;
}
}
}
-
+
} else {
$file = $filename = '';
$filesize = 0;
}
FORMDATAPOST:
-
+
@hh = (); # HTTP header
@hb = (); # HTTP body
@r = ();
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},
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"
}
$boundary = randstring(48);
-
+
$P{seek} = $seek;
$P{filesize} = $filesize;
push @hb,encode_utf8($P{$v});
}
}
-
+
# at last, POST the file
if ($file) {
push @hb,"--$boundary";
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";
}
binmode $file;
}
-
+
$bytes = 0;
autoflush $SH 0;
-
+
print $rcamel[0] if ${'opt_+'};
$SIG{ALRM} = sub { retry("timed out") };
}
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)",
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";
}
return "X-Location: $location\n";
}
-
+
if ($flink) {
$bytes = -s $flink;
if ($bytes>2*M) {
}
# 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";
}
last if @r and $r[0] =~ / 204 / and /^$/ or /<\/html>/i;
push @r,decode_utf8($_);
}
-
+
if ($file) {
close $SH;
undef $SH;
goto FORMDATAPOST;
}
}
-
+
return @r;
}
}
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;
}
sub getline {
my $file = shift;
local $_;
-
+
while (<$file>) {
chomp;
s/^#.*//;
my ($head,$location);
my ($response,$fexsrv);
local $_;
-
+
$to =~ s/,.*//;
$to =~ s/:\w+=.*//;
$to = $AB{$to} if $AB{$to};
# return true seek only if file is identified
$seek = 0 if $qfileid and $qfileid ne $fileid;
-
+
return ($seek,$location);
}
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;
%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";
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.'~';
}
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>;
last if /^$/;
$cl = $1 if /^Content-Length: (\d+)/;
}
-
+
if ($cl) {
while (<$SH>) {
$b += length;
last if $b >= $cl;
}
}
-
+
$AB{ADDRESS_BOOK} = $ab;
-
+
return %AB;
}
}
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);
serverconnect($server,$port);
$sid = $id;
}
-
+
# warn "proxy: $proxy\n";
if ($proxy) {
serverconnect($server,$port);
$sid = $id;
}
-
+
}
}
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;
}
sleep 1 while ($opt_m and $B/k/(time-$t0||1) > $opt_m);
}
-
+
print STDERR ts($B,$cl),"\n";
close F;
}
my ($b,$tb) = @_;
return sprintf("transferred: %d MB (%d%%)",int($b/M),int($b/$tb*100));
}
-
+
sub sigpipehandler {
retry("died");
sub retry {
my $reason = shift;
local $SIG{ALRM} = sub { };
-
+
if (fileno $SH) {
alarm(1);
my @r = <$SH>;
my ($from,$to) = @_;
my @r;
local $_;
-
+
@r = formdatapost(
from => $from,
to => $to,
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;
}
}
my $ma = $HOME.'/.mutt/aliases';
my $alias;
local $_;
-
+
open $ma,$ma or return $to;
while (<$ma>) {
if (/^alias \Q$to\E\s/i) {
my @files = @_;
my ($file,$dir);
my $fmd = '';
-
+
foreach $file (@files) {
if (not -l $file and -d $file) {
$dir = $file;
$fmd .= $file.fileid($file);
}
}
-
+
return $fmd;
}
local $_ = shift;
my $uu = '';
my ($i,$l);
-
+
tr|A-Za-z0-9+=/||cd;
s/=+$//;
tr|A-Za-z0-9+/| -_|;
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>;
$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);
my ($server,$port) = @_;
my $connect = "CONNECT $server:$port HTTP/1.1";
local $_;
-
+
if ($proxy) {
tcpconnect(split(':',$proxy));
if ($https) {
# 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;
Proto => 'tcp',
);
}
-
+
if ($SH) {
autoflush $SH 1;
} else {
die "$0: cannot connect $server:$port - $@\n";
}
-
+
print "TCPCONNECT to $server:$port\n" if $opt_v;
}
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";
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) {
return 0;
}
}
-
+
return 1;
}
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+/|;
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;
$| = 1;
# sexsend is default
-$usage =
+$usage =
"usage: ... | $0 [options] [SEX-URL/]recipient [stream]\n".
"options: -v verbose mode\n".
" -g show transfer rate\n".
"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".
}
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".
$_ = "$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/;
}
close $idf;
}
-
+
getopts('hgvcu:s:') or die $usage;
die $usage if $opt_h;
die $usage unless -t;
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;
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);
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;
print "Version: $version\n";
exit unless @ARGV;
}
-
+
if ($opt_t and $opt_t =~ /^\d+$/) {
$timeout = "&timeout=$opt_t";
}
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';
die "$0: no SEX URL found, use \"$0 SEX-URL/recipient\" or \"fexsend -I\"\n";
}
}
-
+
}
&get_ssl_env;
$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";
}
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;
print STDERR "==> (streaming ...)\n" if $opt_v;
transfer(STDIN,$SH);
-
+
exit;
my $destination = shift;
my ($t0,$t1,$tt);
my ($B,$b,$bt);
-
+
$t0 = $t2 = time;
$tt = $t0-1;
$t1 = 0;
}
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",
$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 (;;) {
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";
}
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;
return $id;
}
-sub sigpipehandler {
+sub sigpipehandler {
local $_ = '';
$SIG{ALRM} = sub { };
alarm(1);
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;
}
local $_ = shift;
my $uu = '';
my ($i,$l);
-
+
tr|A-Za-z0-9+=/||cd;
s/=+$//;
tr|A-Za-z0-9+/| -_|;
$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);
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) {
# 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";
Proto => 'tcp',
);
}
-
+
if ($SH) {
autoflush $SH 1;
} else {
die "$0: cannot connect $server:$port - $@\n";
}
-
+
print "TCPCONNECT to $server:$port\n" if $opt_v;
}
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";
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) {
return 0;
}
}
-
+
return 1;
}
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+/|;
<title>F*EX simple upload</title>
</head>
<body>
-<h1><a href="/">F*EX</a> simple upload</h1>
-<p><hr><p>
<script type="text/javascript">
function showstatus() {
var file = document.forms["upload"].elements["file"].value;
- if (file != "") {
- window.open(
- '$PROTO$://$HTTP_HOST$/fup?showstatus=$RANDOM$',
- 'fup_status',
- 'width=700,height=500'
- );
- return true;
- } else {
- return false;
- }
+ if (file == "") return false;
+ window.open(
+ '/fup?showstatus=$RANDOM$',
+ 'fup_status',
+ 'width=700,height=500'
+ );
+ return true;
}
</script>
+<h1><a href="/">F*EX</a> simple upload</h1>
+<p><hr><p>
<form name="upload"
action="/fup"
method="post"
<tr><td>your e-mail address:
<td><input type="text" name="from" size="80" value="">
</tr>
- <tr><td>your auth-ID:
+ <tr><td>your <a href="/FAQ/user.html#What_is_the__auth_ID">auth-ID</a>(*):
<td><input type="password" name="id" size="16" value="">
</tr>
<tr><td>your file:
<p>
<p><hr><p>
After "submit" you will see an upload progress bar
-(if you have javascript enabled and popups allowed).
-<p>
-If you have lost your auth-ID use "?" as auth-ID and select a small dummy file.
-Your auth-ID will be sent by e-mail to you.
+(if you have javascript enabled and popups allowed).<br>
+After the end a download URL will be shown.
<p>
You can also use the <a href="/fup">regular upload form</a>
(with more features).
<p>
<em>NOTE: Only Firefox or Google Chrome can upload files > 2 GB!</em><br>
<p><hr><p>
+(*) Please <a href="/fur">register yourself</a> if you do not have an
+ <a href="/FAQ/user.html#What_is_the__auth_ID">auth-ID</a> yet.
+<p><hr><p>
<address>Contact: <a href="mailto:$SERVER_ADMIN$">fexmaster</a></address>
</body>
</html>
<center></center>
<h1> <a href="/">F*EX</a> tools</h1>
+<<$ENV{TA}='http://fex.belwue.de';''>>
+
<table border=1>
<tr><td><a href="/download/fexsend">fexsend</a>
<td>UNIX CLI client for sending files (with many
- <a href="http://fex.rus.uni-stuttgart.de/fstools/fexsend.html">
+ <a href="$TA$/fstools/fexsend.html">
additional features</a>)</tr>
<tr><td><a href="/download/fexget">fexget</a>
<td>UNIX CLI client for receiving files (with many
- <a href="http://fex.rus.uni-stuttgart.de/fstools/fexget.html">
+ <a href="$TA$/fstools/fexget.html">
additional features</a>)</tr>
-<tr><td><a href="http://fex.rus.uni-stuttgart.de/download/fexget.exe">fexget</a>
+<tr><td><a href="$TA$/download/fexget.exe">fexget</a>
<td>Windows CLI client for receiving files
<tr><td><a href="/download/sex.tar">sexsend, sexget</a>
<td>UNIX CLI clients for sending and receiving streams</tr>
-<tr><td><a href="http://fex.rus.uni-stuttgart.de/download/schwuppdiwupp.exe">schwuppdiwupp</a>
+<tr><td><a href="$TA$/download/schwuppdiwupp.exe">schwuppdiwupp</a>
<td>Windows GUI client for sending files</tr>
-<tr><td><a href="http://fex.rus.uni-stuttgart.de/download/macschwupp.tar">schwuppdiwupp</a>
+<tr><td><a href="$TA$/download/macschwupp.tar">schwuppdiwupp</a>
<td>Macintosh GUI client for sending files</tr>
</table>
<p>
<p>
Hint for UNIX users:
<pre> wget -qO- http://$HTTP_HOST$/xx.tar | tar xvf -</pre>
-installs fexsend fexget and
-<a href="http://fex.rus.uni-stuttgart.de/usecases/anonymous.html">xx</a>.
+installs fexsend, fexget and
+<a href="http://fex.rus.uni-stuttgart.de/usecases/xx.html">xx</a>.
<pre> wget -qO- http://$HTTP_HOST$/afs.tar | tar xvf -</pre>
also installs the client programs for
-<a href="/SEX.html">Stream EXchange</a>
-and
-<a href="http://fex.rus.uni-stuttgart.de/usecases/anonymous.html">anonymous usage</a>.
-
+<a href="$TA$/SEX.html">Stream EXchange</a> and
+<<
+ my $a = "/usecases/anonymous.html";
+ print "<a href=\"";
+ print "http://fex.rus.uni-stuttgart.de" unless -s "$docdir$a";
+ print "$a\">anonymous usage</a>";
+>>
</BODY>
</HTML>
-fex-20150729
+fex-20150826
use IO::Socket::INET;
use Digest::MD5 'md5_hex';
+our (@local_rdomains,@local_rhosts);
+
$ENV{PATH} .= ':/sbin:/usr/sbin';
$usage = "usage: $0 [-p port] [IP-address]\n";
if (@local_rdomains and not @local_rhosts) {
print "\nWARNING:\n";
- print "In $fph you have @local_rdomains but not @local_rhosts!\n";
+ print "In $fph you have \@local_rdomains but not \@local_rhosts!\n";
print "Selfregistrating of external users will not work!\n";
print "See ${fph}_new/\n";
}
-if (`$sendmail -h 2>&1` =~ /exim/ and
+if (`$sendmail -h 2>&1 </dev/null` =~ /exim/ and
`grep trusted_users /etc/exim4/exim4.conf 2>/dev/null` !~ /\bfex\b/) {
print "\nWARNING:\n";
print "$sendmail is exim\n";
my $seek = 0;
my $stop = 0;
my ($link,$host,$path,$range);
-
+
our $error = 'F*EX document output ERROR';
-
+
security_check($doc);
-
+
# reget?
if ($range = $ENV{HTTP_RANGE}) {
$seek = $1 if $range =~ /^bytes=(\d+)-/i;
$stop = $1 if $range =~ /^bytes=\d*-(\d+)/i;
}
- # redirect on relative symlinks without "../"
- if ($link = readlink($doc) and
+ # redirect on relative symlinks without "../"
+ if ($link = readlink($doc) and
$link !~ m:^/: and $link !~ m:\.\./: and $link !~ /^:.+:$/) {
$path = $ENV{REQUEST_URI};
$path =~ s:[^/]*$::;
} elsif ($file =~ /(.+)\.tgz$/ and -f "$1.tar") {
@files = ("$1.tar");
open $file,'-|',qw'gzip -c',@files or http_error(503);
- } elsif ($file =~ /(.+)\.(tar|tgz|zip)$/ and
+ } elsif ($file =~ /(.+)\.(tar|tgz|zip)$/ and
@s = lstat($streamfile = "$1.stream") and $s[4] == $<)
{
# streaming file (only if it is owned by user fex)
}
close $streamfile;
foreach (@files) {
- if (/^\// or /\.\.\//) {
+ if (/^\// or /\.\.\//) {
# absolute path or relative path with parent directory is not allowed
http_error(403);
}
- if (@s = stat($_) and not($s[2] & S_IRGRP) or not -r $_) {
+ if (@s = stat($_) and not($s[2] & S_IRGRP) or not -r $_) {
# file must be readable by user and group
http_error(403);
}
}
http_error(416) if $ENV{HTTP_RANGE};
close STDERR;
- if ($file =~ /\.tar$/) { @a = qw'tar --exclude *~ --exclude .* -cf -' }
+ if ($file =~ /\.tar$/) { @a = qw'tar --exclude *~ --exclude .* -cf -' }
elsif ($file =~ /\.tgz$/) { @a = qw'tar --exclude *~ --exclude .* -czf -' }
elsif ($file =~ /\.zip$/) { @a = qw'zip -x *~ */.*/* @ -rq -' }
else { http_error(400) }
} else {
http_error(404);
}
-
+
$type = 'application/octet-stream';
- if ($file =~ /\.html$/) { $type = 'text/html' }
+ if ($file =~ /\.html$/) { $type = 'text/html' }
# elsif ($file =~ /\.txt$/) { $type = 'text/plain' }
elsif ($file =~ /\.css$/) { $type = 'text/css' }
elsif ($file =~ /\.js$/) { $type = 'text/javascript' }
} elsif ($ENV{'QUERY_STRING'} eq '!') {
$type = 'text/plain';
}
-
-
+
+
if ($type eq 'text/html') {
$seek = $stop = 0;
local $^W = 0;
http_header('416 Requested Range Not Satisfiable');
exit;
}
-
+
alarm($timeout*10);
-
+
if ($seek or $stop) {
my $range;
if ($stop) {
$b = $size-$s;
$data = substr($data,0,$b)
}
- $s += $b;
+ $s += $b;
alarm($timeout*10);
print $data or last;
}
}
fdlog($log,$file,$s,$size) if $s;
}
-
+
alarm(0);
close $file;
exit if @files; # streaming end
my $allowed;
my ($htindex,$htauth);
local $_;
-
+
$uri =~ s:/+$::;
$dir =~ s:/+$::;
security_check($dir);
-
+
$htindex = "$dir/.htindex";
$htauth = "$dir/.htauth";
-
+
open $htindex,$htindex or http_error(403);
require_auth($htauth,$dir) if -f $htauth;
-
+
# .htindex may contain listing regexp
chomp ($allowed = <$htindex>||'.');
close $htindex;
-
+
opendir $dir,$dir or http_error(503);
while (defined($_ = readdir $dir)) {
next if /^[.#]/ or /~$/;
$htmldoc .= "<h3><a href=\"$uri/$d/\">$uri/$d/</a></h3>\n";
}
}
-
+
# # then the symlinks
# $htmldoc .= "\n<pre>\n";
# my $link;
# $htmldoc .= "$l -> <a href=\"$link\">$dir/$link</a>\n";
# }
# }
-
+
# then the files
$htmldoc .= "\n<pre>\n";
foreach my $f (sort @files) {
}
}
$htmldoc .= "</pre>\n</HTML>\n";
-
+
$size = length($htmldoc);
nvt_print(
'HTTP/1.1 200 OK',
sub http_date {
my $file = shift;
my @stat;
-
+
if (@stat = stat($file)) {
return strftime("%a, %d %b %Y %T GMT",gmtime($stat[9]));
} else {
# return real file name (from symlink)
sub realfilename {
my $file = shift;
-
+
return '' unless -e $file;
-
+
if (-l $file) {
return realfilename(readlink($file));
} else {
errorlog("$file contains @");
http_error(403);
}
-
+
# document filename must not end with ~
if (realfilename($file) =~ /~$/) {
errorlog("$file ends with ~");
http_error(403);
}
-
+
# file must be group or world readable
if (@s = stat($file) and not($s[2] & (S_IRGRP|S_IROTH))) {
errorlog("$file not group or world readable");
@s = lstat($file);
return if $s[4] == 0 or $s[4] == $<;
}
-
+
}
-
+
# file in allowed directory? ==> ok!
foreach my $dir (@doc_dirs) {
return if path_match($file,$dir);
}
-
+
errorlog("$file not in \@doc_dirs");
http_error(403);
}
local $_;
$dir .= '/x' if -d $dir;
-
+
while ($dir = dirname($dir) and $dir ne '/') {
$af = "$dir/.htaccessfrom";
if (open $af,$af) {
http_error(403);
}
}
-
+
}
# HTTP Basic authentication
my ($realm,$auth);
my @http_auth;
my $uri = $ENV{REQUEST_URI} || '/';
-
+
$uri =~ s/\/index\.html$//;
$uri =~ s/\/$//;
} else {
$realm = dirname($uri);
}
-
+
$auth = slurp($htauth);
unless ($auth and $realm) {
http_header("200 OK");
exit;
}
chomp $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 or $http_auth[1] ne $auth) {
http_header(
# tie STDOUT to buffer variable (redefining print)
package Buffer;
-sub TIEHANDLE {
- my ($class,$buffer) = @_;
- bless $buffer,$class;
+sub TIEHANDLE {
+ my ($class,$buffer) = @_;
+ bless $buffer,$class;
}
-sub PRINT {
- my $buffer = shift;
- $$buffer .= $_ foreach @_;
+sub PRINT {
+ my $buffer = shift;
+ $$buffer .= $_ foreach @_;
}
-sub PRINTF {
- my $buffer = shift;
+sub PRINTF {
+ my $buffer = shift;
my $fmt = shift @_;
$$buffer .= sprintf($fmt,@_);
}
$docdir = '/var/lib/fex/htdocs';
$notify_newrelease = '';
}
-
+
# allowed download managers (HTTP User-Agent)
$adlm = '^(Axel|fex)';
$keep = $keep_default ||= $keep || 5;
$fra = $ENV{REMOTE_ADDR} || '';
$sid = $ENV{SID} || '';
-
+
mkdirp($dkeydir = "$spooldir/.dkeys"); # download keys
mkdirp($ukeydir = "$spooldir/.ukeys"); # upload keys
mkdirp($akeydir = "$spooldir/.akeys"); # authentification keys
my $host = '';
my $port = 80;
my $xinetd = '/etc/xinetd.d/fex';
-
+
if (@durl) {
$durl = $durl[0];
} elsif ($ENV{HTTP_HOST} and $ENV{PROTO}) {
-
+
($host,$port) = split(':',$ENV{HTTP_HOST}||'');
$host = $hostname;
-
+
unless ($port) {
$port = 80;
if (open $xinetd,$xinetd) {
close $xinetd;
}
}
-
+
# use same protocal as uploader for download
if ($ENV{PROTO} eq 'https' and $port == 443 or $port == 80) {
$durl = "$ENV{PROTO}://$host/fop";
sub jsredirect {
$url = shift;
$cont = shift || 'request accepted: continue';
-
+
http_header('200 ok');
print html_header($head||$ENV{SERVER_NAME});
pq(qq(
sub html_quote {
local $_ = shift;
-
+
s/&/&/g;
s/</</g;
s/\"/"/g;
-
+
return $_;
}
sub http_header {
-
+
my $status = shift;
my $msg = $status;
return if $HTTP_HEADER;
$HTTP_HEADER = $status;
-
+
$msg =~ s/^\d+\s*//;
nvt_print("HTTP/1.1 $status");
nvt_print("X-Frame-Options: SAMEORIGIN");
if ($force_https) {
# https://www.owasp.org/index.php/HTTP_Strict_Transport_Security
- nvt_print("Strict-Transport-Security: max-age=2851200");
+ nvt_print("Strict-Transport-Security: max-age=2851200; preload");
}
if ($use_cookies) {
if ($akey) {
'</head>'
));
# '<!-- <style type="text/css">\@import "/fex.css";</style> -->'
-
- if ($0 =~ /fexdev/) { $head .= "<body bgcolor=\"pink\">\n" }
+
+ if ($0 =~ /fexdev/) { $head .= "<body bgcolor=\"pink\">\n" }
else { $head .= "<body>\n" }
-
+
$title =~ s:F\*EX:<a href="/index.html">F*EX</a>:;
if (open $header,'<',"$docdir/$header") {
$head .= $_ while <$header>;
close $header;
}
-
+
$head .= &$prolog($title) if defined($prolog);
-
+
if (@H1_extra) {
$head .= sprintf(
'<h1><a href="%s"><img align=center src="%s" border=0></a>%s</h1>',
$head .= "<h1>$title</h1>";
}
$head .= "\n";
-
+
return $head;
}
my $msg = "@_";
my @msg = @_;
my $isodate = isodate(time);
-
+
$msg =~ s/[\s\n]+/ /g;
$msg =~ s/<.+?>//g; # remove HTML
map { s/<script.*?>//gi } @msg;
-
+
errorlog($msg);
-
- # cannot send standard HTTP Status-Code 400, because stupid
+
+ # cannot send standard HTTP Status-Code 400, because stupid
# Internet Explorer then refuses to display HTML body!
http_header("666 Bad Request - $msg");
print html_header($error);
sub http_die {
-
+
# not in CGI mode
unless ($ENV{GATEWAY_INTERFACE}) {
warn "$0: @_\n"; # must not die, because of fex_cleanup!
return;
}
-
+
debuglog(@_);
-
+
# create special error file on upload
if ($uid) {
my $ukey = "$spooldir/.ukeys/$uid";
close $ukey;
}
}
-
+
html_error($error||'',@_);
}
sub check_status {
my $user = shift;
-
+
$user = lc $user;
$user .= '@'.$mdomain if $mdomain and $user !~ /@/;
my $s = shift;
$s =~ s{([\=\x00-\x20\x7F-\xA0])}{sprintf("=%02X",ord($1))}eog;
return $s;
-}
+}
# from MIME::Base64::Perl
sub b64 {
local $_ = '';
my $x = 0;
-
+
pos($_[0]) = 0;
$_ = join '',map(pack('u',$_)=~ /^.(\S*)/, ($_[0]=~/(.{1,45})/gs));
tr|` -_|AA-Za-z0-9+/|;
$x = (3 - length($_[0]) % 3) % 3;
s/.{$x}$//;
-
+
return $_;
}
my ($file,$dir);
local *D;
local $_;
-
+
foreach (@files) {
next if /(^|\/)\.\.$/;
/(.*)/; $file = $1;
if ($hostname !~ /\./ and $admin and $admin =~ /\@([\w.-]+)/) {
$hostname .= '.'.$1;
}
-
+
return $hostname;
}
# strip off path names (Windows or UNIX)
sub strip_path {
local $_ = shift;
-
+
s/.*\\// if /^([A-Z]:)?\\/;
s:.*/::;
-
+
return $_;
}
# substitute all critcal chars
sub normalize {
local $_ = shift;
-
+
return '' unless defined $_;
-
+
# we need perl native utf8 (see perldoc utf8)
$_ = decode_utf8($_) unless utf8::is_utf8($_);
s/[\x00-\x1F\x80-\x9F]/_/g;
s/^\s+//;
s/\s+$//;
-
+
return encode_utf8($_);
}
# substitute all critcal chars
sub normalize_html {
local $_ = shift;
-
+
return '' unless defined $_;
-
+
$_ = normalize($_);
s/[\"<>]//g;
-
+
return $_;
}
# we need native utf8
$_ = decode_utf8($_) unless utf8::is_utf8($_);
-
+
$_ = strip_path($_);
-
+
# substitute all critcal chars with underscore
s/[^a-zA-Z0-9_=.+-]/_/g;
s/^\./_/;
-
+
return encode_utf8($_);
}
sub normalize_email {
local $_ = lc shift;
-
+
s/[^\w_.+=!~#^\@\-]//g;
s/^\./_/;
/(.*)/;
sub normalize_user {
my $user = shift;
-
+
$user = lc(urldecode(despace($user)));
$user .= '@'.$mdomain if $mdomain and $user !~ /@/;
checkaddress($user) or http_die("$user is not a valid e-mail address");
sub checkchars {
my $input = shift;
local $_ = shift;
-
+
if (/^([|+.])/) {
http_die("\"$1\" is not allowed at beginning of $input");
}
my $re;
local $_;
local ($domain,$dns);
-
+
$a =~ s/:\w+=.*//; # remove options from address
-
+
return $a if $a eq 'anonymous';
$a .= '@'.$mdomain if $mdomain and $a !~ /@/;
$re = '^[!^=~#_:.+*{}\w\-\[\]]+\@(\w[.\w\-]*\.[a-z]+)$';
if ($a =~ /$re/i) {
$domain = $dns = $1;
- {
+ {
local $SIG{__DIE__} = sub { die "\n" };
eval q{
use Net::DNS;
unless ($dns or mx('uni-stuttgart.de')) {
http_die("Internal error: bad resolver");
}
- }
+ }
};
if ($dns) {
return untaint($a);
sub randstring {
my $n = shift;
- my @rc = ('A'..'Z','a'..'z',0..9 );
- my $rn = @rc;
+ my @rc = ('A'..'Z','a'..'z',0..9 );
+ my $rn = @rc;
my $rs;
-
+
for (1..$n) { $rs .= $rc[int(rand($rn))] };
return $rs;
}
sub mkdirp {
my $dir = shift;
my $pdir;
-
+
return if -d $dir;
$dir =~ s:/+$::;
http_die("cannot mkdir /") unless $dir;
$ipe = lc(ipe($ip));
map { lc } @list;
-
+
foreach $i (@list) {
if ($ip =~ /\./ and $i =~ /\./ or $ip =~ /:/ and $i =~ /:/) {
if ($i =~ /(.+)-(.+)/) {
chomp $filename;
close $file;
}
-
+
unless ($filename) {
$filename = $file;
$filename =~ s:.*/::;
}
-
+
return $filename;
}
sub debuglog {
my $prg = $0;
local $_;
-
+
return unless $debug and @_;
unless ($debuglog and fileno $debuglog) {
my $ddir = "$spooldir/.debug";
sub writelog {
my $log = shift;
my $msg = shift;
-
+
foreach my $logdir (@logdir) {
if (open $log,'>>',"$logdir/$log") {
flock $log,LOCK_EX;
# print superquoted
sub pq {
my $H = STDOUT;
+
if (@_ > 1 and defined fileno $_[0]) { $H = shift }
+ binmode($H,':utf8');
print {$H} qqq(@_);
}
my $du = 0;
my ($file,$size,%file,$data,$upload);
local $_;
-
+
if (open $qf,'<',"$sender/\@QUOTA") {
while (<$qf>) {
s/#.*//;
}
close $qf;
}
-
+
foreach $file (glob "*/$sender/*") {
$data = "$file/data";
$upload = "$file/upload";
}
}
}
-
+
return($squota,int($du/1024/1024));
}
my $du = 0;
my ($file,$size);
local $_;
-
+
if (open my $qf,'<',"$recipient/\@QUOTA") {
while (<$qf>) {
s/#.*//;
}
close $qf;
}
-
+
foreach $file (glob "$recipient/*/*") {
if (-f "$file/upload" and $size = readlink "$file/size") {
$du += $size;
$du += $size;
}
}
-
+
return($rquota,int($du/1024/1024));
}
sub wcmatch {
local $_ = shift;
my $p = quotemeta shift;
-
+
$p =~ s/\\\*/.*/g;
$p =~ s/\\\?/./g;
$p =~ s/\\\[/[/g;
return /$p/;
}
-
+
sub logout {
my $logout;
if ($skey) { $logout = "/fup?logout=skey:$skey" }
# print data dump of global or local variables in HTML
# input musst be a string, eg: '%ENV'
sub DD {
- my $v = shift;
+ my $v = shift;
local $_;
$n =~ s/.//;
s/</</g;
print "<pre>\n$_\n</pre>\n";
}
-
+
# make symlink
sub mksymlink {
my ($file,$link) = @_;
my $link;
local $/;
local $_;
-
+
$to .= '/'.basename($from) if -d $to;
if (defined($link = readlink $from)) {
eval $mod if $mod;
print {$to} $_;
close $to or http_die("internal error: $to - $!");
- if (my @s = stat($from)) {
+ if (my @s = stat($from)) {
chmod $s[2],$to;
utime @s[8,9],$to unless $mod;
}
my $file = shift;
local $_;
local $/;
-
+
if (open $file,$file) {
$_ = <$file>;
close $file;
my $data = '';
my $filename;
local $_;
-
+
if ($cl > 128*$MB) {
http_die("request too large");
}
-
+
+ binmode(STDIN,':raw');
+
foreach (split('&',$ENV{QUERY_STRING})) {
if (/(.+?)=(.*)/) { $PARAM{$1} = $2 }
else { $PARAM{$_} = $_ }
# memorized vhost? (default is in fex.ph)
%vhost = split(':',$ENV{VHOST}) if $ENV{VHOST};
-
+
if (%vhost and $hh and $hh =~ s/^([\w\.-]+).*/$1/) {
if ($vhost = $vhost{$hh} and -f "$vhost/lib/fex.ph") {
$ENV{VHOST} = "$hh:$vhost"; # memorize vhost for next run
my ($plain,$to,$keyring,$from) = @_;
my ($pid,$pi,$po,$pe,$enc,$err);
local $_;
-
+
$pe = gensym;
-
+
$pid = open3($po,$pi,$pe,
"gpg --batch --trust-model always --keyring $keyring".
" -a -e -r $bcc -r $to"
) or return;
-
+
print {$po} $plain;
close $po;
-
+
$enc .= $_ while <$pi>;
$err .= $_ while <$pe>;
errorlog("($from --> $to) $err") if $err;
-
+
close $pi;
close $pe;
waitpid($pid,0);
-
+
return $enc;
}
my $locale = shift;
local $/;
local $_;
-
+
if ($locale and open my $fexpp,"$FEXHOME/locale/$locale/lib/fex.pp") {
$_ = <$fexpp>;
s/.*\n(\#\#\# locale functions)/$1/s;
# sub xx {} ==> xx{$locale} = sub {}
- s/\nsub (\w+)/\n\$$1\{$locale\} = sub/gs;
+ s/\nsub (\w+)/\n\$$1\{$locale\} = sub/gs;
s/\n}\n/\n};\n/gs;
eval $_;
close $fexpp;
$file = $dkey;
$dkey = readlink("$file/dkey");
} else {
- $file = readlink("$dkeydir/$dkey")
+ $file = readlink("$dkeydir/$dkey")
or http_die("internal error: no DKEY $DKEY");
}
$file =~ s:^../::;
$mtime = mtime("$file/data") or http_die("internal error: no $file/data");
$comment = slurp("$file/comment") || '';
$replyto = readlink "$file/replyto" || '';
- $autodelete = readlink "$file/autodelete"
- || readlink "$to/\@AUTODELETE"
+ $autodelete = readlink "$file/autodelete"
+ || readlink "$to/\@AUTODELETE"
|| $::autodelete;
- $keep = readlink "$file/keep"
- || readlink "$to/\@KEEP"
+ $keep = readlink "$file/keep"
+ || readlink "$to/\@KEEP"
|| $keep_default;
-
+
$locale = readlink "$to/\@LOCALE" || readlink "$file/locale" || 'english';
$_ = untaint("$FEXHOME/locale/$locale/lib/lf.pl");
require if -f;
my ($body,$enc_body);
return if $nomail;
-
+
$warn = $P{warn}||2;
- $comment = encode_utf8($P{comment}||'');
+ $comment = $P{comment}||'';
+ $comment = encode_utf8($P{comment}||'') if utf8::is_utf8($comment);
$comment =~ s/^!\*!//; # multi download allow flag
$autodelete = $P{autodelete}||$::autodelete;
-
+
$file = untaint(readlink("$dkeydir/$P{dkey}"));
$file =~ s/^\.\.\///;
# make download protocal same as upload protocol
if ($nowarning) {
$warning = '';
} else {
- $warning =
+ $warning =
"Please avoid download with Internet Explorer, ".
"because it has too many bugs.\n".
"We recommend Firefox or wget.";
$mimefilename =~ s/ /_/g;
$mimefilename = '=?UTF-8?Q?'.$mimefilename.'?=';
}
- }
-
+ }
+
unless ($fileid = readlink("$dkeydir/$P{dkey}/id")) {
my @s = stat($data);
$fileid = @s ? $s[1].$s[9] : 0;
}
-
+
if ($P{status} eq 'new') {
$days = $P{keep};
$header .= "Subject: F*EX-upload: $mimefilename\n";
$header .= "X-FEX-URL: $durl\n" unless -s $keyring;
$download .= "$durl\n";
}
- $header .=
+ $header .=
"X-FEX-Filesize: $bytes\n".
"X-FEX-File-ID: $fileid\n".
"X-FEX-Fexmaster: $ENV{SERVER_ADMIN}\n".
"X-Mailer: F*EX\n".
"MIME-Version: 1.0\n";
- if ($comment =~ s/^\[(\@(.*?))\]\s*//) {
+ if ($comment =~ s/^\[(\@(.*?))\]\s*//) {
$receiver = "group $1";
if ($_ = readlink "$from/\@GROUP/$2" and m:^../../(.+?)/:) {
$receiver .= " (maintainer: $1)";
}
- } else {
+ } else {
$receiver = 'you';
}
if ($days == 1) { $days .= " day" }
else { $days .= " days" }
-
+
# explicite sender set in fex.ph?
if ($sender_from) {
map { s/^From: <$mfrom/From: <$sender_from/ } $header;
open $sendmail,'|-',$sendmail,$mto,$bcc
or http_die("cannot start sendmail - $!");
} else {
- # for special remote domains do not use same domain in From,
+ # for special remote domains do not use same domain in From,
# because remote MTA will probably reject this e-mail
$dfrom = $1 if $mfrom =~ /@(.+)/;
$dto = $1 if $mto =~ /@(.+)/;
- if ($dfrom and $dto and @remote_domains and
- grep {
- $dfrom =~ /(^|\.)$_$/ and $dto =~ /(^|\.)$_$/
- } @remote_domains)
+ if ($dfrom and $dto and @remote_domains and
+ grep {
+ $dfrom =~ /(^|\.)$_$/ and $dto =~ /(^|\.)$_$/
+ } @remote_domains)
{
$header =~ s/(From: <)\Q$mfrom\E(.*?)\n/$1$admin$2\nReply-To: $mfrom\n/;
open $sendmail,'|-',$sendmail,$mto,$bcc
or http_die("cannot start sendmail - $!");
}
}
- if ($comment =~ s/^!(shortmail|\.)!\s*//i
+ if ($comment =~ s/^!(shortmail|\.)!\s*//i
or (readlink "$to/\@NOTIFICATION"||'') =~ /short/i
) {
$body = qqq(qq(
my $fexsend = "$FEXHOME/bin/fexsend";
return if $nomail;
-
+
if (-x $fexsend) {
$fexsend .= " -M -D -k 30 -C"
." 'Your F*EX account has been inactive for $expire days,"
projects / fex.git / commitdiff