#  -*- perl -*-

use 5.010;
# use utf8;
use Encode;
use Symbol qw(gensym);
use Cwd qw(abs_path);
use Fcntl qw(:flock :seek :mode);
use IO::Handle;
use IPC::Open3;
use Digest::MD5 qw(md5_hex);
# use Digest::SHA qw(hmac_sha512 hmac_sha512_base64);
use File::Basename;
use Sys::Hostname;
use Scalar::Util qw(tainted);

# set and untaint ENV if not in CLI (fexsrv provides clean ENV)
unless (-t) {
  foreach my $v (keys %ENV) {
    ($ENV{$v}) = ($ENV{$v} =~ /(.*)/s) if defined $ENV{$v};
  }
  $ENV{PATH}     = $ENV{HOME}.'/bin:/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);
$RA = $ENV{REMOTE_ADDR} || 0;

umask 0077;

$| = 1;
binmode(STDOUT,':raw');
binmode(STDIN,':raw');

# 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
$fex_yourself = 'YES';	        # allow SENDER = RECIPIENT
$keep_default = 5;		# days
$keep_max = 99;
$recipient_quota = 0; 		# MB
$sender_quota = 0;    		# MB
$timeout = 30;	 		# seconds
$bs = 2**16;		 	# I/O blocksize (64 kB)
$DS = 60*60*24;			# seconds in a day
$MB = 1024*1024;		# binary Mega
$vp = '\d{8}_\d{6}';		# date_time version pattern # should be: $vrx
$arx = 'tar|tgz|zip|7z|gz';	# archive container regexp
$mrx = '[\w!^=~#_:.*+-]+\@\w[\w.-]*\.[a-zA-Z]+'; # mail regexp
$sendmail = '/usr/lib/sendmail';
$sendmail = '/usr/sbin/sendmail' unless -x $sendmail;
$mailmode = 'auto';
$bcc = 'fex';
$default_locale = '';
$charset = 'UTF-8';
$fop_auth = 0;
$mail_authid = 'YES';
$archive_sharing = 'NO';
$document_exchange = 'NO';
$fex_sender = 'NO';
$share_logging = 1;
$force_https = 0;
$debug = 0;
## $enforce_EUCD = 'NO';
@forbidden_user_agents = ('FDM');

# https://securityheaders.io/
# https://scotthelme.co.uk/hardening-your-http-response-headers/
# https://scotthelme.co.uk/a-new-security-header-referrer-policy/
# http://content-security-policy.com/
@extra_header = (
  # "Content-Security-Policy: sandbox allow-forms allow-scripts",
  "Content-Security-Policy: script-src 'self' 'unsafe-inline'",
  "Referrer-Policy: origin-when-cross-origin",
  "X-Frame-Options: SAMEORIGIN",
  "X-XSS-Protection: 1; mode=block",
  "X-Content-Type-Options: nosniff",
);
push @extra_header,'X-Epoch: '.time();

$style = slurp("$FEXLIB/style.css") || qqq(qq(
  'ul {'
  '  list-style: disc outside none;'
  '  padding: 0px 0px 0px 15px;'
  '  margin: 0;'
  '}'
  'table {'
  '  border-collapse: collapse;'
  '}'
  'table, th, td {'
# '  border-width: 1px;'
# '  border-color: black;'
# '  border-style: solid;'
# '  border: 1px solid black;'
  '  padding: 3px;'
  '}'
));

$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)';

# local config
require "$FEXLIB/fex.ph" or die "$0: cannot load $FEXLIB/fex.ph - $!";

$ENV{FEXSERVER} = $hostname;

$keep_default = $keep if $keep;	# backward compatibilty to older fex.ph
## $enforce_EUCD = 0 if $enforce_EUCD !~ /y/i;

chdir $spooldir or die "$spooldir - $!\n";

$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;
$archive_sharing	= 0 if $archive_sharing		=~ /no/i;
$document_exchange	= 0 if $document_exchange	=~ /no/i;
$share_logging   	= 0 if $share_logging   	=~ /no/i;
$fex_sender  		= 0 if $fex_sender		=~ /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;
}

$nomail = ($mailmode =~ /^MANUAL|nomail$/i);

if (not $nomail and not -x $sendmail) {
  http_die("found no sendmail");
}
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} || '';

$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

unless (-d $akeydir) {
  mkdir $akeydir or http_die("$akeydir - $!");
}

if ($RA and $max_fail) {
  mkdirp("$spooldir/.fail");
  $faillog = "$spooldir/.fail/$RA";
}

# $ENV{SERVER_ADMIN} may be set empty in fex.ph!
$admin ||= $ENV{SERVER_ADMIN} || 'fex@'.$hostname;
$ENV{SERVER_ADMIN} ||= $admin;

$mdomain ||= '';

if (my $cookie = $ENV{HTTP_COOKIE}) {
  if ($cookie =~ /\bakey=(\w+)/ and -f "$akeydir/$1/@") {
    $akey = $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';

# $durl is first default fop download URL
# @durl is optional mandatory fop download URL list (from fex.ph)
unless ($durl) {
  my $host = '';
  my $port = 80;
  my $xinetd = '/etc/xinetd.d/fex';

  if (@durl) {
    if ($ENV{PROTO} eq 'https') {
      ($durl) = grep /https:/,@durl;
    } else {
      $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;
          last;
        }
      }
      close $xinetd;
    }
    if ($port == 80) {
      $durl = "http://$hostname/fop";
    } else {
      $durl = "http://$hostname:$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(
    '<script type="text/javascript">'
    '  window.location.replace("$url");'
    '</script>'
    '<noscript>'
    '  <h3><a href="$url">$cont</a></h3>'
    '</noscript>'
    '</body></html>'
  ));
  &reexec;
}


