#!/usr/bin/perl
#
# redirmail v1.0 - simple mail redirection script.
# James Abendschan  jwa@jammed.com
# (c) 1996-1998 James Abendschan, JAMMED Systems
#
# don't want to run sendmail on all your hosts, and can't
# MX them yourself because you don't control DNS?  don't want
# to have that nasty sendmail binary living on all your client
# machines? Run this from inetd, set smtp_server to the name of your
# 'primary' mail server, and go crazy!  Run this from the command
# line and it will behave like "normal" sendmail (just without those
# nasty "get root quick" bugs).
#
# 19 nov 1996 jwa  initial code, smtp server
# 20 nov 1996 jwa  added sendmail stdio emulation
# 10 dec 1996 jwa  parse message for recipient names if appropriate
# 21 dec 1996 jwa  added neeto $0 debugging/status & alternate port setting
#  4 jun 1997 jwa  prerelease code cleanup (syslog fixes, etc)
#  7 dec 1997 jwa  added support for queue files & cleaned up logging code
#
# todo:
#  * paranoid analysis of hostname/to/from/wackychars
#  * support encryption via ssh?  might make a nice little VPN+SMTP hack..
#  * RBL (http://maps.vix.com/rbl/)

require 5.003;
use Socket;
use Sys::Syslog;
use Sys::Hostname;

# change these to suit your setup

$smtp_server="mailhub.jammed.com";	# host/ip of your SMTP server
$smtp_port=25;				# what port to use

$connect_timeout = 10;			# how long to wait for smtp_server (sec)
$session_timeout = 60 * 60 * 24;	# 1 day
$debug = 0;				# 1 == veddy verbose

$queuedir = "/var/spool/redirmail";	# where you want the queuefiles
					# to be stored.

# only change stuff below this line if you know what you're doing :-)

$myname = basename($0);

$max_syslog_len = 2048;			# buffer overflows.. eww.
$hostname = hostname();	
$version = "redirmail-v1.0/JAMMED";

# derive login from uid

$user = $from = (getpwuid($<))[0];
$user = $from = "unknown-uid-$<" if (!defined($from));

# Trap some signals

$SIG{INT} = sub { signal_handler("INT") };	# how to do this automatically?
$SIG{HUP} = sub { signal_handler("HUP") };	# $! doesn't have the signal..
$SIG{KILL} = sub { signal_handler("KILL") };
$SIG{ALRM} = sub { signal_handler("ALRM") };

# we'll only run if we're being called as "sendmail" or "redirmail"

mydie("fatal: $myname can only be called as sendmail or redirmail, not $0") if (($0 !~ /sendmail/) && ($0 !~ /redirmail/));

# figure out our arguments (if any)
# we support the following:
#
#  -bs - SMTP mode
#  -f  - set "From:" field.. actually do "X-Unix-From: " (RFC 822)
#  -v  - verbose (doesn't actually do anything yet :-)
#
# with no arguments behave like the real sendmail would, but
# don't create a dead.letter file.


if (!defined(@ARGV)) {			# no args.  lamer.
	print "$from.. Recipient names must be specified\n";
	while (<>) {}
	exit(1);
}

# Parse our arguments

while ($arg = shift @ARGV) {
	do_log("arg $arg") if ($debug == 1);
	run_queue() if ($arg eq "-q");
	$use_smtp = 1 if ($arg eq "-bs");
	$x_unix_from = shift @ARGV if ($arg eq "-f");
	$verbose = 1 if ($arg eq "-v");
	push(@recipients, $arg) if (substr($arg, 0, 1) ne "-") 
	help() if ($arg eq "--help");
}

# find out who is on the other end.

$sockaddr = getpeername(STDOUT);

if (!$sockaddr) {
	do_log("local exec by $user") if ($debug == 1);
	$0="$myname: exec by $user";
} else {
	($family, $socket_hostport, $heraddr) = unpack('S n a4 x8', $sockaddr);
	($a,$b,$c,$d) = unpack('C4', $heraddr);
	$addr = "$a.$b.$c.$d";
	$remote_hostname = gethostbyaddr($heraddr, AF_INET);
	$remote_hostname = $addr if ($remote_hostname eq "");
	do_log("accepted connection from $remote_hostname");
	$0="redirmail: connection from $remote_hostname";
}

