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