#!/usr/bin/perl -wT

# F*EX CGI for upload
#
# Author: Ulli Horlacher <framstag@rus.uni-stuttgart.de>
#
# Contribs:
#	Sebastian Zaiser <szcode@arcor.de> (upload status)
#
# Copyright: GNU General Public License

use Encode;
use Fcntl 	qw(:flock :seek :mode);
use IO::Handle;
use Digest::MD5	qw(md5_hex);

# add fex lib
$FEXLIB =
  $0 =~ m:(/.+)/.+/: ? "$1/lib":
  $0 =~ m:(.*/):     ? "$1/../lib":
                       "../lib";
die "$0: no $FEXLIB\n" unless -d $FEXLIB;

$| = 1;

our $debug;
our $ndata = 0;
our $error = 'F*EX upload ERROR';
our $head = "$ENV{SERVER_NAME} F*EX upload";
our $autodelete = 'YES';

# import from fex.pp
our ($spooldir,$durl,$tmpdir,$logdir,$keep_default,$hostname,$admin,$fra);
our ($sendmail,$mdomain,$fop_auth);
our ($dkeydir,$ukeydir,$akeydir);

my $data;
my $boundary;
my $rb = 0;		# read bytes, totally
my $seek = 0;		# already sent bytes (from previous upload)
my $rid = '';		# real ID
my @header;		# HTTP entity header

# load common code, local config: $FEXLIB/fex.ph
require "$FEXLIB/fex.pp" or die "$0: cannot load $FEXLIB/fex.pp - $!\n";

# load fup local config
our ($info_1,$info_2);
require "$FEXLIB/fup.pl" or die "$0: cannot load $FEXLIB/fup.pl - $!\n";

chdir $spooldir or http_die("$spooldir - $!\n");

my $log     = "$logdir/fup.log";

my $http_client = $ENV{HTTP_USER_AGENT} || '';
my $ra = untaint($ENV{REMOTE_ADDR});
$fra .= '/'.$ENV{HTTP_X_FORWARDED_FOR} if $ENV{HTTP_X_FORWARDED_FOR};

$from = $to = $id = $file = $fkey = $comment = $akey = $skey = '';
$addto = $submit = '';
@to = ();
$data = '';

&parse_request; # showstatus will not come back

if ($addto) {
  my %to;
  foreach $to (@to) { $to{$to} = 1 }
  push @to,$addto unless $to{$addto};
}

$uid = randstring(8) unless $uid; # upload ID

# user requests for forgotten ID
if ($from and $id_forgotten) {
  $id = '';
  if (open $from,'<',"$from/\@") {
    $id = <$from> || '';
    chomp $id;
    close $from;
  }
  if ($id) {
    open P,"|$sendmail -t" or http_die("cannot start sendmail - $!\n");
    pq(P,qq(
      'From: $admin'
      'To: $from'
      'Subject: F*EX service $hostname'
      'Bcc: fex'
      ''
      'Your reqested F*EX auth-ID for $hostname is:'
      '$id'
    ));
    close P or http_die("cannot send mail - $!\n");
    http_header('200 OK');
    print html_header($head);
    print "<h3>Mail has been sent to you ($from)</h3>\n";
    print "</body></html>\n";
  } else {
    http_die("unknown F*EX user $from");
  }
  exit;
}

# look for regular sender ID
if ($id and $from) {
  if (open $from,'<',"$from/\@") {
    $rid = <$from> || '';
    chomp $rid;
    close $from;
    $rid = sidhash($rid,$id);
  } else {
    my $error = $!;
    # if recipient (to) is specified, we have to look for subusers later, too
    unless (@to) {
      fuplog("ERROR: $spooldir/$from/\@ $error");
      debuglog("cannot open $spooldir/$from/\@ : $error");
      http_die("Wrong auth-ID");
    }
  }
}

# look for (registered) recipient's special receiver ID (= subuser)
$to = join(',',@to);
if ($from and $id and $to 
    and $to !~ /,/ 
    and $id ne $rid 
    and open $to,'<',"$to/@") {
  # skip recipients own ID
  $_ = <$to>; 
  # sub user list MUST be sorted upside down, 
  # anotherwise wildcard * will match first - bad idea!
  foreach (reverse sort <$to>) {
    chomp;
    # special receiver ID (subuser)?
    if (s/(.+?)://) {
      my $sr = lc($1);
      if (lc($from) eq $sr 
          or $sr eq '*' or $sr eq '*@*' 
          or $sr =~ /^\*\@(.+)/ and $from =~ /\@\Q$1\E$/i
          or $sr =~ /(.+)\@\*$/ and $from =~ /^\Q$1\E\@/i) {
        $rid = sidhash($_,$id);
        $subuser = $sr;
        $skey = md5_hex("$subuser:$id");
        last;
      }
    }
  }
  close $to;
}

# check ID
if ($from and $id) {
  if ($rid and $rid eq $id) {
    # set akey link for HTTP sessions
    if (-d $akeydir and not $akey and $id !~ /^MD5H:/) {
      $akey = untaint(md5_hex("$from:$id"));
      symlink "../$from","$akeydir/$ra:$akey";
    }
  } else {
    fuplog("ERROR: wrong auth-ID $id");
    debuglog("id sent by user $from=$id, real id=$rid");
    http_die("Wrong auth-ID");
  }
}