# .. and now do the deed

if ($use_smtp) {
	smtp_proxy_session();
} else {
	stdio_session();
}
# notreached 
exit(0);



#########################################################
#
# normal invokation is via stdio -- echo foo | /bin/mail user
# will pass the mail to sendmail, and to this routine.
# we'll then write it to a queue file and when we hit eof,
# and then we'll run the queue (if possible)
#

sub stdio_session
{
	my ($data, $line_count, $queuef, $dataf);

	($qid, $queuef, $dataf) = getqueuefile();

	open (DATA, ">$dataf") || mydie("couldn't write to data file $dataf: $!");
	$date = localtime(time);	# we should have TZ info..

# build simple header

	print DATA "Received: from $user\@$hostname\n\tby $version; queue ID $qid\n\tfor undisclosed recipients; $date\n";

	print DATA "X-Unix-From: $x_unix_from\n" if (defined($x_unix_from));

	while (($line = <STDIN>) && ($line !~ /^\.$/)) {
		$line_count++;

# if we don't have a to: on the arg line, then get it from the
# message body

		if (($line =~ /^To: /) && ($toset != 1)) {
			$to = $line;
			$to =~ s/To: //g;
			chop $to;
			$toset = 1;
			if (!@recipients) {
				push(@recipients, $to);
				$toset = 1;
			}
		}

# glean from: information from message..

		if (($line =~ /^From: /) && ($fromset != 1)) {
			$from = $line;
			$from =~ s/From: //g;
			$fromset = 1;
			chop $from;
		}

# write to to/from info to the queue file

		if (($line =~ /^$/) && (!$headerS)) {
			open (QUEUE, ">$queuef") || mydir("couldn't write to queue file $dataf: $!");
			$headerS = 1;
			print QUEUE "$from\n";
			@trec = @recipients;
			while ($rec = shift @trec) {
				print QUEUE "$rec,";
			}
			print QUEUE "\n";
			close (QUEUE);
		}	
# write the data to the data file
		print DATA $line || mydie("write to $dataf failed: $!");
	}

	close (DATA);

# release the queue file lock

	releasequeuef($qid);

# and flush the mail queue

	run_queue();
}


# run through the files in $queudir
#

sub run_queue {

	chdir $queuedir;
	open(FILES, "ls rdm.QF.* |") || mydie ("run_queue can't start ls: $!");
FILE:
	while ($file = <FILES>) {
		chop $file;
		($rdm, $type, $qid) = split(/\./, $file);
		stat ("rdm.LCK.$qid");
		if (-e $_) {
			do_log("run_queue: skipping locked $qid");
			next FILE;
		}

# lock this one	
       		open (LOCK, ">$queuedir/rdm.LCK.$qid");
        	print LOCK "queue run $$";
        	close (LOCK);
			
		open(DATA, "rdm.DF.$qid") || mydie("couldn't open data file for qid $qid");
		open(QUEUE, "rdm.QF.$qid") || mydie("couldn't open queue file for qid $qid");
			
		$from = <QUEUE>; chop $from;
		$rec = <QUEUE>; chop $rec;
		@recipients = split(",", $rec);

		$data = "";
	
		while ($line = <DATA>) {
			$data .= $line;
		}	

# deliver it

		do_log("calling deliver_mail from=$from @recipients") if ($debug == 1);	
		deliver_mail($from, $data, @recipients);

# cleanup & unlock it 

		close (QUEUE);
		close (DATA);
		unlink "rdm.QF.$qid";	
		unlink "rdm.DF.$qid";	
 		releasequeuef($qid);
	}
	close (FILES);
	exit (0);
}




