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