# delete file without download
if ($akey and $dkey and $comment eq 'DELETE') {
  $del = untaint(readlink "$dkeydir/$dkey"||'');
  http_die("unknown dkey $dkey") unless $del;
  $del =~ s:^\.\./::;
  $filename = filename($del);
  if (unlink("$del/data") or unlink("$del/upload")) {
    if (open F,'>',"$del/error") {
      printf F "%s has been deleted by %s at %s\n",
               $filename,$ENV{REMOTE_ADDR},isodate(time);
      close F;
    }
    # http_header('200 OK');
    # print html_header($head);
    # print "<h3>$filename deleted</h3>\n";
    http_header(
      "301 Moved Permanently",
      "Location: $ENV{PROTO}://$ENV{HTTP_HOST}/fup?akey=$akey&comment=LIST"
    );
  } else { 
    my $s = $!;
    http_header('404 Not Found');
    print html_header($head);
    print "<h3>$filename not deleted ($s)</h3>\n";
    print "<a href=\"/fup?akey=$akey&comment=LIST\">continue</a>\n";
    print "</body></html>\n";
  }
  exit;
}
  
if ($from and $id and $rid eq $id) {
  
  if ($comment eq 'LIST') {
    $to = join(',',@to);
    # list sent files
    if ($to eq '*') {
      http_header('200 OK');
      print html_header($head);
      print "<h3>Files from $from:</h3>\n",
            "<pre>\n";
      foreach $file (glob "*/$from/*") {
        next if $file =~ /\/STDFEX$/;
        $filename = $comment = '';
        $size = -s "$file/data";
        next unless $size;
        $size = int($size/1024/1024+0.5);
        my $rto = $file;
        $rto =~ s:/.*::;
        if ($dkey = readlink "$file/dkey") {
          if ($rto ne $to) {
            $to = $rto;
            print "\nto $to :\n";
          }
          if (open $file,'<',"$file/filename") {
            $filename = <$file>;
            close $file;
          }
          $filename = '???' unless $filename;
          if (open $file,'<',"$file/comment") {
            $comment = <$file> || '';
            close $file;
          }
          $comment = ' "'.$comment.'"' if $comment;
          printf "%8s MB %s%s\n",$size,$filename,$comment;
        }
      }
      print "</pre>\n";
      print "</body></html>\n";
    } 
    # list received files
    else {
      $to = $from;
      http_header('200 OK');
      print html_header($head);
      print "<h3>Files for $to (*):</h3>\n",
            "<pre>\n";
      foreach $from (glob "$to/*") {
        next if $from =~ /[A-Z]/;
        $from =~ s:.*/::;
        $url = '';
        foreach $file (glob "$to/$from/*") {
          next if $file =~ /\/STDFEX$/;
          $filename = $comment = '';
          $size = -s "$file/data";
          next unless $size;
          $size = int($size/1024/1024+0.5);
          if ($dkey = readlink "$file/dkey") {
            print "\nfrom $from :\n" unless $url;
            $file =~ s:.*/::;
            $url = "$durl/$dkey/$file";
            unless (-l "$dkeydir/$dkey") {
              symlink untaint("../$to/$from/$file"),untaint("$dkeydir/$dkey");
            }
            if (open $file,'<',"$to/$from/$file/filename") {
              $filename = <$file>;
              close $file;
            }
            $filename = '???' unless $filename;
            if (open $file,'<',"$to/$from/$file/comment") {
              $comment = <$file> || '';
              close $file;
            }
            $comment = ' "'.$comment.'"' if $comment;
            # printf "%8s MB <a href=\"%s\">%s : %s</a>\n",$size,$url,$from,$file;
            printf "[<a href=\"/fup?akey=%s&dkey=%s&comment=DELETE\">delete</a>]",
                   $akey,$dkey;
            printf "%8s MB <a href=\"%s\">%s</a>%s\n",
                   $size,$url,$filename,$comment;
          }
        }
      }
      pq(qq(
        '</pre>'
        '<h3>(*) Files for other e-mail addresses you own will not be listed here!</h3>'
        '<a href="/foc?akey=$akey">back to F*EX operation control</a>'
        '</body></html>'
      ));
    }
    exit;
  } 

  if ($comment eq 'FOPLOG') {
    if (open my $log,"$logdir/fop.log") {
      http_header('200 OK');
      while (<$log>) {
        next if /\/STDFEX\s/;
        if (/\s\Q$from\//) {
          if (s:(\d+)/(\d+)$:$1: and $1 and $1 == $2) {
            print;
          }
        }
      }
    }
    exit;
  }
  
  if ($comment eq 'RECEIVEDLOG') {
    if (open my $log,"$logdir/fup.log") {
      http_header('200 OK');
      while (<$log>) {
        next if /\sSTDFEX\s/;
        if (/\d+$/) { 
          @F = split;
          print if $F[4] eq $to;
        }
      }
    }
    exit;
  }

  if ($comment eq 'SENDLOG') {
    if (open my $log,"$logdir/fup.log") {
      http_header('200 OK');
      while (<$log>) {
        next if /\sSTDFEX\s/;
        if (/\d+$/) { 
          @F = split;
          print if $F[2] eq $from;
        }
      }
    }
    exit;
  }

  if (@to and $comment eq 'CHECKRECIPIENT') {
    nvt_print('HTTP/1.1 204 OK');
    foreach $to (@to) {
      nvt_print("X-Recipient: $to");
    }
    nvt_print('');
    # control back to fexsrv for further HTTP handling
    exec($ENV{FEXHOME}.'/bin/fexsrv') if $ENV{KEEP_ALIVE};
    exit;
  }

  if ($file and @to and $comment eq 'DELETE') {
    foreach $to (@to) {
      $del = "$to/$from/$fkey";
      $del =~ s:^/+::;
      if ($del =~ /\/\./) {
        http_die("illegal parameter $del");
      }
      $del = untaint($del);
      
      if (unlink("$del/data") or unlink("$del/upload")) {
        if (open F,'>',"$del/error") {
          print F "$file has been deleted by $from\n";
          close F;
        }
        http_header('200 OK');
        print html_header($head);
        print "<h3>$file deleted</h3>\n";
      } else { 
        http_header('404 Not Found');
        print html_header($head);
        print "<h3>$file not deleted</h3>\n";
      }
      printf "<a href=\"/fup?akey=%s&to=%s&comment=LIST\">continue</a>\n",
             $akey,$to;
      print "</body></html>\n";
    }
    exit;
  }

}

