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

use strict;

use Getopt::Long;
use LWP::UserAgent;
use Socket;
use IO::Socket;
use Sys::Hostname;
use Sys::Syslog qw(:DEFAULT setlogsock);

my $help;
my $verbose;
my $config_filename = "@CONFDIR@/client.conf";
my $spooldir = "@SPOOLDIR@";
my $client_version = "@VERSION@";

GetOptions ("help|?" => \$help,
	    "verbose" => \$verbose,
	    "config=s" => \$config_filename,
	    "spooldir=s" => \$spooldir);

if ($help)
  {
    print STDERR <<EOF;
dlife_client.pl [--help] [--verbose] \
                [--spooldir=spooldir] [--config=config_file]

Options:
  --help               Displays this help text.
  --verbose            Lots of messages.
  --spooldir=spooldir  Set spool directory (default is @SPOOLDIR@).
  --config=config_file Use named configuration file (default is to use
                       @CONFDIR@/client.conf).
EOF
  exit 1;
  }

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

syslog ("info", "version $client_version starting [conf=$config_filename, spool=$spooldir]");

# Default configuration values.
my $server_url;
my @server_zones = ();
my @servers = ();
my $max_cells_upload_per_pass = 6;
my $max_cells_download_per_pass = 4;

# Read configuration file.
open CONFIG, "<$config_filename" or die "$config_filename: $!";

while (<CONFIG>)
  {
    s/[\n\r]*$//;
    next if /^\s*\#/;
    next if /^\s*$/;

    if (/^\s*server_url\s+(\S+)\s*$/)
      {
	$server_url = $1;
	print "server_url=$server_url\n" if $verbose;
      }
    elsif (/^\s*server_zone\s+(.*)\s*$/)
      {
	@server_zones = split /\s+/, $1;
	print "server_zones=", join (" ", @server_zones), "\n" if $verbose;
      }
    elsif (/^\s*server\s+(.*)\s*$/)
      {
	@servers = split /\s+/, $1;
	print "servers=", join (" ", @servers), "\n" if $verbose;
      }
    elsif (/^\s*max_cells_upload_per_pass\s+([1-9][0-9]*)\s*$/)
      {
	$max_cells_upload_per_pass = $1;
      }
    elsif (/^\s*max_cells_download_per_pass\s+([1-9][0-9]*)\s*$/)
      {
	$max_cells_download_per_pass = $1;
      }
    else
      {
	die "unknown configuration option: $_";
      }
  }

close CONFIG;

# Load @server_zones into a hash for rapid searching.
my %server_zones;
foreach (@server_zones) { $server_zones{$_} = 1; }

# Server URL set or @servers not empty?
unless ($server_url || @servers)
  {
    die "neither server_url and servers was set: cannot do anything";
  }

# Go to spool directory.
chdir $spooldir or die "$spooldir: $!";

# Find the list of cells to upload and arrange into a random order.
my @all_upload_cells = randomize_list (glob_outgoing ());

unless (@all_upload_cells)
  {
    syslog ("info", "no cells to upload (is the dlife_soup process running?)");
    exit;
  }

# Only upload the first few cells.
my @upload_cells = @all_upload_cells;
splice @upload_cells, $max_cells_upload_per_pass;

# If server URL set, then go and download the webpage. Load appropriate
# server names into @servers.
if ($server_url)
  {
    syslog ("info", "contacting $server_url");
    print "Contacting $server_url\n" if $verbose;

    my $ua = LWP::UserAgent->new;
    my $req = HTTP::Request->new ("GET", $server_url);
    my $rep = $ua->request ($req);

    if ($rep->is_success)
      {
	print "Fetched page. Parsing page ...\n" if $verbose;

	# Parse the page.
	my @lines = split /[\n\r]+/, $rep->content;

	foreach (@lines)
	  {
	    if (/^\s*server\s+(\S*)\s+(.*)\s*$/)
	      {
		my $server = $1;
		my @zones = split /\s+/, $2;

		# Is this server in one of our zones?
		if (@server_zones)
		  {
		    foreach (@zones)
		      {
			if (exists $server_zones{$_})
			  {
			    push @servers, $server;
			    last;
			  }
		      }
		  }
		else
		  {
		    push @servers, $server;
		  }
	      }
	  }

	print "Finished parsing page. \@servers = ",
	  join (" ", @servers), "\n"
	  if $verbose;
      }
    else
      {
	syslog ("error", "could not contact $server_url");
	print "Could not contact server.\n" if $verbose;
      }
  }

