#!/usr/bin/perl -w
# Salter single-threaded email address salter

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

my($VERSION) = 'V1.8';

# Version history

# 13 apr 2010 V1.8
# remove test code with my email hotmail/yahoo addresses

# 15 apr 2008 V1.7
# fixed support for !@#$ obsolete domainkeys, tested against Y!
# fixed chop bug - truncated last char of mapped address on re-use

# 26 Sep 2007 V1.6
# add wordlist support, for less-salty tasting random addresses

# 30 Jan 07 V1.5
# add dkim and domain keys signing

# 3/2/05 V1.4
# add more verbose status reporting

# 2/10/05 V1.3
# fixed bug related to unavailable smtp/regex

# 7/19/04 V1.2
# added stripsender feature
# fixed missing newline between header & body

# 3/26/04 V1.1
# cleaned up smtp sending code, added envonly mode, added version

# 3/12/04
# give each recipient their own, permanent random virtual sender
# move config to user-dir, not /etc.

# 9/29/03 - changed to use only lowercase-alpha, avoid spam filters
#  Also, added final response after quit (worked without for pine, but not moz)

use strict; use Socket; use FileHandle; use Digest::MD5;

my($CONFIG) = ($ENV{HOME} . '/.salter'); 
my($MAPFN) = "$CONFIG/map.txt";
my($EOL) = "\015\012";
my($debug) = 0;
my($SMTPTO) = 10; # 10 second timeout
my($DKIMSELECT) = 'mail';
my(@wordlist);

my($SAMP) = ' 

# here is a sample config file:

listenport	2525
listenip	127.0.0.1
sendport	25
sendip		your_isps_mailserver.example.com
maxclient	5
# 1 for unsafe but fast!, 0 for slow & steady (not yet available)
buffermode      1
# 1 remaps only envelope, not header, good if you want to filter bad bounces
envonly         0
# 1 strips sender field (for pine or whatever)
stripsender     1
# if missing, will use short (but good) internal list
wordlist        ~/.salter/wordlist.txt

#               From this address       To random @ this domain!
#               -----------------       ------------------------
remap	        you@example.com         salty.you.example.com
remap	        other@example.com       foo.example.com

# to set your identity per-recipient (email or part)
# -  use workplace address for work recipients
hardwire        workplace.example.com  you@workplace.example.com
# -  use mailing list subscription address when posting to list.
hardwire        list1@ml.example.com    listsubaddr@example.com

# if present for salted domain,
# salter will sign with dkim, using dkim selector "mail"
dkim.salty.you.example.com              ~/.salter/dkim_priv_key
dkim.foo.example.com                    ~/.salter/dkim_priv_key
dkim.example.com                        ~/.salter/dkim_priv_key

# end sample config!
';

my(%config, %remap, %map, %hardwire);
unless (-e $CONFIG) { mkdir($CONFIG); }
readConfig(); # read the config file into %config
readMap();
if (($config{wordlist}) && (-e $config{wordlist})) { 
    readWordList($config{wordlist}); 
} else {
    defaultWordList();
}

listenLoop(); # work 'til you die!
exit 0;

# listen for one connection at a time, and call the proxy for each one.
# die if there are errors
sub listenLoop {
    my($cliaddr, $cliip, $cliport);
    socket(SOCK, PF_INET, SOCK_STREAM, getprotobyname('tcp')) || 
	die "Socket: $!";
    setsockopt(SOCK, SOL_SOCKET, SO_REUSEADDR, pack('l', 1)) ||
	die "Setsockopt: $!";
    bind(SOCK, sockaddr_in($config{'listenport'}, 
			   inet_aton($config{'listenip'}))) ||
			   die "bind: $!";
    listen(SOCK, $config{'maxclient'}) || 
	die "listen: $!";
    print STDERR "Listening on $config{'listenip'}:$config{'listenport'} Outbound on $config{'sendip'}:$config{'sendport'}\n";
    while ($cliaddr = accept(CLI, SOCK)) {
#	print STDERR "got connection\n";
	($cliport, $cliip) = (sockaddr_in($cliaddr));
	CLI->autoflush(1);
	if ($_ = proxyIt(\*CLI)) {
	    print STDERR "<< 550 Proxy error: $_\n";
	}
    }
}