# check recipients restriction
if ($id and $id eq $rid and $from and @to
    and -s "$from/\@ALLOWED_RECIPIENTS" 
    and open F,'<',"$from/\@ALLOWED_RECIPIENTS") {
  my ($allowed,$ar);
      
  foreach $to (@to) {
    $allowed = 0;
    seek F,0,0;
    while (<F>) {
      chomp;
      s/#.*//;
      s/\s//g;
    
      # allow wildcard *, but not regexps
      $ar = quotemeta $_;
      $ar =~ s/\\\*/[^@]*/g;
    
      if ($to =~ /^$ar$/i or "$to\@$mdomain" =~ /^$ar$/i) {
        $allowed = 1;
        last;
      }
    }

    unless ($allowed) {
      fuplog("ERROR: $from not allowed to fex to $to");
      debuglog("$to not in $spooldir/$from/\@ALLOWED_RECIPIENTS");
      http_die("You ($from) are not allowed to fex to $to");
    }
  }

  close F;
}

# on secure mode "fop authorization" also check if recipient(s) exists
# (= has a F*EX ID)
if ($fop_auth and $id and $id eq $rid and $from and @to) {
  my ($to_reg,$idf,$subuser);
  foreach my $to (@to) {
    $to_reg = 0;
    # full user?
    if (open $idf,'<',"$to/@") {
      $to_reg = <$idf> || '';
      chomp $to_reg;
      close $idf;
    } 
    # sub user?
    elsif (open $idf,'<',"$from/@") {
      while (<$idf>) {
        next unless /:/;
        chomp;
        ($subuser) = split ':';
        if ($subuser eq $to or $subuser eq '*@*'
            or $subuser =~ /^\*\@(.+)/ and $to =~ /\@\Q$1\E$/i
            or $subuser =~ /(.+)\@\*$/ and $to =~ /^\Q$1\E\@/i) {
          $to_reg = $_;
          last;
        }
      }
      close $idf;
    }
    unless ($to_reg) {
      http_die("recipient $to is not a registered F*EX full or sub user");
    }
  }
}

