# -*- perl -*- use 5.008; use Fcntl qw':flock :seek :mode'; use IO::Handle; use IPC::Open3; use Encode; use Digest::MD5 qw'md5_hex'; use File::Basename; use Sys::Hostname; 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{PATH} = '/usr/local/bin:/bin:/usr/bin'; $ENV{IFS} = " \t\n"; $ENV{BASH_ENV} = ''; } unless ($FEXLIB = $ENV{FEXLIB} and -d $FEXLIB) { die "$0: found no FEXLIB - fexsrv needs full path\n" } $FEXLIB =~ s:/+:/:g; $FEXLIB =~ s:/$::; # $FEXHOME is top-level directory of F*EX installation or vhost # $ENV{HOME} is login-directory of user fex # in default-installation both are equal, but they may differ $FEXHOME = $ENV{FEXHOME} or $ENV{FEXHOME} = $FEXHOME = dirname($FEXLIB); umask 077; # defaults $hostname = gethostname(); $tmpdir = $ENV{TMPDIR} || '/var/tmp'; $spooldir = $FEXHOME.'/spool'; $docdir = $FEXHOME.'/htdocs'; $logdir = $spooldir; $autodelete = 'YES'; $overwrite = 'YES'; $limited_download = 'YES'; # multiple downloads only from same client $keep = 5; # days $recipient_quota = 0; # MB $sender_quota = 0; # MB $timeout = 30; # seconds $bs = 2**16; # I/O blocksize $use_cookies = 1; $sendmail = '/usr/lib/sendmail'; $sendmail = '/usr/sbin/sendmail' unless -x $sendmail; $mailmode = 'auto'; $bcc = 'fex'; $default_locale = ''; $fop_auth = 0; $mail_authid = 'yes'; $force_https = 0; $debug = 0; $FHS = -f '/etc/fex/fex.ph' and -d '/usr/share/fex/lib'; # Debian FHS if ($FHS) { $ENV{FEXHOME} = $FEXHOME = '/usr/share/fex'; $spooldir = '/var/spool/fex'; $logdir = '/var/log/fex'; $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 - $!"; $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; # check for name based virtual host $vhost = vhost($ENV{'HTTP_HOST'}); 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("cannot determine the server hostname") unless $hostname; $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 if (my $ra = $ENV{REMOTE_ADDR} and $max_fail) { mkdirp("$spooldir/.fail"); $faillog = "$spooldir/.fail/$ra"; } unless ($admin) { $admin = $ENV{SERVER_ADMIN} ? $ENV{SERVER_ADMIN} : 'fex@'.$hostname; } # $ENV{SERVER_ADMIN} may be set empty in fex.ph! $ENV{SERVER_ADMIN} = $admin unless defined $ENV{SERVER_ADMIN}; $mdomain ||= ''; if ($use_cookies) { if (my $cookie = $ENV{HTTP_COOKIE}) { if ($cookie =~ /\bakey=(\w+)/) { $akey = $1 } # elsif ($cookie =~ /\bskey=(\w+)/) { $skey = $1 } } } if (@locales) { if ($default_locale and not grep /^$default_locale$/,@locales) { push @locales,$default_locale; } if (@locales == 1) { $default_locale = $locales[0]; } } $default_locale ||= 'english'; 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; } } 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"; } } @durl = ($durl) unless @durl; sub reexec { exec($FEXHOME.'/bin/fexsrv') if $ENV{KEEP_ALIVE}; exit; } sub jsredirect { $url = shift; $cont = shift || 'request accepted: continue'; http_header('200 ok'); print html_header($head||$ENV{SERVER_NAME}); pq(qq( '' '' '' )); &reexec; } sub debug { print header(),"
\n";
  print "file = $file\n";
  foreach $v (keys %ENV) {
    print $v,' = "',$ENV{$v},"\"\n";
  }
  print "

\n"; } sub nvt_print { foreach (@_) { syswrite STDOUT,"$_\r\n" } } sub html_quote { local $_ = shift; s/&/&/g; s/' '' ' ' ' ' ' $title' '' )); # '' 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