sub proxyIt {
   my($CLI) = @_;
   my($cmds, $head, $body, $cmd, $msgid);
   $body = '';
   $cmds = ''; 
   unless ($config{buffered}) {
       print $CLI "500 No safe delivery mode yet, sorry!$EOL";
       close($CLI);
       die "No safe mode yet, sorry!";
   }
   # read smtp
   print $CLI "220 localhost SMTP pretender: salter $VERSION $EOL";
   while ($cmd = <$CLI>) {
       $cmds .= $cmd || '';
       if (lc($cmd) eq "data$EOL") { last; }
       if (lc(substr($cmd, 0, 4)) eq 'ehlo') {
#	   print $CLI "451 EHLO is so, so complicated$EOL";
	   print $CLI "250 Buffering$EOL";
       } else {
	   print $CLI "250 Buffering$EOL";
       }
   }
   print $CLI "354 Ready for data$EOL";
   # read head
   while ($cmd = <$CLI>) {
       if ($cmd eq $EOL) { last; }
       if ((!$config{stripsender}) || ($cmd !~ m/^sender:/i)) {
	   $head .= $cmd;
       }
   }
   # read body
   while ($cmd = <$CLI>) {
       if ($cmd eq ".$EOL") { last; }
       $body .= $cmd;
   }
   while ($CLI && print $CLI "250 Buffering$EOL") {
       $cmd = <$CLI>;
       $cmds .= $cmd;
       if (lc($cmd) eq "quit$EOL") { last; }
   }
   print $CLI "221 Bye bye, hopefully it'll work!$EOL";
   close $CLI;
   if ($head =~ m/message-id: (\S+)/i) { $msgid = $1; }
   print "Accepted message $msgid\n";
   deliverAll($cmds, $head, $body);
   return undef();
}

sub deliverAll {
    my($cmds, $head, $body) = @_;
    my($recipmap, $message, $line, $remap, $recip, $sender, 
       $sremap, $sremap_dom, $cmd, $val, $S,
       @recips, $from);
    while ($cmds =~ m/([^:\n]*): ?\<?([^\>\n]*[^\s\>])?\>?/g) {
	$cmd = lc($1); $val = $2;
	if ($cmd eq 'mail from') {
	    $sender = $val;
	} elsif ($cmd eq 'rcpt to') {
	    $recip = $val;
	    $remap = getRecipMapping($recip);
	    push(@{$recipmap->{$remap}}, $recip);
	}
    }
    while ($_ = smtpOpen(*S)) {
	print STDERR "Cannot open smtp: $_, sleeping..\n";
	sleep(3);
    }
    foreach $remap (keys(%{$recipmap})) {
	$message = 'X-Mailer-Addon: Salter ' . $VERSION . 
	    ' http://www.julianhaight.com/salter' . $EOL . $head;
	$_ = $recipmap->{$remap};
	$sremap = $sender;
	(@recips) = (@$_);
	foreach $from (keys(%remap)) {
	    if ($remap =~ m/\@/) {
		unless ($config{envonly}) {
		    $message = replace($message, $from, $remap);
		}
		$sremap = replace($sremap, $from, $remap);
	    } else {
		unless ($config{envonly}) {
		    $message = replace($message, $from, 
				       $remap . '@' . $remap{$from});
		}
		$sremap = replace($sremap, $from, 
				  $remap . '@' . $remap{$from});
	    }
	}
	unless ($sremap) {
	    print STDERR "sender $sender not remapped\n";
	    $sremap = $sender;
	}
	$message .= $EOL . $body;

	if ($sremap =~ m/\@(.*)$/) {
	    $sremap_dom = $1;
	}
	if ( $config{ 'dkim.' . $sremap_dom } ) {
	    $message = signDomainKeys($message, $sremap_dom);
	    $message = signDkim($message, $sremap_dom);
	}
	if (($_ = smtpEnvelope(\*S, $sremap, @recips)) ||
	    ($_ = smtpData(\*S, $message))) {
	    print STDERR ("Failed to send: $_ saving in $CONFIG/failed.txt");
	    open (SAVE, ">>$CONFIG/failed.txt");
	    print SAVE $message;
	    close(SAVE);
	} else {
	    print "Message delivered: $sremap -> @recips\n";
	}
    }
    smtpClose(\*S);
}