# display HTML form and request user data
unless ($file) {
  $to = join(',',@to);
  if ($test) { $cgi = $test } 
  else       { $cgi = $ENV{SCRIPT_NAME} }
  http_header('200 OK');
  # print html_header($head,'<img src="/fex_small.gif">');
  print html_header($head);
  
  if ($http_client =~ /(Konqueror|w3m)/) {
    pq(qq(
      '<p><hr><p>'
      '<center>'
      '<h3>Your client seems to be "$1" which is incompatible with F*EX and will probably not work!</h3>'
      'We recommend firefox.'
      '</center>'
      '<p><hr><p>'
    ));
  }
  
  if ($from and $id and ($addto or not $submit or not @to)) {
    @ab = ("<option></option>");
    
    # select menu from server address book
    if (open my $ab,'<',"$from/\@ADDRESS_BOOK") {
      while (<$ab>) {
        if (/(\S+)\s+(\S+@[\w.-]+\S*)/) {
          $_ = "$1 &lt;$2>";
          s/,.*/,.../g;
          push @ab,"<option>$_</option>";
        }
      }
      close $ab;
    }
    
    pq(qq(
      '<form name="upload"'
      '      action="$cgi"'
      '      method="post"'
      '      accept-charset="UTF-8"'
      '      enctype="multipart/form-data">'
      '  <input type="hidden" name="from" value="$from">'
      '  <input type="hidden" name="id"   value="$id">'
      '  <table border="1">'
    ));      
    if ($subuser) {
      pq(qq(
        '    <tr><td>sender:   <td>$from</tr>'
        '    <tr><td>recipient:<td>$to</tr>'
        '    <input type="hidden" name="to"   value="$to">'
        '    <input type="hidden" name="skey" value="$skey">'
      ));
    } else {
      pq(qq(
        '    <tr><td>sender:   <td><a href="/fup?akey=$akey">$from</a></tr>'
        '    <tr><td>recipient(s):'
        '        <td><input type="text" name="to" size="80" value="$to">'
        '        (e-mail address or alias)<br>'
        '        or select from your'
        '        <a href="/fuc?ab=load&akey=$akey">address book</a>:'
        '        <select name="addto" size="1">@ab</select>'
        '        and'
        '        <input type="submit" name="submit" value="add to recipients list">'
        '    </tr>'
      ));
    }
    pq(qq(
      '  </table>'
      '  <p>'
      '  <input type="submit" name="submit" value="check recipient(s) and continue">'
      '</form>'
      '<p>'
    ));    
    if ($akey and -f "$from/@") {
      pq(qq(
        '<p>'
        '<a href="foc?akey=$akey">user config & operation control</a>'
      ));
    }
    
    if (-f "$ENV{FEXHOME}/htdocs/FIX.jar") {
      print "<p>\n";
      if ($skey) { print "<a href=\"fix?skey=$skey&to=$to\">" }
      else       { print "<a href=\"fix?akey=$akey\">" }
      print "Alternate Java client</a> (for files > 2 GB or sending of more than one file)\n";
    }
    print "</body></html>\n";
    exit;
    
  } elsif ($from and $id) {
    pq(qq(
      <script type="text/javascript">
        function showstatus() {
          var file  = document.forms["upload"].elements["file"].value;
          if (file != "") {
            window.open('$ENV{PROTO}://$ENV{HTTP_HOST}/$cgi?showstatus=$uid','fup_status','width=700,height=220');
            return true;
          }
          return false;
        }
      </script>
      <form name="upload"
            action="$cgi"
            method="post" 
            accept-charset="UTF-8"
            enctype="multipart/form-data"
            onsubmit="return showstatus();">
        <input type="hidden" name="uid"  value="$uid">
        <input type="hidden" name="from" value="$from">
        <input type="hidden" name="to"   value="$to">
    ));
    if ($skey) {
      pq(qq(
        '  <input type="hidden" name="skey" value="$skey">'
        '  <table border="1">'
        '    <tr><td>sender:   <td>$from</tr>'
        '    <tr><td>recipient:<td>$to</tr>'
      ));
    } else {
      my $toc = join(',',@to);
      my $toh = join('<br>',@to);
      pq(qq(
        '  <input type="hidden" name="akey" value="$akey">'
        '  <table border="1">'
        '    <tr><td>sender:<td>$from</tr>'
        '    <tr><td><a href="/fup?&akey=$akey&to=$toc">recipient(s)</a>:<td>$toh</tr>'
      ));
    }
    $autodelete = lc $autodelete;
    $keep = $keep_default unless $keep;
    pq(qq(
      '    <tr><td>autodelete:<td>$autodelete</tr>'
      '    <input type="hidden" name="autodelete" value="$autodelete">'
      '    <tr><td>keep:<td>$keep days</tr>'
      '    <input type="hidden" name="keep" value="$keep">'
      '    <tr><td>comment:'
      '        <td><input type="text" name="comment" size="80" value="$comment">(optional)</tr>'
      '    <tr><td>file(*):'
      '        <td><input type="file" name="file"    size="80" value="$file"></tr>'
      '  </table>'
      '  (*) If you want to send more than one file, then put them in a zip or tar archive.'
      '  <p><input type="submit" value="upload"><p>'
      '</form>'
    ));
    if ($akey and -f "$from/@") {
      print "<p>\n",
            "<a href=\"foc?akey=$akey\">user config & operation control</a>\n";
    }
    print "$info_2\n",
          "</body></html>\n";
    exit;
  } 

  pq(qq(
    '<form action="$cgi" '
    '      method="post" '
    '      accept-charset="ISO-8859-1" '
    '      enctype="multipart/form-data">'
    '  <table>'
    '    <tr><td>sender:'
    '        <td><input type="text"     name="from" size="40" value="$from"></tr>'
    '    <tr><td>recipient:'
    '        <td><input type="text"     name="to"   size="40" value="$to"></tr>'
    '    <tr><td>auth-ID:       '
    '        <td><input type="password" name="id"   size="16" value="$id"></tr>'
    '  </table> '
    '  <input type="checkbox" name="ID_forgotten" value="ID_forgotten">'
    '  I have lost my auth-ID! Send it to me by e-mail! '
    '  (you must fill out sender field above)'
    '  <p><input type="submit" value="check ID and continue"><p>'
  ));
  if (@local_hosts and ipin($ENV{REMOTE_ADDR}||0,@local_hosts)) {
    pq(qq(
      'You can <a href="/fur">register yourself</a> '
      'if you do not have a F*EX account yet.<p>'
    ));
  }
  print "</form>\n";
    
  if ($akey and -f "$from/@") {
    pq(qq(
      '<p>'
      '<a href="foc?akey=$akey">user config & operation control</a>'
    ));
  }
  
  print $info_1;

  if ($debug and $debug>1) {
    print "<hr>\n<pre>\n";
    foreach $v (sort keys %ENV) {
      print "$v = $ENV{$v}\n";
    }
    print "</pre>\n";
  }
  
  print "</body></html>\n";
  exit;
}

# all these variables should be defined here, but just to be sure...
http_die("no file specified")		unless $file;
http_die("no sender specified")		unless $from;
http_die("no recipient specified")	unless @to;
http_die("wrong auth-ID specified")	unless $rid eq $id;

# file data still waits on STDIN ... get it now!
$dkey = get_file();

if ("@to" eq $from and $file eq 'ADDRESS_BOOK') {
  unlink "$from/\@ADDRESS_BOOK";
  rename "$from/$from/ADDRESS_BOOK/upload","$from/\@ADDRESS_BOOK"
    or http_die("cannot save $from/\@ADDRESS_BOOK - $!\n");
  http_header('200 OK');
  print html_header($head);
  print "address book updated",
        "</body></html>\n";
  exit;
}

# finalize upload
foreach $to (@to) {
  $filed = "$to/$from/$fkey";
  $save = $filed . '/data';
  if (unlink $save) {
    $overwrite{$to}++;
  }
  rename "$filed/upload",$save 
    or http_die("cannot rename $filed/upload to $save - $!\n");
  
  # send notification e-mails if necessary
  if ($comment ne 'NOMAIL' and not $overwrite{$to}) {
    notify("new",
           readlink("$filed/dkey"),
           $filename,
           $keep||$keep_default,
           0,
           $comment,
           $autodelete
    );
    debuglog("notify $to/$from/$fkey [$filename] '$comment'");
  }
}

