#!/usr/bin/perl -wT

# CGI for client to client copy
#
# Author: Ulli Horlacher <framstag@rus.uni-stuttgart.de>

use Fcntl 	qw(:flock :seek :mode);
use Digest::MD5 qw(md5_hex);

# add fex lib
(our $FEXLIB) = $ENV{FEXLIB} =~ /(.+)/;
die "$0: no $FEXLIB\n" unless -d $FEXLIB;

$ENV{LC_ALL} = 'C';

$| = 1;

# import from fex.pp
our ($tmpdir,@logdir,$timeout,$fra,$document_exchange);

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

chdir $spooldir or error(500,"$spooldir - $!");

my $ra = $ENV{REMOTE_ADDR}||0;
$fra .= '/'.$ENV{HTTP_X_FORWARDED_FOR} if $ENV{HTTP_X_FORWARDED_FOR};
$timeout *= 10;

$user = $id = $tkey = $transfer = '';
$RM = $ENV{REQUEST_METHOD};

# parse HTTP QUERY_STRING
if (my $qs = $ENV{QUERY_STRING}) {
  foreach (split '&',$qs) { setparam(split '=',"$_=") };
}

unless ($user)		{ error(400,"Missing user") }
unless (-f "$user/@")	{ error(404,"Unknown user $user") }
unless ($transfer)	{ error(400,"Missing transfer") }

$SIG{ALRM} = sub { error(504,"Timeout") };
alarm(999);

if ($RM eq 'POST') {

  if ($id and $tkey ne '000000') {
    # initial request from send client asking for new tkey

    &authentificate;

    if ($dox) {
      my $doxa = lc(readlink_("$user/\@DOCUMENT_EXCHANGE"));
      if (not $document_exchange and $doxa ne 'yes' or $doxa eq 'no') {
        error(403,"Forbidden");
      }
      mkdirp("$user/DOX");
    }

    if ($tkey) {
      # hidden feature: client may supply tkey
      $tdir = "$user/CCC/$transfer#$tkey";
      if (-d $tdir) {
        rmrf($tdir);
        rmrf("$user/$user/fexsync_${transfer}_$tkey.tar");
        rmrf("$user/$user/fexsync_${transfer}_$tkey.tgz");
      }
      mkdirp($tdir);
    } else {
      for (;;) {
        $tkey = sprintf "%06d",int(rand(1000000));
        $tdir = "$user/CCC/$transfer#$tkey";
        unless (-e $tdir) {
          mkdirp($tdir);
          last;
        }
      }
    }

    $ff = "$tdir/sfiles";
    open $ff,'>',$ff or error(500,"Cannot write $ff : $!");
    while (<STDIN>) {
      if (/^(\d+) (.+)/) {
        print {$ff} $_;
      } else {
        last;
      }
    }
    close $ff;

    header(
      '200 OK',
      "Location: $transfer#$tkey",
    );
    ccclog("request $transfer#$tkey");
    exit;

  } elsif ($tkey) {
    # receive client

    if ($tkey eq '000000') {
      if (`ls -dt $user/CCC/$transfer#* 2>/dev/null` =~ /#(\d+)/) {
        $tkey = $1;
      } else {
        error(404,"No transfer $transfer available");
      }
    }

    $tdir = "$user/CCC/$transfer#$tkey";
    unless (-d $tdir) { error(404,"Unknown $transfer#$tkey") }

    $ff = "$tdir/rfiles";
    $fft = "$ff.tmp";
    if (-e $fft) { error(409,"Transfer in action") }
    if (-e $ff)  { error(409,"Transfer done") }

    open $fft,'>',$fft or error(500,"Cannot write $fft : $!");
    while (<STDIN>) {
      if (/^\d+ ./) {
        print {$fft} $_;
      } else {
        last;
      }
    }
    close $fft;
    rename $fft,$ff;

    symlink $ra,"$tdir/rip";

    for (;;) {
      sleep 2;
      $durl = readlink("$tdir/durl") and last;
    }

    $ff = "$tdir/sfiles";

    header('200 OK',"Location: $durl");

    if (open $ff,$ff) {
      print while <$ff>;
      print "\n";
      close $ff;
    }

    ccclog("receive $transfer#$tkey");
    exit;

  } else {
    error(405,"Unknown Request - Missing ID or TKEY");
  }

} elsif ($RM eq 'GET') {
  # 2nd request from send client asking for receiver files list

  &authentificate;

  if ($tkey) {
    $tdir = "$user/CCC/$transfer#$tkey";
    ccclog("send $transfer#$tkey");
  } else {
    exit;
  }

  if ($dox) {
    chdir "$user/DOX" or http_die("$user/DOX - $!");
    my $folder = $transfer;
    my $lfolder = readlink_($folder);
    my $sfolder = "$folder!stream";
    if (-d $sfolder) {
      $folder = $sfolder;
      if (-d $lfolder and mtime($lfolder) > mtime($sfolder)) {
        $folder = $lfolder;
      }
    }
    header('200 OK');
    if (chdir $folder) {
      foreach (asort(find('.'))) {
        s:^\./::;
        if ((-l or -f) and my @s = lstat) {
          # using ctime is a stupid idea because it is also creation time!
          # printf "%d %s\n",($s[10] > $s[9] ? $s[10] : $s[9]),$_;
          printf "%d %s\n",$s[9],hexencode($_);
        }
      }
    }
  } else {
    $ff = "$tdir/rfiles";

    for (;;) {
      sleep 2;
      last if -e $ff;
    }

    open $ff,$ff or error(500,"Cannot open $ff : $!");
    header('200 OK');
    print while <$ff>;
    print "\n";
    close $ff;
  }

  exit;

} else {
  error(405,"Unknown Request");
}

