umask 077;
# import from fex.pp
-our ($FEXHOME,$FHS,$hostname,$spooldir,$logdir,$akeydir,$docdir);
+our ($FEXHOME,$FHS,$hostname,$spooldir,@logdir,$akeydir,$docdir);
our ($durl,@durl,$mdomain,$admin,$mailmode);
our ($autodelete,$keep_default,$keep_max,$recipient_quota,$sender_quota);
our (@local_rdomains);
# show logfile
if ($opt_w) {
- $log = "$logdir/fexsrv.log";
+ $log = $logdir[0]."/fexsrv.log";
warn "$0: polling $log\n\n";
exec "$FEXHOME/bin/logwatch",$log;
die "$0: logwatch not found\n";
}
# show config
-if ($opt_v) {
+if ($opt_v and not @ARGV) {
print "config from $FEXLIB/fex.ph :\n";
print " spooldir = $spooldir\n";
- print " logdir = $logdir\n";
+ print " logdir = @logdir\n";
print " docdir = $docdir\n";
print " durl = @durl\n";
print " admin = $admin\n";
# add user or show user config
if ($opt_u) {
+ chdir $spooldir or die "$0: cannot chdir $spooldir = $!\n";
if ($opt_u = shift @ARGV) {
$user = lc $opt_u;
$user .= '@'.$mdomain if $mdomain and $user !~ /@/;
$id = shift @ARGV;
- $idf = "$spooldir/$user/@";
+ $idf = "$user/@";
if (open $idf,$idf) {
chomp($ido = <$idf>||'');
close $idf;
}
unless ($id) {
- die "$0: $user is not a FEX user\n" unless -f "$spooldir/$user/@";
+ die "$0: $user is not a regular FEX user\n" unless -f "$user/@";
showuser($user,$ido);
exit;
}
unless ($user =~ /\w@[\w.-]+\.[a-z]+$/) {
die "$0: $user is not a valid email-address!\n";
}
- unless (-d "$spooldir/$user") {
- mkdir "$spooldir/$user",0755
- or die "$0: cannot mkdir $spooldir/$user - $!\n";
+ unless (-d $user) {
+ mkdir $user,0755
+ or die "$0: cannot mkdir $user - $!\n";
}
open F,">$idf" or die "$0: cannot write $idf - $!\n";
print F $id,"\n";
showuser($user,$id);
} else {
print "Users in $spooldir:\n";
- foreach $user (glob "$spooldir/*/@") {
+ foreach $user (glob "*/@") {
$user =~ s:.*/(.+)/@:$1:;
print "$user\n";
}
$user = lc $opt_q;
$user .= '@'.$mdomain if $mdomain and $user !~ /@/;
unless (-d "$spooldir/$user") {
- die "$0: $user is not a regular FEX user\n";
+ die "$0: $user is not a FEX user\n";
}
quota($user,@ARGV);
exit;
sub showuser {
my $user = shift;
my $id = shift;
- my ($keep,$autodelete,$notification);
+ my ($keep,$autodelete,$notification,$login);
$user .= '@'.$mdomain if $mdomain and $user !~ /@/;
printf "%s/%s\n",$fup,b64("from=$user&id=$id");
# printf "%s/%s\n",$fup,b64("from=$user&to=$user&id=$id&submit=.");
print "spool: $spooldir/$user/\n";
+ if ($login_check and $login = readlink "$user/.login") {
+ my $lc = &$login_check($login);
+ if ($lc) {
+ print "login: $login\n";
+ } else {
+ print "login: DELETED\n";
+ }
+ }
printf "fex yourself web default: %s\n",
-e "$spooldir/$user/\@FEXYOURSELF" ? 'yes' : 'no';
printf "persistent: %s\n",
my ($log,$u,$d,$z);
my $Z = 0;
- if (-t) { $log = "$logdir/fup.log" }
+ if (-t) { $log = $logdir[0].'/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/fop.log" }
+ if (-t) { $log = $logdir[0].'/fop.log' }
else { $log = '>&=STDIN' }
open $log,$log or die "$0: cannot open $log - $!\n";
}
-sub mtime {
- my @s = lstat shift;
- return @s ? $s[9] : undef;
-}
-
sub check_admin {
my $admin_id = slurp("$spooldir/$admin/@") or
our ($SH,$windoof,$sigpipe,$useragent);
our ($FEXSERVER);
-our $version = 20150120;
+our $version = 20150615;
# server defaults
my $server = 'fex.rus.uni-stuttgart.de';
# use fex.ph for site configuration!
our ($FEXHOME);
-our ($spooldir,$logdir,$docdir);
+our ($spooldir,@logdir,$docdir);
our ($akeydir,$ukeydir,$dkeydir,$skeydir,$gkeydir,$xkeydir,$lockdir);
our ($durl,$debug,$autodelete,$hostname,$admin,$admin_pw,$bcc);
$keep_default = 5;
# load common code, local config : $HOME/lib/fex.ph
require "$FEXLIB/fex.pp" or die "$0: cannot load $FEXLIB/fex.pp - $!\n";
+my $logdir = $logdir[0];
+
# localized functions
# (needed for reminder and account reactivation e-mails)
foreach my $lf (glob "$FEXHOME/locale/*/lib/lf.pl") { require $lf }
$isodate = isodate($today);
chdir $spooldir or die "$0: $spooldir - $!\n";
-open L,">>$logdir/cleanup.log";
+# open L,">>$logdir/cleanup.log";
# clean up regular spool
opendir $spooldir,'.' or die "$0: $spooldir - $!\n";
while ($to = readdir $spooldir) {
- next if $to !~ /@/ or -l $to;
- if (@demo and -f "$to/.demo" and time > mtime("$to/.demo")+$demo[1]*DS) {
+ next if $to !~ /@/ or $_ = readlink($to) and not /\//;
+ if (@demo and -f "$to/.demo" and time > lmtime("$to/.demo")+$demo[1]*DS) {
logdel($to,"demo user $to deleted");
next;
}
if ($lc) {
if (-f "$user/\@~" and not "$user/@") {
rename "$user/\@~","$user/@" unless $opt_d;
- logv("$isodate $user reanimated (login_check)");
+ logv("$user reanimated (login_check)");
}
} else {
rename "$user/@","$user/\@~" unless $opt_d;
while ($file = readdir D) {
next if $file eq '.' or $file eq '..';
if (($link = readlink $file and not -e "$link/upload"
- or -f $file and time > mtime($file)+DS)) {
+ or -f $file and time > lmtime($file)+DS)) {
logdel($file,".ukeys/$file deleted");
}
}
# clean up authorization key lookup directory
if (chdir $akeydir and opendir D,'.') {
while ($file = readdir D) {
- if (-l $file and time > mtime($file)+DS) {
+ if (-l $file and time > (lmtime($file)||0)+DS) {
logdel($file,".akeys/$file deleted");
}
}
# clean up lock directory
if (chdir $lockdir and opendir D,'.') {
while ($file = readdir D) {
- if (-f $file and time > mtime($file)+DS) {
+ if (-f $file and time > lmtime($file)+DS) {
logdel($file,".locks/$file deleted");
}
}
if (chdir "$spooldir/.error" and opendir D,'.') {
while ($file = readdir D) {
if (-f $file) {
- $mtime = mtime($file);
+ $mtime = lmtime($file);
if ($mtime and $today > 10*$keep_default*DS+$mtime) {
if ($opt_d) { print "unlink .error/$file\n" }
else { logdel($file,".error/$file deleted") }
}
# clean up debug directory
-if (chdir "$logdir/.debug" and opendir D,'.') {
+if (chdir "$spooldir/.debug" and opendir D,'.') {
while ($file = readdir D) {
if (-f $file) {
- $mtime = mtime($file);
+ $mtime = lmtime($file);
if ($mtime and $today > $keep_default*DS+$mtime) {
# logdel($file,".debug/$file deleted");
if ($opt_d) { print "unlink .debug/$file\n" }
# clean up old OKEYs
chdir $spooldir;
foreach my $okey (glob '*/@OKEY/*') {
- if (time > mtime($okey)+30*DS) {
+ if (time > lmtime($okey)+30*DS) {
logdel($okey,"$okey deleted");
}
}
if (chdir "$spooldir/.reg" and opendir D,'.') {
while ($file = readdir D) {
if (-f $file) {
- $mtime = mtime($file);
+ $mtime = lmtime($file);
if ($mtime and $today > $mtime+DS) {
logdel($file,".reg/$file deleted");
}
next if $user =~ /^(fexmaster|fexmail)/ or $user eq $admin;
next if -l "$user/.login";
- if (time > mtime($user)+$expire*DS) {
+ if (time > lmtime($user)+$expire*DS) {
# print "$spooldir/$user\n";
my $locale = readlink "$user/\@LOCALE";
$locale = 'english' unless $locale and $reactivation{$locale};
}
}
-close L;
-
# vhosts
exit if $opt_V;
if (%vhost) {
}
}
-if ($notify_newrelease or not defined $notify_newrelease) {
+if ($notify_newrelease and $notify_newrelease !~ /^no$/i
+ or not defined $notify_newrelease) {
$notify_newrelease ||= $admin;
$newnew = $new = '';
$snew = $FEXHOME.'/doc/new';
else { $qn = "new?$hostname:0" }
for (1..3) {
sleep rand(10);
- $newnew = `wget -qO- http://fex.rus.uni-stuttgart.de/$qn 2>/dev/null`;
- last if $newnew =~ /release/;
$newnew = `wget -qO- http://fex.belwue.de/$qn 2>/dev/null`;
last if $newnew =~ /release/;
+ # $newnew = `wget -qO- http://fex.rus.uni-stuttgart.de/$qn 2>/dev/null`;
+ # last if $newnew =~ /release/;
};
if ($newnew =~ /release/) {
if ($newnew ne $new) {
if ($file =~ /\/ADDRESS_BOOK/) {
logdel($file,"$file deleted");
} elsif (-d $file and not -f $data) {
- if ($mtime = mtime("$file/upload")) {
+ if ($mtime = lmtime("$file/upload")) {
if ($today > $mtime+DS) {
verbose("rmrf $file (today=$today mtime_upload=$mtime)");
logdel($file,"$file deleted");
}
- } elsif ($mtime = mtime("$file/error")) {
+ } elsif ($mtime = lmtime("$file/error")) {
if ($today > 3*$keep*DS+$mtime) {
verbose("rmrf $file (today=$today mtime_error=$mtime keep=$keep)");
logdel($file,"$file deleted");
$delay = autodelete($file);
$delay = 1 if $delay !~ /^\d+$/;
$delay--;
- $mtime = mtime($download);
+ $mtime = lmtime($download);
if ($mtime and $today > $delay*DS+$mtime
and logdel($data,"$data deleted")) {
if (open $ef,'>',$ef) {
printf {$ef} "%s has been autodeleted after download at %s\n",
- filename($file),isodate(mtime($download));
+ filename($file),isodate(lmtime($download));
close $ef;
}
}
} elsif (-f $data) {
my $reactivation = $file =~ m{/\Q$admin/reactivation.txt\E$};
$warn = $reactivation ? $keep-5 : $keep-2;
- $mtime = mtime("$file/filename") || mtime($data) || 0;
+ $mtime = lmtime("$file/filename") || lmtime($data) || 0;
if ($today > $mtime+$keep*DS) {
if ($account_expire and $reactivation) {
if ($account_expire =~ /delete/) {
chomp ($comment = <$c>||'');
close $c;
}
- &{$notify{$locale}}(
+ if (&{$notify{$locale}}(
status => 'remind',
dkey => $dkey,
filename => filename($file),
comment => $comment,
warn => int(($mtime-$today)/DS)+$keep,
autodelete => autodelete($file),
- );
- open $notify,'>',$notify;
- close $notify;
- print "sent reminder for $file\n" if -t or $opt_v;
+ )) {
+ open $notify,'>',$notify;
+ close $notify;
+ print "sent reminder for $file\n" if -t or $opt_v;
+ } else {
+ warn "$0: reminder notification for $file failed\n";
+ }
}
}
}
return $autodelete||$::autodelete;
}
-sub mtime {
- my @s = lstat shift;
- return @s ? $s[9] : undef;
-}
-
sub logdel {
my ($file,$msg) = @_;
my $status = 0;
if ($status = rmrf($file)) {
logv($msg);
} else {
- print L "$isodate $file DEL FAILED : $!\n";
- warn "$file DEL FAILED : $!\n" if -t or $opt_v;
+ logv("$file DEL FAILED : $!");
+ warn "$file DEL FAILED : $!\n" if -t or $opt_v;
}
}
sub logv {
my $msg = shift;
- print L "$isodate $msg\n" unless $opt_d;
+
print "$msg\n" if -t or $opt_v;
+
+ unless ($opt_d) {
+ foreach my $ld (@logdir) {
+ if (open my $log,">>$ld/cleanup.log") {
+ print {$log} "$isodate $msg\n";
+ close $log;
+ }
+ }
+ }
}
}
}
}
+
+
+sub lmtime {
+ my @s = lstat(shift);
+ return @s?$s[9]:0;
+}
our ($fexhome,$idf,$tmpdir,$windoof,$useragent);
our ($xv,%autoview);
our $bs = 2**16; # blocksize for tcp-reading and writing file
-our $version = 20150120;
+our $version = 20150615;
our $CTYPE = 'ISO-8859-1';
our $fexsend = $ENV{FEXSEND} || 'fexsend';
exit;
}
-# set SSL/TLS options
-$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_ca_file)
-) {
- my $env = uc($opt);
- $env =~ s/_//g;
- $SSL{$opt} = $ENV{$env} if defined($ENV{$env});
-}
-
-if ($SSL{SSL_verify_mode}) {
- &search_ca;
- unless ($SSL{SSL_ca_path} or $SSL{SSL_ca_file}) {
- die "$0: \$SSLVERIFYMODE, but not valid \$SSLCAPATH or \$SSLCAFILE\n";
- }
-} elsif (defined($SSL{SSL_verify_mode})) {
- # user has set SSLVERIFY=0 !
-} else {
- &search_ca;
- $SSL{SSL_verify_mode} = 1 if $SSL{SSL_ca_path} or $SSL{SSL_ca_file};
-}
-
-sub search_ca {
- local $_;
- return if $SSL{SSL_ca_file} or $SSL{SSL_ca_path};
- foreach (qw(/etc/ssl/certs/ca-certificates.crt)) {
- if (-f) {
- $SSL{SSL_ca_file} = $_;
- return;
- }
- }
- foreach (qw(/etc/ssl/certs /etc/pki/tls/certs)) {
- if (-f) {
- $SSL{SSL_ca_path} = $_;
- return;
- }
- }
-}
+&get_ssl_env;
my $ffl = "$tmpdir/fexget"; # F*EX files list (cache)
our ($FEXID,$FEXXX,$HOME);
our (%alias);
our $chunksize = 0;
-our $version = 20150120;
+our $version = 20150615;
our $_0 = $0;
our $DEBUG;
$0 -b # other\@address
Where # is the file number.
+You can list an uploaded file in more detail with
+ $0 -l #
+Where # is the file number.
+
If you want to modify the keep time, comment or auto-delete behaviour of an
already uploaded file then you first have to query the file number with:
$0 -l
if ($fexcgi =~ /\?/) {
$from = $1 if $fexcgi =~ /\bfrom=(.+?)(&|$)/i;
$id = $1 if $fexcgi =~ /\bid=(.+?)(&|$)/i;
- $skey = $1 if $fexcgi =~ /\bskey=(.+?)(&|$)/i;
- $gkey = $1 if $fexcgi =~ /\bgkey=(.+?)(&|$)/i;
+ # $skey = $1 if $fexcgi =~ /\bskey=(.+?)(&|$)/i;
+ # $gkey = $1 if $fexcgi =~ /\bgkey=(.+?)(&|$)/i;
+ die "$0: cannot use GKEY URL in ID file\n" if $fexcgi =~ /gkey=/i;
+ die "$0: cannot use SKEY URL in ID file\n" if $fexcgi =~ /skey=/i;
$fexcgi =~ s/\?.*//;
}
unless ($fexcgi =~ /^[_:=\w\-\.\/\@\%]+$/) {
else { $dkey = '' }
# $_ = encode_utf8($_);
s/<.*?>//g;
+ s/&/&/g;
+ s/"/\"/g;
+ s/</</g;
if (/^(to .* :)/) {
print "\n$1\n";
print {$fexlist} "\n$1\n";
my @files = ();
my ($data,$aname,$alias);
my (@r,$r);
- my $ma = $HOME.'/.mutt/aliases';
my $t0 = time;
my $transferfile;
my @transferfiles;
# $to = $AB{$to};
}
# look for mutt aliases
- elsif ($to !~ /@/ and $to ne $from and open $ma,$ma) {
- $alias = $to;
- while (<$ma>) {
- if (/^alias \Q$to\E\s/i) {
- chomp;
- s/\s*#.*//;
- s/\(.*?\)//;
- s/\s+$//;
- s/.*\s+//;
- s/[<>]//g;
- if (/,/) {
- warn "$0: ignoring mutt multi-alias $to = $alias\n";
- last;
- }
- if (/@/) {
- $alias = $_;
- warn "$0: found mutt alias $to = $alias\n";
- last;
- }
- }
- }
- close $ma;
- $to = $alias;
+ elsif ($to !~ /@/ and $to ne $from) {
+ $to = get_mutt_alias($to);
}
}
}
$to = join(',',grep /./,@to) or exit;
- warn "Server/User: $fexcgi/$from\n" unless $opt_q;
+ # warn "Server/User: $fexcgi/$from\n" unless $opt_q;
if (
not $skey and not $gkey
+ and $from ne $to
and $features =~ /CHECKRECIPIENT/
and $opt_C !~ /^(DELETE|LIST|RECEIVEDLOG|SENDLOG|FOPLOG)$/
) {
sub forward {
my (@r);
my ($to,$n,$dkey,$file,$req);
- my $status = 1;
+ my ($status,$fp);
local $_;
# look for single @ in arguments
# if ($windoof and not @ARGV) { &inquire }
$to = pop @ARGV or die $usage;
$to = $from if $to eq '.';
+ if ($to !~ /@/ and $to ne $from) {
+ $to = get_mutt_alias($to);
+ }
open $fexlist,$fexlist or die "$0: $fexlist - $!\n";
while (<$fexlist>) {
$req .= " HTTP/1.1";
sendheader("$server:$port",$req);
http_response();
+ $fp = $file;
+ $fp =~ s/[^\w_.-]/.+/g; # because of UTF8 filename
+ $status = 1;
while (<$SH>) {
- if ($opt_v) {
- print;
- $status = 0 if /\Q"$file"/;
- } else {
- if (/\Q"$file"/) {
- print;
- $status = 0;
- }
- }
+ $status = 0 if /"$fp"/;
+ print if $opt_v or /"$fp"/;
}
if ($status) {
if (/^n/i) {
print "keeping $transferfile\n";
} else {
- system("tar xvf $transferfile && rm $transferfile");
+ my $untar = "tar xvf";
+ # if ($> == 0 and `tar --help 2>&1` =~ /gnu/) {
+ # $untar = "tar --no-same-owner -xvf";
+ # }
+ system("$untar $transferfile && rm $transferfile");
die "$0: error while untaring, see $transferfile\n" if -f $transferfile;
}
} else {
print $rcamel[0] if ${'opt_+'};
+ $SIG{ALRM} = sub { retry("timed out") };
while (my $b = read $file,$buf,$bs) {
- print {$SH} $buf or &sigpipehandler;
+ alarm($timeout*2);
+ syswrite $SH,$buf or &sigpipehandler;
+ alarm(0);
$bytes += $b;
if ($filesize > 0 and $bytes+$seek > $filesize) {
die "$0: $file filesize has grown while uploading\n";
sub sigpipehandler {
- $SIG{ALRM} = sub { };
+ retry("died");
+}
+
+sub retry {
+ my $reason = shift;
+ local $SIG{ALRM} = sub { };
+
if (fileno $SH) {
alarm(1);
- @_ = <$SH>;
+ my @r = <$SH>;
alarm(0);
kill 9,$tpid if $tpid;
- if (@_ and $opt_v) {
- die "\n$0: ($$) server error: @_\n";
+ if (@r and $opt_v) {
+ die "\n$0: ($$) server error: @r\n";
}
- if (@_ and $_[0] =~ /^HTTP.* \d+ (.*)/) {
+ if (@r and $r[0] =~ /^HTTP.* \d+ (.*)/) {
die "\n$0: server error: $1\n";
}
}
$timeout *= 2;
- warn "\n$0: connection to $server died\n";
+ warn "\n$0: connection to $server $reason\n";
warn "retrying after $timeout seconds...\n";
sleep $timeout;
if ($windoof) { exec $^X,$0,@_ARGV }
}
+sub get_mutt_alias {
+ my $to = shift;
+ my $ma = $HOME.'/.mutt/aliases';
+ my $alias;
+ local $_;
+
+ open $ma,$ma or return $to;
+ while (<$ma>) {
+ if (/^alias \Q$to\E\s/i) {
+ chomp;
+ s/\s*#.*//;
+ s/\(.*?\)//;
+ s/\s+$//;
+ s/.*\s+//;
+ s/[<>]//g;
+ if (/,/) {
+ warn "$0: ignoring mutt multi-alias $to = $alias\n";
+ last;
+ }
+ if (/@/) {
+ $alias = $_;
+ warn "$0: found mutt alias $to = $alias\n";
+ last;
+ }
+ }
+ }
+ close $ma;
+ return ($alias||$to);
+}
+
+
# collect file meta data (filename, inode, mtime)
sub fmd {
my @files = @_;
unless (defined $_ and /\w/) {
die "$0: no response from server\n";
}
+ print "<-- $_\n" if $opt_v;
s/\r?\n//;
# CGI fatalsToBrowser
if (/^HTTP.* 500/) {
unless (/^HTTP.* 200/) {
$error = $_;
$error =~ s/HTTP.[\s\d.]+//;
- if ($opt_v) {
- print "<-- $_";
- print "<-- $_" while <$SH>;
+ @r = <$SH> unless @r;
+ @r = () unless @r;
+ foreach (@r) {
+ chomp;
+ $error .= "\n".$_ if /^Location/;
+ print "<-- $_\n" if $opt_v;
}
die "$0: server error: $error\n";
}
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) {
unless (/^HTTP.1.. 200/) {
die "$0: proxy error : $_";
}
- eval "use IO::Socket::SSL";
- die "$0: cannot load IO::Socket::SSL\n" if $@;
+ &enable_ssl;
$SH = IO::Socket::SSL->start_SSL($SH,%SSL);
}
} else {
if ($port == 443) {
# eval "use IO::Socket::SSL qw(debug3)";
- eval "use IO::Socket::SSL";
- die "$0: cannot load IO::Socket::SSL\n" if $@;
+ &enable_ssl;
$SH = IO::Socket::SSL->new(
PeerAddr => $server,
PeerPort => $port,
}
+sub enable_ssl {
+ eval "use IO::Socket::SSL";
+ die "$0: cannot load IO::Socket::SSL\n" if $@;
+ eval '$SSL{SSL_verify_mode} = 0 if Net::SSLeay::SSLeay() <= 9470143';
+ if ($opt_v) {
+ foreach my $v (keys %SSL) {
+ printf "%s => %s\n",$v,$SSL{$v};
+ }
+ }
+}
+
+
sub sendheader {
my $sp = shift;
my @head = @_;
-#!/usr/bin/perl -wT
+#!/usr/bin/perl -T
# fexsrv : web server for F*EX service
#
use Socket;
use IO::Handle;
use Fcntl qw':flock :seek';
-
-# stunnel workaround
-BEGIN { $SIG{CHLD} = "DEFAULT" }
+use warnings;
+
+BEGIN {
+ # stunnel workaround
+ $SIG{CHLD} = "DEFAULT";
+ $ENV{PERLINIT} = q{
+ unshift @INC,(getpwuid($<))[7].'/perl';
+ # web error handler
+ $SIG{__DIE__} = $SIG{__WARN__} = sub {
+ my $info = '';
+ my $url = $ENV{REQUEST_URL}||'';
+ my @d = localtime time;
+ my $time = sprintf('%d-%02d-%02d %02d:%02d:%02d',
+ $d[5]+1900,$d[4]+1,$d[3],$d[2],$d[1],$d[0]);
+ if ($admin) {
+ my $mailto = "mailto:$admin?subject=fex%20bug";
+ $info = "<h3>send this error to <a href=\"$mailto\">$admin</a></h3>";
+ }
+ $_ = join("\n",@_);
+ chomp;
+ s/&/&/g;
+ s/</</g;
+ $_ = join("\n",
+ "<html><body>",
+ "<h1>INTERNAL ERROR in $0</h1>",
+ "<pre>\n$_\n</pre>\n<p>",
+ "$url\n<p>",
+ "$time\n<p>",
+ "$info\n<p>",
+ "</body></html>"
+ );
+ $length = length;
+ unless ($HTTP_HEADER) {
+ print "HTTP/1.0 200 ERROR\r\n";
+ print "Content-Type: text/html\r\n";
+ print "Content-Length: $length\r\n";
+ print "\r\n";
+ }
+ print;
+ exit 99;
+ }
+ };
+ eval $ENV{PERLINIT};
+}
# use BSD::Resource;
# setrlimit(RLIMIT_CPU,999,999) or die "$0: $!\n";
if ($ENV{KEEP_ALIVE}) {
$keep_alive = $ENV{KEEP_ALIVE};
} else {
- %ENV = (); # clean environment
+ %ENV = ( PERLINIT => $ENV{PERLINIT} ); # clean environment
}
-$ENV{HOME} = (getpwuid($<))[7] or die "$0: no HOME\n";
+$ENV{HOME} = (getpwuid($<))[7] or die "no HOME";
# fexsrv MUST be run with full path!
if ($0 =~ m:^(/.+)/bin/fexsrv:) {
# import from fex.pp
our ($hostname,$debug,$timeout,$max_error,$max_error_handler);
-our ($spooldir,$logdir,$docdir,$xkeydir,$lockdir);
-our ($force_https,$default_locale,$bs,$adlm);
+our ($spooldir,@logdir,$docdir,$xkeydir,$lockdir);
+our ($force_https,$default_locale,$bs,$MB,$adlm);
our (@locales);
# load common code (local config: $FEXHOME/lib/fex.ph)
-require "$FEXLIB/fex.pp" or die "$0: cannot load $FEXLIB/fex.pp - $!\n";
+require "$FEXLIB/fex.pp" or die "cannot load $FEXLIB/fex.pp - $!\n";
chdir $spooldir or http_die("$0: $spooldir - $!\n");
-our $log = "$logdir/fexsrv.log";
+our $log = 'fexsrv.log';
our $error = 'F*EX ERROR';
our $htmlsource;
our $hid = ''; # header ID
$0 = untaint($0);
-$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
+$ENV{GATEWAY_INTERFACE} = 'CGI/1.1f';
$ENV{SERVER_NAME} = $hostname;
+$ENV{REQUEST_METHOD} = '';
$ENV{QUERY_STRING} = '';
$ENV{HTTP_COOKIE} = '';
$ENV{PATH_INFO} = '';
# HTTP connect
else {
$ENV{PROTO} = 'http';
- my $sa = getpeername(STDIN) or die "$0: no network stream on STDIN\n";
+ my $sa = getpeername(STDIN) or die "no network stream on STDIN\n";
if (sockaddr_family($sa) == AF_INET) {
($ENV{REMOTE_PORT},$iaddr) = sockaddr_in($sa);
$ENV{REMOTE_ADDR} = $ra = inet_ntoa($iaddr);
$^W = 0; eval 'use Socket6'; $^W = 1;
http_error(503) if $@;
($ENV{REMOTE_PORT},$iaddr) = unpack_sockaddr_in6($sa);
- $ENV{REMOTE_ADDR} = $ra = inet_ntop(AF_INET6, $iaddr);
+ $ENV{REMOTE_ADDR} = $ra = inet_ntop(AF_INET6,$iaddr);
$rh = gethostbyaddr($iaddr,AF_INET6);
($port) = unpack_sockaddr_in6(getsockname(STDIN));
} else {
- die "$0: unknown IP version\n";
+ die "unknown IP version\n";
}
$port = 80 unless $port;
}
$ENV{HTTP_HOST} = ($port == 80 or $port == 443)
? $hostname : "$hostname:$port";
+ $ENV{PORT} = $port;
}
if ($reverse_proxy_ip and $reverse_proxy_ip eq $ra) {
$header{$1} = $2 if /(.+)\s*:\s*(.+)/;
push @log,$_;
}
+ if ($hl > $MB) {
+ fexlog($connect,@log,"OVERRUN");
+ http_error(413);
+ }
if (/^(GET \/|X-Forwarded-For|User-Agent)/i) {
$hid .= $_."\n";
}
if ($request =~ /^(GET|HEAD|POST)\s+(.+)\s+(HTTP\/[\d\.]+$)/i) {
+ $ENV{REQUEST} = $_;
$ENV{REQUEST_METHOD} = uc($1);
$ENV{REQUEST_URI} = $uri = $cgi = $2;
$ENV{HTTP_VERSION} = $protocol = $3;
if ($debug) {
debuglog("ENV:\n");
foreach $var (sort keys %ENV) {
- debuglog(sprintf " %s = >%s<\n",$var,$ENV{$var});
+ if (defined($ENV{$var})) {
+ debuglog(sprintf " %s = >%s<\n",$var,$ENV{$var});
+ }
}
debuglog("\n");
}
# prepare document file name
if ($ENV{REQUEST_METHOD} =~ /^GET|HEAD$/) {
+ if (%redirect) {
+ foreach my $r (keys %redirect) {
+ if ($uri =~ /^\Q$r/) {
+ redirect($uri,$r);
+ exit;
+ }
+ }
+ }
$doc = untaint($uri);
$doc =~ s/%([\dA-F]{2})/unpack("a",pack("H2",$1))/ge;
$doc =~ m:/\.\./: and http_error(403);
$doc =~ s:^/+::;
$doc =~ s/\?.*//;
- if ($locale and -e "$docdir/locale/$locale/$doc") {
+ if ($locale and $locale ne 'english' and -e "$docdir/locale/$locale/$doc") {
$doc = "$docdir/locale/$locale/$doc";
} else {
$doc = "$docdir/$doc";
fexlog($connect,@log,"FORBIDDEN");
http_error(403);
}
- unlink "$logdir/.error/$ra";
+ unlink "$spooldir/.error/$ra";
# push @log,"DEBUG: locale=$locale locales=(@locales)";
fexlog($connect,@log,"EXEC $cgi");
eval { local $^W = 0; exec $cgi };
or $doc =~ /(.+)\.tgz$/ and -f "$1.tar"
or $doc =~ /(.+)\.gz$/ and -f $1)
{
- unlink "$logdir/.error/$ra";
+ unlink "$spooldir/.error/$ra";
delete $ENV{SCRIPT_FILENAME};
$ENV{DOCUMENT_FILENAME} = $doc;
require "$FEXLIB/dop";
# read one text line unbuffered from STDIN
sub getaline {
my $line = '';
+ my $n = 0;
my $c;
alarm($timeout);
# (later exec would destroy line buffer)
while (sysread STDIN,$c,1) {
$line .= $c;
+ $n++;
last if $c eq "\n";
+ if ($n > $bs) {
+ fexlog($connect,@log,$line,"OVERRUN");
+ http_error(413);
+ }
}
alarm(0);
sub fexlog {
my @log = @_;
- if (open $log,">>$log") {
- flock $log,LOCK_EX;
- seek $log,0,SEEK_END;
- print {$log} "\n",join("\n",@log),"\n";
- close $log;
- } else {
- http_die("$0: cannot write to $log - $!\n");
+
+ foreach my $logdir (@logdir) {
+ if (open $log,'>>',"$logdir/$log") {
+ flock $log,LOCK_EX;
+ seek $log,0,SEEK_END;
+ print {$log} "\n",join("\n",@log),"\n";
+ close $log;
+ } else {
+ http_die("$0: cannot write to $logdir/$log - $!\n");
+ }
}
}
-
sub badchar {
my $bc = shift;
} elsif ($error eq 404) {
http_error_header("404 Not Found");
nvt_print("The requested URI $URI was not found on this server.");
+ } elsif ($error eq 413) {
+ http_error_header("413 Payload Too Large");
+ nvt_print("Your HTTP header is too large.");
} elsif ($error eq 416) {
http_error_header("416 Requested Range Not Satisfiable");
} elsif ($error eq 503) {
}
+sub redirect {
+ my $uri = shift;
+ 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",
+ ""
+ );
+ } 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(
+ '<h3>Please use new URL: <a href="$newurl">$newurl</a></h3>'
+ '</body></html>'
+ ));
+ }
+ if ($rr =~ /^http/) {
+ exit;
+ } else {
+ &reexec;
+ }
+}
+
+
sub badlog {
my $request = shift;
my @n;
sub usage {
print "usage: $0 \"SUBJECT\" < mail.text\n";
- exit shift;
+ exit shift||0;
}
# parse CLI arguments
$opt_l = $opt_i = $opt_t = $opt_s = $opt_a = $opt_r = $opt_d = $opt_n = 0;
$opt_L = $opt_N = $opt_c = $opt_u = $opt_S = $opt_R = $opt_z = $opt_h = 0;
-$opt_U = 0;
+$opt_U = $opt_x = 0;
${'opt_*'} = ${'opt_?'} = 0;
$opt_m = $opt_f = $opt_F = $opt_D = '';
-&usage if !getopts('hdnlLNitcuarsUSRz*?m:f:D:F:') || $opt_h;
+&usage if !getopts('hdnlLNitcuarsxUSRz*?m:f:D:F:') || $opt_h;
$opt_z = 1 unless $opt_R;
$opt_l = 1 if $0 eq 'll';
$opt_l = $opt_i = $opt_a = $opt_S = 1 if $0 eq 'lll';
# traverse real subdirs
if (-d $f and not -l $f) {
$f =~ s:/*$:/:;
+ # skip other file systems on -x
+ if ($opt_x) {
+ my @pd = stat(dirname($f));
+ my @sd = stat($f);
+ next if $pd[0] ne $sd[0];
+ }
collect(getfiles($f));
}
sub usage {
- my $opts = '[-lastcuidnrzLRNS*] [-f format] [-D X:Y]';
+ my $opts = '[-lastcuidnrzLRxNS*] [-f format] [-D X:Y]';
if ($0 ne 'lf') {
print "usage: $0 $opts [-F regexp] [file...]\n";
}
-z squeeze size field (slows down output)
-L derefernce symbolic links
-R recursive into subdirs
+ -x do not cross filesystem boundaries with -R
-F find files matching case insensitive regexp
-N show only normal (regular) files
-S print statistics summary at end
#!/usr/bin/perl -w
-use Encode;
use File::Basename;
use Cwd 'abs_path';
use I18N::Langinfo qw'langinfo CODESET';
die "$0: no $FEXLIB\n" unless -d $FEXLIB;
# import from fex.pp
-our ($logdir,$spooldir,$debug);
+our (@logdir,$spooldir,$debug);
# load common code, local config : $HOME/lib/fex.ph
require "$FEXLIB/fex.pp" or die "$0: cannot load $FEXLIB/fex.pp - $!\n";
$CTYPE = langinfo(CODESET());
binmode(STDOUT,":encoding($CTYPE)");
-$log = shift || "$logdir/fexsrv.log";
+$log = shift || $logdir[0].'/fexsrv.log';
$ignore = join('|',qw(
(CONNECT|CONTINUE).*(crawl|msnbot|obertux)
GET./fup\?showstatus
GET./FAQ/faq\.css
GET./FAQ/jquery\.js
- GET./10+.B
GET.*Arrow\.gif
GET./apple-touch
+ GET./browserconfig\.xml
User-Agent:.*(Webnote|FeedFetcher|\w+bot|bot/|Website.Watcher|crawler|spider|searchme|Yandex|Slurp|ScoutJet|findlinks|urlmon|nagios)
User-Agent:.fnb.*quak
From:.*(msnbot|yandex|googlebot|webcrawler)
printf " TO=\"%s\"\n",$to;
$cgi = '';
if ($comment = slurp("$ddir/comment")) {
- printf " COMMENT=\"%s\"\n",decode_utf8($comment,0)||'';
+ printf " COMMENT=\"%s\"\n",utf8decode($comment)||'';
}
if (not -f "$ddir/data" and $_ = slurp("$ddir/error")) {
s/\n.*//s;
read_skey($1);
print "\n";
}
+ if ($debug and $pid and $cgi) {
+ &read_debug_log;
+ };
+ $pid = $cgi = '';
}
sleep 1;
- if ($debug and $pid and $cgi) {
- &read_debug_log;
- $pid = $cgi = '';
- };
}
for (1..2) {
sleep 1;
- @log = `ls -rt $logdir/.debug/*_${pid}.$cgi 2>/dev/null`;
+ @log = `ls -rt $logdir[0]/.debug/*_${pid}.$cgi 2>/dev/null`;
if ($log = $log[-1] and open $log,$log) {
# binmode($log,":encoding(UTF-8)");
while (<$log>) {
$_ = <$log>;
my $v = <$log>||'';
$v =~ s/[\r\n]+//;
- printf " %s=\"%s\"\n",$p,decode_utf8($v,0)||$v if $v;
+ printf " %s=\"%s\"\n",$p,utf8decode($v)||$v if $v;
read_akey($v) if $p eq 'AKEY';
read_skey($v) if $p eq 'SKEY';
} elsif (/^(Param|Exp): (\w+=".+")/) {
close $skey;
}
}
+
+
+sub utf8decode {
+ local $_ = shift;
+ s/([\xC0-\xDF])([\x80-\xBF])/chr(ord($1)<<6&0xC0|ord($2)&0x3F)/eg;
+ return $_;
+}
eval 'use Net::INET6Glue::INET_is_INET6';
-our $version = 20150120;
+our $version = 20150615;
my %SSL = (SSL_version => 'TLSv1');
my $sigpipe;
ZZ=${ZZ:-$HOME/.zz}
-if [ "X$*" = X-h -o "X$*" = X--help ]; then
+if [ "$*" = -h -o "$*" = --help ]; then
exec cat<<EOD
zz is the generic clip board program. See also the edit helper program ezz.
The clip board is \$ZZ (default: \$HOME/.zz). Options and modes are:
EOD
fi
-if [ x"$1"x = x+x ]; then
+if [ "$1" = + ]; then
shift
exec cat -- "$@" >>$ZZ
fi
if [ -t 0 ]; then
- if [ x"$1"x = xx ]; then
+ if [ -z "$1" ]; then
exec cat -- $ZZ
- elif [ x"$1"x = x..x ]; then
+ elif [ "$1" = .. ]; then
exec cat -- $ZZ~
else
test -f $ZZ && mv $ZZ $ZZ~
-#!/usr/bin/perl -w
+#!/usr/bin/perl -Tw
# F*EX CGI for administration
#
-#
Author: Andre Hafner <andrehafner@gmx.net>
+#
Original author: Andre Hafner <andrehafner@gmx.net>
#
-use CGI qw(:standard);
-use CGI::Carp qw(fatalsToBrowser);
+BEGIN { ($ENV{PERLINIT}||'') =~ /(.+)/s and eval $1 }
$| = 1;
+$fac = $0;
+$fac =~ s:.*/::;
+
# add fex lib
-(our $FEXLIB) = $ENV{FEXLIB} =~ /(.+)/;
-die "no \$FEXLIB\n" unless -d $FEXLIB;
+(our $FEXLIB) = $ENV{FEXLIB} =~ /(.+)/ or die "no \$FEXLIB\n";
# import from fex.pp and fex.ph
-our ($FEXHOME,$spooldir,$logdir,$docdir,$durl,$mdomain);
-our ($bs,$hostname,$keep_default,$recipient_quota,$sender_quota,$autodelete);
+our ($FEXHOME,$spooldir,$logdir,$docdir,$akeydir,$durl,$mdomain,$bs,$hostname);
+our ($keep_default,$keep_max,$recipient_quota,$sender_quota,$autodelete);
our ($admin,$admin_pw,$admin_hosts);
our ($sendmail,$bcc);
our $error = 'FAC error';
# load common code, local config : $HOME/lib/fex.ph
-require "$FEXLIB/fex.pp" or http_die("cannot load $FEXLIB/fex.pp - $!\n");
+require "$FEXLIB/fex.pp";
my @http_auth = ();
my $ra = $ENV{REMOTE_ADDR}||0;
html_error($error,"no F*EX account for admin $admin\n") unless $admin_pw;
# redirect to https if configured
-if (0 and open my $x,'/etc/xinetd.d/fexs') {
+(undef,$port) = split(':',$ENV{HTTP_HOST}||'');
+$port ||= $ENV{PROTO} eq 'https' ? 443 : 80;
+if ($port == 80 and open my $x,'/etc/xinetd.d/fexs') {
while (<$x>) {
if (/^\s*disable\s*=\s*no/) {
nvt_print(
close $x;
}
+our %PARAM;
+&parse_parameters;
+
+$action = $PARAM{"action"}||'';
+
# authentication
&require_akey;
my $http_client = $ENV{HTTP_USER_AGENT} || '';
-# here is chosen which files to save with backup function
+# files to save with backup function
my @backup_files = qw(
htdocs/index.html
lib/fex.ph
lib/fup.pl
spool/*@*/@*
+ spool/*@*/.auto
);
# backup goes first
-if (defined param("action") and param("action") eq "backup") { &backup }
+if ($action eq "backup") {
+ &backup;
+ exit;
+}
http_header('200 OK');
print;
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";
+ "<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 =
- 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";
+ "<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";
-if (-f 'fexsrv.log') {
+if (-f "$logdir/fexsrv.log") {
$nav_log =
- li("<a href=\"?action=watch\">Watch logfile</a>") . "\n" .
- li("<a href=\"?action=fexsrv.log\">Get fexsrv.log</a>") . "\n" .
- $nav_log;
+ "<li><a href=\"?action=watch\">Watch logfile</a>\n".
+ "<li><a href=\"?action=fexsrv.log\">Get fexsrv.log</a>\n".
+ $nav_log;
}
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=backup\">Download backup<br>(config only)</a>\n".
+ "<li><a href=\"?action=restore\">Restore backup</a>\n";
my $nav_show =
- li("<a href=\"?action=list\">List spooled files</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";
+ "<li><a href=\"?action=list\">List spooled files</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 =
- li("<a href=\"?action=editconfig\">Edit config</a>") . "\n" .
- li("<a href=\"?action=editindex\">Edit index.html</a>") . "\n";
-
-#print table({-border=>"0"},Tr({-valign=>"top"},[td([ul($nav_user), ul($nav_log), ul($nav_backup), ul($nav_other)])])), "\n";
-#print "\n", hr, "\n" ;
-print table({-border=>"0"},
- th({},["manage user","show","log files","edit","backup"]),
- Tr({-valign=>"top"},[td([
- ul($nav_user),
- ul($nav_show),
- ul($nav_log),
- ul($nav_edit),
- ul($nav_backup)
-])])), "\n";
-print "<hr>\n";
+ "<li><a href=\"?action=editconfig\">Edit config</a>\n".
+ "<li><a href=\"?action=editindex\">Edit index.html</a>\n";
+
+pq(qq(
+ '<table border="0">'
+ ' <th>manage user</th>'
+ ' <th>show</th>'
+ ' <th>log files</th>'
+ ' <th>edit</th>'
+ ' <th>backup</th>'
+ ' <tr valign="top">'
+ ' <td><ul>$nav_user</ul>'
+ ' <td><ul>$nav_show</ul>'
+ ' <td><ul>$nav_log</ul>'
+ ' <td><ul>$nav_edit</ul>'
+ ' <td><ul>$nav_backup</ul>'
+ ' </tr>'
+ '</table>'
+ '<hr>'
+));
my @user_items = &userList;
-if (my $action = param("action")) {
- 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 "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 }
- else { http_die("STOP TRYING TO CHEAT ME!\n") }
-}
-
-if (defined param("createUser")) {
- createUser(param("createUser"), param("authID"));
-
-} elsif (defined param("changeAuthUser")) {
- if (param("changeAuthUser") =~ /^#.*/) {
- &changeAuthForm;
- } else {
- changeUser(param("changeAuthUser"), param("authID"));
- }
-
-} elsif (defined param("showUserConfig")) {
- if (param("showUserConfig") =~ /^#.*/) {
- &userConfigForm;
- } else {
- showUserConfig(param("showUserConfig"));
- }
-
-} elsif (defined param("deleteUser")) {
- if (param("deleteUser") =~ /^#.*/) {
- &deleteUserForm;
- } else {
- deleteUser(param("deleteUser"));
- }
-} elsif (defined param("userQuota")) {
- if (param("userQuota") =~ /^#.*/) {
- &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 "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 }
+
+if (defined $PARAM{"createUser"}) {
+ createUser($PARAM{"createUser"}, $PARAM{"authID"});
+} elsif (defined $PARAM{"changeAuthUser"}) {
+ if ($PARAM{"changeAuthUser"} =~ /^#.*/) {
+ &changeAuthForm;
+ } else {
+ changeUser($PARAM{"changeAuthUser"}, $PARAM{"authID"});
+ }
+} elsif (defined $PARAM{"showUserConfig"}) {
+ if ($PARAM{"showUserConfig"} =~ /^#.*/) {
+ &userConfigForm;
+ } else {
+ showUserConfig($PARAM{"showUserConfig"});
+ }
+} elsif (defined $PARAM{"deleteUser"}) {
+ if ($PARAM{"deleteUser"} =~ /^#.*/) {
+ &deleteUserForm;
+ } else {
+ deleteUser($PARAM{"deleteUser"});
+ }
+} elsif (defined $PARAM{"userQuota"}) {
+ if ($PARAM{"userQuota"} =~ /^#.*/) {
+ &changeQuotaForm;
+ } else {
+ if (defined $PARAM{"default quota"}) {
+ $user = normalize_user($PARAM{"userQuota"});
+ unlink "$user/\@QUOTA";
+ print "$user has now default quota:<p>\n";
+ print "recipient quota: $recipient_quota MB<br>\n";
+ print "sender quota: $sender_quota MB<br>\n";
+ &end_html;
} else {
- if (defined param("remove quota")) {
- $user = param("userQuota");
- deleteFiles("$spooldir/$user/\@QUOTA");
- } else {
- alterQuota(param("userQuota"), param("recipientQuota"), param("senderQuota"));
- }
+ alterQuota(
+ $PARAM{"userQuota"},
+ $PARAM{"recipientQuota"},
+ $PARAM{"senderQuota"}
+ );
}
-
-} elsif (defined param("editUser")) {
- if (param("editUser") =~ /^#.*/) {
- &editRestrictionsForm;
+ }
+} elsif (defined $PARAM{"editUser"}) {
+ if ($PARAM{"editUser"} =~ /^#.*/) {
+ &editRestrictionsForm;
+ } else {
+ if (defined $PARAM{"delete file"}) {
+ $user = normalize_user($PARAM{"editUser"});
+ unlink "$user/\@ALLOWED_RECIPIENTS";
+ print "upload restrictions for $user have been deleted\n";
+ &end_html;
} else {
- if (defined param("delete file")) {
- $user = param("editUser");
- deleteFiles("$spooldir/$user/\@ALLOWED_RECIPIENTS");
- } else {
- editUser(param("editUser"));
- }
+ editUser($PARAM{"editUser"});
}
-
-} elsif (defined param("contentBox") && defined param("ar")) {
- saveFile(param("contentBox"), param("ar"));
-
-} elsif (defined param("upload_archive")) {
- restore(param("upload_archive"));
+ }
+} elsif ($PARAM{"contentBox"} and $PARAM{"ar"}) {
+ saveFile($PARAM{"contentBox"},$PARAM{"ar"});
+} elsif ($PARAM{"upload_archive"}) {
+ restore($PARAM{"upload_archive"}{data});
}
-print end_html();
-exit;
-
+&end_html;
#######
# declaration of formular functions
# formular for creating new users
# required arguments: -
sub createUserForm {
- my $nameRow = "\n" . td(["user:", textfield(-size=>80, -name=>"createUser")]);
- my $authRow = "\n" . td(["auth-ID:", textfield(-size=>80, -name=>"authID")]);
- print "\n", h3("Create new user");
- print "\n", start_form(-name=>"create", -method=>"POST");
- print "\n", table(Tr([$nameRow, $authRow]));
- print "\n", submit('create user'), br;
- print "\n", end_form;
+ print h3("Create new user");
+ pq(qq(
+ '<form action="/$fac" method="post" enctype="multipart/form-data">'
+ '<table>'
+ '<tr>'
+ '<td>user</td><td><input type="text" name="createUser" size="80"></td>'
+ '</tr>'
+ '<tr>'
+ '<td>auth-ID:</td><td><input type="text" name="authID" size="16"></td>'
+ '</tr>'
+ '</table>'
+ '<input type="submit" name="create user" value="create user">'
+ '</form>'
+ ));
+ &end_html;
}
# formular for changing auth-id of an user
# required arguments: -
sub changeAuthForm {
- my $nameRow = "\n" . td(["user:", popup_menu(-name=>"changeAuthUser", -values=>\@user_items)]);
- my $authRow = "\n" . td(["new auth-ID:", textfield(-size=>80, -name=>"authID")]);
- print "\n", h3("change auth-ID");
- print "\n", start_form(-name=>"change-auth", -method=>"POST");
- print "\n", table(Tr([$nameRow, $authRow]));
- print "\n", submit('change'), br;
- print "\n", end_form;
+ my @option = map { "<option value=\"$_\">$_</option>\n" } @user_items;
+
+ print h3("change auth-ID");
+ pq(qq(
+ '<form action="/$fac" method="post" enctype="multipart/form-data">'
+ '<table>'
+ '<tr>'
+ '<td>user:</td><td><select name="changeAuthUser">@option</select></td>'
+ '</tr>'
+ '<tr>'
+ '<td>new auth-ID:</td><td><input type="text" name="authID" size="16"></td>'
+ '</tr>'
+ '</table>'
+ '<input type="submit" name="change" value="change">'
+ '</form>'
+ ));
+ &end_html;
}
# formular choosing user, whose config files shall be shown
# required arguments: -
sub userConfigForm {
- my $nameRow = "\n". td(["user:", popup_menu(-name=>"showUserConfig", -values=>\@user_items)]);
- print "\n", h3("Show user config files");
- print "\n", start_form(-name=>"showUserConfig", -method=>"POST");
- print "\n", table(Tr([$nameRow]));
- print "\n", submit('show config files'), br;
- print "\n", end_form;
+ my @option = map { "<option value=\"$_\">$_</option>\n" } @user_items;
+
+ print h3("Show user config files");
+ pq(qq(
+ '<form action="/$fac" method="post enctype="multipart/form-data">'
+ '<table>'
+ '<tr>'
+ '<td>user:</td><td><select name="showUserConfig">@option</select></td>'
+ '</tr>'
+ '</table>'
+ '<input type="submit" name="show config files" value="show config files">'
+ '</form>'
+ ));
+ &end_html;
}
# formular for choosing user, whose restriction file shall be edited
# required arguments: -
sub editRestrictionsForm {
- my $nameRow = "\n" . td(["user:", popup_menu(-name=>"editUser", -values=>\@user_items)]);
- print "\n", h3("Edit user restriction file");
- print "\n", start_form(-name=>"edit", -method=>"POST");
- print "\n", table(Tr([$nameRow]));
- print "\n", submit('edit file');
- print "\n", submit('delete file'), br;
- print "\n", end_form;
+ my @option = map { "<option value=\"$_\">$_</option>\n" } @user_items;
+
+ print h3("Edit user restriction file");
+ pq(qq(
+ '<form action="/$fac" method="post enctype="multipart/form-data">'
+ '<table>'
+ '<tr>'
+ '<td>user:</td><td><select name="editUser">@option</select></td>'
+ '</tr>'
+ '</table>'
+ '<input type="submit" name="edit file" value="edit file">'
+ '<input type="submit" name="delete file" value="delete file">'
+ '</form>'
+ ));
+ &end_html;
}
# formular for choosing user, who shall be removed
# required arguments: -
sub deleteUserForm {
- my $nameRow = "\n". td(["user:", popup_menu(-name=>"deleteUser", -values=>\@user_items)]);
- print "\n", h3("Delete existing user");
- print "\n", start_form(-name=>"deleteUser", -method=>"POST");
- print "\n", table(Tr([$nameRow]));
- print "\n", submit('delete user'), br;
+ my @option = map { "<option value=\"$_\">$_</option>\n" } @user_items;
- print "\n", end_form;
+ print h3("Delete existing user");
+ pq(qq(
+ '<form action="/$fac" method="post enctype="multipart/form-data">'
+ '<table>'
+ '<tr>'
+ '<td>user:</td><td><select name="deleteUser">@option</select></td>'
+ '</tr>'
+ '</table>'
+ '<input type="submit" name="delete user" value="delete user">'
+ '</form>'
+ ));
+ &end_html;
}
# formular for changing an user's quota file
# required arguments: -
sub changeQuotaForm {
- my ($rquota,$squota) = '';
- $rquota = param("rquota") if defined param("rquota");
- $squota = param("squota") if defined param("squota");
- my $dropdownMenu;
- if (defined param("user")) {
- $dropdownMenu = "<select name=\"userQuota\">\n";
- foreach (@user_items) {
- if ($_ eq param("user")) {
- $dropdownMenu .= "<option value=\"$_\" selected>$_</option>";
- } else {
- $dropdownMenu .= "<option value=\"$_\">$_</option>";
- }
- }
- $dropdownMenu .= "</select>\n";
+ my $user;
+ my @option;
+ my $rquota = '';
+ my $squota = '';
+
+ if ($user = $PARAM{"user"}) {
+
+ $user = normalize_user($user);
+ $rquota = $1 if ($PARAM{"rquota"}||'') =~ /^(\d+)$/;
+ $squota = $1 if ($PARAM{"squota"}||'') =~ /^(\d+)$/;
+ }
+
+ foreach (@user_items) {
+ if ($user and $user eq $_) {
+ push @option,"<option value=\"$_\" selected>$_</option>\n";
} else {
- $dropdownMenu = popup_menu(-name=>"userQuota", -values=>\@user_items);
+ push @option,"<option value=\"$_\">$_</option>\n";
}
- my $nameRow = "\n" . td(["user:", $dropdownMenu]);
- my $recipientRow = "\n" . td(["new quota for recipient:", textfield(-size=>20, -name=>"recipientQuota", -value=>$rquota). " MB (optional)"]);
- my $senderRow = "\n" . td (["new quota for sender:", textfield(-size=>20, -name=>"senderQuota", -value=>$squota). " MB (optional)"]);
- print "\n", h3("Manage disk quota");
- print "\n", start_form(-name=>"manageQuota", -method=>"POST");
- print "\n", table(Tr([$nameRow, $recipientRow, $senderRow]));
- print "\n", submit('change quota');
- print "\n", submit('remove quota'), br;
- print "\n", end_form;
+ }
+
+ print h3("Manage disk quota");
+ pq(qq(
+ '<form action="/$fac" method="post" enctype="multipart/form-data">'
+ '<table>'
+ '<tr>'
+ '<td>user:</td><td><select name="userQuota">@option</select></td>'
+ '</tr>'
+ '<tr>'
+ '<td>new quota for recipient:</td>'
+ '<td><input type="text" name="recipientQuota" size="12" value=\"$rquota\">'
+ ' MB (optional)</td>'
+ '</tr>'
+ '<tr>'
+ '<td>new quota for sender:</td>'
+ '<td><input type="text" name="senderQuota" size="12" value=\"$squota\">'
+ ' MB (optional)</td>'
+ '</tr>'
+ '</table>'
+ '<input type="submit" name="change quota" value="change quota">'
+ '<input type="submit" name="default quota" value="default quota">'
+ '</form>'
+ ));
+ &end_html;
}
# formular for choosing backup file to restore
# required arguments: -
sub restoreForm {
- print h2("restore config");
- print "please specify the backup-archive you want to restore:";
- print "\n", start_form(-name=>"restoreFile", -method=>"POST");
- print "\n", filefield(-name=>"upload_archive", -size=>"80"), br;
- print "\n", submit('restore');
- print "\n", end_form;
+ print h2("restore config");
+ pq(qq(
+ 'Specify the backup-archive you want to restore:<br>'
+ '<form action="/$fac" method="post" enctype="multipart/form-data">'
+ '<input type="file" name="upload_archive" size="80"><br>'
+ '<input type="submit" name="restore" value="restore">'
+ '</form>'
+ ));
+ &end_html;
}
# function for creating new users
# required arguments: username, auth-id
sub createUser {
- my ($user,$id) = @_;
- my $idf;
-
- $id or http_die("not enough arguments in createUser");
-
- $user = lc $user;
- $user =~ s:/::g;
- $user =~ s:^[.@]+::;
- $user =~ s:@+$::;
-
- if ($user !~ /@/) {
- if ($mdomain) {
- $user .= '@'.$mdomain;
- } else {
- error("Missing domain part in user address");
- }
- }
+ my ($user,$id) = @_;
+ my $idf;
- unless (-d "$spooldir/$user") {
- mkdir "$spooldir/$user",0755
- or http_die("cannot mkdir $spooldir/$user - $!\n");
- }
+ http_die("not enough arguments in createUser") unless $id;
- $idf = "$spooldir/$user/@";
+ $user = normalize_user($user);
- if (-f $idf) {
- error("There is already an 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 - $!\n");
- print {$idf} $id,"\n";
- close $idf or http_die("cannot write $idf - $!\n");
- print "<code>\n";
- printf "%s?from=%s&ID=%s<br>\n",$fup,$user,$id;
- printf "%s/%s<p>\n",$fup,b64("from=$user&id=$id");
- print "</code>\n";
- notifyUser($user,$id);
- print "An information e-mail to $user has been sent.\n";
+ open $idf,'>',$idf or http_die("cannot write $idf - $!");
+ print {$idf} $id,"\n";
+ close $idf or http_die("cannot write $idf - $!");
+ print "<code>\n";
+ printf "%s?from=%s&ID=%s<br>\n",$fup,$user,$id;
+ printf "%s/%s<p>\n",$fup,b64("from=$user&id=$id");
+ print "</code>\n";
+ notifyUser($user,$id);
+ print "An information e-mail to $user has been sent.\n";
+ &end_html;
}
# function for changing an user's auth-ID
# required arguments: username, auth-id
sub changeUser {
- my ($user,$id) = @_;
- defined($id) or http_die("not enough arguments in changeUser.\n");
-
- $user .= '@'.$mdomain if $mdomain and $user !~ /@/;
- my $idf = "$spooldir/$user/@";
- print "<code>\n";
- print "$idf<p>";
-
- open $idf,'>',$idf or http_die("cannot write $idf - $!\n");
- print {$idf} $id,"\n";
- close $idf or http_die("cannot write $idf - $!\n");
- printf "%s?from=%s&ID=%s<br>\n",$fup,$user,$id;
- printf "%s/%s\n",$fup,b64("from=$user&id=$id");
- print "</code><p>\n";
- notifyUser($user,$id,"change-auth");
- print "An information e-mail to $user has been sent.\n";
+ 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 - $!");
+ printf "%s?from=%s&ID=%s<br>\n",$fup,$user,$id;
+ printf "%s/%s\n",$fup,b64("from=$user&id=$id");
+ print "</code><p>\n";
+ notifyUser($user,$id,"change-auth");
+ print "An information e-mail to $user has been sent.\n";
+ &end_html;
}
# function for showing an user's config files
# required arguments: username
sub showUserConfig {
- http_die("not enough arguments in showUserConfig!\n") unless (my $user = $_[0]);
+ my $user = shift;
+
+ http_die("not enough arguments in showUserConfig!") unless $user;
+ $user = normalize_user($user);
- chdir "$spooldir/$user" or http_die("could not change directory $spooldir/$user - $!");
- print h2("Config files of <code>$user</code>");
-
- foreach my $file (glob('.auto @* @GROUP/*')) {
- if (-f $file and not -l $file and $file !~ /.*~$/) {
- print h3($file), "\n";
- open $file,'<',$file or http_die("cannot open $file - $!");
- # print "<table border=1><tr><td>\n";
- dumpfile($file);
- # print "</tr></table>\n";
- close $file;
- }
+ chdir "$user" or http_die("could not change directory $user - $!");
+ print h2("Config files of <code>$user</code>");
+
+ foreach my $file (glob('.auto @* @GROUP/*')) {
+ if (-f $file and not -l $file and $file !~ /.*~$/) {
+ print h3($file), "\n";
+ open $file,'<',$file or http_die("cannot open $file - $!");
+ # print "<table border=1><tr><td>\n";
+ dumpfile($file);
+ # print "</tr></table>\n";
+ close $file;
}
+ }
+ &end_html;
}
# function for editing an user's recipient/sender restrictions
# required arguments: username
sub editUser {
- http_die("not enough arguments in editUser.\n") unless (my $user = $_[0]);
- my @content;
- http_die("no user $user") unless -d "$spooldir/$user";
- my $ar = "$spooldir/$user/\@ALLOWED_RECIPIENTS";
- unless (-f $ar) {
- print "yeah!";
- open F,">$ar" or http_die("cannot open $ar - $!");
- print F<<EOD;
+ 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;
+ my $ar = "$user/\@ALLOWED_RECIPIENTS";
+ unless (-f $ar) {
+ open $ar,'>',$ar or http_die("cannot open $ar - $!");
+ print {$ar}<<'EOD';
# Restrict allowed recipients. Only those listed here are allowed.
# Make this file COMPLETLY empty if you want to disable the restriction.
# An allowed recipient is an e-mail address, you can use * as wildcard.
-# Example: *\@flupp.org
+# Example: *@flupp.org
EOD
- close F;
- }
- open my $file,'<',$ar or http_die("cannot open $ar - $!");
- while (<$file>) {
- push @content, $_;
- }
- close $file or http_die("cannot write $file - $!\n");
- print "\nedit file:", br;
- print "\n", start_form(-name=>"editRestrictions", -method=>"POST");
- print "\n", textarea(-name=>'contentBox', -default=>join('',@content), -rows=>10, -columns=>80), br;
- print "\n", hidden(-name=>'ar', -default=>"$ar",);
- print "\n", submit('save changes');
- print "\n", end_form;
+ close $ar;
+ }
+ $content = dehtml(slurp($ar));
+ pq(qq(
+ 'Edit restrictions file for user $user :<br>'
+ '<form action="/$fac" method="post" enctype="multipart/form-data">'
+ '<textarea name="contentBox" rows="10" cols="80">'
+ '$content'
+ '</textarea><br>'
+ '<input type="hidden" name="ar" value="$ar">'
+ '<input type="submit" name="save changes" value="save changes">'
+ '</form>'
+ ));
+ &end_html;
}
# function for deleting files
# required arguments: list of Files
sub deleteFiles {
- http_die("not enough arguments in deleteFiles.\n") unless (my @files = @_);
+ http_die("not enough arguments in deleteFiles") unless (my @files = @_);
- foreach (@files) {
- if (-e $_) {
- if (unlink $_) {
- print "file has been deleted: $_\n", br;
- } else {
- print "file could not be deleted: $_ - $!\n", br;
- }
- } else {
- print "file does not exists: $_\n", br;
- }
+ foreach (@files) {
+ if (-e) {
+ if (unlink $_) {
+ print "file has been deleted: $_<br>\n";
+ } else {
+ print "file could not be deleted: $_ - $!<br>\n";
+ }
+ } else {
+ print "file does not exists: $_<br>\n";
}
+ }
+ &end_html;
}
# function for saving a single file
# required arguments: content, location
sub saveFile {
- http_die("not enough arguments in saveFile.\n") unless (my ($rf,$ar) = @_);
-
- if ($ar eq "$FEXLIB/fex.ph") {
- open my $conf,">${ar}_new" or http_die("cannot open ${ar}_new - $!");
- print {$conf} $rf;
- close $conf or http_die("cannot write $conf - $!\n");;
- my $status = `perl -c $FEXLIB/fex.ph_new 2>&1`;
- if ($status =~ /syntax OK/ ) {
- unlink "${ar}_new";
- } else {
- pq(qq(
- 'No valid syntax in configuration file:'
- '<p>'
- '<pre>$status</pre>'
- ));
- &editFile("$FEXLIB/fex.ph_new");
- exit;
- }
- }
- open my $file,">$ar" or http_die("cannot open $ar - $!");
- print {$file} $rf;
- close $file or http_die("cannot write $file - $!\n");;
- print "The following data has been saved:\n<p>\n";
- open $file,'<',$ar or http_die("cannot open $ar - $!");
- if ($ar =~ /\.html$/) {
- print while <$file>;
+ 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') {
+ $ar = "$FEXLIB/fex.ph"
+ } elsif ($ar =~ m'^([^/]+/\@ALLOWED_RECIPIENTS)$') {
+ $ar = $1;
+ } else {
+ http_die("unknown file $ar")
+ }
+
+ $new = $ar.'_new';
+ if ($ar =~ /fex.ph$/) {
+ open $new,'>',$new or http_die("cannot open ${ar}_new - $!");
+ print {$new} $rf;
+ close $new or http_die("cannot write $new - $!");;
+ my $status = dehtml(`perl -c $FEXLIB/fex.ph_new 2>&1`);
+ if ($status =~ /syntax OK/ ) {
+ rename $ar,"$ar~";
+ rename $new,$ar;
+ http_die("cannot write $ar~ - $!") if $?;
} else {
- print "<pre>\n";
- print while <$file>;
+ rename "$ar~",$ar;
+ pq(qq(
+ 'No valid syntax in configuration file:'
+ '<p><pre>$status</pre><p>'
+ '<a href="javascript:history.back()">back</a>'
+ ));
+ &end_html;
}
- close $file or http_die("cannot write $file - $!\n");;
+ } else {
+ system qw'cp -a',$ar,"$ar~";
+ }
+ open $ar,'>',$ar or http_die("cannot write $ar - $!");
+ print {$ar} $rf;
+ close $ar or http_die("cannot write $ar - $!");;
+ print "<code>$ar</code> has been saved\n";
+ &end_html;
}
# function for deleting existing user
# required arguments: username
sub deleteUser {
- http_die("not enough arguments in createUser.\n") unless (my $user = $_[0]);
+ my $user = shift;
+
+ http_die("not enough arguments in deleteUser") unless $user;
+
+ $user = normalize_user($user);
- $idf = "$spooldir/$user/\@";
- http_die("no such user $user\n") unless -f $idf;
- unlink $idf or http_die("cannot remove $idf - $!\n");
- unlink "$spooldir/$user/\@ALLOWED_RECIPIENTS";
- print "$user deleted\n";
+ $idf = "$user/\@";
+ http_die("no such user $user") unless -f $idf;
+ unlink $idf or http_die("cannot remove $idf - $!");
+ unlink "$user/\@ALLOWED_RECIPIENTS";
+ unlink "$user/\@SUBUSER";
+ rmrf("$user/\@GROUP");
+ print "$user deleted\n";
+ &end_html;
}
# function for saving quota information for one single user
# required arguments: username, recipient-quota, sender-quota
sub alterQuota {
- http_die("not enough arguments in createUser.\n") unless (my ($user,$rq,$sq) = @_);
-
- $user .= '@'.$mdomain if $mdomain and $user !~ /@/;
- unless (-d "$spooldir/$user") {
- http_die("$user is not a regular F*EX user\n");
- }
+ my ($user,$rq,$sq) = @_;
+ my ($rquota,$squota);
+ my $qf;
- $rquota = $squota = '';
- $qf = "$spooldir/$user/\@QUOTA";
- if (open $qf,'<',$qf) {
- while (<$qf>) {
- s/#.*//;
- $rquota = $1 if /recipient.*?(\d+)/i;
- $squota = $1 if /sender.*?(\d+)/i;
- }
- close $qf or http_die("cannot write $qf - $!\n");
- }
-
- open $qf,'>',$qf or http_die("cannot open $qf - $!\n");
- if(defined($rq) && $rq ne "") {
- $rquota = $1 if $rq =~ /(\d+)/i;
+ $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) {
+ while (<$qf>) {
+ s/#.*//;
+ $rquota = $1 if /recipient.*?(\d+)/i;
+ $squota = $1 if /sender.*?(\d+)/i;
}
- if(defined($sq) && $sq ne "") {
- $squota = $1 if $sq =~ /(\d+)/i;
- }
- print {$qf} "recipient:$rquota\n" if $rquota =~ /\d/;
- print {$qf} "sender:$squota\n" if $squota =~ /\d/;
- close $qf or http_die("cannot write $qf - $!\n");
-
- $rquota = $recipient_quota if $rquota !~ /\d/;
- $squota = $sender_quota if $squota !~ /\d/;
- print h3("New quotas for $user");
- print "recipient quota: $rquota MB\n", br;
- print "sender quota: $squota MB\n", br;
+ 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");
+ print "recipient quota: $rquota MB<br>\n";
+ print "sender quota: $squota MB<br>\n";
+ &end_html;
}
# function for listing f*exed files
# required arguments: -
sub listFiles {
- print h3("List current files"),"\n";
- my ($file,$dkey);
- chdir $spooldir or http_die("$spooldir - $!\n");
- print "<code>\n";
- foreach $file (glob "*/*/*") {
- if (-s "$file/data" and $dkey = readlink("$file/dkey") and -l ".dkeys/$dkey") {
- ($to,$from,$file) = split "/",$file;
- $file = html_quote($file);
- print "$from --> $to : $durl/$dkey/$file<br>\n";
- }
+ print h3("List current files");
+ my ($file,$dkey);
+ print "<pre>\n";
+ foreach $recipient (glob "*@*") {
+ next if -l $recipient;
+ foreach $file (glob "$recipient/*/*") {
+ if (-s "$file/data" and $dkey = readlink("$file/dkey") and -l ".dkeys/$dkey") {
+ ($to,$from,$file) = split "/",$file;
+ $file = html_quote($file);
+ print "$from → $to : $durl/$dkey/$file\n";
+ }
}
- print "</code>\n";
+ }
+ print "</pre>\n";
+ &end_html;
}
# function for watching the fex-logfile
# required arguments: -
sub watchLog {
- if (-f 'fexsrv.log') {
+ if (-f "$logdir/fexsrv.log") {
print h2("polling fexsrv.log"),"\n";
open my $log,"$FEXHOME/bin/logwatch|"
- or http_die("cannot run $FEXHOME/bin/logwatch - $!\n");
+ or http_die("cannot run $FEXHOME/bin/logwatch - $!");
dumpfile($log);
} else {
- print h2("no fexsrv.log"),"\n";
+ print h2("no fexsrv.log");
}
+ &end_html;
}
# function for showing logfiles
# required arguments: logfile-name
sub getlog {
- my $log = shift or http_die("not enough arguments in getLog");
-
- print h2("show $log"),"\n";
- if (open $log,"$logdir/$log") {
- dumpfile($log);
- close $log;
- } else {
- http_die("cannot open $logdir/$log - $!\n");
- }
+ my $log = shift or http_die("not enough arguments in getLog");
+
+ print h2("show $log");
+ if (open $log,"$logdir/$log") {
+ dumpfile($log);
+ close $log;
+ } else {
+ http_die("cannot open $logdir/$log - $!");
+ }
+ &end_html;
}
# function for creating a new backup file
# required arguments: -
sub backup {
- my @d = localtime time;
- my $date = sprintf('%d%02d%02d',$d[5]+1900,$d[4]+1,$d[3]);
- my $backup = "backup/config-$date.tar";
- my $http_client = $ENV{HTTP_USER_AGENT} || '';
- my $size;
-
- my $home = $FEXHOME;
- $home = $1 if $ENV{VHOST} and $ENV{VHOST} =~ /:(.+)/;
+ my @d = localtime time;
+ my $date = sprintf('%d%02d%02d',$d[5]+1900,$d[4]+1,$d[3]);
+ my $backup = "backup/config-$date.tar";
+ my $http_client = $ENV{HTTP_USER_AGENT} || '';
+ my $size;
+
+ my $home = $FEXHOME;
+ $home = $1 if $ENV{VHOST} and $ENV{VHOST} =~ /:(.+)/;
- chdir $home or http_die("$home - $!\n");
-
- unless (-d "backup") {
- mkdir "backup",0700 or http_die("cannot mkdir backup - $!\n");
- }
-
- system "tar -cf $backup @backup_files 2>/dev/null";
-
- $size = -s $backup or http_die("backup file empty\n");
-
- open $backup,'<',$backup or http_die("cannot open $backup - $!\n");
-
- nvt_print(
- 'HTTP/1.1 200 OK',
- "Content-Length: $size",
- "Content-Type: application/octet-stream; filename=fex-backup-$date.tar",
- "Content-Disposition: attachment; filename=\"fex-backup-$date.tar\"",
- "",
- );
-
- while (read($backup,my $b,$bs)) {
- print $b or last;
- }
-
- exit;
+ 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-Type: application/octet-stream; filename=fex-backup-$date.tar",
+ "Content-Disposition: attachment; filename=\"fex-backup-$date.tar\"",
+ "",
+ );
+
+ while (read($backup,my $b,$bs)) {
+ print $b or last;
+ }
+
+ exit;
}
# function for restoring an old configuration file
# required arguments: uploaded archive
sub restore {
- http_die("not enough arguments in restore!\n") unless (my $archive_file = $_[0]);
- my $restore = "backup.tar";
-
- my $home = $FEXHOME;
- $home = $1 if $ENV{VHOST} and $ENV{VHOST} =~ /:(.+)/;
-
- chdir $home or http_die("$home - $!\n");
-
- open $restore,'>',$restore or http_die("cannot open $restore - $!");
-
- my $data;
- while(read $archive_file,$data,$bs) {
- print {$restore} $data;
- }
- close $restore or http_die("cannot write $restore - $!");
- if (-s $restore) {
- print "file upload successful, saving actual config in $home/backup/failsave.tar\n", br;
- system "tar -cf $home/backup/failsave.tar @backup_files 2>/dev/null";
- print "starting restore:\n<p><pre>\n";
- system "tar -xvf $restore";
- unlink $restore;
- } else {
- http_die("upload error - no file data received\n");
- }
+ my $archive_file = shift or http_die("not enough arguments in restore!");
+ my $restore = "backup.tar";
+ my $home = $FEXHOME;
+
+ $home = $1 if $ENV{VHOST} and $ENV{VHOST} =~ /:(.+)/;
+
+ chdir $home or http_die("$home - $!");
+ mkdir 'backup';
+
+ open $restore,'>',$restore or http_die("cannot open $restore - $!");
+ print {$restore} $archive_file;
+ close $restore or http_die("cannot write $restore - $!");
+ if (-s $restore) {
+ print "file upload successful<br>\n";
+ print "saving actual config in $home/backup/config.tar<br>\n";
+ print "<pre>\n";
+ system "tar -cf backup/config.tar @backup_files";
+ print "</pre>\n";
+ print "starting restore:\n<p>\n";
+ print "<pre>\n";
+ system "tar -xvf $restore";
+ unlink $restore;
+ &end_html;
+ } else {
+ http_die("upload error - no file data received");
+ }
}
# function for editing a text-file
# required arguments: filepath, filename
sub editFile {
- my $ar = shift;
- my $file;
- local $/;
+ my $ar = shift;
+ my $file;
- open $ar,'<',$ar or http_die("cannot open $ar - $!");
- $file = <$ar>;
- close $ar;
+ $file = dehtml(slurp($ar));
+
+ $ar =~ s:.*/::;
- print start_form(-name=>"editFile", -method=>"POST"),"\n";
- print textarea(-name=>'contentBox', -default=>$file, -rows=>26, -columns=>80), br,"\n";
- print hidden(-name=>'ar', -default=>"$ar"),"\n";
- print submit('save changes'),"\n";
- print end_form(),"\n";
+ print h2("edit <code>$ar<code>");
+
+ pq(qq(
+ '<form action="/$fac" enctype="multipart/form-data" method="post">'
+ '<textarea name="contentBox" rows="26" cols="80">'
+ '$file'
+ '</textarea><br>'
+ '<input type="hidden" name="ar" value="$ar">'
+ '<input type="submit" name="save changes" value="save changes">'
+ '</form>'
+ ));
+ &end_html;
}
# function for showing all users' quotas
# required arguments: -
sub showQuota {
- my @table_content;
- my $table_head;
-
- print h2("Show quotas (domain sorted, values in MB)");
- foreach (@user_items) {
- if (s/###\s*//g) {
- $table_head = th({}, ["\@$_","sender","sender (used)","recipient","recipient (used)"]);
- if (@table_content) {
- print table({-border=>1},Tr([@table_content])), "\n<p>\n";
- @table_content = '';
- }
- push @table_content, $table_head;
- } else {
- my $rquota = $recipient_quota;
- my $squota = $sender_quota;
- my $rquota_used = 0;
- my $squota_used = 0;
- my $user = $_;
- ($squota,$squota_used) = check_sender_quota($user);
- ($rquota,$rquota_used) = check_recipient_quota($user);
- s/\@.*//;
- push @table_content,
- "<td><a href=\"?action=quota&user=$user&rquota=$rquota&squota=$squota\">$_</a></td>".
- "<td align=\"right\">$squota</td>".
- "<td align=\"right\">$squota_used</td>".
- "<td align=\"right\">$rquota</td>".
- "<td align=\"right\">$rquota_used</td>";
- }
+
+ print h2("Show quotas (domain sorted, values in MB)");
+ print "<table border=\"1\"><tr>";
+ foreach (@user_items) {
+ if (/\#\#\#\s(\S+)/) {
+ print "<tr>";
+ print "<th>\@$1</th>";
+ print "<th>sender</th>";
+ print "<th>sender (used)</th>";
+ print "<th>recipient</th>";
+ print "<th>recipient (used)</th>";
+ print "</tr>\n";
+# $table = $_;
+ } else {
+ my $rquota = $recipient_quota;
+ my $squota = $sender_quota;
+ my $rquota_used = 0;
+ my $squota_used = 0;
+ my $user = $_;
+ ($squota,$squota_used) = check_sender_quota($user);
+ ($rquota,$rquota_used) = check_recipient_quota($user);
+ my $action = "quota&user=$user&rquota=$rquota&squota=$squota";
+ s/\@.*//;
+ print "<tr>";
+ print "<td><a href=\"?action=$action\">$_</a></td>";
+ print "<td align=\"right\">$squota</td>";
+ print "<td align=\"right\">$squota_used</td>";
+ print "<td align=\"right\">$rquota</td>";
+ print "<td align=\"right\">$rquota_used</td>";
+ print "</tr>\n";
}
- print table({-border=>1},Tr([@table_content])), "\n";
+ }
+ print "</table>\n";
+ &end_html;
+
}
# function for showing fex-server configuration
# required arguments: -
sub showConfig {
- print h3("Show config");
- print table({},Tr([
- td(["spooldir:", $spooldir ]),
- td(["logdir:", $logdir ]),
- td(["docdir:", $docdir ]),
- td(["durl:", $durl ]),
- td(["mdomain:", $mdomain||'' ]),
- td(["autodelete:", $autodelete ]),
- td(["keep:", $keep_default ]),
- td(["recipient_quota:", $recipient_quota]),
- td(["sender_quota:", $sender_quota ]),
- td(["admin:", $admin ])
- ]));
+ print h3("Show config");
+ print "<table border=\"0\">\n";
+ printf "<tr><td>spooldir:</td><td>%s</td>\n",$spooldir;
+ printf "<tr><td>logdir:</td><td>%s</td>\n",$logdir;
+ printf "<tr><td>docdir:</td><td>%s</td>\n",$docdir;
+ printf "<tr><td>durl:</td><td>%s</td>\n",$durl;
+ printf "<tr><td>mdomain:</td><td>%s</td>\n",$mdomain||'';
+ printf "<tr><td>autodelete:</td><td>%s</td>\n",$autodelete;
+ printf "<tr><td>keep:</td><td>%s</td>\n",$keep_default;
+ printf "<tr><td>keep_max:</td><td>%s</td>\n",$keep_max;
+ printf "<tr><td>recipient_quota:</td><td>%s</td>\n",$recipient_quota;
+ printf "<tr><td>sender_quota:</td><td>%s</td>\n",$sender_quota;
+ printf "<tr><td>admin:</td><td>%s</td>\n",$admin;
+ print "</table>\n";
+ &end_html;
}
# require authentification
sub require_akey {
my $id;
my $rid;
- my $action;
- $action = param("action");
- if ($action and $action eq 'logout') {
+ if ($action eq 'logout') {
+ if (($ENV{HTTP_COOKIE}||'') =~ /akey=(\w+)/) {
+ unlink "$akeydir/$1";
+ }
nvt_print(
"HTTP/1.1 301 Moved Permanently",
- "Location: /fac",
+ "Location: /$fac",
'Content-Length: 0',
"Set-Cookie: akey=; Max-Age=0; Discard",
''
$rid = slurp("$admin/@") or html_error($error,"no F*EX account for $admin");
chomp $rid;
- $id = param("id");
+ $id = $PARAM{"id"};
if ($id) {
# correct auth-ID?
}
pq(qq(
- '<form action="/fac" '
- ' method="post" '
- ' enctype="multipart/form-data">'
+ '<form action="/$fac" method="post" enctype="multipart/form-data">'
' auth-ID for <code>$admin</code>:'
' <input type="password" name="id" size="16" autocomplete="off">'
'</form>'
));
- exit;
+ &end_html;
}
}
}
+
# function for sending notification mails to an user
# required arguments: username, auth-id, message-type
sub notifyUser {
- http_die("not enough arguments in createUser.\n") unless (my ($user,$id) = @_);
- my $type = $_[2];
- my $message = 'A F*EX account has been created for you. Use';
+ my ($user,$id,$type) = @_;
+ my $url = $durl;
+ my $message = 'A F*EX account has been created for you. Use';
- if (defined($type) and $type eq "change-auth") {
- $message = 'New auth-ID for your F*EX account has been set. Use'
- }
+ http_die("not enough arguments in createUser") unless $id;
+ if ($type and $type eq "change-auth") {
+ $message = 'New auth-ID for your F*EX account has been set. Use'
+ }
- $user .= '@'.$mdomain if $mdomain and $user !~ /@/;
- open my $mail,'|-',$sendmail,'-f',$admin,$user,$bcc
- or http_die("cannot start sendmail - $!\n");
- pq($mail,qq(
- 'From: $admin'
- 'To: $user'
- 'Subject: your F*EX account on $hostname'
- 'X-Mailer: F*EX'
- ''
- '$message'
- ''
- '$ENV{PROTO}://$ENV{HTTP_HOST}/fup?from=$user'
- 'auth-ID: $id'
- ''
- 'See http://$ENV{HTTP_HOST}/index.html for more information about F*EX.'
- ''
- 'Questions? ==> F*EX admin: $admin'
- ));
- close $mail
- or http_die("cannot send notification e-mail (sendmail error $!)\n");
+ $user = normalize_user($user);
+ open my $mail,'|-',$sendmail,'-f',$admin,$user,$bcc
+ or http_die("cannot start sendmail - $!");
+ $url =~ s:/fop::;
+ pq($mail,qq(
+ 'From: $admin'
+ 'To: $user'
+ 'Subject: your F*EX account on $hostname'
+ 'X-Mailer: F*EX'
+ ''
+ '$message'
+ ''
+ '$url/fup?from=$user'
+ 'auth-ID: $id'
+ ''
+ 'See $url/index.html for more information about F*EX.'
+ ''
+ 'Questions? ==> F*EX admin: $admin'
+ ));
+ close $mail
+ or http_die("cannot send notification e-mail (sendmail error $!)");
}
+
# sort key is the (inverse) domain
# required arguments: list of usernames (e-mail addresses)
sub domainsort {
-# http_die("not enough arguments in domainsort.\n") unless (my @d = @_);
- my @d = @_;
- local $_;
-
- foreach (@d) {
- s/ //g;
- s/^/ /;
- s/\./,/ while /\..*@/;
- s/@/@./;
- $_ = join('.',reverse(split /\./));
- }
-
- @d = sort { lc $a cmp lc $b } @d;
-
- foreach (@d) {
- $_ = join('.',reverse(split /\./));
- s/,/./g;
- s/@\./@/;
- }
-
- return @d;
+# http_die("not enough arguments in domainsort") unless (my @d = @_);
+ my @d = @_;
+ local $_;
+
+ foreach (@d) {
+ s/\s//g;
+ s/\./,/ while /\..*@/;
+ s/@/@./;
+ $_ = join('.',reverse(split /\./));
+ }
+
+ @d = sort { lc $a cmp lc $b } @d;
+
+ foreach (@d) {
+ $_ = join('.',reverse(split /\./));
+ s/,/./g;
+ s/@\./@/;
+ }
+
+ return @d;
}
# function for creating a sorted list of all users
# required arguments: -
sub userList {
- my @u;
- my $d = '';
-
- foreach (domainsort(grep { s:/@:: } glob('*@*/@'))) {
- s/ //g;
- /@(.+)/;
- if ($1 ne $d) {
- push @u,"### $1 ###";
- }
- push @u,$_;
- $d = $1;
+ 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) {
+ push @list,"### $1 ###";
+ }
+ push @list,$_;
+ $domain = $1;
}
- return @u;
+ }
+
+ return @list;
}
my $file = shift;
print "<pre>\n";
- while (<$file>) {
- s/&/&/g;
- s/</</g;
- print or exit;
- }
+ while (<$file>) { print dehtml($_) }
print "\n</pre>\n";
}
-sub error {
- print join("\n",@_),"\n";
- print end_html();
- exit;
+sub h2 {
+ local $_ = shift;
+ chomp;
+ return "<h2>$_</h2>\n";
+}
+
+
+sub h3 {
+ local $_ = shift;
+ chomp;
+ return "<h3>$_</h3>\n";
+}
+
+
+sub end_html {
+ print "</body></html>\n";
+ exit;
+}
+
+
+sub dehtml {
+ local $_ = shift;
+ s/&/&/g;
+ s/</</g;
+ return $_;
}
# Author: Ulli Horlacher <framstag@rus.uni-stuttgart.de>
#
-use CGI qw(:standard);
-use CGI::Carp qw(fatalsToBrowser);
+BEGIN { ($ENV{PERLINIT}||'') =~ /(.+)/s and eval $1 }
+
use Fcntl qw(:flock);
use Digest::MD5 qw(md5_hex);
-$CGI::LIST_CONTEXT_WARN = 0;
-$CGI::LIST_CONTEXT_WARN = 0;
-
# add fex lib
($FEXLIB) = $ENV{FEXLIB} =~ /(.+)/;
die "$0: no $FEXLIB\n" unless -d $FEXLIB;
$user = $id = '';
# look for CGI parameters
-foreach my $v (param) {
- my $vv = param($v);
- debuglog("Param: $v=\"$vv\"");
+our %PARAM;
+&parse_parameters;
+foreach my $v (keys %PARAM) {
+ my $vv = $PARAM{$v};
+ # debuglog("Param: $v=\"$vv\"");
if ($v =~ /^akey$/i and $vv =~ /^(\w+)$/) {
$akey = $1;
} elsif ($v =~ /^(from|user)$/i) {
# Author: Ulli Horlacher <framstag@rus.uni-stuttgart.de>
#
-use CGI qw':standard';
-use CGI::Carp qw'fatalsToBrowser';
+BEGIN { ($ENV{PERLINIT}||'') =~ /(.+)/s and eval $1 }
+
use Fcntl qw':flock :seek';
use Cwd qw'abs_path';
use File::Basename;
our $error = 'F*EX download ERROR';
our $head = "$ENV{SERVER_NAME} F*EX download";
# import from fex.pp
-our ($spooldir,$tmpdir,$logdir,$skeydir,$dkeydir,$durl);
-our ($bs,$fop_auth,$timeout,$keep_default);
+our ($spooldir,$tmpdir,@logdir,$skeydir,$dkeydir,$durl);
+our ($bs,$fop_auth,$timeout,$keep_default,$nowarning);
our ($limited_download,$admin,$akey,$adlm,$amdl);
our (@file_link_dirs);
}
}
-my $log = "$logdir/fop.log";
+my $log = 'fop.log';
chdir $spooldir or die "$spooldir - $!\n";
$filename,$ENV{REMOTE_ADDR},isodate(time);
close $log;
}
- if (open $log,'>>',$log) {
- printf {$log}
- "%s [%s_%s] %s %s deleted\n",
- isodate(time),$$,$ENV{REQUESTCOUNT},$ra,encode_Q($file);
- close $log;
+ foreach my $logdir (@logdir) {
+ my $msg = sprintf "%s [%s_%s] %s %s deleted\n",
+ isodate(time),$$,$ENV{REQUESTCOUNT},$ra,encode_Q($file);
+ if (open $log,'>>',"$logdir/$log") {
+ print {$log} $msg;
+ close $log;
+ }
}
http_header('200 OK',"X-File: $file");
print html_header($head),
if (@anonymous_upload and ipin($ra,@anonymous_upload)) {
unlink "$dkeydir/$dkey" if $dkey;
if (rmrf($file)) {
- if (open $log,'>>',$log) {
- printf {$log}
- "%s [%s_%s] %s %s purged\n",
- isodate(time),$$,$ENV{REQUESTCOUNT},$ra,encode_Q($file);
- close $log;
+ foreach my $logdir (@logdir) {
+ my $msg = sprintf "%s [%s_%s] %s %s purged\n",
+ isodate(time),$$,$ENV{REQUESTCOUNT},$ra,encode_Q($file);
+ if (open $log,'>>',"$logdir/$log") {
+ print {$log} $msg;
+ close $log;
+ }
}
http_header('200 OK',"X-File: $file");
print html_header($head),
chomp;
if ($ra) {
# allow downloads from same ip
- $_ = '' if $ra eq $_;
+ $_ = '' if /\Q$ra/;
# allow downloads from sender ip
$_ = '' if (readlink("$file/ip")||'') eq $ra;
}
# another stupid IE bug-workaround
# http://drupal.org/node/163445
# http://support.microsoft.com/kb/323308
- if ($http_client =~ /MSIE/) {
+ if ($http_client =~ /MSIE/ and not $nowarning) {
# $type = 'application/x-msdownload';
if ($ignorewarning) {
$type .= "; filename=$filename";
# Author: Ulli Horlacher <framstag@rus.uni-stuttgart.de>
#
-use CGI qw(:standard);
-use CGI::Carp qw(fatalsToBrowser);
+BEGIN { ($ENV{PERLINIT}||'') =~ /(.+)/s and eval $1 }
+
use Fcntl qw(:flock);
use Digest::MD5 qw(md5_hex);
-$CGI::LIST_CONTEXT_WARN = 0;
-$CGI::LIST_CONTEXT_WARN = 0;
-
# add fex lib
($FEXLIB) = $ENV{FEXLIB} =~ /(.+)/;
die "$0: no $FEXLIB\n" unless -d $FEXLIB;
if ($qs =~ /ab=load/) { $ab = 'load' }
}
-# look for CGI POST parameters
-foreach my $v (param) {
- my $vv = param($v);
- debuglog("Param: $v=\"$vv\"");
+# look for CGI parameters
+our %PARAM;
+&parse_parameters;
+foreach my $v (keys %PARAM) {
+ my $vv = $PARAM{$v};
+ # debuglog("Param: $v=\"$vv\"");
if ($v =~ /^akey$/i) {
$akey = $1 if $vv =~ /^(\w+)$/;
next;
$v =~ /^notification$/i ? $notification = checkchars('parameter',$vv):
$v =~ /^disclaimer$/i ? $disclaimer = $vv:
$v =~ /^encryption$/i ? $encryption = checkchars('parameter',$vv):
- $v =~ /^pubkey$/i ? $pubkey = $vv:
+ $v =~ /^pubkey$/i ? $pubkey = $PARAM{$v}{data}:
$v =~ /^reminder$/i ? $reminder = checkchars('parameter',$vv):
$v =~ /^mime$/i ? $mime = checkchars('parameter',$vv):
$v =~ /^comment$/i ? $comment = decode_utf8(normalize($vv)):
$ESAC;
}
-$group = lc $group if $group and $group ne 'NEW';
+if ($group and $group ne 'NEW') {
+ $group = lc $group;
+ $group =~ s/[^\w\*%^+=:,.!-]/_/g;
+}
$group = '' if $nomail;
$user .= '@'.$mdomain if $mdomain and $user !~ /@/;
'<a href="/foc?akey=$akey">back to F*EX operation control</a>'
'</body></html>'
));
+ exit;
} else {
$ab =~ s/[\r<>]//g;
$ab =~ s/\s*$/\n/;
local $/;
local $_;
- open $gf,">$gf.pk" or http_die("cannot write $gf - $!\n");
- print {$gf} <$pubkey>;
- close $gf;
+ open $pk,">$gf.pk" or http_die("cannot write $gf.pk - $!\n");
+ print {$pk} $pubkey;
+ close $pk;
unlink $gf;
system "gpg --batch --no-default-keyring --keyring $gf --import".
"< $gf.pk >/dev/null 2>&1";
'$pk'
'</pre>'
'<p>'
- '<a href="javascript:history.back()">back</a>'
+ '<a href="javascript:history.back()">back</a>'
'</body></html>'
));
}
'<h3>E-mails to you will be sent not encrypted.</h3>'
'<p>'
'<a href="/foc?akey=$akey">back to F*EX operation control</a>'
- '</body></html>'
));
} elsif ($encryption eq 'CHANGE') {
pq(qq(
'<pre>'
'$g'
'</pre>'
- '<p><hr><p>'
- '(*) To extract and verify your GPG public key use:'
- '<pre>'
- 'gpg -a --export $user > pubkey.gpg'
- 'gpg < pubkey.gpg'
- '</pre>'
));
}
- print "</body></html>\n";
- exit;
+ pq(qq(
+ '<p><hr><p>'
+ '(*) To extract and verify your GPG public key use:'
+ '<pre>'
+ 'gpg -a --export $user > pubkey.gpg'
+ 'gpg < pubkey.gpg'
+ '</pre>'
+ ));
}
-
- &reexec;
+ print "</body></html>\n";
+ exit;
}
if ($user and $reminder eq 'yes') {
'<a href="/foc?akey=$akey">back to F*EX operation control</a>'
'</body></html>'
));
- exit;
+ &reexec;
}
# empty subuser list POST
-if (defined(param('ssid')) and $ssid =~ /^\s*$/) {
+if (defined($PARAM{'ssid'}) and $ssid =~ /^\s*$/) {
unlink "$user/\@SUBUSER";
pq(qq(
'<h2>All subusers deleted</h2>\n<ul>'
'<a href="/foc?akey=$akey">back to F*EX operation control</a>'
'</body></html>'
));
- exit;
+ &reexec;
}
# update sub-users
'<p>'
'<a href="/foc?akey=$akey">back to F*EX operation control</a>'
));
- print end_html();
+ print "</body></html>\n";
exit;
} else {
# no group members -> delete group file
' New group name: <input type="text" name="group"> (You MUST fill out this field!)'
' </font>'
));
+ $gm = $user.':'.randstring(8);
} else {
if (open $gf,'<',$gf) {
local $/;
# Sebastian Zaiser <szcode@arcor.de> (upload status)
#
+BEGIN { ($ENV{PERLINIT}||'') =~ /(.+)/s and eval $1 }
+
use Encode;
use Fcntl qw':flock :seek :mode';
use IO::Handle;
use Digest::MD5 qw'md5_hex';
-use CGI::Carp qw'fatalsToBrowser';
use Cwd qw'abs_path';
-use constant DS => 60*60*24;
-use constant M => 1024*1024;
-
# add fex lib
-die "$0: no \$FEXLIB\n" unless $ENV{FEXLIB};
(our $FEXLIB) = $ENV{FEXLIB} =~ /(.+)/;
-die "$0: no $FEXLIB\n" unless -d $FEXLIB;
$| = 1;
# import from fex.pp
our ($FEXHOME);
-our ($spooldir,$durl,$tmpdir,$logdir,$docdir,$hostname,$admin,$fra);
-our ($keep_default,$recipient_quota,$sender_quota);
+our ($spooldir,$durl,$tmpdir,@logdir,$logdir,$docdir,$hostname,$admin,$fra);
+our ($keep_default,$recipient_quota,$sender_quota,$fex_yourself);
our ($sendmail,$mdomain,$fop_auth,$mail_auth,$faillog);
our ($dkeydir,$ukeydir,$akeydir,$skeydir,$gkeydir,$xkeydir);
+our ($MB,$DS);
+our $RB; # read POST bytes (total)
our $akey = '';
our $dkey = '';
our $skey = '';
my $data;
my $boundary;
-my $rb = 0; # read bytes, totally
my $rid = ''; # real ID
my @header; # HTTP entity header
my $fileid; # file ID
my $muser; # main user fur sub or group user
# load common code, local config: $FEXLIB/fex.ph
-require "$FEXLIB/fex.pp" or die "$0: cannot load $FEXLIB/fex.pp - $!\n";
+require "$FEXLIB/fex.pp";
# load fup local config
our ($info_1,$info_2,$info_login);
$locale = $ENV{LOCALE} || 'english';
-foreach my $pl (
+foreach (
"/var/lib/fex/locale/$locale/lib/fup.pl",
"$FEXLIB/fup.pl",
) {
- if (-f $pl) {
- require $pl or die "$0: cannot load $FEXLIB/fup.pl - $!\n";
+ if (-f) {
+ require;
last;
}
}
chdir $spooldir or http_die("$spooldir - $!\n");
-my $log = "$logdir/fup.log";
+my $log = 'fup.log';
my $http_client = $ENV{HTTP_USER_AGENT} || '';
my $cl = $ENV{X_CONTENT_LENGTH} || $ENV{CONTENT_LENGTH} || 0;
$to = join(',',@to);
+if ($from eq $to and $fex_yourself =~ /^no|0$/i) {
+ http_die("fexing to yourself is not allowed");
+}
+
$uid = randstring(8) unless $uid; # upload ID
# user requests for forgotten ID
}
}
+# optional $auth_hook() in fup.pl
+if ($auth_hook and ($akey or $skey or $gkey) and $from and -d $from) {
+ &$auth_hook;
+}
+
# forward a copy of a file to another recipient
if ($akey and $dkey and $command eq 'FORWARD') {
my $file = untaint(readlink "$dkeydir/$dkey"||'');
next if $file =~ m:(.+?)/: and -l $1;
$size = -s "$file/data";
next unless $size;
- $size = int($size/M+0.5);
+ $size = int($size/$MB+0.5);
$filename = $comment = '';
my $rto = $file;
$rto =~ s:/.*::;
close $file;
}
my $rkeep = untaint(readlink "$file/keep"||$keep_default)
- - int((time-mtime("$file/filename"))/DS);
+ - int((time-mtime("$file/filename"))/$DS);
if ($comment =~ /NOMAIL/ or
(readlink "$to/\@NOTIFICATION"||'') =~ /^no/i) {
printf "%8s MB [%s d] %s/%s/%s\n",
next if $file =~ m:(.+?)/: and -l $1;
$size = -s "$file/data";
next unless $size;
- $size = int($size/M+0.5);
+ $size = int($size/$MB+0.5);
$filename = $comment = '';
my $rto = $file;
$rto =~ s:/.*::;
if ($dkey = readlink "$file/dkey") {
+ # die $file if -s "$file/data" and $file =~ /^$from/;
if ($rto ne $to) {
$to = $rto;
print "\nto $to :\n";
close $file;
}
my $rkeep = untaint(readlink "$file/keep"||$keep_default)
- - int((time-mtime("$file/filename"))/DS);
+ - int((time-mtime("$file/filename"))/$DS);
printf "%8s MB [%s d] <a href=\"%s\">%s</a>%s\n",
$size,
$rkeep,
$filename = $comment = '';
$size = -s "$file/data";
next unless $size;
- $size = int($size/M+0.5);
+ $size = int($size/$MB+0.5);
if ($dkey = readlink "$file/dkey") {
print "\nfrom $from :\n" unless $url;
$file =~ m:.*/(.+):;
close $file;
}
my $rkeep = untaint(readlink "$file/keep"||$keep_default)
- - int((time-mtime("$file/filename"))/DS);
+ - int((time-mtime("$file/filename"))/$DS);
printf "[<a href=\"/fup?akey=%s&dkey=%s&command=DELETE\">delete</a>] ",
$akey,$dkey;
printf "[<a href=\"/fup?akey=%s&dkey=%s&command=COPY\">forward</a>] ",
if ($command eq 'RECEIVEDLOG') {
http_die("illegal command \"$command\"") if $public or $anonymous;
- if (open my $fuplog,"$logdir/fup.log") {
+ if (open my $log,"$logdir/fup.log") {
http_header('200 OK');
- while (<$fuplog>) {
+ while (<$log>) {
next if /\sSTDFEX\s/;
if (/\d+$/) {
my @F = split;
if ($command eq 'SENDLOG') {
http_die("illegal command \"$command\"") if $public or $anonymous;
- if (open my $fuplog,"$logdir/fup.log") {
+ if (open my $log,"$logdir/fup.log") {
http_header('200 OK');
- while (<$fuplog>) {
+ while (<$log>) {
next if /\sSTDFEX\s/;
if (/(\S+\@\S+)/ and $1 eq $from) {
s/ \[[\d_]+\]//;
# check sender quota
($quota,$du) = check_sender_quota($muser||$from);
- if ($quota and $du+$cl/M > $quota) {
+ 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 ($quota and $du+$cl/M > $quota) {
+ if ($quota and $du+$cl/$MB > $quota) {
http_die("$to cannot receive files: is overquota");
}
}
# (= has a F*EX ID)
if (not $addto and $fop_auth and $id and $id eq $rid and $from and @to) {
my ($to_reg,$idf,$subuser);
- foreach (@to) {
- my $to = $_;
+ foreach my $to (my @loop = @to) {
$to =~ s/:\w+=.*//; # remove options from address
$to_reg = 0;
# full user?
}
}
- # save default locale for this user
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+)/) {
$locale = $1;
}
@ab = ("<option></option>");
# select menu from server address book
- if (open my $ab,'<',"$from/\@ADDRESS_BOOK") {
- while (<$ab>) {
+ if (open my $AB,'<',"$from/\@ADDRESS_BOOK") {
+ while (<$AB>) {
s/#.*//g;
if (/(\S+)[=\s]+(\S+@[\w.-]+\S*)/) {
$_ = "$1 <$2>";
push @ab,"<option>$_</option>";
}
}
- close $ab;
+ close $AB;
}
unless (@to) {
print "</pre><p>\n";
close $rr;
}
- pq(qq(
- ' <input type="submit" name="submit" value="check recipient(s) and continue">'
- ' or <input type="submit" name="fexyourself" value="fex yourself">'
- '</form>'
- '<p>'
- ));
+ print qq' <input type="submit" name="submit" value="check recipient(s) and continue">';
+ if ($fex_yourself =~ /^yes|1/i) {
+ print qq' or <input type="submit" name="fexyourself" value="fex yourself">'
+ }
+ print "\n</form>\n<p>\n";
if ($akey and -f "$from/\@" and not $captive ) {
pq(qq(
'<a href="/foc?akey=$akey">user config & operation control</a>'
if ($from and ($id or $okey)) {
$to = $group if $group;
present_locales($ENV{REQUEST_URI}) if $skey or $gkey or $okey;
+# " '$ENV{PROTO}://$ENV{HTTP_HOST}/$cgi?showstatus=$uid',"
pq(qq(
'<script type="text/javascript">'
' function showstatus() {'
' var file = document.forms["upload"].elements["file"].value;'
' if (file != "") {'
' window.open('
- " '$ENV{PROTO}://$ENV{HTTP_HOST}/$cgi?showstatus=$uid',"
+ " '/$cgi?showstatus=$uid',"
" 'fup_status',"
" 'width=700,height=500'"
' );'
? "<tr><td>sender quota (used):<td>$quota ($du) MB</tr>"
: '';
- $bwl = qq'<td><input type="text" name="bwlimit" size="8" value="$bwlimit"> kB/s';
+ $bwl = qq'<input type="text" name="bwlimit" size="8" value="$bwlimit"> kB/s';
if (@throttle) {
foreach (@throttle) {
if (/\[?(.+?)\]?:(\d+)$/) {
# throttle ip address?
if ($throttle =~ /^[\w:.-]+$/) {
if (ipin($ra,$throttle)) {
- $bwl = qq'<td><input type="hidden" name="bwlimit" value="$limit"> $limit kB/s';
+ $bwl = qq'<input type="hidden" name="bwlimit" value="$limit"> $limit kB/s';
last;
}
}
$throttle =~ quotemeta $throttle;
$throttle =~ s/\*/.*/g;
if ($from =~ /^$throttle$/i) {
- $bwl = qq'<td><input type="hidden" name="bwlimit" value="$limit"> $limit kB/s';
+ $bwl = qq'<input type="hidden" name="bwlimit" value="$limit"> $limit kB/s';
last;
}
}
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">';
my $ctr = my $ktr = '';
if ($nomail) {
- $ctr = qq'<td><input type="hidden" name="comment" value="$comment">'
- .qq'<em>no notification e-mail will be send</em>';
- $ktr = qq'<input type="text" name="keep" size="2" value="$keep"> days</tr>';
- $ktr = qq'$keep days<input type="hidden" name="keep" value="$keep"></tr>';
+ $ctr = qq'<em>no notification e-mail will be send</em>';
} else {
- $ctr = qq'<td><input type="text" name="comment" size="80" value="$comment">';
- $ktr = qq'$keep days<input type="hidden" name="keep" value="$keep"></tr>';
+ $ctr = qq'<input type="text" name="comment" size="80" value="$comment">';
}
if ($captive) {
- $ktr = qq'$keep days<input type="hidden" name="keep" value="$keep"></tr>';
+ $ktr = qq'$keep days<input type="hidden" name="keep" value="$keep">';
+ } else {
+ $ktr = qq'$keep days<input type="hidden" name="keep" value="$keep">';
}
-
pq(qq(
- ' <tr title="$adt"><td>autodelete:<td>$adt</tr>'
- ' <input type="hidden" name="autodelete" value="$autodelete">'
- ' <tr title="keep file max $keep days, then delete it"><td>keep:<td>'
- ' $ktr'
+ ' <tr><td>autodelete:'
+ ' <td>$adt'
+ ' </tr>'
+ ' <tr title="keep file max $keep days, then delete it"><td>keep:'
+ ' <td>$ktr'
+ ' </tr>'
' $quota'
' <tr title="optional, full speed if empty"><td>bandwith limit:'
- ' $bwl'
+ ' <td>$bwl'
' </tr>'
' <tr title="optional, will be included in notification e-mail"><td>comment:'
- ' $ctr'
+ ' <td>$ctr'
' </tr>'
- ' <tr title="If you want to send more than one file, then put them in a zip or tar archive">'
- ' <td>file:'
- ' <td><input type="file" name="file" size="80" value="$file" onchange="reportsize();">'
+ ' <tr title="If you want to send more than one file, then put them in a zip or tar archive"><td>file:'
+ ' <td><input type="file" name="file" size="80" value="$file" onchange="reportsize();">'
' </tr>'
' <tr><td>file size:<td id="filesize"></td></tr>'
' </table>'
}
# additional last check
-foreach $to (@to) {
- checkaddress($to) or
- http_die("<code>$to</code> is not a valid e-mail address");
+unless (@group or $gkey or $skey or $public or $okey) {
+ foreach $to (@to) {
+ 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
rename $upload,$save or http_die("cannot rename $upload to $save - $!\n");
# log dkey
- my $dlog = "$logdir/dkey.log";
- if (open $dlog,'>>',$dlog) {
- flock $dlog,LOCK_EX;
- seek $dlog,0,SEEK_END;
- printf {$dlog} "%s %s %s %s %s\n",
- isodate(time),$dkey{$to},$from,$to,$fkey;
- close $dlog;
- }
+ 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
print html_header($head);
if ($nostore) {
- printf "%s (%s MB) received\n",$file,$ndata/M;
+ 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*M ? sprintf "%s kB",int($ndata/1024):
- sprintf "%s MB",int($ndata/M);
+ $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>'
'Download URL for copy & paste:'
if (not $boring and not $seek) {
print "Ehh... $ndata <b>BYTES</b>?! You are kidding?<p>\n";
}
- } elsif ($ndata<2*M) {
+ } elsif ($ndata<2*$MB) {
$ndata = int($ndata/1024);
print "<code>$file</code> ($ndata kB) received and saved<p>\n";
if ($ndata<1024 and not ($boring or $seek)) {
"ever heard of MIME e-mail? ☺<p>\n";
}
} else {
- $ndata = int($ndata/M);
+ $ndata = int($ndata/$MB);
print "<code>$file</code> ($ndata MB) received and saved<p>\n";
}
print "<ul>\n";
}
if ($from) {
- $from .= '@'.$mdomain if $mdomain and $from !~ /@/;
- if ($from ne 'anonymous' and not checkaddress($from)) {
- http_die("<code>$from</code> is not a valid e-mail address");
+ unless ($skey or $gkey or $okey) {
+ $from .= '@'.$mdomain if $mdomain and $from !~ /@/;
+ if ($from ne 'anonymous' and not checkaddress($from)) {
+ http_die("<code>$from</code> is not a valid e-mail address");
+ }
}
$from = untaint($from);
}
# look for recipient's options and eliminate dupes
%to = ();
- foreach (@to) {
- my $to = $_;
+ foreach my $to (my @loop = @to) {
# address book alias?
- if ($ab{$to}) {
- foreach (@{$ab{$to}}) {
- my $address = $_;
+ if ($to !~ /@/ and $ab{$to}) {
+ foreach my $address (my @loop = @{$ab{$to}}) {
$address .= '@'.$mdomain if $mdomain and $address !~ /@/;
$to{$address} = $address; # ignore dupes
if ($specific{'autodelete'}) {
$autodelete{$address} = readlink "$address/\@AUTODELETE"
|| $autodelete;
}
- if ($_ = readlink "$address/\@LOCALE") {
- $locale{$address} = $_;
+ if (my $locale = readlink "$address/\@LOCALE") {
+ $locale{$address} = $locale;
} elsif ($locale{$to}) {
$locale{$address} = $locale{$to};
} else {
http_die("You cannot send to more than one group") if @to > 1;
http_die("Group <code>$to</code> does not exist") unless -f "$from/\@GROUP/$1";
} else {
- $to .= '@'.$mdomain if $mdomain and $to !~ /@/;
- if (checkaddress($to)) {
+ if ($skey or $gkey or $okey or checkaddress($to)) {
+ $to .= '@'.$mdomain if $mdomain and $to !~ /@/;
$to{$to} = untaint($to);
} else {
http_die("<code>$to</code> is not a valid e-mail address");
"$filed/speed",
"$filed/replyto",
"$filed/useragent",
+ "$filed/uurl",
"$filed/comment",
"$filed/notify";
unlink "$filed/size" unless $seek;
close $fh;
if ($::filesize > 0 or $cl > 0) {
if ($::filesize > 0) { $filesize = $fpsize || $::filesize }
- else { $filesize = $cl-$rb-$ebl+$seek }
+ else { $filesize = $cl-$RB-$ebl+$seek }
# new file
unless ($seek) {
if ($::filesize > 0) {
}
}
- $autodelete{$to} = $autodelete unless $autodelete{$to};
- if ($autodelete{$to} =~ /^(DELAY|NO|\d+)$/i) {
- mksymlink("$filed/autodelete",$autodelete{$to});
+ if ($from eq "@to") {
+ # special "fex yourself"
+ mksymlink("$filed/autodelete",'NO');
+ } else {
+ $autodelete{$to} = $autodelete unless $autodelete{$to};
+ if ($autodelete{$to} =~ /^(DELAY|NO|\d+)$/i) {
+ mksymlink("$filed/autodelete",$autodelete{$to});
+ }
}
if (my $keep = $keep{$to} || $::keep) {
}
mksymlink("$filed/id",$fileid) if $fileid;
mksymlink("$filed/ip",$ra) if $ra;
+ if (my $uurl = $ENV{REQUEST_URL}) {
+ mksymlink("$filed/uurl",$uurl);
+ }
if ($http_client and open $http_client,'>',"$filed/useragent") {
print {$http_client} $http_client,"\n";
close $http_client;
if ($cl == -1) {
alarm($timeout*2);
# read until EOF, including MIME end boundary
+ # note: cannot use sysread because of previous buffered read!
while ($n = read(STDIN,$_,$bs)) {
- $rb += $n;
+ $RB += $n;
$fb += $n;
syswrite $upload,$_ unless $nostore;
alarm($timeout*2);
if ($fpsize) {
debuglog(sprintf("still awaiting %d+%d = %d bytes",
$fpsize,$ebl,$fpsize+$ebl));
- $cl = $rb+$fpsize+$ebl; # recalculate CONTENT_LENGTH
+ $cl = $RB+$fpsize+$ebl; # recalculate CONTENT_LENGTH
} else {
if ($::filesize) {
- $cl = $rb+$::filesize+$ebl; # recalculate CONTENT_LENGTH
+ $cl = $RB+$::filesize+$ebl; # recalculate CONTENT_LENGTH
}
debuglog(sprintf("still awaiting %d-%d = %d bytes",
- $cl,$rb,$cl-$rb));
+ $cl,$RB,$cl-$RB));
}
# read until end boundary, not EOF
- while ($rb < $cl-$ebl) {
- $b = $cl-$ebl-$rb;
+ while ($RB < $cl-$ebl) {
+ $b = $cl-$ebl-$RB;
$b = $bs if $b > $bs;
# max wait for 1 kB/s, but at least 10 s
# $timeout = $b/1024;
# $timeout = 10 if $timeout < 10;
alarm($timeout);
if ($n = read(STDIN,$_,$b)) {
- $rb += $n;
+ $RB += $n;
$fb += $n;
# syswrite is much faster than print
syswrite $upload,$_ unless $nostore;
if ($bwlimit) {
alarm(0);
$tt = (time-$t0) || 1;
- while ($rb/$tt/1024 > $bwlimit) {
+ while ($RB/$tt/1024 > $bwlimit) {
sleep 1;
$tt = time-$t0;
}
http_die("found no MIME end boundary in upload ($_)");
}
}
- $rb += $ebl;
+ $RB += $ebl;
$ndata = untaint($fb);
}
# truncate $upload,$ndata+$uss if -s $upload > $ndata+$uss;
# incomplete?
- if ($cl != $rb) {
+ if ($cl != $RB) {
fuplog($to,$fkey,$ndata,'(aborted)');
if ($fpsize) {
- http_die("read $rb bytes, but Content-Length announces $fpsize bytes");
+ http_die("read $RB bytes, but Content-Length announces $fpsize bytes");
} else {
- http_die("read $rb bytes, but CONTENT_LENGTH announces $cl bytes");
+ http_die("read $RB bytes, but CONTENT_LENGTH announces $cl bytes");
}
}
my @users = @_;
my @ua;
- foreach (@users) {
- my $u = $_;
+ foreach my $u (my @loop = @users) {
if ($u =~ /^anonymous(_\d+)?$/) {
$u = "$u\@$hostname";
}
}
# collect addresses
- foreach (@to) {
- my $to = $_;
+ foreach my $to (my @loop = @to) {
if ($ab{$to}) {
foreach my $address (@{$ab{$to}}) {
$to{$address} = $address;
@to = keys %to;
- foreach (@to) {
- my $to = $_;
+ foreach my $to (my @loop = @to) {
$to =~ s/:\w+=.*//; # remove options from address
$nfile = $file;
$nfile =~ s:.*?/:$to/:;
}
-# read one line from STDIN (net socket) and assign it to $_
-# returns number of read bytes
-sub nvt_read {
- my $len = 0;
-
- if (defined ($_ = <STDIN>)) {
- debuglog($_);
- $len = length;
- $rb += $len;
- s/\r?\n//;
- }
- return $len;
-}
-
-
-# read forward to given pattern
-sub nvt_skip_to {
- my $pattern = shift;
-
- while (&nvt_read) { return if /$pattern/ }
-}
-
-
# set parameter variables
sub setparam {
my ($v,$vv) = @_;
$from = normalize_email($vv);
$from = untaint(expand($from));
checkchars('from address',$from);
- checkaddress($from) or http_die("FROM $from is no legal e-mail address");
+ # maybe FROM=SUBUSER !
+ # checkaddress($from) or http_die("FROM $from is no legal e-mail address");
} elsif ($v eq 'REPLYTO') {
$replyto = normalize_email($vv);
checkchars('replyto address',$replyto);
while (<$df>) {
if (/^.+?\s+\d+\s+\d+\s+(\d+)/ and $req/1024 > $1) {
$free = int($1/1024);
- $uprq = int($req/M);
+ $uprq = int($req/$MB);
if (not $nomail and open P,"|$sendmail -t") {
pq(P,qq(
'From: $admin'
$msg =~ s/\n/ /g;
$msg =~ s/\s+$//;
-
- if (open $log,'>>',$log) {
- flock $log,LOCK_EX;
- seek $log,0,SEEK_END;
- printf {$log} "%s [%s_%s] %s (%s) %s\n",
- isodate(time),$$,$ENV{REQUESTCOUNT},$from,$fra,$msg;
- close $log;
- }
+ $msg = sprintf "%s [%s_%s] %s (%s) %s\n",
+ isodate(time),$$,$ENV{REQUESTCOUNT},$from,$fra,$msg;
+ writelog($log,$msg);
}
$msg = @_ ? "@_" : '???';
$msg =~ s/\n/ /g;
$msg =~ s/\s+$//;
+ $msg = sprintf "%s %s (%s) %s %s caught SIGNAL %s %s\n",
+ isodate(time),
+ $from||'-',
+ $fra||'-',
+ $to||'-',
+ encode_Q($file||'-'),
+ $msg,
+ $RB?"(after $RB bytes)":"";
+
+ writelog($log,$msg);
- if (open $log,'>>',$log) {
- printf {$log}
- "%s %s (%s) %s %s caught SIGNAL %s %s\n",
- isodate(time),
- $from||'-',
- $fra||'-',
- $to||'-',
- encode_Q($file||'-'),
- $msg,
- $rb?"(after $rb bytes)":"";
- close $log;
- }
if ($sig eq 'DIE') {
shift;
die "$msg\n";
}
-sub mtime {
- my @s = lstat shift;
- return @s ? $s[9] : undef;
-}
-
-
sub present_locales {
my $url = shift;
my @locales = @::locales; # from fex.ph
if (@locales > 1) {
print "<h3>";
- foreach (@locales) {
- $locale = $_;
+ foreach my $locale (my @loop = @locales) {
if (-x "$locale/cgi-bin/fup") {
$lang = "$locale/lang.html";
$locale =~ s:.*/::;
# Author: Ulli Horlacher <framstag@rus.uni-stuttgart.de>
#
-use CGI qw(:standard);
-use CGI::Carp qw(fatalsToBrowser);
-use Fcntl qw(:flock :seek :mode);
+BEGIN { ($ENV{PERLINIT}||'') =~ /(.+)/s and eval $1 }
-$CGI::LIST_CONTEXT_WARN = 0;
-$CGI::LIST_CONTEXT_WARN = 0;
+use Fcntl qw(:flock :seek :mode);
# import from fex.ph
our (@local_hosts,@local_domains,@local_rhosts,@local_rdomains);
our ($usage_conditions);
# import from fex.pp
-our ($mdomain,$logdir,$spooldir,$fra,$hostname,$sendmail,$admin,$bcc);
+our ($mdomain,@logdir,$spooldir,$fra,$hostname,$sendmail,$admin,$bcc);
our $error = "F*EX user registration ERROR";
# load common code, local config: $HOME/lib/fex.ph
require "$FEXLIB/fex.pp" or die "$0: cannot load $FEXLIB/fex.pp - $!\n";
-my $log = "$logdir/fur.log";
+my $log = 'fur.log';
my $head = "$ENV{SERVER_NAME} F*EX user registration";
chdir $spooldir or die "$spooldir - $!\n";
}
# look for CGI parameters
-foreach my $v (param) {
- my $vv = despace(param($v));
- debuglog("Param: $v=\"$vv\"");
+our %PARAM;
+&parse_parameters;
+foreach my $v (keys %PARAM) {
+ my $vv = despace($PARAM{$v});
+ # debuglog("Param: $v=\"$vv\"");
$CASE =
$v =~ /^user$/i ? $user = normalize_address($vv):
$v =~ /^exuser$/i ? $exuser = normalize_address($vv):
http_header("200 OK",'Content-Type: text/plain');
print "$ENV{PROTO}://$ENV{HTTP_HOST}/fup?from=$user&ID=$id\n";
furlog("direct: account $user created");
- if ($bcc and open my $mail,"|$sendmail '$bcc' 2>>$log") {
+ if ($bcc and open my $mail,"|$sendmail '$bcc' 2>>$logdir[0]/$log") {
pq($mail,qq(
'From: fex'
'To: $bcc'
$msg =~ s/\n/ /g;
$msg =~ s/\s+$//;
+ $msg = sprintf "%s [%s_%s] %s %s\n",
+ isodate(time),$$,$ENV{REQUESTCOUNT},$fra,$msg;
- if (open $log,'>>',$log) {
- flock $log,LOCK_EX;
- seek $log,0,SEEK_END;
- printf {$log} "%s [%s_%s] %s %s\n",
- isodate(time),$$,$ENV{REQUESTCOUNT},$fra,$msg;
- close $log;
- }
+ writelog($log,$msg);
}
sub normalize_address {
# Author: Ulli Horlacher <framstag@rus.uni-stuttgart.de>
#
-use CGI::Carp qw(fatalsToBrowser);
+BEGIN { ($ENV{PERLINIT}||'') =~ /(.+)/s and eval $1 }
# add fex lib
(our $FEXLIB) = $ENV{FEXLIB} =~ /(.+)/;
$to = normalize_email($vv);
}
}
-
-
-# read one line from STDIN (net socket) and assign it to $_
-# returns number of read bytes
-sub nvt_read {
- my $len = 0;
-
- if (defined ($_ = <STDIN>)) {
- debuglog($_);
- $len = length;
- s/\r?\n//;
- }
- return $len;
-}
# Author: Ulli Horlacher <framstag@rus.uni-stuttgart.de>
#
+BEGIN { ($ENV{PERLINIT}||'') =~ /(.+)/s and eval $1 }
+
use Fcntl qw(:flock :seek :mode);
-use CGI qw(:standard);
-use CGI::Carp qw(fatalsToBrowser);
-use Fcntl qw(:flock);
use Digest::MD5 qw(md5_hex);
# add fex lib
(our $FEXLIB) = $ENV{FEXLIB} =~ /(.+)/;
die "$0: no $FEXLIB\n" unless -d $FEXLIB;
-our ($keep_default,$dkeydir,$akeydir,$mdomain,$logdir,$fra);
+our ($keep_default,$dkeydir,$akeydir,$mdomain,@logdir,$fra);
our $akey = '';
# load common code, local config : $HOME/lib/fex.ph
chdir $spooldir or die "$spooldir - $!\n";
-my $log = "$logdir/rup.log";
-
$from = $id = $oto = $nto = $file = '';
# look for CGI parameters
-foreach my $v (param) {
- $vv = param($v);
+our %PARAM;
+&parse_parameters;
+foreach my $v (keys %PARAM) {
+ my $vv = $PARAM{$v};
$vv =~ s/[<>\'\`\"\000-\037]//g;
if ($v =~ /^akey$/i and $vv =~ /^(\w+)$/) {
$akey = $1;
unlink "$nto/$from/$fkey/notify";
unlink "$nto/$from/$fkey/error";
unlink "$nto/$from/$fkey/download";
- if (slurp("$oto/$from/$fkey/$comment") =~ 'NOMAIL') {
+ if (slurp("$oto/$from/$fkey/comment")||'' =~ /NOMAIL/) {
unlink "$nto/$from/$fkey/comment";
}
$dkey = randstring(8);
$msg =~ s/\n/ /g;
$msg =~ s/\s+$//;
-
- if (open $log,'>>',$log) {
- flock $log,LOCK_EX;
- seek $log,0,SEEK_END;
- printf {$log} "%s [%s_%s] (%s) %s\n",
- isodate(time),$$,$ENV{REQUESTCOUNT},$fra,$msg;
- close $log;
+ $msg = sprintf "%s [%s_%s] (%s) %s\n",
+ isodate(time),$$,$ENV{REQUESTCOUNT},$fra,$msg;
+
+ foreach my $log (@logdir) {
+ if (open $log,'>>',"$log/rup.log") {
+ flock $log,LOCK_EX;
+ seek $log,0,SEEK_END;
+ printf {$log} $msg;
+ close $log;
+ }
}
}
$| = 1;
# import from fex.pp
-our ($tmpdir,$logdir,$timeout,$fra,$bs);
+our ($tmpdir,@logdir,$timeout,$fra,$bs);
# load common code, local config: $HOME/lib/fex.ph
require "$FEXLIB/fex.pp" or die "$0: cannot load $FEXLIB/fex.pp - $!\n";
chdir $spooldir or error(500,"$spooldir - $!");
-my $debuglog = "$tmpdir/sex.log";
+# my $debuglog = "$tmpdir/sex.log";
my $ra = $ENV{REMOTE_ADDR}||0;
$fra .= '/'.$ENV{HTTP_X_FORWARDED_FOR} if $ENV{HTTP_X_FORWARDED_FOR};
$timeout *= 10;
}
sub sexlog {
- if (open my $log,'>>',"$logdir/sex.log") {
- flock $log,LOCK_EX;
- seek $log,0,SEEK_END;
- printf {$log} "%s [%s_%s] %s (%s) %s\n",
- isodate(time),$$,$ENV{REQUESTCOUNT},$user,$fra,"@_";
- close $log;
+ 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;
+ seek $log,0,SEEK_END;
+ printf {$log} $msg;
+ close $log;
+ }
}
}
sub sigexit {
my ($sig) = @_;
- if (open my $log,'>>',"$logdir/sex.log") {
- printf {$log} "%s %s (%s) caught SIGNAL %s\n",
- isodate(time),$user||'-',$fra||'-',"@_";
- close $log;
+ 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;
+ seek $log,0,SEEK_END;
+ printf {$log} $msg;
+ close $log;
+ }
}
if ($sig eq 'DIE') {
shift;
+2015-06-10 fexsrv: fixed warning with https and SIGCHLD
+2015-05-16 fexsrv/dop: added active and passive redirect support
+2015-05-12 fuc: fixed bug undefined subroutine end_html
+2015-04-30 fex_cleanup: fixed bug runtime error with mtime (symlinks)
+2015-04-24 fixed bug wrong quota calculation for uploads
+2015-04-23 fex_cleanup: follow symbolic links if they contain a /
+2015-04-22 fexsend: 60 s timeout for file transfer socket (sys)write
+2015-04-22 fup: fixed bug fexsend hangs with SKEY or GKEY recipient URL
+2015-04-02 fixed several severe bugs in install script
+2015-04-01 group name may only contain (some) ASCII characters
+2015-03-29 fop: fixed bug no more download from same (recipient) ip
+2015-03-18 added local URL redirect service
+2015-03-08 fup: fixed bug uninitialized value $address if alias address is
+ used twice
+2015-03-07 disallow email addresses starting with "-"
+ fex_cleanup: do not terminate on sendmail error
+2015-03-01 no file name in email subject if notification is encrypted
+2015-02-28 fexsrv: restrict HTTP header to 64 kB ($bs) and POST (not fup) to
+ 128 MB
+2015-02-27 no more usage of CGI.pm at all
+2015-02-25 fup: added $auth_hook
+2015-02-24 fac(CGI): no more usage of CGI.pm
+2015-02-18 fuc: fixed bug no gpg usage help
+2015-02-17 fexsend: check SSLeay version and adjust SSL_verify_mode
+2015-02-16 fup: save upload URL in spool
+ in notification+reminder emails use same protocol for download URL
+ like in upload
+2015-02-08 rup: fixed various bugs (not working at all)
+2015-02-05 fup: fixed bug cannot send to groups
+2015-01-27 fup: set autodelete=no if sender == recipient
+ (use case: provide download link for mailing lists)
+ new fex.ph config variable $fex_yourself (default yes)
+2015-01-25 fexsend: fixed bug cannot forward a file name with "&"
+2015-01-21 main user is always first member of a new group
+ substituted CGI::Carp with web error handler via PERLINIT environment
2015-01-17 new fex.ph config variable $mail_authid (default yes)
2015-01-16 fixed bug no notfication for still existing file (overwrite)
2015-01-15 fixed bug no locale reminder notfication
2012-11-07 fixed security bug restricted user can redirect files
2012-11-06 fup: show download-URL after upload if sender = recipient
fup,fop,fac: added user up/download IP restriction by admin
-2012-11-05 added HTTP Strict Transport Security if $force_https is enabled
+2012-11-05 added HTTP Strict Transport Security (HSTS) if $force_https is set
fixed bug afex accessible via xkey from everywhere
2012-11-02 fup: fixed bug one time upload URL gives "no recipient specified"
error
fex.pp: umask 077
2008-03-23 fup: fixed bug in using multiple recipients
2008-03-22 first public release
+2007-01-27 first file fexed via fex.rus.uni-stuttgart.de
2006-11-?? first code
# execute this as root!
+# Redhat : stunnel-4 does not work! you need to install stunnel-5
+
mkdir /home/fex/etc
cd /home/fex/etc/
A GKEY is made of md5_hex("$mainuser:$groupname:$groupuser:$groupuserid")
Note: the AKEY, SKEY and GKEY always can be stolen by a network sniffer!
-If you need true security, then you have to use https (SSL) instead of
-http!
+If you need true security, then you have to use https instead of http!
After download the file will be deleted after a grace time of 1 minute.
This grace time allows a recipient to get the file again if he had
$to/$from/$file/filename original file name
$to/$from/$file/size original file size
$to/$from/$file/useragent HTTP header User-Agent
+ $to/$from/$file/uurl upload URL
$to/$from/$file/data file data after complete upload
$to/$from/$file/keep keep time (autoexpire) in days
$to/$from/$file/autodelete autodelete option: YES NO or DELAY
-New release on http://fex.rus.uni-stuttgart.de/fex.html
-
+New release on http://fex.belwue.de/fex.html
+
Important changes:
-- workaround for upload problem with chaching proxies
+- moved to new distribution site fex.belwue.de
+
+- autodelete=no if sender == recipient
+
+- no file name in email subject if notification is encrypted
+
+- added active and passive redirect support for standard HTTP documents
-- some small bug fixes
+- fixed various bugs
-fex-20150120
+fex-20150615
--- /dev/null
+<html>
+<head><title>F*EX FAQ</title></head>
+<body>
+
+## <pre>
+## << while (($v,$vv) = each %ENV) { print "$v = $vv\n" } >>
+## </pre>
+
+<< require "./faq.pl" or print $! >>
+
+</body>
+</html>
F*EX needs port 80/tcp for HTTP and optionally port 443/tcp for HTTPS.
Q: What is the difference between all these user types (full, sub, group, external, ...)?
-A: See http://fex.rus.uni-stuttgart.de/users.html
+A: See http://fex.belwue.de/users.html
Q: How can I integrate F*EX in the existing user management at my site?
A: F*EX has several authentification modules: local, RADIUS, LDAP, mailman and POP.
Q: I need more security! How can I enable (https) encryption?
A: Read doc/SSL and also look for "fop_auth" in doc/concept
- (doc is a local directory in your installation or online http://fex.rus.uni-stuttgart.de/doc/)
- For email encryption see http://fex.rus.uni-stuttgart.de/gpg.html
+ (doc is a local directory in your installation or online http://fex.belwue.de/doc/)
+ For email encryption see http://fex.belwue.de/gpg.html
Q: I need a corporate identity look. How can I configure F*EX in this way?
A: * See variable @H1_extra in /home/fex/lib/fex.ph and you can add HTML code to /home/fex/htdocs/header.html
Q: F*EX is too complicated for my tie users. I need a simplified upload form.
A: See /home/fex/htdocs/fup_template.html and /home/fex/htdocs/sup.html
- or use public upload, see http://fex.rus.uni-stuttgart.de/usecases/foreign.html
+ or use public upload, see http://fex.belwue.de/usecases/foreign.html
Q: F*EX is still too complicated! I need something more simplified.
-A: Try http://fex.rus.uni-stuttgart.de/fstools/woos.html or use F*EX mail (see next question).
+A: Try http://fex.belwue.de/fstools/woos.html or use F*EX mail (see next question).
Q: Can I integrate F*EX in my users MUAs (thunderbird, outlook, etc)?
-A: See http://fex.rus.uni-stuttgart.de/usecases/BIGMAIL.html
+A: See http://fex.belwue.de/usecases/BIGMAIL.html
Q: Can I get a localized version in my native languange?
A: With your help, yes. Please contact <framstag@rus.uni-stuttgart.de>
Q: What is so special about F*EX?
-A: See feature list http://fex.rus.uni-stuttgart.de/features.html
- and use cases http://fex.rus.uni-stuttgart.de/usecases/
+A: See feature list http://fex.belwue.de/features.html
+ and use cases http://fex.belwue.de/usecases/
Q: Why not use one of the commercial services like DropLoad, ALLPeers, YouSendIt, etc?
A: * They have a file size limit of 2 GB or even less.
Q: Why a camel as the logo?
A: The logo was inspired by the Perl camel, but it is based on a Steiff plush camel, which rides with us on our racing tandem.
The logo was drawn by my stoker Beate.
- http://fex.rus.uni-stuttgart.de/Vortrag/tosa.html
+ http://fex.belwue.de/Vortrag/tosa.html
Q: What do I need to install F*EX?
A: A UNIX or Windows server with a DNS entry, smtp for outgoing email and one open and free incoming tcp port.
Q: Can I run F*EX on Windows?
A: On client side all operating systems are supported, even Windows.
- If you want to run a F*EX server on Windows, then see http://fex.rus.uni-stuttgart.de/fexwix.html
+ If you want to run a F*EX server on Windows, then see http://fex.belwue.de/fexwix.html
Q: Where can I get the F*EX sources?
-A: F*EX server for UNIX: http://fex.rus.uni-stuttgart.de/fex.html
+A: F*EX server for UNIX: http://fex.belwue.de/fex.html
Q: I do not want to install a F*EX server of my own, but where can I use it?
A: Contact <fex@nepustil.net> http://www.nepustil.net/ for F*EX hosting.
Q: The F*EX server is all in Perl?! Isn't Perl too slow for this job?
-A: fex.rus.uni-stuttgart.de runs on an office PC and F*EX is able to handle uploads with more than 300 MB/s.
+A: fex.belwue.de runs on a PC and F*EX is able to handle uploads with more than 300 MB/s.
Try this with an ordinary webserver like Apache!
Q: Which licence does F*EX have? And why?
A: Perl Artistic free software with a special anti-military clause:
- http://fex.rus.uni-stuttgart.de/doc/Licence
+ http://fex.belwue.de/doc/Licence
"I want peace on earth and goodwill towards men"
http://www.youtube.com/watch?v=JHU0HinVhYc
A: The auth-ID is an internal identification which authentificates the user. It will be first generated by the admin or the automatic registration process and can later be modified by you, the user. Think of some kind of a low security password.
Q: What is the difference between all these user types (full, sub, group, external, ...)?
-A: See http://fex.rus.uni-stuttgart.de/users.html
+A: See http://fex.belwue.de/users.html
Q: I have uploaded a HUGE file but misspelled my recipient's address. Now I have got an error bounce email. Must I re-upload the HUGE file?
A: No, it is not necessary. You can redirect the file with "user config & operation control"
* send several files or even whole directory trees at once
* stream files
* transfer files via command line
- * use an Internet clipboard http://fex.rus.uni-stuttgart.de/usecases/xx.html
+ * use an Internet clipboard http://fex.belwue.de/usecases/xx.html
* do much more :-)
Q: How can I upload several files at once?
Q: I need to send a file bigger than my quota allows. What can I do?
A: Simply ask $SERVER_ADMIN$ to raise your quota.
+ If you want to send a REALLY big file, you also have to tell the recipient's address because his quota also has to be raised.
Q: Why is the upload status window empty and I cannot see the progress bar?
A: Most probably you are using a (enforced) web proxy, which cannot handle dynamic HTML pages.
Q: Can I integrate F*EX in my mail program (thunderbird, outlook, etc)?
A: Yes, if your mail admin has set up a "fexmail" smtp relay.
- http://fex.rus.uni-stuttgart.de/usecases/BIGMAIL.html
+ http://fex.belwue.de/usecases/BIGMAIL.html
Q: Can I use a download manager/accelerator?
A: Generally, no, because they suck: they are not RFC compliant and produce a LOT of unnecessary server load.
Q: Sending as a F*EX user is easy, but how to receive files from others, outside?
A: Register them as your subusers, create a F*EX group or a one-time upload key with "user config & operation control"
- See also http://fex.rus.uni-stuttgart.de/usecases/foreign.html
+ See also http://fex.belwue.de/usecases/foreign.html
Q: Sometimes I can download a file more than once, especially when I repeat it quickly. Is the autodelete feature buggy?
A: The F*EX server has a grace time of 1 minute after first sucessfully download in which the file is still available. This is necessary because of some stupid "download managers" which request the file several times at once. Otherwise they would report an error to the user.
With email you also have no acknowledgement of receipt.
Q: Can I have encrypted emails?
-A: See http://fex.rus.uni-stuttgart.de/gpg.html
+A: See http://fex.belwue.de/gpg.html
Q: I cannot download files with Internet Explorer, it tells me "Cannot open Internet site". What shall I do?
A: Use Firefox or any other Internet-compatible web browser, that Internet Explorer is not.
our ($fexhome,$idf,$tmpdir,$windoof,$useragent);
our ($xv,%autoview);
our $bs = 2**16; # blocksize for tcp-reading and writing file
-our $version = 20150120;
+our $version = 20150615;
our $CTYPE = 'ISO-8859-1';
our $fexsend = $ENV{FEXSEND} || 'fexsend';
exit;
}
-# set SSL/TLS options
-$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_ca_file)
-) {
- my $env = uc($opt);
- $env =~ s/_//g;
- $SSL{$opt} = $ENV{$env} if defined($ENV{$env});
-}
-
-if ($SSL{SSL_verify_mode}) {
- &search_ca;
- unless ($SSL{SSL_ca_path} or $SSL{SSL_ca_file}) {
- die "$0: \$SSLVERIFYMODE, but not valid \$SSLCAPATH or \$SSLCAFILE\n";
- }
-} elsif (defined($SSL{SSL_verify_mode})) {
- # user has set SSLVERIFY=0 !
-} else {
- &search_ca;
- $SSL{SSL_verify_mode} = 1 if $SSL{SSL_ca_path} or $SSL{SSL_ca_file};
-}
-
-sub search_ca {
- local $_;
- return if $SSL{SSL_ca_file} or $SSL{SSL_ca_path};
- foreach (qw(/etc/ssl/certs/ca-certificates.crt)) {
- if (-f) {
- $SSL{SSL_ca_file} = $_;
- return;
- }
- }
- foreach (qw(/etc/ssl/certs /etc/pki/tls/certs)) {
- if (-f) {
- $SSL{SSL_ca_path} = $_;
- return;
- }
- }
-}
+&get_ssl_env;
my $ffl = "$tmpdir/fexget"; # F*EX files list (cache)
our ($FEXID,$FEXXX,$HOME);
our (%alias);
our $chunksize = 0;
-our $version = 20150120;
+our $version = 20150615;
our $_0 = $0;
our $DEBUG;
$0 -b # other\@address
Where # is the file number.
+You can list an uploaded file in more detail with
+ $0 -l #
+Where # is the file number.
+
If you want to modify the keep time, comment or auto-delete behaviour of an
already uploaded file then you first have to query the file number with:
$0 -l
if ($fexcgi =~ /\?/) {
$from = $1 if $fexcgi =~ /\bfrom=(.+?)(&|$)/i;
$id = $1 if $fexcgi =~ /\bid=(.+?)(&|$)/i;
- $skey = $1 if $fexcgi =~ /\bskey=(.+?)(&|$)/i;
- $gkey = $1 if $fexcgi =~ /\bgkey=(.+?)(&|$)/i;
+ # $skey = $1 if $fexcgi =~ /\bskey=(.+?)(&|$)/i;
+ # $gkey = $1 if $fexcgi =~ /\bgkey=(.+?)(&|$)/i;
+ die "$0: cannot use GKEY URL in ID file\n" if $fexcgi =~ /gkey=/i;
+ die "$0: cannot use SKEY URL in ID file\n" if $fexcgi =~ /skey=/i;
$fexcgi =~ s/\?.*//;
}
unless ($fexcgi =~ /^[_:=\w\-\.\/\@\%]+$/) {
else { $dkey = '' }
# $_ = encode_utf8($_);
s/<.*?>//g;
+ s/&/&/g;
+ s/"/\"/g;
+ s/</</g;
if (/^(to .* :)/) {
print "\n$1\n";
print {$fexlist} "\n$1\n";
my @files = ();
my ($data,$aname,$alias);
my (@r,$r);
- my $ma = $HOME.'/.mutt/aliases';
my $t0 = time;
my $transferfile;
my @transferfiles;
# $to = $AB{$to};
}
# look for mutt aliases
- elsif ($to !~ /@/ and $to ne $from and open $ma,$ma) {
- $alias = $to;
- while (<$ma>) {
- if (/^alias \Q$to\E\s/i) {
- chomp;
- s/\s*#.*//;
- s/\(.*?\)//;
- s/\s+$//;
- s/.*\s+//;
- s/[<>]//g;
- if (/,/) {
- warn "$0: ignoring mutt multi-alias $to = $alias\n";
- last;
- }
- if (/@/) {
- $alias = $_;
- warn "$0: found mutt alias $to = $alias\n";
- last;
- }
- }
- }
- close $ma;
- $to = $alias;
+ elsif ($to !~ /@/ and $to ne $from) {
+ $to = get_mutt_alias($to);
}
}
}
$to = join(',',grep /./,@to) or exit;
- warn "Server/User: $fexcgi/$from\n" unless $opt_q;
+ # warn "Server/User: $fexcgi/$from\n" unless $opt_q;
if (
not $skey and not $gkey
+ and $from ne $to
and $features =~ /CHECKRECIPIENT/
and $opt_C !~ /^(DELETE|LIST|RECEIVEDLOG|SENDLOG|FOPLOG)$/
) {
sub forward {
my (@r);
my ($to,$n,$dkey,$file,$req);
- my $status = 1;
+ my ($status,$fp);
local $_;
# look for single @ in arguments
# if ($windoof and not @ARGV) { &inquire }
$to = pop @ARGV or die $usage;
$to = $from if $to eq '.';
+ if ($to !~ /@/ and $to ne $from) {
+ $to = get_mutt_alias($to);
+ }
open $fexlist,$fexlist or die "$0: $fexlist - $!\n";
while (<$fexlist>) {
$req .= " HTTP/1.1";
sendheader("$server:$port",$req);
http_response();
+ $fp = $file;
+ $fp =~ s/[^\w_.-]/.+/g; # because of UTF8 filename
+ $status = 1;
while (<$SH>) {
- if ($opt_v) {
- print;
- $status = 0 if /\Q"$file"/;
- } else {
- if (/\Q"$file"/) {
- print;
- $status = 0;
- }
- }
+ $status = 0 if /"$fp"/;
+ print if $opt_v or /"$fp"/;
}
if ($status) {
if (/^n/i) {
print "keeping $transferfile\n";
} else {
- system("tar xvf $transferfile && rm $transferfile");
+ my $untar = "tar xvf";
+ # if ($> == 0 and `tar --help 2>&1` =~ /gnu/) {
+ # $untar = "tar --no-same-owner -xvf";
+ # }
+ system("$untar $transferfile && rm $transferfile");
die "$0: error while untaring, see $transferfile\n" if -f $transferfile;
}
} else {
print $rcamel[0] if ${'opt_+'};
+ $SIG{ALRM} = sub { retry("timed out") };
while (my $b = read $file,$buf,$bs) {
- print {$SH} $buf or &sigpipehandler;
+ alarm($timeout*2);
+ syswrite $SH,$buf or &sigpipehandler;
+ alarm(0);
$bytes += $b;
if ($filesize > 0 and $bytes+$seek > $filesize) {
die "$0: $file filesize has grown while uploading\n";
sub sigpipehandler {
- $SIG{ALRM} = sub { };
+ retry("died");
+}
+
+sub retry {
+ my $reason = shift;
+ local $SIG{ALRM} = sub { };
+
if (fileno $SH) {
alarm(1);
- @_ = <$SH>;
+ my @r = <$SH>;
alarm(0);
kill 9,$tpid if $tpid;
- if (@_ and $opt_v) {
- die "\n$0: ($$) server error: @_\n";
+ if (@r and $opt_v) {
+ die "\n$0: ($$) server error: @r\n";
}
- if (@_ and $_[0] =~ /^HTTP.* \d+ (.*)/) {
+ if (@r and $r[0] =~ /^HTTP.* \d+ (.*)/) {
die "\n$0: server error: $1\n";
}
}
$timeout *= 2;
- warn "\n$0: connection to $server died\n";
+ warn "\n$0: connection to $server $reason\n";
warn "retrying after $timeout seconds...\n";
sleep $timeout;
if ($windoof) { exec $^X,$0,@_ARGV }
}
+sub get_mutt_alias {
+ my $to = shift;
+ my $ma = $HOME.'/.mutt/aliases';
+ my $alias;
+ local $_;
+
+ open $ma,$ma or return $to;
+ while (<$ma>) {
+ if (/^alias \Q$to\E\s/i) {
+ chomp;
+ s/\s*#.*//;
+ s/\(.*?\)//;
+ s/\s+$//;
+ s/.*\s+//;
+ s/[<>]//g;
+ if (/,/) {
+ warn "$0: ignoring mutt multi-alias $to = $alias\n";
+ last;
+ }
+ if (/@/) {
+ $alias = $_;
+ warn "$0: found mutt alias $to = $alias\n";
+ last;
+ }
+ }
+ }
+ close $ma;
+ return ($alias||$to);
+}
+
+
# collect file meta data (filename, inode, mtime)
sub fmd {
my @files = @_;
unless (defined $_ and /\w/) {
die "$0: no response from server\n";
}
+ print "<-- $_\n" if $opt_v;
s/\r?\n//;
# CGI fatalsToBrowser
if (/^HTTP.* 500/) {
unless (/^HTTP.* 200/) {
$error = $_;
$error =~ s/HTTP.[\s\d.]+//;
- if ($opt_v) {
- print "<-- $_";
- print "<-- $_" while <$SH>;
+ @r = <$SH> unless @r;
+ @r = () unless @r;
+ foreach (@r) {
+ chomp;
+ $error .= "\n".$_ if /^Location/;
+ print "<-- $_\n" if $opt_v;
}
die "$0: server error: $error\n";
}
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) {
unless (/^HTTP.1.. 200/) {
die "$0: proxy error : $_";
}
- eval "use IO::Socket::SSL";
- die "$0: cannot load IO::Socket::SSL\n" if $@;
+ &enable_ssl;
$SH = IO::Socket::SSL->start_SSL($SH,%SSL);
}
} else {
if ($port == 443) {
# eval "use IO::Socket::SSL qw(debug3)";
- eval "use IO::Socket::SSL";
- die "$0: cannot load IO::Socket::SSL\n" if $@;
+ &enable_ssl;
$SH = IO::Socket::SSL->new(
PeerAddr => $server,
PeerPort => $port,
}
+sub enable_ssl {
+ eval "use IO::Socket::SSL";
+ die "$0: cannot load IO::Socket::SSL\n" if $@;
+ eval '$SSL{SSL_verify_mode} = 0 if Net::SSLeay::SSLeay() <= 9470143';
+ if ($opt_v) {
+ foreach my $v (keys %SSL) {
+ printf "%s => %s\n",$v,$SSL{$v};
+ }
+ }
+}
+
+
sub sendheader {
my $sp = shift;
my @head = @_;
eval 'use Net::INET6Glue::INET_is_INET6';
-our $version = 20150120;
+our $version = 20150615;
my %SSL = (SSL_version => 'TLSv1');
my $sigpipe;
+++ /dev/null
-<HTML> \r
-<HEAD><TITLE>F*EX feature list</TITLE></HEAD>\r
-<BODY>\r
-<h1><a href="/">F*EX</a> feature list</h1>\r
-<ul>\r
- <li>file transfer of virtually unlimited file size\r
- <li>recipient and sender only need an e-mail program and a web browser -\r
- of any kind, they do not have to install any software<br>\r
- (the F*EX server itself is UNIX based)\r
- <li>RESEND and REGET for resuming after link failures at last sent byte\r
- <li>auto-notification of recipient\r
- <li>auto-deletion after download\r
- <li>auto-deletion after expiration date (default: 5 days)\r
- <li>full-users can create one time upload URLs for foreign users\r
- <li>full-users can create sub-users, who can send only to this full-user\r
- <li>full-users can create groups, an analogy to mailing lists, but for files\r
- <li>admin can allow (internal or external) user self-registration\r
- <li>admin can allow upload to public recipients without authentification\r
- <li>admin can allow upload for LAN users without registration \r
- (<a href="/usecases/anonymous.html">anonymous upload</a>)\r
- <li>user can forward a file to a second recipient without re-uploading it\r
- <li>user can forward a received file without download\r
- <li>adminstration by CLI or Web\r
- <li>server based user address books\r
- <li>user and admin can throttle bandwith usage\r
- <li>admin can restrict access based on e-mail or ip addresses \r
- <li>sending to multiple recipients needs storage on the server only once\r
- <li>quotas for sending and receiving\r
- <li>support for named based virtual hosts \r
- (multiple server instances with different hostnames on same IP)\r
- <li>support for streams, including streaming recursive file transfer\r
- <li>support for file linking (upload just a link, not the file itself)\r
- <li>integrated web server with special features:\r
- <ul>\r
- <li>HTML with inline perl code\r
- <li>HTML with conditional if..then..elseif..end blocks\r
- <li>HTML with include statement\r
- <li>on-the-fly zip, tar and tgz streaming output \r
- <li>(restricted) directory file viewer\r
- </ul>\r
- <li>for real UNIX users, there are the shell programs \r
- <a href="/fstools/fexsend.html">fexsend</a> and\r
- <a href="/fstools/fexget.html">fexget</a><br>\r
- to avoid annoying web browser usage and with a lot of additional\r
- features,<br>\r
- also there is an <a href="/usecases/xx.html">Internet clipboard</a>\r
- and <a href="/usecases/anonymous.html">anonymous usage</a>\r
- <li><a href="/fex.html">protocol and source-code free available</a>\r
- <li>localization for <a href="http://fex.rus.uni-stuttgart.de:8080/">\r
- many languanges</a> available\r
- <li>optional authentification by LDAP, RADIUS, POP, IMAP, mailman\r
- <li>server available for UNIX and Windows hosts\r
- <li>about 10 times faster than apache\r
- <li><b>very</b> low memory usage\r
- <li>(reverse) proxy support\r
- <li>F*EX is a HTTP web-service and needs no firewall-tunnels\r
- <li>works with NAT or DHCP clients, too\r
- <li><a href="/usecases/BIGMAIL.html">postfix filter</a> available to send\r
- e-mails with attachments of <b>any</b> size\r
- <li>maintenance-free: no admin interaction necessary \r
- <li>minimal software & hardware requirements for the server\r
- <li>no external database necessary, but possible (LDAP)\r
- <li>full IPv6 support\r
- <li>easy server installation, no installation necessary on client side\r
- <li>great <a href="/FAQ/">FAQ</a>, <a href="/usecases/">use cases</a> \r
- and detailed <a href="/doc/concept">internal documentation</a>\r
-</ul>\r
-</BODY>\r
-</HTML> \r
<li>Very few http servers can handle files greater than 2 GB
</ul>
<p>
- <li><h3><a href ="http://fex.rus.uni-stuttgart.de/saft/">
+ <li><h3><a href ="http://fex.belwue.de/saft/">
sendfile</a></h3><p>
<ul>
<li>You run UNIX and have sendfile installed?
Authentication is the same as with F*EX.
<h2>Still questions?</h2>
-See the <a href="/FAQ/FAQ.html">FAQ</a>
-and the <a href="http://fex.rus.uni-stuttgart.de/usecases/">use cases</a>.
+See the <a href="http://fex.belwue.de/features.html">full feature list</a>,
+the <a href="/FAQ/FAQ.html">FAQ</a>
+and the <a href="http://fex.belwue.de/usecases/">use cases</a>.
<p>
<ADDRESS>contact: <A HREF="mailto:$SERVER_ADMIN$">fexmaster</A></ADDRESS>
-fex-20150120
+fex-20150615
die "you must be root to install F*EX\n";
}
-goto INSTALL if $0 =~ /upgrade$/;
-
$fex = 'fex.rus.uni-stuttgart.de';
if (system("host $fex >/dev/null") != 0) {
die "host $fex is not resolvable - check /etc/resolv.conf\n";
}
-if (`uname` =~ /^SunOS/) {
- die "Solaris is currently not supported. "
- ."Please contact framstag\@rus.uni-stuttgart.de for details.\n";
-}
-
$opt_p = 80;
if (open $xinetd,$xinetd) {
if (/^\s*port\s*=\s*(\d+)/) {
$opt_p = $fexport = $1;
}
- if (/^\s*bind\s*=\s*([\d.]+)/) {
+ if (/^\s*bind\s*=\s*([\d.]+)$/) {
$fexip = $ip = $1;
}
}
close $xinetd;
}
+goto INSTALL if $0 =~ /upgrade$/;
+
+if (`uname` =~ /^SunOS/) {
+ die "Solaris is currently not supported. "
+ ."Please contact framstag\@rus.uni-stuttgart.de for details.\n";
+}
+
getopts('p:') or die $usage;
$arg = shift;
$ip = $arg || $fexip || 0;
}
-
# if (not $ip and open P,"ifconfig 2>/dev/null |") {
if (not $ip and open P,'host $(hostname)|') {
$guessed_ip = 0;
$ip ||= $guessed_ip;
}
-$ip =~ /^\d+\.\d+\.\d+\.\d+$/ or die $usage;
($hostname) = gethostbyaddr(gethostbyname($ip),AF_INET);
die "cannot find hostname for IP $ip\n" unless $hostname;
@FEX = getpwnam('fex') or die "no user fex\n";
$FEXHOME = $FEX[7];
+$ENV{HOME} = $FEXHOME; # needed for later eval fex.ph
die "no HOME directory for user fex\n" unless -d $FEXHOME;
+if ($FEXHOME !~ /fex/) {
+ print "HOME=$FEXHOME for user fex does not contain \"fex\"\n";
+ print "REALLY continue?! ";
+ $_ = <STDIN>;
+ exit unless /^y/i;
+}
print "Installing:\n";
+$pecl = "$FEXHOME/perl/Encode/ConfigLocal.pm";
+unless (-f $pecl) {
+ mkdir "$FEXHOME/perl";
+ mkdir "$FEXHOME/perl/Encode";
+ open $pecl,'>',$pecl or die "$0: cannot write $pecl - $!\n";
+ print {$pecl}
+ "# hack for broken Perl in SuSe and Solaris, used via \@INC in fexsrv\n",
+ "1;\n";
+ close $pecl;
+ print $pecl,"\n";
+ chownr('fex:root',"$FEXHOME/perl");
+}
+
@save = (
"lib/fex.ph",
"lib/fup.pl",
$hl = "$FEXHOME/htdocs/locale";
unless (-d $hl) { mkdir $hl or die "$0: cannot mkdir $hl - $!\n" }
-if (-d "$FEXHOME/spool") {
- warn "checking spool ...\n";
- &convert_spool;
- system "chown -R fex $spooldir/";
-} else {
- $newinstall = $FEXHOME;
- chmod 0700,$FEXHOME;
- mkdir "$FEXHOME/spool",0700 or die "cannot mkdir $FEXHOME/spool - $!\n";
- mkdir "$FEXHOME/spool/.error",0700;
- system "chown -R fex $FEXHOME/spool";
-}
-
foreach $s (@save) {
$f = "$FEXHOME/$s";
$fs = $f.'_save';
$fn = $f.'_new';
if (-e $fs) {
- system "rm -rf $fn";
+ unlink $fn;
rename $f,$fn and print "$f --> $fn\n";
rename $fs,$f and print "$fs --> $f\n";
}
}
+if (-d "$FEXHOME/spool") {
+ warn "checking $FEXHOME/spool ...\n";
+ &convert_spool;
+} else {
+ $newinstall = $FEXHOME;
+ chmod 0700,$FEXHOME;
+ mkdir "$FEXHOME/spool",0700 or die "cannot mkdir $FEXHOME/spool - $!\n";
+ mkdir "$FEXHOME/spool/.error",0700;
+}
+chownr('fex',"$FEXHOME/spool/.");
+
system(qw'perl -p -i -e',
's:href="/?FAQ.html":href="/FAQ/FAQ.html":',
"$FEXHOME/lib/fup.pl"
close $fph;
eval $conf;
-$spooldir ||= "$FEXHOME/spool";
+
+die "no \$spooldir in $fph\n" unless $spooldir;
+die "\$spooldir=$spooldir is not a directory, see $fph\n" unless -d $spooldir;
+symlink $spooldir,"$FEXHOME/spool" unless -e "$FEXHOME/spool";
+@sds1 = stat "$spooldir/.";
+@sds2 = stat "$FEXHOME/spool/.";
+if ("@sds1" ne "@sds2") {
+ die "$FEXHOME/spool is not a symbolic link to \$spooldir=$spooldir\n";
+}
$fid = "$FEXHOME/.fex/id";
$aa = "$spooldir/$admin/@";
-if ($newinstall) {
+if ($newinstall or not -s $aa) {
print "\n";
for (;;) {
print "Server hostname [$hostname] : ";
}
}
-sub mkfid {
- my $ad = dirname($aa);
- mkdir $ad;
- open $aa,'>',$aa or die "$0: cannot create $aa - $!\n";
- print {$aa} "$admin_pw\n";
- close $aa;
- my $fd = dirname($fid);
- mkdir $fd;
- rename $fid,$fid.'_save';
- open $fid,'>',$fid or die "$0: cannot create $fid - $!\n";
- print {$fid} "$hostname:$opt_p\n";
- print {$fid} "$admin\n";
- print {$fid} "$admin_pw\n";
- close $fid;
- chmod 0700,$fd;
- system "chown -R fex $fd $ad";
-}
-
open $fph,">$fph.new" or die "$0: cannot write $fph.new - $!\n";
print {$fph} $conf;
close $fph;
do $fph or die "$0: error in new $fph - $!\n";
-rename "locale/deutsch","locale/german" if -d "locale/deutsch";
-rename "locale/espanol","locale/spanish" if -d "locale/espanol";
-
if (@locales = glob "locale/*/lib/fup.pl") {
foreach (@locales) {
m{locale/(.+?)/} and $locale = $1;
if (-f "$FEXHOME/$_") {
system 'locale/translate',$locale;
- system "chown -R fex $FEXHOME/locale/$locale";
+ chownr('fex',"$FEXHOME/locale/$locale");
$hl = "$FEXHOME/htdocs/locale/$locale";
symlink "$FEXHOME/locale/$locale/htdocs",$hl unless -l $hl;
} else {
system qw(crontab -u fex fex.cron);
}
- system "chown -R fex:root $FEXHOME $FEXHOME/spool/";
- system "chmod -R go-r $FEXHOME/lib $FEXHOME/cgi-bin $FEXHOME/spool/";
+ chownr('fex:root',"$FEXHOME $FEXHOME/spool/.");
+ chmodr('go-r',"$FEXHOME/lib","$FEXHOME/cgi-bin","$FEXHOME/spool/.");
print "\n";
print "Now check configuration file $FEXHOME/lib/fex.ph and run\n";
print "(You can do this as user \"fex\")\n";
} else {
- system "chmod -R go-r $FEXHOME/lib $FEXHOME/cgi-bin";
+ chmodr('go-r',"$FEXHOME/lib","$FEXHOME/cgi-bin");
print "\n";
print "F*EX update installed.\n";
print "You MUST set in your exim4.conf:\n";
print "trusted_users = mail : uucp : fex\n";
}
+
exit;
+sub mkfid {
+ my $ad = dirname($aa);
+ mkdir $ad;
+ open $aa,'>',$aa or die "$0: cannot create $aa - $!\n";
+ print {$aa} "$admin_pw\n";
+ close $aa;
+ my $fd = dirname($fid);
+ mkdir $fd;
+ rename $fid,$fid.'_save';
+ open $fid,'>',$fid or die "$0: cannot create $fid - $!\n";
+ print {$fid} "$hostname:$opt_p\n";
+ print {$fid} "$admin\n";
+ print {$fid} "$admin_pw\n";
+ close $fid;
+ chownr('fex',$ad,$fd);
+ chmod 0700,$ad,$fd;
+}
+
+sub chownr {
+ my $user = shift;
+ local $_;
+ foreach (@_) {
+ if (m:^/*(lib|usr|home)?/*$:) {
+ die "ERROR: short path in chownr $user @_\n";
+ }
+ }
+ system qw'chown -R',$user,@_;
+}
+
+sub chmodr {
+ my $mod = shift;
+ local $_;
+ foreach (@_) {
+ if (m:^/*(lib|usr|home)?/*$:) {
+ die "ERROR: short path in chmodr $mod @_\n";
+ }
+ }
+ system qw'chmod -R',$mod,@_;
+}
sub convert_spool {
my ($f,$d,$to,$from,$link);
local $) = $FEX[3];
- local $> = $FEX[2];
+ local $> = $FEX[2];
our ($spooldir,$skeydir,$gkeydir);
$ENV{FEXLIB} = $FEXLIB = "$FEXHOME/lib";
require "$FEXLIB/fex.pp" or die "$0: cannot load $FEXLIB/fex.pp - $!\n";
+ die "no \$spooldir in $FEXLIB/fex.pp\n" unless $spooldir;
+ die "\$spooldir=$spooldir/" if $spooldir =~ m:^/*(root)?$:;
# User --> user@maildomain
if ($mdomain) {
# create new GKEYs
foreach my $gf (glob "$spooldir/*/\@GROUP/*") {
next unless -f $gf;
+ # normalize group name
+ if ($gf =~ m:(.+)/(.+):) {
+ my $gd = $1;
+ my $g1 = $2;
+ my $g2 = $2;
+ $g2 =~ s/[^\w\*%^+=:,.!-]/_/g;
+ if ($g1 ne $g2) {
+ rename "$gd/$g1","$gd/$g2" and $gf = "$gd/$g2";
+ }
+ }
$group = (split '/',$gf)[-1];
$user = (split '/',$gf)[-3];
if (open $gf,$gf) {
# import from fex.pp
our ($bs,$tmpdir,@doc_dirs);
-my $log = "$logdir/dop.log";
+my $log = 'dop.log';
# POSIX time format needed for HTTP header
setlocale(LC_TIME,'POSIX');
if ($type eq 'text/html') {
alarm($timeout*10);
print $htmldoc;
+ $s = $size;
} else {
# binary data # can be stream!
seek $file,$seek,0 if $seek;
}
-sub mtime {
- return (lstat shift)[9];
-}
-
-
sub d3 {
local $_ = shift;
while (s/(\d)(\d\d\d\b)/$1,$2/) {};
+# -*- perl -*- #
+
## your F*EX server host name (with domain)
$hostname = 'MYHOSTNAME.MYDOMAIN';
## admin email address used in notification emails
-## to change it, you must call: fac -/ admin-email-address auth-id
+## to change it, you MUST call: fac -/ admin-email-address auth-id
$admin = 'fex@'.$hostname;
## server admin email address shown on web page
## restrict web administration to ip range(s)
@admin_hosts = qw(127.0.0.1 10.0.0.0-10.10.255.255);
-## Bcc address for notification emails
+## Bcc address for notification emails, must not be empty
$bcc = 'fex';
-## send notifications about new F*EX releases
+## send notifications about new F*EX releases (bugfixes!)
$notify_newrelease = $admin;
## optional: download-URLs sent in notification emails
## optional: suppress funny messages
# $boring = 1;
+## optional: suppress warning messages about incompatible web browsers
+# $nowarning = 'YES';
+
# locales to present (must be installed!)
# if empty, present all installed locales
# @locales = qw(english swabian);
# $spooldir = "$ENV{HOME}/spool";
# $logdir = $spooldir;
-## Default quota in MB for recipient; 0 means "no quota"
+## default quota in MB for recipient; 0 means "no quota"
$recipient_quota = 0;
-## Default quota in MB for sender; 0 means "no quota"
+## default quota in MB for sender; 0 means "no quota"
$sender_quota = 0;
-## Expiration: keep files that number of days (default)
+## expiration: keep files that number of days (default)
$keep = 5;
-## Expiration: keep files that number of days (maximum)
+## expiration: keep files that number of days (maximum)
$keep_max = 99;
-## Autodelete: delete files after download (automatically)
+## autodelete: delete files after download (automatically)
## YES ==> immediatelly (1 minute grace time)
## DELAY ==> after download at next fex_cleanup cronjob run
## 2 ==> 2 days after download (can be any number!)
## to prevent unwanted file sharing
$limited_download = 'YES';
-## Allow or disallow overwriting of files
+## allow RECIPIENT = SENDER
+## in this case subsequentials downloads from any ip are possible until
+## regular file expiration (KEEP); exception for $limited_download
+$fex_yourself = 'YES';
+
+## allow overwriting of files
$overwrite = 'YES';
-## Allow user requests for forgotten auth-IDs (then send by email)
+## allow user requests for forgotten auth-IDs (then send by email)
$mail_authid = 'YES';
## optional: from which hosts and for which mail domains users may
# @file_link_dirs = qw(/sw /nfs/home/exampleuser);
## optional: allow additional directories with static documents
-## ($docdir (/home/fex/htdocs) is always allowed implicitly)
+## $docdir (/home/fex/htdocs) is always allowed implicitly
# @doc_dirs = qw(/sw /nfs/home/exampleuser/htdocs);
## optional: text file with your conditions of using
-## will be append to registrations request replies
+## will be append to registrations request replies
# $usage_conditions = "$docdir/usage_conditions.txt";
+
+## optional: redirect URIs
+## URLs with leading ! are active http redirects
+# %redirect = (
+# '/fstools/' => '!http://fex.belwue.de/fstools/',
+# '/usecases/' => 'http://fex.belwue.de/usecases/',
+# );
# set and untaint ENV if not in CLI (fexsrv provides clean ENV)
unless (-t) {
foreach my $v (keys %ENV) {
- ($ENV{$v}) = ($ENV{$v} =~ /(.*)/s);
+ ($ENV{$v}) = ($ENV{$v} =~ /(.*)/s) if defined $ENV{$v};
}
$ENV{PATH} = '/usr/local/bin:/bin:/usr/bin';
$ENV{IFS} = " \t\n";
$autodelete = 'YES';
$overwrite = 'YES';
$limited_download = 'YES'; # multiple downloads only from same client
+$fex_yourself = 'YES'; # allow SENDER = RECIPIENT
$keep = 5; # days
$recipient_quota = 0; # MB
$sender_quota = 0; # MB
$timeout = 30; # seconds
$bs = 2**16; # I/O blocksize
+$DS = 60*60*24; # seconds in a day
+$MB = 1024*1024; # binary Mega
$use_cookies = 1;
$sendmail = '/usr/lib/sendmail';
$sendmail = '/usr/sbin/sendmail' unless -x $sendmail;
$mail_authid = 0 if $mail_authid =~ /no/i;
$force_https = 0 if $force_https =~ /no/i;
$debug = 0 if $debug =~ /no/i;
-
+
+@logdir = ($logdir) unless @logdir;
+$logdir = $logdir[0];
+
# check for name based virtual host
$vhost = vhost($ENV{'HTTP_HOST'});
+$RB = 0; # read POST bytes
+
push @doc_dirs,$docdir;
foreach my $ld (glob "$FEXHOME/locale/*/htdocs") {
push @doc_dirs,$ld;
$nomail = ($mailmode =~ /^MANUAL|nomail$/i);
if (not $nomail and not -x $sendmail) {
- http_die("found no sendmail\n");
+ http_die("found no sendmail");
}
http_die("cannot determine the server hostname") unless $hostname;
$default_locale ||= 'english';
+# $durl is first default fop download URL
+# @durl is optional mandatory fop download URL list (from fex.ph)
unless ($durl) {
- my $host = '';
- my $port = 0;
-
- ($host,$port) = split(':',$ENV{HTTP_HOST}||'');
- $host = $hostname;
-
- unless ($port) {
- $port = 80;
- if (open my $xinetd,'<',"/etc/xinetd.d/fex") {
- while (<$xinetd>) {
- if (/^\s*port\s*=\s*(\d+)/) {
- $port = $1;
- last;
+ if (@durl) {
+ $durl = $durl[0];
+ } elsif ($ENV{HTTP_HOST} and $ENV{PROTO}) {
+ my $host = '';
+ my $port = 0;
+
+ ($host,$port) = split(':',$ENV{HTTP_HOST}||'');
+ $host = $hostname;
+
+ unless ($port) {
+ $port = 80;
+ if (open my $xinetd,'<',"/etc/xinetd.d/fex") {
+ while (<$xinetd>) {
+ if (/^\s*port\s*=\s*(\d+)/) {
+ $port = $1;
+ last;
+ }
}
+ close $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";
+ # use same protocal as uploader for download
+ if ($ENV{PROTO} eq 'https' and $port == 443 or $port == 80) {
+ $durl = "$ENV{PROTO}://$host/fop";
+ } else {
+ $durl = "$ENV{PROTO}://$host:$port/fop";
+ }
} else {
- $durl = "$ENV{PROTO}://$host:$port/fop";
+ $durl = "http://$hostname/fop";
}
}
-@durl = ($durl) unless @durl;
-
sub reexec {
exec($FEXHOME.'/bin/fexsrv') if $ENV{KEEP_ALIVE};
sub http_die {
# not in CGI mode
- die "$0: @_\n" unless $ENV{GATEWAY_INTERFACE};
+ unless ($ENV{GATEWAY_INTERFACE}) {
+ warn "$0: @_\n"; # must not die, because of fex_cleanup!
+ return;
+ }
debuglog(@_);
}
+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");
+ return untaint($user);
+}
+
+
+sub urldecode {
+ local $_ = shift;
+ s/%([a-f0-9]{2})/chr(hex($1))/gie;
+ return $_;
+}
+
+
sub untaint {
local $_ = shift;
/(.*)/s;
$a =~ s/:\w+=.*//; # remove options from address
return $a if $a eq 'anonymous';
-
- $re = '^[.@]|@.*@|local(host|domain)$|["\'\`\|\s()<>/;,]';
+
+ $a .= '@'.$mdomain if $mdomain and $a !~ /@/;
+
+ $re = '^[.@-]|@.*@|local(host|domain)$|["\'\`\|\s()<>/;,]';
if ($a =~ /$re/i) {
debuglog("$a has illegal syntax ($re)");
return '';
return if -d $dir;
$dir =~ s:/+$::;
- http_die("cannot mkdir /\n") unless $dir;
+ http_die("cannot mkdir /") unless $dir;
$pdir = $dir;
if ($pdir =~ s:/[^/]+$::) {
mkdirp($pdir) unless -d $pdir;
}
unless (-d $dir) {
- mkdir $dir,0770 or http_die("mkdir $dir - $!\n");
+ mkdir $dir,0770 or http_die("mkdir $dir - $!");
}
}
# file and document log
sub fdlog {
my ($log,$file,$s,$size) = @_;
- my $ra;
-
- if (open $log,'>>',$log) {
- flock $log,LOCK_EX;
- seek $log,0,SEEK_END;
- $ra = $ENV{REMOTE_ADDR}||'-';
- $ra .= '/'.$ENV{HTTP_X_FORWARDED_FOR} if $ENV{HTTP_X_FORWARDED_FOR};
- $ra =~ s/\s//g;
- $file =~ s:/data$::;
- printf {$log}
- "%s [%s_%s] %s %s %s/%s\n",
- isodate(time),$$,$ENV{REQUESTCOUNT},$ra,encode_Q($file),$s,$size;
- close $log;
- }
+ my $ra = $ENV{REMOTE_ADDR}||'-';
+ my $msg;
+
+ $ra .= '/'.$ENV{HTTP_X_FORWARDED_FOR} if $ENV{HTTP_X_FORWARDED_FOR};
+ $ra =~ s/\s//g;
+ $file =~ s:/data$::;
+ $msg = sprintf "%s [%s_%s] %s %s %s/%s\n",
+ isodate(time),$$,$ENV{REQUESTCOUNT},$ra,encode_Q($file),$s,$size;
+
+ writelog($log,$msg);
}
return unless $debug and @_;
unless ($debuglog and fileno $debuglog) {
- mkdir "$logdir/.debug",0770 unless -d "$logdir/.debug";
+ my $ddir = "$spooldir/.debug";
+ mkdir $ddir,0770 unless -d $ddir;
$prg =~ s:.*/::;
$prg = untaint($prg);
- $debuglog = sprintf("%s/.debug/%s_%s_%s.%s",
- $logdir,time,$$,$ENV{REQUESTCOUNT}||0,$prg);
+ $debuglog = sprintf("%s/%s_%s_%s.%s",
+ $ddir,time,$$,$ENV{REQUESTCOUNT}||0,$prg);
$debuglog =~ s/\s/_/g;
# open $debuglog,'>>:encoding(UTF-8)',$debuglog or return;
open $debuglog,'>>',$debuglog or return;
# extra debug log
sub errorlog {
my $prg = $0;
- my $log = "$logdir/error.log";
my $msg = "@_";
+ my $ra = $ENV{REMOTE_ADDR}||'-';
+ $ra .= '/'.$ENV{HTTP_X_FORWARDED_FOR} if $ENV{HTTP_X_FORWARDED_FOR};
+ $ra =~ s/\s//g;
$prg =~ s:.*/::;
$msg =~ s/[\r\n]+$//;
$msg =~ s/[\r\n]+/ /;
$msg =~ s/\s*<p>.*//;
+ $msg = sprintf "%s %s %s %s\n",isodate(time),$prg,$ra,$msg;
- if (open $log,'>>',$log) {
- flock $log,LOCK_EX;
- seek $log,0,SEEK_END;
- $ra = $ENV{REMOTE_ADDR}||'-';
- $ra .= '/'.$ENV{HTTP_X_FORWARDED_FOR} if $ENV{HTTP_X_FORWARDED_FOR};
- $ra =~ s/\s//g;
- printf {$log} "%s %s %s %s\n",isodate(time),$prg,$ra,$msg;
- close $log;
+ writelog('error.log',$msg);
+}
+
+
+sub writelog {
+ my $log = shift;
+ my $msg = shift;
+
+ foreach my $logdir (@logdir) {
+ if (open $log,'>>',"$logdir/$log") {
+ flock $log,LOCK_EX;
+ seek $log,0,SEEK_END;
+ print {$log} $msg;
+ close $log;
+ }
}
}
my $sender = shift;
my $squota = $sender_quota||0;
my $du = 0;
- my ($file,$size,%file,$data);
+ my ($file,$size,%file,$data,$upload);
local $_;
if (open $qf,'<',"$sender/\@QUOTA") {
foreach $file (glob "*/$sender/*") {
$data = "$file/data";
+ $upload = "$file/upload";
if (not -l $data and $size = -s $data) {
# count hard links only once (= same inode)
my $i = (stat($data))[1]||0;
$du += $size;
$file{$i} = $i;
}
- } elsif (-f "$file/upload" and $size = readlink "$file/size") {
- $du += $size;
+ } elsif (-f $upload) {
+ # count hard links only once (= same inode)
+ my $i = (stat($upload))[1]||0;
+ unless ($file{$i}) {
+ $size = readlink "$file/size" and $du += $size;
+ $file{$i} = $i;
+ }
}
}
}
+# read one line from STDIN (net socket) and assign it to $_
+# return number of read bytes
+# also set global variable $RB (read bytes)
+sub nvt_read {
+ my $len = 0;
+
+ if (defined ($_ = <STDIN>)) {
+ debuglog($_);
+ $len = length;
+ $RB += $len;
+ s/\r?\n//;
+ }
+ return $len;
+}
+
+
+# read forward to given pattern
+sub nvt_skip_to {
+ my $pattern = shift;
+
+ while (&nvt_read) { return if /$pattern/ }
+}
+
+
+# HTTP GET and POST parameters
+# (not used by fup)
+# fills global variable %PARAM :
+# normal parameter is $PARAM{$parameter}
+# file parameter is $PARAM{$parameter}{filename} $PARAM{$parameter}{data}
+sub parse_parameters {
+ my $cl = $ENV{X_CONTENT_LENGTH} || $ENV{CONTENT_LENGTH} || 0;
+ my $data = '';
+ my $filename;
+ local $_;
+
+ if ($cl > 128*$MB) {
+ http_die("request too large");
+ }
+
+ foreach (split('&',$ENV{QUERY_STRING})) {
+ if (/(.+?)=(.*)/) { $PARAM{$1} = $2 }
+ else { $PARAM{$_} = $_ }
+ }
+ $_ = $ENV{CONTENT_TYPE}||'';
+ if ($ENV{REQUEST_METHOD} eq 'POST' and /boundary=\"?([\w\-\+\/_]+)/) {
+ my $boundary = $1;
+ while ($RB<$cl and &nvt_read) { last if /^--\Q$boundary/ }
+ # continuation lines are not checked!
+ while ($RB<$cl and &nvt_read) {
+ $filename = '';
+ if (/^Content-Disposition:.*\s*filename="(.+?)"/i) {
+ $filename = $1;
+ }
+ if (/^Content-Disposition:\s*form-data;\s*name="(.+?)"/i) {
+ my $p = $1;
+ # skip rest of mime part header
+ while ($RB<$cl and &nvt_read) { last if /^\s*$/ }
+ $data = '';
+ while (<STDIN>) {
+ if ($p =~ /password/i) {
+ debuglog('*' x length)
+ } else {
+ debuglog($_)
+ }
+ $RB += length;
+ last if /^--\Q$boundary/;
+ $data .= $_;
+ }
+ unless (defined $_) { die "premature end of HTTP POST\n" }
+ $data =~ s/\r?\n$//;
+ if ($filename) {
+ $PARAM{$p}{filename} = $filename;
+ $PARAM{$p}{data} = $data;
+ } else {
+ $PARAM{$p} = $data;
+ }
+ last if /^--\Q$boundary--/;
+ }
+ }
+ }
+}
+
+
# name based virtual host?
sub vhost {
my $hh = shift; # HTTP_HOST
$ENV{FEXLIB} = $FEXLIB = "$vhost/lib";
$logdir = $spooldir = "$vhost/spool";
$docdir = "$vhost/htdocs";
+ @logdir = ($logdir);
if ($locale and -e "$vhost/locale/$locale/lib/fex.ph") {
$ENV{FEXLIB} = $FEXLIB = "$vhost/locale/$locale/lib";
}
}
+sub mtime {
+ my @s = stat(shift) or return;
+ return $s[9];
+}
+
+
# extract locale functions into hash of subroutine references
# e.g. \&german ==> $notify{german}
sub locale_functions {
status => $status,
dkey => $dkey,
filename => $filename,
- keep => $keep-int((time-$mtime)/DS),
+ keep => $keep-int((time-$mtime)/$DS),
comment => $comment,
autodelete => $autodelete,
replyto => $replyto,
# my ($status,$dkey,$filename,$keep,$warn,$comment,$autodelete) = @_;
my %P = @_;
my ($to,$from,$file,$mimefilename,$receiver,$warn,$comment,$autodelete);
- my ($size,$bytes,$days,$header,$data,$replyto);
+ my ($size,$bytes,$days,$header,$data,$replyto,$uurl);
my ($mfrom,$mto,$dfrom,$dto);
+ my $proto = 'http';
+ my $durl = $::durl;
my $index;
my $fileid = 0;
my $fua = $ENV{HTTP_USER_AGENT}||'';
$comment = encode_utf8($P{comment}||'');
$comment =~ s/^!\*!//; # multi download allow flag
$autodelete = $P{autodelete}||$::autodelete;
- $index = $durl;
- $index =~ s/fop/index.html/;
-
- (undef,$to,$from,$file) = split('/',untaint(readlink("$dkeydir/$P{dkey}")));
+
+ $file = untaint(readlink("$dkeydir/$P{dkey}"));
+ $file =~ s/^\.\.\///;
+ # make download protocal same as upload protocol
+ if ($uurl = readlink("$file/uurl") and $uurl =~ /^(\w+):/) {
+ $proto = $1;
+ $durl =~ s/^\w+::/$proto::/;
+ }
+ $index = "$proto://$hostname/index.html";
+ ($to,$from,$file) = split('/',$file);
$filename = strip_path($P{filename});
$mfrom = $from;
$mto = $to;
$data = "$dkeydir/$P{dkey}/data";
$size = $bytes = -s $data;
return unless $size;
- $warning =
- "Please avoid download with Internet Explorer, ".
- "because it has too many bugs.\n".
- "We recommend Firefox or wget.";
+ if ($nowarning) {
+ $warning = '';
+ } else {
+ $warning =
+ "Please avoid download with Internet Explorer, ".
+ "because it has too many bugs.\n".
+ "We recommend Firefox or wget.";
+ }
if ($filename =~ /\.(tar|zip|7z|arj|rar)$/) {
$warning .= "\n\n".
"$filename is a container file.\n".
} else {
$autodelete = '';
}
- $mimefilename = $filename;
- if ($mimefilename =~ s{([_\?\=\x00-\x1F\x7F-\xFF])}{sprintf("=%02X",ord($1))}eog) {
- $mimefilename =~ s/ /_/g;
- $mimefilename = '=?UTF-8?Q?'.$mimefilename.'?=';
- }
+
+ if (-s $keyring) {
+ $mimefilename = '';
+ } else {
+ $mimefilename = $filename;
+ if ($mimefilename =~ s/([_\?\=\x00-\x1F\x7F-\xFF])/sprintf("=%02X",ord($1))/eog) {
+ $mimefilename =~ s/ /_/g;
+ $mimefilename = '=?UTF-8?Q?'.$mimefilename.'?=';
+ }
+ }
unless ($fileid = readlink("$dkeydir/$P{dkey}/id")) {
my @s = stat($data);
}
$header .= "X-FEX-Client-Address: $fra\n" if $fra;
$header .= "X-FEX-Client-Agent: $fua\n" if $fua;
- foreach my $u (@durl) {
+ foreach my $u (@durl?@durl:($durl)) {
my $durl = sprintf("%s/%s/%s",$u,$P{dkey},normalize_filename($filename));
$header .= "X-FEX-URL: $durl\n" unless -s $keyring;
$download .= "$durl\n";
if ($sender_from) {
map { s/^From: <$mfrom/From: <$sender_from/ } $header;
open $sendmail,'|-',$sendmail,$mto,$bcc
- or http_die("cannot start sendmail - $!\n");
+ or http_die("cannot start sendmail - $!");
} else {
# for special remote domains do not use same domain in From,
# because remote MTA will probably reject this e-mail
{
$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 - $!\n");
+ or http_die("cannot start sendmail - $!");
} else {
open $sendmail,'|-',$sendmail,'-f',$mfrom,$mto,$bcc
- or http_die("cannot start sendmail - $!\n");
+ or http_die("cannot start sendmail - $!");
}
}
if ($comment =~ s/^!(shortmail|\.)!\s*//i
'$disclaimer'
));
}
+ $body =~ s/\n\n+/\n\n/g;
if (-s $keyring) {
$enc_body = gpg_encrypt($body,$to,$keyring,$from);
}
"Content-Transfer-Encoding: 8bit\n";
}
print {$sendmail} $header,"\n",$body;
- close $sendmail
- or $! and http_die("cannot send notification e-mail (sendmail error $!)\n");
- return $to;
+ close $sendmail and return $to;
+ http_die("cannot send notification e-mail (sendmail error $!)");
}
F*EX is not an archive!
<p>
See also <a href="/FAQ/">questions & answers</a> and
-<a href="http://fex.rus.uni-stuttgart.de/usecases/">use cases</a>.
+<a href="http://fex.belwue.de/usecases/">use cases</a>.
<p><hr><p>
<address>
<a href="mailto:$ENV{SERVER_ADMIN}">$ENV{SERVER_ADMIN}</a><br>
e.g. with <a href="http://www.7-zip.org/download.html">7-Zip</a>.
<p>
See also the <a href="/FAQ/user.html">FAQ<a> and
-<a href="http://fex.rus.uni-stuttgart.de/usecases/">use cases</a>.
+<a href="http://fex.belwue.de/usecases/">use cases</a>.
<p><hr><p>
<address>
<a href="mailto:$ENV{SERVER_ADMIN}">$ENV{SERVER_ADMIN}</a><br>
projects / fex.git / commitdiff