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 { die "TIMEOUT\n" };
1617     alarm($timeout);
1618     binmode(STDIN,':raw');
1619
1620     if (defined($ENV{FEX_FILENAME})) {
1621       # JUP via HTTP header
1622       $file = $param{'FILE'} = $ENV{FEX_FILENAME};
1623       $fileid = $ENV{FEX_FILEID} || 0;
1624       $fpsize = $ENV{X_CONTENT_LENGTH} || 0;
1625       $boundary = '';
1626     } elsif ($contentlength) {
1627       # JUP via URL parameter
1628       $fpsize = $contentlength;
1629       $boundary = '';
1630     } else {
1631       # FUP
1632       if ($ENV{CONTENT_TYPE} =~ /boundary=\"?([\w\-\+\/_]+)/) {
1633         $boundary = $1;
1634       } else {
1635         http_die("malformed HTTP POST (no boundary found)");
1636       }
1637
1638       READPOST: while (&nvt_read) {
1639         # the file itself - *must* be last part of POST!
1640         if (/^Content-Disposition:\s*form-data;\s*name="file";\s*filename="(.+)"/i) {
1641           push @header,$_;
1642           $file = $param{'FILE'} = $1;
1643           while (&nvt_read) {
1644             last if /^\s*$/;
1645             $fileid = $1 if /^X-File-ID:\s*(.+)/;
1646             $fpsize = $1 if /^Content-Length:\s*(\d+)/;
1647             $flink  = $1 if /^Content-Location:\s*(\/.+)/;
1648             push @header,$_;
1649           }
1650           # STDIN is now at begin of file, will be read later with get_file()
1651           last;
1652         }
1653         # all other parameters
1654         if (/^Content-Disposition:\s*form-data;\s*name="([a-z]\w*)"/i) {
1655           my $x = $1;
1656           nvt_skip_to('^\s*$');
1657           &nvt_read;
1658           setparam($x,$_);
1659           NEXTPART: while (&nvt_read) {
1660             last READPOST if /^--\Q$boundary--/;
1661             last NEXTPART if /^--\Q$boundary/;
1662           }
1663         }
1664       }
1665     }
1666
1667     if (length($file)) {
1668       $file =~ s/%(\d+)/chr($1)/ge;
1669       $file = untaint(strip_path(normalize($file)));
1670       $file =~ s/[\\\/<>]/_/g; # filter out dangerous chars
1671       $file =~ s/^\|//;        # filter out dangerous chars
1672       $file =~ s/\|$//;        # filter out dangerous chars
1673       $filename = $file;
1674       $fkey = urlencode($file);
1675     }
1676
1677     # check for akey, gkey and skey (from HTTP POST)
1678     &check_keys;
1679
1680   }
1681
1682   if ($from) {
1683     unless ($skey or $gkey or $okey) {
1684       $from .= '@'.$mdomain if $mdomain and $from !~ /@/;
1685       if ($from ne 'anonymous' and not checkaddress($from)) {
1686         http_die("<code>$from</code> is not a valid e-mail address");
1687       }
1688     }
1689     $from = untaint($from);
1690   }
1691
1692   # collect multiple addresses and check for aliases (not group)
1693   if (@to and "@to" !~ /^@[\w-]+$/
1694       and not ($gkey or $addto or $command =~ /^LIST(RECEIVED)?$/)) {
1695     # read address book
1696     if ($from and open my $AB,'<',"$from/\@ADDRESS_BOOK") {
1697       my ($alias,$addresses,$autodelete,$locale,$keep);
1698       while (<$AB>) {
1699         s/#.*//;
1700         $_ = lc $_;
1701         if (s/^\s*(\S+)[=\s]+(\S+)//) {
1702           ($alias,$addresses) = ($1,$2);
1703           # alias specific options?
1704           $autodelete = $locale = $keep = '';
1705           $autodelete = $1 if /autodelete=(\w+)/;
1706           $locale     = $1 if /locale=(\w+)/;
1707           $keep       = $1 if /keep=(\d+)/;
1708           foreach my $address (split(",",$addresses)) {
1709             # alias address specific :options?
1710             if ($address =~ s/(.+?):(.+)/$1/) {
1711               my @options = split(':',$2);
1712               $address = expand($address);
1713               foreach (@options) {
1714                 if (/^keep=(\d+)$/i) {
1715                   $alias_keep{$alias}{$address} = $1
1716                 }
1717                 if (/^autodelete=(yes|no|delay)$/i) {
1718                   $alias_autodelete{$alias}{$address} = $1
1719                 }
1720                 if (/^locale=(\w+)$/i) {
1721                   $alias_locale{$alias}{$address} = $1
1722                 }
1723               }
1724             } else {
1725               $address = expand($address);
1726             }
1727             push @{$ab{$alias}},$address;
1728             $autodelete{$alias} = $autodelete if $autodelete;
1729             $keep{$alias}       = $keep       if $keep;
1730             $locale{$alias}     = $locale     if $locale;
1731           }
1732         }
1733       }
1734       close $AB;
1735     }
1736
1737     # look for recipient's options and eliminate dupes
1738     %to = ();
1739     foreach my $to (my @loop = @to) {
1740       # address book alias?
1741       if ($to !~ /@/ and ($ab{$to} or $to =~ /(.+?):(.+)/ and $ab{$1})) {
1742         my $alias = $to;
1743         my @options = ();
1744         $alias =~ s/:(.*)// and @options = split(':',$1);
1745         if (@options) {
1746           # alias with :options
1747           $alias =~ s/:.*//;
1748           foreach my $address (my @loop = @{$ab{$alias}}) {
1749             $to{$address} = $address; # ignore dupes
1750             foreach (@options) {
1751               $keep{$address} = $1       if /^keep=(\d+)$/i;
1752               $autodelete{$address} = $1 if /^autodelete=(yes|no|delay)$/i;
1753               $locale{$address} = $1     if /^locale=(\w+)$/i;
1754             }
1755           }
1756         }
1757         foreach my $address (my @loop = @{$ab{$alias}}) {
1758           $to{$address} = $address; # ignore dupes
1759           unless ($keep{$address}) {
1760             $keep{$address} = $keep{$alias} if $keep{$alias};
1761             if ($specific{'keep'}) {
1762               $keep{$address} = $specific{'keep'}
1763             } elsif (my $keep = $alias_keep{$alias}{$address}) {
1764               $keep{$address} = $keep;
1765             } elsif ($keep{$alias}) {
1766               $keep{$address} = $keep{$alias}
1767             }
1768           }
1769           unless ($autodelete{$address}) {
1770             if ($specific{'autodelete'}) {
1771               $autodelete{$address} = $specific{'autodelete'};
1772             } elsif (my $autodelete = $alias_autodelete{$alias}{$address}) {
1773               $autodelete{$address} = $keep;
1774             } elsif ($autodelete{$alias}) {
1775               $autodelete{$address} = $autodelete{$alias};
1776             } else {
1777               $autodelete{$address} = readlink "$address/\@AUTODELETE"
1778                                       || $autodelete;
1779             }
1780           }
1781           unless ($locale{$address}) {
1782             if (my $locale = readlink "$address/\@LOCALE") {
1783               $locale{$address} = $locale;
1784             } elsif ($locale{$alias}) {
1785               $locale{$address} = $locale{$alias};
1786             } elsif ($locale = $alias_locale{$alias}{$address}) {
1787               $locale{$address} = $locale;
1788             } else {
1789               $locale{$address} = $::locale ;
1790             }
1791             $locale{$address} ||= $default_locale || 'english';
1792           }
1793         }
1794       } else {
1795         # regular address, not an alias
1796         if ($to =~ s/(.+?):(.+)/$1/) {
1797           my @options = split(':',$2);
1798           $to = expand($to);
1799           foreach (@options) {
1800             $keep{$to} = $1       if /^keep=(\d+)$/i;
1801             $autodelete{$to} = $1 if /^autodelete=(yes|no|delay)$/i;
1802             $locale{$to} = $1     if /^locale=(\w+)$/i;
1803           }
1804         }
1805         $to = expand($to);
1806         $to{$to} = $to; # ignore dupes
1807         unless ($autodelete{$to}) {
1808           $autodelete{$to} = untaint(readlink("$to/\@AUTODELETE")
1809                                      ||$autodelete);
1810           if ($specific{'autodelete'}) {
1811             $autodelete{$to} = $specific{'autodelete'};
1812           }
1813         }
1814         unless ($keep{$to}) {
1815           $keep{$to} = $keep_default;
1816           $keep{$to} = $keep                          if $keep;
1817           $keep{$to} = untaint(readlink "$to/\@KEEP") if -l "$to/\@KEEP";
1818           $keep{$to} = $specific{'keep'}              if $specific{'keep'};
1819         }
1820       }
1821       $autodelete{$to} = 'NO' if $to =~ /$amdl/; # mailing lists, etc
1822       if (-e "$to/\@CAPTIVE") {
1823         my $v;
1824         $v = readlink "$to/\@AUTODELETE" and $autodelete{$to} = $v;
1825         $v = readlink "$to/\@KEEP"       and $keep{$to}       = $v;
1826       }
1827     }
1828     @to = keys %to;
1829
1830     if (scalar(@to) == 1) {
1831       $to = "@to";
1832       $keep       = $keep{$to}       if $keep{$to};
1833       $autodelete = $autodelete{$to} if $autodelete{$to};
1834     }
1835
1836     # check recipients and eliminate dupes
1837     %to = ();
1838     foreach $to (@to) {
1839       if ($to eq 'anonymous') {
1840         $to{$to} = $to;
1841       } else {
1842         if ($to =~ /^@(.+)/) {
1843           http_die("You cannot send to more than one group") if @to > 1;
1844           http_die("Group <code>$to</code> does not exist") unless -f "$from/\@GROUP/$1";
1845         } else {
1846           if ($skey or $gkey or $okey or checkaddress($to)) {
1847             $to .= '@'.$mdomain if $mdomain and $to !~ /@/;
1848             $to{$to} = untaint($to);
1849           } else {
1850             http_die("<code>$to</code> is not a valid e-mail address");
1851           }
1852         }
1853       }
1854     }
1855     @to = values %to;
1856   }
1857
1858   foreach $to (@to) {
1859     unless (checkforbidden($to)) {
1860       http_die("<code>$to</code> is not allowed");
1861     }
1862   }
1863 }
1864
1865
1866 # show the status progress bar
1867 sub showstatus {
1868   my $wclose;
1869   my ($upload,$data,$sfile,$ukey,$file);
1870   my ($nsize,$tsize);
1871   my ($t0,$t1,$t2,$tt,$ts,$tm);
1872   my ($osize,$percent,$npercent);
1873   local $_;
1874
1875   $wclose = '<p><a href="#" onclick="window.close()">close</a>'."\n".
1876             '</body></html>'."\n";
1877   $ukey   = "$ukeydir/$uid";
1878   $upload = "$ukey/upload";
1879   $data   = "$ukey/data";
1880   $sfile  = "$ukey/size";
1881   for (1..$timeout) {
1882     sleep 1;
1883     $tsize = readlink $sfile and last;
1884     # upload error?
1885     # remark: stupid Internet Explorer *needs* the error represented in this
1886     # asynchronous popup window, because it cannot display the error in the
1887     # main window on HTTP POST!
1888     if (-f $ukey and open $ukey,'<',$ukey or
1889         -f "$ukey/error" and open $ukey,'<',"$ukey/error") {
1890       undef $/;
1891       unlink $ukey;
1892       html_error($error,<$ukey> || 'unknown');
1893     }
1894   }
1895   # unlink $sfile;
1896
1897   if (defined $tsize and $tsize == 0) {
1898     print "<script type='text/javascript'>window.close()</script>\n";
1899     exit;
1900   }
1901   unless ($tsize) {
1902     html_error($error,
1903                "no file data received - does your file exist or is it >2GB?")
1904   }
1905   html_error($error,"file size unknown") unless $tsize =~ /^\d+$/;
1906
1907   http_header('200 OK');
1908   if (open $ukey,'<',"$ukey/filename") {
1909     local $/;
1910     $file = <$ukey>;
1911     close $ukey;
1912   }
1913   http_die("no filename?!") unless $file;
1914
1915   my $ssize = $tsize;
1916   if ($ssize<2097152) {
1917     $ssize = sprintf "%d kB",int($ssize/1024);
1918   } else {
1919     $ssize = sprintf "%d MB",int($ssize/1048576);
1920   }
1921
1922   pq(qq(
1923     "<html><body>"
1924     "<center>"
1925     "<h1>Upload Status for<br><code>$file ($ssize)</code></h1>"
1926     '<img src="/action-fex-camel.gif" id="afc">'
1927     "</center>"
1928     "<input type='text' id='percent' style='margin-left:1ex;color:black;background:transparent;border:none;width:32ex;' disabled='true' value='0%'>"
1929     "<div style='border:1px solid black;width:100%;height:20px;'>"
1930     "<div style='float:left;width:0%;background:black;height:20px;' id='bar'>"
1931     "</div></div>"
1932   ));
1933
1934   # wait for upload file
1935   for (1..9) {
1936     last if -f $upload or -f $data;
1937     sleep 1;
1938   }
1939   unless (-f $upload or -f $data) {
1940     print "<p><H3>ERROR: no upload received</H3>\n";
1941     print $wclose;
1942     exit;
1943   }
1944
1945   $SIG{ALRM} = sub { die "TIMEOUT in showstatus: no (more) data received\n" };
1946   alarm($timeout*2);
1947
1948   $t0 = $t1 = time;
1949   $osize = $percent = $npercent = 0;
1950
1951   for ($percent = 0; $percent<100; sleep(1)) {
1952     $t2 = time;
1953     $nsize = -s $upload;
1954     if (defined $nsize) {
1955       if ($nsize<$osize) {
1956         print "<p><h3>ABORTED</h3>\n";
1957         print $wclose;
1958         exit;
1959       }
1960       if ($nsize>$osize) {
1961         alarm($timeout*2);
1962         $osize = $nsize;
1963       }
1964       $npercent = int($nsize*100/$tsize);
1965       $showsize = calcsize($tsize,$nsize);
1966     } else {
1967       $npercent = 100;
1968       $showsize = calcsize($tsize,$tsize);
1969     }
1970     # hint: for ISDN (or even slower) links, 5 s tcp delay is minimum
1971     # so, updating more often is contra-productive
1972     if ($t2>$t1+5 or $npercent>$percent) {
1973       $percent = $npercent;
1974       $t1 = $t2;
1975       $tm = int(($t2-$t0)/60);
1976       $ts = $t2-$t0-$tm*60;
1977       $tt = sprintf("%d:%02d",$tm,$ts);
1978       pq(qq(
1979         "<script type='text/javascript'>"
1980         "  document.getElementById('bar').style.width = '$percent%';"
1981         "  document.getElementById('percent').value = '$showsize, $tt, $percent %';"
1982         "</script>"
1983       )) or last;
1984     }
1985   }
1986
1987   alarm(0);
1988   if ($npercent == 100) {
1989     print "<h3>file successfully transferred</h3>\n";
1990   } else {
1991     print "<h3>file transfer aborted</h3>\n";
1992   }
1993   pq(qq(
1994     "<script type='text/javascript'>"
1995     "  document.getElementById('afc').src='/logo.jpg'"
1996     "</script>"
1997   ));
1998   print $wclose;
1999   unlink $ukey;
2000   exit;
2001 }
2002
2003
2004 # get file from post request
2005 sub get_file {
2006   my ($to,$filed,$upload,$nupload,$speed,$download);
2007   my ($b,$n,$uss);
2008   my $dkey;
2009   my ($fh,$filesize);
2010   my ($t0,$tt);
2011   my $fb = 0;           # file bytes
2012   my $ebl = 0;          # end boundary length
2013
2014   # FUP, not JUP
2015   if ($boundary) {
2016     $ebl = length($boundary)+8; # 8: 2 * CRLF + 2 * "--"
2017   }
2018
2019   unless ($nostore) {
2020
2021     # download already in progress?
2022     foreach $to (@to) {
2023       $to =~ s/:\w+=.*//; # remove options from address
2024       $filed = "$to/$from/$fkey";
2025       $download = "$filed/download";
2026       if (-f $download and open $download,'>>',$download) {
2027         flock($download,LOCK_EX|LOCK_NB) or
2028           http_die("<code>$filed</code> locked: a download is currently in progress");
2029       }
2030     }
2031
2032     # prepare upload
2033     foreach $to (@to) {
2034       $to =~ s/:\w+=.*//; # remove options from address
2035       $filed = "$to/$from/$fkey";
2036       $nupload = "$filed/upload"; # upload for next recipient
2037       mkdirp($filed);
2038
2039       # upload already prepared (for first recipient)?
2040       if ($upload) {
2041         # link upload for next recipient
2042         unless ($upload eq $nupload or
2043                 -r $upload and -r $nupload and
2044                 (stat $upload)[1] == (stat $nupload)[1])
2045         {
2046           unlink $nupload;
2047           link $upload,$nupload;
2048         }
2049       }
2050
2051       # first recipient => create upload
2052       else {
2053         $upload = $nupload;
2054         unlink "$ukeydir/$uid";
2055         if ($flink) {
2056           if ($seek) {
2057             http_die("cannot resume on link upload");
2058           }
2059           &nvt_read and $flink = $_;
2060           if ($flink !~ /^\//) {
2061             http_die("no file link name ($flink)");
2062           }
2063           $flink = abs_path($flink);
2064           my $fok;
2065           foreach (@file_link_dirs) {
2066             my $dir = abs_path($_);
2067             $fok = $flink if $flink =~ /^\Q$dir\//;
2068           }
2069           unless ($fok) {
2070             http_die("<code>$flink</code> not allowed for linking");
2071           }
2072           my @s = stat($flink);
2073           unless (@s and ($s[2] & S_IROTH) and -r $flink) {
2074             http_die("cannot read <code>$flink</code>");
2075           }
2076           unless (-f $flink and not -l $flink) {
2077             http_die("<code>$flink</code> is not a regular file");
2078           }
2079           # http_die("DEBUG: flink = $flink");
2080           &nvt_read;
2081           &nvt_read if /^$/;
2082           unless (/^--\Q$boundary--/) {
2083             http_die("found no MIME end boundary in upload ($_)");
2084           }
2085           unlink $upload;
2086           symlink untaint($flink),$upload;
2087         } else {
2088           unlink $upload if -l $upload;
2089           open $upload,'>>',$upload or http_die("cannot write $upload - $!");
2090           flock($upload,LOCK_EX|LOCK_NB) or
2091             http_die("<code>$file</code> locked: a transfer is already in progress");
2092           unless ($seek) {
2093             seek $upload,0,0;
2094             truncate $upload,0;
2095           }
2096           # already uploaded file data size
2097           $uss = -s $upload;
2098           # provide upload ID symlink for showstatus
2099           symlink "../$filed","$ukeydir/$uid";
2100         }
2101       }
2102
2103       unlink "$filed/autodelete",
2104              "$filed/error",
2105              "$filed/restrictions",
2106              "$filed/locale",
2107              "$filed/keep",
2108              "$filed/header",
2109              "$filed/id",
2110              "$filed/ip",
2111              "$filed/speed",
2112              "$filed/replyto",
2113              "$filed/useragent",
2114              "$filed/uurl",
2115              "$filed/comment",
2116              "$filed/notify";
2117       unlink "$filed/size" unless $seek;
2118
2119       # showstatus needs file name and size
2120       # fexsend needs full file size (+$seek)
2121       $fh = "$filed/filename";
2122       open $fh,'>',$fh or die "cannot write $fh - $!\n";
2123       print {$fh} $filename;
2124       close $fh;
2125       if ($::filesize > 0 or $cl > 0) {
2126         if ($::filesize > 0) { $filesize = $fpsize || $::filesize }
2127         else                 { $filesize = $cl-$RB-$ebl+$seek }
2128         # new file
2129         unless ($seek) {
2130           if ($::filesize > 0) {
2131             # total file size as reported by POST
2132             mksymlink("$filed/size",$::filesize)
2133               or die "cannot write $filed/size - $!\n";
2134           } else {
2135             # file size as counted
2136             mksymlink("$filed/size",$filesize)
2137               or die "cannot write $filed/size - $!\n";
2138           }
2139         }
2140       }
2141
2142       if ($from eq "@to") {
2143         # special "fex yourself"
2144         mksymlink("$filed/autodelete",$specific{'autodelete'}||'NO');
2145       } else {
2146         $autodelete{$to} = $autodelete unless $autodelete{$to};
2147         if ($autodelete{$to} =~ /^(DELAY|NO|\d+)$/i) {
2148           mksymlink("$filed/autodelete",$autodelete{$to});
2149         }
2150       }
2151
2152       if (my $keep = $keep{$to} || $::keep) {
2153         mksymlink("$filed/keep",$keep);
2154       }
2155       mksymlink("$filed/id",$fileid) if $fileid;
2156       mksymlink("$filed/ip",$ra)     if $ra;
2157       if (my $uurl = $ENV{REQUEST_URL}) {
2158         mksymlink("$filed/uurl",$uurl);
2159       }
2160       if ($http_client and open $http_client,'>',"$filed/useragent") {
2161         print {$http_client} $http_client,"\n";
2162         close $http_client;
2163       }
2164       if ($_ = readlink "$to/\@LOCALE") {
2165         # mksymlink("$filed/locale",$_);
2166       } elsif ($locale{$to}) {
2167         mksymlink("$filed/locale",$locale{$to});
2168       } elsif ($locale and $locale ne $default_locale) {
2169         mksymlink("$filed/locale",$locale);
2170       }
2171       if ($replyto and $replyto =~ /.@./) {
2172         mksymlink("$filed/replyto",$replyto);
2173       }
2174
2175       my $arh = "$from/\@ALLOWED_RHOSTS";
2176       if (-s $arh) {
2177         copy($arh,"$filed/restrictions");
2178       }
2179
2180       if (@header and open $fh,'>',"$filed/header") {
2181         print {$fh} join("\n",@header),"\n";
2182         close $fh;
2183       }
2184
2185       if ((readlink "$to/\@NOTIFICATION"||'') =~ /^no/i) {
2186         $nomail{$to} = 'NOTIFICATION';
2187       }
2188
2189       if ($nomail) {
2190         open $fh,'>',"$filed/notify" and close $fh;
2191       }
2192       if ($comment) {
2193         if (open $fh,'>',"$filed/comment") {
2194           print {$fh} encode_utf8($comment);
2195           close $fh;
2196         }
2197       }
2198
2199       # provide download ID key
2200       unless ($dkey = readlink("$filed/dkey") and -l "$dkeydir/$dkey") {
2201         $dkey = randstring(8);
2202         unlink "$dkeydir/$dkey";
2203         symlink "../$filed","$dkeydir/$dkey"
2204           or http_die("cannot symlink $dkeydir/$dkey ($!)");
2205         unlink "$filed/dkey";
2206         symlink $dkey,"$filed/dkey";
2207       }
2208
2209     }
2210
2211     # extra download (XKEY)?
2212     if ($anonymous and $fkey =~ /^afex_\d/ or
2213         $from eq "@to" and $comment =~ s:^//(.*)$:NOMAIL:)
2214     {
2215       $xkey = $1||$fkey;
2216       $nomail = $comment;
2217       my $x = "$xkeydir/$xkey";
2218       unless (-l $x and readlink($x) eq "../$from/$from/$fkey") {
2219         if (-e $x) {
2220           http_die("extra download key $xkey already exists");
2221         }
2222         symlink "../$from/$from/$fkey",$x
2223           or http_die("cannot symlink $x - $!\n");
2224         unlink "$x/xkey";
2225         symlink $xkey,"$x/xkey";
2226       }
2227     }
2228
2229   }
2230
2231   # file link?
2232   if ($flink) {
2233     # upload link has been already created, no data to read any more
2234     $to = join(',',@to);
2235     fuplog($to,$fkey,0);
2236     debuglog("upload link successfull, dkey=$dkey");
2237   }
2238
2239   # regular file
2240   else {
2241
2242     # at last, read (real) file data
2243     $t0 = time();
2244
2245     # streaming data?
2246     if ($cl == -1) {
2247       alarm($timeout*2);
2248       # read until EOF, including MIME end boundary
2249       # note: cannot use sysread because of previous buffered read!
2250       while ($n = read(STDIN,$_,$bs)) {
2251         $RB += $n;
2252         $fb += $n;
2253         syswrite $upload,$_ unless $nostore;
2254         alarm($timeout*2);
2255       }
2256       # size of transferred file, without end boundary
2257       $ndata = untaint($fb-$ebl);
2258     }
2259
2260     # normal file with known file size
2261     else {
2262
2263       if ($fpsize) {
2264         debuglog(sprintf("still awaiting %d+%d = %d bytes",
2265                  $fpsize,$ebl,$fpsize+$ebl));
2266         $cl = $RB+$fpsize+$ebl; # recalculate CONTENT_LENGTH
2267       } else {
2268         if ($::filesize) {
2269           $cl = $RB+$::filesize+$ebl; # recalculate CONTENT_LENGTH
2270         }
2271         debuglog(sprintf("still awaiting %d-%d = %d bytes",
2272                          $cl,$RB,$cl-$RB));
2273       }
2274       # read until end boundary, not EOF
2275       while ($RB < $cl-$ebl) {
2276         $b = $cl-$ebl-$RB;
2277         $b = $bs if $b > $bs;
2278         # max wait for 1 kB/s, but at least 10 s
2279         # $timeout = $b/1024;
2280         # $timeout = 10 if $timeout < 10;
2281         alarm($timeout);
2282         if ($n = read(STDIN,$_,$b)) {
2283           $RB += $n;
2284           $fb += $n;
2285           # syswrite is much faster than print
2286           syswrite $upload,$_ unless $nostore;
2287           if ($bwlimit) {
2288             alarm(0);
2289             $tt = (time-$t0) || 1;
2290             while ($RB/$tt/1024 > $bwlimit) {
2291               sleep 1;
2292               $tt = time-$t0;
2293             }
2294           }
2295           # debuglog($_);
2296         } else {
2297           last;
2298         }
2299       }
2300       # read end boundary - F*IX is broken!
2301       if ($ebl and $http_client !~ /F\*IX/) {
2302         $_ = <STDIN>;
2303         $_ = <STDIN>||'';
2304         unless (/^--\Q$boundary--/) {
2305           http_die("found no MIME end boundary in upload ($_)");
2306         }
2307       }
2308       $RB += $ebl;
2309       $ndata = untaint($fb);
2310     }
2311
2312     alarm(0);
2313
2314     unless ($nostore) {
2315       close $upload; # or die "cannot close $upload - $!\n";;
2316
2317       # throuput in kB/s
2318       $tt = (time-$t0) || 1;
2319       mksymlink("$filed/speed",int($fb/1024/$tt));
2320
2321       unless ($ndata) {
2322         http_die(
2323           "No file data received!".
2324           " File name correct?".
2325           " File too big (browser-limit: 2 GB!)?"
2326         );
2327       }
2328
2329       $to = join(',',@to);
2330
2331       # streaming upload?
2332       if ($cl == -1) {
2333
2334         open $upload,'<',$upload or http_die("internal error - cannot read upload");
2335         seek $upload,$ndata+2,0;
2336         $_ = <$upload>||'';
2337         unless (/^--\Q$boundary--/) {
2338           http_die("found no MIME end boundary in upload ($_)");
2339         }
2340         close $upload;
2341         truncate $upload,$ndata;
2342
2343       } else {
2344
2345         # truncate boundary string
2346         # truncate $upload,$ndata+$uss if -s $upload > $ndata+$uss;
2347
2348         # incomplete?
2349         if ($cl != $RB) {
2350           fuplog($to,$fkey,$ndata,'(aborted)');
2351           if ($fpsize) {
2352             http_die("read $RB bytes, but Content-Length announces $fpsize bytes");
2353           } else {
2354             http_die("read $RB bytes, but CONTENT_LENGTH announces $cl bytes");
2355           }
2356         }
2357
2358         # multipost, not complete
2359         if ($::filesize > -s $upload) {
2360           http_header('206 Partial OK');
2361           exit;
2362         }
2363
2364         # save error?
2365         if (-s $upload > ($::filesize||$filesize)) {
2366           fuplog($to,$fkey,$ndata,'(write error: upload > filesize)');
2367           http_die("internal server error while writing file data");
2368         }
2369
2370       }
2371       fuplog($to,$fkey,$ndata);
2372       debuglog("upload successfull, dkey=$dkey");
2373     }
2374   }
2375 }
2376
2377
2378 # check recipients restriction
2379 sub check_rr {
2380   my $from = shift;
2381   my @to = @_;
2382   my $rr = "$from/\@ALLOWED_RECIPIENTS";
2383   my ($allowed,$to,$ar,$rd);
2384
2385   if (-s $rr and open $rr,'<',$rr) {
2386
2387     $restricted = $rr;
2388
2389     foreach (@to) {
2390       my $to = $_;
2391       $allowed = 0;
2392       seek $rr,0,0;
2393       while (<$rr>) {
2394         chomp;
2395         s/#.*//;
2396         s/\s//g;
2397
2398         if (/^\@LOCAL_RDOMAINS/) {
2399           $ar = '(@';
2400           foreach (@local_rdomains) {
2401             my $rd = $_;
2402             # allow wildcard *, but not regexps
2403             $rd =~ s/\./\\./g;
2404             $rd =~ s/\*/[\\w.-]+/g;
2405             $ar .= '|[^\@]+\@' . $rd;
2406           }
2407           $ar .= ')';
2408         } elsif (/^\@LOCAL_USERS/ and -s "$to/@") {
2409           $allowed = 1;
2410           last;
2411         } else {
2412           # allow wildcard *, but not regexps
2413           $ar = quotemeta $_;
2414           $ar =~ s/\\\*/[^@]*/g;
2415         }
2416
2417         if ($to =~ /^$ar$/i) {
2418           $allowed = 1;
2419           last;
2420         }
2421
2422       }
2423
2424       unless ($allowed) {
2425         fuplog("ERROR: $from not allowed to fex to $to");
2426         debuglog("$to not in $spooldir/$from/\@ALLOWED_RECIPIENTS");
2427         http_die("You ($from) are not allowed to fex to $to");
2428       }
2429     }
2430
2431     close $rr;
2432   }
2433 }
2434
2435
2436 # add domain to user if necessary
2437 sub expand {
2438   my @users = @_;
2439   my @ua;
2440
2441   foreach my $u (my @loop = @users) {
2442     if ($u =~ /^anonymous(_\d+)?$/) {
2443       $u = "$u\@$hostname";
2444     }
2445     if ($u eq 'nettest') {
2446       if ($mdomain and -d "$u\@$mdomain") {
2447         $u .= "\@$mdomain"
2448       } elsif (-d "$u\@$hostname") {
2449         $u .= "\@$hostname"
2450       }
2451     }
2452     if    ($u =~ /@/)          { push @ua,$u }
2453     elsif ($mdomain)           { push @ua,"$u\@$mdomain" }
2454     elsif (-d "$u\@$hostname") { push @ua,"$u\@$hostname" }
2455     else                       { push @ua,$u }
2456   }
2457
2458   return wantarray ? @ua : join(',',@ua);
2459 }
2460
2461
2462 # forward-copy (bounce) an already uploaded file
2463 sub forward {
2464   my $file = shift;
2465   my ($nfile,$to,$AB);
2466   my ($filename,$keep);
2467   my (%to);
2468
2469   http_die("no file data for <code>$file</code>") unless -f "$file/data";
2470
2471   $keep = $::keep||$keep_default;
2472   if (my $mt = mtime("$file/data")) { $keep += int((time-$mt)/$DS) }
2473
2474   if (@to) {
2475
2476     # check recipients restriction
2477     check_rr($from,@to);
2478
2479     # read aliases from address book
2480     if (open $AB,'<',"$from/\@ADDRESS_BOOK") {
2481       while (<$AB>) {
2482         s/#.*//;
2483         $_ = lc $_;
2484         if (s/^\s*(\S+)[=\s]+(\S+)//) {
2485           my ($alias,$address) = ($1,$2);
2486           foreach my $address (split(",",$address)) {
2487             $address .= '@'.$mdomain if $mdomain and $address !~ /@/;
2488             push @{$ab{$alias}},$address;
2489           }
2490         }
2491       }
2492       close $AB;
2493     }
2494
2495     # collect addresses
2496     foreach my $to (my @loop = @to) {
2497       if ($ab{$to}) {
2498         foreach my $address (@{$ab{$to}}) {
2499           $to{$address} = $address;
2500         }
2501       } else {
2502         $to .= '@'.$mdomain if $mdomain and $to !~ /@/;
2503         $to{$to} = $to;
2504       }
2505     }
2506
2507     @to = keys %to;
2508
2509     http_header('200 OK');
2510     print html_header($head);
2511
2512     foreach my $to (my @loop = @to) {
2513       $to =~ s/:\w+=.*//; # remove options from address
2514       $nfile = $file;
2515       $nfile =~ s:.*?/:$to/:;
2516       next if $nfile eq $file;
2517       mkdirp($nfile);
2518       http_die("cannot create directory $nfile") unless -d $nfile;
2519       unlink "$nfile/data",
2520              "$nfile/upload",
2521              "$nfile/download",
2522              "$nfile/autodelete",
2523              "$nfile/error",
2524              "$nfile/restrictions",
2525              "$nfile/keep",
2526              "$nfile/header",
2527              "$nfile/id",
2528              "$nfile/speed",
2529              "$nfile/comment",
2530              "$nfile/replyto",
2531              "$nfile/notify";
2532       if ($comment) {
2533         open $comment,'>',"$nfile/comment";
2534         print {$comment} $comment;
2535         close $comment;
2536       }
2537       if ($autodelete =~ /^(DELAY|NO|\d+)$/i) {
2538         symlink $autodelete,"$nfile/autodelete";
2539       }
2540       symlink          $keep,             "$nfile/keep";
2541                   copy("$file/id",        "$nfile/id");
2542                   copy("$file/ip",        "$nfile/ip");
2543                   copy("$file/speed",     "$nfile/speed");
2544                   copy("$file/replyto",   "$nfile/replyto");
2545       $filename = copy("$file/filename",  "$nfile/filename");
2546       link             "$file/data",      "$nfile/data"
2547         or die http_die("cannot create $nfile/data - $!");
2548       unless ($dkey = readlink("$nfile/dkey") and -l "$dkeydir/$dkey") {
2549         $dkey = randstring(8);
2550         unlink "$dkeydir/$dkey";
2551         symlink "../$nfile","$dkeydir/$dkey"
2552           or http_die("cannot symlink $dkeydir/$dkey");
2553         unlink "$nfile/dkey";
2554         symlink $dkey,"$nfile/dkey"
2555           or http_die("cannot create $nfile/dkey - $!");
2556       }
2557
2558       if ($nomail or $nomail{$to}) {
2559         if ($filename) {
2560           my $url = "$durl/$dkey/".normalize_filename($filename);
2561           pq(qq(
2562             'Download-URL for $to:<br>'
2563             '<code>$url</code>'
2564             '<p>'
2565           ));
2566         }
2567       } else {
2568         notify_locale($dkey,'new');
2569         fuplog($to,urlencode($filename),"(forwarded)");
2570         if ($filename) {
2571           pq(qq(
2572             'File "$filename" copy-forwarded to $to and notified.'
2573             '<p>'
2574           ));
2575         }
2576       }
2577     }
2578     pq(qq(
2579       '<a href="/foc?akey=$akey">back to F*EX operation control</a>'
2580       '</body></html>'
2581     ));
2582   } else {
2583     $filename = filename($file);
2584     http_header('200 OK');
2585     print html_header($head);
2586     pq(qq(
2587       '<form name="upload"'
2588       '      action="/fup"'
2589       '      method="post"'
2590       '      accept-charset="UTF-8"'
2591       '      enctype="multipart/form-data">'
2592       '  <input type="hidden" name="akey"    value="$akey">'
2593       '  <input type="hidden" name="dkey"    value="$dkey">'
2594       '  <input type="hidden" name="command" value="FORWARD">'
2595       '  forward a copy of "<code>$filename</code>" to:<br>'
2596       '  <input type="text" name="to" size="80">'
2597       '</form>'
2598       '</body></html>'
2599     ));
2600   }
2601 }
2602
2603
2604 # modify file parameter
2605 sub modify {
2606   my $file = shift;
2607   my $filename = filename($file);
2608   my $dkey = readlink "$file/$dkey";
2609   my $to;
2610   my @parameter;
2611
2612   http_die("no file data for <code>$file</code>") unless -f "$file/data";
2613
2614   $to = $file;
2615   $to =~ s:/.*::;
2616   if ($specific{'keep'}) {
2617     mksymlink("$file/keep",$keep);
2618     utime time,time,"$file/filename";
2619     push @parameter,'KEEP';
2620   }
2621   if ($specific{'autodelete'}) {
2622     mksymlink("$file/autodelete",$autodelete);
2623     push @parameter,'AUTODELETE';
2624   }
2625   if ($comment) {
2626     if (open $comment,'>',"$file/comment") {
2627       print {$comment} $comment;
2628       close $comment;
2629     }
2630     notify_locale($dkey,'new');
2631     push @parameter,'COMMENT';
2632   }
2633   http_header('200 OK');
2634   print "Parameter ".join(',',@parameter)." modified for $filename for $to\n";
2635 }
2636
2637
2638 sub calcsize {
2639   my ($tsize,$nsize) = @_;
2640   if ($tsize<2097152) {
2641     return sprintf "%d kB",int($nsize/1024);
2642   } else {
2643     return sprintf "%d MB",int($nsize/1048576);
2644   }
2645 }
2646
2647
2648 # set parameter variables
2649 sub setparam {
2650   my ($v,$vv) = @_;
2651   my ($idf,$to);
2652
2653   $v = uc(despace($v));
2654
2655 #  if ($vv =~ /([<>])/) {
2656 #    http_die(sprintf("\"&#%s;\" is not allowed in parameter $v",ord($1)));
2657 #  }
2658
2659   $param{$v} = $vv;
2660   if ($v eq 'LOGOUT') {
2661     $logout = $v;
2662     # skey and gkey are persistant!
2663     $akey = $1 if $ENV{QUERY_STRING} =~ /AKEY:(\w+)/i;
2664     unlink "$akeydir/$akey";
2665     $login = $FEXHOME.'/cgi-bin/login';
2666     if (-x $login) {
2667       $login = readlink $login || 'login';
2668       nvt_print(
2669         "HTTP/1.1 302 Found",
2670         "Location: $ENV{PROTO}://$ENV{HTTP_HOST}/$login",
2671         'Content-Length: 0',
2672         ""
2673       );
2674     } else {
2675       nvt_print(
2676         "HTTP/1.1 302 Found",
2677         "Location: $ENV{PROTO}://$ENV{HTTP_HOST}/fup",
2678         'Content-Length: 0',
2679         ""
2680       );
2681     }
2682     &reexec;
2683   } elsif ($v eq 'LOCALE' and $vv =~ /^(\w+)$/) {
2684     $locale = $1;
2685   } elsif ($v eq 'REDIRECT' and $vv =~ /^([\w?=]+)$/) {
2686     $redirect = $1;
2687   } elsif ($v eq 'SKEY' and $vv =~ /^([\w:]+)/) {
2688     $skey = $1;
2689     $restricted = $v;
2690   } elsif ($v eq 'GKEY' and $vv =~ /^([\w:]+)/) {
2691     $gkey = $1 unless $nomail;
2692     $restricted = $v;
2693   } elsif ($v eq 'DKEY' and $vv =~ /^(\w+)/) {
2694     $dkey = $1;
2695   } elsif ($v eq 'AKEY' and $vv =~ /^(\w+)/) {
2696     $akey = $1;
2697   } elsif ($v eq 'FROM' or $v eq 'USER') {
2698     $from = normalize_email($vv);
2699     $from = untaint(expand($from));
2700     checkchars('from address',$from);
2701     # maybe FROM=SUBUSER !
2702     # checkaddress($from) or http_die("FROM $from is no legal e-mail address");
2703   } elsif ($v eq 'REPLYTO') {
2704     $replyto = normalize_email($vv);
2705     checkchars('replyto address',$replyto);
2706     checkaddress($replyto) or
2707       http_die("REPLYTO $replyto is no legal e-mail address");
2708   } elsif ($v eq 'ADDTO') {
2709     $vv =~ s/\s.*//;
2710     $addto = normalize_email($vv);
2711   } elsif ($v eq 'SUBMIT') {
2712     $submit = decode_utf8(normalize($vv));
2713   } elsif ($v eq 'FEXYOURSELF') {
2714     $submit = $vv;
2715     @to = ($from);
2716     $specific{'autodelete'} = $autodelete = 'no';
2717   } elsif ($v eq 'TO') {
2718     # extract AUTODELETE and KEEP options
2719     if ($vv =~ s/[\s,]+AUTODELETE=(\w+)//i) {
2720       $specific{'autodelete'} = $autodelete = uc($1);
2721     }
2722     if ($vv =~ s/[\s,]+KEEP=(\d+)//i) {
2723       $keep = $1;
2724       $keep = $keep_max if $keep_max and $keep > $keep_max;
2725       $specific{'keep'} = $keep;
2726     }
2727     $to = normalize(lc($vv));
2728     $to =~ s/[\n\s;,]+/,/g;
2729     if ($from) {
2730       if ($to eq '.') {
2731         $to = $from;
2732          unless ($specific{'autodelete'}) {
2733            $specific{'autodelete'} = $autodelete = 'no';
2734          }
2735       }
2736       if ($to eq '//') {
2737         $to = $from;
2738         unless ($specific{'autodelete'}) {
2739           $specific{'autodelete'} = $autodelete = 'no';
2740         }
2741         $comment = '//';
2742       }
2743     }
2744     checkchars('to address',$to);
2745     push @to,split(',',$to);
2746   } elsif ($v eq 'ID') {
2747     $id = despace($vv);
2748     checkchars('auth-ID',$id);
2749   } elsif ($v eq 'TCE') {
2750     $test = despace($vv);
2751   } elsif ($v eq 'OKEY' and $vv =~ /^(\w+)$/) {
2752     $okey = $1;
2753     $restricted = $v;
2754   } elsif ($v eq 'FILEID' and $vv =~ /^(\w+)$/) {
2755     $fileid = $1;
2756   } elsif ($v eq 'CONTENTLENGTH' and $vv =~ /^(\d+)$/) {
2757     $contentlength = $1;
2758   } elsif ($v eq 'FILE' or $v eq 'FILENAME') {
2759     $file = strip_path(normalize($vv));
2760   } elsif ($v eq 'UID' and $vv =~ /^(\w+)$/) {
2761     $uid = $1;
2762   } elsif ($v eq 'ID_FORGOTTEN') {
2763     $id_forgotten = $vv;
2764   } elsif ($v eq 'SHOWSTATUS' and $vv =~ /^(\w+)$/) {
2765     $showstatus = $uid = $1;
2766   } elsif ($v eq 'COMMENT') {
2767     $comment = decode_utf8(normalize($vv));
2768     $comment =~ s/^\s*!\.!/!SHORTMAIL!/;
2769     $comment =~ s/^!#!/!NOMAIL!/;
2770     $comment =~ s/^!-!/!NOSTORE!/;
2771     $nomail = $comment if $comment =~ /NOMAIL/;
2772     $nostore = $nomail = $comment if $comment =~ /NOSTORE/;
2773     $bcc .= " $from"   if $comment =~ s/\s*!bcc!?\s*//i;
2774     # backward compatibility
2775     foreach my $cmd (qw(
2776       DELETE LIST CHECKQUOTA CHECKRECIPIENT RECEIVEDLOG SENDLOG FOPLOG FORWARD
2777     )) { $command = $comment if $comment eq $cmd }
2778   } elsif ($v eq 'COMMAND') {
2779     $command = normalize($vv);
2780   } elsif ($v eq 'BWLIMIT' and $vv =~ /^(\d+)$/) {
2781     $bwlimit = $1;
2782   } elsif ($v eq 'SEEK' and $vv =~ /^(\d+)$/) {
2783     $seek = $1;
2784   } elsif ($v eq 'FILESIZE' and $vv =~ /^(\d+)$/) {
2785     $filesize = $1; # complete filesize!
2786     &check_space($filesize-$seek);
2787   } elsif ($v eq 'AUTODELETE' and $vv =~ /^(\w+)$/) {
2788     $specific{'autodelete'} = $autodelete = uc($1);
2789   } elsif ($v eq 'KEEP' and $vv =~ /^(\d+)$/) {
2790     $keep = $1;
2791     $keep = $keep_max if $keep_max and $keep > $keep_max;
2792     $specific{'keep'} = $keep;
2793   } elsif ($v eq 'TIMEOUT' and $vv =~ /^(\d+)$/) {
2794      $specific{'timeout'} = $timeout = $1;
2795   }
2796 }
2797
2798
2799 sub id_forgotten {
2800   my ($id,$to,$subuser,$gm,$skey,$gkey,$url,$fup);
2801
2802   return if $nomail;
2803
2804   $fup = $durl;
2805   $fup =~ s:/fop:/fup:;
2806
2807   # full user
2808   if (open $from,'<',"$from/\@") {
2809     $id = getline($from);
2810     close $from;
2811   }
2812   if ($id) {
2813     $url = "$fup/".b64("from=$from&id=$id");
2814     mail_forgotten($from,qqq(qq(
2815       'Your reqested F*EX auth-ID for $fup?from=$from is:'
2816       '$id'
2817       ''
2818       'Or use:'
2819       '$url'
2820     )));
2821     exit;
2822   }
2823
2824   # sub user
2825   foreach my $skey (glob("$skeydir/*")) {
2826     if (-f $skey and open $skey,'<',$skey) {
2827       while (<$skey>) {
2828         $_ = lc;
2829         if (/^(\w+)=(.+)/) {
2830           $subuser = $2 if $1 eq 'from';
2831           $to      = $2 if $1 eq 'to';
2832         }
2833       }
2834       close $skey;
2835     }
2836     if ($from and $to and $from eq $subuser) {
2837       $skey =~ s:.*/::;
2838       mail_forgotten($subuser,qqq(qq(
2839         'Your reqested F*EX login is:'
2840         ''
2841         '$fup?skey=$skey'
2842       )));
2843       exit;
2844     }
2845   }
2846
2847   # group user
2848   foreach my $gkey (glob("$gkeydir/*")) {
2849     if (-f $gkey and open $gkey,'<',$gkey) {
2850       while (<$gkey>) {
2851         $_ = lc;
2852         if (/^(\w+)=(.+)/) {
2853           $gm = $2 if $1 eq 'from';
2854           $to = $2 if $1 eq 'to';
2855         }
2856       }
2857       close $gkey;
2858     }
2859     if ($gm and $to and $from eq $gm) {
2860       $gkey =~ s:.*/::;
2861       mail_forgotten($gm,qqq(qq(
2862         'Your reqested F*EX login is:'
2863         ''
2864         '$fup?gkey=$gkey'
2865       )));
2866       exit;
2867     }
2868   }
2869   http_die("<code>$from</code> is not a F*EX user on this server");
2870 }
2871
2872
2873 sub mail_forgotten {
2874   my $user = shift;
2875   my @msg = @_;
2876   local *P;
2877
2878   return if $nomail;
2879
2880   open P,'|-',$sendmail,$user,$bcc or http_die("cannot start sendmail - $!\n");
2881   pq(P,qq(
2882     'From: $admin'
2883     'To: $user'
2884     'Subject: F*EX service $hostname'
2885     'X-Mailer: F*EX'
2886     ''
2887   ));
2888   print P @msg;
2889   close P or http_die("cannot send mail - $!\n");
2890   http_header('200 OK');
2891   print html_header($head);
2892   print "<h3>Mail has been sent to you ($from)</h3>\n";
2893   print "</body></html>\n";
2894 }
2895
2896
2897 # lookup akey, skey and gkey (full and sub user and group)
2898 sub check_keys {
2899
2900   if (@to and "@to" ne '_') {
2901     http_die("you cannot mix TO and SKEY URL parameters") if $skey;
2902     http_die("you cannot mix TO and GKEY URL parameters") if $gkey;
2903   }
2904
2905   # only one key can be valid
2906   $akey = $gkey = '' if $skey;
2907   $akey = $skey = '' if $gkey;
2908
2909   if ($skey) {
2910     # encrypted SKEY?
2911     if ($skey =~ s/^MD5H:(.+)/$1/) {
2912       # search real SKEY
2913       foreach my $s (glob "$skeydir/*") {
2914         $s =~ s:.*/::;
2915         if ($skey eq md5_hex($s.$sid)) {
2916           $skey = $s;
2917           last;
2918         }
2919       }
2920     }
2921     if (open $skey,'<',"$skeydir/$skey") {
2922       $akey = $gkey = '';
2923       while (<$skey>) {
2924         if (/^(\w+)=(.+)/) {
2925           $from = $2          if lc($1) eq 'from';
2926           @to = ($muser = $2) if lc($1) eq 'to';
2927           $rid = $id = $2     if lc($1) eq 'id';
2928         }
2929       }
2930       close $skey;
2931     } else {
2932       # $skey = '';
2933       http_die("invalid SKEY <code>$skey</code>");
2934     }
2935   }
2936
2937   if ($gkey) {
2938     # encrypted GKEY?
2939     if ($gkey =~ s/^MD5H:(.+)/$1/) {
2940       # search real GKEY
2941       foreach my $g (glob "$gkeydir/*") {
2942         $g =~ s:.*/::;
2943         if ($gkey eq md5_hex($g.$sid)) {
2944           $gkey = $g;
2945           last;
2946         }
2947       }
2948     }
2949     if (open $gkey,'<',"$gkeydir/$gkey") {
2950       $akey = $skey = '';
2951       while (<$gkey>) {
2952         if (/^(\w+)=(.+)/) {
2953           $from        = $2 if lc($1) eq 'from';
2954           $to = $muser = $2 if lc($1) eq 'to';
2955           $rid = $id   = $2 if lc($1) eq 'id';
2956           # $user      = $2 if lc($1) eq 'user';
2957         }
2958       }
2959       close $gkey;
2960       @to = ($to);
2961     } else {
2962       # $gkey = '';
2963       http_die("invalid GKEY <code>$gkey</code>");
2964     }
2965   }
2966
2967   if ($akey and not $id) {
2968     my $idf;
2969
2970     # sid is not set with web browser
2971     # akey with sid is set with schwuppdiwupp & co
2972     $idf = "$akeydir/$akey/@";
2973
2974     if (open $idf,'<',$idf and $id = getline($idf)) {
2975       close $idf;
2976       $from = readlink "$akeydir/$akey"
2977         or http_die("internal server error: no $akey symlink");
2978       $from =~ s:.*/::;
2979       $from = untaint($from);
2980       if ($akey ne md5_hex("$from:$id")) {
2981         $from = $id = '';
2982       }
2983     } else {
2984       $akey = '';
2985     }
2986   }
2987
2988 }
2989
2990
2991 # check if there is enough space on spool
2992 sub check_space {
2993   my $req = shift;
2994   my ($df,$free,$uprq);
2995   local *P;
2996
2997   if (open $df,"df -k $spooldir|") {
2998     while (<$df>) {
2999       if (/^.+?\s+\d+\s+\d+\s+(\d+)/ and $req/1024 > $1) {
3000         $free = int($1/1024);
3001         $uprq = int($req/$MB);
3002         if (not $nomail and open P,"|$sendmail -t") {
3003           pq(P,qq(
3004             'From: $admin'
3005             'To: $admin'
3006             'Subject: F*EX spool out of space'
3007             ''
3008             'F*EX spool $spooldir on $ENV{SERVER_NAME} is out of space.'
3009             ''
3010             'Current free space: $free MB'
3011             'Upload request: $uprq MB'
3012           ));
3013           close P;
3014         }
3015         debuglog("aborting because not enough free space in spool ($free MB)");
3016         http_die("not enough free space for this upload");
3017       }
3018     }
3019     close $df;
3020   }
3021 }
3022
3023
3024 # global substitution as a function like in gawk
3025 sub gsub {
3026   local $_ = shift;
3027   my ($p,$r) = @_;
3028   s/$p/$r/g;
3029   return $_;
3030 }
3031
3032
3033 # standard log
3034 sub fuplog {
3035   my $msg = "@_";
3036
3037   $msg =~ s/\n/ /g;
3038   $msg =~ s/\s+$//;
3039   $msg = sprintf "%s [%s_%s] %s (%s) %s\n",
3040                  isodate(time),$$,$ENV{REQUESTCOUNT},$from,$fra,$msg;
3041   writelog($log,$msg);
3042 }
3043
3044
3045 sub sigdie {
3046   local $_ = shift;
3047   chomp;
3048   sigexit('DIE',$_);
3049 }
3050
3051
3052 sub sigexit {
3053   my ($sig) = @_;
3054   my $msg;
3055   my $to = join(',',@to);
3056
3057   $SIG{__DIE__} = 'DEFAULT';
3058   foreach (keys %SIG) { $SIG{$_} = 'DEFAULT' }
3059
3060   $msg = @_ ? "@_" : '???';
3061   $msg =~ s/\n/ /g;
3062   $msg =~ s/\s+$//;
3063   $msg = sprintf "%s %s (%s) %s %s caught SIGNAL %s %s\n",
3064                  isodate(time),
3065                  $from||'-',
3066                  $fra||'-',
3067                  $to||'-',
3068                  encode_Q($file||'-'),
3069                  $msg,
3070                  $RB?"(after $RB bytes)":"";
3071
3072   writelog($log,$msg);
3073
3074   if ($sig eq 'DIE') {
3075     shift;
3076     die "$msg\n";
3077   } else {
3078     die "SIGNAL $msg\n";
3079   }
3080 }
3081
3082
3083 sub present_locales {
3084   my $url = shift;
3085   my @locales = @::locales; # from fex.ph
3086   my ($locale,$lang);
3087
3088   if ($url =~ /\?/) {
3089     $url .= "&";
3090     $url =~ s/locale=\w+&//g;
3091   } else {
3092     $url .= "?";
3093   }
3094
3095   if (@locales) {
3096     map { $_ = "$FEXHOME/locale/$_" } @locales;
3097   } else {
3098     @locales = glob "$FEXHOME/locale/*";
3099   }
3100
3101   if (@locales > 1) {
3102     print "<h3>";
3103     foreach my $locale (my @loop = @locales) {
3104       if (-x "$locale/cgi-bin/fup") {
3105         $lang = "$locale/lang.html";
3106         $locale =~ s:.*/::;
3107         if (open $lang,'<',$lang and $lang = getline($lang)) {
3108           close $lang;
3109         } else {
3110           $lang = $locale;
3111         }
3112         print "<a href=\"${url}locale=$locale\">$lang</a> ";
3113       }
3114     }
3115     print "</h3>\n";
3116   }
3117 }
3118
3119
3120 sub check_camel {
3121   my ($logo,$camel);
3122   local $/;
3123
3124   if (open $logo,"$docdir/logo.jpg") {
3125     $camel = md5_hex(<$logo>) eq 'ad8a95bba8dd1a61d70bd38611bc2059';
3126   }
3127   if ($camel and open $logo,"$docdir/action-fex-camel.gif") {
3128     $camel = md5_hex(<$logo>) eq '1f3d7acc70377496f95c5adddaf4ca7b';
3129   }
3130   http_die("Missing camel") unless $camel;
3131 }