sub signDkim {
    require Mail::DKIM::Signer;
    my($dkim, $message, $domain, $sig, $sigtxt, $dktxt);
    ($message, $domain) = @_;
    if (!-e $config{'dkim.' . $domain}) {
	print STDERR "dkim private key for $domain is missing\n";
	return $message;
    }
    $dkim = new Mail::DKIM::Signer
	(Algorithm => 'rsa-sha1',
	 Domain => $domain,
	 Selector => $DKIMSELECT,
	 Method => 'relaxed',
	 KeyFile => $config{'dkim.' . $domain});
    $dkim -> PRINT($message);
    $dkim->finish_body();
    $sig = $dkim->signature();
    $sigtxt = $sig->as_string();
    return $sigtxt . $EOL . $message;
}

sub signDomainKeys {
    require Mail::DomainKeys::Message;
    require Mail::DomainKeys::Key::Private;
    my($mail, $key, $head, @body, $message, $domain, $sigtxt);
    ($message, $domain) = @_;
    if (($_ = index($message, $EOL . $EOL)) >=0) {
	$head = substr($message, 0, $_);
	(@body) = (substr($message, $_));
    } else {
	die "Cannot find head/body split for DomainKeys";
    }
    $mail = load Mail::DomainKeys::Message
	(HeadString => $head,
	 BodyReference => \@body) ||
	 die "Unable to load message";
    $key = load Mail::DomainKeys::Key::Private
	(File => $config{'dkim.' . $domain}) ||
	die "unable to load key";
    $mail->sign(Method=>'simple',
		Selector=>$DKIMSELECT,
		Private => $key,
		Method => 'nofws', # yahoo requires nofws
		SignHeaders => 'Date:From:Subject:To');
    $sigtxt = 'DomainKey-Signature: ' . $mail->signature->as_string;
    return $sigtxt . $EOL . $message;
}

