#!/usr/bin/perl -wT

# F*EX CGI for download
#
# Author: Ulli Horlacher <framstag@rus.uni-stuttgart.de>
#
# Copyright: GNU General Public License

use CGI 		qw(:standard);
use CGI::Carp		qw(fatalsToBrowser);
use Fcntl 		qw(:flock :seek);
use File::Basename;
use IO::Handle;
use Encode;

# add fex lib
$FEXLIB =
  $0 =~ m:(/.+)/.+/: ? "$1/lib":
  $0 =~ m:(.*/):     ? "$1/../lib":
                       "../lib";
die "$0: no $FEXLIB\n" unless -d $FEXLIB;

our $error = 'F*EX download ERROR';
our $head = "$ENV{SERVER_NAME} F*EX download";
# import from fex.pp
our ($spooldir,$tmpdir,$logdir,$bs,$fop_auth);

# load common code, local config : $HOME/lib/fex.ph
require "$FEXLIB/fex.pp" or die "$0: cannot load $FEXLIB/fex.pp - $!\n";

my $log       = "$logdir/fop.log";

chdir $spooldir or die "$spooldir - $!\n";

my $http_client = $ENV{HTTP_USER_AGENT} || '';

$file = $ENV{PATH_INFO} || '';
http_die('no file name') unless $file;
$file =~ s/%([\dA-F]{2})/unpack("a",pack("H2",$1))/ge;
$file =~ s:/\.\.:/__:g;
$file =~ s:^/+::;
$file = untaint($file);

# secure mode with HTTP authorization?
if ($fop_auth) {
  @http_auth = ();
  if ($ENV{HTTP_AUTHORIZATION} and $ENV{HTTP_AUTHORIZATION} =~ /Basic\s+(.+)/) {
    @http_auth = split(':',decode_b64($1));
  }
  if (@http_auth != 2) {
    &require_auth;
  }
  &check_auth($file,@http_auth);
}

# download-URL-scheme /$dkey/$file ?
if ($file =~ m:^([^/]+)/[^/]+$:) {
  $dkey = $1;
  if ($link = readlink(".dkeys/$dkey")) {
    if ($link !~ s:^\.\./::) {
      http_die("internal error on dkey for $link");
    }
    $file = untaint($link);
  } else {
    http_die("no such file $file");
  }
} else {
  $file =~ s/\?.*//;
  # add mail-domain to addresses if necessary
  if (($to,$from,$file) = ($file =~ m:(.+)/(.+)/(.+):)) {
    $to   .= '@'.$mdomain if $to   !~ /@/;
    $from .= '@'.$mdomain if $from !~ /@/;
    $file = "$to/$from/$file";
  }
}

unless ($file and $file =~ m:.+/.+/.+:) {
  http_die("unknown query format");
}

