X-Git-Url: http://git.treefish.org/fex.git/blobdiff_plain/97b87610331f53e756d032ad21db786037f921a1..HEAD:/lib/fex.pp?ds=inline diff --git a/lib/fex.pp b/lib/fex.pp index bd7ed98..177baba 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; @@ -61,6 +62,18 @@ $fop_auth = 0; $mail_authid = 'yes'; $force_https = 0; $debug = 0; +@forbidden_user_agents = ('FDM'); + +# 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 @@ -71,7 +84,7 @@ if ($FHS) { $docdir = '/var/lib/fex/htdocs'; $notify_newrelease = ''; } - + # allowed download managers (HTTP User-Agent) $adlm = '^(Axel|fex)'; @@ -112,16 +125,17 @@ http_die("cannot determine the server hostname") unless $hostname; $ENV{PROTO} = 'http' unless $ENV{PROTO}; $keep = $keep_default ||= $keep || 5; +$purge ||= 3*$keep; $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"); @@ -161,14 +175,14 @@ unless ($durl) { my $host = ''; my $port = 80; my $xinetd = '/etc/xinetd.d/fex'; - + if (@durl) { $durl = $durl[0]; } elsif ($ENV{HTTP_HOST} and $ENV{PROTO}) { - + ($host,$port) = split(':',$ENV{HTTP_HOST}||''); $host = $hostname; - + unless ($port) { $port = 80; if (open $xinetd,$xinetd) { @@ -181,7 +195,7 @@ 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"; @@ -217,7 +231,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( @@ -250,24 +264,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

', @@ -340,7 +357,7 @@ sub html_header { $head .= "

$title