', $H1_extra[0],$H1_extra[1]||'',$title ); } else { $head .= "

$title

"; } $head .= "\n"; return $head; } sub html_error { my $error = shift; 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 # Internet Explorer then refuses to display HTML body! http_header("666 Bad Request - $msg"); print html_header($error); print 'ERROR: ',join("

\n",@msg),"\n"; pq(qq( '


' '

' $ENV{HTTP_HOST}' ' $isodate' ' $ENV{SERVER_ADMIN}' '
' '' )); exit; } sub http_die { # not in CGI mode die "$0: @_\n" unless $ENV{GATEWAY_INTERFACE}; debuglog(@_); # create special error file on upload if ($uid) { my $ukey = "$spooldir/.ukeys/$uid"; $ukey .= "/error" if -d $ukey; unlink $ukey; if (open $ukey,'>',$ukey) { print {$ukey} join("\n",@_),"\n"; close $ukey; } } html_error($error||'',@_); } sub check_maint { if (my $status = readlink '@MAINTENANCE') { my $isodate = isodate(time); http_header('666 MAINTENANCE'); print html_header($head||''); pq(qq( "
" "

Server is in maintenance mode

" "

($status)

" "
" "


" "

$ENV{HTTP_HOST} $isodate
" "" )); exit; } } sub check_status { my $user = shift; $user = lc $user; $user .= '@'.$mdomain if $mdomain and $user !~ /@/; if (-e "$user/\@DISABLED") { my $isodate = isodate(time); http_header('666 DISABLED'); print html_header($head); pq(qq( "

$user is disabled

" "Contact $ENV{SERVER_ADMIN} for details" "


" "