sub debug {
  print header(),"<pre>\n";
  print "file = $file\n";
  foreach $v (keys %ENV) {
    print $v,' = "',$ENV{$v},"\"\n";
  }
  print "</pre><p>\n";
}


sub ssplit {
  local $_ = "@_";
  return split;
};


sub nvt_print {
  local $_;
  foreach (@_) {
    my $x = $_;
    $x = encode_utf8($x) if utf8::is_utf8($x);
    syswrite STDOUT,"$x\r\n";
  }
}


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("X-Message: $msg");
  # nvt_print("X-SID: $ENV{SID}") if $ENV{SID};
  nvt_print("Server: fexsrv");
  nvt_print("Expires: 0");
  nvt_print("Cache-Control: no-cache");
  if ($force_https) {
    # https://www.owasp.org/index.php/HTTP_Strict_Transport_Security
    # 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 ($from and $id and not $akey and my $rid = readline1("$from/@")) {
    $akey = genakey($from) if $id eq $rid;
  }
  if ($akey and -l "$akeydir/$akey") {
    my $login = basename(readlink("$akeydir/$akey"));
    nvt_print("Set-Cookie: akey=$akey; path=/; Max-Age=44444; Discard");
    nvt_print("Set-Cookie: login=$login; path=/");
  }
  # if ($skey) {
  #   nvt_print("Set-Cookie: skey=$skey; Max-Age=9999; Discard");
  # }
  if ($locale) {
    nvt_print("Set-Cookie: locale=$locale");
  }
  unless (grep /^Content-Type:/i,@_) {
    # nvt_print("Content-Type: text/html; charset=ISO-8859-1");
    nvt_print("Content-Type: text/html; charset=$charset");
  }

  nvt_print(@_,'');
}


sub html_header {
  my $title = shift;
  my $header = 'header.html';
  my $fua = $ENV{HTTP_USER_AGENT}||'';
  my $head;
  my $h1;

  # binmode(STDOUT,':utf8'); # for text/html !

  $h1 = $title;
  $title =~ s/<.*?>//g;
  $style =~ s/\n+$//;

  # http://www.w3.org/TR/html401/struct/global.html
  # http://www.w3.org/International/O-charset
  if ($fua =~ /^fex/) {
    $head = "<html><body>\n";
  } else {
    $head = qqq(qq(
      '<html>'
      '<head>'
      '  <meta http-equiv="expires" content="0">'
      '  <meta http-equiv="Content-Type" content="text/html;charset=$charset">'
      '  <title>$title</title>'
      '</head>'
      '<style>'
      '$style'
      '</style>'
    ));
    # '<!-- <style type="text/css">\@import "/fex.css";</style> -->'

    if ($0 =~ /fexdev/) { $head .= "<body bgcolor=\"pink\">\n" }
    else                { $head .= "<body>\n" }

    $h1 =~ 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(
        qq'<h1><a href="%s"><img align=center src="%s" border=0></a>%s</h1>\n',
        $H1_extra[0],$H1_extra[1]||'',$h1
      );
    } else {
      $head .= "<h1>$h1</h1>\n";
    }

    $head .= qqq(qq(
      '<font color="red">'
      '<h2 id="jswarning">PLEASE ENABLE JAVASCRIPT TO USE THIS SERVICE</h2>'
      '</font>'
      '<script>'
      'document.getElementById("jswarning").innerHTML = "";'
      '</script>'
      ''
    ));
  }

  # Safari does not show popups (javascript window.open)
#  if (($ENV{HTTP_USER_AGENT}||'') =~ /Apple.*Safari/) {
#    $head .= qqq(qq(
#      '<font color="orange">'
#      '<h2>Your webbrowser (Safari) is not supported</h2>'
#      '</font>'
#    ));
#  }

  return $head;
}


sub http_error {
  my $error = shift;
  my $msg = shift;
  my $URL = $ENV{REQUEST_URL}||'';
  my $URI = $ENV{REQUEST_URI}||'';
  my $isodate = isodate(time);

  $URI =~ s/\?.*//;

  if ($error eq 400) {
    http_error_header("400 Bad Request");
    nvt_print("Your request $URL is not acceptable.");
  } elsif ($error eq 403) {
    http_error_header("403 Forbidden");
    if ($msg) {
      nvt_print($msg);
    } else {
      nvt_print("You have no permission to request $URL");
    }
  } elsif ($error eq 404) {
    http_error_header("404 Not Found");
    nvt_print("The requested URI $URI was not found on this server.");
  } elsif ($error eq 413) {
    http_error_header("413 Payload Too Large");
    nvt_print("Your HTTP header is too large.");
  } elsif ($error eq 416) {
    http_error_header("416 Requested Range Not Satisfiable");
  } elsif ($error eq 503) {
    http_error_header("503 Service Unavailable");
    # nvt_print("No Perl ipv6 support on this server.");
  } else {
    http_error_header("555 Unknown Error");
    nvt_print("The requested URL $URL produced an internal error.");
  }
  pq(qq(
    '<p><hr><p>'
    '$isodate<br>'
    '$ENV{HTTP_HOST}<p>'
    '<address>'
    '  <a href="mailto:$admin">$admin</a>'
    '</address>'
    '</body></html>'
  ));
  exit;
}


