#!/client/bin/perl -w

# PUSSY - Perl User SAFT Server Yin

###################### user configuration section ###########################

$spool = "~/.sfspool";		# local spool
$maxfilesize = 100*2**20;	# a single file may not exceed 100 MB
$maxfiles = 1000;		# maximum number of files
$compress = "GZIP|BZIP2";	# accept gzip and bzip2 files
$deleting = 1;			# allow remote sender to delete his files

$firstport = 48700;		# first available port 
$lastport  = 48999;		# last available port 
$maxconnects = 5; 		# max # of concurrent connections

################### end of user configuration section #######################

$0 =~ s:.*/::;
$pussy = "PUSSY-19981213";
$configdir = $ENV{"HOME"}."/.sendfile";
$userspool = $ENV{"HOME"}."/.sfspool";

use 5.003;
use POSIX;
use IO::Socket;
use Getopt::Std;

$SIG{CHLD} = sub{wait()};

# parse CLI arguments
$opt_p = 0;
$opt_h = $opt_V = $opt_v = $opt_x = "";
if (!getopts('hVvxp:') || $opt_h) {
  print "usage: $0 [-v] [-x] [-p port]\n";
  print "options: -v       verbose mode\n";
  print "         -x       do not write SAFTport to \$HOME/.plan\n";
  print "         -p port  use this port to bind to\n";
  exit 2;
}

if ($opt_V) {
  print "$pussy\n";
  exit;
}  

$firstport = $lastport = $opt_p if $opt_p;
$base_socket = &init;

# main-loop
print "waiting for connection...\n" if $opt_v;
while ($sock = $base_socket->accept()) {
  $peername = gethostbyaddr($sock->peeraddr(),AF_INET);
  print "\nnew connection from $peername:\n" if $opt_v;
  $pid = fork();
  die "$0: cannot create subprocess: $!\n" unless defined($pid);
  if ($pid == 0) {
    select($sock);
    $| = 1;
    &handle_connection;
    exit;
  }
  close $sock;
}

exit;


