#!/usr/bin/perl -w
# stubmail library.  does things with mail store and fetching into user mbox

# (c) 2003, 2004 Julian Haight,     http://www.julianhaight.com/
# All Rights Reserved under GPL:    http://www.gnu.org/licenses/gpl.txt
# Current version available here:   http://www.stubmail.com/

# Version history
# 4/8/2006 V1.
# based on salter V1.4.

package Stubmail;
use strict;

use Net::DNS;
use Digest::MD5;
use Time::HiRes;
use IO::Socket::INET;
use Socket;
use Convert::Bencode;
use IPC::Open2;
use CGI;
use LWP;
use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);

my($EOL) = "\015\012";
my($GPG) = '/usr/bin/gpg';
my($TMP) = '/var/tmp';
my($SRV_PORT) = 2225; # port to listen for udp commands
sub srvPort { return $SRV_PORT; } 
my($DEF_KEY_LEN) = 4096; # default key length when auto-generating one
my($UDP_WAIT) = 3; # num seconds to wait for udp responses from sender server
my($PER_SEC) = 10; # num of udp queries to make per second
my($resolver) = new Net::DNS::Resolver;
my($ua) = new LWP::UserAgent;
$ua -> agent("Stubmail");
my(%cookies);

# to be nice, use a mime-type in our multipart/form-data submissions
# probably not really necessary, but seems like the Right Thing To Do
my(%MIME_TYPES) = (# invented this mime type for md5, not official
		   'md5' => 'application/x-md5-digest',
		   # these were in my /etc/mime.types
		   'data' => 'application/pgp-encrypted',
		   'sig' => 'application/pgp-signature',
		   'request' => 'text/plain',
		   'mode' => 'text/plain'
		   );


sub acceptsStubs {
    my(@srvs, $email);
    ($email) = @_;
    unless ((@srvs) = (getSRVs('_stub._udp.' . getDom($email)))) {
	print STDERR "No results from SRV query\n";
	return ();
    }
    return (@srvs);
}

sub getTXTs {
    return getRRs($_[0], 'TXT');
}

sub getSRVs {
    return getRRs($_[0], 'SRV');
}

sub getRRs {
    my($dom, $type, @srvs, $query, $rr);

    ($dom, $type) = @_;
    if ($query = $resolver->query($dom, $type)) {
	foreach $rr ($query->answer) {
	    if ($rr->type eq $type) {
		if ($rr->string =~ 
		    m/^\S+\s+\d+\s+\S+\s+\S+\s*\"?([^\"]*)\"?$/) {
		    push(@srvs, $1);
		}
	    }
	}
    }
    return (@srvs);
}

sub getDom {
    my($email) = @_;
    unless ($email =~ m/^[^\@]+\@([^\@]+)$/) {
	return undef();
    }
    return $1;
}

sub makeKey {
    my($name, $email, $message, $keyid, $params);
    ($email, $message) = @_;
    if ($message =~ m/From: ([^\<]+)\</) {
	$name = $1;
    } else {
	$name = "Name not provided";
    }
	
    $params = '
Key-Type: 1
Key-Length: ' . $DEF_KEY_LEN . '
Name-Real: ' . $name . '
Name-Comment: http://example.com/captcha_goes_here
Name-Email: ' . $email . '
';
    unless (open(CMD, "|$GPG --gen-key --batch")) {
	print STDERR "Cannot open $GPG: $!\n";
	return undef();
    }
    print CMD $params;
    close CMD;
}

sub getKeyID {
    return getKeyIDLocal(@_) || getKeyIDNet(@_);
}

sub getKeyIDLocal {
    my($email, $keyid);
    ($email) = @_;
    unless (open(CMD, "$GPG --list-keys --keyid-format=long $email|")) {
	print STDERR "Cannot open $GPG: $!\n";
	return undef();
    }
    while ($keyid = <CMD>) {
	if ($keyid =~ m/pub\s*[^\/]+\/([0-9a-fA-F]+)\s/) {
	    $keyid = $1;
	    last;
	}
    }
    return $keyid || undef();
}


