#! env perl
use strict;
use warnings;
# BEGIN { $ENV{IO_LAMBDA_DEBUG} = "select=2,io=2,lambda=2"; }
use Getopt::Long;
use Socket;
use IO::Socket;
use IO::Lambda qw(:all get_frame set_frame);
use IO::Lambda::Socket qw(:all);
use Net::MitDK;

my %opt = (
	port  => 110,
	addr  => '0.0.0.0',
	debug => 0,
	help  => 0,
	config => undef,
);

my $version = 0.01;

sub usage
{
	print <<USAGE;

$0

   --port      - listen on port, 110 by default
   --addr      - listen on address, 0.0.0.0 by default
   --debug     - debug on stderr
   --config    - location of directory where .mitdk configuration is stored
   --help

USAGE
	exit 1;
}

GetOptions(\%opt,
	"port|p=i",
	"addr|a=s",
	"config|c=s",
	"debug",
	"help|h",
) or usage;

$opt{help} and usage();

print "Listening on $opt{addr}:$opt{port}...\n";

my $conn_timeout = 30;
my $server = IO::Socket::INET-> new(
	Listen    => 5,
	LocalAddr => $opt{addr},
	LocalPort => $opt{port},
	Blocking  => 0,
	ReuseAddr => ($^O !~ /win32/i),
);
unless ($server) {
	my $err = $!;
	print STDERR <<ERR;
Cannot bind to socket: $! .
(Not running as root? Try an unprivileged port, -p 8111 for example)
ERR
	exit 1;
}

sub debug($)
{
	return unless $opt{debug};
	my $t = scalar localtime;
	warn "$t: $_[0]\n";
}

my $serv = lambda {
	context $server;
	accept {
		# incoming connection
		my $conn = shift;
		again;

		unless ( ref($conn)) {
			debug("accept() error:$conn") if !ref($conn);
			return;
		}
		$conn-> blocking(0);

       		my $hostname = inet_ntoa((sockaddr_in(getsockname($conn)))[1]);

		debug("[$hostname] connect");

		my $buf     = '';
		my $session = { hostname => $hostname };
		my $resp    = ok("POP3 server ready\x{a}");
		context writebuf, $conn, \$resp, length($resp), 0, $conn_timeout;
	tail {
		context readbuf, $conn, \$buf, qr/^([^\r\n]*)[\r\n]+/s, $conn_timeout;
	tail {
		my @frame = get_frame;
		my ( $match, $error) = @_;
		unless ( defined($match)) {
			debug("[$hostname] session error: $error");
			undef @frame; # circular refs!
			return close($conn);
		}
		substr( $buf, 0, length($match)) = '';
		my $resp = handle( $match, $session);
		context ref($resp) ? $resp : lambda {};
	tail {
		$resp = shift if ref $resp;
		$resp .= "\x{a}";
		context writebuf, $conn, \$resp, length($resp), 0, $conn_timeout;
	tail {
		if ($session->{quit}) {
			debug("[$hostname] QUIT");
			undef @frame; # circular refs!
			close($conn);
		} else {
			set_frame(@frame);
			again;
		}
	}}}}}
};

sub fail($) { "-ERR $_[0]" }
sub ok($) { "+OK $_[0]" }
sub multi
{
	my @msgs;
	my $comment = shift;
	for ( @_ ) {
		my $p = $_;
		$p .= ' ' if $p eq '.';
		push @msgs, $p;
	}
	return ok(join("\x{a}", $comment, @msgs, '.'));
}

sub remotefail($)
{
	debug($_[0]);
	fail("mit.dk says: $_[0]");
}

sub want_list
{
	my $session = shift;
	return lambda {
		return 1 if $session->{list};

		context $session->{obj}->list_all_messages;
	tail {
		my ( $list, $error ) = @_;
		unless ( $list ) {
			$session->{error} = $error;
			return 0;
		} else {
			$session->{list} = $list;
			return 1;
		}
	}};
}

sub pop3_capa
{
	multi("my caps",
		"USER", "UIDL", "TOP",
		"EXPIRE $conn_timeout", "IMPLEMENTATION Shlemazle-Plotz-v$Net::MitDK::VERSION/$version"
	)
}

sub pop3_user
{
	my ($session, $user) = @_;
	return fail("already authorized") if exists $session->{obj};

	my ( $obj, $error) = Net::MitDK->new(
		profile => $user, 
		( defined $opt{config} ) ? ( homepath => $opt{config} ) : (),
	);
	return fail($error) if defined $error;
	$obj->mgr->readonly(1); # the daemon runs as nobody

	$session->{obj} = $obj;
	return ok("hello");
}

