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