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 use CGI                 qw':standard';
   9 use CGI::Carp           qw'fatalsToBrowser';
  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);
  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 = "$logdir/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       if (open $log,'>>',$log) {
 401         printf {$log}
 402                "%s [%s_%s] %s %s deleted\n",
 403                isodate(time),$$,$ENV{REQUESTCOUNT},$ra,encode_Q($file);
 404         close $log;
 405       }
 406       http_header('200 OK',"X-File: $file");
 407       print html_header($head),
 408             "<h3>$filename deleted</h3>\n",
 409             "</body></html>\n";
 410       exit;
 411     } else {
 412       http_die("no such file");
 413     }
 414     exit;
 415   }
 416
 417   # wipe out!? (for anonymous upload)
 418   if ($qs =~ s/(^|&)PURGE//i) {
 419     $filename = filename($file);
 420     if (@anonymous_upload and ipin($ra,@anonymous_upload)) {
 421       unlink "$dkeydir/$dkey" if $dkey;
 422       if (rmrf($file)) {
 423         if (open $log,'>>',$log) {
 424           printf {$log}
 425                  "%s [%s_%s] %s %s purged\n",
 426                  isodate(time),$$,$ENV{REQUESTCOUNT},$ra,encode_Q($file);
 427           close $log;
 428         }
 429         http_header('200 OK',"X-File: $file");
 430         print html_header($head),
 431           "<h3>$filename purged</h3>\n",
 432           "</body></html>\n";
 433       } else {
 434         http_die("no such file");
 435       }
 436     } else {
 437       http_die("you are not allowed to purge $filename");
 438     }
 439     exit;
 440   }
 441
 442   # request for file size?
 443   if ($qs eq '?') {
 444     sendsize($file);
 445     # control back to fexsrv for further HTTP handling
 446     &reexec;
 447   }
 448
 449   # fallback
 450   if ($qs) {
 451     http_die("unknown query format $qs");
 452   }
 453
 454 }
 455
 456 unless ($id and $rid and $id eq $rid or $dkey or $anonymous) {
 457   http_die("wrong parameter $file");
 458 }
 459
 460 unless ($to) {
 461   http_die("internal error: unknown recipient");
 462 }
 463
 464 unless ($from) {
 465   http_die("internal error: unknown sender");
 466 }
 467
 468 &check_status($from);
 469
 470 # server based ip restrictions
 471 if (@download_hosts and not ipin($ra,@download_hosts)) {
 472   http_die(
 473     "Downloads from your host ($ra) are not allowed.",
 474     "Contact $ENV{SERVER_ADMIN} for details."
 475   );
 476 }
 477
 478 # user based ip restrictions
 479 unless (check_rhosts("$to/\@DOWNLOAD_HOSTS")) {
 480   http_die("You are not allowed to download from IP $ra");
 481 }
 482
 483 # file based ip restrictions
 484 unless (check_rhosts("$file/restrictions")) {
 485   http_die("Download of files from external user $from is restricted "
 486           ."to internal hosts. Your IP $ra is not allowed.");
 487 }
 488
 489 # set time mark for this access
 490 if ($file =~ m:(.+?)/:) {
 491   my $user = $1;
 492   my $time = untaint(time);
 493   utime $time,$time,$user;
 494 }
 495
 496 # reget or range?
 497 if ($range = $ENV{HTTP_RANGE}) {
 498   $seek = $1 if $range =~ /^bytes=(\d+)-/i;
 499   $stop = $1 if $range =~ /^bytes=\d*-(\d+)/i;
 500 } else {
 501   $seek = 0;
 502   $stop = 0;
 503 }
 504
 505 if (not $autodelete or $autodelete ne 'NO') {
 506   $autodelete = readlink "$file/autodelete" || 'YES';
 507 }
 508
 509 if ($from and $file eq "$from/$from/ADDRESS_BOOK") {
 510   if (open my $AB,'<',"$from/\@ADDRESS_BOOK") {
 511     my $ab = '';
 512     while (<$AB>) {
 513       s/^\s+//;
 514       s/\s+$//;
 515       s/[\r\n]//g;
 516       $ab .= $_."\r\n";
 517     }
 518     close $AB;
 519     nvt_print(
 520       'HTTP/1.1 200 OK',
 521       'Content-Length: ' . length($ab),
 522       'Content-Type: text/plain',
 523       ''
 524     );
 525     print $ab;
 526   } else {
 527     nvt_print(
 528       'HTTP/1.1 404 No address book found',
 529       'Content-Length: 0',
 530       ''
 531     );
 532   }
 533   # control back to fexsrv for further HTTP handling
 534   &reexec;
 535 }
 536
 537 if (-f $data) {
 538   # already downloaded?
 539   if ($limited_download and $limited_download !~ /^n/i
 540       and $from ne $to                    # fex to yourself is ok!
 541       and $to !~ /$amdl/                  # allowed multi download recipients
 542       and $from !~ /^_?fexmail/           # fexmail is ok!
 543       and $to !~ /^_?fexmail/             # fexmail is ok!
 544       and $to !~ /^anonymous/             # anonymous fex is ok!
 545       and $http_client !~ /$adlm/         # allowed download managers
 546       and $file !~ /\/STDFEX$/            # xx is ok!
 547       and (slurp("$file/comment")||'') !~ /^!\*!/ # multi download allow flag
 548       and not($dkey and ($ENV{HTTP_COOKIE}||'') =~ /dkey=$dkey/)
 549       and open $file,'<',"$file/download")
 550   {
 551     $_ = <$file> || '';
 552     close $file;
 553     chomp;
 554     if ($ra) {
 555       # allow downloads from same ip
 556       $_ = '' if $ra eq $_;
 557       # allow downloads from sender ip
 558       $_ = '' if (readlink("$file/ip")||'') eq $ra;
 559     }
 560     if ($_) {
 561       s/(.+) ([\w.:]+)$/by $2 at $1/;
 562       $file = filename($file);
 563       http_die("$file has already been downloaded $_");
 564     }
 565   }
 566   $sb = sendfile($file,$seek,$stop);
 567   shutdown(STDOUT,2);
 568 } elsif (-l $data) {
 569   # $file =~ s:.*/::;
 570   http_die("<code>$file</code> has been withdrawn");
 571 } elsif (open $errf,'<',"$file/error" and $err = getline($errf)) {
 572   fdlog($log,$file,0,0);
 573   http_die($err);
 574 } else {
 575   fdlog($log,$file,0,0);
 576   if ($file =~ /^anonymous.*afex_\d+\.tar$/) {
 577     # should be extra handled...
 578   }
 579   http_die("no such file $file");
 580 }
 581
 582 debuglog(sprintf("%s %s %d %d %d",
 583          isodate(time),$file,$sb||0,$seek,-s $data||0));
 584
 585 if ($sb+$seek == -s $data) {
 586
 587   # note successfull download
 588   $download = "$file/download";
 589   if (open $download,'>>',$download) {
 590     printf {$download} "%s %s\n",isodate(time),$ENV{REMOTE_ADDR};
 591     close $download;
 592   }
 593
 594   # delete file after grace period
 595   if ($autodelete eq 'YES') {
 596     $grace_time = 60 unless defined $grace_time;
 597     for (;;) {
 598       my $utime = (stat $data)[8] || 0;
 599       my $dtime = (stat $download)[8] || 0;
 600       exit if $utime > $dtime;
 601       last if time > $dtime+$grace_time;
 602       sleep 10;
 603     }
 604     unlink $data;
 605     my $error = "$file/error";
 606     if (open $error,'>',$error) {
 607       printf {$error} "%s has been autodeleted after download from %s at %s\n",
 608                       filename($file),$ENV{REMOTE_ADDR},isodate(time);
 609       close $error;
 610     }
 611   }
 612
 613 }
 614
 615 exit;
 616
 617
 618 sub sendfile {
 619   my ($file,$seek,$stop) = @_;
 620   my ($filename,$size,$total_size,$fileid,$filetype);
 621   my ($data,$download,$header,$buf,$range,$s,$b,$t0);
 622   my $type = '';
 623
 624   # swap to and from for special senders, see fup storage swap!
 625   $file =~ s:^(_?anonymous_.*)/(anonymous.*)/:$2/$1/:;
 626   $file =~ s:^(_?fexmail_.*)/(fexmail.*)/:$2/$1/:;
 627
 628   $data     = $file.'/data';
 629   $download = $file.'/download';
 630   $header   = $file.'/header';
 631
 632   # fallback defaults, should be set later with better values
 633   $filename = filename($file);
 634   $total_size = -s $data || 0;
 635
 636   # file link?
 637   if (-l $data) {
 638     unless (-f $data and -r $data) {
 639       http_die("<code>$file</code> has been withdrawn");
 640     }
 641     $data = abs_path($data);
 642     my $fok;
 643     foreach (@file_link_dirs) {
 644       my $dir = abs_path($_);
 645       $fok = $data if $data =~ /^\Q$dir\//;
 646     }
 647     unless ($fok) {
 648       http_die("no permission to download <code>$file</code>");
 649     }
 650   } else {
 651     unless (-f $data and -r $data) {
 652       http_die("<code>$file</code> has gone");
 653     }
 654   }
 655
 656   if ($ENV{REQUEST_METHOD} eq 'GET') {
 657     debuglog("Exp: FROM=\"$from\"","Exp: TO=\"$to\"");
 658     open $data,$data and flock($data,LOCK_EX|LOCK_NB);
 659     # security check: must be regular file after abs_path()
 660     if (-l $data) {
 661       http_die("no permission to download <code>$file</code>");
 662     }
 663     # HTTP Range download suckers are already rejected by fexsrv
 664     unless ($range = $ENV{HTTP_RANGE}) {
 665       # download lock
 666       open $download,'>>',$download or die "$download - $!\n";
 667       if ($file =~ m:(.+?)/(.+?)/: and $1 ne $2) {
 668         # only one concurrent download is allowed if sender <> recipient
 669         flock($download,LOCK_EX|LOCK_NB) or
 670           http_die("$file locked: a download is already in progress");
 671       }
 672     }
 673     $size = $total_size - $seek - ($stop ? $total_size-$stop-1 : 0);
 674   } elsif ($ENV{REQUEST_METHOD} eq 'HEAD') {
 675     $size = -s $data || 0;
 676   } else {
 677     http_die("unknown HTTP request method $ENV{REQUEST_METHOD}");
 678   }
 679
 680   # read MIME entity header (what the client said)
 681   if (open $header,'<',$header) {
 682     while (<$header>) {
 683       if (/^Content-Type: (.+)/i) {
 684         $type = $1;
 685         last;
 686       }
 687     }
 688     close $header;
 689     $type =~ s/\s//g;
 690   }
 691
 692   $fileid = readlink "$file/id" || '';
 693
 694   # determine own MIME entity header for download
 695   my $mime = $file;
 696   $mime =~ s:/.*:/\@MIME:;
 697   my $mt = $ENV{FEXHOME}.'/etc/mime.types';
 698   if (($type =~ /x-mime/i or -e $mime) and open $mt,'<',$mt) {
 699     $type = 'application/octet-stream';
 700     MIMETYPES: while (<$mt>) {
 701       chomp;
 702       s/#.*//;
 703       s/^\s+//;
 704       my ($mt,@ft) = split;
 705       foreach my $ft (@ft) {
 706         if ($filename =~ /\.\Q$ft\E$/i) {
 707           $type = $mt;
 708           last MIMETYPES;
 709         }
 710       }
 711     }
 712     close $mt;
 713   }
 714   # reset to default MIME type
 715   else { $type = 'application/octet-stream' }
 716
 717   # HTML is not allowed for security reasons! (embedded javascript, etc)
 718   $type =~ s/html/plain/i;
 719
 720   debuglog("download with $http_client");
 721
 722   if ($seek or $stop) {
 723     if ($size < 0) {
 724       http_header('416 Requested Range Not Satisfiable');
 725       exit;
 726     }
 727     if ($stop) {
 728       $range = sprintf("bytes %s-%s/%s",$seek,$stop,$total_size);
 729     } else {
 730       $range = sprintf("bytes %s-%s/%s",$seek,$total_size-1,$total_size);
 731     }
 732     nvt_print(
 733       'HTTP/1.1 206 Partial Content',
 734       "Content-Length: $size",
 735       "Content-Range: $range",
 736       "Content-Type: $type",
 737     );
 738     if ($http_client !~ /MSIE/) {
 739       nvt_print("Cache-Control: no-cache");
 740       if ($type eq 'application/octet-stream') {
 741         nvt_print("Content-Disposition: attachment; filename=\"$filename\"");
 742       }
 743     }
 744     nvt_print('');
 745   } else {
 746     # another stupid IE bug-workaround
 747     # http://drupal.org/node/163445
 748     # http://support.microsoft.com/kb/323308
 749     if ($http_client =~ /MSIE/) {
 750       # $type = 'application/x-msdownload';
 751       if ($ignorewarning) {
 752         $type .= "; filename=$filename";
 753         nvt_print(
 754           'HTTP/1.1 200 OK',
 755           "Content-Length: $size",
 756           "Content-Type: $type",
 757 #         "Pragma: no-cache",
 758 #         "Cache-Control: no-store",
 759           "Content-Disposition: attachment; filename=\"$filename\"",
 760           "Connection: close",
 761         );
 762 #        nvt_print('','HTTP/1.1 200 OK',"Content-Length: $size","Content-Type: $type"); exit;
 763       } else {
 764         http_header('200 OK');
 765         print html_header($head);
 766         pq(qq(
 767           '<h2>Internet Explorer warning</h2>'
 768           'Using Microsoft Internet Explorer for download will probably'
 769           'lead to problems, because it is not Internet compatible (RFC 2616).'
 770           '<p>'
 771           'We recommend <a href="http://firefox.com">Firefox</a>'
 772           '<p>'
 773           'If you really want to continue with Internet Explorer, then'
 774           '<a href="$ENV{REQUEST_URL}?IGNOREWARNING">'
 775           'click here with your right mouse button and select "save as"'
 776           '</a>'
 777           '<p>'
 778           'See also <a href="/FAQ/user.html">F*EX user FAQ</a>.'
 779           '</body></html>'
 780         ));
 781         &reexec;
 782       }
 783     } else {
 784       nvt_print(
 785         'HTTP/1.1 200 OK',
 786         "Content-Length: $size",
 787         "Content-Type: $type",
 788         "Cache-Control: no-cache",
 789         "Connection: close",
 790       );
 791       if ($type eq 'application/octet-stream') {
 792         nvt_print(qq'Content-Disposition: attachment; filename="$filename"');
 793       }
 794     }
 795
 796     nvt_print("X-Size: $total_size");
 797     nvt_print("X-File-ID: $fileid") if $fileid;
 798     # if ((`file "$file/data" 2>/dev/null` || '') =~ m{.*/data:\s(.+)}) {
 799     #  nvt_print("X-File-Type: $1");
 800     # }
 801     if ($dkey = $dkey||readlink "$file/dkey") {
 802       my $ma = (readlink "$file/keep"||$keep_default)*60*60*24;
 803       nvt_print("Set-Cookie: dkey=$dkey; Max-Age=$ma; Path=$ENV{REQUEST_URI}");
 804     }
 805     nvt_print('');
 806   }
 807
 808   if ($ENV{REQUEST_METHOD} eq 'HEAD') {
 809     # control back to fexsrv for further HTTP handling
 810     &reexec;
 811   }
 812
 813   if ($ENV{REQUEST_METHOD} eq 'GET') {
 814
 815     if (@throttle) {
 816       my $to = $file;
 817       $to =~ s:/.*::;
 818       foreach (@throttle) {
 819         if (/(.+):(\d+)$/) {
 820           my $throttle = $1;
 821           my $limit = $2;
 822           # throttle ip address?
 823           if ($throttle =~ /^[\d.-]+$/) {
 824             if (ipin($ra,$throttle)) {
 825               $bwl = $limit;
 826               last;
 827             }
 828           }
 829           # throttle e-mail address?
 830           else {
 831             # allow wildcard *, but not regexps
 832             $throttle =~ quotemeta $throttle;
 833             $throttle =~ s/\*/.*/g;
 834             if ($to =~ /$throttle$/) {
 835               $bwl = $limit;
 836               last;
 837             }
 838           }
 839         }
 840       }
 841     }
 842
 843     foreach my $sig (keys %SIG) { local $SIG{$sig} = \&sigexit }
 844     local $SIG{ALRM} = sub { die "TIMEOUT\n" };
 845
 846     seek $data,$seek,0;
 847
 848     $t0 = time;
 849     $s = $b = 0;
 850
 851     # sysread/syswrite because of speed
 852     while ($s < $size and $b = sysread($data,$buf,$bs)) {
 853       # last chunk for HTTP Range?
 854       if ($stop and $s+$b > $size) {
 855         $b = $size-$s;
 856         $buf = substr($buf,0,$b)
 857       }
 858       $s += $b;
 859       alarm($timeout*10);
 860       syswrite STDOUT,$buf or last; # client still alive?
 861       if ($bwl) {
 862         alarm(0);
 863         sleep 1 while $s/(time-$t0||1)/1024 > $bwl;
 864       }
 865     }
 866
 867     close $data;
 868     alarm(0);
 869
 870     fdlog($log,$file,$s,$size);
 871   }
 872   close $download;
 873
 874   return $s;
 875 }
 876
 877
 878 sub sendsize {
 879   my ($path) = @_;
 880   my ($file,$upload,$to,$from,$dkey);
 881   my $size = 0;
 882   local $_;
 883
 884   $path =~ s:^/::;
 885   ($to,$from,$file) = split('/',$path);
 886   $to =~ s/,.*//;
 887   $to   = lc $to;
 888   $from = lc $from;
 889
 890   # swap to and from for special senders, see fup storage swap!
 891   ($from,$to) = ($to,$from) if $from =~ /^(fexmail|anonymous)/;
 892
 893   $to   .= '@'.$hostname if $to   eq 'anonymous';
 894   $from .= '@'.$hostname if $from eq 'anonymous';
 895
 896   $to   .= '@'.$mdomain if -d "$to\@$mdomain";
 897   $from .= '@'.$mdomain if -d "$from\@$mdomain";
 898
 899   $file =~ s/%([A-F0-9]{2})/chr(hex($1))/ge;
 900   $file = urlencode($file);
 901
 902   if ($to eq '*' and $fileid) {
 903     foreach my $fd (glob "*/$from/$file") {
 904       if (-f "$fd/data"
 905           and -l "$fd/id" and readlink "$fd/id" eq $fileid
 906           and $dkey = readlink "$fd/dkey") {
 907         $to = $fd;
 908         $to =~ s:/.*::;
 909         last;
 910       }
 911     }
 912   } elsif ($to !~ /@/ and open my $AB,'<',"$from/\@ADDRESS_BOOK") {
 913     while (<$AB>) {
 914       s/\s*#.*//;
 915       $_ = lc $_;
 916       my ($alias,$address) = split;
 917       if ($address) {
 918         $address =~ s/,.*//;
 919         $address .= '@'.$mdomain if $mdomain and $address !~ /@/;
 920         if ($to eq $alias) {
 921           $to = $address;
 922           last;
 923         }
 924       }
 925     }
 926     close $AB;
 927   }
 928
 929   if (-f "$to/$from/$file/data") {
 930     $dkey = readlink "$to/$from/$file/dkey";
 931     $fkey = slurp("$to/$from/$file/filename")||$file;
 932   }
 933
 934   $upload = -s "$to/$from/$file/upload" || -s "$to/$from/$file/data" || 0;
 935   $size = readlink "$to/$from/$file/size" || 0;
 936   $fileid = readlink "$to/$from/$file/id" || '';
 937
 938   nvt_print('HTTP/1.1 200 OK');
 939   nvt_print("Server: fexsrv");
 940   nvt_print("Content-Length: $upload");
 941   nvt_print("X-Original-Recipient: $to");
 942   if ($dkey and not -s "$from/\@ALLOWED_RECIPIENTS") {
 943     nvt_print("X-DKEY: $dkey");
 944     nvt_print("X-Location: $durl/$dkey/$fkey") if $fkey;
 945   }
 946   nvt_print("X-Size: $size");
 947   nvt_print("X-File-ID: $fileid") if $fileid;
 948   nvt_print("X-Features: $ENV{FEATURES}");
 949   nvt_print('');
 950 }
 951
 952
 953 sub check_rhosts {
 954   my $ipr = shift;
 955   my @hosts;
 956   local $_;
 957
 958   if (open $ipr,$ipr) {
 959     while (<$ipr>) {
 960       chomp;
 961       s/#.*//;
 962       s/\s//g;
 963       if ($_ eq '@LOCAL_RHOSTS') {
 964         push @hosts,@local_rhosts if @local_rhosts;
 965       } elsif (/\w/) {
 966         push @hosts,$_;
 967       }
 968     }
 969     close $ipr;
 970     if (@hosts and not ipin($ra,@hosts)) {
 971       return 0;
 972     }
 973   }
 974   return 1;
 975 }
 976
 977
 978 sub require_auth {
 979   http_header(
 980     '401 Authorization Required',
 981     'WWW-Authenticate: Basic realm="'.$ENV{SERVER_NAME}.' F*EX download"',
 982     'Content-Length: 0',
 983   );
 984   # control back to fexsrv for further HTTP handling
 985   &reexec;
 986 }
 987
 988
 989 sub check_auth {
 990   my ($path,$user,$auth) = @_;
 991   my ($to,$from,$file,$dkey);
 992   my ($id,$idf);
 993   my ($subuser,$subid);
 994   my $auth_ok = 0;
 995   local $_;
 996
 997   if ($path =~ m:(.+)/(.+)/(.+):) {
 998     ($to,$from,$file) = ($1,$2,$3);
 999   } elsif ($path =~ m:(.+)/(.+):) {
1000     ($dkey,$file) = ($1,$2);
1001     $path = readlink "$dkeydir/$dkey" or http_die('no such file');
1002     (undef,$to,$from,$file) = split('/',$path);
1003   } else {
1004     http_die("wrong URL format for download");
1005   }
1006
1007   $to   .= '@'.$mdomain if $mdomain and $to   !~ /@/;
1008   $from .= '@'.$mdomain if $mdomain and $from !~ /@/;
1009
1010   $to   = lc $to;
1011   $from = lc $from;
1012
1013   # auth user match to in download URL?
1014   if ($to ne $user and "$to\@$mdomain" ne $user and $to ne "$user@$mdomain") {
1015     debuglog("mismatch: to=$to, auth user=$user");
1016     &require_auth;
1017   }
1018
1019   # check for real user
1020   if (open $idf,'<',"$to/@") {
1021     $id = getline($idf);
1022     close $idf;
1023     unless ($id and $id eq $auth) {
1024       debuglog("$user mismatch: id=$id, auth=$auth");
1025       &require_auth;
1026     }
1027   }
1028   # check for sub user
1029   elsif (open $idf,'<',"$from/\@SUBUSER") {
1030     while (<$idf>) {
1031       chomp;
1032       s/#.*//;
1033       ($subuser,$subid) = split ':';
1034       if ($subid and $subid eq $auth
1035           and ($user eq $subuser
1036                or $subuser eq '*@*'
1037                or $subuser =~ /^\*\@(.+)/ and $user =~ /\@\Q$1\E$/i
1038                or $subuser =~ /(.+)\@\*$/ and $user =~ /^\Q$1\E\@/i)) {
1039         $auth_ok = 1;
1040         last;
1041       }
1042     }
1043     close $idf;
1044     unless ($auth_ok) {
1045       debuglog("no matching $user in $from/\@SUBUSER");
1046       &require_auth;
1047     }
1048   } else {
1049     debuglog("no $to/@ and no $from/@");
1050     &require_auth;
1051   }
1052
1053 }
1054
1055
1056 sub check_captive {
1057   my $to = shift;
1058   $to =~ s:/.*::;
1059   $to .= '@'.$mdomain if $mdomain and -d "$to\@$mdomain";
1060   if (-e "$to/\@CAPTIVE") {
1061     http_die("$to is CAPTIVE - no URL parameters allowed");
1062   }
1063 }
1064
1065
1066 sub sigexit {
1067   my ($sig) = @_;
1068   my $msg;
1069
1070   $msg = @_ ? "@_" : '???';
1071   $msg =~ s/\n/ /g;
1072   $msg =~ s/\s+$//;
1073
1074   errorlog("$file caught SIGNAL $msg");
1075
1076   # sigpipe means: client has terminated
1077   # this event will be handled further by sendfile(), do not terminate here
1078   if ($sig ne 'PIPE') {
1079     $SIG{__DIE__} = '';
1080     if ($sig eq 'DIE') {
1081       shift;
1082       die "$msg\n";
1083     } else {
1084       die "SIGNAL $msg\n";
1085     }
1086   }
1087 }