]> git.treefish.org Git - fex.git/blob - cgi-bin/fop
fb37261f075b9b62a17c7b9869418f4c5828eebd
[fex.git] / cgi-bin / fop
1 #!/usr/bin/perl -wT
2
3 # F*EX CGI for download
4 #
5 # Author: Ulli Horlacher <framstag@rus.uni-stuttgart.de>
6 #
7
8 BEGIN { ($ENV{PERLINIT}||'') =~ /(.+)/s and eval $1 }
9
10 use Fcntl               qw':flock :seek';
11 use Cwd                 qw'abs_path';
12 use File::Basename;
13 use IO::Handle;
14 use Encode;
15
16 # add fex lib
17 ($FEXLIB) = $ENV{FEXLIB} =~ /(.+)/;
18 die "$0: no $FEXLIB\n" unless -d $FEXLIB;
19
20 our $error = 'F*EX download ERROR';
21 our $head = "$ENV{SERVER_NAME} F*EX download";
22 # import from fex.pp
23 our ($spooldir,$tmpdir,@logdir,$skeydir,$dkeydir,$durl);
24 our ($bs,$fop_auth,$timeout,$keep_default,$nowarning);
25 our ($limited_download,$admin,$akey,$adlm,$amdl);
26 our (@file_link_dirs);
27
28 # load common code, local config : $HOME/lib/fex.ph
29 require "$FEXLIB/fex.pp" or die "$0: cannot load $FEXLIB/fex.pp - $!\n";
30
31 my $ra = $ENV{REMOTE_ADDR}||0;
32 if (@download_hosts and not ipin($ra,@download_hosts)) {
33   http_die(
34     "Downloads from your host ($ra) are not allowed.",
35     "Contact $ENV{SERVER_ADMIN} for details."
36   );
37 }
38
39 &check_maint;
40
41 # call localized fop if available
42 if ($0 !~ m{/locale/.*/fop} and my $lang = $ENV{HTTP_ACCEPT_LANGUAGE}) {
43   if ($lang =~ /^de/ and $0 =~ m{(.*)/cgi-bin/fop}) {
44     my $fop = "$1/locale/deutsch/cgi-bin/fop";
45     exec $fop if -x $fop;
46   }
47 }
48
49 my $log = 'fop.log';
50
51 chdir $spooldir or die "$spooldir - $!\n";
52
53 my $http_client = $ENV{HTTP_USER_AGENT} || '';
54
55 $file = $ENV{PATH_INFO} || '';
56 http_die('no file name') unless $file;
57 $file =~ s:%3F:/?/:g; # escape '?' for URL-decoding
58 $file =~ s/%([\dA-F]{2})/unpack("a",pack("H2",$1))/ge;
59 $file =~ s:/\?/:%3F:g; # deescape '?'
60 $file =~ s:/\.\.:/__:g;
61 $file =~ s:^/+::;
62 $file = untaint($file);
63
64 # secure mode with HTTP authorization?
65 if ($fop_auth) {
66   @http_auth = ();
67   if ($ENV{HTTP_AUTHORIZATION} and $ENV{HTTP_AUTHORIZATION} =~ /Basic\s+(.+)/) {
68     @http_auth = split(':',decode_b64($1));
69   }
70   if (@http_auth != 2) {
71     &require_auth;
72   }
73   &check_auth($file,@http_auth);
74 }
75
76 # download-URL-scheme /$dkey/$file ?
77 if ($file =~ m:^([^/]+)/[^/]+$:) {
78   $dkey = $1;
79   if ($link = readlink("$dkeydir/$dkey")) {
80     if ($link !~ s:^\.\./::) {
81       http_die("internal error on dkey for $link");
82     }
83     $file = untaint($link);
84   } else {
85     http_die("no such file $file");
86   }
87 } else {
88   # download-URL-scheme /$to/$from/$file
89   $file =~ s/\?.*//;
90
91   if ($ENV{REQUEST_METHOD} eq 'GET' and $file =~ m:.+/(.+)/.+:) {
92     $from = lc $1;
93     if (-s "$from/\@ALLOWED_RECIPIENTS") {
94       http_die("$from is a restricted user");
95     }
96   }
97
98   # add mail-domain to addresses if necessary
99   if ($mdomain and $file =~ s:(.+)/(.+)/(.+):$3:) {
100     $to   = lc $1;
101     $from = lc $2;
102     $to   .= '@'.$hostname if $to   eq 'anonymous';
103     $from .= '@'.$hostname if $from eq 'anonymous';
104     $to   .= '@'.$mdomain if -d "$to\@$mdomain";
105     $from .= '@'.$mdomain if -d "$from\@$mdomain";
106     if ($ENV{REQUEST_METHOD} eq 'GET' and -s "$from/\@ALLOWED_RECIPIENTS") {
107       http_die("$from is a restricted user");
108     }
109     $file = "$to/$from/$file";
110   }
111 }
112
113 if ($file and $file =~ m:(.+)/(.+)/.+:) {
114   $to   = $1;
115   $from = $2;
116   # afex!
117   if ($from =~ s/^(anonymous).*/$1/) {
118     if (@anonymous_upload and ipin($ra,@anonymous_upload) or $dkey) {
119       $anonymous = $from;
120     } else {
121       http_header('403 Forbidden');
122       print html_header($head),
123         "You have no permission to request the URI $ENV{REQUEST_URI}\n",
124         "</body></html>\n";
125       exit;
126     }
127   }
128 } else {
129   http_die("unknown query format");
130 }
131
132 $data = "$file/data";
133
134 # open $file,$file; print Digest::MD5->new->addfile($file)->hexdigest;
135
136 # request with ?query-parameter ?
137 if ($qs = $ENV{QUERY_STRING}) {
138
139   http_die("\"$1\" is not allowed in URL") if $qs =~ /([<>\%\'\"])/;
140
141   # workaround for broken F*IX
142   $qs =~ s/&ID=skey:\w+//;
143
144   # subuser with skey?
145   if ($qs =~ s/&*SKEY=([\w:]+)//i) {
146     $skey = $1;
147     # encrypted skey?
148     if ($skey =~ s/^MD5H:(.+)/$1/) {
149       # lookup real skey
150       foreach my $s (glob "$skeydir/*") {
151         $s =~ s:.*/::;
152         if ($skey eq md5_hex($s.$ENV{SID})) {
153           $skey = $s;
154           last;
155         }
156       }
157     }
158     if (open $skey,'<',"$skeydir/$skey") {
159       $from = $to = '';
160       while (<$skey>) {
161         $from = lc($1) if /^from=(.+)/;
162         $to   = lc($1) if /^to=(.+)/;
163       }
164       close $skey;
165       if ($from and $to) {
166         $file =~ s:.*/:$to/$from/:;
167       } else {
168         http_die("INTERNAL ERROR: missing data in $skeydir/$skey");
169       }
170     } else {
171       debuglog("SKEY=$skey");
172       http_die("wrong SKEY authentification");
173     }
174   }
175
176   # group member with gkey?
177   if ($qs =~ s/&*GKEY=([\w:]+)//i) {
178     $gkey = $1;
179     # encrypted gkey?
180     if ($gkey =~ s/^MD5H:(.+)/$1/) {
181       # lookup real gkey
182       foreach my $g (glob "$gkeydir/*") {
183         $g =~ s:.*/::;
184         if ($gkey eq md5_hex($g.$ENV{SID})) {
185           $gkey = $g;
186           last;
187         }
188       }
189     }
190     if (open $gkey,'<',"$gkeydir/$gkey") {
191       $from = $to = '';
192       while (<$gkey>) {
193         $from  = lc($1) if /^from=(.+)/;
194         $group = lc($1) if /^to=\@(.+)/;
195       }
196       close $gkey;
197       if ($from and $group and open $group,'<',"$from/\@GROUP/$group") {
198         while (<$group>) {
199           s/#.*//;
200           s/\s//g;
201           if (/(.+):/) {
202             my $to = $1;
203             $file =~ s:.*/:$to/$from/:;
204             last;
205           }
206         }
207         close $group;
208       } else {
209         http_die("INTERNAL ERROR: missing data in $gkeydir/$gkey");
210       }
211     } else {
212       debuglog("GKEY=$gkey");
213       http_die("wrong GKEY authentification");
214     }
215   }
216
217   # check for ID in query
218   elsif ($qs =~ s/\&*\bID=([^&]+)//i) {
219     $id = $1;
220     $fop_auth = 0;
221
222     if ($id eq 'PUBLIC') {
223       http_header('403 Forbidden');
224       exit;
225     }
226
227     if ($file =~ m:^(.+)/(.+)/(.+):) {
228       $to   = $1;
229       $from = $2;
230       $to   =~ s/,+/,/g;
231       $to   =~ s/\s//g;
232       $from =~ s/\s//g;
233       if ($mdomain and $from ne 'anonymous') {
234         $to   .= '@'.$mdomain if $to   !~ /@/;
235         $from .= '@'.$mdomain if $from !~ /@/;
236       }
237       $to   = lc $to;
238       $from = lc $from;
239     } else {
240       http_die("unknown file query format");
241     }
242
243     # public or anonymous recipient? (needs no auth-ID for sender)
244     if ($anonymous or $id eq 'PUBLIC' and
245         @public_recipients and grep /^\Q$to\E$/i,@public_recipients) {
246       $rid = $id;
247     } else {
248       open my $idf,'<',"$from/@" or http_die("unknown user $from");
249       $rid = getline($idf);
250       close $idf;
251       $rid = sidhash($rid,$id);
252     }
253
254     unless ($id eq $rid) {
255       debuglog("real id=$rid, id sent by user=$id");
256       http_die("wrong auth-ID");
257     }
258
259     # set akey link for HTTP sessions
260     # (need original id for consistant non-moving akey)
261     if (-d $akeydir and open $idf,'<',"$from/@" and my $id = getline($idf)) {
262       $akey = untaint(md5_hex("$from:$id"));
263       unlink "$akeydir/$akey";
264       symlink "../$from","$akeydir/$akey";
265     }
266
267     my %to;
268     COLLECTTO: foreach my $to (split(',',$to)) {
269       if ($to !~ /.@./ and open my $AB,'<',"$from/\@ADDRESS_BOOK") {
270         while (<$AB>) {
271           s/\s*#.*//;
272           s/^\s+//;
273           next unless $_;
274           if (/^\s*([\S]+)\s+([\S]+)/) {
275             my ($alias,$address) = ($1,$2);
276             if ($to =~ /^\Q$alias\E$/i) {
277               foreach my $to (split(",",$address)) {
278                 $to .= '@'.$mdomain if $mdomain and $to !~ /@/;
279                 $to{$to} = lc $to; # ignore dupes
280               }
281               next COLLECTTO;
282             }
283           }
284         }
285       } elsif ($to =~ /^\@(.+)/) {
286         my $group = "$from/\@GROUP/$1";
287         if (not -l $group and open $group) {
288           while (<$group>) {
289             s/#.*//;
290             s/\s//g;
291             if (/(.+\@[w.-]+):.+/) {
292               $to{$1} = lc $1; # ignore dupes
293             }
294           }
295           close $group;
296         }
297       } else {
298         $to .= '@'.$mdomain if $mdomain and $to !~ /.@./;
299         $to{$to} = lc $to; # ignore dupes
300       }
301     }
302     foreach $to (keys %to) {
303       # if (-e "$to/\@CAPTIVE") { http_die("$to is CAPTIVE") }
304       unless (-d $to or checkaddress($to)) {
305         http_die("$to is not a legal e-mail address");
306       }
307     }
308
309   }
310
311   if ($qs =~ /\&?KEEP=(\d+)/i) {
312     $keep = $1;
313     $filename = filename($file);
314     check_captive($file);
315     if  (-f $data) {
316       unlink "$file/keep";
317       if (symlink $keep,"$file/keep") {
318         http_header('200 OK');
319         print html_header($head),
320               "<h3>set keep=$keep for $filename</h3>\n",
321               "</body></html>\n";
322       } else {
323         http_header('599 internal error');
324         print html_header($head),
325               "<h3>$filename - $!</h3>\n",
326               "</body></html>\n";
327       }
328     } else {
329       http_header('404 File not found');
330       print html_header($head),
331             "<h3>$filename not found</h3>\n",
332             "</body></html>\n";
333     }
334     exit;
335   } elsif ($qs =~ s/\&?KEEP//i) {
336     check_captive($file);
337     $autodelete = 'NO';
338   }
339
340   if ($qs =~ s/\&?FILEID=(\w+)//i) { $fileid = $1 }
341
342   if ($qs =~ s/\&?IGNOREWARNING//i) { $ignorewarning = 1 }
343
344   if ($qs eq 'LIST') {
345     http_header('200 OK','Content-Type: text/plain');
346     print "$file :\n";
347     chdir $file and exec '/client/bin/l';
348     exit;
349   }
350
351   # copy file to yourself
352   if ($qs eq 'COPY') {
353     unless (-f "$file/data") {
354       http_die("File not found.");
355     }
356     ($to,$from,$file) = split('/',$file);
357     unless ("$to/@") {
358       # http_header('403 Forbidden');
359       # print html_header($head),
360       #  "You have no permission to copy a file.\n",
361       #  "</body></html>\n";
362       http_die("You have no permission to copy a file.");
363     }
364     if (-s "$to/\@ALLOWED_RECIPIENTS") {
365       http_die("You are a restricted user.");
366     }
367     if (-e "$to/$to/$file/data") {
368       # http_header('409 File Exists');
369       # print html_header($head),
370       #   "File $file already exists in your outgoing spool.\n",
371       #   "</body></html>\n";
372       http_die("File $file already exists in your outgoing spool.");
373     }
374     mkdirp("$to/$to/$file");
375     link "$to/$from/$file/data","$to/$to/$file/data"
376       or http_die("cannot link to $to/$to/$file/data - $!\n");
377     my $fkey = copy("$to/$from/$file/filename","$to/$to/$file/filename");
378     open my $notify,'>',"$to/$to/$file/notify";
379     close $notify;
380     my $dkey = randstring(8);
381     unlink "$to/$to/$file/dkey","$dkeydir/$dkey";
382     symlink "../$to/$to/$file","$dkeydir/$dkey";
383     symlink $dkey,"$to/$to/$file/dkey";
384     http_header('200 OK',"Location: $durl/$dkey/$fkey");
385     print html_header($head),
386       "File $file copied to yourself.\n",
387       "</body></html>\n";
388     exit;
389   }
390
391   # ex and hopp?
392   if ($qs =~ s/(^|&)DELETE//i) {
393     if (unlink $data) {
394       $filename = filename($file);
395       if (open my $log,'>',"$file/error") {
396         printf {$log} "%s has been deleted by %s at %s\n",
397                       $filename,$ENV{REMOTE_ADDR},isodate(time);
398         close $log;
399       }
400       foreach my $logdir (@logdir) {
401         my $msg = sprintf "%s [%s_%s] %s %s deleted\n",
402                   isodate(time),$$,$ENV{REQUESTCOUNT},$ra,encode_Q($file);
403         if (open $log,'>>',"$logdir/$log") {
404           print {$log} $msg;
405           close $log;
406         }
407       }
408       http_header('200 OK',"X-File: $file");
409       print html_header($head),
410             "<h3>$filename deleted</h3>\n",
411             "</body></html>\n";
412       exit;
413     } else {
414       http_die("no such file");
415     }
416     exit;
417   }
418
419   # wipe out!? (for anonymous upload)
420   if ($qs =~ s/(^|&)PURGE//i) {
421     $filename = filename($file);
422     if (@anonymous_upload and ipin($ra,@anonymous_upload)) {
423       unlink "$dkeydir/$dkey" if $dkey;
424       if (rmrf($file)) {
425         foreach my $logdir (@logdir) {
426           my $msg = sprintf "%s [%s_%s] %s %s purged\n",
427                     isodate(time),$$,$ENV{REQUESTCOUNT},$ra,encode_Q($file);
428           if (open $log,'>>',"$logdir/$log") {
429             print {$log} $msg;
430             close $log;
431           }
432         }
433         http_header('200 OK',"X-File: $file");
434         print html_header($head),
435           "<h3>$filename purged</h3>\n",
436           "</body></html>\n";
437       } else {
438         http_die("no such file");
439       }
440     } else {
441       http_die("you are not allowed to purge $filename");
442     }
443     exit;
444   }
445
446   # request for file size?
447   if ($qs eq '?') {
448     sendsize($file);
449     # control back to fexsrv for further HTTP handling
450     &reexec;
451   }
452
453   # fallback
454   if ($qs) {
455     http_die("unknown query format $qs");
456   }
457
458 }
459
460 unless ($id and $rid and $id eq $rid or $dkey or $anonymous) {
461   http_die("wrong parameter $file");
462 }
463
464 unless ($to) {
465   http_die("internal error: unknown recipient");
466 }
467
468 unless ($from) {
469   http_die("internal error: unknown sender");
470 }
471
472 &check_status($from);
473
474 # server based ip restrictions
475 if (@download_hosts and not ipin($ra,@download_hosts)) {
476   http_die(
477     "Downloads from your host ($ra) are not allowed.",
478     "Contact $ENV{SERVER_ADMIN} for details."
479   );
480 }
481
482 # user based ip restrictions
483 unless (check_rhosts("$to/\@DOWNLOAD_HOSTS")) {
484   http_die("You are not allowed to download from IP $ra");
485 }
486
487 # file based ip restrictions
488 unless (check_rhosts("$file/restrictions")) {
489   http_die("Download of files from external user $from is restricted "
490           ."to internal hosts. Your IP $ra is not allowed.");
491 }
492
493 # set time mark for this access
494 if ($file =~ m:(.+?)/:) {
495   my $user = $1;
496   my $time = untaint(time);
497   utime $time,$time,$user;
498 }
499
500 # reget or range?
501 if ($range = $ENV{HTTP_RANGE}) {
502   $seek = $1 if $range =~ /^bytes=(\d+)-/i;
503   $stop = $1 if $range =~ /^bytes=\d*-(\d+)/i;
504 } else {
505   $seek = 0;
506   $stop = 0;
507 }
508
509 if (not $autodelete or $autodelete ne 'NO') {
510   $autodelete = readlink "$file/autodelete" || 'YES';
511 }
512
513 if ($from and $file eq "$from/$from/ADDRESS_BOOK") {
514   if (open my $AB,'<',"$from/\@ADDRESS_BOOK") {
515     my $ab = '';
516     while (<$AB>) {
517       s/^\s+//;
518       s/\s+$//;
519       s/[\r\n]//g;
520       $ab .= $_."\r\n";
521     }
522     close $AB;
523     nvt_print(
524       'HTTP/1.1 200 OK',
525       'Content-Length: ' . length($ab),
526       'Content-Type: text/plain',
527       ''
528     );
529     print $ab;
530   } else {
531     nvt_print(
532       'HTTP/1.1 404 No address book found',
533       'Content-Length: 0',
534       ''
535     );
536   }
537   # control back to fexsrv for further HTTP handling
538   &reexec;
539 }
540
541 if (-f $data) {
542   # already downloaded?
543   if ($limited_download and $limited_download !~ /^n/i
544       and $from ne $to                    # fex to yourself is ok!
545       and $from !~ /^_?fexmail/           # fexmail is ok!
546       and $to !~ /^_?fexmail/             # fexmail is ok!
547       and $to !~ /^anonymous/             # anonymous fex is ok!
548       and $to !~ /$amdl/                  # allowed multi download recipients
549       and $http_client !~ /$adlm/         # allowed download managers
550       and $file !~ /\/STDFEX$/            # xx is ok!
551       and (slurp("$file/comment")||'') !~ /^!\*!/ # multi download allow flag
552       and not($dkey and ($ENV{HTTP_COOKIE}||'') =~ /dkey=$dkey/)
553       and open $file,'<',"$file/download")
554   {
555     $_ = <$file> || '';
556     close $file;
557     chomp;
558     if ($ra) {
559       # allow downloads from same ip
560       $_ = '' if /\Q$ra/;
561       # allow downloads from sender ip
562       $_ = '' if (readlink("$file/ip")||'') eq $ra;
563     }
564     if ($_) {
565       s/(.+) ([\w.:]+)$/by $2 at $1/;
566       $file = filename($file);
567       http_die("$file has already been downloaded $_");
568     }
569   }
570   $sb = sendfile($file,$seek,$stop);
571   shutdown(STDOUT,2);
572 } elsif (-l $data) {
573   # $file =~ s:.*/::;
574   http_die("<code>$file</code> has been withdrawn");
575 } elsif (open $errf,'<',"$file/error" and $err = getline($errf)) {
576   fdlog($log,$file,0,0);
577   http_die($err);
578 } else {
579   fdlog($log,$file,0,0);
580   if ($file =~ /^anonymous.*afex_\d+\.tar$/) {
581     # should be extra handled...
582   }
583   http_die("no such file $file");
584 }
585
586 debuglog(sprintf("%s %s %d %d %d",
587          isodate(time),$file,$sb||0,$seek,-s $data||0));
588
589 if ($sb+$seek == -s $data) {
590
591   # note successfull download
592   $download = "$file/download";
593   if (open $download,'>>',$download) {
594     printf {$download} "%s %s\n",isodate(time),$ENV{REMOTE_ADDR};
595     close $download;
596   }
597
598   # delete file after grace period
599   if ($autodelete eq 'YES') {
600     $grace_time = 60 unless defined $grace_time;
601     for (;;) {
602       my $utime = (stat $data)[8] || 0;
603       my $dtime = (stat $download)[8] || 0;
604       exit if $utime > $dtime;
605       last if time > $dtime+$grace_time;
606       sleep 10;
607     }
608     unlink $data;
609     my $error = "$file/error";
610     if (open $error,'>',$error) {
611       printf {$error} "%s has been autodeleted after download from %s at %s\n",
612                       filename($file),$ENV{REMOTE_ADDR},isodate(time);
613       close $error;
614     }
615   }
616
617 }
618
619 exit;
620
621
622 sub sendfile {
623   my ($file,$seek,$stop) = @_;
624   my ($filename,$size,$total_size,$fileid,$filetype);
625   my ($data,$download,$header,$buf,$range,$s,$b,$t0);
626   my $type = '';
627
628   # swap to and from for special senders, see fup storage swap!
629   $file =~ s:^(_?anonymous_.*)/(anonymous.*)/:$2/$1/:;
630   $file =~ s:^(_?fexmail_.*)/(fexmail.*)/:$2/$1/:;
631
632   $data     = $file.'/data';
633   $download = $file.'/download';
634   $header   = $file.'/header';
635
636   # fallback defaults, should be set later with better values
637   $filename = filename($file);
638   $total_size = -s $data || 0;
639
640   # file link?
641   if (-l $data) {
642     unless (-f $data and -r $data) {
643       http_die("<code>$file</code> has been withdrawn");
644     }
645     $data = abs_path($data);
646     my $fok;
647     foreach (@file_link_dirs) {
648       my $dir = abs_path($_);
649       $fok = $data if $data =~ /^\Q$dir\//;
650     }
651     unless ($fok) {
652       http_die("no permission to download <code>$file</code>");
653     }
654   } else {
655     unless (-f $data and -r $data) {
656       http_die("<code>$file</code> has gone");
657     }
658   }
659
660   if ($ENV{REQUEST_METHOD} eq 'GET') {
661     debuglog("Exp: FROM=\"$from\"","Exp: TO=\"$to\"");
662     open $data,$data and flock($data,LOCK_EX|LOCK_NB);
663     # security check: must be regular file after abs_path()
664     if (-l $data) {
665       http_die("no permission to download <code>$file</code>");
666     }
667     # HTTP Range download suckers are already rejected by fexsrv
668     unless ($range = $ENV{HTTP_RANGE}) {
669       # download lock
670       open $download,'>>',$download or die "$download - $!\n";
671       if ($file =~ m:(.+?)/(.+?)/: and $1 ne $2) {
672         # only one concurrent download is allowed if sender <> recipient
673         flock($download,LOCK_EX|LOCK_NB) or
674           http_die("$file locked: a download is already in progress");
675       }
676     }
677     $size = $total_size - $seek - ($stop ? $total_size-$stop-1 : 0);
678   } elsif ($ENV{REQUEST_METHOD} eq 'HEAD') {
679     $size = -s $data || 0;
680   } else {
681     http_die("unknown HTTP request method $ENV{REQUEST_METHOD}");
682   }
683
684   # read MIME entity header (what the client said)
685   if (open $header,'<',$header) {
686     while (<$header>) {
687       if (/^Content-Type: (.+)/i) {
688         $type = $1;
689         last;
690       }
691     }
692     close $header;
693     $type =~ s/\s//g;
694   }
695
696   $fileid = readlink "$file/id" || '';
697
698   # determine own MIME entity header for download
699   my $mime = $file;
700   $mime =~ s:/.*:/\@MIME:;
701   my $mt = $ENV{FEXHOME}.'/etc/mime.types';
702   if (($type =~ /x-mime/i or -e $mime) and open $mt,'<',$mt) {
703     $type = 'application/octet-stream';
704     MIMETYPES: while (<$mt>) {
705       chomp;
706       s/#.*//;
707       s/^\s+//;
708       my ($mt,@ft) = split;
709       foreach my $ft (@ft) {
710         if ($filename =~ /\.\Q$ft\E$/i) {
711           $type = $mt;
712           last MIMETYPES;
713         }
714       }
715     }
716     close $mt;
717   }
718   # reset to default MIME type
719   else { $type = 'application/octet-stream' }
720
721   # HTML is not allowed for security reasons! (embedded javascript, etc)
722   $type =~ s/html/plain/i;
723
724   debuglog("download with $http_client");
725
726   if ($seek or $stop) {
727     if ($size < 0) {
728       http_header('416 Requested Range Not Satisfiable');
729       exit;
730     }
731     if ($stop) {
732       $range = sprintf("bytes %s-%s/%s",$seek,$stop,$total_size);
733     } else {
734       $range = sprintf("bytes %s-%s/%s",$seek,$total_size-1,$total_size);
735     }
736     nvt_print(
737       'HTTP/1.1 206 Partial Content',
738       "Content-Length: $size",
739       "Content-Range: $range",
740       "Content-Type: $type",
741     );
742     if ($http_client !~ /MSIE/) {
743       nvt_print("Cache-Control: no-cache");
744       if ($type eq 'application/octet-stream') {
745         nvt_print("Content-Disposition: attachment; filename=\"$filename\"");
746       }
747     }
748     nvt_print('');
749   } else {
750     # another stupid IE bug-workaround
751     # http://drupal.org/node/163445
752     # http://support.microsoft.com/kb/323308
753     if ($http_client =~ /MSIE/ and not $nowarning) {
754       # $type = 'application/x-msdownload';
755       if ($ignorewarning) {
756         $type .= "; filename=$filename";
757         nvt_print(
758           'HTTP/1.1 200 OK',
759           "Content-Length: $size",
760           "Content-Type: $type",
761 #         "Pragma: no-cache",
762 #         "Cache-Control: no-store",
763           "Content-Disposition: attachment; filename=\"$filename\"",
764           "Connection: close",
765         );
766 #        nvt_print('','HTTP/1.1 200 OK',"Content-Length: $size","Content-Type: $type"); exit;
767       } else {
768         http_header('200 OK');
769         print html_header($head);
770         pq(qq(
771           '<h2>Internet Explorer warning</h2>'
772           'Using Microsoft Internet Explorer for download will probably'
773           'lead to problems, because it is not Internet compatible (RFC 2616).'
774           '<p>'
775           'We recommend <a href="http://firefox.com">Firefox</a>'
776           '<p>'
777           'If you really want to continue with Internet Explorer, then'
778           '<a href="$ENV{REQUEST_URL}?IGNOREWARNING">'
779           'click here with your right mouse button and select "save as"'
780           '</a>'
781           '<p>'
782           'See also <a href="/FAQ/user.html">F*EX user FAQ</a>.'
783           '</body></html>'
784         ));
785         &reexec;
786       }
787     } else {
788       nvt_print(
789         'HTTP/1.1 200 OK',
790         "Content-Length: $size",
791         "Content-Type: $type",
792         "Cache-Control: no-cache",
793         "Connection: close",
794       );
795       if ($type eq 'application/octet-stream') {
796         nvt_print(qq'Content-Disposition: attachment; filename="$filename"');
797       }
798     }
799
800     nvt_print("X-Size: $total_size");
801     nvt_print("X-File-ID: $fileid") if $fileid;
802     # if ((`file "$file/data" 2>/dev/null` || '') =~ m{.*/data:\s(.+)}) {
803     #  nvt_print("X-File-Type: $1");
804     # }
805     if ($dkey = $dkey||readlink "$file/dkey") {
806       my $ma = (readlink "$file/keep"||$keep_default)*60*60*24;
807       nvt_print("Set-Cookie: dkey=$dkey; Max-Age=$ma; Path=$ENV{REQUEST_URI}");
808     }
809     nvt_print('');
810   }
811
812   if ($ENV{REQUEST_METHOD} eq 'HEAD') {
813     # control back to fexsrv for further HTTP handling
814     &reexec;
815   }
816
817   if ($ENV{REQUEST_METHOD} eq 'GET') {
818
819     if (@throttle) {
820       my $to = $file;
821       $to =~ s:/.*::;
822       foreach (@throttle) {
823         if (/(.+):(\d+)$/) {
824           my $throttle = $1;
825           my $limit = $2;
826           # throttle ip address?
827           if ($throttle =~ /^[\d.-]+$/) {
828             if (ipin($ra,$throttle)) {
829               $bwl = $limit;
830               last;
831             }
832           }
833           # throttle e-mail address?
834           else {
835             # allow wildcard *, but not regexps
836             $throttle =~ quotemeta $throttle;
837             $throttle =~ s/\*/.*/g;
838             if ($to =~ /$throttle$/) {
839               $bwl = $limit;
840               last;
841             }
842           }
843         }
844       }
845     }
846
847     foreach my $sig (keys %SIG) { local $SIG{$sig} = \&sigexit }
848     local $SIG{ALRM} = sub { die "TIMEOUT\n" };
849
850     seek $data,$seek,0;
851
852     $t0 = time;
853     $s = $b = 0;
854
855     # sysread/syswrite because of speed
856     while ($s < $size and $b = sysread($data,$buf,$bs)) {
857       # last chunk for HTTP Range?
858       if ($stop and $s+$b > $size) {
859         $b = $size-$s;
860         $buf = substr($buf,0,$b)
861       }
862       $s += $b;
863       alarm($timeout*10);
864       syswrite STDOUT,$buf or last; # client still alive?
865       if ($bwl) {
866         alarm(0);
867         sleep 1 while $s/(time-$t0||1)/1024 > $bwl;
868       }
869     }
870
871     close $data;
872     alarm(0);
873
874     fdlog($log,$file,$s,$size);
875   }
876   close $download;
877
878   return $s;
879 }
880
881
882 sub sendsize {
883   my ($path) = @_;
884   my ($file,$upload,$to,$from,$dkey);
885   my $size = 0;
886   local $_;
887
888   $path =~ s:^/::;
889   ($to,$from,$file) = split('/',$path);
890   $to =~ s/,.*//;
891   $to   = lc $to;
892   $from = lc $from;
893
894   # swap to and from for special senders, see fup storage swap!
895   ($from,$to) = ($to,$from) if $from =~ /^(fexmail|anonymous)/;
896
897   $to   .= '@'.$hostname if $to   eq 'anonymous';
898   $from .= '@'.$hostname if $from eq 'anonymous';
899
900   $to   .= '@'.$mdomain if -d "$to\@$mdomain";
901   $from .= '@'.$mdomain if -d "$from\@$mdomain";
902
903   $file =~ s/%([A-F0-9]{2})/chr(hex($1))/ge;
904   $file = urlencode($file);
905
906   if ($to eq '*' and $fileid) {
907     foreach my $fd (glob "*/$from/$file") {
908       if (-f "$fd/data"
909           and -l "$fd/id" and readlink "$fd/id" eq $fileid
910           and $dkey = readlink "$fd/dkey") {
911         $to = $fd;
912         $to =~ s:/.*::;
913         last;
914       }
915     }
916   } elsif ($to !~ /@/ and open my $AB,'<',"$from/\@ADDRESS_BOOK") {
917     while (<$AB>) {
918       s/\s*#.*//;
919       $_ = lc $_;
920       my ($alias,$address) = split;
921       if ($address) {
922         $address =~ s/,.*//;
923         $address .= '@'.$mdomain if $mdomain and $address !~ /@/;
924         if ($to eq $alias) {
925           $to = $address;
926           last;
927         }
928       }
929     }
930     close $AB;
931   }
932
933   if (-f "$to/$from/$file/data") {
934     $dkey = readlink "$to/$from/$file/dkey";
935     $fkey = slurp("$to/$from/$file/filename")||$file;
936   }
937
938   $upload = -s "$to/$from/$file/upload" || -s "$to/$from/$file/data" || 0;
939   $size = readlink "$to/$from/$file/size" || 0;
940   $fileid = readlink "$to/$from/$file/id" || '';
941
942   nvt_print('HTTP/1.1 200 OK');
943   nvt_print("Server: fexsrv");
944   nvt_print("Content-Length: $upload");
945   nvt_print("X-Original-Recipient: $to");
946   if ($dkey and not -s "$from/\@ALLOWED_RECIPIENTS") {
947     nvt_print("X-DKEY: $dkey");
948     nvt_print("X-Location: $durl/$dkey/$fkey") if $fkey;
949   }
950   nvt_print("X-Size: $size");
951   nvt_print("X-File-ID: $fileid") if $fileid;
952   nvt_print("X-Features: $ENV{FEATURES}");
953   nvt_print('');
954 }
955
956
957 sub check_rhosts {
958   my $ipr = shift;
959   my @hosts;
960   local $_;
961
962   if (open $ipr,$ipr) {
963     while (<$ipr>) {
964       chomp;
965       s/#.*//;
966       s/\s//g;
967       if ($_ eq '@LOCAL_RHOSTS') {
968         push @hosts,@local_rhosts if @local_rhosts;
969       } elsif (/\w/) {
970         push @hosts,$_;
971       }
972     }
973     close $ipr;
974     if (@hosts and not ipin($ra,@hosts)) {
975       return 0;
976     }
977   }
978   return 1;
979 }
980
981
982 sub require_auth {
983   http_header(
984     '401 Authorization Required',
985     'WWW-Authenticate: Basic realm="'.$ENV{SERVER_NAME}.' F*EX download"',
986     'Content-Length: 0',
987   );
988   # control back to fexsrv for further HTTP handling
989   &reexec;
990 }
991
992
993 sub check_auth {
994   my ($path,$user,$auth) = @_;
995   my ($to,$from,$file,$dkey);
996   my ($id,$idf);
997   my ($subuser,$subid);
998   my $auth_ok = 0;
999   local $_;
1000
1001   if ($path =~ m:(.+)/(.+)/(.+):) {
1002     ($to,$from,$file) = ($1,$2,$3);
1003   } elsif ($path =~ m:(.+)/(.+):) {
1004     ($dkey,$file) = ($1,$2);
1005     $path = readlink "$dkeydir/$dkey" or http_die('no such file');
1006     (undef,$to,$from,$file) = split('/',$path);
1007   } else {
1008     http_die("wrong URL format for download");
1009   }
1010
1011   $to   .= '@'.$mdomain if $mdomain and $to   !~ /@/;
1012   $from .= '@'.$mdomain if $mdomain and $from !~ /@/;
1013
1014   $to   = lc $to;
1015   $from = lc $from;
1016
1017   # auth user match to in download URL?
1018   if ($to ne $user and "$to\@$mdomain" ne $user and $to ne "$user@$mdomain") {
1019     debuglog("mismatch: to=$to, auth user=$user");
1020     &require_auth;
1021   }
1022
1023   # check for real user
1024   if (open $idf,'<',"$to/@") {
1025     $id = getline($idf);
1026     close $idf;
1027     unless ($id and $id eq $auth) {
1028       debuglog("$user mismatch: id=$id, auth=$auth");
1029       &require_auth;
1030     }
1031   }
1032   # check for sub user
1033   elsif (open $idf,'<',"$from/\@SUBUSER") {
1034     while (<$idf>) {
1035       chomp;
1036       s/#.*//;
1037       ($subuser,$subid) = split ':';
1038       if ($subid and $subid eq $auth
1039           and ($user eq $subuser
1040                or $subuser eq '*@*'
1041                or $subuser =~ /^\*\@(.+)/ and $user =~ /\@\Q$1\E$/i
1042                or $subuser =~ /(.+)\@\*$/ and $user =~ /^\Q$1\E\@/i)) {
1043         $auth_ok = 1;
1044         last;
1045       }
1046     }
1047     close $idf;
1048     unless ($auth_ok) {
1049       debuglog("no matching $user in $from/\@SUBUSER");
1050       &require_auth;
1051     }
1052   } else {
1053     debuglog("no $to/@ and no $from/@");
1054     &require_auth;
1055   }
1056
1057 }
1058
1059
1060 sub check_captive {
1061   my $to = shift;
1062   $to =~ s:/.*::;
1063   $to .= '@'.$mdomain if $mdomain and -d "$to\@$mdomain";
1064   if (-e "$to/\@CAPTIVE") {
1065     http_die("$to is CAPTIVE - no URL parameters allowed");
1066   }
1067 }
1068
1069
1070 sub sigexit {
1071   my ($sig) = @_;
1072   my $msg;
1073
1074   $msg = @_ ? "@_" : '???';
1075   $msg =~ s/\n/ /g;
1076   $msg =~ s/\s+$//;
1077
1078   errorlog("$file caught SIGNAL $msg");
1079
1080   # sigpipe means: client has terminated
1081   # this event will be handled further by sendfile(), do not terminate here
1082   if ($sig ne 'PIPE') {
1083     $SIG{__DIE__} = '';
1084     if ($sig eq 'DIE') {
1085       shift;
1086       die "$msg\n";
1087     } else {
1088       die "SIGNAL $msg\n";
1089     }
1090   }
1091 }