#!/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 = 2**10;		# maximum number of files
$compress = 'GZIP|BZIP2';	# accept gzip and bzip2 files
$deleting = 1;			# allow remote sender to delete his files
$mailnotify = 1;		# notify new files by mail (you may also
				# assign a string like 'framstag@belwue.de')

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

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

$0 =~ s:.*/::;
$HOME = $ENV{'HOME'};
$pussy = 'PUSSY-19990818';
$sendmail = '/usr/lib/sendmail -t';
$configdir = $HOME.'/.sendfile';
$userspool = $HOME.'/.sfspool';

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

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

# parse CLI arguments
$opt_p = 0;
$opt_I = $opt_h = $opt_V = $opt_v = $opt_x = '';
if (!getopts('IhVvxp:') || $opt_h) {
  print "usage: $0 [-I] [-v] [-x] [-p port]\n";
  print "options: -I       print instructions\n";
  print "         -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;
}  

&instructions if $opt_I;

$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;
    $notify = '';
    &handle_connection;
    if ($notify) {
      warn "%$0-Info received files:\n".$notify;
      &sendmail if $mailnotify;
    }
    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 original size
  my $type = 'BINARY';	# file type
  my $comment;		# file comment
  my $transmitted;	# bytes which have been already transmitted

  # SAFT welcome message
  &reply(220);

  while (<$sock>) {

    # trim command line
    s/\r//;s/\n//;
    warn ">$_<\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.' ('.join(' ',@args[2..$#args]).')';
	&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;
      }
      &receive($from,$file,$type,"$size $osize",
               $date,$attr,$sign,$comment,$sn,$transmitted) or &reply(451);
      &reply(201);
      &logfile($from,$file,$date,$comment);
      $notify .= "$from : $file\n";
      $size = -1;
      $sn = $transmitted = 0;
      $type = "BINARY";
      $file = $sign = $comment = $attr = $date = "";
      next;
    }
    
    if (/^MSG/i) {
      &reply(511);
      next;
    }
    
    if (/^QUIT$/i) {
      &reply(221);
      return;
    }
    
    &reply(500);
  }
}


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

  $username = getpwuid $< or die "$0: cannot determine own username : $!\n";
  $hostname = &gethostname;
  
  $spool =~ s:^~/:$HOME/:;
  unless (-d $spool) {
    mkdir $spool,0700 or die "$0: cannot create $spool : $!\n";
  }
  chdir $spool or die "$0: cannot cd 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;
  local $_;

  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);
  local $_;
  
  %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+//;
 
  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;
  local $_;
  
  $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;
}


sub sendmail {
  if (open P,'|'.$sendmail) {
    if ($mailnotify =~ /[a-z]/i)
      { print P "To: $mailnotify\n" }
    else
      { print P "To: $username\n" }
    print P "Subject: PUSSY receive report\n\n";
    print P $notify,".\n";
    close P;
  }
}


sub instructions {
  print <<EOD;
This is $pussy : Perl User SAFT Server Yin

If you do not know what SAFT means, please first read 
http://www.belwue.de/belwue/software/saft/index.html

PUSSY is for users which can not install the regular SAFT server sendfiled
on port 487 for which reasons ever. You do not need root privileges.

On starting pussy binds itself to the first free tcp port between
$firstport and $lastport and logs this port to your \$HOME/.plan file.
This file will be printed if any user starts a so called finger request at
you (normally by "finger USER\@HOST"). This user then can send you files by
specifying the URL saft://HOST:PORT/USER, e.g.: 
sendfile rabbit.jpg saft://bofh.belwue.de:48700/framstag

The received files will be stored in the spool \$HOME/.sfspool and can be
retrieved by the regular receive program from the sendfile package, see
ftp://ftp.belwue.de/pub/unix/sendfile.tar.gz
EOD
  exit;
}