X-Git-Url: http://git.treefish.org/fex.git/blobdiff_plain/7fa382617fbaccc0ce522b2b3adbbee9db5ad227..e60096926213ce02293a261254ff065cae44c1c8:/lib/fex.pp diff --git a/lib/fex.pp b/lib/fex.pp index bb72a4e..352b412 100644 --- a/lib/fex.pp +++ b/lib/fex.pp @@ -13,7 +13,7 @@ use Symbol qw'gensym'; # 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"; @@ -43,11 +43,14 @@ $logdir = $spooldir; $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; @@ -82,10 +85,15 @@ $fop_auth = 0 if $fop_auth =~ /no/i; $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; @@ -94,7 +102,7 @@ foreach my $ld (glob "$FEXHOME/locale/*/htdocs") { $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; @@ -143,36 +151,42 @@ if (@locales) { $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}; @@ -344,7 +358,10 @@ sub html_error { 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(@_); @@ -584,6 +601,23 @@ sub normalize_email { } +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; @@ -621,8 +655,10 @@ sub checkaddress { $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 ''; @@ -696,13 +732,13 @@ sub mkdirp { 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 - $!"); } } @@ -789,20 +825,16 @@ sub urlencode { # 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); } @@ -813,11 +845,12 @@ sub debuglog { 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; @@ -836,22 +869,32 @@ sub debuglog { # 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*

.*//; + $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; + } } } @@ -931,7 +974,7 @@ sub check_sender_quota { 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") { @@ -944,6 +987,7 @@ sub check_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; @@ -951,8 +995,13 @@ sub check_sender_quota { $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; + } } } @@ -1094,6 +1143,89 @@ sub slurp { } +# 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 ($_ = )) { + 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 () { + 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 @@ -1109,6 +1241,7 @@ sub vhost { $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"; } @@ -1151,6 +1284,12 @@ sub gpg_encrypt { } +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 { @@ -1207,7 +1346,7 @@ sub notify_locale { status => $status, dkey => $dkey, filename => $filename, - keep => $keep-int((time-$mtime)/DS), + keep => $keep-int((time-$mtime)/$DS), comment => $comment, autodelete => $autodelete, replyto => $replyto, @@ -1222,8 +1361,10 @@ sub notify { # 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}||''; @@ -1240,10 +1381,16 @@ sub notify { $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; @@ -1258,10 +1405,14 @@ sub notify { $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". @@ -1288,11 +1439,16 @@ sub notify { } 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); @@ -1308,7 +1464,7 @@ sub notify { } $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"; @@ -1334,7 +1490,7 @@ sub notify { 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 @@ -1347,10 +1503,10 @@ sub notify { { $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 @@ -1387,6 +1543,7 @@ sub notify { '$disclaimer' )); } + $body =~ s/\n\n+/\n\n/g; if (-s $keyring) { $enc_body = gpg_encrypt($body,$to,$keyring,$from); } @@ -1417,9 +1574,8 @@ sub notify { "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 $!)"); }