sub http_error_header {
  my $error = shift;
  my $uri = $ENV{REQUEST_URI};

  errorlog("$uri ==> $error") if $uri;
  nvt_print(
    "HTTP/1.1 $error",
    "Connection: close",
    "Content-Type: text/html; charset=iso-8859-1",
    "",
    '<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">',
    "<html>",
    "<head><title>$error</title></head>",
    "<body>",
    "<h1>$error</h1>",
  );
}


sub html_error {
  my $error = shift;
  my $msg = "@_";
  my @msg = @_;
  my $isodate = isodate(time);
  local $_;

  $x = encode_utf8($msg) if utf8::is_utf8($msg);
  $msg =~ s/[\s\n]+/ /g;
  $msg =~ s/<.+?>//g; # remove HTML
  foreach (@msg) {
    $_ = encode_utf8($_) if utf8::is_utf8($_);
    s/<script.*?>//gi;
  }

  errorlog($msg);

  $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);
  print 'ERROR: ',join("<p>\n",@msg),"\n";
  pq(qq(
    '<p><hr><p>'
    '$isodate<br>'
    '$ENV{HTTP_HOST}<p>'
    '<address>'
    '  <a href="mailto:$admin">$admin</a>'
    '</address>'
    '</body></html>'
  ));
  exit;
}


sub http_die {

  # not in CGI mode
  unless ($ENV{GATEWAY_INTERFACE}) {
    warn "$0: @_\n"; # must not die, because of fex_cleanup!
    return;
  }

  debuglog("die: @_");

  # 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(
      "<center>"
      "<h1>Server is in maintenance mode</h1>"
      "<h3>($status)</h3>"
      "</center>"
      "<p><hr><p>"
      "<address>"
      "Contact: $admin<br>"
      "$ENV{HTTP_HOST} $isodate"
      "</address>"
      "</body></html>"
    ));
    exit;
  }
}


sub check_status {
  my $user = shift;

  $user = lc $user;
  $user .= '@'.$mdomain if $mdomain and $user !~ /@/;

  if (my $disabled = slurp("$user/\@DISABLED")) {
    if ($disabled =~ s/^!//) {
      $disabled = "$user is disabled: $disabled";
    } else {
      $disabled = "$user is disabled";
    }
    my $isodate = isodate(time);
    http_header('666 DISABLED');
    print html_header($head);
    pq(qq(
      "<h3>$disabled</h3>"
      "Contact $admin for details"
      "<p><hr><p>"
      "<address>$ENV{HTTP_HOST} $isodate</address>"
      "</body></html>"
    ));
    exit;
  }
}


sub isodate {
  my $time = shift;
  my $isodate = '????-??-?? ??:??:??';

  if ($time) {
    my @d = localtime $time;
    $isodate = sprintf('%d-%02d-%02d %02d:%02d:%02d',
                       $d[5]+1900,$d[4]+1,$d[3],$d[2],$d[1],$d[0]);
  }

  return $isodate;
}



sub genakey {
  my $user = shift;
  my $fua = $ENV{HTTP_USER_AGENT}||'';
  my $akey;

  $akey = $ENV{AKEY} || randstring(16);
  if ($fua !~ /^fex/) {
    unlink "$akeydir/$akey";
    symlink "../$user","$akeydir/$akey";
  }
  return $akey;
}


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 $_;
}


# a secure "rm -rf":
#   never remove '.' or '..'
#   restricted to $spooldir
#   returns number of deleted objects
sub rmrf {
  my @files = @_;
  my @caller;
  my $spool = untaint(abs_path($spooldir));
  my ($file,$dir);
  my $n = 0;
  local $_;

  @caller = caller(1) or @caller = caller;

  foreach $file (@files) {
    next unless lstat $file;
    my $afile = abs_path($file)||'';
    if ($file =~ m:^/: and $afile !~ m:^\Q$spool/: or
        $afile eq $spool or "/$file/" =~ m:\Q/../:)
    {
      http_die(
        sprintf "rmrf() called by %s::%s() line %s with illegal '%s'",
                $caller[1],$caller[3]||'',$caller[2],$file
      );
    }
    if (tainted($file)) {
      http_die(
        sprintf "rmrf() called by %s::%s() line %s with tainted '%s'",
                $caller[1],$caller[3]||'',$caller[2],$file
      );
    }
  }

  foreach $file (@files) {
    if (lstat $file) {
      system qw'rm -rf',$file;
      $n++ unless lstat $file;
    }
  }

  return $n;
}

## does not work because of UTF8 vs ISO-Latin filenames :-(
# sub rmrf {
#   my @files = @_;
#   my $dels = 0;
#   my @caller = caller(0);
#   my $spool = untaint(abs_path($spooldir));
#   my ($file,$dir);
#   local $_;
#
#   foreach $file (@files) {
#     next unless lstat $file;
#     my $afile = abs_path($file)||'';
#     if ($file =~ m:^/: and $afile !~ m:^\Q$spool/:
#         or $afile eq $spool or "/$file/" =~ m:\Q/../:)
#     {
#       http_die(
#         sprintf "rmrf() called by %s::%s() line %s with illegal '%s'",
#                 $caller[1],$caller[3],$caller[2],$file
#       );
#     }
#     if (tainted($file)) {
#       http_die(
#         sprintf "rmrf() called by %s::%s() line %s with tainted '%s'",
#                 $caller[1],$caller[3],$caller[2],$file
#       );
#     }
#     if (-d $file and not -l $file) {
#       $dir = $file;
#       opendir $dir,$dir or next;
#       while (defined(my $file = readdir $dir)) {
#         next if $file eq '.' or $file eq '..';
#         if ($charset =~ /utf/i) {
#           $file = untaint(decode_utf8($file));
#         } else {
#           $file = untaint($file);
#         }
#         $dels += rmrf("$dir/$file");
#       }
#       closedir $dir;
#       rmdir $dir and $dels++;
#     } else {
#       unlink $file and $dels++;
#     }
#   }
#   return $dels;
# }