# send HTTP status
if ($file eq 'STDFEX') {
  nvt_print('HTTP/1.1 200 OK','');
  exit;
} else {
  http_header(
    '200 OK',
    "Location: $durl/$dkey/$fkey",
    "X-Recipient: ".join(",",@to),
  );
}

# send HTML report
print html_header($head);

if ($ndata) {
  if ($ndata<2*1024) {
    print "$file ($ndata B) received and saved<p>\n";
    print "Ehh... $ndata <b>BYTES</b>?! You are kidding?<p>\n" unless $seek;
  } elsif ($ndata<2*1024*1024) {
    $ndata = int($ndata/1024);
    print "$file ($ndata kB) received and saved<p>\n";
    if ($ndata<1024 and not $seek) {
      print "Using F*EX for less than 1 MB: ",
            "ever heard of MIME e-mail? :-)<p>\n";
    }
  } else {
    $ndata = int($ndata/1024/1024);
    print "$file ($ndata MB) received and saved<p>\n";
  }
  if ($comment ne 'NOMAIL') {
    foreach $to (@to) {
      if ($overwrite{$to}) { 
        print "(old $file for $to overwritten)<p>\n" 
      } else { 
        print "$to notified<p>\n" 
      }
    }
  }
  if ($skey) {
    print "<a href=\"/fup?submit=again&skey=$skey\">send another file</a>\n";
  } else {
    $to = join(',',@to);
    print "<a href=\"/fup?submit=again&akey=$akey&to=$to\">send another file</a>\n";
  }
} else {
  http_die(
    "No file data received!".
    " File name correct?".
    " File too big (Browser-limit: 2 GB)?"
  );
}

print "</body></html>\n";
exit;


sub checkchars {
  my $input = shift;
  local $_ = shift;
  http_die("\"$1\" is not allowed at beginning of $input $_") if /^([<>|+.])/;
  http_die("\"$1\" is not allowed in $input $_")              if /([\/,])/;
  http_die("\"$1\" is not allowed at end of $input $_")       if /([<>|])$/;
}

# parse GET and POST requests
sub parse_request {
  my %to;
  my ($to,$cl,$dkey);
  local $_;

  # parse HTTP QUERY_STRING (parameter=value pairs)
  if ($ENV{QUERY_STRING}) {
    foreach (split '&',$ENV{QUERY_STRING}) {
      if (s/^(\w+)=//) {
        my $x = $1;
        # decode URL-encoding
        s/%([a-f0-9]{2})/chr(hex($1))/gie;
        setparam($x,$_); 
      }
    }
  }
  
  if ($showstatus) {
    &showstatus;
    exit;
  }

  if ($ENV{REQUEST_METHOD} eq 'POST' and $cl = $ENV{CONTENT_LENGTH}) {
    foreach $sig (keys %SIG) {
      if ($sig !~ /^(CHLD|CLD)$/) {
        $SIG{$sig} = \&sigexit;
      }
    }
    $SIG{__DIE__} = \&sigdie;
    http_die("invalid Content-Length header \"$cl\"") unless $cl =~ /^\d+$/;
    debuglog("awaiting $cl bytes");
    
    # check if there is enough space on spool
    if (open my $df,"df -k $spooldir|") {
      while (<$df>) {
        if (/^.+?\s+\d+\s+\d+\s+(\d+)/ and $cl/1024 > $1) {
          my $free = int($1/1024);
          my $uprq = int($cl/1024/1024);
          if (open P,"|$sendmail -t") {
            pq(P,qq(
              'From: $admin'
              'To: $admin'
              'Subject: F*EX spool out of space'
              ''
              'F*EX spool $spooldir on $ENV{SERVER_NAME} is out of space.'
              ''
              'Current free space: $free MB'
              'Upload request: $uprq MB'
            ));
            close P;
          }
          debuglog("aborting because not enough free space in spool ($free MB)");
          http_die("not enough free space for this upload");
        }
      }
      close $df;
    }
    
    $SIG{ALRM} = sub { die "TIMEOUT\n" };
    alarm($timeout);
    if ($ENV{CONTENT_TYPE} =~ /boundary=\"?([\w\-\+\/_]+)/) {
      $boundary = $1;
    } else {
      http_die("malformed HTTP POST (no boundary found)");
    }
    
    binmode(STDIN,':raw');
    
    READPOST: while (&nvt_read) {
      # the file itself - *must* be last part of POST!
      if (/^Content-Disposition:\s*form-data;\s*name="file";\s*filename="(.+)"/i) {
        push @header,$_;
        $file = $param{'FILE'} = $1;
        $file =~ s/%(\d+)/chr($1)/ge;
        $file = $filename = untaint(strip_path(normalize($file)));
        $fkey = urlencode($file);
        while (&nvt_read) {
          last if /^\s*$/;
          push @header,$_;
        }
        # STDIN is now at begin of file, will be read later with get_file()
        last; 
      }
      # all other parameters
      if (/^Content-Disposition:\s*form-data;\s*name="([a-z]\w*)"/i) {
        my $x = $1;
        nvt_skip_to('^\s*$');
        &nvt_read;
        setparam($x,$_);
        NEXTPART: while (&nvt_read) {
          last READPOST if /^--\Q$boundary--/;
          last NEXTPART if /^--\Q$boundary/;
        }
      }
    }
    
    if ($from) {
      checkchars('from address',$from);
      unless (checkaddress($from)) {
        http_die("$from is not a valid e-mail address");
      }
      $from = untaint($from);
    }
    
    # collect multiple addresses and check for aliases
    if (@to and not $addto) {

      # read address book
      if ($from and open my $AB,'<',"$from/\@ADDRESS_BOOK") {
        while (<$AB>) {
          s/#.*//;
          $_ = lc $_;
          if (s/^\s*(\S+)\s+(\S+)//) {
            my ($alias,$address) = ($1,$2);
            my ($autodelete,$keep);
            $autodelete = $1 if /autodelete=(\w+)/;
            $keep       = $1 if /keep=(\d+)/;
            if ($address =~ /,/) {
              foreach my $address (split(",",$address)) {
                $address .= '@'.$mdomain if $address !~ /@/;
                push @{$ab{$alias}},$address;
                $autodelete{$alias} = $autodelete;
                $keep{$alias}       = $keep;
              }
            } else {
              $address .= '@'.$mdomain if $address !~ /@/;
              push @{$ab{$alias}},$address;
              $autodelete{$address} = $autodelete;
              $keep{$address}       = $keep;
            }
          }
        }
        close $AB;
      }

      # look for recipient's options
      foreach $to (@to) {
        # address book alias?
        if ($ab{$to}) {
          foreach my $address (@{$ab{$to}}) {
            $to{$address} = $to; # ignore dupes
            $autodelete{$address} = $autodelete if $specific{'autodelete'};
            $autodelete{$address} = $autodelete unless $autodelete{$address};
            if ($specific{'keep'}) {
              $keep{$address} = $keep;
            } elsif ($keep{$to}) {
              $keep{$address} = $keep{$to};
            }
          }
        } else {
          $to .= '@'.$mdomain if $to !~ /@/ and $to =~ /\w/;
          $to{$to} = $to; # ignore dupes
          $autodelete{$to} = $autodelete if $specific{'autodelete'};
          $autodelete{$to} = $autodelete unless $autodelete{$to};
          $keep{$to} = $keep if $specific{'keep'};
          # $keep{$to} = $keep unless $keep{$to};
        }
      }
      
      @to = keys %to;
      
      foreach $to (@to) {
        if ($comment ne 'LIST') {
          if (-d $to or checkaddress($to)) {
            $to = untaint($to);
          } else {
            http_die("\"$to\" is not a valid e-mail address");
          }
        }
        $to{$to} = $to; # ignore dupes
      }
       
      @to = keys %to;
    }
  }

}


