#!/usr/bin/perl -w -T
# -*- perl -*-
# @configure_input@

BEGIN {
  # Close stderr, else inetd sends this back to the client.
  close STDERR;
};

use strict;

use Socket;
use IO::Socket;
use Sys::Hostname;
use Sys::Syslog qw(:DEFAULT setlogsock);

$ENV{PATH} = "/usr/bin:/bin";
delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};

my $spooldir = "@SPOOLDIR@";
my $user = "dlife";
my $server_version = "@VERSION@";
my $protocol_version = "1.0";
my $cells_uploaded = 0;
my $cells_downloaded = 0;
my $max_cells_upload_per_pass = 8;
my $max_cells_download_per_pass = 8;

my $hostname = hostname ();

# Open a connection to syslog.
setlogsock ("unix");
openlog ("dlife_server", "pid,ndelay", "user");

# Chroot into the spool directory and change our UID/GID so we are safe.
my ($login, $pass, $uid, $gid) = getpwnam ($user)
  or die "$user: user not found in password file";

chroot $spooldir or die "chroot $spooldir: $!";

$) = $gid;
$> = $uid;

die "could not change UID successfully: $!" unless $> == $uid && $) == $gid;

chdir "/store" or die "$spooldir/store: $!";

# Pull out connection information.
my $peername = getpeername STDIN;
my ($peerport, $peeraddr) = unpack_sockaddr_in ($peername);
my $peeraddrstring = inet_ntoa ($peeraddr);

my $peerhostname;

my $revhostname = gethostbyaddr ($peeraddr, AF_INET);
if ($revhostname)
  {
    my $ipaddr = gethostbyname ($revhostname);

    if ($ipaddr && inet_ntoa ($ipaddr) eq $peeraddrstring)
      {
	$peerhostname = $revhostname;
      }
  }

# Log connection information.
syslog ("info", "received connection from $peeraddrstring:$peerport" .
	($peerhostname ? " ($peerhostname)" : ""));

$| = 1;

# Send greeting to client.
print "DLIFE SERVER $server_version $protocol_version\r\n";

# Loop, waiting for commands from the client.
for (;;)
  {
    alarm 60;
    $_ = <STDIN>;

    # Remove trailing \r\n.
    s/[\r\n]+$//;

    if (/^HELO\s+(.*)\s+(.*)$/)
      {
	do_HELO_command ($1, $2);
      }
    elsif (/^STOR$/)
      {
	do_STOR_command ();
      }
    elsif (/^RETR$/)
      {
	do_RETR_command ();
      }
    elsif (/^QUIT$/)
      {
	print "200 Goodbye.\r\n";
	last;			# Exit the loop.
      }
    else
      {
	# Unknown command. Return an error message.
	print "500 Unknown command.\r\n";
      }
  }

exit 0;

sub do_HELO_command
  {
    my $remote_hostname = shift;
    my $remote_client_version = shift;

    syslog ("info", "client software version: $remote_client_version");

    # Do nothing with this information for now.
    print "200 Hello.\r\n";
  }

sub do_STOR_command
  {
    if ($cells_uploaded > $max_cells_upload_per_pass)
      {
	print "500 Too many cells uploaded in this pass.\r\n";
	return;
      }

    print "100 OK. Send the cell, terminated by . <CR> <LF> on a line of its own.\r\n";

    # Read in the cell.
    my $cell = "";

    while (length ($cell) < 8192)
      {
	alarm 10;
	$_ = <STDIN>;
	alarm 0;

	s/[\n\r]*$//;

	last if $_ eq ".";

	$cell .= $_ . "\n";
      }

    # Save the cell to a file.
    my $rand = int (rand 1000000000);
    open CELL, ">$rand.dlo" or die "$rand.dlo: $!";

    print CELL $cell;

    close CELL;

    syslog ("info", "received cell $rand.dlo");

    $cells_uploaded ++;
    print "200 Cell uploaded OK.\r\n";
  }

sub do_RETR_command
  {
    if ($cells_downloaded > $max_cells_download_per_pass)
      {
	print "500 Too many cells downloaded in this pass.\r\n";
	return;
      }

    # Find a cell at random.
    my @cells = glob_cells ();
    if (@cells == 0)
      {
	print "400 I have no cells to send you. Try again later.\r\n";
	return;
      }

    my $r = rand @cells;
    my $cell_filename = $cells[$r];

    unless (open CELL, "<$cell_filename")
      {
	print "400 Another process grabbed that cell before I could send it. Try again.\r\n";
	return;
      }

    # Send it.
    print "100 OK. Sending you a cell now.\r\n";

    syslog ("info", "sending cell $cell_filename");

    while (<CELL>)
      {
	s/[\n\r]+$//;
	print $_, "\r\n";
      }

    close CELL;

    unlink $cell_filename;

    print ".\r\n";

    $cells_downloaded ++;
    print "200 Finished sending the cell.\r\n";
  }

# This function is equivalent to glob ("*.dlo"), except that
# the glob function doesn't work when tainting is enabled, alas.
sub glob_cells
  {
    opendir DIR, "." or die "$spooldir/store: $!";
    my @names = map { untaint_string ($_) } grep { /\.dlo$/ } readdir DIR;
    closedir DIR;
    return @names;
  }

sub untaint_string
  {
    my $s = shift;
    $s =~ /^(.*)$/;
    return $1;
  }