# remove recursive files matching regular expression
# return number of removed files
sub rmrx {
  my $rx = shift;
  my @files = @_;
  my $dels = 0;
  my @caller;
  my $spool = untaint(abs_path($spooldir));
  local $_;

  @caller = caller(1) or @caller = caller;

  foreach (@files) {
    if (tainted($_)) {
      http_die(
        sprintf "rmrx() called by %s::%s() line %s with tainted '%s'",
                $caller[1],$caller[3]||'',$caller[2],$_
      );
    }
    if (m:^/: and abs_path($_) !~ m:^\Q$spool/:) {
      http_die(
        sprintf "rmrx() called by %s::%s() line %s with illegal '%s'",
                $caller[1],$caller[3]||'',$caller[2],$_
      );
    }
    $_ = untaint(abs_path('.')) if $_ eq '.';
    next if /(^|\/)\.\.?$/;
    if (-d and not -l) {
      my $dir = $_;
      if (basename($dir) =~ /$rx/) {
        $dels += rmrf($dir);
      } else {
        opendir $dir,$dir or next;
        while (defined(my $file = readdir $dir)) {
          next if $file eq '.' or $file eq '..';
          $dels += rmrx($rx,"$dir/".untaint($file));
        }
        closedir $dir;
      }
    } else {
      if (basename($_) =~ /$rx/) {
        unlink($_) and $dels++;
      }
    }
  }
  return $dels;
}


# remove recursive non-regular files (symlinks, etc)
sub doxunweed {
  my $dir = shift;
  my @caller;
  my $spool = untaint(abs_path($spooldir));
  local $_;

  @caller = caller(1) or @caller = caller;

  $dir = untaint(abs_path('.')) if $dir eq '.';

  if (tainted($dir)) {
    http_die(
      sprintf "doxunweed() called by %s::%s() line %s with tainted '%s'",
              $caller[1],$caller[3]||'',$caller[2],$dir
    );
  }
  $dir = untaint(abs_path($dir));
  if ($dir !~ m:^\Q$spool\E/.+\@.+/DOX/.+:) {
    http_die(
      sprintf "doxunweed() called by %s::%s() line %s with illegal '%s'",
              $caller[1],$caller[3]||'',$caller[2],$dir
    );
  }
  if (opendir $dir,$dir) {
    while (defined(my $file = readdir $dir)) {
      next if $file eq '.' or $file eq '..';
      my $dfile = untaint("$dir/$file");
      if (-l $dfile) {
        unlink $dfile;
      } elsif (-d $dfile) {
        doxunweed($dfile) if $file ne '.fexdox';
      } elsif (not -f $dfile) {
        unlink $dfile;
      }
    }
    closedir $dir;
  }
}


# rename recursive files matching regular expression
# substitute character is '_'
sub rrrx {
  my $rx = shift;
  my @files = @_;
  local $_;

  foreach (@files) {
    if (-d and not -l) {
      my $dir = $_;
      opendir $dir,$dir or next;
      while (defined(my $file = readdir $dir)) {
        next if $file eq '.' or $file eq '..';
        $file = untaint($file);
        rrrx($rx,"$dir/$file");
      }
      closedir $dir;
    } else {
      my $bname = basename($_);
      my $dname = dirname($_);
      $bname = s/$rx/_/g;
      if ($_ ne "$dname/$bname") {
        rename $_,"$dname/$bname";
      }
    }
  }
}


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 $_;
}


sub searchpath {
  my $prg = shift;
  my @PATH = split(':',$ENV{PATH});

  if ($prg =~ m:/:) {
    return $prg if -x $prg and -f $prg;
    return '';
  }

  foreach my $path (@PATH) {
    return $prg if -x "$path/$prg" and -f "$path/$prg";
  }

  return '';
}


# substitute all critical 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;

  # we need native utf8
  $_ = decode_utf8($_) unless utf8::is_utf8($_);

  $_ = strip_path($_);

  # substitute all critcal chars with underscore
  s/^\./_/;
  s/[:&<>\$\`\|\\]/_/g;
  s/[^a-z_\d@^~.,=+-]/_/gi;

  return encode_utf8(untaint($_));
}


sub normalize_email {
  local $_ = lc shift;

  s/[^\w_.+=!~#^\@\-]//g;
  s/^\./_/;
  /(.*)/;
  return $1;
}


sub normalize_user {
  my $user = shift;

  $user = lc(urldecode(despace($user)));
  $user .= '@'.$mdomain if $mdomain and $user !~ /@/;
  $user =~ s:/:_:g;
  checkaddress($user) or http_die("$user is not a valid email address");
  return untaint($user);
}


sub untaint {
  local $_ = shift;

  if (defined $_) {
    /(.*)/s;
    return $1;
  } else {
    @x = caller;
    die "untaint() @x";
  }
}


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';

  $a .= '@'.$mdomain if $mdomain and $a !~ /@/;

  $re = '^[.@-]|@.*@|local(host|domain)$|[(){}<>/;,*?&"`\'\s\[\]\|\\\\]';
  if ($a =~ /$re/i) {
    debuglog("$a has illegal syntax ($re)");
    return '';
  }

  if ($a !~ /.\@[\w.-]+$/) {
    debuglog("$a is not an email-address");
    return '';
  }

  if ($a =~ /[\x00-\x20\x7f]/) {
    debuglog("$a has non-printable character");
    return '';
  }

  if ($a =~ /[\xa0-\xff]/) {
    debuglog("$a has 8-bit character");
    return '';
  }

  return $a if not $checkaddress or $checkaddress =~ /n/i;

  $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 email 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 = quotewild($_);
      # 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;

  unless (-d $dir) {
    $dir =~ s:/+$::;
    if (length($dir)) {
      mkdirp(dirname($dir));
      mkdir $dir,0770 or http_die("mkdir $dir - $!");
    } else {
      http_die("cannot mkdir /");
    }
  }
}