sub getKeyIDNet {
    my($email, $keyid, $key, @keysvrs, $req, $res, $srv, $port, $url);
    ($email) = @_;
    unless ((@keysvrs) = (getSRVs('_pks._tcp.' . getDom($email)))) {
	print STDERR "Canot find SRV for pks server for " . $email . "\n";
	return undef();
    }
    
    unless ($keysvrs[0] =~ 
	    m/^\d+\s+\d+\s+(\d+)\s+(\S*)/) {
	print STDERR "Cannot parse SVR record for pks server: $keysvrs[0]\n";
	return undef();
    }
    $port = $1; $srv = $2;
    $url = ('http://' . $srv . ':' . $port . 
	    '/pks/lookup?op=index&exact=on&options=mr&search=' . 
	    CGI::escape($email));
    $req = new HTTP::Request(GET => $url);
    $res = $ua->request($req);
    unless ($res->is_success) {
	print STDERR "HTTP request to $url failed: " . 
	    $res->status_line . "\n";
	return undef();
    }
    $keyid = $res->content;
    if ($keyid =~ m/pub:([0x0-9A-Fa-f]+)/) {
	$keyid = $1;
    } elsif ($keyid =~ m/no matching keys/i) {
	return undef();
    } else {
	print STDERR "Cannot parse keyserver response $url: $keyid\n";
	return undef();
    }
    
    # if we get here, means we didn't have local copy, get one
    recvKeys($keyid, $srv); 
    return getKeyIDLocal(@_);
#    return $keyid;
}

sub recvKeys { # wrapper around gpg function --recv-keys
    my($keyid, $server, $ex);
    ($keyid, $server) = @_;
    print STDERR "recvKeys $server, $keyid\n";
    system($GPG, '--keyserver', $server, '--recv-keys', $keyid);
    $ex = $? >> 8;
    if ($ex > 1) {
	print STDERR "$GPG exited with status: $ex\n";
    }
}
    
sub getKey { # for what? we don't know.  just push into gpg keyring..
    # http://www.julianhaight.com:11371/pks/lookup?op=get&search=0xFF2C1596
    my($req, $res, $srv, $port, $keyid, $key);
    $req = new HTTP::Request
	(GET => ('http://' . $srv . ':' . $port .
		 '/pks/lookup?op=get&options=mr&search=0x' . $keyid));
    $res = $ua->request($req);
    unless ($res->is_success) {
	print STDERR "HTTP request to keyserver failed: " . 
	    $res->status_line . "\n";
	return undef();
    }
    $key = $res->content;
    return $key;
}

sub fetchMail {
    my($s, $r, $mbox, $pair, %pairs);
    ($mbox) = @_;
    foreach $s (getSenders()) {
	foreach $r (getRecipients()) {
	    $pairs{"$s $r"} = 1;
	}
    }
    foreach $pair (mightHaveMail(keys(%pairs))) {
	print "checking for mail: $pair\n";
	intoMaildir(split(/ /, $pair), $mbox);
    }
}

sub mightHaveMail {
    my($s, $r, $host, $port, $sock, $ipaddr, $portaddr, $start, %might, @have,
       @pairs, $pair, $rr, $msg, $rval);

    (@pairs) = @_;

    $sock = new IO::Socket::INET(Proto => 'udp', Blocking => 0);
    
    foreach $pair (@pairs) {

	unless (cookie($pair)) {
	    print "No cookie for pair: $pair\n";
	    next;
	}
	($s, $r) = split(/\s/, $pair);
	$might{cookie($pair)} = $pair;

	# Make new udp socket and send cookie to each host
	foreach $rr (getSRVs("_stub._udp." . getDom($s))) {
	    # ignore port spec, use service port only
	    $rr =~ m/\d+\s\d+\s(\d+)\s(\S+)/;
	    $port = $1; $host = $2;
	    $portaddr = sockaddr_in($port, inet_aton($host));
	    print "Sending " . cookie($pair) . " to $host:$port\n";
	    $sock->send(cookie($pair), 0, $portaddr);
	}
    }
    
    $start = time();
    sleep($UDP_WAIT);  # todo: better timeout system
    while ($portaddr = $sock->recv($msg, 4096, 0)) {
	$msg =~ m/([0-9a-f]+)\:([01e])/;
	$rval = $2; $msg = $1;
	print "got msg: $msg ($rval)\n";
	
	if ($rval eq 0) {
	    # no mail for us confirmed
	    delete($might{$msg});
	}
    }
    (@have) = values(%might);
    return (@have);
}

sub intoMaildir {
    my($r, $s, $msgs, $msgid, $msg, $mbox);
    ($s, $r, $mbox) = @_;
    # TODO suppress dup msgids
    $msgs = getMessageIDs($s, $r);
    foreach $msgid (keys(%{$msgs})) {
	print "Fetch msgid: $msgid\n";
	$msg = getMessage($msgs->{$msgid});
	if ($msg) {
	    open(MBOX, ">>$mbox") || die "Error opening $mbox for append: $!";
	    print MBOX 'From <' . $s . '> ' . 
		scalar(localtime()) . $EOL . 
		$msg;
	    if (close(MBOX)) {
		rmMessage($msgs->{$msgid});
	    }
	}
    }
}

sub getRecipients {
    return getEmails('--list-secret-keys');
}

sub getSenders {
    return getEmails('--list-public-keys');
}