"; } $head .= "\n"; - + return $head; } @@ -350,14 +367,20 @@ 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 + + $SIG{ALRM} = sub { + $SIG{__DIE__} = 'DEFAULT'; + die "TIMEOUT\n"; + }; + alarm($timeout); + + # 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); @@ -376,15 +399,15 @@ sub html_error { sub http_die { - + # not in CGI mode unless ($ENV{GATEWAY_INTERFACE}) { warn "$0: @_\n"; # must not die, because of fex_cleanup! return; } - + debuglog(@_); - + # create special error file on upload if ($uid) { my $ukey = "$spooldir/.ukeys/$uid"; @@ -395,7 +418,7 @@ sub http_die { close $ukey; } } - + html_error($error||'',@_); } @@ -421,7 +444,7 @@ sub check_maint { sub check_status { my $user = shift; - + $user = lc $user; $user .= '@'.$mdomain if $mdomain and $user !~ /@/; @@ -452,7 +475,7 @@ sub encode_Q { my $s = shift; $s =~ s{([\=\x00-\x20\x7F-\xA0])}{sprintf("=%02X",ord($1))}eog; return $s; -} +} # from MIME::Base64::Perl @@ -479,13 +502,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 $_; } @@ -498,7 +521,7 @@ sub rmrf { my ($file,$dir); local *D; local $_; - + foreach (@files) { next if /(^|\/)\.\.$/; /(.*)/; $file = $1; @@ -544,7 +567,7 @@ sub gethostname { if ($hostname !~ /\./ and $admin and $admin =~ /\@([\w.-]+)/) { $hostname .= '.'.$1; } - + return $hostname; } @@ -552,10 +575,10 @@ sub gethostname { # strip off path names (Windows or UNIX) sub strip_path { local $_ = shift; - + s/.*\\// if /^([A-Z]:)?\\/; s:.*/::; - + return $_; } @@ -563,9 +586,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($_); @@ -573,7 +596,7 @@ sub normalize { s/[\x00-\x1F\x80-\x9F]/_/g; s/^\s+//; s/\s+$//; - + return encode_utf8($_); } @@ -581,12 +604,12 @@ sub normalize { # substitute all critcal chars sub normalize_html { local $_ = shift; - + return '' unless defined $_; - + $_ = normalize($_); s/[\"<>]//g; - + return $_; } @@ -600,20 +623,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/^\./_/; /(.*)/; @@ -623,7 +646,7 @@ 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"); @@ -648,7 +671,7 @@ sub untaint { sub checkchars { my $input = shift; local $_ = shift; - + if (/^([|+.])/) { http_die("\"$1\" is not allowed at beginning of $input"); } @@ -671,9 +694,9 @@ sub checkaddress { my $re; local $_; local ($domain,$dns); - + $a =~ s/:\w+=.*//; # remove options from address - + return $a if $a eq 'anonymous'; $a .= '@'.$mdomain if $mdomain and $a !~ /@/; @@ -686,7 +709,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; @@ -694,7 +717,7 @@ sub checkaddress { unless ($dns or mx('uni-stuttgart.de')) { http_die("Internal error: bad resolver"); } - } + } }; if ($dns) { return untaint($a); @@ -735,10 +758,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; } @@ -748,7 +771,7 @@ sub randstring { sub mkdirp { my $dir = shift; my $pdir; - + return if -d $dir; $dir =~ s:/+$::; http_die("cannot mkdir /") unless $dir; @@ -781,7 +804,7 @@ sub ipin { $ipe = lc(ipe($ip)); map { lc } @list; - + foreach $i (@list) { if ($ip =~ /\./ and $i =~ /\./ or $ip =~ /:/ and $i =~ /:/) { if ($i =~ /(.+)-(.+)/) { @@ -824,12 +847,12 @@ sub filename { chomp $filename; close $file; } - + unless ($filename) { $filename = $file; $filename =~ s:.*/::; } - + return $filename; } @@ -861,7 +884,7 @@ sub fdlog { sub debuglog { my $prg = $0; local $_; - + return unless $debug and @_; unless ($debuglog and fileno $debuglog) { my $ddir = "$spooldir/.debug"; @@ -871,12 +894,15 @@ sub debuglog { $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} $_; @@ -906,7 +932,7 @@ sub errorlog { sub writelog { my $log = shift; my $msg = shift; - + foreach my $logdir (@logdir) { if (open $log,'>>',"$logdir/$log") { flock $log,LOCK_EX; @@ -948,11 +974,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"; @@ -983,7 +1009,9 @@ sub qqq { # print superquoted sub pq { my $H = STDOUT; + if (@_ > 1 and defined fileno $_[0]) { $H = shift } + binmode($H,':utf8'); print {$H} qqq(@_); } @@ -995,7 +1023,7 @@ sub check_sender_quota { my $du = 0; my ($file,$size,%file,$data,$upload); local $_; - + if (open $qf,'<',"$sender/\@QUOTA") { while (<$qf>) { s/#.*//; @@ -1003,7 +1031,7 @@ sub check_sender_quota { } close $qf; } - + foreach $file (glob "*/$sender/*") { $data = "$file/data"; $upload = "$file/upload"; @@ -1023,7 +1051,7 @@ sub check_sender_quota { } } } - + return($squota,int($du/1024/1024)); } @@ -1035,7 +1063,7 @@ sub check_recipient_quota { my $du = 0; my ($file,$size); local $_; - + if (open my $qf,'<',"$recipient/\@QUOTA") { while (<$qf>) { s/#.*//; @@ -1043,7 +1071,7 @@ sub check_recipient_quota { } close $qf; } - + foreach $file (glob "$recipient/*/*") { if (-f "$file/upload" and $size = readlink "$file/size") { $du += $size; @@ -1051,7 +1079,7 @@ sub check_recipient_quota { $du += $size; } } - + return($rquota,int($du/1024/1024)); } @@ -1068,7 +1096,7 @@ sub getline { sub wcmatch { local $_ = shift; my $p = quotemeta shift; - + $p =~ s/\\\*/.*/g; $p =~ s/\\\?/./g; $p =~ s/\\\[/[/g; @@ -1077,7 +1105,7 @@ sub wcmatch { return /$p/; } - + sub logout { my $logout; if ($skey) { $logout = "/fup?logout=skey:$skey" } @@ -1097,7 +1125,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/.//; @@ -1107,7 +1135,7 @@ sub DD { s/\n$_\n\n"; } - + # make symlink sub mksymlink { my ($file,$link) = @_; @@ -1124,7 +1152,7 @@ sub copy { my $link; local $/; local $_; - + $to .= '/'.basename($from) if -d $to; if (defined($link = readlink $from)) { @@ -1138,7 +1166,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; } @@ -1152,7 +1180,7 @@ sub slurp { my $file = shift; local $_; local $/; - + if (open $file,$file) { $_ = <$file>; close $file; @@ -1196,11 +1224,13 @@ sub parse_parameters { 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{$_} = $_ } @@ -1253,7 +1283,7 @@ 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 @@ -1280,25 +1310,25 @@ 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; } @@ -1323,12 +1353,12 @@ 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; @@ -1345,7 +1375,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:^../::; @@ -1355,13 +1385,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; @@ -1405,12 +1435,13 @@ 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; - + $file = untaint(readlink("$dkeydir/$P{dkey}")); $file =~ s/^\.\.\///; # make download protocal same as upload protocol @@ -1434,14 +1465,17 @@ sub notify { $data = "$dkeydir/$P{dkey}/data"; $size = $bytes = -s $data; return unless $size; - if ($nowarning) { - $warning = ''; - } else { - $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". @@ -1477,13 +1511,13 @@ sub notify { $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"; @@ -1498,37 +1532,37 @@ sub notify { $header .= "X-FEX-URL: $durl\n" unless -s $keyring; $download .= "$durl\n"; } - $header .= + $header .= "X-FEX-Filesize: $bytes\n". "X-FEX-File-ID: $fileid\n". "X-FEX-Fexmaster: $ENV{SERVER_ADMIN}\n". "X-Mailer: F*EX\n". "MIME-Version: 1.0\n"; - if ($comment =~ s/^\[(\@(.*?))\]\s*//) { + if ($comment =~ s/^\[(\@(.*?))\]\s*//) { $receiver = "group $1"; if ($_ = readlink "$from/\@GROUP/$2" and m:^../../(.+?)/:) { $receiver .= " (maintainer: $1)"; } - } else { + } else { $receiver = 'you'; } if ($days == 1) { $days .= " day" } else { $days .= " days" } - + # explicite sender set in fex.ph? if ($sender_from) { map { s/^From: <$mfrom/From: <$sender_from/ } $header; open $sendmail,'|-',$sendmail,$mto,$bcc or http_die("cannot start sendmail - $!"); } else { - # for special remote domains do not use same domain in From, + # for special remote domains do not use same domain in From, # because remote MTA will probably reject this e-mail $dfrom = $1 if $mfrom =~ /@(.+)/; $dto = $1 if $mto =~ /@(.+)/; - if ($dfrom and $dto and @remote_domains and - grep { - $dfrom =~ /(^|\.)$_$/ and $dto =~ /(^|\.)$_$/ - } @remote_domains) + if ($dfrom and $dto and @remote_domains and + grep { + $dfrom =~ /(^|\.)$_$/ and $dto =~ /(^|\.)$_$/ + } @remote_domains) { $header =~ s/(From: <)\Q$mfrom\E(.*?)\n/$1$admin$2\nReply-To: $mfrom\n/; open $sendmail,'|-',$sendmail,$mto,$bcc @@ -1538,17 +1572,16 @@ sub notify { 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' '' @@ -1557,8 +1590,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' @@ -1566,7 +1600,6 @@ sub notify { '$download' 'to download this file within $days.' '' - '$comment' '$autodelete' '' '$disclaimer' @@ -1612,21 +1645,23 @@ sub notify { 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"; }