# 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;
}


# emulate a "find $dir"
sub find {
  my $dir = shift;
  my @files = ();
  local $_;

  if (opendir $dir,$dir) {
    while (defined($_ = readdir $dir)) {
      next if /^\.\.?$/;
      my $df = "$dir/$_";
      push @files,$df;
      push @files,find($df) if -d $df and not -l $df;
    }
    closedir $dir;
  }
  return @files;
}


sub hexencode {
  local $_ = shift;
  s/%/%25/g;
  s/([^!-~])/sprintf "%%%X",ord($1)/ige;
  return $_;
}


sub hexdecode {
  local $_ = shift;
  s/%([a-f0-9]{2})/chr(hex($1))/ige;
  return $_;
}


sub urlencode {
  local $_ = shift;
#  $_ = encode_utf8($_) if utf8::is_utf8($_);
  s/(^[.~]|[^\d\/a-z_@.,=:~^+-])/sprintf "%%%X",ord($1)/ige;
  return $_;
}


sub urldecode {
  local $_ = shift;
  s/%([a-f0-9]{2})/chr(hex($1))/gie;
  return $_;
}


sub htmlencode {
  local $_ = shift;
  s/&/&amp;/g;
  s/</&lt;/g;
  return $_;
}


sub htmlquote {
  local $_ = shift;
  s/&/&amp;/g;
  s/</&lt;/g;
  s/\"/&quot;/g;
  s/\'/&apos;/g;
  return $_;
}


# shell pattern to Perl regular expression
sub shp2prx {
  local $_ = shift;
  s:([^\w\[\]^/*?-]):\\$1:g;
  s:([^*])\*([^*]):$1\[^/\]*$2:g;
  s:([^*])\*$:$1\[^/\]*:;
  s:^\*([^*]):[^/]*$1:;
  s:\*\*:.*:g;
  s:\?:.:g;
  return $_;
}


# file archive sharing log
sub faslog {
  my $shared = shift;
  my $msg = "@_";
  my $log = "$shared/log";

  # do not log special share _
  return if basename($shared) eq '_';

  $msg =~ s/\n/ /g;
  $msg =~ s/\s+$//;
  $msg = sprintf "%s %s %s\n",isodate(time),$RA,$msg;

  if ($share_logging and open $log,'>>',$log) {
    flock $log,LOCK_EX;
    seek $log,0,SEEK_END;
    printf {$log} $msg;
    close $log;
  }
}


# file and document log
sub fdlog {
  my ($log,$file,$s,$size) = @_;
  my $ra = $RA||'-';
  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);
}


# extra (debug) log
sub xdbglog {
  my @caller;
  my $log = '/tmp/fex.log';
  if (open $log,'>>',$log) {
    @caller = caller(1) or @caller = caller;
    printf {$log} "%s %s::%s() line %s:\n",
                  isodate(time),$caller[1],$caller[3]||'',$caller[2];
    print  {$log} "@_\n";
    close $log;
  }
}


sub debuglog {
  my $prg = $0;
  local $_;

  return unless $debug and @_;
  unless ($debuglog and fileno $debuglog) {
    my $ddir = "$spooldir/.debug";
    mkdir $ddir,0770 unless -d $ddir;
    $prg =~ s:.*/::;
    $prg = untaint($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 # can be <COMMENT>!
    print {$debuglog} $_;
    print "DEBUG: $_" if -t;
  }
}


# extra debug log
sub errorlog {
  my $prg = $0;
  my $msg = "@_";
  my $ra = $RA||'-';

  $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*<p>.*//;
  $msg = sprintf "%s %s %s %s\n",isodate(time),$prg,$ra,$msg;

  writelog('error.log',$msg);
}


sub writelog {
  my $log = shift;
  my $msg = shift;

  $msg = encode_utf8($msg) if utf8::is_utf8($msg);

  foreach my $logdir (@logdir) {
    if (open $log,'>>',"$logdir/$log") {
      flock $log,LOCK_EX;
      seek $log,0,SEEK_END;
      print {$log} $msg;
      close $log;
    }
  }
}


# failed authentification log
sub faillog {
  my $request = shift;
  my $n = 1;

  if ($RA and $faillog 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;
    if ($max_fail and $n > $max_fail and
        not ($ENV{HTTP_X_FORWARDED_FOR}||$ENV{HTTP_VIA}) and
        ($ENV{HTTP_USER_AGENT}||'') !~ /^fex/)
    {
      if ($max_fail_handler) {
        &$max_fail_handler($RA);
      } else {
        http_die(
          "Too many login failures from $RA : IP BLOCKED",
          "Contact $admin for details."
        );
      }
    }
  }
}

# remove all white space
sub despace {
  local $_ = shift;
  s/\s//g;
  return $_;
}


# superquoting
sub qqq {
  local $_ = shift;
  my ($s,@s);
  my $i = '';
  my $q = "[\'\"]"; # quote delimiter chars " and '

  # remove comment
  while (s/\n#.*?\n/\n/) {}

  # remove first newline and look for default indention
  s/^((\d+)?)?\n// and $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;
  local $_;

  if (@_ > 1 and defined fileno $_[0]) { $H = shift }
  $_ = qqq(@_);
  # print needs need binary data, not wide characters
  ## binmode($H,':utf8'); # does not work correctly
  $_ = encode_utf8($_) if utf8::is_utf8($_);
  print {$H} $_;
}


# print needs need binary data, not wide characters
sub printb {
  local $_;

  foreach (@_) {
    print utf8::is_utf8($_) ? encode_utf8($_) : $_;
  }
}


# check sender quota
sub check_sender_quota {
  my $sender = shift;
  my $squota = $sender_quota||0;
  my $du = 0;
  my ($file,$size,%file,$data,$upload,$share);
  local $_;

  if (open $qf,'<',"$spooldir/$sender/\@QUOTA") {
    while (<$qf>) {
      s/#.*//;
      $squota = $1 if /sender.*?(\d+)/i;
    }
    close $qf;
  }

  foreach $file (glob "$spooldir/*/$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;
      unless ($file{$i}) {
        $du += $size;
        $file{$i} = $i;
      }
    } elsif (-f $upload) {
      # count hard links only once (= same inode)
      my $i = (stat($upload))[1]||0;
      unless ($file{$i}) {
        $du += readlink("$file/size")||0;
        $file{$i} = $i;
      }
    }
  }

  foreach $size (glob "$sender/SHARE/*/archives/*/*/size") {
    $du += readlink($size)||0;
  }

  foreach (glob("$sender/DOX/.*.du")) {
    if (m:(.+)/\.(.+)\.du: and -d "$1/$2" and my $s = readlink) {
      $du += $s*1024;
    }
  }

  return($squota,int($du/$MB));
}


# check recipient quota
sub check_recipient_quota {
  my $recipient = shift;
  my $rquota = $recipient_quota||0;
  my $du = 0;
  my ($file,$size,$share);
  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;
    }
  }

  foreach $size (glob "$recipient/SHARE/*/archives/*/*/size") {
    $du += readlink($size)||0;
  }

  foreach my $d (glob("$recipient/DOX/.*.du")) {
    $du += (readlink($d)||0)*1024;
  }

  return($rquota,int($du/$MB));
}


