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   .= '@'.$hostname if $to   eq 'anonymous';
 104     $from .= '@'.$hostname if $from eq 'anonymous';
 105     $to   .= '@'.$mdomain if -d "$to\@$mdomain";
 106     $from .= '@'.$mdomain if -d "$from\@$mdomain";
 107     if ($ENV{REQUEST_METHOD} eq 'GET' and -s "$from/\@ALLOWED_RECIPIENTS") {
 108       http_die("$from is a restricted user");
 109     }
 110     $file = "$to/$from/$file";
 111   }
 112 }
 113
 114 if ($file and $file =~ m:(.+)/(.+)/.+:) {
 115   $to   = $1;
 116   $from = $2;
 117   # afex!
 118   if ($from =~ s/^(anonymous).*/$1/) {
 119     if (@anonymous_upload and ipin($ra,@anonymous_upload) or $dkey) {
 120       $anonymous = $from;
 121     } else {
 122       http_header('403 Forbidden');
 123       print html_header($head),
 124         "You have no permission to request the URI $ENV{REQUEST_URI}\n",
 125         "</body></html>\n";
 126       exit;
 127     }
 128   }
 129 } else {
 130   http_die("unknown query format");
 131 }
 132
 133 $data = "$file/data";
 134
 135 # open $file,$file; print Digest::MD5->new->addfile($file)->hexdigest;
 136
 137 # request with ?query-parameter ?
 138 if ($qs = $ENV{QUERY_STRING}) {
 139
 140   http_die("\"$1\" is not allowed in URL") if $qs =~ /([<>\%\'\"])/;
 141
 142   # workaround for broken F*IX
 143   $qs =~ s/&ID=skey:\w+//;
 144
 145   # subuser with skey?
 146   if ($qs =~ s/&*SKEY=([\w:]+)//i) {
 147     $skey = $1;
 148     # encrypted skey?
 149     if ($skey =~ s/^MD5H:(.+)/$1/) {
 150       # lookup real skey
 151       foreach my $s (glob "$skeydir/*") {
 152         $s =~ s:.*/::;
 153         if ($skey eq md5_hex($s.$ENV{SID})) {
 154           $skey = $s;
 155           last;
 156         }
 157       }
 158     }
 159     if (open $skey,'<',"$skeydir/$skey") {
 160       $from = $to = '';
 161       while (<$skey>) {
 162         $from = lc($1) if /^from=(.+)/;
 163         $to   = lc($1) if /^to=(.+)/;
 164       }
 165       close $skey;
 166       if ($from and $to) {
 167         $file =~ s:.*/:$to/$from/:;
 168       } else {
 169         http_die("INTERNAL ERROR: missing data in $skeydir/$skey");
 170       }
 171     } else {
 172       debuglog("SKEY=$skey");
 173       http_die("wrong SKEY authentification");
 174     }
 175   }
 176
 177   # group member with gkey?
 178   if ($qs =~ s/&*GKEY=([\w:]+)//i) {
 179     $gkey = $1;
 180     # encrypted gkey?
 181     if ($gkey =~ s/^MD5H:(.+)/$1/) {
 182       # lookup real gkey
 183       foreach my $g (glob "$gkeydir/*") {
 184         $g =~ s:.*/::;
 185         if ($gkey eq md5_hex($g.$ENV{SID})) {
 186           $gkey = $g;
 187           last;
 188         }
 189       }
 190     }
 191     if (open $gkey,'<',"$gkeydir/$gkey") {
 192       $from = $to = '';
 193       while (<$gkey>) {
 194         $from  = lc($1) if /^from=(.+)/;
 195         $group = lc($1) if /^to=\@(.+)/;
 196       }
 197       close $gkey;
 198       if ($from and $group and open $group,'<',"$from/\@GROUP/$group") {
 199         while (<$group>) {
 200           s/#.*//;
 201           s/\s//g;
 202           if (/(.+):/) {
 203             my $to = $1;
 204             $file =~ s:.*/:$to/$from/:;
 205             last;
 206           }
 207         }
 208         close $group;
 209       } else {
 210         http_die("INTERNAL ERROR: missing data in $gkeydir/$gkey");
 211       }
 212     } else {
 213       debuglog("GKEY=$gkey");
 214       http_die("wrong GKEY authentification");
 215     }
 216   }
 217
 218   # check for ID in query
 219   elsif ($qs =~ s/\&*\bID=([^&]+)//i) {
 220     $id = $1;
 221     $fop_auth = 0;
 222
 223     if ($id eq 'PUBLIC') {
 224       http_header('403 Forbidden');
 225       exit;
 226     }
 227
 228     if ($file =~ m:^(.+)/(.+)/(.+):) {
 229       $to   = $1;
 230       $from = $2;
 231       $to   =~ s/,+/,/g;
 232       $to   =~ s/\s//g;
 233       $from =~ s/\s//g;
 234       if ($mdomain and $from ne 'anonymous') {
 235         $to   .= '@'.$mdomain if $to   !~ /@/;
 236         $from .= '@'.$mdomain if $from !~ /@/;
 237       }
 238       $to   = lc $to;
 239       $from = lc $from;
 240     } else {
 241       http_die("unknown file query format");
 242     }
 243
 244     # public or anonymous recipient? (needs no auth-ID for sender)
 245     if ($anonymous or $id eq 'PUBLIC' and
 246         @public_recipients and grep /^\Q$to\E$/i,@public_recipients) {
 247       $rid = $id;
 248     } else {
 249       open my $idf,'<',"$from/@" or http_die("unknown user $from");
 250       $rid = getline($idf);
 251       close $idf;
 252       $rid = sidhash($rid,$id);
 253     }
 254
 255     unless ($id eq $rid) {
 256       debuglog("real id=$rid, id sent by user=$id");
 257       http_die("wrong auth-ID");
 258     }
 259
 260     # set akey link for HTTP sessions
 261     # (need original id for consistant non-moving akey)
 262     if (-d $akeydir and open $idf,'<',"$from/@" and my $id = getline($idf)) {
 263       $akey = untaint(md5_hex("$from:$id"));
 264       unlink "$akeydir/$akey";
 265       symlink "../$from","$akeydir/$akey";
 266     }
 267
 268     my %to;
 269     COLLECTTO: foreach my $to (split(',',$to)) {
 270       if ($to !~ /.@./ and open my $AB,'<',"$from/\@ADDRESS_BOOK") {
 271         while (<$AB>) {
 272           s/\s*#.*//;
 273           s/^\s+//;
 274           next unless $_;
 275           if (/^\s*([\S]+)\s+([\S]+)/) {
 276             my ($alias,$address) = ($1,$2);
 277             if ($to =~ /^\Q$alias\E$/i) {
 278               foreach my $to (split(",",$address)) {
 279                 $to .= '@'.$mdomain if $mdomain and $to !~ /@/;
 280                 $to{$to} = lc $to; # ignore dupes
 281               }
 282               next COLLECTTO;
 283             }
 284           }
 285         }
 286       } elsif ($to =~ /^\@(.+)/) {
 287         my $group = "$from/\@GROUP/$1";
 288         if (not -l $group and open $group) {
 289           while (<$group>) {
 290             s/#.*//;
 291             s/\s//g;
 292             if (/(.+\@[w.-]+):.+/) {
 293               $to{$1} = lc $1; # ignore dupes
 294             }
 295           }
 296           close $group;
 297         }
 298       } else {
 299         $to .= '@'.$mdomain if $mdomain and $to !~ /.@./;
 300         $to{$to} = lc $to; # ignore dupes
 301       }
 302     }
 303     foreach $to (keys %to) {
 304       # if (-e "$to/\@CAPTIVE") { http_die("$to is CAPTIVE") }
 305       unless (-d $to or checkaddress($to)) {
 306         http_die("$to is not a legal e-mail address");
 307       }
 308     }
 309
 310   }
 311
 312   if ($qs =~ /\&?KEEP=(\d+)/i) {
 313     $keep = $1;
 314     $filename = filename($file);
 315     check_captive($file);
 316     if  (-f $data) {
 317       unlink "$file/keep";
 318       if (symlink $keep,"$file/keep") {
 319         http_header('200 OK');
 320         print html_header($head),
 321               "<h3>set keep=$keep for $filename</h3>\n",
 322               "</body></html>\n";
 323       } else {
 324         http_header('599 internal error');
 325         print html_header($head),
 326               "<h3>$filename - $!</h3>\n",
 327               "</body></html>\n";
 328       }
 329     } else {
 330       http_header('404 File not found');
 331       print html_header($head),
 332             "<h3>$filename not found</h3>\n",
 333             "</body></html>\n";
 334     }
 335     exit;
 336   } elsif ($qs =~ s/\&?KEEP//i) {
 337     check_captive($file);
 338     $autodelete = 'NO';
 339   }
 340
 341   if ($qs =~ s/\&?FILEID=(\w+)//i) { $fileid = $1 }
 342
 343   if ($qs =~ s/\&?IGNOREWARNING//i) { $ignorewarning = 1 }
 344
 345   if ($qs eq 'LIST') {
 346     http_header('200 OK','Content-Type: text/plain');
 347     print "$file :\n";
 348     chdir $file and exec '/client/bin/l';
 349     exit;
 350   }
 351
 352   # copy file to yourself
 353   if ($qs eq 'COPY') {
 354     unless (-f "$file/data") {
 355       http_die("File not found.");
 356     }
 357     ($to,$from,$file) = split('/',$file);
 358     unless ("$to/@") {
 359       # http_header('403 Forbidden');
 360       # print html_header($head),
 361       #  "You have no permission to copy a file.\n",
 362       #  "</body></html>\n";
 363       http_die("You have no permission to copy a file.");
 364     }
 365     if (-s "$to/\@ALLOWED_RECIPIENTS") {
 366       http_die("You are a restricted user.");
 367     }
 368     if (-e "$to/$to/$file/data") {
 369       # http_header('409 File Exists');
 370       # print html_header($head),
 371       #   "File $file already exists in your outgoing spool.\n",
 372       #   "</body></html>\n";
 373       http_die("File $file already exists in your outgoing spool.");
 374     }
 375     mkdirp("$to/$to/$file");
 376     link "$to/$from/$file/data","$to/$to/$file/data"
 377       or http_die("cannot link to $to/$to/$file/data - $!\n");
 378     my $fkey = copy("$to/$from/$file/filename","$to/$to/$file/filename");
 379     open my $notify,'>',"$to/$to/$file/notify";
 380     close $notify;
 381     my $dkey = randstring(8);
 382     unlink "$to/$to/$file/dkey","$dkeydir/$dkey";
 383     symlink "../$to/$to/$file","$dkeydir/$dkey";
 384     symlink $dkey,"$to/$to/$file/dkey";
 385     http_header('200 OK',"Location: $durl/$dkey/$fkey");
 386     print html_header($head),
 387       "File $file copied to yourself.\n",
 388       "</body></html>\n";
 389     exit;
 390   }
 391
 392   # ex and hopp?
 393   if ($qs =~ s/(^|&)DELETE//i) {
 394     if (unlink $data) {
 395       $filename = filename($file);
 396       if (open my $log,'>',"$file/error") {
 397         printf {$log} "%s has been deleted by %s at %s\n",
 398                       $filename,$ENV{REMOTE_ADDR},isodate(time);
 399         close $log;
 400       }
 401       foreach my $logdir (@logdir) {
 402         my $msg = sprintf "%s [%s_%s] %s %s deleted\n",
 403                   isodate(time),$$,$ENV{REQUESTCOUNT},$ra,encode_Q($file);
 404         if (open $log,'>>',"$logdir/$log") {
 405           print {$log} $msg;
 406           close $log;
 407         }
 408       }
 409       http_header('200 OK',"X-File: $file");
 410       print html_header($head),
 411             "<h3>$filename deleted</h3>\n",
 412             "</body></html>\n";
 413       exit;
 414     } else {
 415       http_die("no such file");
 416     }
 417     exit;
 418   }
 419
 420   # wipe out!? (for anonymous upload)
 421   if ($qs =~ s/(^|&)PURGE//i) {
 422     $filename = filename($file);
 423     if (@anonymous_upload and ipin($ra,@anonymous_upload)) {
 424       unlink "$dkeydir/$dkey" if $dkey;
 425       if (rmrf($file)) {
 426         foreach my $logdir (@logdir) {
 427           my $msg = sprintf "%s [%s_%s] %s %s purged\n",
 428                     isodate(time),$$,$ENV{REQUESTCOUNT},$ra,encode_Q($file);
 429           if (open $log,'>>',"$logdir/$log") {
 430             print {$log} $msg;
 431             close $log;
 432           }
 433         }
 434         http_header('200 OK',"X-File: $file");
 435         print html_header($head),
 436           "<h3>$filename purged</h3>\n",
 437           "</body></html>\n";
 438       } else {
 439         http_die("no such file");
 440       }
 441     } else {
 442       http_die("you are not allowed to purge $filename");
 443     }
 444     exit;
 445   }
 446
 447   # request for file size?
 448   if ($qs eq '?') {
 449     sendsize($file);
 450     # control back to fexsrv for further HTTP handling
 451     &reexec;
 452   }
 453
 454   # fallback
 455   if ($qs) {
 456     http_die("unknown query format $qs");
 457   }
 458
 459 }
 460
 461 unless ($id and $rid and $id eq $rid or $dkey or $anonymous) {
 462   http_die("wrong parameter $file");
 463 }
 464
 465 unless ($to) {
 466   http_die("internal error: unknown recipient");
 467 }
 468
 469 unless ($from) {
 470   http_die("internal error: unknown sender");
 471 }
 472
 473 &check_status($from);
 474
 475 # server based ip restrictions
 476 if (@download_hosts and not ipin($ra,@download_hosts)) {
 477   http_die(
 478     "Downloads from your host ($ra) are not allowed.",
 479     "Contact $ENV{SERVER_ADMIN} for details."
 480   );
 481 }
 482
 483 # user based ip restrictions
 484 unless (check_rhosts("$to/\@DOWNLOAD_HOSTS")) {
 485   http_die("You are not allowed to download from IP $ra");
 486 }
 487
 488 # file based ip restrictions
 489 unless (check_rhosts("$file/restrictions")) {
 490   http_die("Download of files from external user $from is restricted "
 491           ."to internal hosts. Your IP $ra is not allowed.");
 492 }
 493
 494 # set time mark for this access
 495 if ($file =~ m:(.+?)/:) {
 496   my $user = $1;
 497   my $time = untaint(time);
 498   utime $time,$time,$user;
 499 }
 500
 501 # reget or range?
 502 if ($range = $ENV{HTTP_RANGE}) {
 503   $seek = $1 if $range =~ /^bytes=(\d+)-/i;
 504   $stop = $1 if $range =~ /^bytes=\d*-(\d+)/i;
 505 } else {
 506   $seek = 0;
 507   $stop = 0;
 508 }
 509
 510 if (not $autodelete or $autodelete ne 'NO') {
 511   $autodelete = readlink "$file/autodelete" || 'YES';
 512 }
 513
 514 if ($from and $file eq "$from/$from/ADDRESS_BOOK") {
 515   if (open my $AB,'<',"$from/\@ADDRESS_BOOK") {
 516     my $ab = '';
 517     while (<$AB>) {
 518       s/^\s+//;
 519       s/\s+$//;
 520       s/[\r\n]//g;
 521       $ab .= $_."\r\n";
 522     }
 523     close $AB;
 524     nvt_print(
 525       'HTTP/1.1 200 OK',
 526       'Content-Length: ' . length($ab),
 527       'Content-Type: text/plain',
 528       ''
 529     );
 530     print $ab;
 531   } else {
 532     nvt_print(
 533       'HTTP/1.1 404 No address book found',
 534       'Content-Length: 0',
 535       ''
 536     );
 537   }
 538   # control back to fexsrv for further HTTP handling
 539   &reexec;
 540 }
 541
 542 if (-f $data) {
 543   # already downloaded?
 544   if ($limited_download and $limited_download !~ /^n/i
 545       and $from ne $to                    # fex to yourself is ok!
 546       and $from !~ /^_?fexmail/           # fexmail is ok!
 547       and $to !~ /^_?fexmail/             # fexmail is ok!
 548       and $to !~ /^anonymous/             # anonymous fex is ok!
 549       and $to !~ /$amdl/                  # allowed multi download recipients
 550       and $http_client !~ /$adlm/         # allowed download managers
 551       and $file !~ /\/STDFEX$/            # xx is ok!
 552       and (slurp("$file/comment")||'') !~ /^!\*!/ # multi download allow flag
 553       and not($dkey and ($ENV{HTTP_COOKIE}||'') =~ /dkey=$dkey/)
 554       and open $file,'<',"$file/download")
 555   {
 556     my $d1 = <$file> || ''; # first download
 557     chomp $d1;
 558     close $file;
 559     if ($ra) {
 560       # allow downloads from same ip
 561       $d1 = '' if $d1 =~ /\Q$ra/;
 562       # allow downloads from sender ip
 563       $d1 = '' if (readlink("$file/ip")||'') eq $ra;
 564     }
 565     if ($d1 and $d1 =~ s/(.+) ([\w.:]+)$/$2 at $1/) {
 566       $file = filename($file);
 567       http_die("$file has already been downloaded by $d1");
 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 }