sub deliver_mail {
	my ($from, $data, @recipients) = @_;

	do_log("deliver_mail from=$from data=$data recipients=@recipients") if ($debug == 1);

	$0="$myname: open $smtp_server:$smtp_port";

	$iaddr = inet_aton($smtp_server);
	$paddr = sockaddr_in($smtp_port, $iaddr);
	$proto = getprotobyname('tcp');
	alarm($connect_timeout);
	socket(C, PF_INET, SOCK_STREAM, $proto) || mydie ("500 fatal: couldn't create SMTP socket: $!");
	connect(C, $paddr) || mydie ("500 fatal: couldn't connect to socket: $!");
	alarm(0);

	alarm($session_timeout);

	select (C);			# we must
	$|=1;				# we must
	select (STDOUT);		# we must
	$|=1;				# flush flush flush!

	$stat = <C>;
	mydie("500 fatal: bad message from $smtp_server on connect: $stat")
		 if ($stat !~ /^2/);

	do_log($stat) if ($debug == 1);

	$0="$myname: HELO $hostname";
	do_log("HELO $hostname")if ($debug == 1);
	print C "HELO $hostname\r\n";
	$stat = <C>;
	mydie("500 fatal: bad message from $smtp_server on helo: $stat")
		if ($stat !~ /^2/);

	while (@recipients) {
		$to = shift @recipients;

		do_log("delivering: from=$from to=$to relay=$smtp_server");
		do_log(">> Sending to $to") if ($debug == 1);
		do_log("MAIL FROM: <$from>") if ($debug == 1); 
		$0="$myname: MAIL FROM: <$from>";
		print C "MAIL FROM: <$from>\r\n";
		$stat = <C>;
		mydie("500 fatal: bad message from $smtp_server on mail from: $stat")
			if ($stat !~ /^2/);
		do_log($stat) if ($debug == 1);

		do_log("RCPT TO: <$to>") if ($debug == 1);
		$0="$myname: RCPT TO: <$to>";

		print C "RCPT TO: <$to>\r\n";
		$stat = <C>;
		mydie("500 fatal: bad message from $smtp_server on rcpt to: $stat")
			if ($stat !~ /^2/);
		do_log($stat) if ($debug == 1);

		$0="$myname: DATA";

		do_log("DATA") if ($debug == 1);
		print C "DATA\r\n"; 
		$stat = <C>;
		mydie("500 fatal: bad message from $smtp_server on data: $stat")
			if ($stat !~ /^3/);		# usually 354, but what does RFC822 say?
		do_log($stat) if ($debug == 1);

		print C $data;

		do_log(".") if ($debug == 1);
		print C "\r\n.\r\n";
		$stat = <C>;

		mydie("500 fatal: bad message from $smtp_server on eof: $stat")
			if ($stat !~ /^2/);

		$0="$myname: RSET";
		print C "RSET\r\n";  
		do_log("RSET") if ($debug == 1);
		$stat = <C>;
		mydie("500 fatal: bad message from $smtp_server on rset: $stat")
			if ($stat !~ /^2/);
		do_log("RSET: $stat") if ($debug == 1);

	}
	$0="$myname: QUIT";
 	do_log("QUIT") if ($debug == 1);
 	print C "QUIT\r\n"; 
	close (C);
}




# tie our stdio to $smtp_server on $smtp_port
# very simple, just fork a reader and a writer.

sub smtp_proxy_session
{
	my ($iaddr, $paddr, $proto, $data, $line);

	if ($remote_hostname) {
		do_log("proxying session from $remote_hostname to $smtp_server:$smtp_port");
	} else {
		do_log("proxying session from $user/stdio to $smtp_server:$smtp_port");
	}

	$iaddr = inet_aton($smtp_server);
	$paddr = sockaddr_in($smtp_port, $iaddr);
	$proto = getprotobyname('tcp');
	alarm($connect_timeout);
	socket(SOCK, PF_INET, SOCK_STREAM, $proto) || mydie ("500 fatal: couldn't create SMTP socket: $!");
	connect (SOCK, $paddr) || mydie ("500 fatal: couldn't connect to socket: $!");
	alarm(0);
	alarm($session_timeout); 

# flush it

	select(SOCK); $|=1;
	select (STDOUT); $|=1;

	$0="$myname: $remote_hostname -> $smtp_server:$smtp_port ";

# socket from inetd on stdio

	print "220 $version ready\r\n";

# fork
 
	if ($pid2 = fork) {
		while ($data = <SOCK>) {
			print $data;
		}
		closeup("remote eof");
	}

	if ($pid = fork) {
		while ($line = <STDIN>) {
			print SOCK $line;
		}
		closeup("local eof");
	}

	wait;
 
	close (SOCK);

	exit 0;
}