# dox disk usage
sub doxdu {
  my $user = shift;
  my $folder = shift;
  my $doxd = "$spooldir/$user/DOX";
  my $duf;
  my @folder = ();
  local $_;

  if (-d $doxd) {
    if (defined $folder) {
      @folder = ("$doxd/$folder");
    } else {
      foreach my $f (glob "$doxd/*") {
        push @folder,$f if -l $f and -d $f;
      }
    }
    foreach my $f (@folder) {
      if ($f =~ m:(.+)/(.+):) {
        $duf = "$1/.$2.du";
      } else {
        next;
      }
      unlink $duf;
      if (-l $f and -d $f) {
        if (my @f = grep m:\Q$f\E_\d+_\d+$:,glob($f.'_*')) {
          symlink untaint(ddu(@f)),$duf;
        }
      }
    }
  }
}


# directory disk usage (kB)
sub ddu {
  my $du = 0;
  local %DU;

  local $ddu = sub {
    my $dir = shift;
    my $du = 0;
    opendir $dir,$dir or return 0;
    while (defined (my $file = readdir $dir)) {
      next if $file eq '.' or $file eq '..';
      my $df = "$dir/$file";
      my @s = lstat($df) or next;
      if (-l _) {
        $du += 4;
        next;
      }
      if (-d _) {
        $du += 4;
        next if $file =~ /^\.snapshots?$/;
        $du += &$ddu($df);
        next;
      }
      if (-f _) {
        my $i = "$s[0]:$s[1]";
        $du += $DU{$i} ? 4 : int(($s[7]+4095)/4096)*4;
        $DU{$i}++;
        next;
      }
      $du += 4;
    }
    closedir $dir;
    return $du;
  };

  foreach my $dir (@_) {
    $du += &$ddu($dir);
  }
  return $du;
}


sub getline {
  my $file = shift;
  local $_;

  chomp($_ = <$file> // '');
  return $_;
}


sub readline1 {
  my $file = shift;
  local $_;

  if (open $file,$file) {
    $_ = <$file> // '';
    close $file;
    chomp;
  }
  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(
    '<p>'
    '<form name="logout" action="$logout">'
    '  <input type="submit" name="logout" value="logout">'
    '</form>'
    '<p>'
  ));
}


# 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/&/&amp;/g;
  s/</&lt;/g;
  print "<pre>\n$_\n</pre>\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,$sx,$ss) = @_;
  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;
    s/$sx/$ss/g if defined $ss;
    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 $_;
}