# show the status progress bar
sub showstatus {
  my $wclose;
  my ($upload,$sfile,$ukey,$file);
  my ($nsize,$tsize);
  my ($t0,$t1,$t2,$tt,$ts,$tm);
  my $osize = 0;
  my $percent = 0;
  my $npercent = 0;
  local $_;

  $wclose = '<p><a href="#" onclick="window.close()">close</a>'."\n".
            '</body></html>'."\n";
  $ukey = "$ukeydir/$uid";
  $upload = "$ukey/upload";
  $sfile = "$ukey/size";
  for (1..10) {
    sleep 1;
    if (-s $sfile and open $sfile,'<',$sfile) {
      $tsize = <$sfile>;
      chomp $tsize;
      close $sfile;
      last;
    }
    # upload error?
    # remark: stupid Internet Explorer *needs* the error represented in this 
    # asynchronous popup window, because it cannot display the error in the
    # main window on HTTP POST!
    if (-f $ukey and open $ukey,'<',$ukey or 
        -f "$ukey/error" and open $ukey,'<',"$ukey/error") {
      undef $/;
      html_error($error,<$ukey> || 'unknown');
      unlink $ukey;
      exit;
    }
  }
  # unlink $sfile;
  
  if (defined $tsize and $tsize == 0) {
    print "<script type='text/javascript'>window.close()</script>\n";
    exit;
  }
  http_die("no file data received - does your file exist?") unless $tsize;
  http_die("file size unknown") unless $tsize =~ /^\d+$/;
  
  http_header('200 OK');
  if (open $ukey,'<',"$ukey/filename") {
    local $/;
    $file = <$ukey>;
    close $ukey;
  }
  http_die("no filename?!") unless $file;
  
  pq(qq(
    "<html><body>"
    "<h1>Upload Status for <tt>$file</tt></h1>"
    "<input type='text' id='percent' style='margin-left:1ex;color:black;background:transparent;border:none;width:32ex;' disabled='true' value='0%'>"
    "<div style='border:1px solid black;width:100%;height:20px;'>"
    "<div style='float:left;width:0%;background:black;height:20px;' id='bar'>"
    "</div></div>"
  ));
    
  # check for upload file
  for (1..5) {
    last if -f $upload or -f "$ukey/data";
    sleep 1;
  }
  unless (-f $upload or -f "$ukey/data") {
    print "<p><H3>ERROR: no upload received</H3>\n";
    print $wclose;
    exit;
  }
  
  $SIG{ALRM} = sub { die "TIMEOUT in showstatus\n" . $wclose };
  alarm($timeout*2);
  $t0 = $t1 = time;
  
  for ($percent = 0; $percent<100; sleep(1)) {
    $t2 = time;
    $nsize = -s $upload;
    if (defined $nsize) {
      if ($nsize<$osize) {
        print "<p><H3>ABORTED</H3>\n";
        print $wclose;
        exit;
      }
      if ($nsize>$osize) {
        alarm($timeout*2);
        $osize = $nsize;
      }
      $npercent = int($nsize*100/$tsize);
      $showsize = calcsize($tsize,$nsize);
    } else {
      $npercent = 100;
      $showsize = calcsize($tsize,$tsize);
    }
    # hint: for ISDN (or even slower) links, 5 s tcp delay is minimum
    # so, updating more often is contra-productive
    if ($t2>$t1+5 or $npercent>$percent) {
      $percent = $npercent;
      $t1 = $t2; 
      $tm = int(($t2-$t0)/60);
      $ts = $t2-$t0-$tm*60;
      $tt = sprintf("%d:%02d",$tm,$ts);
      pq(qq(
        "<script type='text/javascript'>"
        "  document.getElementById('bar').style.width = '$percent%';"
        "  document.getElementById('percent').value = '$showsize, $tt, $percent %';"
        "</script>"
      )) or last;
    }
  }
  
  alarm(0);
  print "<h3>file successfully transferred</h3>\n";
  print $wclose;
  unlink $ukey;
  exit;
}