sub closeup {
	my ($stat);

	$stat = shift @_;
	$0="$myname: closing up proxied connection";
	print "221 goodbye from $version ($stat)\r\n";
	close (C);
	kill 9, $pid2 if ($stat eq "remote eof"); # kill off local listener
	do_log("connection closed");
	exit 0;
}



###################
# Return a uniquely named queue file
# 
# queue files are in two forms- data files (Where mail data is stored)
# and queue files (where MAIL FROM/RCPT TO information is kept)
#

 
sub getqueuefile {
	my ($qid, $queuef, $dataf);
	my ($magic, $filename, $c_retries);

	srand($$ + time);

   	$magic = "$$" . int(rand(time));
	$magic = sprintf("%lx", $magic);
	$dataf = "$queuedir/rdm.DF.$magic";
	$queuef = "$queuedir/rdm.QF.$magic";
	$qid = $magic;

# check the files to make sure they don't already exist (!)

	statfile($dataf);
	statfile($queuef);

# lock 'em.

	open (LOCK, ">$queuedir/rdm.LCK.$magic");
	print LOCK $$;
	close (LOCK);

# return

        return ($qid, $queuef, $dataf);
}


# release the queue file - it's done being written to, so we unlock it.

sub releasequeuef {
	my ($qid) = shift @_;

	mydie("releasequeuef() called with empty queue ID?") if ($qid eq "");

	unlink "$queuedir/rdm.LCK.$qid" || do_log("WARNING: $qid was unlocked in releasequeuef()!");

}





sub statfile {
	my ($file) = shift @_;

	stat($file);                    # and make sure it's unique
		if (-l $_) {                                # check for symlink
		dolog("security error: symbolic link encountered for $file");
		mydie("couldn't create data file\n");
	}

	if (-e $_) {                                # check other cases
		dolog("security error: $file already exists?!"); # try to recover?
		return 1;
	}
	return 0;
}

# death, old friend, death and my perl code is the world.
# i can forgive my injuries in the name of 
# typos,
#  mountain dew, 
#   white zombie.
# sentence upon sentence, words are a healing lament
# for the death of my code's spirit -- has no meaning in the soft fire.
# perl got me the wound, and will get me well, if you believe it.
# all join now in the death of my code, a fork() of knowledge in the
# brain of night.

sub mydie {
	my ($why) = shift @_;

	$why =~ s/\r|\n//g;

	do_log($why);
	print "$why\n";
        releasequeuef($qid);
	exit(1);
}


#
# logging
#

sub do_log {
	my ($what) = shift @_;
	my ($i, $c, $n, $data);

# expand unprintable chars

	for ($i=0; $i<length($what); $i++) {
		$c = substr($what, $i, 1);
		$n = ord($c);
		$n = $n - 128 if ($n > 127);	# no 8bits, buudy.
		if (($n < 32) || ($n >= 127)) {
			$c = "<$n>";
		}
		$data .= $c;
	}	

	$data = "[Nothing?]" if (!$data);

	print "DEBUG: $data\n" if ($debug == 1);	# DEBUG

# length checker
		
	if (length($data) >= $max_syslog_len) {       # yikes, someone's trying
		openlog($myname, 'pid', 'user');      # to fill up the buffer.
		syslog('mail|info', "Warning: long message seen; trancating to $max_syslog_len bytes");
		$data = substr($data, 0, $max_syslog_len);
	}		

# log it!

	openlog($myname, 'pid', 'user');
	syslog('mail|info', $data);
	closelog();
}



sub signal_handler {
	my ($sig) = @_;

	alarm(0);		# reset alarm clock

	releasequeuef($qid) if (defined($qid));
	
	mydie("500 Fatal: got signal $sig") if (defined($remote_hostname));
	mydie("Fatal: got signal $sig");
	exit 1;	 #NOTREACHED
}


sub basename {
	my ($data) = shift @_;

	$data = reverse($data);
	$data = (split("/", $data))[0];
	$data = reverse($data);

	return $data;
}