# request with ?query-parameter ?
if ($qs = $ENV{QUERY_STRING}) {
  
  # check for ID in query
  if ($qs =~ s/\&?ID=([^&]+)//i) {
    $id = $1;
    $fop_auth = 0;

    if ($file =~ m:^(.+)/(.+)/(.+):) {
      $to   = $1;
      $from = $2;
      $to   =~ s/,+/,/g;
      $to   =~ s/\s//g;
      $from =~ s/\s//g;
      $to   .= '@'.$mdomain if $to   !~ /@/;
      $from .= '@'.$mdomain if $from !~ /@/;
    } else {
      http_die("unknown file query format");
    }

    # subuser?
    if ($qs =~ s/\&?SKEY=(\w+)//i) {
      $skey = $1;
      my ($s_from,$s_to);
      if (open $skey,'<',".skeys/$skey") {
        while (<$skey>) {
          if (/^(\w+)=(.+)/) {
            $s_from = $2 if lc($1) eq 'from';
            $s_to   = $2 if lc($1) eq 'to';
          }
        }
        close $skey;
      }
      if ($s_from and $s_to) {
        unless ($s_from eq $from and $s_to eq $to) {
          debuglog("SKEY=$skey, from=$from/$s_from, to=$to/$s_to");
          http_die("wrong SKEY authentification"); 
        }
      } else {
        http_die("no SKEY authentification"); 
      }
    } 
    
    # regular user
    else {
      open F,'<',"$from/@" or http_die("unknown user $from");
      $rid = <F>||'';
      close F;
      chomp $rid;
      $rid = sidhash($rid,$id);
      
      unless ($id eq $rid) {
        debuglog("real id=$rid, id sent by user=$id");
        http_die("wrong auth-ID");
      }
    
      my %to;
      COLLECTTO: foreach my $to (split(',',$to)) {
        if ($from and open my $AB,'<',"$from/\@ADDRESS_BOOK") {
          while (<$AB>) {
            s/#.*//;
            if (/^\s*([\S]+)\s+([\S]+)/) {
              my ($alias,$address) = ($1,$2);
              if ($to =~ /^\Q$alias\E$/i) {
                foreach my $to (split(",",$address)) {
                  $to .= '@'.$mdomain if $to !~ /@/;
                  $to{$to} = $to; # ignore dupes
                }
                next COLLECTTO;
              }
            }
          }
        }
        $to .= '@'.$mdomain if $to !~ /@/;
        $to{$to} = $to; # ignore dupes
      }
      foreach $to (keys %to) {
        unless (-d $to or checkaddress($to)) {
          http_die("$to is not a legal e-mail address");
        }
      }
      
    }

  }

  # request for file size?
  if ($qs eq '?') {
    sendsize($file);
    # control back to fexsrv for further HTTP handling
    exec($ENV{FEXHOME}.'/bin/fexsrv') if $ENV{KEEP_ALIVE};
    exit;
  }
  
  if ($qs =~ s/\&?KEEP//i) {
    $autodelete = 'NO';
  }
  
  # ex and hopp?
  if ($qs =~ s/\&?DELETE//i) {
    if (unlink "$file/data") {
      $filename = filename($file);
      if (open F,'>',"$file/error") {
        printf F "%s has been deleted by %s at %s\n",
                 $filename,$ENV{REMOTE_ADDR},isodate(time);
        close F;
      }
      http_header('200 OK');
      print html_header($head),
            "<h3>/$filename deleted</h3>\n",
            "</body></html>\n";
      exit;
    } else {              
      http_die("no such file");
    }
  } 
  
  # fallback
  if ($qs) {
    http_die("unknown query format $qs");
  }

} 

unless ($id and $rid and $id eq $rid or $dkey) {
  http_die("wrong parameter $file");
}

# reget?
if ($ENV{HTTP_RANGE} and $ENV{HTTP_RANGE} =~ /^bytes=(\d+)-$/i) {
  $seek = $1;
} else {
  $seek = 0;
}

$data = "$file/data";

if ((not $autodelete or $autodelete ne 'NO') 
    and open F,'<',"$file/autodelete") {
  $autodelete = <F> || '';
  close F;
  chomp $autodelete;
}
$autodelete = 'YES' unless $autodelete;
  
if ($from and $file eq "$from/$from/ADDRESS_BOOK") {
  if (open my $AB,'<',"$from/\@ADDRESS_BOOK") {
    nvt_print(
      'HTTP/1.1 200 OK',
      "Content-Length: " . -s "$from/\@ADDRESS_BOOK",
      "Content-Type: text/plain",
      ''
    );
    print while <$AB>;
    close $AB;
  } else {
    nvt_print(
      'HTTP/1.1 404 No address book found',
      "Content-Length: 0",
      ''
    );
  }
  exit;
}

if (-r $file and -f $data) {
  # DELAY auto-delete flag and already downloaded?
  if ($autodelete eq 'DELAY' and open F,'<',"$file/download") {
    my ($dra) = <F> || '';
    close F;
    # other client IP?
    if ($dra and $dra !~ /\Q$ENV{REMOTE_ADDR}/) {
      # my $date = isodate((stat "$file/download")[9]);
      $file = filename($file);
      $dra =~ s/(.+) ([\d.]+)$/by $2 at $1/;
      http_die("$file has been already downloaded $dra");
    }
  }
  $sb = sendfile($file,$seek);
} elsif (open F,'<',"$file/error" and my $err = <F>) {
  fdlog($log,$file,0,0);
  chomp $err;
  http_die($err);
} else {
  fdlog($log,$file,0,0);
  http_die("no such file $file");
}

