#!/usr/bin/perl -w
#
# umtp:
# The Unreliable Mail Transfer Protocol.
#
# Small email messages may reasonably be compressed and transmitted in UDP
# packets, short-circuiting long SMTP transaction delays. Obviously such a
# protocol is unreliable, and must be shadowed by real delivery over SMTP,
# with duplicates discarded at a higher protocol level.
#
# Usage:
#   umtp send host port recipient
#       Send a message supplied on standard input to the named recipient,
#       transmitting it to the given host:port. If the message is too large
#       (greater than 8k compressed) or if there is an error, returns failure.
# 
#   umtp receive host port
#       Receive email on the given host and port, and pass it to the local MTA.
#
# To prevent the possibility of unauthorised relaying, umtp employs a
# shared-secret authentication mechanism. For transmission or reception, umtp
# reads the secret from ~/.umtp/secret, which should not be readable or
# writable by others. The shared secret is used to authenticate packets as
# described below.
#
# umtp writes its PID in ~/.umtp/pid and logs messages in ~/.umtp/log.
#
# Packet structure:
#
#  length     element
#  ---------- -------------------------------------------------------------
#  2          length of whole packet, in network order
#  varies     0-terminated email address of recipient
#  varies     gzip'd data for content of email
#  16         MD5 checksum of secret followed by the content of the packet,
#             excluding the checksum
#
# Copyright (c) 2002 Chris Lightfoot. All rights reserved.
# Email: chris@ex-parrot.com; WWW: http://www.ex-parrot.com/~chris/
#

my $rcsid = '$Id: umtp,v 1.18 2002/07/23 13:05:15 chris Exp $';

$maxpktlen = 1472;  # Fragmented UDP Packets Don't Work.
$maxsecret = 8192;
$sendmail = `which sendmail`;
chomp $sendmail;

$mode = '';

use FileHandle;
use POSIX;
use IO::File;
use IO::Pipe;
use IO::Socket;
use Compress::Zlib;
use Digest::MD5;
use Fcntl ':flock';

@foo = uname;
$pidfile = "$ENV{HOME}/.umtp/pid.$foo[1]";

$log = undef;

# log_start:
# Switch on logging.
sub log_start () {
    $log = new IO::File("$ENV{HOME}/.umtp/log", O_WRONLY | O_CREAT | O_APPEND) or die "~/.umtp/log: $!";
    $log->autoflush(1);
}

# log_print:
# Print something to the log.
sub log_print (@) {
    $log->print(scalar(localtime), " umtp $mode" ."[$$]: ", @_, "\n");
}

# Get die to emit a normal Unixish error message.
$SIG{__DIE__} = sub {
        my $a = shift;
        $a =~ s/ at .* line \d.*//;
        chomp $a;
        if ($log) {
            log_print("$a; aborting");
        } else {
            print STDERR "umtp: $a\n";
        }
        unlink $pidfile if ($mode eq 'receive');
        exit(1);
    };

die "not enough arguments" unless (@ARGV);
die "no ~/.umtp directory" unless (-d "$ENV{HOME}/.umtp");

$mode = shift(@ARGV);

# obtain secret
$g = new IO::File("$ENV{HOME}/.umtp/secret", O_RDONLY) or die "~/.umtp/secret: $!";
$secret = '';
$g->read($secret, $maxsecret);
$g->close();

# my_open2 READ WRITE COMMAND
# Fork and run COMMAND, returning its PID and making READ and WRITE into
# IO objects for reading its standard output and writing its standard input
# respectively.
sub my_open2 ($$@) {
    my ($rd, $wr, $cmd) = @_;
    my $p1 = new IO::Pipe;
    my $p2 = new IO::Pipe;
    my $pid = fork();
    if ($pid == 0) {
        # child.
        close(STDIN);
        close(STDOUT);
        $p1->writer;
        $p2->reader;
        POSIX::dup2($p1->fileno, 1);
        POSIX::dup2($p2->fileno, 0);
        exec("/bin/sh", "-c", $cmd);
    } elsif ($pid > 0) {
        # parent.
        $p1->reader;
        $_[0] = $p1;
        $p2->writer;
        $_[1] = $p2;
        return $pid;
    } else {
        return undef;
    }
}

# daemonise
# Become a daemon process. From perlipc(3).
sub daemonise {
   chdir '/'                    or die "chdir(/): $!";
   open STDIN, '/dev/null'      or die "/dev/null: $!";
   open STDOUT, '>/dev/null'    or die "/dev/null: $!";
   defined(my $pid = fork)      or die "fork: $!";
   exit if $pid;
   setsid                       or die "Can't start a new session: $!";
   open STDERR, '>/dev/null'    or die "/dev/null: $!";
}