exit;


sub setparam {
  my ($v,$vv) = @_;

  $v = uc(despace($v));
  $vv = normalize($vv);
  # $param{$v} = $vv;
  if ($v eq 'DOX') {
    $dox = $v;
    $v = 'TRANSFER';
  }
  if ($v eq 'USER') {
    $user = normalize_user($vv);
  } elsif ($v eq 'ID') {
    $id = $vv;
  } elsif ($v eq 'TRANSFER') {
    $transfer = untaint($vv);
    $transfer =~ s/[^\w\@~^=:.,+-]/_/g;
    $transfer =~ s/^\./_/;
  } elsif ($v eq 'TKEY' and $vv =~ /^(\d+)$/) {
    $tkey = $1;
  }
}


sub ccclog {
  my $msg = "@_";

  $msg =~ s/\n/ /g;
  $msg =~ s/\s+$//;
  $msg = sprintf "%s [%s_%s] %s (%s) %s\n",
                  isodate(time),$$,$ENV{REQUESTCOUNT},$user,$fra,$msg;

  foreach my $log (@logdir) {
    if (open $log,'>>',"$log/ccc.log") {
      flock $log,LOCK_EX;
      seek $log,0,SEEK_END;
      printf {$log} $msg;
      close $log;
    }
  }
}


sub sigdie {
  local $_ = shift;
  chomp;
  sigexit('DIE',$_);
}


sub sigexit {
  my ($sig) = @_;
  my $msg = "@_";

  $msg =~ s/\n/ /g;
  $msg =~ s/\s+$//;
  $msg = sprintf "%s %s (%s) caught SIGNAL %s\n",
                 isodate(time),$user||'-',$fra||'-',$msg;

  foreach my $log (@logdir) {
    if (open $log,'>>',"$log/ccc.log") {
      flock $log,LOCK_EX;
      seek $log,0,SEEK_END;
      printf {$log} $msg;
      close $log;
    }
  }
  if ($sig eq 'DIE') {
    shift;
    die "@_\n";
  } else {
    die "SIGNAL @_\n";
  }
}


sub error {
  nvt_print("HTTP/1.0 @_");
  exit;
}


sub header {
  my ($status) = shift;

  nvt_print("HTTP/1.1 $status");
  nvt_print('Server: fexsrv');
  nvt_print('Expires: 0');
  nvt_print('Cache-Control: no-cache');
  nvt_print('Connection: close');
  nvt_print($_) foreach (@_);
  nvt_print('');
}


sub authentificate {
  my $rid;

  error(400,"Missing auth-ID") unless $id;
  $rid = readline1("$user/@") or error(400,"No auth-ID");
  if ($sid and $id =~ /^(MD5H:)/) {
    $rid = $1 . md5_hex($rid.$sid);
  }
  error(401,"Wrong auth-ID") if $rid ne $id;
}