sub pop3_pass
{
	my ($session, $pass) = @_;
	return lambda {
		context $session->{obj}->mailboxes;
	tail {
		my ( $json, $error ) = @_;
		unless (defined $json) {
			debug("[$session->{hostname}] $error");
			return remotefail($error)
		}
		$session->{authorized} = 1;
		debug("[$session->{hostname}] authorized");
		return ok("Welcome $json->{ownerName}");
	}};
}

sub pop3_quit
{
	my ($session) = @_;
	$session->{quit} = 1;
	return ok("bye");
}

sub pop3_stat
{
	my ($session) = @_;
	return fail("not authorized") unless $session->{authorized};
	return lambda {
		context want_list($session);
	tail {
		return remotefail($session->{error}) unless shift;

		my $sum = 0;
		$sum += $_->{fileSize} for
			map { @{ $_->{files}     } }
			map { @{ $_->{documents} } }
			@{ $session->{list} };
		return ok(@{$session->{list}} . ' ' . $sum);
	}};
}

sub msgsize
{
	my ( $session, $id ) = @_;
	my $sum = 0;
	$sum += $_->{fileSize} for map { @{ $_->{files} } } @{ $session->{list}->[$id]->{documents} };
	return $sum;
}

sub pop3_list
{
	my ($session, $id) = @_;
	return fail("not authorized") unless $session->{authorized};
	return lambda {
		context want_list($session);
	tail {
		return remotefail($session->{error}) unless shift;
		if ( defined $id) {
			return fail("bad command") unless $id =~ /^\d+$/;
			return fail("no such msg") if $id <= 0 || $id > @{$session->{list}};
			return ok($id . ' '. msgsize($session,$id-1));
		} else {
			return multi( @{$session->{list}} . " messages",
				(map { "$_ " . msgsize($session,$_-1) } (1..scalar @{$session->{list}})));
		}
	}}
}

sub pop3_uidl
{
	my ($session, $id) = @_;
	return fail("not authorized") unless $session->{authorized};
	return lambda {
		context want_list($session);
	tail { 
		return remotefail($session->{error}) unless shift;
		if ( defined $id) {
			return fail("no such msg") if $id <= 0 || $id > @{$session->{list}};
			return ok($id . ' '. $session->{list}->[$id-1]->{id});
		} else {
			return multi( @{$session->{list}} . " messages",
				(map { "$_ " . $session->{list}->[$_-1]->{id} } (1..scalar @{$session->{list}})));
		}
	}}
}

sub pop3_noop { ok('') }
sub pop3_dele { ok("not deleted, actually") }
sub pop3_rset { fail("not implemented") }
sub pop3_apop { fail("not implemented") }

sub pop3_retr
{
	my ( $session, $id ) = @_;
	return fail("bad argument") unless defined($id) && $id =~ /^\d+$/ && $id > 0;

	lambda {
		context want_list($session);
	tail {
		return remotefail($session->{error}) unless shift;
		return fail("bad argument") if $id > @{$session->{list}};
		context $session->{obj}->fetch_message_and_attachments( $session->{list}->[$id - 1] );
	tail {
		my ($attachments, $error) = @_;
		return remotefail($error) unless $attachments;
		my $msg = $session->{obj}->assemble_mail($session->{list}->[$id - 1], $attachments);
		return multi('message follows', split("\n", $msg));
	}}}
}

sub pop3_top
{
	my ( $session, $id, $lines ) = @_;
	return fail("bad argument") unless
		defined($id)      &&
		$id =~ /^\d+$/    &&
		$id > 0           &&
		defined($lines)   &&
		$lines =~ /^\d+$/ &&
		$lines > 0;

	lambda {
		context want_list($session);
	tail {
		return remotefail(shift) unless shift;
		return fail("bad argument") if $id > @{$session->{list}};
		context $session->{obj}->fetch_message_and_attachments( $session->{list}->[$id - 1] );
	tail {
		my ($attachments, $error) = @_;
		return remotefail($error) unless $attachments;
		my $msg = $session->{obj}->assemble_mail($session->{list}->[$id - 1], $attachments);
		my @lines = split("\n", $msg);
		splice(@lines, $lines);
		return multi('top of message follows', @lines);
	}}}
}

sub pop3__terminate { exit }

sub handle
{
	my ( $cmd, $session ) = @_;

	chomp $cmd;
	$cmd =~ s/^\s*//;
	$cmd =~ s/\s*$//;
	my @cmd = split(' ', $cmd);
	$cmd[0] //= '';
	$cmd[0] = uc $cmd[0];
	
	debug("[$session->{hostname}] @cmd") unless $cmd[0] =~ /^(USER|PASS)$/;

	my $msgs = 2;

	my $can = __PACKAGE__->can("pop3_\L$cmd[0]");
	return fail("bad command") unless $can;
	shift @cmd;
	return $can->($session, @cmd);
}

$serv-> wait;
