cgi-bin/fup

   1 #!/usr/bin/perl -wT
   2
   3 # F*EX CGI for upload
   4 #
   5 # Author: Ulli Horlacher <framstag@rus.uni-stuttgart.de>
   6 #
   7 # Contribs:
   8 #       Sebastian Zaiser <szcode@arcor.de> (upload status)
   9 #
  10
  11 BEGIN { ($ENV{PERLINIT}||'') =~ /(.+)/s and eval $1 }
  12
  13 use utf8;
  14 use Encode;
  15 use Fcntl               qw':flock :seek :mode';
  16 use IO::Handle;
  17 use Digest::MD5         qw'md5_hex';
  18 use Cwd                 qw'abs_path';
  19
  20 # add fex lib
  21 (our $FEXLIB) = $ENV{FEXLIB} =~ /(.+)/;
  22
  23 $| = 1;
  24
  25 our $debug;
  26 our $ndata = 0;
  27 our $error = 'F*EX upload ERROR';
  28 our $head = "$ENV{SERVER_NAME} F*EX upload";
  29 our $autodelete = 'YES';
  30 our $locale;
  31
  32 # import from fex.ph
  33 our (@locales,@throttle,$bcc,$keep_max,$nomail,$nostore,$overwrite);
  34 our (@local_domains,@local_rdomains,@local_hosts,@local_rhosts,);
  35 our (@registration_hosts,@demo,@file_link_dirs);
  36
  37 # import from fex.pp
  38 our ($FEXHOME);
  39 our ($spooldir,$durl,$tmpdir,@logdir,$logdir,$docdir,$hostname,$admin,$fra);
  40 our ($keep_default,$recipient_quota,$sender_quota,$fex_yourself);
  41 our ($sendmail,$mdomain,$fop_auth,$mail_auth,$faillog,$amdl);
  42 our ($dkeydir,$ukeydir,$akeydir,$skeydir,$gkeydir,$xkeydir);
  43 our ($MB,$DS);
  44 our $RB;                # read POST bytes (total)
  45 our $akey = '';
  46 our $dkey = '';
  47 our $skey = '';
  48 our $gkey = '';
  49
  50 our $seek = 0;          # already sent bytes (from previous upload)
  51 our $filesize = 0;      # total file size
  52 our $fpsize = 0;        # file part size (MIME-part)
  53
  54 my $data;
  55 my $boundary;
  56 my $rid = '';           # real ID
  57 my @header;             # HTTP entity header
  58 my $fileid;             # file ID
  59 my $captive;
  60 my $muser;              # main user fur sub or group user
  61
  62 # load common code, local config: $FEXLIB/fex.ph
  63 require "$FEXLIB/fex.pp";
  64
  65 # load fup local config
  66 our ($info_1,$info_2,$info_login);
  67
  68 $locale = $ENV{LOCALE} || 'english';
  69 foreach (
  70   "/var/lib/fex/locale/$locale/lib/fup.pl",
  71   "$FEXLIB/fup.pl",
  72 ) {
  73   if (-f) {
  74     require;
  75     last;
  76   }
  77 }
  78
  79 &check_camel unless $sid;
  80
  81 chdir $spooldir or http_die("$spooldir - $!\n");
  82
  83 my $log = 'fup.log';
  84
  85 my $http_client = $ENV{HTTP_USER_AGENT} || '';
  86 my $cl = $ENV{X_CONTENT_LENGTH} || $ENV{CONTENT_LENGTH} || 0;
  87
  88 $fra .= '/'.$ENV{HTTP_X_FORWARDED_FOR} if $ENV{HTTP_X_FORWARDED_FOR};
  89
  90 $from = $to = $id = $file = $fkey = $comment = $command = $bwlimit = '';
  91 $filename = $okey = $addto = $replyto = $submit = '';
  92 @to = ();
  93 $data = '';
  94 $locale = untaint($ENV{LOCALE}||'');
  95
  96 my $ra = $ENV{REMOTE_ADDR}||0;
  97 if (@upload_hosts and not ipin($ra,@upload_hosts)) {
  98   http_die(
  99     "Uploads from your host ($ra) are not allowed.",
 100     "Contact $ENV{SERVER_ADMIN} for details."
 101   );
 102 }
 103
 104 &check_maint;
 105
 106 &parse_request; # showstatus will not come back!
 107
 108 if ($addto) {
 109   my %to;
 110   foreach $to (@to) { $to{$to} = 1 }
 111   push @to,$addto unless $to{$addto};
 112   if ($submit and @to == 1) { $addto = '' }
 113 }
 114
 115 $to = join(',',@to);
 116
 117 if ($from eq $to and $fex_yourself =~ /^no|0$/i) {
 118   http_die("fexing to yourself is not allowed");
 119 }
 120
 121 $uid = randstring(8) unless $uid; # upload ID
 122
 123 # user requests for forgotten ID
 124 $id_forgotten = $id if $id =~ /^"?\?"?$/;
 125 if ($from and $id_forgotten and $mail_authid and not ($fop_auth or $nomail)) {
 126   &check_status($from);
 127   &id_forgotten;
 128   exit;
 129 }
 130
 131 # public recipients? (needs no auth-ID for sender)
 132 if ($to and $id and $id eq 'PUBLIC' and @public_recipients) {
 133
 134   unless ($from) {
 135     http_die("missing sender e-mail address");
 136   }
 137   # must use $param{FROM} for checking because $from is expanded with $mdomain
 138   unless (checkaddress(despace($param{FROM}))) {
 139     http_die("<code>$param{FROM}</code> is not a valid e-mail address");
 140   }
 141   foreach my $to (@to) {
 142     unless (grep /^\Q$to\E$/i,@public_recipients) {
 143       http_die("<code>$to</code> is not a valid recipient");
 144     }
 145   }
 146   $restricted = $public = $rid = $id;
 147 }
 148
 149 # anonymous upload from enabled IP?
 150 if ($from =~ /^anonymous@/ and
 151     @anonymous_upload and ipin($ra,@anonymous_upload)) {
 152   $id = $rid = $anonymous = 'anonymous';
 153   if ($to =~ /^anonymous/) {
 154     @to = ($to);
 155     $autodelete{$to} = $autodelete = $specific{'autodelete'}||'NO';
 156   }
 157   $nomail = $anonymous;
 158 }
 159
 160 $comment = 'NOMAIL' if $nomail and not $comment;
 161
 162 # one time token
 163 if ($okey) {
 164   $to = "@to" or http_die("no recipient specified");
 165   $from = readlink "$to/\@OKEY/$okey"
 166     or http_die("no upload key \"<code>$okey</code>\" - ".
 167                 "request another one from <code>$to</code>");
 168   $from = untaint($from);
 169 }
 170
 171 &check_status($from) if $from;
 172
 173 # look for regular sender ID
 174 if ($id and $from and not ($public or $anonymous or $okey)) {
 175   if (open $from,'<',"$from/\@") {
 176     # chomp($rid = <$from> || '');
 177     $rid = getline($from);
 178     close $from;
 179     $rid = sidhash($rid,$id);
 180     # set time mark for successfull access
 181     if ($id eq $rid) {
 182       my $time = untaint(time);
 183       utime $time,$time,$from;
 184     }
 185   } else {
 186     my $error = $!;
 187     # if recipient (to) is specified, we have to look for subusers later, too
 188     unless (@to) {
 189       fuplog("ERROR: $spooldir/$from/\@ $error");
 190       debuglog("cannot open $spooldir/$from/\@ : $error");
 191       faillog("user $from, id $id");
 192       http_die("wrong user or auth-ID");
 193     }
 194   }
 195 }
 196
 197 # check regular ID
 198 if ($from and $id and not ($gkey or $skey or $public or $okey)) {
 199   if ($rid and $rid eq $id) {
 200     # set akey link for HTTP sessions
 201     # (need original id for consistant non-moving akey)
 202     if (-d $akeydir and open $idf,'<',"$from/@" and my $id = getline($idf)) {
 203       # akey for webbrowser or fexsend special
 204       if (not $sid or ($from eq $to and ($comment eq '*')) or $command) {
 205         $akey = untaint(md5_hex("$from:$id"));
 206         mksymlink("$akeydir/$akey","../$from");
 207       }
 208     }
 209     $captive = -e "$from/\@CAPTIVE";
 210   } else {
 211     fuplog("ERROR: wrong auth-ID for $from");
 212     debuglog("id sent by user $from=$id, real id=$rid");
 213     faillog("user $from, id $id");
 214     http_die("Wrong user or auth-ID");
 215   }
 216 }
 217
 218 # optional $auth_hook() in fup.pl
 219 if ($auth_hook and ($akey or $skey or $gkey) and $from and -d $from) {
 220   &$auth_hook;
 221 }
 222
 223 # forward a copy of a file to another recipient
 224 if ($akey and $dkey and $command eq 'FORWARD') {
 225   my $file = untaint(readlink "$dkeydir/$dkey"||'');
 226   http_die("unknown dkey <code>$dkey></code>") unless $file;
 227   $file =~ s:^\.\./::;
 228   forward($file);
 229   exit;
 230 }
 231
 232 # modify file parameter
 233 if ($akey and $dkey and $command eq 'MODIFY') {
 234   my $file = untaint(readlink "$dkeydir/$dkey"||'');
 235   http_die("unknown dkey <code>$dkey</code>") unless $file;
 236   $file =~ s:^\.\./::;
 237   modify($file);
 238   exit;
 239 }
 240
 241 # copy file from incoming to outgoing spool
 242 if ($akey and $dkey and $command eq 'COPY') {
 243   unless ($file = readlink "$dkeydir/$dkey") {
 244     http_die("No such file with DKEY=$dkey");
 245   }
 246   if ($file =~ m:../(.+)/(.+)/(.+):) {
 247     ($to,$from,$file) = ($1,$2,$3);
 248   } else {
 249     http_die("Bad DKEY $dkey -> $file");
 250   }
 251   unless (-f "$to/$from/$file/data") {
 252     http_die("File not found");
 253   }
 254   if (-e "$to/$to/$file/data") {
 255     http_die("File $file already exists in your outgoing spool")
 256       if (readlink("$to/$to/$file/id")||$to) ne
 257          (readlink("$to/$from/$file/id")||$from);
 258   } else {
 259     mkdirp("$to/$to/$file");
 260     link "$to/$from/$file/data","$to/$to/$file/data"
 261       or http_die("cannot link to $to/$to/$file/data - $!\n");
 262     copy("$to/$from/$file/filename","$to/$to/$file/filename");
 263     copy("$to/$from/$file/id","$to/$to/$file/id");
 264     open $file,'>',"$to/$to/$file/notify";
 265     close $file;
 266     open $file,'>',"$to/$to/$file/download";
 267     print {$file} "$to\n";
 268     close $file;
 269     $dkey = randstring(8);
 270     unlink "$to/$to/$file/dkey","$to/$to/$file/keep","$dkeydir/$dkey";
 271     symlink "../$to/$to/$file","$dkeydir/$dkey";
 272     symlink $dkey,"$to/$to/$file/dkey";
 273   }
 274   nvt_print(
 275     "HTTP/1.1 302 Found",
 276     "Location: $ENV{PROTO}://$ENV{HTTP_HOST}/rup?akey=$akey&oto=$to&file=$file",
 277     'Content-Length: 0',
 278     ''
 279   );
 280   &reexec;
 281 }
 282
 283 # delete file without download
 284 if ($akey and $dkey and $command eq 'DELETE') {
 285   $del = untaint(readlink "$dkeydir/$dkey"||'');
 286   http_die("unknown dkey <code>$dkey</code>") unless $del;
 287   $del =~ s:^\.\./::;
 288   $filename = filename($del);
 289   if (unlink("$del/data") or unlink("$del/upload")) {
 290     if (open F,'>',"$del/error") {
 291       printf F "%s has been deleted by %s at %s\n",
 292                $filename,$ENV{REMOTE_ADDR},isodate(time);
 293       close F;
 294     }
 295     # http_header('200 OK');
 296     # print html_header($head);
 297     # print "<h3>$filename deleted</h3>\n";
 298     nvt_print(
 299       "HTTP/1.1 302 Found",
 300       "Location: $ENV{PROTO}://$ENV{HTTP_HOST}/fup?akey=$akey&command=LISTRECEIVED",
 301       'Content-Length: 0',
 302       ""
 303     );
 304     &reexec;
 305   } else {
 306     my $s = $!;
 307     http_header('404 Not Found');
 308     print html_header($head);
 309     print "<h3>$filename not deleted ($s)</h3>\n";
 310     print "<a href=\"/fup?akey=$akey&command=LISTRECEIVED\">continue</a>\n" if $akey;
 311     print "</body></html>\n";
 312   }
 313   exit;
 314 }
 315
 316 # special commands
 317 if (($from and $id and $rid eq $id or $gkey or $skey) and $command) {
 318
 319   if ($command eq 'CHECKQUOTA') {
 320     http_die("illegal command \"$command\"") if $public or $anonymous;
 321     nvt_print('HTTP/1.1 204 OK');
 322     # nvt_print("X-SID: $ENV{SID}") if $ENV{SID};
 323     ($quota,$du) = check_sender_quota($muser||$from);
 324     nvt_print("X-Sender-Quota: $quota $du")    if $quota;
 325     ($quota,$du) = check_recipient_quota($muser||$from);
 326     nvt_print("X-Recipient-Quota: $quota $du") if $quota;
 327     nvt_print('');
 328     exit;
 329   }
 330
 331   if ($command eq 'LISTSETTINGS') {
 332     http_die("illegal command \"$command\"") if $public or $anonymous;
 333     nvt_print('HTTP/1.1 204 OK');
 334     # nvt_print("X-SID: $ENV{SID}") if $ENV{SID};
 335     ($quota,$du) = check_sender_quota($muser||$from);
 336     nvt_print("X-Sender-Quota: $quota $du")    if $quota;
 337     ($quota,$du) = check_recipient_quota($muser||$from);
 338     nvt_print("X-Recipient-Quota: $quota $du") if $quota;
 339     $autodelete = lc(readlink "$from/\@AUTODELETE" || $autodelete);
 340     nvt_print("X-Autodelete: $autodelete");
 341     $keep = readlink "$from/\@KEEP" || $keep;
 342     nvt_print("X-Default-Keep: $keep");
 343     $locale = readlink "$from/\@LOCALE" || $default_locale || 'english';
 344     nvt_print("X-Default-Locale: $locale");
 345     $mime = -e "$from/\@MIME" ? 'yes' : 'no';
 346     nvt_print("X-MIME: $mime");
 347     nvt_print('');
 348     exit;
 349   }
 350
 351   if ($command eq 'RENOTIFY') {
 352     http_die("illegal command \"$command\"") if $public or $anonymous;
 353     my $nfile = '';
 354     if ($dkey) {
 355       # resend notification e-mail
 356       $file = readlink("$dkeydir/$dkey")
 357         or html_error($error,"illegal DKEY $dkey");
 358       $file =~ s:^../::;
 359       $file = untaint($file);
 360       unlink "$file/download"; # re-allow download from any ip address
 361       notify_locale($dkey,'new');
 362       http_header(
 363         '200 OK',
 364         "X-Notify: $file",
 365       );
 366       $nfile = $file;
 367     } else {
 368       http_header('200 OK');
 369     }
 370     print html_header($head);
 371     # list sent files
 372     print "<h3>Files from $from, ",
 373           "click on the file name to resend a notification e-mail:</h3>\n",
 374           "<pre>\n";
 375     foreach $file (glob "*/$from/*") {
 376       next if $file =~ m:/STDFEX$:;
 377       next if $file =~ m:(.+?)/: and -l $1;
 378       $size = -s "$file/data";
 379       next unless $size;
 380       $size = int($size/$MB+0.5);
 381       $filename = $comment = '';
 382       my $rto = $file;
 383       $rto =~ s:/.*::;
 384       if ($dkey = readlink "$file/dkey") {
 385         if ($rto ne $to) {
 386           $to = $rto;
 387           print "\nto $to :\n";
 388         }
 389         if (open $file,'<',"$file/filename") {
 390           $filename = <$file>;
 391           close $file;
 392         }
 393         if ($filename and length $filename) {
 394           $filename = html_quote($filename);
 395         } else {
 396           $filename = '???';
 397         }
 398         if (open $file,'<',"$file/comment") {
 399           $comment = untaint(html_quote(getline($file)));
 400           close $file;
 401         }
 402         my $rkeep = untaint(readlink "$file/keep"||$keep_default)
 403                     - int((time-mtime("$file/filename"))/$DS);
 404         if ($comment =~ /NOMAIL/ or
 405            (readlink "$to/\@NOTIFICATION"||'') =~ /^no/i) {
 406           printf "%8s MB (%2s d) %s/%s/%s\n",
 407                  $size,
 408                  $rkeep,
 409                  $durl,
 410                  $dkey,
 411                  urlencode(basename($file));
 412         } else {
 413           printf "%8s MB (%2s d) <a href=\"%s\">%s</a>%s %s\n",
 414                  $size,
 415                  $rkeep,
 416                  untaint("/fup?akey=$akey&dkey=$dkey&command=RENOTIFY"),
 417                  $filename,
 418                  $comment ? qq' "$comment"' : '',
 419                  $file eq $nfile ?
 420                    " &rarr; notification e-mail has been resent" :
 421                    "";
 422         }
 423       }
 424     }
 425     pq(qq(
 426       '</pre>'
 427       '<p><a href="/foc?akey=$akey">back to F*EX operation control</a>'
 428       '</body></html>'
 429     ));
 430     exit;
 431   }
 432
 433   if ($command =~ /^LIST(RECEIVED)?$/) {
 434     http_die("illegal command \"$command\"") if $public or $anonymous;
 435     # list sent files
 436     if ($to and $param{'TO'} eq '*') {
 437       http_header('200 OK');
 438       print html_header($head);
 439 #            "(Format: [size] [rest keep time] [filename] [comment])<p>\n",
 440       print "<h3>Files from $from:</h3>\n",
 441             "<pre>\n";
 442       foreach $file (glob "*/$from/*") {
 443         next if $file =~ m:/STDFEX$:;
 444         next if $file =~ m:(.+?)/: and -l $1;
 445         $size = -s "$file/data";
 446         next unless $size;
 447         $size = int($size/$MB+0.5);
 448         $filename = $comment = '';
 449         my $rto = $file;
 450         $rto =~ s:/.*::;
 451         if ($dkey = readlink "$file/dkey") {
 452         # die $file if -s "$file/data" and $file =~ /^$from/;
 453           if ($rto ne $to) {
 454             $to = $rto;
 455             print "\nto $to :\n";
 456           }
 457           if (open $file,'<',"$file/filename") {
 458             $filename = <$file>;
 459             close $file;
 460           }
 461           if ($filename and length $filename) {
 462             $filename = html_quote($filename);
 463           } else {
 464             $filename = '???';
 465           }
 466           if (open $file,'<',"$file/comment") {
 467             $comment = untaint(html_quote(getline($file)));
 468             close $file;
 469           }
 470           my $rkeep = untaint(readlink "$file/keep"||$keep_default)
 471                       - int((time-mtime("$file/filename"))/$DS);
 472           printf "%8s MB (%2s d) %s <a href=\"%s\">%s</a>%s\n",
 473                  $size,
 474                  $rkeep,
 475                  stat("$file/download")?'+':'-',
 476                  untaint("/fup?akey=$akey&dkey=$dkey&command=FORWARD"),
 477                  $filename,
 478                  $comment?qq( "$comment"):'';
 479         }
 480       }
 481       pq(qq(
 482         '</pre>'
 483         '<p><a href="javascript:history.back()">back to F*EX operation control</a>'
 484         '</body></html>'
 485       ));
 486     }
 487     # list received files
 488     else {
 489       $to = $from;
 490       http_header('200 OK');
 491       print html_header($head);
 492 #            "(Format: [size] [rest keep time] [URL] [comment])<p>\n",
 493       print "<h3>Files for $to (*):</h3>\n",
 494             "<pre>\n";
 495       foreach $from (glob "$to/*") {
 496         next if $from =~ /[A-Z]/;
 497         $from =~ s:.*/::;
 498         $url = '';
 499         foreach $file (glob "$to/$from/*") {
 500           next if $file =~ /\/STDFEX$/;
 501           $filename = $comment = '';
 502           $size = -s "$file/data";
 503           next unless $size;
 504           $size = int($size/$MB+0.5);
 505           if ($dkey = readlink "$file/dkey") {
 506             print "\nfrom $from :\n" unless $url;
 507             $file =~ m:.*/(.+):;
 508             $url = "$durl/$dkey/$1";
 509             unless (-l "$dkeydir/$dkey") {
 510               symlink untaint("../$file"),untaint("$dkeydir/$dkey");
 511             }
 512             if (open $file,'<',"$file/filename") {
 513               $filename = <$file>;
 514               close $file;
 515             }
 516             if ($filename and length $filename) {
 517               $filename = html_quote($filename);
 518             } else {
 519               $filename = '???';
 520             }
 521             if (open $file,'<',"$file/comment") {
 522               $comment = untaint(html_quote(getline($file)));
 523               $comment = ' "'.$comment.'"';
 524               close $file;
 525             }
 526             my $rkeep = untaint(readlink "$file/keep"||$keep_default)
 527                         - int((time-mtime("$file/filename"))/$DS);
 528             printf "[<a href=\"/fup?akey=%s&dkey=%s&command=DELETE\">delete</a>] ",
 529                    $akey,$dkey;
 530             printf "[<a href=\"/fup?akey=%s&dkey=%s&command=COPY\">forward</a>] ",
 531                    $akey,$dkey;
 532             printf "%8s MB (%2s d) <a href=\"%s\">%s</a>%s\n",
 533                    $size,$rkeep,$url,$filename,$comment;
 534           }
 535         }
 536       }
 537       pq(qq(
 538         '</pre>'
 539         '(*) Files for other e-mail addresses you own will not be listed here!<p>'
 540         '<a href="/foc?akey=$akey">back to F*EX operation control</a>'
 541         '</body></html>'
 542       ));
 543     }
 544     exit;
 545   }
 546
 547   if ($command eq 'LISTSENT') {
 548     http_die("illegal command \"$command\"") if $public or $anonymous;
 549     # show download URLs
 550     http_header('200 OK');
 551     print html_header($head);
 552     print "<h2>Download URLs of files you have sent\n";
 553     foreach $to (glob "*/$from") {
 554       if (@files = glob "$to/*/data") {
 555         $to =~ s:/.*::;
 556         print "<h3>to <code>$to</code> :</h3>\n";
 557         print "<pre>\n";
 558         foreach $file (@files) {
 559           $file =~ s:/data::;
 560           next if $file =~ /\/STDFEX$/;
 561           $dkey = readlink "$file/dkey" or next;
 562           $file =~ s:.*/::;
 563           print "$ENV{PROTO}://$ENV{HTTP_HOST}/fop/$dkey/$file\n";
 564         }
 565         print "</pre>\n";
 566       }
 567     }
 568     pq(qq(
 569       '</pre>'
 570       '<p><a href="javascript:history.back()">back to F*EX operation control</a>'
 571       '</body></html>'
 572     ));
 573     exit;
 574   }
 575
 576   if ($command eq 'FOPLOG') {
 577     http_die("illegal command \"$command\"") if $public or $anonymous;
 578     if (open my $log,"$logdir/fop.log") {
 579       http_header('200 OK');
 580       while (<$log>) {
 581         next if /\/STDFEX\s/;
 582         if (s:^([^/]+)/$from/:$1 :) {
 583           if (s:(\d+)/(\d+)$:$1: and $1 and $1 == $2) {
 584             s/ \[[\d_]+\]//;
 585             print;
 586           }
 587         }
 588       }
 589     }
 590     exit;
 591   }
 592
 593   if ($command eq 'RECEIVEDLOG') {
 594     http_die("illegal command \"$command\"") if $public or $anonymous;
 595     if (open my $log,"$logdir/fup.log") {
 596       http_header('200 OK');
 597       while (<$log>) {
 598         next if /\sSTDFEX\s/;
 599         if (/\d+$/) {
 600           my @F = split;
 601           if ($F[5] eq $to) {
 602             s/ \[[\d_]+\]//;
 603             print;
 604           }
 605         }
 606       }
 607     }
 608     exit;
 609   }
 610
 611   if ($command eq 'SENDLOG') {
 612     http_die("illegal command \"$command\"") if $public or $anonymous;
 613     if (open my $log,"$logdir/fup.log") {
 614       http_header('200 OK');
 615       while (<$log>) {
 616         next if /\sSTDFEX\s/;
 617         if (/(\S+\@\S+)/ and $1 eq $from) {
 618           s/ \[[\d_]+\]//;
 619           print;
 620         }
 621       }
 622     }
 623     exit;
 624   }
 625
 626   if (@to and $command eq 'CHECKRECIPIENT') {
 627     http_die("illegal command \"$command\"") if $public or $anonymous;
 628     check_rr($from,@to);
 629     nvt_print('HTTP/1.1 204 OK');
 630     nvt_print("X-SID: $sid") if $sid;
 631     foreach my $to (@group?@group:@to) {
 632       # my $options = sprintf "(autodelete=%s,keep=%s,locale=%s)",
 633       # readlink "$to/\@LOCALE"||$locale||$locale{$to}||$default_locale;
 634       my $options = sprintf "(autodelete=%s,keep=%s,locale=%s,notification=%s)",
 635         $autodelete{$to}||$autodelete,
 636         $keep{$to}||$keep_default,
 637         readlink("$to/\@LOCALE")||$default_locale,
 638         readlink("$to/\@NOTIFICATION")||'full';
 639       nvt_print("X-Recipient: $to $options");
 640     }
 641     nvt_print('');
 642     # control back to fexsrv for further HTTP handling
 643     &reexec;
 644   }
 645
 646   if ($file and @to and $command eq 'DELETE') {
 647     http_die("illegal command \"$command\"") if $public or $anonymous;
 648     foreach (@group?@group:@to) {
 649       my $to = $_;
 650       $to =~ s/:\w+=.*//; # remove options from address
 651       $del = "$to/$from/$fkey";
 652       # swap to and from for special senders, see fup storage swap!
 653       $del = "$from/$to/$fkey" if $from =~ /^(fexmail|anonymous)/;
 654
 655       $del =~ s:^/+::;
 656       if ($del =~ /\/\./) {
 657         http_die("illegal parameter <code>$del</code>");
 658       }
 659       $del = untaint($del);
 660
 661       if (unlink("$del/data") or unlink("$del/upload")) {
 662         if (open F,'>',"$del/error") {
 663           print F "$file has been deleted by $from\n";
 664           close F;
 665         }
 666         http_header('200 OK',"X-File: $del");
 667         print html_header($head);
 668         print "<h3>$file deleted</h3>\n";
 669       } else {
 670         http_header("404 Not Found");
 671         print html_header($head);
 672         print "<h3>$file not deleted</h3>\n";
 673       }
 674       if ($akey) {
 675         printf "<a href=\"/fup?akey=%s&to=%s&command=LISTRECEIVED\">continue</a>\n",
 676                $akey,$to;
 677       }
 678       print "</body></html>\n";
 679     }
 680     exit;
 681   }
 682
 683 }
 684
 685 # ip restrictions
 686 if ($from and $id and $rid eq $id and open my $ipr,"$from/\@UPLOAD_HOSTS") {
 687   my @hosts;
 688   while (<$ipr>) {
 689     chomp;
 690     s/#.*//;
 691     push @hosts,$_ if /\w/;
 692   }
 693   close $ipr;
 694   unless (@hosts and ipin($ra,@hosts)) {
 695     http_die("<code>$from</code> is not allowed to upload from IP $ra");
 696   }
 697 }
 698
 699 # quotas
 700 if ($from and $id and $rid eq $id and @to and not $flink and not $seek) {
 701   my ($quota,$du);
 702
 703   # check sender quota
 704   ($quota,$du) = check_sender_quota($muser||$from);
 705   if ($quota and $du+$cl/$MB > $quota) {
 706     http_die("you are overquota");
 707   }
 708
 709   # check recipient quota
 710   foreach my $to (@to) {
 711     ($quota,$du) = check_recipient_quota($to);
 712     if ($quota and $du+$cl/$MB > $quota) {
 713       http_die("$to cannot receive files: is overquota");
 714     }
 715   }
 716
 717 }
 718
 719 # check recipients restriction
 720 if ($id and $id eq $rid and $from and @to and not $public) {
 721   check_rr($from,@to);
 722 }
 723
 724 # on secure mode "fop authorization" also check if recipient(s) exists
 725 # (= has a F*EX ID)
 726 if (not $addto and $fop_auth and $id and $id eq $rid and $from and @to) {
 727   my ($to_reg,$idf,$subuser);
 728   foreach my $to (my @loop = @to) {
 729     $to =~ s/:\w+=.*//; # remove options from address
 730     $to_reg = 0;
 731     # full user?
 732     if (open $idf,'<',"$to/@") {
 733       $to_reg = getline($idf);
 734       close $idf;
 735     }
 736     # sub user?
 737     elsif (open $idf,'<',"$from/\@SUBUSER") {
 738       while (<$idf>) {
 739         s/#.*//;
 740         next unless /:/;
 741         chomp;
 742         ($subuser) = split ':';
 743         if ($subuser eq $to or $subuser eq '*@*'
 744             or $subuser =~ /^\*\@(.+)/ and $to =~ /\@\Q$1\E$/i
 745             or $subuser =~ /(.+)\@\*$/ and $to =~ /^\Q$1\E\@/i) {
 746           $to_reg = $_;
 747           last;
 748         }
 749       }
 750       close $idf;
 751     }
 752     unless ($to_reg) {
 753       http_die("recipient <code>$to</code> is not a registered F*EX full or sub user");
 754     }
 755   }
 756 }
 757
 758 $to = join(',',@to);
 759
 760 if ($to =~ /^@(.+)/) {
 761   if ($nomail) {
 762     http_die("server runs in NOMAIL mode - groups ($to) are not allowed");
 763   }
 764   my $gf = "$from/\@GROUP/$1";
 765   if (open $gf,'<',$gf) {
 766     while (<$gf>) {
 767       s/#.*//;
 768       push @group,$1 if /(.+@.+):/;
 769     }
 770   }
 771   close $gf;
 772   $group = $to;
 773 }
 774
 775 if ($redirect) {
 776   nvt_print(
 777     "HTTP/1.1 302 Found",
 778     "Location: $ENV{PROTO}://$ENV{HTTP_HOST}/$redirect?akey=$akey",
 779     'Content-Length: 0',
 780     ""
 781   );
 782   &reexec;
 783 }
 784
 785 if ($from and $id and $id eq $rid and $faillog) {
 786   unlink $faillog;
 787 }
 788
 789 # display HTML form and request user data
 790 unless ($file) {
 791
 792   if ($test) { $cgi = $test }
 793   else       { $cgi = $ENV{SCRIPT_NAME} }
 794   $cgi = 'fup';
 795
 796   # delete old cookies on logout referer
 797   my @cookies;
 798   if ($logout and my $cookie = $ENV{HTTP_COOKIE}) {
 799     while ($cookie =~ s/(\w+key)=\w+//) {
 800       push @cookies,"Set-Cookie: $1=x; path=/; expires=Thu, 01 Jan 1970 00:00:00 GMT";
 801     }
 802   }
 803
 804   if (($akey or $skey or $gkey) and $from and -d $from) {
 805     # save default locale for this user
 806     if (not $locale and ($ENV{HTTP_COOKIE}||'') =~ /\blocale=(\w+)/) {
 807       $locale = $1;
 808     }
 809     mksymlink("$from/\@LOCALE",$locale) if $locale;
 810   }
 811
 812   http_header('200 OK',@cookies);
 813   # print html_header($head,'<img src="/fex_small.gif">');
 814   print html_header($head);
 815
 816   if ($http_client =~ /(Konqueror|w3m)/) {
 817     pq(qq(
 818       '<p><hr><p>'
 819       '<center>'
 820       '<h3>Your client seems to be "$1" which is incompatible with F*EX and will probably not work!</h3>'
 821       'We recommend firefox.'
 822       '</center>'
 823       '<p><hr><p>'
 824     ));
 825   }
 826
 827   # default "fex yourself" setting?
 828   if ($from and $id and $id eq $rid and not $addto
 829       and not ($gkey or $skey or $okey or $public or $anonymous)
 830       and (not @to or "@to" eq $from)
 831       and -f "$from/\@FEXYOURSELF")
 832   {
 833     @to = ($from);
 834     $nomail = 'fexyourself';
 835   }
 836
 837   # ask for recipient address(es)
 838   elsif ($from and $id and $id eq $rid and ($addto or not $submit or not @to)
 839          and not ($gkey or $skey or $okey or $public or $anonymous))
 840   {
 841     present_locales('/fup');
 842
 843     @ab = ("<option></option>");
 844
 845     # select menu from server address book
 846     if (open my $AB,'<',"$from/\@ADDRESS_BOOK") {
 847       while (<$AB>) {
 848         s/#.*//g;
 849         if (/(\S+)[=\s]+(\S+@[\w.-]+\S*)/) {
 850           $_ = "$1 &lt;$2>";
 851           s/,.*/,.../g;
 852           push @ab,"<option>$_</option>";
 853         }
 854       }
 855       close $AB;
 856     }
 857
 858     unless (@to) {
 859       unless ($nomail) {
 860         foreach (glob "$from/\@GROUP/*") {
 861           if (-f and not -l) {
 862             s:.*/::;
 863             push @ab,"<option>\@$_</option>" unless /~$/;
 864           }
 865         }
 866       }
 867     }
 868
 869     my $ab64 = b64("from=$from&id=$id");
 870 #     '<form class="uploadform" name="upload"'
 871     pq(qq(
 872       '<form name="upload"'
 873       '      action="/fup"'
 874       '      method="post"'
 875       '      accept-charset="UTF-8"'
 876       '      enctype="multipart/form-data">'
 877       '  <input type="hidden" name="from" value="$from">'
 878       '  <input type="hidden" name="id"   value="$id">'
 879       '  <table border="1">'
 880       '    <tr><td>sender:   <td><a href="/foc">$from</a></tr>'
 881       '    <tr title="e-mail address or alias"><td>recipient(s):'
 882       '        <td><input type="text" name="to" size="96" value="$to"><br>'
 883     ));
 884     if (grep /@/,@ab) {
 885       pq(qq(
 886         '        or select from your address book:'
 887         '        <select name="addto" size="1">@ab</select>'
 888         '        and'
 889         '        <input type="submit" name="addsubmit" value="add to recipients list">'
 890       ));
 891     }
 892     pq(qq(
 893       '    </tr>'
 894       '  </table>'
 895       '  <p>'
 896     ));
 897     my $rr = "$from/\@ALLOWED_RECIPIENTS";
 898     if (-s $rr and open $rr,'<',$rr) {
 899       pq(qq(
 900         'You are a restricted user and may only fex to these recipients:<p>'
 901         '<pre>'
 902       ));
 903       while (<$rr>) {
 904         chomp;
 905         s/#.*//;
 906         s/\s//g;
 907         next unless $_;
 908         if (/^\@LOCAL_RDOMAINS/) {
 909           foreach my $rd (@local_rdomains) {
 910             print "*\@$rd\n";
 911           }
 912         } elsif (/^\@LOCAL_USERS/) {
 913           foreach (glob "*/@") {
 914             s:/.::;
 915             print "$_\n";
 916           }
 917         } else {
 918           print "$_\n";
 919         }
 920       }
 921       print "</pre><p>\n";
 922       close $rr;
 923     }
 924     print qq'  <input type="submit" name="submit" value="check recipient(s) and continue">';
 925     if ($fex_yourself =~ /^yes|1/i) {
 926       print qq' or <input type="submit" name="fexyourself" value="fex yourself">'
 927     }
 928     print "\n</form>\n<p>\n";
 929     if ($akey and -f "$from/\@" and not $captive ) {
 930       pq(qq(
 931         '<a href="/foc?akey=$akey">user config & operation control</a>'
 932       ));
 933     }
 934
 935     if ($from eq $admin ) {
 936       pq(qq(
 937         '<p>'
 938         '<a href="/fac">server config & admin control</a>'
 939       ));
 940     }
 941
 942     if (0 and -f "$docdir/FIX.jar") {
 943       print "<p>\n";
 944       if    ($public) { print "<a href=\"/fix?from=$from&id=$public&to=$to\">" }
 945       elsif ($skey)   { print "<a href=\"/fix?skey=$skey&to=$to\">" }
 946       elsif ($gkey)   { print "<a href=\"/fix?gkey=$gkey&to=$to\">" }
 947       else            { print "<a href=\"/fix?akey=$akey\">" }
 948       print "Alternate Java client</a> (for files > 2 GB or sending of more than one file)\n";
 949     }
 950     print &logout;
 951     if (-x "$FEXHOME/cgi-bin/login") {
 952       print $info_login||$info_1;
 953     }
 954     pq(qq(
 955       '<p><hr><p>'
 956       '<b>'
 957       'Warning: the recipient must not be a mailing list,'
 958       'because after download the file will be no more available!'
 959       '</b><br>'
 960       'Contact <a href="mailto:$ENV{SERVER_ADMIN}">fexmaster</a> if you want to fex to a mailing list,'
 961       'he can allow multiple downloads for specific addresses.'
 962       '<p>'
 963       'Use a <a href="/tools.html">F*EX client</a> if you want to send more than one file or resume an interrupted upload.'
 964       '</body></html>'
 965       '<p>
 966    ));
 967     exit;
 968   }
 969
 970   # ask for filename
 971   if ($from and ($id or $okey)) {
 972     $to = $group if $group;
 973     present_locales($ENV{REQUEST_URI}) if $skey or $gkey or $okey;
 974 #      "        '$ENV{PROTO}://$ENV{HTTP_HOST}/$cgi?showstatus=$uid',"
 975     pq(qq(
 976       '<script type="text/javascript">'
 977       '  function showstatus() {'
 978       '    var file = document.forms["upload"].elements["file"].value;'
 979       '    if (file == "") return false;'
 980       '    window.open('
 981       "      '/$cgi?showstatus=$uid',"
 982       "      'fup_status',"
 983       "      'width=700,height=500'"
 984       '    );'
 985       '    return true;'
 986       '  }'
 987       ''
 988       '  function checkupload() {'
 989       '    var file  = document.forms["upload"].elements["file"].value;'
 990       '    if (file == "") { alert("No file selected"); }'
 991       '  }'
 992       ''
 993       '  function reportsize() {'
 994       '    var form = document.forms["upload"];'
 995       '    var filesize = form.file.files[0].size;'
 996       '    // alert(filesize + " bytes");'
 997       '    form.elements["filesize"].value = filesize;'
 998       '    filesize = filesize.toString();'
 999       '    filesize = filesize.replace(/(\\d)(?=(\\d\\d\\d)+(?!\\d))/g,"\$1,");'
1000       '    document.getElementById("filesize").innerHTML = filesize + " bytes";'
1001       '  }'
1002       '</script>'
1003     ));
1004     pq(qq(
1005       '<form name="upload"'
1006       '      action="/fup"'
1007       '      method="post"'
1008       '      accept-charset="UTF-8"'
1009       '      enctype="multipart/form-data"'
1010       '      onsubmit="return showstatus();">'
1011       '  <input type="hidden" name="uid"      value="$uid">'
1012       '  <input type="hidden" name="from"     value="$from">'
1013       '  <input type="hidden" name="filesize" value="">'
1014     ));
1015
1016     if ($public) {
1017       my $toh = join('<br>',@to);
1018       pq(qq(
1019         '  <input type="hidden" name="id" value="$public">'
1020         '  <input type="hidden" name="to" value="$to">'
1021         '  <table border="1">'
1022         '    <tr><td>sender:   <td><code>$from</code></tr>'
1023         '    <tr><td>recipient:<td><code>$toh</code></tr>'
1024       ));
1025     } elsif ($okey) {
1026       pq(qq(
1027         '  <input type="hidden" name="okey" value="$okey">'
1028         '  <input type="hidden" name="to" value="$to">'
1029         '  <table border="1">'
1030         '    <tr><td>sender:   <td>$from</tr>'
1031         '    <tr><td>recipient:<td>$to</tr>'
1032       ));
1033     } elsif ($skey) {
1034       pq(qq(
1035         '  <input type="hidden" name="skey" value="$skey">'
1036         '  <table border="1">'
1037         '    <tr><td>sender:   <td>$from</tr>'
1038         '    <tr><td>recipient:<td>$to</tr>'
1039       ));
1040     } elsif (@group) {
1041       if ($gkey) {
1042         pq(qq(
1043           '  <input type="hidden" name="gkey" value="$gkey">'
1044         ));
1045       }
1046       my $toh = "group $group:<ul>";
1047       my $toc = join(',',@group);
1048       foreach my $gm (@group) { $toh .= "<li>$gm" }
1049       $toh .= "</ul>";
1050       pq(qq(
1051         '  <input type="hidden" name="id" value="$id">'
1052         '  <table border="1">'
1053         '    <tr><td>sender:<td>$from</tr>'
1054         '    <tr><td>recipient(s):'
1055         '        <td><input type="hidden" name="to" value="$toc">$toh</tr>'
1056       ));
1057     } else {
1058       my $toc = join(',',@to);
1059       my $toh = join('<br>',@to);
1060       pq(qq(
1061         '  <input type="hidden" name="akey" value="$akey">'
1062         '  <table border="1">'
1063         '    <tr><td>sender:<td><a href="/foc">$from</a></tr>'
1064       ));
1065       if ($anonymous) {
1066         pq(qq(
1067           '    <tr><td>recipient:'
1068           '        <td><input type="hidden" name="to" value="$toc">$toh</tr>'
1069         ));
1070       } else {
1071         pq(qq(
1072           '    <tr><td><a href="/fup?akey=$akey&to=$toc">recipient(s)</a>:'
1073           '        <td><input type="hidden" name="to" value="$toc">$toh</tr>'
1074         ));
1075       }
1076     }
1077
1078     $autodelete = lc $autodelete;
1079     $keep = $keep_default unless $keep;
1080     my ($quota,$du) = check_sender_quota($muser||$from);
1081     $quota = $quota
1082            ? "<tr><td>sender quota (used):<td>$quota ($du) MB</tr>"
1083            : '';
1084
1085     $bwl = qq'<input type="text" name="bwlimit" size="8" value="$bwlimit"> kB/s';
1086     if (@throttle) {
1087       foreach (@throttle) {
1088         if (/\[?(.+?)\]?:(\d+)$/) {
1089           my $throttle = $1;
1090           my $limit = $2;
1091           # throttle ip address?
1092           if ($throttle =~ /^[\w:.-]+$/) {
1093             if (ipin($ra,$throttle)) {
1094               $bwl = qq'<input type="hidden" name="bwlimit" value="$limit"> $limit kB/s';
1095               last;
1096             }
1097           }
1098           # throttle e-mail address?
1099           else {
1100             # allow wildcard *, but not regexps
1101             $throttle =~ quotemeta $throttle;
1102             $throttle =~ s/\*/.*/g;
1103             if ($from =~ /^$throttle$/i) {
1104               $bwl = qq'<input type="hidden" name="bwlimit" value="$limit"> $limit kB/s';
1105               last;
1106             }
1107           }
1108         }
1109       }
1110     }
1111
1112     $autodelete = $autodelete{$to} if $autodelete{$to};
1113
1114     my $adt = '';
1115     for ($autodelete) {
1116          if (/yes/i)   { $adt = 'delete file after download' }
1117       elsif (/no/i)    { $adt = 'do not delete file after download' }
1118       elsif (/delay/i) { $adt = 'delete file after download with delay' }
1119       elsif (/^\d+$/)  { $adt = "delete file $autodelete days after download" }
1120     }
1121     $adt .= qq'<input type="hidden" name="autodelete" value="$autodelete">';
1122
1123     my $ctr = my $ktr = '';
1124     if ($nomail) {
1125       $ctr = qq'<em>no notification e-mail will be send</em>';
1126     } else {
1127       $ctr = qq'<input type="text" name="comment" size="80" value="$comment">';
1128     }
1129     if ($captive) {
1130       $ktr = qq'$keep days<input type="hidden" name="keep" value="$keep">';
1131     } else {
1132       $ktr = qq'$keep days<input type="hidden" name="keep" value="$keep">';
1133     }
1134     pq(qq(
1135       '    <tr><td>autodelete:'
1136       '      <td>$adt'
1137       '    </tr>'
1138       '    <tr title="keep file max $keep days, then delete it"><td>keep:'
1139       '      <td>$ktr'
1140       '    </tr>'
1141       '    $quota'
1142       '    <tr title="optional, full speed if empty"><td>bandwith limit:'
1143       '      <td>$bwl'
1144       '    </tr>'
1145       '    <tr title="optional, will be included in notification e-mail"><td>comment:'
1146       '      <td>$ctr'
1147       '    </tr>'
1148       '    <tr title="If you want to send more than one file, then put them in a zip or tar archive"><td>file:'
1149       '      <td><input type="file" name="file" size="80" value="$file" onchange="reportsize();">'
1150       '    </tr>'
1151       '    <tr><td>file size:<td id="filesize"></td></tr>'
1152       '  </table>'
1153       '  <p>
1154       '  <input type="submit" value="upload" onclick="checkupload()">'
1155       '<p>'
1156       '</form>'
1157     ));
1158     if ($akey and -f "$from/\@" and not $captive) {
1159       print "<p>\n",
1160             "<a href=\"/foc?akey=$akey\">user config & operation control</a>\n";
1161     }
1162     if ($from eq $admin ) {
1163       pq(qq(
1164         '<p>'
1165         '<a href="/fac">server config & admin control</a>'
1166       ));
1167     }
1168     if (0 and -f "$docdir/FIX.jar" and not $okey) {
1169       print "<p>\n";
1170       if    ($public) { print "<a href=\"/fix?from=$from&id=$public&to=$to\">" }
1171       elsif ($skey)   { print "<a href=\"/fix?skey=$skey&to=$to\">" }
1172       elsif ($gkey)   { print "<a href=\"/fix?gkey=$gkey&to=$to\">" }
1173       else            { print "<a href=\"/fix?akey=$akey&to=$to\">" }
1174       print "Alternate Java client</a> (for files > 2 GB or sending of more than one file)\n";
1175     }
1176     print &logout;
1177     print $info_2;
1178     # printf "<hr><pre>%s</pre>\n",$ENV{HTTP_HEADER};
1179     print "</body></html>\n";
1180     exit;
1181   }
1182
1183   present_locales('/fup');
1184
1185   if ($ENV{REQUEST_METHOD} eq 'POST') {
1186     pq(qq(
1187       '<font color="red"><h3>'
1188       '  You have to fill out this form completely to continue.'
1189       '</h3></font>'
1190     ));
1191   }
1192
1193   pq(qq(
1194     '<form action="/fup"'
1195     '      method="post"'
1196     '      accept-charset="UTF-8"'
1197     '      enctype="multipart/form-data">'
1198     '  <table>'
1199     '    <tr><td>sender:'
1200     '        <td><input type="text"     name="from" size="40" value="$from"></tr>'
1201     '    <tr><td>auth-ID:'
1202     '        <td><input type="password" name="id"   size="16" value="$id" autocomplete="off"></tr>'
1203     '  </table>'
1204   ));
1205   if ($mail_authid and not ($fop_auth or $nomail)) {
1206 #    pq(qq(
1207 #      'If you enter "?" as your auth-ID then it will be sent by e-mail to you.'
1208 #      '<p>'
1209 #    ));
1210     pq(qq(
1211       '  <input type="checkbox" name="ID_forgotten" value="ID_forgotten">'
1212       '  I have lost my auth-ID! Send it to me by e-mail! '
1213       '  (you must fill out sender field above)'
1214     ));
1215   }
1216   pq(qq(
1217     '  <p><input type="submit" value="check ID and continue"><p>'
1218   ));
1219   if (not $nomail and (
1220     @local_domains and @local_hosts or
1221     @local_rdomains and @local_rhosts or
1222     @demo
1223   )) {
1224     pq(qq(
1225       'You can <a href="/fur">register yourself</a> '
1226       'if you do not have a F*EX account yet.<p>'
1227     ));
1228   }
1229   if (@anonymous_upload and ipin($ra,@anonymous_upload)) {
1230     my $a = 'anonymous_'.int(rand(999999));
1231     pq(qq(
1232       'You may also use <a href="/fup?from=anonymous&to=$a">anonymous upload</a>'
1233     ));
1234   }
1235   # if (-f "$docdir/sup.html") {
1236   #  pq(qq(
1237   #    '<br>'
1238   #    'You may also use <a href="/sup.html">simple upload</a>'
1239   #  ));
1240   # }
1241   print "</form>\n";
1242
1243   print $info_1;
1244
1245   if ($debug and $debug>1) {
1246     print "<hr>\n<pre>\n";
1247     foreach $v (sort keys %ENV) {
1248       print "$v = $ENV{$v}\n";
1249     }
1250     print "</pre>\n";
1251   }
1252
1253   print "</body></html>\n";
1254   exit;
1255 }
1256
1257 # from sup.html
1258 if ($from and $file and not @to) {
1259   check_rr($from,$from);
1260   @to = ($from);
1261   $sup = 'fexyourself';
1262   $keep{$from} = readlink("$from/\@KEEP")||$keep_default;
1263 }
1264
1265 # all these variables should be defined here, but just to be sure...
1266 http_die("no file specified")       unless $file;
1267 http_die("no sender specified")     unless $from;
1268 http_die("no recipient specified")  unless @to;
1269 unless ($okey and -l "$to/\@OKEY/$okey") {
1270   http_die("no auth-ID specified") unless $id;
1271   unless ($rid eq $id or $gkey or $skey) {
1272     faillog("user $from, id $id");
1273     http_die("wrong auth-ID specified");
1274   }
1275 }
1276
1277 &check_status($from);
1278
1279 if (@throttle) {
1280   foreach (@throttle) {
1281     if (/(.+):(\d+)$/) {
1282       my $throttle = $1;
1283       my $limit = $2;
1284       if (not $bwlimit or $limit < $bwlimit) {
1285         # throttle ip address?
1286         if ($throttle =~ /^[\d.-]+$/) {
1287           if (ipin($ra,$throttle)) {
1288             $bwlimit = $limit;
1289             last;
1290           }
1291         }
1292         # throttle e-mail address?
1293         else {
1294           # allow wildcard *, but not regexps
1295           $throttle =~ quotemeta $throttle;
1296           $throttle =~ s/\*/.*/g;
1297           if ($from =~ /^$throttle$/i) {
1298             $bwlimit = $limit;
1299             last;
1300           }
1301         }
1302       }
1303     }
1304   }
1305 }
1306
1307 # address rewriting for storage (swap sender and recipient), see also fop!
1308 if (not ($skey or $gkey) and $from =~ /^(anonymous|fexmail)/) {
1309   ($from,@to) = ("@to",$from);
1310 }
1311
1312 if (not $anonymous and $overwrite =~ /^n/i) {
1313   foreach $to (@to) {
1314     if (-f "$to/$from/$fkey/data") {
1315       http_die("<code>$file</code> already exists for <code>$to</code>");
1316     }
1317   }
1318 }
1319
1320 # additional last check
1321 unless (@group or $gkey or $skey or $public or $okey) {
1322   foreach $to (@to) {
1323     checkaddress($to) or
1324       http_die("<code>$to</code> is not a valid e-mail address");
1325   }
1326 }
1327
1328
1329 $to = join(',',@to);
1330
1331 # file overwriting for anonymous is only possible if his client has the
1332 # download cookie - else request purging
1333 if ($anonymous and not $seek and my $dkey = readlink "$to/$from/$fkey/dkey") {
1334   if ($overwrite =~ /^n/i) {
1335     http_die("<code>$file</code> already exists for <code>$to</code>");
1336   }
1337   if ($ENV{HTTP_COOKIE} !~ /$dkey/) {
1338     my $purge = "/fop/$dkey/$dkey?purge";
1339     # http_die("$file already exists $dkey:$ENV{HTTP_COOKIE}:");
1340     http_die("<code>$file</code> already exists - <a href=\"$purge\">purge it?!</a>");
1341   }
1342 }
1343
1344 if (@group) {
1345   @to = @group;
1346   $comment = "[$group] $comment";
1347 } elsif ($public) {
1348   $comment .= ' (public upload)';
1349 }
1350
1351 # file data still waits on STDIN ... get it now!
1352 &get_file;
1353
1354 if ($to eq $from and $file eq 'ADDRESS_BOOK') {
1355   unlink "$from/\@ADDRESS_BOOK";
1356   rename "$from/$from/ADDRESS_BOOK/upload","$from/\@ADDRESS_BOOK"
1357     or http_die("cannot save $from/\@ADDRESS_BOOK - $!\n");
1358   http_header('200 OK');
1359   print html_header($head);
1360   print "address book updated",
1361         "</body></html>\n";
1362   exit;
1363 }
1364
1365 # finalize upload
1366 unless ($nostore) {
1367   foreach (@group?@group:@to) {
1368     my $to = $_;
1369     $to =~ s/:\w+=.*//; # remove options from address
1370     $filed     = "$to/$from/$fkey";
1371     $save      = "$filed/data";
1372     $upload    = "$filed/upload";
1373     $download  = "$filed/download";
1374     $dkey{$to} = readlink "$filed/dkey";
1375     $overwrite{$to}++ if -f $save and not -f $download;
1376     unlink $save,$download;
1377     rename $upload,$save or http_die("cannot rename $upload to $save - $!\n");
1378
1379     # log dkey
1380     my $msg = sprintf "%s %s %s %s %s\n",
1381                       isodate(time),$dkey{$to},$from,$to,$fkey;
1382     writelog('dkey.log',$msg);
1383
1384     # send notification e-mails if necessary
1385     if (not $nomail and (readlink "$to/\@NOTIFICATION"||'') !~ /^no/i
1386         and ($comment or not $overwrite{$to})) {
1387       notify_locale($dkey{$to},'new');
1388       debuglog("notify $filed [$filename] '$comment'");
1389     }
1390   }
1391 }
1392
1393 # send HTTP status
1394 $HTTP_HEADER = 'HTTP/1.1 200 OK';
1395 if ($nostore) {
1396   nvt_print($HTTP_HEADER,'Content-Type: text/html','');
1397   exit if $http_client =~ /^fexsend/;
1398 } elsif ($file eq 'STDFEX') {
1399   nvt_print($HTTP_HEADER,'');
1400   exit;
1401 } else {
1402   nvt_print($HTTP_HEADER);
1403   if ($xkey and not $restricted) {
1404     my $x = "$durl//$xkey";
1405     $x =~ s:/fop::;
1406     nvt_print("X-Location: $x");
1407   }
1408   if ($anonymous) {
1409     my $dkey = $dkey{$to};
1410     my $cookie = $dkey;
1411     $cookie = $1 if $ENV{HTTP_COOKIE} =~ /anonymous=([\w:]+)/;
1412     $cookie .= ':'.$dkey if $cookie !~ /$dkey/;
1413     nvt_print("Set-Cookie: anonymous=$cookie");
1414     $keep{$to} = readlink("$to/\@KEEP")||$keep_default;
1415   }
1416   foreach (@group?@group:@to) {
1417     my $to = $_;
1418     $to =~ s/:\w+=.*//; # remove options from address
1419     my $file = "$to/$from/$fkey";
1420     my $options = sprintf "(autodelete=%s,keep=%s,locale=%s,notification=%s)",
1421       readlink("$file/autodelete")||$autodelete,
1422       readlink("$file/keep")||readlink("$to/\@KEEP")||$keep_default,
1423       readlink("$to/\@LOCALE")||readlink("$file/locale")||$default_locale,
1424       readlink("$to/\@NOTIFICATION")||'full';
1425     nvt_print("X-Recipient: $to $options");
1426     nvt_print("X-Location: $durl/$dkey{$to}/$fkey") unless $restricted;
1427   }
1428   if ($http_client =~ /^(fexsend|schwuppdiwupp)/) {
1429     nvt_print('');
1430     exit;
1431   } else {
1432     nvt_print('Content-Type: text/html','');
1433   }
1434 }
1435
1436 # send HTML report
1437 print html_header($head);
1438
1439 if ($nostore) {
1440   printf "%s (%s MB) received\n",$file,int($ndata/$MB);
1441 } elsif (not $restricted and ($anonymous or $from eq $to)) {
1442   my $size = $ndata<2*1024 ? sprintf "%s B",$ndata:
1443              $ndata<2*$MB  ? sprintf "%s kB",int($ndata/1024):
1444                              sprintf "%s MB",int($ndata/$MB);
1445   pq(qq(
1446     '<code>$file</code> ($size) received and saved<p>'
1447     'Download URL for copy & paste:'
1448     '<h2>$durl/$dkey{$to}/$fkey</h2>'
1449     'Link is valid for $keep{$to} days!<p>'
1450   ));
1451 } else {
1452   if ($ndata<2*1024) {
1453     print "<code>$file</code> ($ndata B) received and saved<p>\n";
1454     if (not $boring and not $seek) {
1455       print "Ehh... $ndata <b>BYTES</b>?! You are kidding?<p>\n";
1456     }
1457   } elsif ($ndata<2*$MB) {
1458     $ndata = int($ndata/1024);
1459     print "<code>$file</code> ($ndata kB) received and saved<p>\n";
1460     if ($ndata<1024 and not ($boring or $seek)) {
1461       print "Using F*EX for less than 1 MB: ",
1462         "ever heard of MIME e-mail? &#9786;<p>\n";
1463     }
1464   } else {
1465     $ndata = int($ndata/$MB);
1466     print "<code>$file</code> ($ndata MB) received and saved<p>\n";
1467   }
1468   print "<ul>\n";
1469   foreach $to (@to) {
1470     print "<li>";
1471     if ($nomail or $nomail{$to}) {
1472       if ($restricted) {
1473         rmrf("$to/$from/$fkey");
1474         print "<code>$file</code> removed because you are a restricted user ".
1475               "and recipient $to cannot receive e-mail<p>\n";
1476       } else {
1477         pq(qq(
1478           '$to cannot receive e-mail &rarr;'
1479           '<h3><font color="red">'
1480           '  No notification e-mail has been sent to $to!'
1481           '</font></h3>'
1482           'Download URL for copy & paste:'
1483         ));
1484         if ($xkey) {
1485           my $x = "$durl{$to}//$xkey";
1486           $x =~ s:/fop::;
1487           print "<h2><code>$x</code></h2>\n";
1488         } else {
1489           print "<h2>$durl/$dkey{$to}/$fkey</h2>\n";
1490           print "Link is valid for $keep{$to} days!<p>\n";
1491         }
1492       }
1493     } elsif ($overwrite{$to} and not $comment) {
1494       print "(old <code>$file</code> for $to overwritten)<p>\n"
1495     } else {
1496       print "$to notified<p>\n"
1497     }
1498   }
1499   print "</ul>\n";
1500 }
1501
1502 if ($okey) {
1503   unlink "$to/\@OKEY/$okey";
1504 } elsif (not $anonymous and not $sup) {
1505   print "<a href=\"/fup?submit=again";
1506   if    ($public) { print "&from=$from&to=$to&id=$id" }
1507   elsif ($skey)   { print "&skey=$skey" }
1508   elsif ($gkey)   { print "&gkey=$gkey" }
1509   elsif ($akey)   { print "&akey=$akey&to=$to" }
1510   print "&bwlimit=$bwlimit&autodelete=$autodelete&keep=$keep\">";
1511   print "send another file</a>\n";
1512   if ($http_client !~ /fexsend/ and $http_client =~ /Linux/i) {
1513     print qq'<p>Hi Linux-user, try <a href="/FAQ/user.html#Why_should_I_use_a_special_F_EX_client">fexsend</a>! &#9786;<p>\n';
1514   }
1515   print &logout;
1516 }
1517
1518 print "</body></html>\n";
1519 exit;
1520
1521
1522 # parse GET and POST requests
1523 sub parse_request {
1524   my %to;
1525   my ($to,$dkey);
1526   my ($x,$k,$v);
1527   my $qs = $ENV{QUERY_STRING};
1528   local $_;
1529
1530   # get JUP parameters from environment (HTTP headers)
1531   while (($k,$v) = each %ENV) {
1532     if ($k =~ s/^FEX_//) {
1533       setparam($k,$v);
1534     }
1535   }
1536
1537   # decode base64 PATH_INFO to QUERY_STRING
1538   if ($ENV{PATH_INFO} =~ m:^/(\w+=*)$:) {
1539     if ($qs) {
1540       $qs = sprintf("%s&%s",decode_b64($1),$qs);
1541     } else {
1542       $qs = decode_b64($1);
1543     }
1544   }
1545
1546   # parse HTTP QUERY_STRING (parameter=value pairs)
1547   if ($qs) {
1548     foreach (split '&',$qs) {
1549       if (s/^(\w+)=(.*)//) {
1550         my $p = uc($1);
1551         my $v = $2;
1552         # decode URL-encoding
1553         $v =~ s/%([a-f0-9]{2})/chr(hex($1))/gie;
1554         setparam($p,$v);
1555         if ($p eq 'AUTODELETE') {
1556           $specific{'autodelete'} = $autodelete = $v;
1557         }
1558         if ($p eq 'KEEP' and /^\d+$/) {
1559           $specific{'keep'} = $keep = $v;
1560         }
1561       }
1562     }
1563   }
1564
1565   # HTTP redirect does not work correctly with opera!
1566   # ==> locale handling is now done by fexsrv
1567   if (0 and $locale) {
1568     nvt_print(
1569       "HTTP/1.1 302 Found",
1570       "Location: $ENV{PROTO}://$ENV{HTTP_HOST}/fup",
1571       "Set-Cookie: locale=$locale",
1572       'Expires: 0',
1573       'Content-Length: 0',
1574       ''
1575     );
1576     &reexec;
1577   }
1578
1579   if ($showstatus) {
1580     &showstatus;
1581     exit;
1582   }
1583
1584   # check for akey, gkey and skey (from HTTP GET)
1585   &check_keys;
1586
1587   if ($ENV{REQUEST_METHOD} eq 'POST' and $cl) {
1588     foreach $sig (keys %SIG) {
1589       if ($sig !~ /^(CHLD|CLD)$/) {
1590         $SIG{$sig} = \&sigexit;
1591       }
1592     }
1593     $SIG{PIPE} = 'IGNORE' if $ENV{PROTO} eq 'https'; # stunnel workaround
1594     $SIG{__DIE__} = \&sigdie;
1595     http_die("invalid Content-Length header \"$cl\"") if $cl !~ /^-?\d+$/;
1596     debuglog($0);
1597     debuglog(sprintf("awaiting %d bytes from %s %s",
1598                      $cl,$ENV{REMOTE_ADDR}||'',$ENV{REMOTE_HOST}||''),"\n");
1599
1600     &check_space($cl) if $cl > 0;
1601
1602     $SIG{ALRM} = sub { die "TIMEOUT\n" };
1603     alarm($timeout);
1604     binmode(STDIN,':raw');
1605
1606     if (defined($ENV{FEX_FILENAME})) {
1607       # JUP via HTTP header
1608       $file = $param{'FILE'} = $ENV{FEX_FILENAME};
1609       $fileid = $ENV{FEX_FILEID} || 0;
1610       $fpsize = $ENV{X_CONTENT_LENGTH} || 0;
1611       $boundary = '';
1612     } elsif ($contentlength) {
1613       # JUP via URL parameter
1614       $fpsize = $contentlength;
1615       $boundary = '';
1616     } else {
1617       # FUP
1618       if ($ENV{CONTENT_TYPE} =~ /boundary=\"?([\w\-\+\/_]+)/) {
1619         $boundary = $1;
1620       } else {
1621         http_die("malformed HTTP POST (no boundary found)");
1622       }
1623
1624       READPOST: while (&nvt_read) {
1625         # the file itself - *must* be last part of POST!
1626         if (/^Content-Disposition:\s*form-data;\s*name="file";\s*filename="(.+)"/i) {
1627           push @header,$_;
1628           $file = $param{'FILE'} = $1;
1629           while (&nvt_read) {
1630             last if /^\s*$/;
1631             $fileid = $1 if /^X-File-ID:\s*(.+)/;
1632             $fpsize = $1 if /^Content-Length:\s*(\d+)/;
1633             $flink  = $1 if /^Content-Location:\s*(\/.+)/;
1634             push @header,$_;
1635           }
1636           # STDIN is now at begin of file, will be read later with get_file()
1637           last;
1638         }
1639         # all other parameters
1640         if (/^Content-Disposition:\s*form-data;\s*name="([a-z]\w*)"/i) {
1641           my $x = $1;
1642           nvt_skip_to('^\s*$');
1643           &nvt_read;
1644           setparam($x,$_);
1645           NEXTPART: while (&nvt_read) {
1646             last READPOST if /^--\Q$boundary--/;
1647             last NEXTPART if /^--\Q$boundary/;
1648           }
1649         }
1650       }
1651     }
1652
1653     if (length($file)) {
1654       $file =~ s/%(\d+)/chr($1)/ge;
1655       $file = untaint(strip_path(normalize($file)));
1656       $file =~ s/[\\\/<>]/_/g; # filter out dangerous chars
1657       $file =~ s/^\|//;        # filter out dangerous chars
1658       $file =~ s/\|$//;        # filter out dangerous chars
1659       $filename = $file;
1660       $fkey = urlencode($file);
1661     }
1662
1663     # check for akey, gkey and skey (from HTTP POST)
1664     &check_keys;
1665
1666   }
1667
1668   if ($from) {
1669     unless ($skey or $gkey or $okey) {
1670       $from .= '@'.$mdomain if $mdomain and $from !~ /@/;
1671       if ($from ne 'anonymous' and not checkaddress($from)) {
1672         http_die("<code>$from</code> is not a valid e-mail address");
1673       }
1674     }
1675     $from = untaint($from);
1676   }
1677
1678   # collect multiple addresses and check for aliases (not group)
1679   if (@to and "@to" !~ /^@[\w-]+$/
1680       and not ($gkey or $addto or $command =~ /^LIST(RECEIVED)?$/))
1681   {
1682
1683     # read address book
1684     if ($from and open my $AB,'<',"$from/\@ADDRESS_BOOK") {
1685       my ($alias,$address,$autodelete,$locale,$keep);
1686       while (<$AB>) {
1687         s/#.*//;
1688         $_ = lc $_;
1689         if (s/^\s*(\S+)[=\s]+(\S+)//) {
1690           ($alias,$address) = ($1,$2);
1691           $autodelete = $locale = $keep = '';
1692           $autodelete = $1 if /autodelete=(\w+)/;
1693           $locale     = $1 if /locale=(\w+)/;
1694           $keep       = $1 if /keep=(\d+)/;
1695           foreach my $address (split(",",$address)) {
1696             $address .= '@'.$mdomain if $mdomain and $address !~ /@/;
1697             push @{$ab{$alias}},$address;
1698             $autodelete{$alias} = $autodelete if $autodelete;
1699             $keep{$alias}       = $keep       if $keep;
1700             $locale{$alias}     = $locale     if $locale;
1701           }
1702         }
1703       }
1704       close $AB;
1705     }
1706
1707     # look for recipient's options and eliminate dupes
1708     %to = ();
1709     foreach my $to (my @loop = @to) {
1710      # address book alias?
1711       if ($to !~ /@/ and $ab{$to}) {
1712         foreach my $address (my @loop = @{$ab{$to}}) {
1713           $address .= '@'.$mdomain if $mdomain and $address !~ /@/;
1714           $to{$address} = $address; # ignore dupes
1715           if ($specific{'autodelete'}) {
1716             $autodelete{$address} = $specific{'autodelete'};
1717           } elsif ($autodelete{$to}) {
1718             $autodelete{$address} = $autodelete{$to};
1719           } else {
1720             $autodelete{$address} = readlink "$address/\@AUTODELETE"
1721                                     || $autodelete;
1722           }
1723           if (my $locale = readlink "$address/\@LOCALE") {
1724             $locale{$address} = $locale;
1725           } elsif ($locale{$to}) {
1726             $locale{$address} = $locale{$to};
1727           } else {
1728             $locale{$address} = $::locale ;
1729           }
1730           unless ($locale{$address}) {
1731             $locale{$address} = $default_locale || 'english';
1732           }
1733           if ($specific{'keep'}) { $keep{$address} = $specific{'keep'} }
1734           elsif ($keep{$to})     { $keep{$address} = $keep{$to} }
1735         }
1736       } else {
1737         $to = expand($to);
1738         $to{$to} = $to; # ignore dupes
1739         unless ($autodelete{$to}) {
1740           $autodelete{$to} = readlink "$to/\@AUTODELETE" || $autodelete;
1741         }
1742         $autodelete{$to} = $specific{'autodelete'}  if $specific{'autodelete'};
1743         $keep{$to} = $keep_default;
1744         $keep{$to} = $keep                          if $keep;
1745         $keep{$to} = untaint(readlink "$to/\@KEEP") if -l "$to/\@KEEP";
1746         $keep{$to} = $specific{'keep'}              if $specific{'keep'};
1747         # recipient specific parameters
1748         $keep{$to}       = $1 if $to =~ /:keep=(\d+)/i;
1749         $autodelete{$to} = $1 if $to =~ /:autodelete=(\w+)/i;
1750       }
1751       $autodelete{$to} = 'NO' if $to =~ /$amdl/; # mailing lists, etc
1752       if (-e "$to/\@CAPTIVE") {
1753         my $v;
1754         $v = readlink "$to/\@AUTODELETE" and $autodelete{$to} = $v;
1755         $v = readlink "$to/\@KEEP"       and $keep{$to}       = $v;
1756       }
1757     }
1758     @to = keys %to;
1759
1760     if (scalar(@to) == 1) {
1761       $to = "@to";
1762       $keep       = $keep{$to}       if $keep{$to};
1763       $autodelete = $autodelete{$to} if $autodelete{$to};
1764     }
1765
1766     # check recipients and eliminate dupes
1767     %to = ();
1768     foreach $to (@to) {
1769       if ($to eq 'anonymous') {
1770         $to{$to} = $to;
1771       } else {
1772         if ($to =~ /^@(.+)/) {
1773           http_die("You cannot send to more than one group") if @to > 1;
1774           http_die("Group <code>$to</code> does not exist") unless -f "$from/\@GROUP/$1";
1775         } else {
1776           if ($skey or $gkey or $okey or checkaddress($to)) {
1777             $to .= '@'.$mdomain if $mdomain and $to !~ /@/;
1778             $to{$to} = untaint($to);
1779           } else {
1780             http_die("<code>$to</code> is not a valid e-mail address");
1781           }
1782         }
1783       }
1784     }
1785     @to = values %to;
1786   }
1787
1788   foreach $to (@to) {
1789     unless (checkforbidden($to)) {
1790       http_die("<code>$to</code> is not allowed");
1791     }
1792   }
1793 }
1794
1795
1796 # show the status progress bar
1797 sub showstatus {
1798   my $wclose;
1799   my ($upload,$data,$sfile,$ukey,$file);
1800   my ($nsize,$tsize);
1801   my ($t0,$t1,$t2,$tt,$ts,$tm);
1802   my ($osize,$percent,$npercent);
1803   local $_;
1804
1805   $wclose = '<p><a href="#" onclick="window.close()">close</a>'."\n".
1806             '</body></html>'."\n";
1807   $ukey   = "$ukeydir/$uid";
1808   $upload = "$ukey/upload";
1809   $data   = "$ukey/data";
1810   $sfile  = "$ukey/size";
1811   for (1..$timeout) {
1812     sleep 1;
1813     $tsize = readlink $sfile and last;
1814     # upload error?
1815     # remark: stupid Internet Explorer *needs* the error represented in this
1816     # asynchronous popup window, because it cannot display the error in the
1817     # main window on HTTP POST!
1818     if (-f $ukey and open $ukey,'<',$ukey or
1819         -f "$ukey/error" and open $ukey,'<',"$ukey/error") {
1820       undef $/;
1821       unlink $ukey;
1822       html_error($error,<$ukey> || 'unknown');
1823     }
1824   }
1825   # unlink $sfile;
1826
1827   if (defined $tsize and $tsize == 0) {
1828     print "<script type='text/javascript'>window.close()</script>\n";
1829     exit;
1830   }
1831   unless ($tsize) {
1832     html_error($error,
1833                "no file data received - does your file exist or is it >2GB?")
1834   }
1835   html_error($error,"file size unknown") unless $tsize =~ /^\d+$/;
1836
1837   http_header('200 OK');
1838   if (open $ukey,'<',"$ukey/filename") {
1839     local $/;
1840     $file = <$ukey>;
1841     close $ukey;
1842   }
1843   http_die("no filename?!") unless $file;
1844
1845   my $ssize = $tsize;
1846   if ($ssize<2097152) {
1847     $ssize = sprintf "%d kB",int($ssize/1024);
1848   } else {
1849     $ssize = sprintf "%d MB",int($ssize/1048576);
1850   }
1851
1852   pq(qq(
1853     "<html><body>"
1854     "<center>"
1855     "<h1>Upload Status for<br><code>$file ($ssize)</code></h1>"
1856     '<img src="/action-fex-camel.gif" id="afc">'
1857     "</center>"
1858     "<input type='text' id='percent' style='margin-left:1ex;color:black;background:transparent;border:none;width:32ex;' disabled='true' value='0%'>"
1859     "<div style='border:1px solid black;width:100%;height:20px;'>"
1860     "<div style='float:left;width:0%;background:black;height:20px;' id='bar'>"
1861     "</div></div>"
1862   ));
1863
1864   # wait for upload file
1865   for (1..9) {
1866     last if -f $upload or -f $data;
1867     sleep 1;
1868   }
1869   unless (-f $upload or -f $data) {
1870     print "<p><H3>ERROR: no upload received</H3>\n";
1871     print $wclose;
1872     exit;
1873   }
1874
1875   $SIG{ALRM} = sub { die "TIMEOUT in showstatus: no (more) data received\n" };
1876   alarm($timeout*2);
1877
1878   $t0 = $t1 = time;
1879   $osize = $percent = $npercent = 0;
1880
1881   for ($percent = 0; $percent<100; sleep(1)) {
1882     $t2 = time;
1883     $nsize = -s $upload;
1884     if (defined $nsize) {
1885       if ($nsize<$osize) {
1886         print "<p><h3>ABORTED</h3>\n";
1887         print $wclose;
1888         exit;
1889       }
1890       if ($nsize>$osize) {
1891         alarm($timeout*2);
1892         $osize = $nsize;
1893       }
1894       $npercent = int($nsize*100/$tsize);
1895       $showsize = calcsize($tsize,$nsize);
1896     } else {
1897       $npercent = 100;
1898       $showsize = calcsize($tsize,$tsize);
1899     }
1900     # hint: for ISDN (or even slower) links, 5 s tcp delay is minimum
1901     # so, updating more often is contra-productive
1902     if ($t2>$t1+5 or $npercent>$percent) {
1903       $percent = $npercent;
1904       $t1 = $t2;
1905       $tm = int(($t2-$t0)/60);
1906       $ts = $t2-$t0-$tm*60;
1907       $tt = sprintf("%d:%02d",$tm,$ts);
1908       pq(qq(
1909         "<script type='text/javascript'>"
1910         "  document.getElementById('bar').style.width = '$percent%';"
1911         "  document.getElementById('percent').value = '$showsize, $tt, $percent %';"
1912         "</script>"
1913       )) or last;
1914     }
1915   }
1916
1917   alarm(0);
1918   if ($npercent == 100) {
1919     print "<h3>file successfully transferred</h3>\n";
1920   } else {
1921     print "<h3>file transfer aborted</h3>\n";
1922   }
1923   pq(qq(
1924     "<script type='text/javascript'>"
1925     "  document.getElementById('afc').src='/logo.jpg'"
1926     "</script>"
1927   ));
1928   print $wclose;
1929   unlink $ukey;
1930   exit;
1931 }
1932
1933
1934 # get file from post request
1935 sub get_file {
1936   my ($to,$filed,$upload,$nupload,$speed,$download);
1937   my ($b,$n,$uss);
1938   my $dkey;
1939   my ($fh,$filesize);
1940   my ($t0,$tt);
1941   my $fb = 0;           # file bytes
1942   my $ebl = 0;          # end boundary length
1943
1944   # FUP, not JUP
1945   if ($boundary) {
1946     $ebl = length($boundary)+8; # 8: 2 * CRLF + 2 * "--"
1947   }
1948
1949   unless ($nostore) {
1950
1951     # download already in progress?
1952     foreach $to (@to) {
1953       $to =~ s/:\w+=.*//; # remove options from address
1954       $filed = "$to/$from/$fkey";
1955       $download = "$filed/download";
1956       if (-f $download and open $download,'>>',$download) {
1957         flock($download,LOCK_EX|LOCK_NB) or
1958           http_die("<code>$filed</code> locked: a download is currently in progress");
1959       }
1960     }
1961
1962     # prepare upload
1963     foreach $to (@to) {
1964       $to =~ s/:\w+=.*//; # remove options from address
1965       $filed = "$to/$from/$fkey";
1966       $nupload = "$filed/upload"; # upload for next recipient
1967       mkdirp($filed);
1968
1969       # upload already prepared (for first recipient)?
1970       if ($upload) {
1971         # link upload for next recipient
1972         unless ($upload eq $nupload or
1973                 -r $upload and -r $nupload and
1974                 (stat $upload)[1] == (stat $nupload)[1])
1975         {
1976           unlink $nupload;
1977           link $upload,$nupload;
1978         }
1979       }
1980
1981       # first recipient => create upload
1982       else {
1983         $upload = $nupload;
1984         unlink "$ukeydir/$uid";
1985         if ($flink) {
1986           if ($seek) {
1987             http_die("cannot resume on link upload");
1988           }
1989           &nvt_read and $flink = $_;
1990           if ($flink !~ /^\//) {
1991             http_die("no file link name ($flink)");
1992           }
1993           $flink = abs_path($flink);
1994           my $fok;
1995           foreach (@file_link_dirs) {
1996             my $dir = abs_path($_);
1997             $fok = $flink if $flink =~ /^\Q$dir\//;
1998           }
1999           unless ($fok) {
2000             http_die("<code>$flink</code> not allowed for linking");
2001           }
2002           my @s = stat($flink);
2003           unless (@s and ($s[2] & S_IROTH) and -r $flink) {
2004             http_die("cannot read <code>$flink</code>");
2005           }
2006           unless (-f $flink and not -l $flink) {
2007             http_die("<code>$flink</code> is not a regular file");
2008           }
2009           # http_die("DEBUG: flink = $flink");
2010           &nvt_read;
2011           &nvt_read if /^$/;
2012           unless (/^--\Q$boundary--/) {
2013             http_die("found no MIME end boundary in upload ($_)");
2014           }
2015           unlink $upload;
2016           symlink untaint($flink),$upload;
2017         } else {
2018           unlink $upload if -l $upload;
2019           open $upload,'>>',$upload or http_die("cannot write $upload - $!");
2020           flock($upload,LOCK_EX|LOCK_NB) or
2021             http_die("<code>$file</code> locked: a transfer is already in progress");
2022           unless ($seek) {
2023             seek $upload,0,0;
2024             truncate $upload,0;
2025           }
2026           # already uploaded file data size
2027           $uss = -s $upload;
2028           # provide upload ID symlink for showstatus
2029           symlink "../$filed","$ukeydir/$uid";
2030         }
2031       }
2032
2033       unlink "$filed/autodelete",
2034              "$filed/error",
2035              "$filed/restrictions",
2036              "$filed/locale",
2037              "$filed/keep",
2038              "$filed/header",
2039              "$filed/id",
2040              "$filed/ip",
2041              "$filed/speed",
2042              "$filed/replyto",
2043              "$filed/useragent",
2044              "$filed/uurl",
2045              "$filed/comment",
2046              "$filed/notify";
2047       unlink "$filed/size" unless $seek;
2048
2049       # showstatus needs file name and size
2050       # fexsend needs full file size (+$seek)
2051       $fh = "$filed/filename";
2052       open $fh,'>',$fh or die "cannot write $fh - $!\n";
2053       print {$fh} $filename;
2054       close $fh;
2055       if ($::filesize > 0 or $cl > 0) {
2056         if ($::filesize > 0) { $filesize = $fpsize || $::filesize }
2057         else                 { $filesize = $cl-$RB-$ebl+$seek }
2058         # new file
2059         unless ($seek) {
2060           if ($::filesize > 0) {
2061             # total file size as reported by POST
2062             mksymlink("$filed/size",$::filesize)
2063               or die "cannot write $filed/size - $!\n";
2064           } else {
2065             # file size as counted
2066             mksymlink("$filed/size",$filesize)
2067               or die "cannot write $filed/size - $!\n";
2068           }
2069         }
2070       }
2071
2072       if ($from eq "@to") {
2073         # special "fex yourself"
2074         mksymlink("$filed/autodelete",$specific{'autodelete'}||'NO');
2075       } else {
2076         $autodelete{$to} = $autodelete unless $autodelete{$to};
2077         if ($autodelete{$to} =~ /^(DELAY|NO|\d+)$/i) {
2078           mksymlink("$filed/autodelete",$autodelete{$to});
2079         }
2080       }
2081
2082       if (my $keep = $keep{$to} || $::keep) {
2083         mksymlink("$filed/keep",$keep);
2084       }
2085       mksymlink("$filed/id",$fileid) if $fileid;
2086       mksymlink("$filed/ip",$ra)     if $ra;
2087       if (my $uurl = $ENV{REQUEST_URL}) {
2088         mksymlink("$filed/uurl",$uurl);
2089       }
2090       if ($http_client and open $http_client,'>',"$filed/useragent") {
2091         print {$http_client} $http_client,"\n";
2092         close $http_client;
2093       }
2094       if ($_ = readlink "$to/\@LOCALE") {
2095         # mksymlink("$filed/locale",$_);
2096       } elsif ($locale{$to}) {
2097         mksymlink("$filed/locale",$locale{$to});
2098       } elsif ($locale and $locale ne $default_locale) {
2099         mksymlink("$filed/locale",$locale);
2100       }
2101       if ($replyto and $replyto =~ /.@./) {
2102         mksymlink("$filed/replyto",$replyto);
2103       }
2104
2105       my $arh = "$from/\@ALLOWED_RHOSTS";
2106       if (-s $arh) {
2107         copy($arh,"$filed/restrictions");
2108       }
2109
2110       if (@header and open $fh,'>',"$filed/header") {
2111         print {$fh} join("\n",@header),"\n";
2112         close $fh;
2113       }
2114
2115       if ((readlink "$to/\@NOTIFICATION"||'') =~ /^no/i) {
2116         $nomail{$to} = 'NOTIFICATION';
2117       }
2118
2119       if ($nomail) {
2120         open $fh,'>',"$filed/notify" and close $fh;
2121       }
2122       if ($comment) {
2123         if (open $fh,'>',"$filed/comment") {
2124           print {$fh} encode_utf8($comment);
2125           close $fh;
2126         }
2127       }
2128
2129       # provide download ID key
2130       unless ($dkey = readlink("$filed/dkey") and -l "$dkeydir/$dkey") {
2131         $dkey = randstring(8);
2132         unlink "$dkeydir/$dkey";
2133         symlink "../$filed","$dkeydir/$dkey"
2134           or http_die("cannot symlink $dkeydir/$dkey ($!)");
2135         unlink "$filed/dkey";
2136         symlink $dkey,"$filed/dkey";
2137       }
2138
2139     }
2140
2141     # extra download (XKEY)?
2142     if ($anonymous and $fkey =~ /^afex_\d/ or
2143         $from eq "@to" and $comment =~ s:^//(.*)$:NOMAIL:)
2144     {
2145       $xkey = $1||$fkey;
2146       $nomail = $comment;
2147       my $x = "$xkeydir/$xkey";
2148       unless (-l $x and readlink($x) eq "../$from/$from/$fkey") {
2149         if (-e $x) {
2150           http_die("extra download key $xkey already exists");
2151         }
2152         symlink "../$from/$from/$fkey",$x
2153           or http_die("cannot symlink $x - $!\n");
2154         unlink "$x/xkey";
2155         symlink $xkey,"$x/xkey";
2156       }
2157     }
2158
2159   }
2160
2161   # file link?
2162   if ($flink) {
2163     # upload link has been already created, no data to read any more
2164     $to = join(',',@to);
2165     fuplog($to,$fkey,0);
2166     debuglog("upload link successfull, dkey=$dkey");
2167   }
2168
2169   # regular file
2170   else {
2171
2172     # at last, read (real) file data
2173     $t0 = time();
2174
2175     # streaming data?
2176     if ($cl == -1) {
2177       alarm($timeout*2);
2178       # read until EOF, including MIME end boundary
2179       # note: cannot use sysread because of previous buffered read!
2180       while ($n = read(STDIN,$_,$bs)) {
2181         $RB += $n;
2182         $fb += $n;
2183         syswrite $upload,$_ unless $nostore;
2184         alarm($timeout*2);
2185       }
2186       # size of transferred file, without end boundary
2187       $ndata = untaint($fb-$ebl);
2188     }
2189
2190     # normal file with known file size
2191     else {
2192
2193       if ($fpsize) {
2194         debuglog(sprintf("still awaiting %d+%d = %d bytes",
2195                  $fpsize,$ebl,$fpsize+$ebl));
2196         $cl = $RB+$fpsize+$ebl; # recalculate CONTENT_LENGTH
2197       } else {
2198         if ($::filesize) {
2199           $cl = $RB+$::filesize+$ebl; # recalculate CONTENT_LENGTH
2200         }
2201         debuglog(sprintf("still awaiting %d-%d = %d bytes",
2202                          $cl,$RB,$cl-$RB));
2203       }
2204       # read until end boundary, not EOF
2205       while ($RB < $cl-$ebl) {
2206         $b = $cl-$ebl-$RB;
2207         $b = $bs if $b > $bs;
2208         # max wait for 1 kB/s, but at least 10 s
2209         # $timeout = $b/1024;
2210         # $timeout = 10 if $timeout < 10;
2211         alarm($timeout);
2212         if ($n = read(STDIN,$_,$b)) {
2213           $RB += $n;
2214           $fb += $n;
2215           # syswrite is much faster than print
2216           syswrite $upload,$_ unless $nostore;
2217           if ($bwlimit) {
2218             alarm(0);
2219             $tt = (time-$t0) || 1;
2220             while ($RB/$tt/1024 > $bwlimit) {
2221               sleep 1;
2222               $tt = time-$t0;
2223             }
2224           }
2225           # debuglog($_);
2226         } else {
2227           last;
2228         }
2229       }
2230       # read end boundary - F*IX is broken!
2231       if ($ebl and $http_client !~ /F\*IX/) {
2232         $_ = <STDIN>;
2233         $_ = <STDIN>||'';
2234         unless (/^--\Q$boundary--/) {
2235           http_die("found no MIME end boundary in upload ($_)");
2236         }
2237       }
2238       $RB += $ebl;
2239       $ndata = untaint($fb);
2240     }
2241
2242     alarm(0);
2243
2244     unless ($nostore) {
2245       close $upload; # or die "cannot close $upload - $!\n";;
2246
2247       # throuput in kB/s
2248       $tt = (time-$t0) || 1;
2249       mksymlink("$filed/speed",int($fb/1024/$tt));
2250
2251       unless ($ndata) {
2252         http_die(
2253           "No file data received!".
2254           " File name correct?".
2255           " File too big (browser-limit: 2 GB!)?"
2256         );
2257       }
2258
2259       $to = join(',',@to);
2260
2261       # streaming upload?
2262       if ($cl == -1) {
2263
2264         open $upload,'<',$upload or http_die("internal error - cannot read upload");
2265         seek $upload,$ndata+2,0;
2266         $_ = <$upload>||'';
2267         unless (/^--\Q$boundary--/) {
2268           http_die("found no MIME end boundary in upload ($_)");
2269         }
2270         close $upload;
2271         truncate $upload,$ndata;
2272
2273       } else {
2274
2275         # truncate boundary string
2276         # truncate $upload,$ndata+$uss if -s $upload > $ndata+$uss;
2277
2278         # incomplete?
2279         if ($cl != $RB) {
2280           fuplog($to,$fkey,$ndata,'(aborted)');
2281           if ($fpsize) {
2282             http_die("read $RB bytes, but Content-Length announces $fpsize bytes");
2283           } else {
2284             http_die("read $RB bytes, but CONTENT_LENGTH announces $cl bytes");
2285           }
2286         }
2287
2288         # multipost, not complete
2289         if ($::filesize > -s $upload) {
2290           http_header('206 Partial OK');
2291           exit;
2292         }
2293
2294         # save error?
2295         if (-s $upload > ($::filesize||$filesize)) {
2296           fuplog($to,$fkey,$ndata,'(write error: upload > filesize)');
2297           http_die("internal server error while writing file data");
2298         }
2299
2300       }
2301       fuplog($to,$fkey,$ndata);
2302       debuglog("upload successfull, dkey=$dkey");
2303     }
2304   }
2305 }
2306
2307
2308 # check recipients restriction
2309 sub check_rr {
2310   my $from = shift;
2311   my @to = @_;
2312   my $rr = "$from/\@ALLOWED_RECIPIENTS";
2313   my ($allowed,$to,$ar,$rd);
2314
2315   if (-s $rr and open $rr,'<',$rr) {
2316
2317     $restricted = $rr;
2318
2319     foreach (@to) {
2320       my $to = $_;
2321       $allowed = 0;
2322       seek $rr,0,0;
2323       while (<$rr>) {
2324         chomp;
2325         s/#.*//;
2326         s/\s//g;
2327
2328         if (/^\@LOCAL_RDOMAINS/) {
2329           $ar = '(@';
2330           foreach (@local_rdomains) {
2331             my $rd = $_;
2332             # allow wildcard *, but not regexps
2333             $rd =~ s/\./\\./g;
2334             $rd =~ s/\*/[\\w.-]+/g;
2335             $ar .= '|[^\@]+\@' . $rd;
2336           }
2337           $ar .= ')';
2338         } elsif (/^\@LOCAL_USERS/ and -s "$to/@") {
2339           $allowed = 1;
2340           last;
2341         } else {
2342           # allow wildcard *, but not regexps
2343           $ar = quotemeta $_;
2344           $ar =~ s/\\\*/[^@]*/g;
2345         }
2346
2347         if ($to =~ /^$ar$/i) {
2348           $allowed = 1;
2349           last;
2350         }
2351
2352       }
2353
2354       unless ($allowed) {
2355         fuplog("ERROR: $from not allowed to fex to $to");
2356         debuglog("$to not in $spooldir/$from/\@ALLOWED_RECIPIENTS");
2357         http_die("You ($from) are not allowed to fex to $to");
2358       }
2359     }
2360
2361     close $rr;
2362   }
2363 }
2364
2365
2366 # add domain to user if necessary
2367 sub expand {
2368   my @users = @_;
2369   my @ua;
2370
2371   foreach my $u (my @loop = @users) {
2372     if ($u =~ /^anonymous(_\d+)?$/) {
2373       $u = "$u\@$hostname";
2374     }
2375     if ($u eq 'nettest') {
2376       if ($mdomain and -d "$u\@$mdomain") {
2377         $u .= "\@$mdomain"
2378       } elsif (-d "$u\@$hostname") {
2379         $u .= "\@$hostname"
2380       }
2381     }
2382     if    ($u =~ /@/)          { push @ua,$u }
2383     elsif ($mdomain)           { push @ua,"$u\@$mdomain" }
2384     elsif (-d "$u\@$hostname") { push @ua,"$u\@$hostname" }
2385     else                       { push @ua,$u }
2386   }
2387
2388   return wantarray ? @ua : join(',',@ua);
2389 }
2390
2391
2392 # forward-copy (bounce) an already uploaded file
2393 sub forward {
2394   my $file = shift;
2395   my ($nfile,$to,$AB);
2396   my ($filename,$keep);
2397   my (%to);
2398
2399   http_die("no file data for <code>$file</code>") unless -f "$file/data";
2400
2401   $keep = $::keep||$keep_default;
2402   if (my $mt = mtime("$file/data")) { $keep += int((time-$mt)/$DS) }
2403
2404   if (@to) {
2405
2406     # check recipients restriction
2407     check_rr($from,@to);
2408
2409     # read aliases from address book
2410     if (open $AB,'<',"$from/\@ADDRESS_BOOK") {
2411       while (<$AB>) {
2412         s/#.*//;
2413         $_ = lc $_;
2414         if (s/^\s*(\S+)[=\s]+(\S+)//) {
2415           my ($alias,$address) = ($1,$2);
2416           foreach my $address (split(",",$address)) {
2417             $address .= '@'.$mdomain if $mdomain and $address !~ /@/;
2418             push @{$ab{$alias}},$address;
2419           }
2420         }
2421       }
2422       close $AB;
2423     }
2424
2425     # collect addresses
2426     foreach my $to (my @loop = @to) {
2427       if ($ab{$to}) {
2428         foreach my $address (@{$ab{$to}}) {
2429           $to{$address} = $address;
2430         }
2431       } else {
2432         $to .= '@'.$mdomain if $mdomain and $to !~ /@/;
2433         $to{$to} = $to;
2434       }
2435     }
2436
2437     @to = keys %to;
2438
2439     http_header('200 OK');
2440     print html_header($head);
2441
2442     foreach my $to (my @loop = @to) {
2443       $to =~ s/:\w+=.*//; # remove options from address
2444       $nfile = $file;
2445       $nfile =~ s:.*?/:$to/:;
2446       next if $nfile eq $file;
2447       mkdirp($nfile);
2448       http_die("cannot create directory $nfile") unless -d $nfile;
2449       unlink "$nfile/data",
2450              "$nfile/upload",
2451              "$nfile/download",
2452              "$nfile/autodelete",
2453              "$nfile/error",
2454              "$nfile/restrictions",
2455              "$nfile/keep",
2456              "$nfile/header",
2457              "$nfile/id",
2458              "$nfile/speed",
2459              "$nfile/comment",
2460              "$nfile/replyto",
2461              "$nfile/notify";
2462       if ($comment) {
2463         open $comment,'>',"$nfile/comment";
2464         print {$comment} $comment;
2465         close $comment;
2466       }
2467       if ($autodelete =~ /^(DELAY|NO|\d+)$/i) {
2468         symlink $autodelete,"$nfile/autodelete";
2469       }
2470       symlink          $keep,             "$nfile/keep";
2471                   copy("$file/id",        "$nfile/id");
2472                   copy("$file/ip",        "$nfile/ip");
2473                   copy("$file/speed",     "$nfile/speed");
2474                   copy("$file/replyto",   "$nfile/replyto");
2475       $filename = copy("$file/filename",  "$nfile/filename");
2476       link             "$file/data",      "$nfile/data"
2477         or die http_die("cannot create $nfile/data - $!");
2478       unless ($dkey = readlink("$nfile/dkey") and -l "$dkeydir/$dkey") {
2479         $dkey = randstring(8);
2480         unlink "$dkeydir/$dkey";
2481         symlink "../$nfile","$dkeydir/$dkey"
2482           or http_die("cannot symlink $dkeydir/$dkey");
2483         unlink "$nfile/dkey";
2484         symlink $dkey,"$nfile/dkey"
2485           or http_die("cannot create $nfile/dkey - $!");
2486       }
2487
2488       if ($nomail or $nomail{$to}) {
2489         if ($filename) {
2490           my $url = "$durl/$dkey/".normalize_filename($filename);
2491           pq(qq(
2492             'Download-URL for $to:<br>'
2493             '<code>$url</code>'
2494             '<p>'
2495           ));
2496         }
2497       } else {
2498         notify_locale($dkey,'new');
2499         fuplog($to,urlencode($filename),"(forwarded)");
2500         if ($filename) {
2501           pq(qq(
2502             'File "$filename" copy-forwarded to $to and notified.'
2503             '<p>'
2504           ));
2505         }
2506       }
2507     }
2508     pq(qq(
2509       '<a href="/foc?akey=$akey">back to F*EX operation control</a>'
2510       '</body></html>'
2511     ));
2512   } else {
2513     $filename = filename($file);
2514     http_header('200 OK');
2515     print html_header($head);
2516     pq(qq(
2517       '<form name="upload"'
2518       '      action="/fup"'
2519       '      method="post"'
2520       '      accept-charset="UTF-8"'
2521       '      enctype="multipart/form-data">'
2522       '  <input type="hidden" name="akey"    value="$akey">'
2523       '  <input type="hidden" name="dkey"    value="$dkey">'
2524       '  <input type="hidden" name="command" value="FORWARD">'
2525       '  forward a copy of "<code>$filename</code>" to:<br>'
2526       '  <input type="text" name="to" size="80">'
2527       '</form>'
2528       '</body></html>'
2529     ));
2530   }
2531 }
2532
2533
2534 # modify file parameter
2535 sub modify {
2536   my $file = shift;
2537   my $filename = filename($file);
2538   my $dkey = readlink "$file/$dkey";
2539   my $to;
2540   my @parameter;
2541
2542   http_die("no file data for <code>$file</code>") unless -f "$file/data";
2543
2544   $to = $file;
2545   $to =~ s:/.*::;
2546   if ($specific{'keep'}) {
2547     mksymlink("$file/keep",$keep);
2548     utime time,time,"$file/filename";
2549     push @parameter,'KEEP';
2550   }
2551   if ($specific{'autodelete'}) {
2552     mksymlink("$file/autodelete",$autodelete);
2553     push @parameter,'AUTODELETE';
2554   }
2555   if ($comment) {
2556     if (open $comment,'>',"$file/comment") {
2557       print {$comment} $comment;
2558       close $comment;
2559     }
2560     notify_locale($dkey,'new');
2561     push @parameter,'COMMENT';
2562   }
2563   http_header('200 OK');
2564   print "Parameter ".join(',',@parameter)." modified for $filename for $to\n";
2565 }
2566
2567
2568 sub calcsize {
2569   my ($tsize,$nsize) = @_;
2570   if ($tsize<2097152) {
2571     return sprintf "%d kB",int($nsize/1024);
2572   } else {
2573     return sprintf "%d MB",int($nsize/1048576);
2574   }
2575 }
2576
2577
2578 # set parameter variables
2579 sub setparam {
2580   my ($v,$vv) = @_;
2581   my ($idf,$to);
2582
2583   $v = uc(despace($v));
2584
2585 #  if ($vv =~ /([<>])/) {
2586 #    http_die(sprintf("\"&#%s;\" is not allowed in parameter $v",ord($1)));
2587 #  }
2588
2589   $param{$v} = $vv;
2590   if ($v eq 'LOGOUT') {
2591     $logout = $v;
2592     # skey and gkey are persistant!
2593     $akey = $1 if $ENV{QUERY_STRING} =~ /AKEY:(\w+)/i;
2594     unlink "$akeydir/$akey";
2595     $login = $FEXHOME.'/cgi-bin/login';
2596     if (-x $login) {
2597       $login = readlink $login || 'login';
2598       nvt_print(
2599         "HTTP/1.1 302 Found",
2600         "Location: $ENV{PROTO}://$ENV{HTTP_HOST}/$login",
2601         'Content-Length: 0',
2602         ""
2603       );
2604     } else {
2605       nvt_print(
2606         "HTTP/1.1 302 Found",
2607         "Location: $ENV{PROTO}://$ENV{HTTP_HOST}/fup",
2608         'Content-Length: 0',
2609         ""
2610       );
2611     }
2612     &reexec;
2613   } elsif ($v eq 'LOCALE' and $vv =~ /^(\w+)$/) {
2614     $locale = $1;
2615   } elsif ($v eq 'REDIRECT' and $vv =~ /^([\w?=]+)$/) {
2616     $redirect = $1;
2617   } elsif (($v eq 'KEY' or $v eq 'SKEY') and $vv =~ /^([\w:]+)$/) {
2618     $skey = $1;
2619     $restricted = $v;
2620   } elsif ($v eq 'GKEY' and $vv =~ /^([\w:]+)$/) {
2621     $gkey = $1 unless $nomail;
2622     $restricted = $v;
2623   } elsif ($v eq 'DKEY' and $vv =~ /^(\w+)$/) {
2624     $dkey = $1;
2625   } elsif ($v eq 'AKEY' and $vv =~ /^(\w+)$/) {
2626     $akey = $1;
2627   } elsif ($v eq 'FROM' or $v eq 'USER') {
2628     $from = normalize_email($vv);
2629     $from = untaint(expand($from));
2630     checkchars('from address',$from);
2631     # maybe FROM=SUBUSER !
2632     # checkaddress($from) or http_die("FROM $from is no legal e-mail address");
2633   } elsif ($v eq 'REPLYTO') {
2634     $replyto = normalize_email($vv);
2635     checkchars('replyto address',$replyto);
2636     checkaddress($replyto) or
2637       http_die("REPLYTO $replyto is no legal e-mail address");
2638   } elsif ($v eq 'ADDTO') {
2639     $vv =~ s/\s.*//;
2640     $addto = normalize_email($vv);
2641   } elsif ($v eq 'SUBMIT') {
2642     $submit = decode_utf8(normalize($vv));
2643   } elsif ($v eq 'FEXYOURSELF') {
2644     $submit = $vv;
2645     @to = ($from);
2646     $specific{'autodelete'} = $autodelete = 'no';
2647   } elsif ($v eq 'TO') {
2648     # extract AUTODELETE and KEEP options
2649     if ($vv =~ s/[\s,]+AUTODELETE=(\w+)//i) {
2650       $specific{'autodelete'} = $autodelete = uc($1);
2651     }
2652     if ($vv =~ s/[\s,]+KEEP=(\d+)//i) {
2653       $keep = $1;
2654       $keep = $keep_max if $keep_max and $keep > $keep_max;
2655       $specific{'keep'} = $keep;
2656     }
2657     $to = normalize(lc($vv));
2658     $to =~ s/[\n\s;,]+/,/g;
2659     if ($from) {
2660       if ($to eq '.') {
2661         $to = $from;
2662          unless ($specific{'autodelete'}) {
2663            $specific{'autodelete'} = $autodelete = 'no';
2664          }
2665       }
2666       if ($to eq '//') {
2667         $to = $from;
2668         unless ($specific{'autodelete'}) {
2669           $specific{'autodelete'} = $autodelete = 'no';
2670         }
2671         $comment = '//';
2672       }
2673     }
2674     checkchars('to address',$to);
2675     push @to,split(',',$to);
2676   } elsif ($v eq 'ID') {
2677     $id = despace($vv);
2678     checkchars('auth-ID',$id);
2679   } elsif ($v eq 'TCE') {
2680     $test = despace($vv);
2681   } elsif ($v eq 'OKEY' and $vv =~ /^(\w+)$/) {
2682     $okey = $1;
2683     $restricted = $v;
2684   } elsif ($v eq 'FILEID' and $vv =~ /^(\w+)$/) {
2685     $fileid = $1;
2686   } elsif ($v eq 'CONTENTLENGTH' and $vv =~ /^(\d+)$/) {
2687     $contentlength = $1;
2688   } elsif ($v eq 'FILE' or $v eq 'FILENAME') {
2689     $file = strip_path(normalize($vv));
2690   } elsif ($v eq 'UID' and $vv =~ /^(\w+)$/) {
2691     $uid = $1;
2692   } elsif ($v eq 'ID_FORGOTTEN') {
2693     $id_forgotten = $vv;
2694   } elsif ($v eq 'SHOWSTATUS' and $vv =~ /^(\w+)$/) {
2695     $showstatus = $uid = $1;
2696   } elsif ($v eq 'COMMENT') {
2697     $comment = decode_utf8(normalize($vv));
2698     $comment =~ s/^\s*!\.!/!SHORTMAIL!/;
2699     $comment =~ s/^!#!/!NOMAIL!/;
2700     $comment =~ s/^!-!/!NOSTORE!/;
2701     $nomail = $comment if $comment =~ /NOMAIL/;
2702     $nostore = $nomail = $comment if $comment =~ /NOSTORE/;
2703     $bcc .= " $from"   if $comment =~ s/\s*!bcc!?\s*//i;
2704     # backward compatibility
2705     foreach my $cmd (qw(
2706       DELETE LIST CHECKQUOTA CHECKRECIPIENT RECEIVEDLOG SENDLOG FOPLOG FORWARD
2707     )) { $command = $comment if $comment eq $cmd }
2708   } elsif ($v eq 'COMMAND') {
2709     $command = normalize($vv);
2710   } elsif ($v eq 'BWLIMIT' and $vv =~ /^(\d+)$/) {
2711     $bwlimit = $1;
2712   } elsif ($v eq 'SEEK' and $vv =~ /^(\d+)$/) {
2713     $seek = $1;
2714   } elsif ($v eq 'FILESIZE' and $vv =~ /^(\d+)$/) {
2715     $filesize = $1; # complete filesize!
2716     &check_space($filesize-$seek);
2717   } elsif ($v eq 'AUTODELETE' and $vv =~ /^(\w+)$/) {
2718     $specific{'autodelete'} = $autodelete = uc($1);
2719   } elsif ($v eq 'KEEP' and $vv =~ /^(\d+)$/) {
2720     $keep = $1;
2721     $keep = $keep_max if $keep_max and $keep > $keep_max;
2722     $specific{'keep'} = $keep;
2723   } elsif ($v eq 'TIMEOUT' and $vv =~ /^(\d+)$/) {
2724     $specific{'timeout'} = $timeout = $1;
2725   }
2726 }
2727
2728
2729 sub id_forgotten {
2730   my ($id,$to,$subuser,$gm,$skey,$gkey,$url,$fup);
2731
2732   return if $nomail;
2733
2734   $fup = $durl;
2735   $fup =~ s:/fop:/fup:;
2736
2737   # full user
2738   if (open $from,'<',"$from/\@") {
2739     $id = getline($from);
2740     close $from;
2741   }
2742   if ($id) {
2743     $url = "$fup/".b64("from=$from&id=$id");
2744     mail_forgotten($from,qqq(qq(
2745       'Your reqested F*EX auth-ID for $fup?from=$from is:'
2746       '$id'
2747       ''
2748       'Or use:'
2749       '$url'
2750     )));
2751     exit;
2752   }
2753
2754   # sub user
2755   foreach my $skey (glob("$skeydir/*")) {
2756     if (-f $skey and open $skey,'<',$skey) {
2757       while (<$skey>) {
2758         $_ = lc;
2759         if (/^(\w+)=(.+)/) {
2760           $subuser = $2 if $1 eq 'from';
2761           $to      = $2 if $1 eq 'to';
2762         }
2763       }
2764       close $skey;
2765     }
2766     if ($from and $to and $from eq $subuser) {
2767       $skey =~ s:.*/::;
2768       mail_forgotten($subuser,qqq(qq(
2769         'Your reqested F*EX login is:'
2770         ''
2771         '$fup?skey=$skey'
2772       )));
2773       exit;
2774     }
2775   }
2776
2777   # group user
2778   foreach my $gkey (glob("$gkeydir/*")) {
2779     if (-f $gkey and open $gkey,'<',$gkey) {
2780       while (<$gkey>) {
2781         $_ = lc;
2782         if (/^(\w+)=(.+)/) {
2783           $gm = $2 if $1 eq 'from';
2784           $to = $2 if $1 eq 'to';
2785         }
2786       }
2787       close $gkey;
2788     }
2789     if ($gm and $to and $from eq $gm) {
2790       $gkey =~ s:.*/::;
2791       mail_forgotten($gm,qqq(qq(
2792         'Your reqested F*EX login is:'
2793         ''
2794         '$fup?gkey=$gkey'
2795       )));
2796       exit;
2797     }
2798   }
2799   http_die("<code>$from</code> is not a F*EX user on this server");
2800 }
2801
2802
2803 sub mail_forgotten {
2804   my $user = shift;
2805   my @msg = @_;
2806   local *P;
2807
2808   return if $nomail;
2809
2810   open P,'|-',$sendmail,$user,$bcc or http_die("cannot start sendmail - $!\n");
2811   pq(P,qq(
2812     'From: $admin'
2813     'To: $user'
2814     'Subject: F*EX service $hostname'
2815     'X-Mailer: F*EX'
2816     ''
2817   ));
2818   print P @msg;
2819   close P or http_die("cannot send mail - $!\n");
2820   http_header('200 OK');
2821   print html_header($head);
2822   print "<h3>Mail has been sent to you ($from)</h3>\n";
2823   print "</body></html>\n";
2824 }
2825
2826
2827 # lookup akey, skey and gkey (full and sub user and group)
2828 sub check_keys {
2829
2830   # only one key can be valid
2831   $akey = $gkey = '' if $skey;
2832   $akey = $skey = '' if $gkey;
2833
2834   if ($skey) {
2835     # encrypted SKEY?
2836     if ($skey =~ s/^MD5H:(.+)/$1/) {
2837       # search real SKEY
2838       foreach my $s (glob "$skeydir/*") {
2839         $s =~ s:.*/::;
2840         if ($skey eq md5_hex($s.$sid)) {
2841           $skey = $s;
2842           last;
2843         }
2844       }
2845     }
2846     if (open $skey,'<',"$skeydir/$skey") {
2847       $akey = $gkey = '';
2848       while (<$skey>) {
2849         if (/^(\w+)=(.+)/) {
2850           $from = $2          if lc($1) eq 'from';
2851           @to = ($muser = $2) if lc($1) eq 'to';
2852           $rid = $id = $2     if lc($1) eq 'id';
2853         }
2854       }
2855       close $skey;
2856     } else {
2857       # $skey = '';
2858       http_die("invalid SKEY <code>$skey</code>");
2859     }
2860   }
2861
2862   if ($gkey) {
2863     # encrypted GKEY?
2864     if ($gkey =~ s/^MD5H:(.+)/$1/) {
2865       # search real GKEY
2866       foreach my $g (glob "$gkeydir/*") {
2867         $g =~ s:.*/::;
2868         if ($gkey eq md5_hex($g.$sid)) {
2869           $gkey = $g;
2870           last;
2871         }
2872       }
2873     }
2874     if (open $gkey,'<',"$gkeydir/$gkey") {
2875       $akey = $skey = '';
2876       while (<$gkey>) {
2877         if (/^(\w+)=(.+)/) {
2878           $from        = $2 if lc($1) eq 'from';
2879           $to = $muser = $2 if lc($1) eq 'to';
2880           $rid = $id   = $2 if lc($1) eq 'id';
2881           # $user      = $2 if lc($1) eq 'user';
2882         }
2883       }
2884       close $gkey;
2885       @to = ($to);
2886     } else {
2887       # $gkey = '';
2888       http_die("invalid GKEY <code>$gkey</code>");
2889     }
2890   }
2891
2892   if ($akey and not $id) {
2893     my $idf;
2894
2895     # sid is not set with web browser
2896     # akey with sid is set with schwuppdiwupp & co
2897     $idf = "$akeydir/$akey/@";
2898
2899     if (open $idf,'<',$idf and $id = getline($idf)) {
2900       close $idf;
2901       $from = readlink "$akeydir/$akey"
2902         or http_die("internal server error: no $akey symlink");
2903       $from =~ s:.*/::;
2904       $from = untaint($from);
2905       if ($akey ne md5_hex("$from:$id")) {
2906         $from = $id = '';
2907       }
2908     } else {
2909       $akey = '';
2910     }
2911   }
2912
2913 }
2914
2915
2916 # check if there is enough space on spool
2917 sub check_space {
2918   my $req = shift;
2919   my ($df,$free,$uprq);
2920   local *P;
2921
2922   if (open $df,"df -k $spooldir|") {
2923     while (<$df>) {
2924       if (/^.+?\s+\d+\s+\d+\s+(\d+)/ and $req/1024 > $1) {
2925         $free = int($1/1024);
2926         $uprq = int($req/$MB);
2927         if (not $nomail and open P,"|$sendmail -t") {
2928           pq(P,qq(
2929             'From: $admin'
2930             'To: $admin'
2931             'Subject: F*EX spool out of space'
2932             ''
2933             'F*EX spool $spooldir on $ENV{SERVER_NAME} is out of space.'
2934             ''
2935             'Current free space: $free MB'
2936             'Upload request: $uprq MB'
2937           ));
2938           close P;
2939         }
2940         debuglog("aborting because not enough free space in spool ($free MB)");
2941         http_die("not enough free space for this upload");
2942       }
2943     }
2944     close $df;
2945   }
2946 }
2947
2948
2949 # global substitution as a function like in gawk
2950 sub gsub {
2951   local $_ = shift;
2952   my ($p,$r) = @_;
2953   s/$p/$r/g;
2954   return $_;
2955 }
2956
2957
2958 # standard log
2959 sub fuplog {
2960   my $msg = "@_";
2961
2962   $msg =~ s/\n/ /g;
2963   $msg =~ s/\s+$//;
2964   $msg = sprintf "%s [%s_%s] %s (%s) %s\n",
2965                  isodate(time),$$,$ENV{REQUESTCOUNT},$from,$fra,$msg;
2966   writelog($log,$msg);
2967 }
2968
2969
2970 sub sigdie {
2971   local $_ = shift;
2972   chomp;
2973   sigexit('DIE',$_);
2974 }
2975
2976
2977 sub sigexit {
2978   my ($sig) = @_;
2979   my $msg;
2980   my $to = join(',',@to);
2981
2982   $SIG{__DIE__} = 'DEFAULT';
2983   foreach (keys %SIG) { $SIG{$_} = 'DEFAULT' }
2984
2985   $msg = @_ ? "@_" : '???';
2986   $msg =~ s/\n/ /g;
2987   $msg =~ s/\s+$//;
2988   $msg = sprintf "%s %s (%s) %s %s caught SIGNAL %s %s\n",
2989                  isodate(time),
2990                  $from||'-',
2991                  $fra||'-',
2992                  $to||'-',
2993                  encode_Q($file||'-'),
2994                  $msg,
2995                  $RB?"(after $RB bytes)":"";
2996
2997   writelog($log,$msg);
2998
2999   if ($sig eq 'DIE') {
3000     shift;
3001     die "$msg\n";
3002   } else {
3003     die "SIGNAL $msg\n";
3004   }
3005 }
3006
3007
3008 sub present_locales {
3009   my $url = shift;
3010   my @locales = @::locales; # from fex.ph
3011   my ($locale,$lang);
3012
3013   if ($url =~ /\?/) {
3014     $url .= "&";
3015     $url =~ s/locale=\w+&//g;
3016   } else {
3017     $url .= "?";
3018   }
3019
3020   if (@locales) {
3021     map { $_ = "$FEXHOME/locale/$_" } @locales;
3022   } else {
3023     @locales = glob "$FEXHOME/locale/*";
3024   }
3025
3026   if (@locales > 1) {
3027     print "<h3>";
3028     foreach my $locale (my @loop = @locales) {
3029       if (-x "$locale/cgi-bin/fup") {
3030         $lang = "$locale/lang.html";
3031         $locale =~ s:.*/::;
3032         if (open $lang,'<',$lang and $lang = getline($lang)) {
3033           close $lang;
3034         } else {
3035           $lang = $locale;
3036         }
3037         print "<a href=\"${url}locale=$locale\">$lang</a> ";
3038       }
3039     }
3040     print "</h3>\n";
3041   }
3042 }
3043
3044
3045 sub check_camel {
3046   my ($logo,$camel);
3047   local $/;
3048
3049   if (open $logo,"$docdir/logo.jpg") {
3050     $camel = md5_hex(<$logo>) eq 'ad8a95bba8dd1a61d70bd38611bc2059';
3051   }
3052   if ($camel and open $logo,"$docdir/action-fex-camel.gif") {
3053     $camel = md5_hex(<$logo>) eq '1f3d7acc70377496f95c5adddaf4ca7b';
3054   }
3055   http_die("Missing camel") unless $camel;
3056 }