# 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 ($_ = <STDIN>)) {
    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 $_;
  our %PARAM = ();

  if ($cl > 128*$MB) {
    http_die("request too large");
  }

  # binmode(STDIN,':raw');

  $_ = $ENV{QUERY_STRING};
  s/%5E/^/g;
  if (/&/) {
    foreach (split(/&/)) {
      if (/(.+?)=(.*)/) { $PARAM{$1} = $2 }
      else              { $PARAM{$_} = $_ }
    }
  } elsif (/\?/) {
    foreach (split(/\?/)) {
      if (/(.+?)=(.*)/) { $PARAM{$1} = $2 }
      else              { $PARAM{$_} = $_ }
    }
  } else {
    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 (<STDIN>) {
          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
  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";
      @logdir = ($logdir);
      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;

  $keyring =~ s/[;<>()|\`]//;
  $to =~ s/[;<>()|\`]//;

  $pid = open3($po,$pi,$pe,untaint(
    "gpg --batch --trust-model always --keyring '$keyring'".
    "    -a -e -r '$bcc' -r '$to'"
  )) or return;

  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 fcrypt {
  my $encryption = shift;
  my $salt = shift || randstring(16);
  my $password = shift;
  my $hash;
  my $i = 1;

  $password =~ s/\s//;

  if ($encryption eq '64kHMACSHA512B') {
    $hash = hmac_sha512($password,$salt);
    foreach (2..2**16-1) {
      $i++;
      $hash = hmac_sha512($password,$hash.$i);
    }
    $i++;
    $hash = hmac_sha512_base64($password,$hash.$i);
  } elsif (ref($$encryption) eq 'CODE') {
    $hash = &$$encryption($password,$salt);
  } else {
    http_die("unknown encryption $encryption");
    exit 1;
  }

  return "$encryption $salt $hash";
}

## example for fex.ph:
# $encryption = 'NONE';
# $NONE = sub { return $_[1] };


sub move {
  our ($move);
  my $ddir = pop;
  my $move_errors = '';
  my @dstat = stat $ddir or return "cannot stat $ddir - $!\n";

  unless (-d $ddir) {
    return "destination $ddir is not a directory\n";
  }

  unless (-w $ddir) {
    return "destination directory $ddir is not writable\n";
  }

  local $move = sub {
    my $sdir = shift;
    my @sstat;
    my $dfile;
    local $_;

    foreach (my @__ = @_) {
      unless (@sstat = lstat) {
        $move_errors .= "cannot stat '$_' - $!\n";
        next;
      }
      if ($sstat[0] != $dstat[0]) {
        $move_errors .= "cannot link $_ to $ddir - different filesystem\n";
        next;
      }
      s:/+:/:g;
      s:/$::;
      $dfile = "$ddir/$sdir".basename($_);
      $dfile =~ s:/+:/:g;
      if (-l or not -d) {
        if (-d $dfile and not -l $dfile) {
          if ($opt_f) {
            system qw'rm -rf',$dfile;
          } else {
            $move_errors .= "cannot replace directory '$dfile'\n";
            next;
          }
        }
        if (my @s = lstat $dfile) {
          if ("@s" eq "@sstat") {
            unless (unlink) {
              $move_errors .= "cannot remove '$_' - $!\n";
            }
            next;
          }
          unless (unlink $dfile) {
            $move_errors .= "cannot remove '$dfile' - $!\n";
            next;
          }
        }
        if (rename $_,$dfile) {
          print "'$_' -> '$dfile'\n" if $opt_v;
        } else {
          $move_errors .= "cannot move '$_' to '$dfile' - $!\n";
          next;
        }
      } elsif (-d) {
        if (-d $dfile) {
          my $dir = $_;
          my @files = ();
          if (opendir $dir,$dir) {
            @files = grep { not /^\.\.?$/ } readdir($dir);
            closedir $dir;
            @files = sort { lc $a cmp lc $b } @files;
            foreach (@files) {
              /(.+)/;
              $_ = $dir.'/'.decode_utf8($1);
            }
            &$move($sdir.basename($dir).'/',@files);
            unless (rmdir $dir) {
              $move_errors .= "cannot rmdir $dir - $!\n";
              next;
            }
          } else {
            $move_errors .= "cannot read $dir - $!\n";
            next;
          }
        } else {
          if (lstat $dfile) {
            unlink $dfile;
          }
          if (rename $_,$dfile) {
            print "'$_' -> '$dfile'\n" if $opt_v;
          } else {
            $move_errors .= "cannot move '$_' to '$dfile' - $!\n";
            next;
          }
        }
      } else {
        $move_errors .= "unknown file type '$_'\n";
        next;
      }
    }
  };

  &$move('',@_);
  return $move_errors;
}


sub mtime {
  my @s = stat(shift) or return;
  return $s[9];
}


sub lmtime {
  my @s = lstat(shift) or return;
  return @s?$s[9]:0;
}


# wildcard * to perl regexp
sub quotewild {
  local $_ = quotemeta shift;
  s/\\\*/.*/g; # allow wildcard *
  return $_;
}


sub readlink_ {
  my $file = shift;
  return (readlink($file)||'');
}


sub asort {
  return sort { lc($a) cmp lc($b) } @_;
}


sub mhfrom {
  my $mfrom = shift;
  my $hfrom;
  my $fex_sender = $::fex_sender;

  $mfrom .= '@'.$mdomain if $mdomain and $mfrom !~ /@/;
  $hfrom = $mfrom;
  $hfrom =~ s/@/(at)/g;

  if ($fex_sender and @local_domains) {
    foreach my $ld (@local_domains) {
      $fex_sender = 0 if $mfrom =~ /\@\Q$ld\E$|\@.+\.\Q$ld\E$/;
    }
  }
  if ($fex_sender) {
    $mfrom =~ s/\@/_/;
    $mfrom = "fex+$mfrom\@$hostname";
  }


  return ($mfrom,$hfrom);
}


# 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")
      or http_die("internal error: no $file/dkey");
  } else {
    $file = readlink("$dkeydir/$dkey")
      or http_die("internal error: no DKEY $dkey");
  }
  $file = untaint($file);
  $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;
  $notify{'english'} = \&notify; # local default notify function, not via lf.pl
  unless ($notify{$locale}) {
    $locale = 'english';
    $notify{$locale} ||= \&notify;
  }
#  return notify(
  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!                   #
########################################################################

# locale function!
sub notify {
  # my ($status,$dkey,$filename,$keep,$warn,$comment,$autodelete) = @_;
  my %P = @_;
  my ($to,$from,$file,$mimefilename,$receiver,$warn,$comment,$status);
  my ($size,$bytes,$header,$data,$replyto,$uurl,$alist,$filed,$share);
  my ($mfrom,$mto,$dfrom,$dto,$hfrom);
  my $proto = 'http';
  my $days = 0;
  my $durl = $::durl;
  my $autodelete = '';
  my ($index,$tools);
  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;

  $status = $P{status};
  $warn = $P{warn}||2;
  $autodelete = $P{autodelete}||$::autodelete;
  $comment = $P{comment}||'';
  $comment = encode_utf8($P{comment}||'') if utf8::is_utf8($comment);
  $comment =~ s/^!\*!//; # multi download allow flag
  chomp $comment;

  $index = $tools = $durl;
  $index =~ s/fop$/index.html/;
  $tools =~ s/fop$/tools.html/;

  if ($share = $P{share}) {
    $filed = $P{filed};
    $to = $P{to};
    $from = $P{from};
    $file = $filename = $P{filename};
    $durl = $P{durl};
  } else {
    $filed = untaint(readlink("$dkeydir/$P{dkey}"));
    $filed =~ s/^\.\.\///;
    ($to,$from,$file) = split('/',$filed);
    $filename = strip_path($P{filename});
  }

  return '' unless $to;
  return '' unless $from;
  return '' unless length($filename);

  # make download protocal same as upload protocol
  if ($uurl = readlink("$filed/uurl") and $uurl =~ /^(https?):/) {
    $proto = $1;
    $durl =~ s/^https?:/$proto:/;
    $durl =~ s/:\d+\b// if $durl =~ /^https:/;
  }
  ($mfrom,$hfrom) = mhfrom($from);
  $mto = $to;
  $replyto = $P{replyto}||$from;
  $keyring = $to.'/@GPG';
  $header = "From: <$mfrom> ($hfrom via F*EX service $hostname)\n";
  $header .= "Reply-To: <$replyto>\n" if $replyto ne $mfrom;
  $header .= "To: <$mto>\n";
  $data = "$filed/data";
  $alist = "$filed/alist";
  $size = $bytes = -s $data;
  return unless $size;

  $warning =
    "We recommend fexget or fexit for download,\n".
    "because these clients can resume the download after an interruption.\n".
    "See $tools";
  # if ($nowarning) {
  #   $warning = '';
  # } else {
  #   $warning =
  #     "Please avoid download with Internet Explorer, ".
  #     "because it has too many bugs.\n\n";
  # }
  if ($filename =~ /\.(tar|tgz|tar\.gz|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 and $from ne $to) {
    $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/$MB)." 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 = '';
  }

  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("$filed/id")) {
    my @s = stat($data);
    $fileid =  @s ? $s[1].$s[9] : 0;
  }

  if ($share) {
    $header .= "Subject: new F*EX share archive: $share:$mimefilename\n";
  } elsif ($status =~ /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;
  if ($share) {
    $download = "$durl\n";
  } else {
    foreach my $u (@durl?@durl:($durl)) {
      my $durl = sprintf("%s/%s/%s",$u,$P{dkey},urlencode($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: $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) {
    # obsoleted feature!
    map { s/^From: <\Q$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,
    # because remote MTA will probably reject this email
    $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 - $!");
    } else {
      open $sendmail,'|-',$sendmail,'-f',$mfrom,$mto,$bcc
        or http_die("cannot start sendmail - $!");
    }
  }
  if (length($comment)) {
    $comment = '. ' if $comment eq '.';
    $comment = "\n$comment\n"
  }
  if ($share) {
    $disclaimer = "\n$::disclaimer\n" if $::disclaimer;
    $body = qqq(qq(
      '$comment'
      '$from has uploaded the archive file'
      '  "$filename" ($size)'
      'for share $share. See'
      ''
      '$download'
      '$disclaimer'
    ));
  } else {
    if ($comment =~ s/\n!(shortmail|\.)!\s*//i
      or (readlink("$to/\@NOTIFICATION")||'') =~ /short/i
    ) {
      $body = $comment."\n".$download."\n".$size;
    } else {
      $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\n" if $::disclaimer;
      $body = qqq(qq(
        '$comment'
        '$from has uploaded the file'
        '  "$filename" ($size)'
        'for $receiver. Use'
        ''
        '$download'
        'to download this file within $days.'
        ''
        '$autodelete'
        ''
        '$disclaimer'
      ));
    }
  }
  $body =~ s/\n\n+/\n\n/g;
  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 and return $to;
  http_die("cannot send notification email (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 $user has been inactive for $expire days,"
               ." you must download this file to reactivate it."
               ." Otherwise your account will be deleted.'"
               ." $reactivation $user";
    # on error show STDOUT and STDERR
    my $fo = `$fexsend 2>&1`;
    warn $fexsend."\n".$fo if $?;
  } else {
    warn "$0: cannot execute $fexsend for reactivation()\n";
  }
}

1;