sub getEmails {
    my($mode) = @_;
    my($line, @emails);
    foreach $line (`$GPG $mode --keyid-format=long`) {
	if ($line =~ m/^uid.*\<([^\>]+)\>/) {
	    push(@emails, $1);
	}
    }
    return (@emails);
}

sub rmMessage {
    my($path, %params);
    ($path) = @_;
    (%params) = ('mode' => 'rm');
    if (postBinary($path, Digest::MD5::md5_hex(time()), \%params)) {
	return 1;
    }
    return undef();
}

sub getMessage {
    my($path, $message, %params);

    ($path) = @_;

    (%params) = ('mode' => 'get');

    if ($message = postBinary($path, Digest::MD5::md5_hex(time()), \%params)) {
	return decryptMessage($message);
    }
    return undef();
}

sub decryptMessage {
    my($msg, $cmd);

    ($msg) = @_;
    $cmd = "$GPG --trust-model always --decrypt";

    unless (open2(*RCMD, *WCMD, $cmd)) {
	print STDERR "Cannot open $cmd: $!\n";
	return undef();
    }
    print WCMD $msg;
    close(WCMD);
    
    $msg = join('', <RCMD>);
    close RCMD;
    return $msg;
}

# cookies are stored as "sender@example.com recip@example.com" => "cookie"
# on recip side or "cookie" => "??" on sender side
sub cookie {
    my(%cookies, $key, $val);
    ($key, $val) = @_;
    dbmopen(%cookies, '/tmp/stubmail_cookies', 0600) || return undef();
    if ($val) {
	$cookies{$key} = $val;
    } else {
	$val = $cookies{$key};
    }
    dbmclose(%cookies);
    return $val;
}

sub getMessageIDs {
    my($sender, $recip, $rkid, $skid, %params, %req, $beparams, $md5, 
       $path, $req, $res, $rr, $port, $host, $prefix, $cookie, 
       $msgid, $msgids);

    ($sender, $recip) = @_;

    # fetch old or make new cookie for sender/recip pair
    $cookie = (cookie("$sender $recip") ||
	       cookie("$sender $recip", sprintf("%8x", int(rand(2**32)))));
    $rkid = getKeyID($recip); $skid = getKeyID($sender);

    %params = (mode => 'getMessageIDs',
	       time => time(),
	       since => 0,
	       skid => $skid,
	       rkid => $rkid,
	       sender => $sender,
	       recip => $recip,
	       cookie => $cookie);
    $beparams = Convert::Bencode::bencode(\%params);
    %req = ('mode' => 'signedrequest',
	    'request' => $beparams,
	    'sig' => signData($rkid, $beparams));

    # look for mail on all send servers (hopefully not too many)
    foreach $rr (getTXTs("_post._tcp." . getDom($sender))) {
	$rr =~ m/\d+\s\d+\s(\d+)\s(\S+)\s(\S+)/;
	($port, $host, $prefix) = ($1, $2, $3);
	
	$path = 'http://' . $host . ':' . $port .'/' . $prefix . '/' . 
	    $skid . '/' . $rkid . '/';
	
	if ($res = postBinary($path . '*', 
			      Digest::MD5::md5_hex($beparams), \%req)) {
	    foreach $msgid (split(/\n/, $res)) {
		$msgids->{$msgid} = $path . $msgid;
	    }
	}
    }
    return ($msgids);
}

sub signData {
    my($cmd, $sign, $skid, $data);

    ($skid, $data) = @_;
    $cmd = "$GPG --trust-model always --detach-sign -u $skid";
    
    unless (open2(*RCMD, *WCMD, $cmd)) {
	print STDERR "Cannot open $cmd: $!\n";
	return undef();
    }
    print WCMD $data;
    close(WCMD);

    $sign = join('', <RCMD>);
    close RCMD;
    return $sign;
}

sub checkSig {
    my($cmd, $req, $sig, $sigf, $verify, $rkid, $recip);
    ($req, $sig, $rkid, $recip) = @_;
    $sigf = "/tmp/stubmail_$$.sig";

    if (getKeyID($recip) ne $rkid) {
	print STDERR "KeyID check failure in checkSig\n";
	return 0;
    }

    open(SIG, ">$sigf") || die "$!";
    print SIG $sig;
    close(SIG);

    $cmd = 
	"$GPG --trust-model always --keyid-format=long --verify $sigf - 2>&1";
    
    unless (open2(*RCMD, *WCMD, $cmd)) {
	print STDERR "Cannot open $cmd: $!\n";
	return 0;
    }
    print WCMD $req;
    close(WCMD);

    $verify = join('', <RCMD>);
    close RCMD;
    unlink($sigf);
    $verify =~ m/key\s([A-F0-9]+)\s+gpg:\s(BAD|Good)\ssignature\sfrom/;
    return (($1 eq $rkid) && ($2 eq 'Good'));
    
    # FIXME for now, we just pretend all sigs are good - ack!
    return 1;
}