debuglog(sprintf("%s %s %d %d %d\n",
         isodate(time),$file,$sb||0,$seek,-s $data||0));

close STDOUT or exit 2; # download no success?
close STDIN;
close STDERR;

if ($sb+$seek == -s $data) {
  
  # note successfull download
  $download = "$file/download";
  if (open F,'>>',$download) {
    printf F "%s %s\n",isodate(time),$ENV{REMOTE_ADDR};
    close F;
  }
  
  # delete file after grace period
  if ($autodelete eq 'YES') {
    $grace_time = 60 unless defined $grace_time;
    for (;;) {
      last if time > ((stat $download)[8] || 0)+$grace_time;
      sleep 10;
    }
    unlink $data;
    if (open F,'>',"$file/error") {
      printf F "%s has been autodeleted after download from %s at %s\n",
               filename($file),$ENV{REMOTE_ADDR},isodate(time);
      close F;
    }
  }
  
}

exit;
  
sub sendfile {
  my ($file,$seek) = @_;
  my ($filename,$savefilename,$size,$total_size);
  my ($data,$download,$buf);
  my $type = '';
  my $s = 0;
  my $b = 0;
  local *F;

  $data = $file.'/data';
  $download = $file.'/download';
  
  # fallback defaults, should be set later with better values
  $filename = $file;
  $filename =~ s:.*/::;
  $savefilename = $filename;
  
  if ($ENV{REQUEST_METHOD} eq 'GET') {
    open $download,'>>',$download or die "$download - $!\n";

    unless (flock($download,LOCK_EX|LOCK_NB)) {
      # teergrub download manager and other suckers
      if ($ENV{HTTP_RANGE}) { flock($download,LOCK_EX) }
      http_die("$file locked: a download is already in progress");
    }
  
    $total_size = -s $data || 0;
    $size = $total_size - $seek;
  } elsif ($ENV{REQUEST_METHOD} eq 'HEAD') {
    $size = -s $data || 0;
  } else {
    http_die("unknown HTTP request method $ENV{REQUEST_METHOD}");
  }
  
  if (open F,'<',"$file/filename") {
    local $/;
    $filename = <F>;
    close F;
    $filename =~ s:[\r\n]+: :g;
    $savefilename = normalize_filename(decode_utf8($filename));
  }

  # read MIME entity header (what the client said)
  if (open F,'<',"$file/header") {
    while (<F>) {
      if (/^Content-Type: (.+)/i) {
        $type = $1;
        last;
      }
    }
    close F;
    $type =~ s/\s//g;
  }
  
  # determine own MIME entity header for download
  if ($http_client !~ /MSIE/ and $type =~ /x-mime/i 
      and open F,'<',$ENV{FEXHOME}.'/etc/mime.types') {
    $type = 'application/octet-stream';
    MIMETYPES: while (<F>) {
      chomp;
      s/#.*//;
      s/^\s+//;
      my ($mt,@ft) = split;
      foreach my $ft (@ft) {
        if ($filename =~ /\.\Q$ft\E$/i) {
          $type = $mt;
          last MIMETYPES;
        }
      }
    }
    close F;
  } else {
    $type = 'application/octet-stream';
  }
  
  if ($seek) {
    my $range = sprintf("bytes %s-%s/%s",$seek,$total_size-1,$total_size);
    nvt_print(
      'HTTP/1.1 206 Partial Content',
      "Content-Length: $size",
      "Content-Range: $range",
      "Content-Type: $type",
      "Cache-Control: no-cache",
    );
    if ($type eq 'application/octet-stream') {
      nvt_print("Content-Disposition: attachment; filename=\"$filename\"");
    }
    nvt_print('');
  } else {
    debuglog("download with $http_client");
    if ($http_client =~ /MSIE/) {
      nvt_print(
        'HTTP/1.1 200 OK',
        "Content-Length: $size",
        "Content-Type: $type",
        "Pragma: no-cache",
      );
      if ($type eq 'application/octet-stream') {
#                 "Content-Type: application/x-msdownload; name=\"$savefilename\"",
        nvt_print("Content-Disposition: attachment; filename=\"$filename\"");
      }
      nvt_print('');
    } else {
      nvt_print(
        'HTTP/1.1 200 OK',
        "Content-Length: $size",
        "Content-Type: $type",
        "Cache-Control: no-cache",
      );
      if ($type eq 'application/octet-stream') {
        nvt_print("Content-Disposition: attachment; filename=\"$filename\"");
      }
      nvt_print('');
    }
  }

  if ($ENV{REQUEST_METHOD} eq 'HEAD') {
    # control back to fexsrv for further HTTP handling
    exec($ENV{FEXHOME}.'/bin/fexsrv') if $ENV{KEEP_ALIVE};
    exit;
  }
  
  if ($ENV{REQUEST_METHOD} eq 'GET') {
    open $data,'<',$data or die "$data - $!\n";
    seek $data,$seek,0;
  
    while ($b = read($data,$buf,$bs)) {
      $s += $b;      
      print $buf or last;
    }
    
    close $data;
    
    fdlog($log,$file,$s,$size);
  }
  close $download;
  
  return $s;
}