# Sort the server list into a random order.
@servers = randomize_list (@servers);

# Contact each server in turn until we succeed with one of them.
my $server;

foreach $server (@servers)
  {
    alarm 0;

    print "Attempting to connect to $server port 5904\n" if $verbose;
    syslog ("info", "exchanging cells with $server");

    my $socket = new IO::Socket::INET (PeerAddr => $server,
				       PeerPort => "5904",
				       Proto => "tcp");

    unless ($socket)
      {
	syslog ("error", "could not connect to $server");
	print "Failed to connect.\n" if $verbose;
	next;
      }

    print "Connected.\n" if $verbose;

    # Read server and protocol version.
    alarm 60;
    $_ = $socket->getline;

    unless (/^DLIFE SERVER\s+([0-9]+\.[0-9]+)\s+([0-9]+\.[0-9]+)/)
      {
	print "Unrecognized server greeting.\n" if $verbose;
	next;
      }

    my $server_version = $1;
    my $protocol_version = $2;

    # The only protocol we recognize right now is version 1.x. These
    # x (minor) revisions will be backwards compatible. If an
    # incompatibility is introduced in the future, then that will
    # become version 2.x, 3.x, etc.
    unless ($protocol_version =~ /^1\./)
      {
	print "Unsupported protocol version.\n" if $verbose;
	next;
      }

    # Send our client greeting string.
    $socket->print ("HELO - $client_version\r\n");

    # Wait for OK response.
    alarm 60;
    $_ = $socket->getline;

    unless (/^2[0-9][0-9]\s/)
      {
	print "Error response from server during HELO.\n" if $verbose;
	next;
      }

    # Check for cells to upload, and upload the first few.
    my $cell_filename;

    foreach $cell_filename (@upload_cells)
      {
	print "Uploading $cell_filename ...\n" if $verbose;

	$socket->print ("STOR\r\n");

	# Wait for OK to send response.
	alarm 60;
	$_ = $socket->getline;

	unless (/^1[0-9][0-9]\s/)
	  {
	    print "Error response from server during STOR.\n" if $verbose;
	    next;
	  }

	# Send the cell.
	open CELL, "<$cell_filename" or die "$cell_filename: $!";

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

	close CELL;

	$socket->print (".\r\n");

	# Wait for OK response from server.
	alarm 60;
	$_ = $socket->getline;

	unless (/^2[0-9][0-9]\s/)
	  {
	    print "Error response from server after STOR.\n" if $verbose;
	    next;
	  }
      }

    # Remove all upload cells in the queue.
    foreach $cell_filename (@all_upload_cells)
      {
	unlink $cell_filename;
      }

    # Check for cells to download.
    for (my $i = 0; $i < $max_cells_download_per_pass; ++$i)
      {
	print "Downloading ...\n" if $verbose;

	$socket->print ("RETR\r\n");

	# Wait for OK to retrieve response.
	alarm 60;
	$_ = $socket->getline;

	unless (/^1[0-9][0-9]\s/)
	  {
	    print "Error response from server during RETR.\n" if $verbose;
	    next;
	  }

	# Retrieve the cell.
	my $cell = "";

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

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

	    last if $_ eq ".";

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

	# Wait for OK response.
	alarm 60;
	$_ = $socket->getline;

	unless (/^2[0-9][0-9]\s/)
	  {
	    print "Error response from server after RETR.\n" if $verbose;
	    next;
	  }

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

	print CELL $cell;

	close CELL;
      }

    print "Disconnecting ...\n" if $verbose;

    # Say goodbye.
    $socket->print ("QUIT\r\n");

    # Wait for OK response from server.
    alarm 60;
    $_ = $socket->getline;

    unless (/^2[0-9][0-9]\s/)
      {
	print "Error response from server during QUIT.\n" if $verbose;
	next;
      }

    # Close socket.
    $socket->close;

    alarm 0;
    last;
  }

syslog ("info", "exit");

exit;

sub randomize_list
  {
    for (my $i = 0; $i < @_; ++$i)
      {
	my $r = int (rand (@_ - $i));

	if ($r > 0)
	  {
	    # Swap elements $i and $i+$r.
	    my $t = $_[$i+$r];
	    $_[$i+$r] = $_[$i];
	    $_[$i] = $t;
	  }
      }

    return @_;
  }

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

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