# get file from post request
sub get_file {
  my ($to,$filed,$upload,$nupload,$speed,$data);
  my ($b,$n,$uss);
  my $dkey;
  my ($fh,$filesize);
  my ($t0,$tt);
  my $fb = 0;			# file bytes
  my $cl = $ENV{CONTENT_LENGTH};

  foreach $to (@to) {
    $filed = "$to/$from/$fkey";
    $nupload = "$filed/upload";
    mkdirp($filed);
    unlink "$filed/autodelete",
           "$filed/error",
           "$filed/download",
           "$filed/keep",
           "$filed/header",
           "$filed/speed",
           "$filed/comment",
           "$filed/notify";
    # do not delete $filed/data, because we need it later to determine if we 
    # are in overwrite mode!
    
    if ($upload) {
      if ($upload eq $nupload or
          -r $upload and -r $nupload and
          (stat $upload)[1] == (stat $nupload)[1]) {
        next;
      }
      unlink $nupload;
      link $upload,$nupload;
      link $speed,"$filed/speed";
    } else {
      $upload = $nupload;
      unlink "$ukeydir/$uid";
      open $upload,'>>',$upload or http_die("cannot create $upload - $!");
      unless (flock($upload,LOCK_EX|LOCK_NB)) {
        http_die("$file locked: a transfer is already in progress");
      }
      $data = "$filed/data";
      if (-f $data and open $data,'>>',$data) {
        unless (flock($data,LOCK_EX|LOCK_NB)) {
          http_die("$filed locked: a download is currently in progress");
        }
      }
      unless ($seek) {
        seek $upload,0,0;
        truncate $upload,0;
      }
      $uss = -s $upload;
      # provide upload ID symlink for showstatus
      symlink "../$filed","$ukeydir/$uid";
      $speed = "$filed/speed";
      open $speed,'>',$speed;
    }
    
    # showstatus needs file name and size
    # fexsend needs full file size (+$seek)
    open $fh,'>',"$filed/filename" or die "cannot write $filed/filename - $!\n";
    print {$fh} $filename;
    close $fh;
    $filesize = $cl-$rb-(length($boundary)+8)+$seek; # 8: 2 * CRLF + 2 * "--"
    open $fh,'>',"$filed/size" or die "cannot write $filed/size - $!\n";
    print {$fh} $filesize,"\n";
    close $fh;
    
    if ($autodelete{$to} =~ /^(DELAY|NO)$/i) {
      if (open $fh,'>',"$filed/autodelete") {
        print {$fh} $autodelete{$to},"\n";
        close $fh;
      }
    }
    
    if ($keep{$to} and open $fh,'>',"$filed/keep") {
      print {$fh} $keep{$to},"\n";
      close $fh;
    }
    
    if (@header and open $fh,'>',"$filed/header") {
      print {$fh} join("\n",@header),"\n";
      close $fh;
    }
    
    if ($comment) {
      if ($comment eq 'NOMAIL') {
        open $fh,'>',"$filed/notify";
        close $fh;
      } else {
        open $fh,'>',"$filed/comment";
        print {$fh} $comment;
        close $fh;
      }
    }
    
    # provide download ID key
    unless ($dkey = readlink("$filed/dkey") and -l "$dkeydir/$dkey") {
      $dkey = randstring(8);
      unlink "$dkeydir/$dkey";
      symlink "../$filed","$dkeydir/$dkey" or die "cannot symlink $dkeydir/$dkey";
      unlink "$filed/dkey";
      symlink $dkey,"$filed/dkey";
    }
    
  }

  # at last, read file data
  alarm($timeout);
  debuglog("still awaiting $cl-$rb =",$cl-$rb,"bytes");
  $t0 = time();
  while ($rb<$cl) {
    $b = $cl-$rb; 
    $b = $bs if $b>$bs;
    # max wait for 1 kB/s, but at least 10 s
    $timeout = $b/1024;
    $timeout = 10 if $timeout < 10;
    alarm($timeout);
    if ($n = read(STDIN,$_,$b)) {
      $rb += $n;
      $fb += $n;
      print {$upload} $_;
      # debuglog($_);
    } else {
      last;
    }
  } 
  alarm(0);       
  close $upload; # or die "cannot close $upload - $!\n";;
  
  # throuput in kB/s
  $tt = (time()-$t0) || 1;
  printf {$speed} "%d\n",$fb/1024/$tt;
  close $speed;
  
  # size of transferred (partial) file
  $ndata = untaint($fb-length($boundary)-8);

  # truncate boundary string
  truncate $upload,$ndata+$uss if -s $upload > $ndata+$uss;

  $to = join(',',@to);

  # incomplete?
  if ($cl != $rb) {
    fuplog($to,$fkey,$ndata,'(aborted)');
    http_die("read $rb bytes, but CONTENT_LENGTH announces $cl bytes");
  }
  
  # save error?
  if ($filesize > -s $upload) {
    fuplog($to,$fkey,$ndata,'(write error)');
    http_die("internal server error while writing file data");
  }
  
  fuplog($to,$fkey,$ndata);
  debuglog("upload successfull, dkey=$dkey");
  
  return $dkey;
}