sub sendsize {
  my ($path) = @_;
  my ($file,$upload,$to,$from);
  my $size = 0;
  local $_;
  
  $path =~ s:^/::;
  ($to,$from,$file) = split('/',$path);
  $to =~ s/,.*//;
  $to = lc $to;
  $from = lc $from;
  $file =~ s/%([A-F0-9]{2})/chr(hex($1))/ge;
  $file = urlencode($file);
  $upload = -s "$to/$from/$file/upload" || 0;
  if (open $size,"$to/$from/$file/size") {
    $_ = <$size> || 0;
    close $size;
    /(\d+)/;
    $size = $1;
  }

  nvt_print('HTTP/1.1 200 OK');
  nvt_print("Content-Length: $upload");
  nvt_print("X-Size: $size");
  nvt_print('');
}

sub require_auth {
  http_header(
    '401 Authorization Required',
    'WWW-Authenticate: Basic realm="'.$ENV{SERVER_NAME}.' F*EX download"',
    'Content-Length: 0',
  );
  # control back to fexsrv for further HTTP handling
  exec($ENV{FEXHOME}.'/bin/fexsrv') if $ENV{KEEP_ALIVE};
  exit;
}


sub check_auth {
  my ($path,$user,$auth) = @_;
  my ($to,$from,$file,$dkey);
  my ($id,$idf);
  my ($subuser,$subid);
  my $auth_ok = 0;
  local $_;

  if ($path =~ m:(.+)/(.+)/(.+):) {
    ($to,$from,$file) = ($1,$2,$3);
  } elsif ($path =~ m:(.+)/(.+):) {  
    ($dkey,$file) = ($1,$2);
    $path = readlink "$spooldir/.dkeys/$dkey" or http_die('no such file');
    (undef,$to,$from,$file) = split('/',$path);
  } else {
    http_die("wrong URL format for download");
  }

  $to   .= '@'.$mdomain if $to   !~ /@/;
  $from .= '@'.$mdomain if $from !~ /@/;

  # auth user match to in download URL?
  if ($to ne $user and "$to\@$mdomain" ne $user and $to ne "$user@$mdomain") {
    debuglog("mismatch: to=$to, auth user=$user");
    &require_auth;
  }

  # check for real user
  if (open $idf,'<',"$to/@") {
    $id = <$idf> || '';
    close $idf;
    chomp $id;
    unless ($id and $id eq $auth) {
      debuglog("$user mismatch: id=$id, auth=$auth");
      &require_auth;
    }
  } 
  # check for sub user
  elsif (open $idf,'<',"$from/@") {
    while (<$idf>) {
      chomp;
      ($subuser,$subid) = split ':';
      if ($subid and $subid eq $auth 
          and ($user eq $subuser 
               or $subuser eq '*@*'
               or $subuser =~ /^\*\@(.+)/ and $user =~ /\@\Q$1\E$/i
               or $subuser =~ /(.+)\@\*$/ and $user =~ /^\Q$1\E\@/i)) {
        $auth_ok = 1;
        last;
      }
    }
    close $idf;
    unless ($auth_ok) {
      debuglog("no matching $user in $from/@");
      &require_auth;
    }
  }
  else {
    debuglog("no $to/@ and no $from/@");
    &require_auth;
  }
  
}