sub randWords {
    my($len) = @_; # no. of words to pick
    my($txt, $i);
    for ($i=0; $i < $len; $i++) {
	$txt .= $wordlist[int(rand() * $#wordlist)];
    }
    return $txt;
}

# no longer used
sub randSecret {
    my($len) = @_;
    my($char, $pass, $i);
    for ($i=0; $i < $len; $i++) {
	$char = int(rand() * 26);
	$char += 97;
	$pass .= pack('c', $char);
    }
    return $pass;
}

sub readConfig {
    my($line);
    my($fn) = "$CONFIG/salter.conf";
    unless (-e $fn) {
	print STDERR "Salter not configured.  Please create $fn.  Sample:
$SAMP
";
	exit 1;
    }
    open (CONFIG, $fn) || die "$fn $!";
    while ($line = <CONFIG>) {
	if ($line =~ m/^([^\#;\s]\S+)\s*(\S+)\s*(\S*).*$/) {
	    if ($1 eq 'remap') {
		$remap{$2} = $3;
	    } elsif ($1 eq 'hardwire') {
		$hardwire{$2} = $3;
	    } else {
		$config{$1} = $2;
	    }
	}
    }
}

sub getSenderMapping {
    my($addr) = lc(@_);
    return $remap{$addr}
}

sub getRecipMapping {
    my($addr) = lc($_[0]);
    my(@parts, $part);
    # exact match
    if ($part = $hardwire{$addr}) {
	return $part;
    }
    # domain match
    (@parts) = (getDomParts($addr));
    while (@parts) {
	if ($part = $hardwire{join('.', @parts)}) {
	    return $part;
	}
	pop(@parts);
    }
    # default randomizer
    return getMapping($addr);
}

sub getDomParts {
    my($addr) = @_;
    my($dom, @parts);
#    print "getDomParts $addr\n";
#    print hexDump($addr) . "\n";
    if ($addr =~ m/[^\@]*\@(.*)/) {
#    if ($addr =~ m/^\s*[^\@\s]+\@([^\@\s]+)\s*$/) {
	$dom = $1;
	(@parts) = (split(/\./, $dom));
    }
#    print STDERR "parts: @parts ($dom)\n";
    return (@parts);
}
    

sub getMapping {
    my($addr) = @_;
    my($hash) = Digest::MD5::md5_base64($addr);
    my($rand);
    unless ($rand = $map{$hash}) {
	$map{$hash} = ($rand = (randWords(2) . int(rand() * 99)));
	writeMap($hash, $rand);
    }
#    print "getMapping $addr = $rand\n";
    return ($rand);	
}

sub writeMap {
    open(MAP, ">>$MAPFN") || return 1;
    print MAP join(' ', @_) . "\n";
    close(MAP);
}

sub readMap {
    my($line);
    my($key, $val);
    unless (-e $MAPFN) {
	print STDERR "Starting hashed recip map in $MAPFN\n";
    } elsif (open (MAP, $MAPFN)) {
	while (($key, $val) = split(' ', <MAP>)) {
	    $map{$key} = $val;
	}
    } else {
	die "Error opening $MAPFN for read: $!";
    }
    close(MAP);
}

sub replace {
    my($text, $old, $new) = @_;
    my($loc, $len);
#    print "text: $text\n";
    if (index($new, $old) >= 0) { return $text; }
    $len = length($old);
    $loc = index($text, $old);
    while ($loc >= 0) {
	$text = substr($text, 0, $loc) . $new . substr($text, $loc + $len);
	$loc = index($text, $old);
    }
#    print "replaced $old with $new in text: $text\n";
    return $text;
}

sub errlog {
    print STDERR "@_\n";
}

sub hexDump {
    my($string) = @_;
    my($size) = 15;
    my($char, $rval, $hex, $str, $asc);
    foreach $char (split('', $string)) {
	$asc = unpack('C', $char);
	if (($asc < 32) || ($asc > 176)) {
	    $char = '?';
	    $hex .= sprintf('%.2x<', $asc);
	} else {
	    $hex .= sprintf('%.2x ', $asc);
	}
	$str .= $char;
	if (length($str) >= $size) {
	    $rval .= $hex . $str . "\n";
	    $hex = ''; $str = '';
	}
    }
    if ($hex) {
	$hex .= (' ' x (($size*3) - length($hex)));
	$rval .= $hex . $str . "\n"
    }
    $rval = substr($rval, 0, length($rval)-1);
    return $rval;
}

sub readWordList {
    my($file) = @_;
    my($line);
    print "reading $file\n";
    open(IN, $file) || die "$file $!";
    (@wordlist) = ();
    while ($line = <IN>) {
	chomp($line);
	push(@wordlist, $line);
	print "$line\n";
    }
    close(IN);
}

sub defaultWordList {
    # http://ogden.basic-english.org/words.html (omiting operations)
    (@wordlist) = qw{
account act addition adjustment advertisement agreement air amount
amusement animal answer apparatus approval argument art attack attempt
attention attraction authority back balance base behavior belief birth
bit bite blood blow body brass bread breath brother building burn
burst business butter canvas care cause chalk chance change cloth coal
color comfort committee company comparison competition condition
connection control cook copper copy cork cotton cough country cover
crack credit crime crush cry current curve damage danger daughter day
death debt decision degree design desire destruction detail
development digestion direction discovery discussion disease disgust
distance distribution division doubt drink driving dust earth edge
education effect end error event example exchange existence expansion
experience expert fact fall family father fear feeling fiction field
fight fire flame flight flower fold food force form friend front fruit
glass gold government grain grass grip group growth guide harbor
harmony hate hearing heat help history hole hope hour humor ice idea
impulse increase industry ink insect instrument insurance interest
invention iron jelly join journey judge jump kick kiss knowledge land
language laugh law lead learning leather letter level lift light limit
linen liquid list look loss love machine man manager mark market mass
meal measure meat meeting memory metal middle milk mind mine minute
mist money month morning mother motion mountain move music name nation
need news night noise note number observation offer oil operation
opinion order organization ornament owner page pain paint paper part
paste payment peace person place plant play pleasure point poison
polish porter position powder power price print process produce profit
property prose protest pull punishment purpose push quality question
rain range rate ray reaction reading reason record regret relation
religion representative request respect rest reward rhythm rice river
road roll room rub rule run salt sand scale science sea seat secretary
selection self sense servant shade shake shame shock side sign
silk silver sister size sky sleep slip slope smash smell smile smoke
sneeze snow soap society son song sort sound soup space stage start
statement steam steel step stitch stone stop story stretch structure
substance sugar suggestion summer support surprise swim system talk
taste tax teaching tendency test theory thing thought thunder time tin
top touch trade transport trick trouble turn twist unit use value
verse vessel view voice walk war wash waste water wave wax way weather
week weight wind wine winter woman wood wool word work wound writing
year angle ant apple arch arm army baby bag ball band basin basket
bath bed bee bell berry bird blade board boat bone book boot bottle
box boy brain brake branch brick bridge brush bucket bulb button cake
camera card cart carriage cat chain cheese chest chin church circle
clock cloud coat collar comb cord cow cup curtain cushion dog door
drain drawer dress drop ear egg engine eye face farm feather finger
fish flag floor fly foot fork fowl frame garden girl glove goat gun
hair hammer hand hat head heart hook horn horse hospital house island
jewel kettle key knee knife knot leaf leg library line lip lock map
match monkey moon mouth muscle nail neck needle nerve net nose nut
office orange oven parcel pen pencil picture pig pin pipe plane plate
plough plow pocket pot potato prison pump rail rat receipt ring rod
roof root sail school scissors screw seed sheep shelf ship shirt shoe
skin skirt snake sock spade sponge spoon spring square stamp star
station stem stick stocking stomach store street sun table tail thread
throat thumb ticket toe tongue tooth town train tray tree trousers
umbrella wall watch wheel whip whistle window wing wire worm able acid
angry automatic beautiful black boiling bright broken brown cheap
chemical chief clean clear common complex conscious cut deep dependent
early elastic electric equal fat fertile first fixed flat free
frequent full general good great grey gray hanging happy hard healthy
high hollow important kind like living long male married material
medical military natural necessary new normal open parallel past
physical political poor possible present private probable quick quiet
ready red regular responsible right round same second separate serious
sharp smooth sticky stiff straight strong sudden sweet tall thick
tight tired true violent waiting warm wet wide wise yellow young awake
bad bent bitter blue certain cold complete cruel dark dead dear
delicate different dirty dry false feeble female foolish future green
ill last late left loose loud low mixed narrow old opposite public
rough sad safe secret short shut simple slow small soft solid special
strange thin white wrong
};
}

# (C) 2002, 2003 Julian Haight.  All rights reserved
# original sendmail 1.21 by Christian Mallwitz.
# Modified and 'modulized' by ivkovic@csi.com
# totally mangled by julian
# adapted for salter 3/13/04

sub smtpSend {
    my($message, $fromaddr, @recips) = @_;
    
    unless ($message) {
	errlog ("Refusing to send empty email $fromaddr -> @recips");
	return undef();
    }		    
    if ($debug) { errlog("trying smtpSend"); }
	
    # now, isn't that pretty?
    if (($_ = smtpOpen(\*S)) ||
	($_ = smtpEnvelope(\*S, $fromaddr, @recips)) ||
	($_ = smtpData(\*S, $message)) ||
	($_ = smtpClose(\*S))) {
	return ("smtpSend:" . $_);
    } else {
	return undef();
    }
}

sub smtpOpen {
    my($fh) = @_;
    my($k, $proto, $smtpaddr);
    ($smtpaddr) = (gethostbyname($config{sendip}))[4];
    
    my $save_w = $^W;
    local $/;
    $/ = "\015\012";
    
    $proto = (getprotobyname('tcp'))[2];
    unless (defined($smtpaddr)) {
	return ("smtpOpen: smtp host unknown:'" . $config{sendip} . "'");
    }
    # open socket and start mail session
    if (!socket($fh, AF_INET, SOCK_STREAM, $proto)) {
        return ("smtpOpen: socket failed ( $! )");
    }

    # connect
    if (!connect($fh, pack('Sna4x8', AF_INET, $config{sendport}, $smtpaddr))) {
	if ($! eq 'Interrupted system call') {
	    return "smtpOpen: timeout after $SMTPTO seconds during connect";
	} else {
	    return ("smtpOpen: connect to smtp server failed ($!)");
	}
    }
    my($oldfh) = select($fh); $| = 1; select($oldfh);
    if (($_ = smtpExchange($fh)) !~ m/^[23]/) {
        return ("smtpOpen: smtpsend connection error from smtp server ($_)");
    }
    if (($_ = smtpExchange($fh, "HELO Salter" . $VERSION)) !~ m/^[23]/) {
	return ("smtpOpen: smtpsend HELO error ($_)");
    }
    return undef();
}

sub smtpEnvelope {
    my($fh, $from, @recips) = @_;
    if (($_ = smtpFrom($fh, $from)) || ($_ = smtpTo($fh, @recips))) {
	return "smtpEnvelope ($from, @recips): $_";
    }
    return undef();
}

sub smtpFrom {
    my($fh, $from) = @_;
    if (($_ = smtpExchange($fh, "MAIL FROM:<$from>")) !~ m/^[23]/) {
        return ("smtpFrom: mail From $from: error ($_)");
    }
    return undef();
}

sub smtpTo {
    my($fh, @recips) = @_;
    my($to);
    unless (@recips) { return ("No recipient!") }
    foreach $to (@recips) {
	unless ($to) { 
	    errlog("Null recipient in smtpTo, skipping");
	    next; 
	}
	if (($_ = smtpExchange($fh, "RCPT TO:<$to>")) !~ m/^[23]/) {
	    return ("smtpTo rcpt to:$to ($_)");
        }
    }
    return undef();
}
    
sub smtpData {
    my($fh, $data) = @_;
    $data =~ s/^\./\.\./gm;     # handle . as first character
    if ($_ = smtpBeginData($fh)) { return $_; }
    smtpOutput($fh, $data);
    if ($debug) { errlog("Wrote " . length($data) . " bytes of data"); }
    return smtpEnd($fh);
}

sub smtpOutput {
    my($fh, $data) = @_;
    my($i, $c, $lc);

    for ($i = 0; $i < length($data); $i++) {
	$c = substr($data, $i, 1);
	if (($c eq "\012") && ($lc ne "\015")) {
	    print $fh "\015";
	}
	$lc = $c;
	print $fh $c;
    }
}

sub smtpBeginData {
    my($fh) = @_;
    if (($_ = smtpExchange($fh, "DATA")) !~ m/^[23]/) {
	return ("smtpBeginData: Cannot send data ($_)");
    }
    return undef();
}

sub smtpRset {
    my($fh) = @_;
    if (($_ = smtpExchange($fh, "RSET")) !~ m/^[23]/) {
	return ("smtpRset: Cannot rset smtp ($_)");
    }
    return undef();
}

sub smtpEnd {
    my($fh) = @_;
    if (($_ = smtpExchange($fh, "\015\012.")) !~ m/^[23]/) {
	return ("smtpEnd: message transmission failed: $_");
    }
    return undef();
}

sub smtpClose {
    my($fh) = @_;
    my($code) = smtpExchange($fh, "QUIT");
    close $fh;

    if ($code !~ m/^[23]/) {
	return ("smtpClose: cannot quit: $_");
    } else {
	return undef();
    }
}

sub smtpExchange {
    my($fh, $cmd) = @_;
    my($resp);
    if ($cmd) {
	print $fh ($cmd . "\015\012");
	if ($debug) { errlog(">> $cmd"); }
    }
    while (defined($resp = <$fh>) && ($resp !~ m/^(\d+)\s/)) {
	if ($debug) { errlog("<. $resp"); }
    }
    chomp($resp);
    if ($debug) { errlog("<< $resp"); }
    return $resp;
}


1;