# -*- perl -*-
use 5.008;
+use utf8;
use Fcntl qw':flock :seek :mode';
use IO::Handle;
use IPC::Open3;
$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) {
$docdir = '/var/lib/fex/htdocs';
$notify_newrelease = '';
}
-
+
# allowed download managers (HTTP User-Agent)
$adlm = '^(Axel|fex)';
$keep = $keep_default ||= $keep || 5;
$fra = $ENV{REMOTE_ADDR} || '';
$sid = $ENV{SID} || '';
-
-mkdirp($dkeydir = "$spooldir/.dkeys"); # download keys
-mkdirp($ukeydir = "$spooldir/.ukeys"); # upload keys
-mkdirp($akeydir = "$spooldir/.akeys"); # authentification keys
-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");
my $host = '';
my $port = 80;
my $xinetd = '/etc/xinetd.d/fex';
-
+
if (@durl) {
$durl = $durl[0];
} elsif ($ENV{HTTP_HOST} and $ENV{PROTO}) {
-
+
($host,$port) = split(':',$ENV{HTTP_HOST}||'');
$host = $hostname;
-
+
unless ($port) {
$port = 80;
if (open $xinetd,$xinetd) {
close $xinetd;
}
}
-
+
# use same protocal as uploader for download
if ($ENV{PROTO} eq 'https' and $port == 443 or $port == 80) {
$durl = "$ENV{PROTO}://$host/fop";
sub jsredirect {
$url = shift;
$cont = shift || 'request accepted: continue';
-
+
http_header('200 ok');
print html_header($head||$ENV{SERVER_NAME});
pq(qq(
sub html_quote {
local $_ = shift;
-
+
s/&/&/g;
s/</</g;
s/\"/"/g;
-
+
return $_;
}
sub http_header {
-
+
my $status = shift;
my $msg = $status;
return if $HTTP_HEADER;
$HTTP_HEADER = $status;
-
+
$msg =~ s/^\d+\s*//;
nvt_print("HTTP/1.1 $status");
nvt_print("Server: fexsrv");
nvt_print("Expires: 0");
nvt_print("Cache-Control: no-cache");
- # http://en.wikipedia.org/wiki/Clickjacking
- nvt_print("X-Frame-Options: SAMEORIGIN");
if ($force_https) {
# https://www.owasp.org/index.php/HTTP_Strict_Transport_Security
- nvt_print("Strict-Transport-Security: max-age=2851200");
+ # https://scotthelme.co.uk/hsts-the-missing-link-in-tls/
+ nvt_print("Strict-Transport-Security: max-age=2851200; preload");
}
+ nvt_print($_) foreach(@extra_header);
if ($use_cookies) {
+ $akey = md5_hex("$from:$id") if $id and $from;
if ($akey) {
- nvt_print("Set-Cookie: akey=$akey; Max-Age=9999; Discard");
+ nvt_print("Set-Cookie: akey=$akey; path=/; Max-Age=9999; Discard");
}
# if ($skey) {
# nvt_print("Set-Cookie: skey=$skey; Max-Age=9999; Discard");
'</head>'
));
# '<!-- <style type="text/css">\@import "/fex.css";</style> -->'
-
- if ($0 =~ /fexdev/) { $head .= "<body bgcolor=\"pink\">\n" }
+
+ if ($0 =~ /fexdev/) { $head .= "<body bgcolor=\"pink\">\n" }
else { $head .= "<body>\n" }
-
+
$title =~ s:F\*EX:<a href="/index.html">F*EX</a>:;
if (open $header,'<',"$docdir/$header") {
$head .= $_ while <$header>;
close $header;
}
-
+
$head .= &$prolog($title) if defined($prolog);
-
+
if (@H1_extra) {
$head .= sprintf(
'<h1><a href="%s"><img align=center src="%s" border=0></a>%s</h1>',
$head .= "<h1>$title</h1>";
}
$head .= "\n";
-
+
return $head;
}
my $msg = "@_";
my @msg = @_;
my $isodate = isodate(time);
-
+
$msg =~ s/[\s\n]+/ /g;
$msg =~ s/<.+?>//g; # remove HTML
map { s/<script.*?>//gi } @msg;
-
+
errorlog($msg);
-
- # cannot send standard HTTP Status-Code 400, because stupid
+
+ # cannot send standard HTTP Status-Code 400, because stupid
# Internet Explorer then refuses to display HTML body!
http_header("666 Bad Request - $msg");
print html_header($error);
sub http_die {
-
+
# not in CGI mode
unless ($ENV{GATEWAY_INTERFACE}) {
warn "$0: @_\n"; # must not die, because of fex_cleanup!
return;
}
-
+
debuglog(@_);
-
+
# create special error file on upload
if ($uid) {
my $ukey = "$spooldir/.ukeys/$uid";
close $ukey;
}
}
-
+
html_error($error||'',@_);
}
sub check_status {
my $user = shift;
-
+
$user = lc $user;
$user .= '@'.$mdomain if $mdomain and $user !~ /@/;
my $s = shift;
$s =~ s{([\=\x00-\x20\x7F-\xA0])}{sprintf("=%02X",ord($1))}eog;
return $s;
-}
+}
# from MIME::Base64::Perl
sub b64 {
local $_ = '';
my $x = 0;
-
+
pos($_[0]) = 0;
$_ = join '',map(pack('u',$_)=~ /^.(\S*)/, ($_[0]=~/(.{1,45})/gs));
tr|` -_|AA-Za-z0-9+/|;
$x = (3 - length($_[0]) % 3) % 3;
s/.{$x}$//;
-
+
return $_;
}
my ($file,$dir);
local *D;
local $_;
-
+
foreach (@files) {
next if /(^|\/)\.\.$/;
/(.*)/; $file = $1;
if ($hostname !~ /\./ and $admin and $admin =~ /\@([\w.-]+)/) {
$hostname .= '.'.$1;
}
-
+
return $hostname;
}
# strip off path names (Windows or UNIX)
sub strip_path {
local $_ = shift;
-
+
s/.*\\// if /^([A-Z]:)?\\/;
s:.*/::;
-
+
return $_;
}
# substitute all critcal chars
sub normalize {
local $_ = shift;
-
+
return '' unless defined $_;
-
+
# we need perl native utf8 (see perldoc utf8)
$_ = decode_utf8($_) unless utf8::is_utf8($_);
s/[\x00-\x1F\x80-\x9F]/_/g;
s/^\s+//;
s/\s+$//;
-
+
return encode_utf8($_);
}
# substitute all critcal chars
sub normalize_html {
local $_ = shift;
-
+
return '' unless defined $_;
-
+
$_ = normalize($_);
s/[\"<>]//g;
-
+
return $_;
}
# we need native utf8
$_ = decode_utf8($_) unless utf8::is_utf8($_);
-
+
$_ = strip_path($_);
-
+
# substitute all critcal chars with underscore
s/[^a-zA-Z0-9_=.+-]/_/g;
s/^\./_/;
-
+
return encode_utf8($_);
}
sub normalize_email {
local $_ = lc shift;
-
+
s/[^\w_.+=!~#^\@\-]//g;
s/^\./_/;
/(.*)/;
sub normalize_user {
my $user = shift;
-
+
$user = lc(urldecode(despace($user)));
$user .= '@'.$mdomain if $mdomain and $user !~ /@/;
checkaddress($user) or http_die("$user is not a valid e-mail address");
sub checkchars {
my $input = shift;
local $_ = shift;
-
+
if (/^([|+.])/) {
http_die("\"$1\" is not allowed at beginning of $input");
}
my $re;
local $_;
local ($domain,$dns);
-
+
$a =~ s/:\w+=.*//; # remove options from address
-
+
return $a if $a eq 'anonymous';
$a .= '@'.$mdomain if $mdomain and $a !~ /@/;
$re = '^[!^=~#_:.+*{}\w\-\[\]]+\@(\w[.\w\-]*\.[a-z]+)$';
if ($a =~ /$re/i) {
$domain = $dns = $1;
- {
+ {
local $SIG{__DIE__} = sub { die "\n" };
eval q{
use Net::DNS;
unless ($dns or mx('uni-stuttgart.de')) {
http_die("Internal error: bad resolver");
}
- }
+ }
};
if ($dns) {
return untaint($a);
sub randstring {
my $n = shift;
- my @rc = ('A'..'Z','a'..'z',0..9 );
- my $rn = @rc;
+ my @rc = ('A'..'Z','a'..'z',0..9 );
+ my $rn = @rc;
my $rs;
-
+
for (1..$n) { $rs .= $rc[int(rand($rn))] };
return $rs;
}
sub mkdirp {
my $dir = shift;
my $pdir;
-
+
return if -d $dir;
$dir =~ s:/+$::;
http_die("cannot mkdir /") unless $dir;
$ipe = lc(ipe($ip));
map { lc } @list;
-
+
foreach $i (@list) {
if ($ip =~ /\./ and $i =~ /\./ or $ip =~ /:/ and $i =~ /:/) {
if ($i =~ /(.+)-(.+)/) {
chomp $filename;
close $file;
}
-
+
unless ($filename) {
$filename = $file;
$filename =~ s:.*/::;
}
-
+
return $filename;
}
sub debuglog {
my $prg = $0;
local $_;
-
+
return unless $debug and @_;
unless ($debuglog and fileno $debuglog) {
my $ddir = "$spooldir/.debug";
$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} $_;
sub writelog {
my $log = shift;
my $msg = shift;
-
+
foreach my $logdir (@logdir) {
if (open $log,'>>',"$logdir/$log") {
flock $log,LOCK_EX;
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";
# print superquoted
sub pq {
my $H = STDOUT;
+
if (@_ > 1 and defined fileno $_[0]) { $H = shift }
+ binmode($H,':utf8');
print {$H} qqq(@_);
}
my $du = 0;
my ($file,$size,%file,$data,$upload);
local $_;
-
+
if (open $qf,'<',"$sender/\@QUOTA") {
while (<$qf>) {
s/#.*//;
}
close $qf;
}
-
+
foreach $file (glob "*/$sender/*") {
$data = "$file/data";
$upload = "$file/upload";
}
}
}
-
+
return($squota,int($du/1024/1024));
}
my $du = 0;
my ($file,$size);
local $_;
-
+
if (open my $qf,'<',"$recipient/\@QUOTA") {
while (<$qf>) {
s/#.*//;
}
close $qf;
}
-
+
foreach $file (glob "$recipient/*/*") {
if (-f "$file/upload" and $size = readlink "$file/size") {
$du += $size;
$du += $size;
}
}
-
+
return($rquota,int($du/1024/1024));
}
sub wcmatch {
local $_ = shift;
my $p = quotemeta shift;
-
+
$p =~ s/\\\*/.*/g;
$p =~ s/\\\?/./g;
$p =~ s/\\\[/[/g;
return /$p/;
}
-
+
sub logout {
my $logout;
if ($skey) { $logout = "/fup?logout=skey:$skey" }
# print data dump of global or local variables in HTML
# input musst be a string, eg: '%ENV'
sub DD {
- my $v = shift;
+ my $v = shift;
local $_;
$n =~ s/.//;
s/</</g;
print "<pre>\n$_\n</pre>\n";
}
-
+
# make symlink
sub mksymlink {
my ($file,$link) = @_;
my $link;
local $/;
local $_;
-
+
$to .= '/'.basename($from) if -d $to;
if (defined($link = readlink $from)) {
eval $mod if $mod;
print {$to} $_;
close $to or http_die("internal error: $to - $!");
- if (my @s = stat($from)) {
+ if (my @s = stat($from)) {
chmod $s[2],$to;
utime @s[8,9],$to unless $mod;
}
my $file = shift;
local $_;
local $/;
-
+
if (open $file,$file) {
$_ = <$file>;
close $file;
my $data = '';
my $filename;
local $_;
-
+
if ($cl > 128*$MB) {
http_die("request too large");
}
-
+
+ binmode(STDIN,':raw');
+
foreach (split('&',$ENV{QUERY_STRING})) {
if (/(.+?)=(.*)/) { $PARAM{$1} = $2 }
else { $PARAM{$_} = $_ }
# memorized vhost? (default is in fex.ph)
%vhost = split(':',$ENV{VHOST}) if $ENV{VHOST};
-
+
if (%vhost and $hh and $hh =~ s/^([\w\.-]+).*/$1/) {
if ($vhost = $vhost{$hh} and -f "$vhost/lib/fex.ph") {
$ENV{VHOST} = "$hh:$vhost"; # memorize vhost for next run
my ($plain,$to,$keyring,$from) = @_;
my ($pid,$pi,$po,$pe,$enc,$err);
local $_;
-
+
$pe = gensym;
-
+
$pid = open3($po,$pi,$pe,
"gpg --batch --trust-model always --keyring $keyring".
" -a -e -r $bcc -r $to"
) or return;
-
- print {$po} $plain;
+
+ 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;
}
my $locale = shift;
local $/;
local $_;
-
+
if ($locale and open my $fexpp,"$FEXHOME/locale/$locale/lib/fex.pp") {
$_ = <$fexpp>;
s/.*\n(\#\#\# locale functions)/$1/s;
# sub xx {} ==> xx{$locale} = sub {}
- s/\nsub (\w+)/\n\$$1\{$locale\} = sub/gs;
+ s/\nsub (\w+)/\n\$$1\{$locale\} = sub/gs;
s/\n}\n/\n};\n/gs;
eval $_;
close $fexpp;
$file = $dkey;
$dkey = readlink("$file/dkey");
} else {
- $file = readlink("$dkeydir/$dkey")
+ $file = readlink("$dkeydir/$dkey")
or http_die("internal error: no DKEY $DKEY");
}
$file =~ s:^../::;
$mtime = mtime("$file/data") or http_die("internal error: no $file/data");
$comment = slurp("$file/comment") || '';
$replyto = readlink "$file/replyto" || '';
- $autodelete = readlink "$file/autodelete"
- || readlink "$to/\@AUTODELETE"
+ $autodelete = readlink "$file/autodelete"
+ || readlink "$to/\@AUTODELETE"
|| $::autodelete;
- $keep = readlink "$file/keep"
- || readlink "$to/\@KEEP"
+ $keep = readlink "$file/keep"
+ || readlink "$to/\@KEEP"
|| $keep_default;
-
+
$locale = readlink "$to/\@LOCALE" || readlink "$file/locale" || 'english';
$_ = untaint("$FEXHOME/locale/$locale/lib/lf.pl");
require if -f;
my ($body,$enc_body);
return if $nomail;
-
+
$warn = $P{warn}||2;
- $comment = encode_utf8($P{comment}||'');
+ $comment = $P{comment}||'';
+ $comment = encode_utf8($P{comment}||'') if utf8::is_utf8($comment);
$comment =~ s/^!\*!//; # multi download allow flag
$autodelete = $P{autodelete}||$::autodelete;
-
+
$file = untaint(readlink("$dkeydir/$P{dkey}"));
$file =~ s/^\.\.\///;
# make download protocal same as upload protocol
$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".
$mimefilename =~ s/ /_/g;
$mimefilename = '=?UTF-8?Q?'.$mimefilename.'?=';
}
- }
-
+ }
+
unless ($fileid = readlink("$dkeydir/$P{dkey}/id")) {
my @s = stat($data);
$fileid = @s ? $s[1].$s[9] : 0;
}
-
+
if ($P{status} eq 'new') {
$days = $P{keep};
$header .= "Subject: F*EX-upload: $mimefilename\n";
$header .= "X-FEX-URL: $durl\n" unless -s $keyring;
$download .= "$durl\n";
}
- $header .=
+ $header .=
"X-FEX-Filesize: $bytes\n".
"X-FEX-File-ID: $fileid\n".
"X-FEX-Fexmaster: $ENV{SERVER_ADMIN}\n".
"X-Mailer: F*EX\n".
"MIME-Version: 1.0\n";
- if ($comment =~ s/^\[(\@(.*?))\]\s*//) {
+ if ($comment =~ s/^\[(\@(.*?))\]\s*//) {
$receiver = "group $1";
if ($_ = readlink "$from/\@GROUP/$2" and m:^../../(.+?)/:) {
$receiver .= " (maintainer: $1)";
}
- } else {
+ } else {
$receiver = 'you';
}
if ($days == 1) { $days .= " day" }
else { $days .= " days" }
-
+
# explicite sender set in fex.ph?
if ($sender_from) {
map { s/^From: <$mfrom/From: <$sender_from/ } $header;
open $sendmail,'|-',$sendmail,$mto,$bcc
or http_die("cannot start sendmail - $!");
} else {
- # for special remote domains do not use same domain in From,
+ # for special remote domains do not use same domain in From,
# because remote MTA will probably reject this e-mail
$dfrom = $1 if $mfrom =~ /@(.+)/;
$dto = $1 if $mto =~ /@(.+)/;
- if ($dfrom and $dto and @remote_domains and
- grep {
- $dfrom =~ /(^|\.)$_$/ and $dto =~ /(^|\.)$_$/
- } @remote_domains)
+ if ($dfrom and $dto and @remote_domains and
+ grep {
+ $dfrom =~ /(^|\.)$_$/ and $dto =~ /(^|\.)$_$/
+ } @remote_domains)
{
$header =~ s/(From: <)\Q$mfrom\E(.*?)\n/$1$admin$2\nReply-To: $mfrom\n/;
open $sendmail,'|-',$sendmail,$mto,$bcc
or http_die("cannot start sendmail - $!");
}
}
- if ($comment =~ s/^!(shortmail|\.)!\s*//i
- 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'
''
''
'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'
'$download'
'to download this file within $days.'
''
- '$comment'
'$autodelete'
''
'$disclaimer'
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";
}
projects / fex.git / blobdiff