#
# handle a SAFT connection (this is a subprocess!)
#
sub handle_connection {
  my @args;		# SAFT command arguments
  my $i;		# simple loop counter
  my $sn;		# spool number
  my $size = -1;	# file transfer size
  my $osize;		# file oroginal size
  my $type = "BINARY";	# file type
  my $comment;		# file comment
  my $transmitted;	# bytes which have been already transmitted

  # SAFT welcome message
  &reply(220);

  while (defined ($_ = <$sock>)) {

    # trim command line
    s/\r//;s/\n//;
    print ">$_<\n" if $opt_v;
    s/\s+/ /g;s/^ //;s/ $//;
    
    @args = split;
    
    if (/^HELP$/i) {
      &reply(214);
      next;
    }
    
    if (/^TO/i) {
      if ($args[1] eq ":NULL:") {
        $test = 1;
      } elsif ($args[1] ne $username) {
        &reply(520);
        exit;
      }
      &reply(200);
      next;
    }
    
    if (/^FROM/i) {
      if ($args[1]) {
        $from = "$args[1]\@$peername";
	for ($i = 2; $i<=$#args; $i++) { $from .= " ".$args[$i]; }
	&reply(430) if &restricted($from);
        &reply(200);
      } else {
        &reply(505);
      }
      next;
    }
    
    if (/^FILE/i) {
      if ($args[1]) {
        $file = $args[1];
        &reply(200);
      } else {
        &reply(505);
      }
      next;
    }
    
    if (/^SIZE/i) {
      if (!$args[2]) {
        &reply(505);
        next;
      }
      if ("$args[1]$args[2]" !~ /^\d+$/) {
        &reply(507);
        next;
      }
      $size = $args[1];
      $osize = $args[2];
      &reply(413) if $size > $maxfilesize;
      &reply(200);
      next;
    }
    
    if (/^TYPE/i) {
      if (!$args[1]) {
        &reply(505);
        next;
      }
      if (/^TYPE (BINARY|SOURCE|MIME|TEXT=[A-Z0-9_:-]+)( COMPRESSED(=($compress))?| CRYPTED(=PGP)?)?$/i) {
        s/TYPE //i;
        $type = uc $_;
        &reply(200);
      } else {
        &reply(507);
      }
      next;
    }
    
    if (/^DATE/i) {
      if (!$args[1]) {
        &reply(505);
        next;
      }
      if (/^DATE \d\d\d\d-\d\d-\d\d[ T]\d\d:\d\d:\d\d$/i) {
        s/DATE //i;s/T/ /i;
        $date = $_;
        &reply(200);
      } else {
        &reply(507);
      }
      next;
    }
    
    if (/^SIGN/i) {
      if (!$args[1]) {
        &reply(505);
        next;
      }
      $sign = $args[1];
      &reply(200);
      next;
    }
    
    if (/^ATTR/i) {
      if (!$args[1]) {
        &reply(505);
        next;
      }
      if (/^ATTR (TAR|EXE|NONE)$/) {
        $attr = $args[1] if $args[1] !~ /^NONE$/i;
        &reply(200);
      } else {
        &reply(507);
      }
      next;
    }
    
    if (/^COMMENT/i) {
      if (!$args[1]) {
        &reply(505);
        next;
      }
      s/^COMMENT //i;
      $comment = $_;
      &reply(200);
      next;
    }
    
    if (/^DEL$/i) {
      if (!$deleting) {
        &reply(502);
        next;
      }
      if (!$from || !$file) {
        &reply(503);
        next;
      }
      $transmitted = 0;
      if (&delfile($from,$file)) {
        &reply(200);
      } else {
        &reply(550);
      }
      next;
    }
    
    if (/^RESEND$/i) {
      if (!$from || !$file || $size<0) {
        &reply(503);
        next;
      }
      if ($test) {
        $transmitted = 0;
      } else {
        ($transmitted,$sn) = &received($from,$file,$size,$type);
      }
      &reply(230,$transmitted);
      next;
    }

    if (/^DATA$/i) {
      if (!$from || !$file || $size<0) {
        &reply(503);
        next;
      }
      if ($transmitted==$size) {
        &reply(531);
        next;
      }
      &reply(451) unless &receive($from,$file,$type,"$size $osize",
                                  $date,$attr,$sign,$comment,$sn,$transmitted);
      &reply(201);
      &logfile($from,$file,$date,$comment);
      $size = -1;
      $sn = $transmitted = 0;
      $type = "BINARY";
      $file = $sign = $comment = $attr = $date = "";
      next;
    }
    
    if (/^MSG/i) {
      &reply(511);
      next;
    }
    
    if (/^QUIT$/i) {
      &reply(221);
      exit;
    }
    
    &reply(500);
  }
}


#
# bind this server to a free port
#
# RETURN: server-socket 
#
sub init {
  my $warning = $^W;
  my $sock;
  my @plan;
  my $planfile = $ENV{"HOME"}."/.plan";

  $username = (getpwuid($<))[0];
  $hostname = &gethostname;
  
  $spool =~ s:^~/:$ENV{"HOME"}/:;
  unless (-d $spool) {
    mkdir $spool,0700 or die "$0: cannot create $spool : $!\n";
  }
  chdir $spool or die "$0: cannot change to $spool : $!\n";
  if ($spool ne $userspool && $spool ne (readlink $userspool or "")) {
    unlink $userspool; rmdir $userspool;
    symlink $spool, $userspool or 
      die "$0: cannot create symlink $userspool : $!\n";
  }
  
  $^W = 0;
  
  for ($port = $firstport; ;$port++) {
    die "$0: cannot bind to a free port: $!\n" if $port > $lastport;
    print "trying port $port\n" if $opt_v;
    $sock = new IO::Socket::INET(
	LocalHost	=> 'localhost',
	LocalPort	=> $port,
	Listen		=> $maxconnects,
	Proto		=> 'tcp',
	Reuse		=> 1);
    last if $sock;
  }

  $^W = $warning;
  
  warn "%$0-Info successfully installed on port $port\n";

  # if allowed, write SAFT-port to $HOME/.plan
  unless ($opt_x) {
    if (open F,$planfile) {
      @plan = <F>;
      close F;
      @plan = grep {  s/^\s*SAFTport\s*=.*$/SAFTport=$port/i or $_ } @plan;
    }
    push @plan,"SAFTport=$port\n" unless grep /^SAFTport=/, @plan;
  
    open F,">$planfile" or die "$0: cannot write $planfile : $!\n";
    print F @plan;
    close F;
  }
  
  %reply = (
    200 => "200 Command ok.",
    201 => "201 File has been received correctly.",
    202 => "202 Command not implemented, superfluous at this site.",
    203 => "203 *schnuffel* *schnuffel* =:3",
    205 => "205 Non-ASCII character in command line ignored.",
    214 => "214-The following commands are recognized:\r\n".
           "214-   FROM    <sender> [<real name>]\r\n".
           "214-   TO      <recipient>\r\n".
	   "214-   FILE    <name>\r\n".
           "214-   SIZE    <bytes to transfer> <original file size uncompressed>\r\n".
           "214-   TYPE    BINARY|SOURCE|MIME|TEXT=<character set name> [COMPRESSED|CRYPTED]\r\n".
           "214-   DATE    <ISO-8601 date & time string (UTC)>\r\n".
           "214-   SIGN    <pgp signature (armor)>\r\n".
           "214-   ATTR    TAR|EXE|NONE\r\n".
           "214-   COMMENT <file comment>\r\n".
           "214-   DEL\r\n".
           "214-   RESEND\r\n".
           "214-   DATA\r\n".
           "214-   QUIT\r\n".
           "214-All arguments have to be UTF-7 encoded.\r\n".
           "214 You must specify at least FROM, TO, FILE, SIZE and DATA to send a file.",
    215 => "215 $pussy",
    220 => "220 $username\@$hostname user SAFT server $pussy on port $port ready.",

    221 => "221 Goodbye.",
    230 => "230 %d bytes have already been transmitted.",
    231 => "231 %d bytes will follow",
    250 => "250 End of transfer.",
    260 => "260 DEBUG-OUTPUT",

    302 => "302 Header ok, send data.",
    331 => "331 challenge: %s",

    410 => "410 No access to spool directory (permission problems?).",
    411 => "411 Can't create user spool directory.",
    412 => "412 Can't write to user spool directory.",
    413 => "413 File quota exceeded.",
    414 => "414 Can't start spool postprocessing.",
    415 => "415 TCP error: received too few data.",
    421 => "421 Service currently not available.",
    430 => "430 You are not allowed to send to this user.",
    451 => "451 Requested action aborted: server error.",
    452 => "452 Insufficient storage space.",
    453 => "453 Insufficient system resources.",
    460 => "460 Authentication error.",
    490 => "490 Internal error.",

    500 => "500 Syntax error, command unrecognized.",
    501 => "501 Syntax error in parameters or arguments.",
    502 => "502 Command not implemented.",
    503 => "503 Bad sequence of commands.",
    504 => "504 Command not implemented for that parameter.",
    505 => "505 Missing argument.",
    506 => "506 Command line too long.",
    507 => "507 Bad argument.",
    #case 510: text="510 User has set a forward to xxx@yyy";
    511 => "511 This SAFT-server can only receive files.",
    512 => "512 This SAFT-server can only receive messages.",
    520 => "520 User unknown.",
    521 => "521 User is not allowed to receive files or messages.",
    522 => "522 User cannot receive messages.",
    530 => "530 Authorization failed.",
    531 => "531 This file has been already received.",
    532 => "532 This file is currently transfered by you within another process.",
    540 => "540 Secure mode enforced: you have to sign your files",
    541 => "541 Secure mode enforced: you have to encrypt your files",
    550 => "550 File not found.",
  );

  return $sock;
}


# 
# send SAFT reply string
#
# INPUT: reply-code-#
#        printf-parameters
#
sub reply {
  my $rc = shift;
  my $text;
  
  $text = $reply{$rc};
  $text = "599 Unknown error." unless $text;
  
  printf "$text\r\n",@_;

  # terminate on a fatal error
  exit 1 if $rc =~ /^4/;
}


#
# delete a file from spool
#
# INPUT: sender in form: user@host
#        file name
# 
# RETURN: number of deleted files
#
sub delfile {
  my $from = shift;
  my $file = shift;
  my $n;
  my $i;

  return 0 unless &scanspool;

  foreach $i (keys %spoolfiles) {
    if ($spoolfiles{$i}{"from"} eq $from &&
        $spoolfiles{$i}{"file"} eq $file) {
      $n++;
      unlink "$i.h","$i.d";
    }
  }
  
  return $n;
}


#
# check restriction file
#
# RETURN: 1 on no access, 0 on access ok
#
sub restricted {
  my $from = shift;

  if (open F,"$configdir/restrictions") {
    while (<F>) {
      chomp;
      s/#.*//;
      s/\s+/ /g;s/^ //;s/ $//;
      next unless / [bf]$/i;
      s/ [bf]$//i;
      # transform simplematch pattern to perl regexp
      $_ = quotemeta;
      s/\\\\/\\/;
      s/\\\*/.*/;
      s/\\\?/./;
      s/\\\[\\\^/[^/;
      s/\\\[/[/;
      s/\\\]/]/;
      return 1 if $from =~ /^$_$/i;
    }
  }
  close F;
  
  return 0;
}


#
# scan the spool header files
#
sub scanspool {
  my ($from,$file,$type,$size,$shf,$n);
  $n = 0;
  
  %spoolfiles = ();
  opendir SPOOL, "." or return 0;
  while (defined($shf = readdir SPOOL)) {
    next if $shf !~ /^(\d+)\.h$/;
    $n = $1;
    next unless -f "$n.d";
    $from = $file = $type = $size = "";
    open F, $shf or next;
    while (<F>) {
      chomp;
      if (/^FROM\t(.*)/) {
        $from = $1;
	next;
      }
      if (/^FILE\t(.*)/) {
        $file = $1;
	next;
      }
      if (/^TYPE\t(.*)/) {
        $type = $1;
	next;
      }
      if (/^SIZE\t(\d+)/) {
        $size = $1;
	next;
      }
    }
    close F;
    if (length $from && length $file && $type && $size) {
      $spoolfiles{$n} = { from => $from,
                          file => $file,
	                  type => $type,
	                  size => $size };
    }
  }
  closedir SPOOL;
  
  return ($n>0);
}


#
# find out how many bytes have been already transmitted
#
# INPUT: sender in form: user@host
#        file name
#        file size
#        file SAFT type
# 
# RETURN: number of already received bytes, spool number
#
sub received {
  my $from = shift;
  my $file = shift;
  my $size = shift;
  my $type = shift;
  my $i;

  return (0,0) unless &scanspool;
  
  foreach $i (keys %spoolfiles) {
    if ($spoolfiles{$i}{"size"} eq $size &&
        $spoolfiles{$i}{"file"} eq $file &&
        $spoolfiles{$i}{"from"} eq $from &&
        $spoolfiles{$i}{"type"} eq $type) {
      return ((stat "$i.d")[7],$i);
    }
  }
  return (0,0);
}	


#
# receive file data
#
sub receive {
  my $from = shift;
  my $file = shift;
  my $type = shift;
  my $sizes = shift;
  my $date = shift;
  my $attr = shift;
  my $sign = shift;
  my $comment = shift;
  my $sn = shift;
  my $transmitted = shift;
  my $size;
  my $bytes;
  my $bn;
  my $nblocks;
  my $n = 0;
  my $fd;
  my $buf;
  
  $size = $sizes;
  $size =~ s/ \d+//;
  
  use integer;
 
  unless ($test) {

    # known spool number: resume transfer
    if ($sn) {
      open D, ">>$sn.d" or return 0;
    } else {

      # find free spool file number
      for ($n=1; $n<=$maxfiles; $n++) {
        last if ($fd = POSIX::open("$n.h",O_CREAT|O_EXCL));
      }
      return 0 if !defined($fd) || $n == $maxfiles;
      POSIX::close($fd);
      #$status = fcntl(LF,F_SETLK,pack('ss4l',F_WRLCK,SEEK_SET,0,0,0,0));
  
      open H, ">$n.h" or return 0;
      open D, ">$n.d" or return 0;
  
      print H "FROM\t$from\n";
      print H "FILE\t$file\n";
      print H "TYPE\t$type\n";
      print H "SIZE\t$sizes\n";
      print H "DATE\t$date\n"		if $date;
      print H "ATTR\t$attr\n"		if $attr;
      print H "SIGN\t$sign\n"		if $sign;
      print H "COMMENT\t$comment\n"	if $comment;
      close H;
    
    }
  }
  
  &reply(302);
  
  $bytes = $size-$transmitted;
  $nblocks = $bytes/512;
  for ($bn=1; $bn<=$nblocks; $bn++) {
    &reply(415) if (read($sock,$buf,512) < 512);
    print D $buf unless $test;
  }

  if ($n = $bytes-$nblocks*512) {
    &reply(415) if (read($sock,$buf,$n) < $n);
    print D $buf unless $test;
  }
  
  close D unless $test;
  
  return 1;
}


#
# log file transfer
#
sub logfile {
  my $from = shift;
  my $file = shift;
  my $date = shift;
  my $comment = shift;
  my $entry;
  
  if (open F,">>$spool/log") {
    $entry =  "FROM\t$from\n".
              "FILE\t$file\n".
              "DATE\t$date\n";
    $entry .= "COMMENT\t$comment\n" if $comment;
    print F $entry,"\n";
    close F;
  }
}


#
# determine own hostname (FQDN)
#
sub gethostname {
  my $hostname;
  my $domain;
  
  $hostname = `hostname 2>/dev/null`;
  chomp $hostname;
  
  return "unknown" unless $hostname;
  
  if ($hostname !~ /\./ and open(F,"/etc/resolv.conf")) {
    while (<F>) {
      if (/^domain/ || /^search/) {
         $domain = (split)[1];
	last;
      }
    }
    close F;
    $hostname .= ".$domain";
  }

  return $hostname;
}