# make_packet RECIPIENT DATA
# Generate a packet to transmit, for sending to RECIPIENT. DATA is the
# uncompressed form of the email.
sub make_packet ($$) {
    my ($recip, $data) = @_;

    # Go through the email, ditching Received: lines.
    my (@lines) = split("\n", $data);
    my $cdata;
    my ($rflag, $bflag) = (0, 0);
    foreach (@lines) {
        if (/^Received:/i) {
            $rflag = 1;
        } elsif (/^[^\s]/) {
            $rflag = 0;
        }
        $bflag = 1 if (/^$/); # end of headers
        
        $cdata .= "$_\n" if ($bflag || !$rflag);
    }

    $cdata = Compress::Zlib::memGzip($cdata);
    
    my $pkt = '';
    $pkt = pack('n', length($recip) + 1 + length($cdata) + 16);
    $pkt .= "$recip\0$cdata";
    my $dig = Digest::MD5::md5($secret . $pkt);
    $pkt .= $dig;
    return $pkt;
}

# parse_packet PACKET
# Break PACKET into its constituents, check its length and checksum, and if
# they are OK, return the recipient and email data in list context.
sub parse_packet ($) {
    my ($pkt) = @_;
    my $len = unpack('n', substr($pkt, 0, 2));
    if ($len != length($pkt) - 2) {
        log_print("length in packet does not match");
        return ();
    }
    # check digest
    my $dig = Digest::MD5::md5($secret . substr($pkt, 0, length($pkt) - 16));
    if ($dig ne substr($pkt, length($pkt) - 16, 16)) {
        log_print("digest in packet does not match");
        return ();
    }
    my ($recip) = (substr($pkt, 2) =~ /([^\0]+)/);
    my $cdata = substr($pkt, 2 + length($recip) + 1, length($pkt) - 2 - 1 - length($recip) - 16);

    my $data = "X-Via: umtp\n" . Compress::Zlib::memGunzip($cdata);
    
    return ($recip, $data);
}

if ($mode eq 'receive') {
    die "call as umtp receive host port" if (@ARGV != 2);
    ($host, $port) = @ARGV;
    
    daemonise;
    log_start;

    $f = new IO::File($pidfile, O_RDWR | O_CREAT) or die "$pidfile: $!";
    if (!flock($f, LOCK_EX | LOCK_NB)) {
        $pid = $f->getline;
        chomp($pid);
        die "~/.umtp/pid: could not lock; probably umtp is already running with PID $pid";
    }
    $f->autoflush(1);
    $f->seek(0, SEEK_SET);
    $f->truncate(0);
    $f->print("$$\n");

    $s = new IO::Socket::INET(LocalAddr => "$host:$port", Proto => "udp") or die "$host:$port: $!";

    do {
        $pkt = '';
        $s->recv($pkt, $maxpktlen, 0);
        @foo = parse_packet($pkt);
        if (@foo) {
            log_print("received packet length " . length($pkt) . " deliver to $foo[0]; email length " . length($foo[1]));

            # Actually deliver the message.
            my_open2($rd, $wr, "$sendmail -i $foo[0]") or die "sendmail: $!";
            $rd->close();
            $wr->print($foo[1]);
            $wr->close();
            wait;
        } else {
            log_print("received bogus packet length " . length($pkt));
        }
    } while (1);

    $f->close;
} elsif ($mode eq 'send') {
    die "call as umtp send host port recipient" if (@ARGV != 3);
    ($host, $port, $recip) = @ARGV;

    log_start;

    @lines = <STDIN>;

    # Possibly discard BSD mail folder separator.
    shift @lines if ($lines[0] =~ /^From /);
    
    $data = join('', @lines);

    log_print("email length " . length($data) . " to send to $recip via $host:$port");
    
    $pkt = make_packet($recip, $data);
    if (length($pkt) > $maxpktlen) {
        log_print("packet length " . length($pkt) . " is too long");
        exit 1;
    } else {
        log_print("packet length is " . length($pkt));
        $s = new IO::Socket::INET(PeerAddr => "$host:$port", Proto => "udp") or die "$host:$port: $!";
        $s->print($pkt) or die "send: $!";
        $s->close();
        exit 0;
    }
} else {
    die "unknown mode $mode";
}