cgi-bin/fup

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