$ENV{HTTP_HOST} $isodate
" "" )); exit; } } sub isodate { my @d = localtime shift; return sprintf('%d-%02d-%02d %02d:%02d:%02d', $d[5]+1900,$d[4]+1,$d[3],$d[2],$d[1],$d[0]); } sub encode_Q { my $s = shift; $s =~ s{([\=\x00-\x20\x7F-\xA0])}{sprintf("=%02X",ord($1))}eog; return $s; } # from MIME::Base64::Perl sub decode_b64 { local $_ = shift; my $uu = ''; my ($i,$l); tr|A-Za-z0-9+=/||cd; s/=+$//; tr|A-Za-z0-9+/| -_|; return '' unless length; $l = (length)-60; for ($i = 0; $i <= $l; $i += 60) { $uu .= "M" . substr($_,$i,60); } $_ = substr($_,$i); $uu .= chr(32+(length)*3/4) . $_ if $_; return unpack ("u",$uu); } # short base64 encoding 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 $_; } # simulate a "rm -rf", but never removes '..' # return number of removed files sub rmrf { my @files = @_; my $dels = 0; my ($file,$dir); local *D; local $_; foreach (@files) { next if /(^|\/)\.\.$/; /(.*)/; $file = $1; if (-d $file and not -l $file) { $dir = $file; opendir D,$dir or next; while ($file = readdir D) { next if $file eq '.' or $file eq '..'; $dels += rmrf("$dir/$file"); } closedir D; rmdir $dir and $dels++; } else { unlink $file and $dels++; } } return $dels; } sub gethostname { my $hostname = hostname; my $domain; local $_; unless ($hostname) { $_ = `hostname 2>/dev/null`; $hostname = /(.+)/ ? $1 : ''; } if ($hostname !~ /\./ and open my $rc,'/etc/resolv.conf') { while (<$rc>) { if (/^\s*domain\s+([\w.-]+)/) { $domain = $1; last; } if (/^\s*search\s+([\w.-]+)/) { $domain = $1; } } close $rc; $hostname .= ".$domain" if $domain; } 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/[\r\n\t]+/ /g; 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 $_; } # substitute all critcal chars with underscore sub normalize_filename { local $_ = shift; return $_ unless $_; # 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/^\./_/; /(.*)/; return $1; } sub untaint { local $_ = shift; /(.*)/s; return $1; } sub checkchars { my $input = shift; local $_ = shift; if (/^([|+.])/) { http_die("\"$1\" is not allowed at beginning of $input"); } if (/([\/\"\'\\<>;])/) { http_die(sprintf("\"&#%s;\" is not allowed in %s",ord($1),$input)); } if (/(\|)$/) { http_die("\"$1\" is not allowed at end of $input"); } if (/[\000-\037]/) { http_die("control characters are not allowed in $input"); } /(.*)/; return $1; } sub checkaddress { my $a = shift; my $re; local $_; local ($domain,$dns); $a =~ s/:\w+=.*//; # remove options from address return $a if $a eq 'anonymous'; $re = '^[.@]|@.*@|local(host|domain)$|["\'\`\|\s()<>/;,]'; if ($a =~ /$re/i) { debuglog("$a has illegal syntax ($re)"); return ''; } $re = '^[!^=~#_:.+*{}\w\-\[\]]+\@(\w[.\w\-]*\.[a-z]+)$'; if ($a =~ /$re/i) { $domain = $dns = $1; { local $SIG{__DIE__} = sub { die "\n" }; eval q{ use Net::DNS; $dns = Net::DNS::Resolver->new->query($domain)||mx($domain); unless ($dns or mx('uni-stuttgart.de')) { http_die("Internal error: bad resolver"); } } }; if ($dns) { return untaint($a); } else { debuglog("no A or MX DNS record found for $domain"); return ''; } } else { debuglog("$a does not match e-mail regexp ($re)"); return ''; } } # check forbidden addresses sub checkforbidden { my $a = shift; my ($fr,$pr); local $_; $a .= '@'.$mdomain if $mdomain and $a !~ /@/; return $a if -d "$spooldir/$a"; # ok, if user already exists if (@forbidden_recipients) { foreach (@forbidden_recipients) { $fr = quotemeta; $fr =~ s/\\\*/.*/g; # allow wildcard * # skip public recipients if (@public_recipients) { foreach $pr (@public_recipients) { return $a if $a eq lc $pr; } } return '' if $a =~ /^$fr$/i; } } return $a; } sub randstring { my $n = shift; my @rc = ('A'..'Z','a'..'z',0..9 ); my $rn = @rc; my $rs; for (1..$n) { $rs .= $rc[int(rand($rn))] }; return $rs; } # emulate mkdir -p sub mkdirp { my $dir = shift; my $pdir; return if -d $dir; $dir =~ s:/+$::; http_die("cannot mkdir /\n") unless $dir; $pdir = $dir; if ($pdir =~ s:/[^/]+$::) { mkdirp($pdir) unless -d $pdir; } unless (-d $dir) { mkdir $dir,0770 or http_die("mkdir $dir - $!\n"); } } # hash with SID sub sidhash { my ($rid,$id) = @_; if ($rid and $ENV{SID} and $id =~ /^MD5H:/) { $rid = 'MD5H:'.md5_hex($rid.$ENV{SID}); } return $rid; } # test if ip is in iplist (ipv4/ipv6) # iplist is an array with ips and ip-ranges sub ipin { my ($ip,@list) = @_; my ($i,$ia,$ib); $ipe = lc(ipe($ip)); map { lc } @list; foreach $i (@list) { if ($ip =~ /\./ and $i =~ /\./ or $ip =~ /:/ and $i =~ /:/) { if ($i =~ /(.+)-(.+)/) { ($ia,$ib) = ($1,$2); $ia = ipe($ia); $ib = ipe($ib); return $ip if $ipe ge $ia and $ipe le $ib; } else { return $ip if $ipe eq ipe($i); } } } return ''; } # ip expand (ipv4/ipv6) sub ipe { local $_ = shift; if (/^\d+\.\d+\.\d+\.\d+$/) { s/\b(\d\d?)\b/sprintf "%03d",$1/ge; } elsif (/^[:\w]+:\w+$/) { s/\b(\w+)\b/sprintf "%04s",$1/ge; s/^:/0000:/; while (s/::/::0000:/) { last if length > 39 } s/::/:/; } else { $_ = ''; } return $_; } sub filename { my $file = shift; my $filename; if (open $file,'<',"$file/filename") { $filename = <$file>||''; chomp $filename; close $file; } unless ($filename) { $filename = $file; $filename =~ s:.*/::; } return $filename; } sub urlencode { local $_ = shift; s/(^[.~]|[^\w.,=:~^+-])/sprintf "%%%X",ord($1)/ge; return $_; } # 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; } } # extra debug log sub debuglog { my $prg = $0; local $_; return unless $debug and @_; unless ($debuglog and fileno $debuglog) { mkdir "$logdir/.debug",0770 unless -d "$logdir/.debug"; $prg =~ s:.*/::; $prg = untaint($prg); $debuglog = sprintf("%s/.debug/%s_%s_%s.%s", $logdir,time,$$,$ENV{REQUESTCOUNT}||0,$prg); $debuglog =~ s/\s/_/g; # open $debuglog,'>>:encoding(UTF-8)',$debuglog or return; open $debuglog,'>>',$debuglog or return; autoflush $debuglog 1; # printf {$debuglog} "\n### %s ###\n",isodate(time); } while ($_ = shift @_) { s/\n*$/\n/; s/<.+?>//g; # remove HTML print {$debuglog} $_; print "DEBUG: $_" if -t; } } # extra debug log sub errorlog { my $prg = $0; my $log = "$logdir/error.log"; my $msg = "@_"; $prg =~ s:.*/::; $msg =~ s/[\r\n]+$//; $msg =~ s/[\r\n]+/ /; $msg =~ s/\s*

.*//; 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; } } # failed authentification log sub faillog { my $request = shift; my $n = 1; if ($faillog and $max_fail_handler and open $faillog,"+>>$faillog") { flock($faillog,LOCK_EX); seek $faillog,0,SEEK_SET; $n++ while <$faillog>; printf {$faillog} "%s %s\n",isodate(time),$request; close $faillog; &$max_fail_handler($ENV{REMOTE_ADDR}) if $n > $max_fail; } } # remove all white space sub despace { local $_ = shift; s/\s//g; return $_; } # superquoting sub qqq { local $_ = shift; my ($s,$i,@s); my $q = "[\'\"]"; # quote delimiter chars " and ' # remove first newline and look for default indention s/^(\«(\d+)?)?\n//; $i = ' ' x ($2||0); # remove trailing spaces at end s/[ \t]*\»?$//; @s = split "\n"; # first line have a quote delimiter char? if (/^\s+$q/) { # remove heading spaces and delimiter chars foreach (@s) { s/^\s*$q//; s/$q\s*$//; } } else { # find the line with the fewest heading spaces (and count them) # (beware of tabs!) $s = length; foreach (@s) { if (/^( *)\S/ and length($1) < $s) { $s = length($1) }; } # adjust indention foreach (@s) { s/^ {$s}/$i/; } } return join("\n",@s)."\n"; } # print superquoted sub pq { my $H = STDOUT; if (@_ > 1 and defined fileno $_[0]) { $H = shift } print {$H} qqq(@_); } # check sender quota sub check_sender_quota { my $sender = shift; my $squota = $sender_quota||0; my $du = 0; my ($file,$size,%file,$data); local $_; if (open $qf,'<',"$sender/\@QUOTA") { while (<$qf>) { s/#.*//; $squota = $1 if /sender.*?(\d+)/i; } close $qf; } foreach $file (glob "*/$sender/*") { $data = "$file/data"; if (not -l $data and $size = -s $data) { # count hard links only once (= same inode) my $i = (stat($data))[1]||0; unless ($file{$i}) { $du += $size; $file{$i} = $i; } } elsif (-f "$file/upload" and $size = readlink "$file/size") { $du += $size; } } return($squota,int($du/1024/1024)); } # check recipient quota sub check_recipient_quota { my $recipient = shift; my $rquota = $recipient_quota||0; my $du = 0; my ($file,$size); local $_; if (open my $qf,'<',"$recipient/\@QUOTA") { while (<$qf>) { s/#.*//; $rquota = $1 if /recipient.*?(\d+)/i; } close $qf; } foreach $file (glob "$recipient/*/*") { if (-f "$file/upload" and $size = readlink "$file/size") { $du += $size; } elsif (not -l "$file/data" and $size = -s "$file/data") { $du += $size; } } return($rquota,int($du/1024/1024)); } sub getline { my $file = shift; local $_; chomp($_ = <$file>||''); return $_; } # (shell) wildcard matching sub wcmatch { local $_ = shift; my $p = quotemeta shift; $p =~ s/\\\*/.*/g; $p =~ s/\\\?/./g; $p =~ s/\\\[/[/g; $p =~ s/\\\]/]/g; return /$p/; } sub logout { my $logout; if ($skey) { $logout = "/fup?logout=skey:$skey" } elsif ($gkey) { $logout = "/fup?logout=gkey:$gkey" } elsif ($akey) { $logout = "/fup?logout=akey:$akey" } else { $logout = "/fup?logout" } return qqq(qq( '

' '

' ' ' '
' '

' )); } # print data dump of global or local variables in HTML # input musst be a string, eg: '%ENV' sub DD { my $v = shift; local $_; $n =~ s/.//; $_ = eval(qq(use Data::Dumper;Data::Dumper->Dump([\\$v]))); s/\$VAR1/$v/; s/&/&/g; s/\n$_\n\n"; } # make symlink sub mksymlink { my ($file,$link) = @_; unlink $file; return symlink untaint($link),$file; } # copy file (and modify) or symlink # returns chomped file contents or link name # preserves permissions and time stamps sub copy { my ($from,$to,$mod) = @_; my $link; local $/; local $_; $to .= '/'.basename($from) if -d $to; if (defined($link = readlink $from)) { mksymlink($to,$link); return $link; } else { open $from,'<',$from or return; open $to,'>',$to or return; $_ = <$from>; close $from; eval $mod if $mod; print {$to} $_; close $to or http_die("internal error: $to - $!"); if (my @s = stat($from)) { chmod $s[2],$to; utime @s[8,9],$to unless $mod; } chomp; return $_; } } sub slurp { my $file = shift; local $_; local $/; if (open $file,$file) { $_ = <$file>; close $file; } return $_; } # name based virtual host? sub vhost { my $hh = shift; # HTTP_HOST my $vhost; my $locale = $ENV{LOCALE}; # 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"; if ($locale and -e "$vhost/locale/$locale/lib/fex.ph") { $ENV{FEXLIB} = $FEXLIB = "$vhost/locale/$locale/lib"; } require "$FEXLIB/fex.ph" or die "$0: cannot load $FEXLIB/fex.ph - $!"; $ENV{SERVER_NAME} = $hostname; @doc_dirs = ($docdir); foreach my $ld (glob "$FEXHOME/locale/*/htdocs") { push @doc_dirs,$ld; } return $vhost; } } } 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; close $po; $enc .= $_ while <$pi>; $err .= $_ while <$pe>; errorlog("($from --> $to) $err") if $err; close $pi; close $pe; waitpid($pid,0); return $enc; } # 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/\n}\n/\n};\n/gs; eval $_; close $fexpp; } } sub notify_locale { my $dkey = shift; my $status = shift || 'new'; my ($to,$keep,$locale,$file,$filename,$comment,$autodelete,$replyto,$mtime); local $_; if ($dkey =~ m:/.+/.+/:) { $file = $dkey; $dkey = readlink("$file/dkey"); } else { $file = readlink("$dkeydir/$dkey") or http_die("internal error: no DKEY $DKEY"); } $file =~ s:^../::; $filename = filename($file); $to = $file; $to =~ 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; $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; unless ($notify{$locale}) { $locale = 'english'; $notify{$locale} ||= \¬ify; } return &{$notify{$locale}}( status => $status, dkey => $dkey, filename => $filename, 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! 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 ($mfrom,$mto,$dfrom,$dto); my $index; my $fileid = 0; my $fua = $ENV{HTTP_USER_AGENT}||''; my $warning = ''; my $disclaimer = ''; my $download = ''; my $keyring; my $boundary = randstring(16); my ($body,$enc_body); return if $nomail; $warn = $P{warn}||2; $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}"))); $filename = strip_path($P{filename}); $mfrom = $from; $mto = $to; $mfrom .= '@'.$mdomain if $mdomain and $mfrom !~ /@/; $mto .= '@'.$mdomain if $mdomain and $mto !~ /@/; $keyring = $to.'/@GPG'; # $to = '' if $to eq $from; # ??? $replyto = $P{replyto}||$mfrom; $header = "From: <$mfrom> ($mfrom via F*EX service $hostname)\n"; $header .= "Reply-To: <$replyto>\n" if $replyto ne $mfrom; $header .= "To: <$mto>\n"; $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 ($filename =~ /\.(tar|zip|7z|arj|rar)$/) { $warning .= "\n\n". "$filename is a container file.\n". "You can unpack it for example with 7zip ". "(http://www.7-zip.org/download.html)"; } if ($limited_download =~ /^y/i) { $warning .= "\n\n". 'This download link only works for you, you cannot distribute it.'; } if ($size < 2048) { $size = "$size Bytes"; } elsif ($size/1024 < 2048) { $size = int($size/1024)." kB"; } else { $size = int($size/1024/1024)." MB"; } if ($autodelete eq 'YES') { $autodelete = "WARNING: After download (or view with a web browser!), " . "the file will be deleted!"; } elsif ($autodelete eq 'DELAY') { $autodelete = "WARNING: When you download the file it will be deleted " . "soon afterwards!"; } else { $autodelete = ''; } $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"; } else { $days = $warn; $header .= "Subject: reminder F*EX-upload: $mimefilename\n"; } $header .= "X-FEX-Client-Address: $fra\n" if $fra; $header .= "X-FEX-Client-Agent: $fua\n" if $fua; foreach my $u (@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 .= "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*//) { $receiver = "group $1"; if ($_ = readlink "$from/\@GROUP/$2" and m:^../../(.+?)/:) { $receiver .= " (maintainer: $1)"; } } 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"); } else { # 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) { $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"); } else { open $sendmail,'|-',$sendmail,'-f',$mfrom,$mto,$bcc or http_die("cannot start sendmail - $!\n"); } } if ($comment =~ s/^!(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' '' 'F*EX is not an archive, it is a transfer system for personal files.' 'For more information see $index' '' 'Questions? ==> F*EX admin: $admin' )); $disclaimer .= "\n" . $::disclaimer if $::disclaimer; $body = qqq(qq( '$from has uploaded the file' ' "$filename"' '($size) for $receiver. Use' '' '$download' 'to download this file within $days.' '' '$comment' '$autodelete' '' '$disclaimer' )); } if (-s $keyring) { $enc_body = gpg_encrypt($body,$to,$keyring,$from); } if ($enc_body) { # RFC3156 $header .= qqq(qq( 'Content-Type: multipart/encrypted; protocol="application/pgp-encrypted";' '\tboundary="$boundary"' 'Content-Disposition: inline' )); $body = qqq(qq( '--$boundary' 'Content-Type: application/pgp-encrypted' 'Content-Disposition: attachment' '' 'Version: 1' '' '--$boundary' 'Content-Type: application/octet-stream' 'Content-Disposition: inline; filename="fex.pgp"' '' '$enc_body' '--$boundary--' )); } else { $header .= "Content-Type: text/plain; charset=UTF-8\n". "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; } sub reactivation { my ($expire,$user) = @_; my $fexsend = "$FEXHOME/bin/fexsend"; return if $nomail; if (-x $fexsend) { $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"; # on error show STDOUT and STDERR system "$fexsend >/dev/null 2>&1"; if ($?) { warn "$fexsend\n"; system $fexsend; } } else { warn "$0: cannot execute $fexsend for reactivation()\n"; } } 1;