X-Git-Url: http://git.treefish.org/fex.git/blobdiff_plain/7fa382617fbaccc0ce522b2b3adbbee9db5ad227..cdeb354c4dbb11b683f9f8c5db2861f3dc572c61:/lib/fex.pp diff --git a/lib/fex.pp b/lib/fex.pp index bb72a4e..8bfddbf 100644 --- a/lib/fex.pp +++ b/lib/fex.pp @@ -1,6 +1,7 @@ # -*- perl -*- use 5.008; +use utf8; use Fcntl qw':flock :seek :mode'; use IO::Handle; use IPC::Open3; @@ -13,7 +14,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 +44,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; @@ -59,6 +63,17 @@ $mail_authid = 'yes'; $force_https = 0; $debug = 0; +# https://securityheaders.io/ +# https://scotthelme.co.uk/hardening-your-http-response-headers/ +# http://content-security-policy.com/ +@extra_header = ( + # "Content-Security-Policy: sandbox allow-forms allow-scripts", + "Content-Security-Policy: script-src 'self' 'unsafe-inline'", + "X-Frame-Options: SAMEORIGIN", + "X-XSS-Protection: 1; mode=block", + "X-Content-Type-Options: nosniff", +); + $FHS = -f '/etc/fex/fex.ph' and -d '/usr/share/fex/lib'; # Debian FHS if ($FHS) { @@ -68,13 +83,10 @@ if ($FHS) { $docdir = '/var/lib/fex/htdocs'; $notify_newrelease = ''; } - + # allowed download managers (HTTP User-Agent) $adlm = '^(Axel|fex)'; -# allowed multi download recipients -$amdl = '^(anonymous|_fexmail_)'; - # local config require "$FEXLIB/fex.ph" or die "$0: cannot load $FEXLIB/fex.ph - $!"; @@ -82,10 +94,22 @@ $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]; + +# allowed multi download recipients: from any ip, any times +if (@mailing_lists) { + $amdl = '^('.join('|',map { quotewild($_) } @mailing_lists).')$'; +} else { + $amdl = '^-$'; +} + # 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 +118,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; @@ -102,14 +126,14 @@ $ENV{PROTO} = 'http' unless $ENV{PROTO}; $keep = $keep_default ||= $keep || 5; $fra = $ENV{REMOTE_ADDR} || ''; $sid = $ENV{SID} || ''; - -mkdirp($dkeydir = "$spooldir/.dkeys"); # download keys -mkdirp($ukeydir = "$spooldir/.ukeys"); # upload keys -mkdirp($akeydir = "$spooldir/.akeys"); # authentification keys -mkdirp($skeydir = "$spooldir/.skeys"); # subuser authentification keys -mkdirp($gkeydir = "$spooldir/.gkeys"); # group authentification keys -mkdirp($xkeydir = "$spooldir/.xkeys"); # extra download keys -mkdirp($lockdir = "$spooldir/.locks"); # download lock files + +$dkeydir = "$spooldir/.dkeys"; # download keys +$ukeydir = "$spooldir/.ukeys"; # upload keys +$akeydir = "$spooldir/.akeys"; # authentification keys +$skeydir = "$spooldir/.skeys"; # subuser authentification keys +$gkeydir = "$spooldir/.gkeys"; # group authentification keys +$xkeydir = "$spooldir/.xkeys"; # extra download keys +$lockdir = "$spooldir/.locks"; # download lock files if (my $ra = $ENV{REMOTE_ADDR} and $max_fail) { mkdirp("$spooldir/.fail"); @@ -143,16 +167,41 @@ 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") { + my $port = 80; + my $xinetd = '/etc/xinetd.d/fex'; + + if (@durl) { + $durl = $durl[0]; + } elsif ($ENV{HTTP_HOST} and $ENV{PROTO}) { + + ($host,$port) = split(':',$ENV{HTTP_HOST}||''); + $host = $hostname; + + unless ($port) { + $port = 80; + if (open $xinetd,$xinetd) { + while (<$xinetd>) { + if (/^\s*port\s*=\s*(\d+)/) { + $port = $1; + last; + } + } + 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"; + } else { + $durl = "$ENV{PROTO}://$host:$port/fop"; + } + } else { + if (open $xinetd,$xinetd) { while (<$xinetd>) { if (/^\s*port\s*=\s*(\d+)/) { $port = $1; @@ -161,16 +210,13 @@ unless ($durl) { } 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"; - } else { - $durl = "$ENV{PROTO}://$host:$port/fop"; + if ($port == 80) { + $durl = "http://$hostname/fop"; + } else { + $durl = "http://$hostname:$port/fop"; + } } } - @durl = ($durl) unless @durl; @@ -183,7 +229,7 @@ sub reexec { sub jsredirect { $url = shift; $cont = shift || 'request accepted: continue'; - + http_header('200 ok'); print html_header($head||$ENV{SERVER_NAME}); pq(qq( @@ -216,24 +262,24 @@ sub nvt_print { sub html_quote { local $_ = shift; - + s/&/&/g; s/' )); # '' - - if ($0 =~ /fexdev/) { $head .= "\n" } + + if ($0 =~ /fexdev/) { $head .= "\n" } else { $head .= "\n" } - + $title =~ s:F\*EX:F*EX:; if (open $header,'<',"$docdir/$header") { $head .= $_ while <$header>; close $header; } - + $head .= &$prolog($title) if defined($prolog); - + if (@H1_extra) { $head .= sprintf( '