sub saveStubMail {
    my($sender, $recip, $message, $filename, $path, $prefix, $bit, $msgid,
       $skid, $rkid, $cmd, $host, $port, $rr);

    ($sender, $recip, $message) = @_;

    unless ($skid = getKeyID($sender)) {
	makeKey($sender, $message);
	$skid = getKeyID($sender);
    }
    unless (($skid) && (($rkid = getKeyID($recip)))) {
	print STDERR "Cannot find keyid for sender and recipient\n";
	return undef();
    }
    # both keys should be in our local keyring at this point
    $cmd = "$GPG --trust-model always --encrypt --sign -u $skid -r $rkid";
    unless (open2(*RCMD, *WCMD, $cmd)) {
	print STDERR "Cannot open $cmd: $!\n";
	return undef();
    }
    print WCMD $message;
    close(WCMD);

    $message = join('', <RCMD>);
    
    $msgid = Digest::MD5::md5_hex(Time::HiRes::time());

    print join("\n", getTXTs("_post._tcp." . getDom($sender))) . "\n";
    foreach $rr (sort srvSort (getTXTs("_post._tcp." . getDom($sender)))) {
	$rr =~ m/\d+\s\d+\s(\d+)\s(\S+)\s(\S+)/;
	($port, $host, $prefix) = ($1, $2, $3);
	$path = 'http://' . $host . ':' . $port .'/' . $prefix . 
	    $skid . '/' . $rkid . '/' . $msgid;
	print STDERR "RR: $rr\nPath: $path\n";
	if (saveUrl($path, $message)) {
	    print STDERR "Saved to send-server for $recip ($rkid)\n";
	    return 1;
	}
    }
    return undef();
}

sub srvSort {
    my($aval, $bval);
    $a =~ m/^(\d+)\s(\d+).*/; $aval = "$1.$2";
    $b =~ m/^(\d+)\s(\d+).*/; $bval = "$1.$2";
    return ($aval <=> $bval);
}

sub postBinary {
    my($path, $params, $mime, $sep, $name, $value, $text, $type, $req, $res);
    ($path, $sep, $params) = @_;

    foreach $name (keys(%{$params})) {
	unless ($type = $MIME_TYPES{$name}) {
	    print STDERR "No mime type coded for field name: $name\n";
	    $type = 'text/plain';
	}
	if (index($params->{$name}, $sep) >= 0) { 
	    print STDERR "Key collision on $name param ($sep), unthinkable!\n";
	    return undef();
	}
	$mime .= 
	    ('--' . $sep . $EOL .
	     'Content-Disposition: form-data; name="' . $name . '"' . $EOL .
	     'Content-Transfer-Encoding: binary' . $EOL .
	     'Content-type: ' . $type . $EOL .
	     'Content-length: ' . length($params->{$name}) . $EOL . $EOL .
	     $params->{$name} . $EOL);
    }
    $mime .= '--' . $sep . '--' . $EOL;
    $req = new HTTP::Request(POST => $path);
    $req->content_type('multipart/form-data');
    $req->content($mime);
    $res = $ua->request($req);
    unless ($res->is_success) {
	print STDERR "Http error: $path" . $res->status_line . "\n";
	return undef();
    }
    if ($res->content) {
	return $res->content;
    } else {
	return '';
    }
}

sub saveUrl {
    my($path, $message, %req, $md5, $md5_bin);

    ($path, $message) = @_;
    $md5 = Digest::MD5::md5_hex($message);
    $md5_bin = pack("H32", $md5);

    %req = ('mode' => 'put',
	    'md5' => $md5_bin,
	    'data' => $message);
    
    return postBinary($path, $md5, \%req);
}

# in the future we can send only the keyid of the sender and the recipient
# avoiding overflowing the udp packet

# this is obsolete anyway, we're going to send stubs only to listening
# clients who already have cookies.

sub sendStub {
    my(%fields, $recip, $pri, $weight, $host, $port, $sock);
    (%fields) = @_;

    $recip = $fields{'r'};
    
    foreach $host (getHosts("_stub._udp." . getDom($recip))) {
	($pri, $weight, $host, $port) = split(/\s/, $host);
	print STDERR "sending stub to $host:$port\n";
	$sock = new IO::Socket::INET->new(Proto    => 'udp',
					  PeerPort => $port,
					  PeerAddr => $host);
	$sock->send(Convert::Bencode::bencode(\%fields));
	$sock->close();
    }
}

1;