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