%s

', @@ -306,7 +353,7 @@ sub html_header { $head .= "

$title

"; } $head .= "\n"; - + return $head; } @@ -316,14 +363,14 @@ sub html_error { my $msg = "@_"; my @msg = @_; my $isodate = isodate(time); - + $msg =~ s/[\s\n]+/ /g; $msg =~ s/<.+?>//g; # remove HTML map { s///gi } @msg; - + errorlog($msg); - - # cannot send standard HTTP Status-Code 400, because stupid + + # cannot send standard HTTP Status-Code 400, because stupid # Internet Explorer then refuses to display HTML body! http_header("666 Bad Request - $msg"); print html_header($error); @@ -342,12 +389,15 @@ 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(@_); - + # create special error file on upload if ($uid) { my $ukey = "$spooldir/.ukeys/$uid"; @@ -358,7 +408,7 @@ sub http_die { close $ukey; } } - + html_error($error||'',@_); } @@ -384,7 +434,7 @@ sub check_maint { sub check_status { my $user = shift; - + $user = lc $user; $user .= '@'.$mdomain if $mdomain and $user !~ /@/; @@ -415,7 +465,7 @@ sub encode_Q { my $s = shift; $s =~ s{([\=\x00-\x20\x7F-\xA0])}{sprintf("=%02X",ord($1))}eog; return $s; -} +} # from MIME::Base64::Perl @@ -442,13 +492,13 @@ sub decode_b64 { sub b64 { local $_ = ''; my $x = 0; - + pos($_[0]) = 0; $_ = join '',map(pack('u',$_)=~ /^.(\S*)/, ($_[0]=~/(.{1,45})/gs)); tr|` -_|AA-Za-z0-9+/|; $x = (3 - length($_[0]) % 3) % 3; s/.{$x}$//; - + return $_; } @@ -461,7 +511,7 @@ sub rmrf { my ($file,$dir); local *D; local $_; - + foreach (@files) { next if /(^|\/)\.\.$/; /(.*)/; $file = $1; @@ -507,7 +557,7 @@ sub gethostname { if ($hostname !~ /\./ and $admin and $admin =~ /\@([\w.-]+)/) { $hostname .= '.'.$1; } - + return $hostname; } @@ -515,10 +565,10 @@ sub gethostname { # strip off path names (Windows or UNIX) sub strip_path { local $_ = shift; - + s/.*\\// if /^([A-Z]:)?\\/; s:.*/::; - + return $_; } @@ -526,9 +576,9 @@ sub strip_path { # substitute all critcal chars sub normalize { local $_ = shift; - + return '' unless defined $_; - + # we need perl native utf8 (see perldoc utf8) $_ = decode_utf8($_) unless utf8::is_utf8($_); @@ -536,7 +586,7 @@ sub normalize { s/[\x00-\x1F\x80-\x9F]/_/g; s/^\s+//; s/\s+$//; - + return encode_utf8($_); } @@ -544,12 +594,12 @@ sub normalize { # substitute all critcal chars sub normalize_html { local $_ = shift; - + return '' unless defined $_; - + $_ = normalize($_); s/[\"<>]//g; - + return $_; } @@ -563,20 +613,20 @@ sub normalize_filename { # we need native utf8 $_ = decode_utf8($_) unless utf8::is_utf8($_); - + $_ = strip_path($_); - + # substitute all critcal chars with underscore s/[^a-zA-Z0-9_=.+-]/_/g; s/^\./_/; - + return encode_utf8($_); } sub normalize_email { local $_ = lc shift; - + s/[^\w_.+=!~#^\@\-]//g; s/^\./_/; /(.*)/; @@ -584,6 +634,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; @@ -594,7 +661,7 @@ sub untaint { sub checkchars { my $input = shift; local $_ = shift; - + if (/^([|+.])/) { http_die("\"$1\" is not allowed at beginning of $input"); } @@ -617,12 +684,14 @@ sub checkaddress { my $re; local $_; local ($domain,$dns); - + $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 ''; @@ -630,7 +699,7 @@ sub checkaddress { $re = '^[!^=~#_:.+*{}\w\-\[\]]+\@(\w[.\w\-]*\.[a-z]+)$'; if ($a =~ /$re/i) { $domain = $dns = $1; - { + { local $SIG{__DIE__} = sub { die "\n" }; eval q{ use Net::DNS; @@ -638,7 +707,7 @@ sub checkaddress { unless ($dns or mx('uni-stuttgart.de')) { http_die("Internal error: bad resolver"); } - } + } }; if ($dns) { return untaint($a); @@ -663,8 +732,7 @@ sub checkforbidden { return $a if -d "$spooldir/$a"; # ok, if user already exists if (@forbidden_recipients) { foreach (@forbidden_recipients) { - $fr = quotemeta; - $fr =~ s/\\\*/.*/g; # allow wildcard * + $fr = quotewild($_); # skip public recipients if (@public_recipients) { foreach $pr (@public_recipients) { @@ -680,10 +748,10 @@ sub checkforbidden { sub randstring { my $n = shift; - my @rc = ('A'..'Z','a'..'z',0..9 ); - my $rn = @rc; + my @rc = ('A'..'Z','a'..'z',0..9 ); + my $rn = @rc; my $rs; - + for (1..$n) { $rs .= $rc[int(rand($rn))] }; return $rs; } @@ -693,16 +761,16 @@ sub randstring { sub mkdirp { my $dir = shift; my $pdir; - + 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 - $!"); } } @@ -726,7 +794,7 @@ sub ipin { $ipe = lc(ipe($ip)); map { lc } @list; - + foreach $i (@list) { if ($ip =~ /\./ and $i =~ /\./ or $ip =~ /:/ and $i =~ /:/) { if ($i =~ /(.+)-(.+)/) { @@ -769,12 +837,12 @@ sub filename { chomp $filename; close $file; } - + unless ($filename) { $filename = $file; $filename =~ s:.*/::; } - + return $filename; } @@ -789,20 +857,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); } @@ -810,21 +874,25 @@ sub fdlog { sub debuglog { my $prg = $0; local $_; - + 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; + # http://perldoc.perl.org/perlunifaq.html#What-is-a-%22wide-character%22%3f # open $debuglog,'>>:encoding(UTF-8)',$debuglog or return; open $debuglog,'>>',$debuglog or return; + # binmode($debuglog,":utf8"); autoflush $debuglog 1; # printf {$debuglog} "\n### %s ###\n",isodate(time); } while ($_ = shift @_) { + $_ = encode_utf8($_) if utf8::is_utf8($_); s/\n*$/\n/; s/<.+?>//g; # remove HTML print {$debuglog} $_; @@ -836,22 +904,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; + + writelog('error.log',$msg); +} + + +sub writelog { + my $log = shift; + my $msg = shift; - 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; + foreach my $logdir (@logdir) { + if (open $log,'>>',"$logdir/$log") { + flock $log,LOCK_EX; + seek $log,0,SEEK_END; + print {$log} $msg; + close $log; + } } } @@ -886,11 +964,11 @@ sub qqq { my $q = "[\'\"]"; # quote delimiter chars " and ' # remove first newline and look for default indention - s/^(\«(\d+)?)?\n//; + s/^((\d+)?)?\n//; $i = ' ' x ($2||0); # remove trailing spaces at end - s/[ \t]*\»?$//; + s/[ \t]*?$//; @s = split "\n"; @@ -921,7 +999,9 @@ sub qqq { # print superquoted sub pq { my $H = STDOUT; + if (@_ > 1 and defined fileno $_[0]) { $H = shift } + binmode($H,':utf8'); print {$H} qqq(@_); } @@ -931,9 +1011,9 @@ 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") { while (<$qf>) { s/#.*//; @@ -941,9 +1021,10 @@ sub check_sender_quota { } close $qf; } - + 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,11 +1032,16 @@ 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; + } } } - + return($squota,int($du/1024/1024)); } @@ -967,7 +1053,7 @@ sub check_recipient_quota { my $du = 0; my ($file,$size); local $_; - + if (open my $qf,'<',"$recipient/\@QUOTA") { while (<$qf>) { s/#.*//; @@ -975,7 +1061,7 @@ sub check_recipient_quota { } close $qf; } - + foreach $file (glob "$recipient/*/*") { if (-f "$file/upload" and $size = readlink "$file/size") { $du += $size; @@ -983,7 +1069,7 @@ sub check_recipient_quota { $du += $size; } } - + return($rquota,int($du/1024/1024)); } @@ -1000,7 +1086,7 @@ sub getline { sub wcmatch { local $_ = shift; my $p = quotemeta shift; - + $p =~ s/\\\*/.*/g; $p =~ s/\\\?/./g; $p =~ s/\\\[/[/g; @@ -1009,7 +1095,7 @@ sub wcmatch { return /$p/; } - + sub logout { my $logout; if ($skey) { $logout = "/fup?logout=skey:$skey" } @@ -1029,7 +1115,7 @@ sub logout { # print data dump of global or local variables in HTML # input musst be a string, eg: '%ENV' sub DD { - my $v = shift; + my $v = shift; local $_; $n =~ s/.//; @@ -1039,7 +1125,7 @@ sub DD { s/\n$_\n\n"; } - + # make symlink sub mksymlink { my ($file,$link) = @_; @@ -1056,7 +1142,7 @@ sub copy { my $link; local $/; local $_; - + $to .= '/'.basename($from) if -d $to; if (defined($link = readlink $from)) { @@ -1070,7 +1156,7 @@ sub copy { eval $mod if $mod; print {$to} $_; close $to or http_die("internal error: $to - $!"); - if (my @s = stat($from)) { + if (my @s = stat($from)) { chmod $s[2],$to; utime @s[8,9],$to unless $mod; } @@ -1084,7 +1170,7 @@ sub slurp { my $file = shift; local $_; local $/; - + if (open $file,$file) { $_ = <$file>; close $file; @@ -1094,6 +1180,91 @@ 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"); + } + + binmode(STDIN,':raw'); + + 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 @@ -1102,13 +1273,14 @@ sub vhost { # memorized vhost? (default is in fex.ph) %vhost = split(':',$ENV{VHOST}) if $ENV{VHOST}; - + if (%vhost and $hh and $hh =~ s/^([\w\.-]+).*/$1/) { if ($vhost = $vhost{$hh} and -f "$vhost/lib/fex.ph") { $ENV{VHOST} = "$hh:$vhost"; # memorize vhost for next run $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"; } @@ -1128,41 +1300,55 @@ sub gpg_encrypt { my ($plain,$to,$keyring,$from) = @_; my ($pid,$pi,$po,$pe,$enc,$err); local $_; - + $pe = gensym; - + $pid = open3($po,$pi,$pe, "gpg --batch --trust-model always --keyring $keyring". " -a -e -r $bcc -r $to" ) or return; - - print {$po} $plain; + + print {$po} "\n",$plain,"\n"; close $po; - + $enc .= $_ while <$pi>; $err .= $_ while <$pe>; errorlog("($from --> $to) $err") if $err; - + close $pi; close $pe; waitpid($pid,0); - + return $enc; } +sub mtime { + my @s = stat(shift) or return; + return $s[9]; +} + + +# wildcard * to perl regexp +sub quotewild { + local $_ = quotemeta shift; + s/\\\*/.*/g; # allow wildcard * + return $_; +} + + # extract locale functions into hash of subroutine references # e.g. \&german ==> $notify{german} sub locale_functions { my $locale = shift; local $/; local $_; - + if ($locale and open my $fexpp,"$FEXHOME/locale/$locale/lib/fex.pp") { $_ = <$fexpp>; s/.*\n(\#\#\# locale functions)/$1/s; # sub xx {} ==> xx{$locale} = sub {} - s/\nsub (\w+)/\n\$$1\{$locale\} = sub/gs; + s/\nsub (\w+)/\n\$$1\{$locale\} = sub/gs; s/\n}\n/\n};\n/gs; eval $_; close $fexpp; @@ -1179,7 +1365,7 @@ sub notify_locale { $file = $dkey; $dkey = readlink("$file/dkey"); } else { - $file = readlink("$dkeydir/$dkey") + $file = readlink("$dkeydir/$dkey") or http_die("internal error: no DKEY $DKEY"); } $file =~ s:^../::; @@ -1189,13 +1375,13 @@ sub notify_locale { $mtime = mtime("$file/data") or http_die("internal error: no $file/data"); $comment = slurp("$file/comment") || ''; $replyto = readlink "$file/replyto" || ''; - $autodelete = readlink "$file/autodelete" - || readlink "$to/\@AUTODELETE" + $autodelete = readlink "$file/autodelete" + || readlink "$to/\@AUTODELETE" || $::autodelete; - $keep = readlink "$file/keep" - || readlink "$to/\@KEEP" + $keep = readlink "$file/keep" + || readlink "$to/\@KEEP" || $keep_default; - + $locale = readlink "$to/\@LOCALE" || readlink "$file/locale" || 'english'; $_ = untaint("$FEXHOME/locale/$locale/lib/lf.pl"); require if -f; @@ -1207,23 +1393,27 @@ 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, ); } -### locale functions ### -# will be extracted by install process and saved in $FEXHOME/lib/lf.pl -# you cannot modify them here without re-installing! +########################### locale functions ########################### +# Will be extracted by install process and saved in $FEXHOME/lib/lf.pl # +# You cannot modify them here without re-installing! # +######################################################################## +# locale function! 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}||''; @@ -1235,15 +1425,22 @@ sub notify { my ($body,$enc_body); return if $nomail; - + $warn = $P{warn}||2; - $comment = encode_utf8($P{comment}||''); + $comment = $P{comment}||''; + $comment = encode_utf8($P{comment}||'') if utf8::is_utf8($comment); $comment =~ s/^!\*!//; # multi download allow flag $autodelete = $P{autodelete}||$::autodelete; - $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 +1455,17 @@ 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."; + $warning = + "We recommend fexget or fexit for download,\n". + "because these clients can resume the download after an interruption.\n". + "See $proto://$hostname/tools.html"; + # if ($nowarning) { + # $warning = ''; + # } else { + # $warning = + # "Please avoid download with Internet Explorer, ". + # "because it has too many bugs.\n\n"; + # } if ($filename =~ /\.(tar|zip|7z|arj|rar)$/) { $warning .= "\n\n". "$filename is a container file.\n". @@ -1288,17 +1492,22 @@ 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); $fileid = @s ? $s[1].$s[9] : 0; } - + if ($P{status} eq 'new') { $days = $P{keep}; $header .= "Subject: F*EX-upload: $mimefilename\n"; @@ -1308,62 +1517,61 @@ 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"; } - $header .= + $header .= "X-FEX-Filesize: $bytes\n". "X-FEX-File-ID: $fileid\n". "X-FEX-Fexmaster: $ENV{SERVER_ADMIN}\n". "X-Mailer: F*EX\n". "MIME-Version: 1.0\n"; - if ($comment =~ s/^\[(\@(.*?))\]\s*//) { + if ($comment =~ s/^\[(\@(.*?))\]\s*//) { $receiver = "group $1"; if ($_ = readlink "$from/\@GROUP/$2" and m:^../../(.+?)/:) { $receiver .= " (maintainer: $1)"; } - } else { + } else { $receiver = 'you'; } if ($days == 1) { $days .= " day" } else { $days .= " days" } - + # explicite sender set in fex.ph? if ($sender_from) { map { s/^From: <$mfrom/From: <$sender_from/ } $header; open $sendmail,'|-',$sendmail,$mto,$bcc - or http_die("cannot start sendmail - $!\n"); + or http_die("cannot start sendmail - $!"); } else { - # for special remote domains do not use same domain in From, + # for special remote domains do not use same domain in From, # because remote MTA will probably reject this e-mail $dfrom = $1 if $mfrom =~ /@(.+)/; $dto = $1 if $mto =~ /@(.+)/; - if ($dfrom and $dto and @remote_domains and - grep { - $dfrom =~ /(^|\.)$_$/ and $dto =~ /(^|\.)$_$/ - } @remote_domains) + if ($dfrom and $dto and @remote_domains and + grep { + $dfrom =~ /(^|\.)$_$/ and $dto =~ /(^|\.)$_$/ + } @remote_domains) { $header =~ s/(From: <)\Q$mfrom\E(.*?)\n/$1$admin$2\nReply-To: $mfrom\n/; open $sendmail,'|-',$sendmail,$mto,$bcc - or http_die("cannot start sendmail - $!\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 - or (readlink "$to/\@NOTIFICATION"||'') =~ /short/i + $comment = "\n$comment\n" if $comment; + if ($comment =~ s/\n!(shortmail|\.)!\s*//i + or (readlink("$to/\@NOTIFICATION")||'') =~ /short/i ) { $body = qqq(qq( '$comment' - '' '$download' '$size' )); } else { - $comment = "Comment: $comment\n" if $comment; $disclaimer = slurp("$from/\@DISCLAIMER") || qqq(qq( '$warning' '' @@ -1372,8 +1580,9 @@ sub notify { '' 'Questions? ==> F*EX admin: $admin' )); - $disclaimer .= "\n" . $::disclaimer if $::disclaimer; + $disclaimer .= "\n$::disclaimer\n" if $::disclaimer; $body = qqq(qq( + '$comment' '$from has uploaded the file' ' "$filename"' '($size) for $receiver. Use' @@ -1381,12 +1590,12 @@ sub notify { '$download' 'to download this file within $days.' '' - '$comment' '$autodelete' '' '$disclaimer' )); } + $body =~ s/\n\n+/\n\n/g; if (-s $keyring) { $enc_body = gpg_encrypt($body,$to,$keyring,$from); } @@ -1417,30 +1626,32 @@ 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 $!)"); } +# locale function! sub reactivation { my ($expire,$user) = @_; my $fexsend = "$FEXHOME/bin/fexsend"; + my $reactivation = "$FEXLIB/reactivation.txt"; return if $nomail; - + if (-x $fexsend) { + if ($locale) { + my $lr = "$FEXHOME/locale/$locale/lib/reactivation.txt"; + $reactivation = $lr if -f $lr and -s $lr; + } $fexsend .= " -M -D -k 30 -C" ." 'Your F*EX account has been inactive for $expire days," ." you must download this file to reactivate it." ." Otherwise your account will be deleted.'" - ." $FEXLIB/reactivation.txt $user"; + ." $reactivation $user"; # on error show STDOUT and STDERR - system "$fexsend >/dev/null 2>&1"; - if ($?) { - warn "$fexsend\n"; - system $fexsend; - } + my $fo = `$fexsend 2>&1`; + warn $fexsend.'\n'.$fo if $?; } else { warn "$0: cannot execute $fexsend for reactivation()\n"; }