sub calcsize {
  my ($tsize,$nsize) = @_;
  if ($tsize<2097152) {
    return sprintf "%d kB",int($nsize/1024);
  } else {
    return sprintf "%d MB",int($nsize/1048576);
  }
}

# read one line from STDIN (net socket) and assign it to $_
# returns number of 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/ }
}

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

# set parameter variables
sub setparam {
  my ($v,$vv) = @_;
  my ($idf,$to);
  
  $v = uc(despace($v));
  $param{$v} = $vv;
  # subuser key
  if (($v eq 'KEY' or $v eq 'SKEY') and $vv =~ /^(\w+)$/) { 
    $skey = $1;
    if (open $skey,'<',".skeys/$skey") {
      while (<$skey>) {
        if (/^(\w+)=(.+)/) {
          $from = $2   if lc($1) eq 'from';
          @to   = ($2) if lc($1) eq 'to';
          $id   = $2   if lc($1) eq 'id';
        }
      }
      close $skey;
    }
  } elsif ($v eq 'DKEY' and $vv =~ /^(\w+)$/) { 
    $dkey = $1;
  } elsif ($v eq 'AKEY' and $vv =~ /^(\w+)$/) { 
    $akey = $1;
    # akey is only valid when from same client IP ($ra)
    if (open $idf,'<',"$akeydir/$ra:$akey/@" and $id = <$idf>) {
      chomp $id;
      close $idf;
      $from = readlink "$akeydir/$ra:$akey"
        or http_die("internal server error: no $akey symlink");
      $from =~ s:.*/::;
      if ($akey ne md5_hex("$from:$id")) {
        $from = $id = '';
      }
    }
  } elsif ($v eq 'FROM' or $v eq 'USER') { 
    $from = lc(despace($vv));
    $from =~ s:/:_:g;
    $from =~ s:^\.:_:;
    $from = normalize($vv);
    $from .= '@'.$mdomain if $from and $from !~ /@/;
  } elsif ($v eq 'ADDTO') {
    $vv =~ s/\s.*//;
    $vv =~ s/[<>]//g;
    $addto = untaint(lc($vv)); # if checkaddress($vv);
  } elsif ($v eq 'SUBMIT') {
    $submit = $vv;
  } elsif ($v eq 'TO') {
    return if @to;
    # extract AUTODELETE and KEEP options
    if ($vv =~ s/[\s,]+AUTODELETE=(\w+)//i) {
      $specific{'autodelete'} = $autodelete = uc($1);
    }
    if ($vv =~ s/[\s,]+KEEP=(\d+)//i) {
      $specific{'keep'} = $keep = $1
    }
    $to	= normalize(lc($vv));
    $to	=~ s/^\s+//;
    $to	=~ s/\s+$//;
    $to	=~ s/[\n\s]+/,/g;
    $to	=~ s/,,+/,/g;
    @to	= split(',',$to);
  } elsif ($v eq 'ID') {
    $id		= despace($vv);
  } elsif ($v eq 'TCE') {
    $test	= despace($vv);
  } elsif ($v eq 'FILE') {
    $file	= strip_path(normalize($vv));
  } elsif ($v eq 'UID' and $vv =~ /^(\w+)$/) {
    $uid = $1;
  } elsif ($v eq 'ID_FORGOTTEN') {
    $id_forgotten = $vv;
  } elsif ($v eq 'SHOWSTATUS' and $vv =~ /^(\w+)$/) {
    $showstatus = $uid = $1;
  } elsif ($v eq 'COMMENT') {
    $comment	= normalize($vv);
  } elsif ($v eq 'SEEK' and $vv =~ /^(\d+)$/) {
    $seek	= $1;
  } elsif ($v eq 'AUTODELETE' and $vv =~ /^(\w+)$/) {
    $specific{'autodelete'} = $autodelete = uc($1);
  } elsif ($v eq 'KEEP' and $vv =~ /^(\d+)$/) {
    $specific{'keep'} = $keep = $1;     
  }
}

# global substitution as a function like in gawk
sub gsub { 
  local $_ = shift;
  my ($p,$r) = @_; 
  s/$p/$r/g; 
  return $_;
}

# standard log
sub fuplog {
  my $msg = "@_";
  
  $msg =~ s/\n/ /g;
  $msg =~ s/\s+$//;
  
  if (open $log,'>>',$log) {
    flock $log,LOCK_EX;
    seek $log,0,SEEK_END;
    printf {$log} "%s %s (%s) %s\n",isodate(time),$from,$fra,$msg;
    close $log;
  }
}

sub sigdie {
  local $_ = shift;
  chomp;
  sigexit('DIE',$_);
}

sub sigexit {
  my ($sig) = @_;
  my $msg;
  my $to = join(',',@to);
  
  $msg = @_ ? "@_" : '???';
  $msg =~ s/\n/ /g;
  $msg =~ s/\s+$//;
  
  if (open my $log,'>>',$log) {
    printf {$log} 
           "%s %s (%s) %s %s caught SIGNAL $msg %s\n",
           isodate(time),
           $from||'-',
           $fra||'-',
           $to||'-',
           encode_Q($file||'-'),
           $rb?"(after $rb bytes)":"";
    close $log;
  }
  $SIG{__DIE__} = '';
  if ($sig eq 'DIE') {
    shift;
    die "$msg\n";
  } else {
    die "SIGNAL $msg\n";
  }
}
