#!/usr/local/bin/perl -w
# -*- Perl -*-

# tms  -  Tagged Mail Sender (tag the sender address specially)
#	Copyright 1997 by THomas Erskine under the GNU Copyleft.

# Run "tms -h" for usage, "tms -H" for how to, and "tms -C" to see a default
# configuration file.

# Using two great pieces of perl code by Russell Nelson, this will
# reduce the spam you get and let you direct replies automatically.
# It works in two modes: with no arguments, it will act as a .qmail
# style filter; with any args, it will change the envelope sender address
# and send the output to qmail-inject (i.e. send your mail).

# What it does is modify your envelope sender address to add a cookie to
# the user part to make replies
# 	- only work for a certain length of time, or
# 	- only work for a certain address, or
# 	- come back to a different .qmail-ext file

# - - -   Configuration   - - -

require 5.0; # many perl5isms
# Where is the configuration file (in the user's home directory)
my $configfile = '.tmsrc';
# Clean the path so -T won't whinge
$ENV{PATH} = '/var/qmail/bin:/usr/bin:/bin';
# What to do if no config file?
$no_config_is_error = 0;
# Default timeout (in s=seconds, m=minutes, h=hours, d=days, w=weeks)
$deftimeout = '5d';
# Where is qmail-inject?
$definject = '/var/qmail/bin/qmail-inject';
# What flags to give qmail-inject?
$definjectflags = 'sfi';
# What kind of cookie, by default?
$defcookietype = 'bare';
# What is this program called anyway
$prog = 'tms';

# - - -   Setup   - - -

# Version number
my $version = "0.3";
# Program name, just the basename
@_ = split('/',$0);
$0 = pop @_;

# Exit codes.  Early just in case.
# Everything except 0, 99 and 100 are soft errors.
$ERR_OK =	0;	# Success; look at the next .qmail file instruction
$ERR_INTERNAL =	93;	# This program has a bug!  How did that happen?
$ERR_CONFIG =	94;	# Something wrong with the config-file.
$ERR_REMOTE =	95;	# Remote user screwed up; usually a bad cookie type.
$ERR_IO =	96;	# Problem with, open, read, write, close, ...
$ERR_STOP =	99;	# Success, but don't look further in the .qmail file
$ERR_HARD =	100;	# Hard error; return to sender
$ERR_SOFT =	111;	# Soft error; try again later

# Parse the command-line
use Getopt::Std;
getopts("c:Cd:ehHs");

my ($sending) = 0;
($debug, $debugfile) = (0, '');
if (defined $opt_h) { &usage($version); } # no return
if (defined $opt_H) { &howto; } # no return
if (defined $opt_c) { $configfile = $opt_c; }
if (defined $opt_C) { &show_default; } # no return
if (defined $opt_d) {
	if ($opt_d eq '1') { $debug = 1; }
	else { $debug = 2; $debugfile = $opt_d; }
}
if (defined $opt_e) { $no_config_is_error = 1; }
if (defined $opt_s) { $sending = 1; } else { $sending = 0; }
&debug("config:\n  configfile=$configfile\n  debug=$debug\n  no_config_is_error=$no_config_is_error\n  sending=$sending\n");

# Initialize the defaults
#if ($debug) { foreach (sort keys %ENV) { print "$_ = $ENV{$_}\n"; } }
%special_addresses = ();

# Who are we?
my ($user,$fullname,$home);
if ($sending && defined $ENV{SENDER}) {
    $user = $ENV{SENDER};
    $user =~ s/@.*$//;
    ($fullname,$home) = (getpwnam($user))[6,7];
    if (not defined $home) {
	($user,$fullname,$home) = (getpwuid($>))[0,6,7];
    }
} else {
    ($user,$fullname,$home) = (getpwuid($>))[0,6,7];
}
if (defined $fullname) {
    $ENV{QMAILNAME} = $fullname;
}
$configfile = "$home/$configfile";
&debug("running as user $user");

# Read my config-file
my ($key, $timeout, $qmail_inject, $inject_flags, $default_cookie) 
	= &read_config($configfile);

# - - -   Mainline   - - -

# Send the message on stdin through qmail-inject, with 
# a user-{dated|sender}-hash envelope sender address.
if ($sending) { 
	$ENV{QMAILUSER} = "$user"; # overridden later, if asked
	&sendit($timeout, $key, $user, $qmail_inject, 
		$inject_flags); 
} # no return

# Otherwise, verify an incoming address
my ($cookie_type, $cookie);
if (defined $ENV{EXT}) {
	if ($ENV{EXT} =~ /^([a-zA-Z0-9_]+)-/) { $cookie_type = $1; }
	if ($ENV{EXT2} =~ /^([a-zA-Z0-9_]+)/) { $cookie = $1; }
	&debug("ext1=$cookie_type, ext2=$cookie");
}
else { 
	$cookie_type = $default_cookie; 
	$cookie = ''; 
	&debug("ext1 not found; assuming $cookie_type");
}
if ($cookie eq 'default') { $cookie = ''; }

&debug("cookie_type=$cookie_type, cookie=$cookie, timeout=$timeout, user=$user\n");
if ($cookie_type eq 'dated') { &verify_dated($cookie,$key,$timeout,$user); }
elsif ($cookie_type eq 'sender') { &verify_sender($user,$key,$cookie); }
else { &exitwith($ERR_REMOTE,"unknown cookie-type $cookie_type"); }

&exitwith($ERR_INTERNAL,"Should never get here");

#--------------------------------------------------- debug ---
# Print debugging messages
sub debug {
	my ($msg) = @_;
	if ($debug == 1) { print STDERR "DEBUG: $msg\n"; }
	elsif ($debug == 2) {
		open (DEBUG, ">>$debugfile")
			|| die "can't open debugging file: $!\n";
		print DEBUG "DEBUG: $msg\n"; 
		close(DEBUG);
	}
0;
}

#----------------------------------------------- exitwith ---
# Stop the program with a specified exit code and message
sub exitwith {
	my ($exitcode,$msg) = @_;
#	if ($debug) { 
		if (defined $msg) { 
			&debug($msg);
			print STDERR $msg;
			close (STDERR);
		}
		&debug("EXIT: $exitcode"); 
#	}
	exit ($exitcode+0); 
$exitcode;
}

#------------------------------------------------------------- read_config ---
# Set up things the way we like
sub read_config {
	my($configfile) = @_;

	&debug("read_config:");
	my ($key, $timeout, $qmail_inject, $inject_flags, $default_cookie) 
		= &default_values();
    
# Do we need one?
	if (!-f $configfile and $no_config_is_error) {
		&exitwith($ERR_CONFIG,"Missing config file ($configfile).");
	}
# Return defaults
	elsif (!-f _) {
		return ($key, $timeout, $qmail_inject, $inject_flags, 
			$default_cookie);
	}

# Try to open the file
	open (CONFIG, "<$configfile") || 
		&exitwith($ERR_CONFIG,"Can't open config file $configfile: $!");

# Parse the config file
	my ($var, $val);
	my $foundkey = 0;
	while (<CONFIG>) {
		chomp;
		next if (/^#|^\s*$/);
		tr/A-Z/a-z/;
		($var, $val) = split(/\s+/,$_,2);
		if ($var eq 'timeout') {
			if ($val =~ /^\d+(\.\d+)?[smhdw]$/i) { $timeout = $val; }
			else {&exitwith ($ERR_CONFIG,"Invalid units for timeout $val.");}
			&debug("  timeout $timeout");
		}
		elsif ($var eq 'qmail-inject') {
			if (-f $val) { $qmail_inject = $val; }
			else { &exitwith($ERR_CONFIG,"qmail-inject not found: $val"); }
			&debug("  qmail-inject $qmail_inject");
		}
		elsif ($var eq 'qmail-inject-flags') {
			if ($val =~ /^[csfirm]*$/) { $inject_flags = $val; }
			else { &exitwith($ERR_CONFIG,"bad qmail-inject-flags: $val"); }
			&debug("  qmail-inject-flags $inject_flags");
		}
		elsif ($var eq 'sender') {
			$special_addresses{$val} = 'sender'; # make a sender-cookie
			&debug("  sender $val");
		}
		elsif ($var eq 'bare') {
			$special_addresses{$val} = 'bare'; # no cookie
			&debug("  bare $val");
		}
		elsif ($var eq 'dated') {
			$special_addresses{$val} = 'dated'; # dated cookie
			&debug("  dated $val");
		}
		elsif ( $var =~ /ext/) {
			if ($val =~ /^(\S+)\s+(\S+)/i) {
				$special_addresses{$1} = "ext=$2"; # extension
			}
			else { &exitwith($ERR_CONFIG,"'$val' has bad syntax for extension"); }
			&debug("  ext $1 $2");
		}
		elsif ($var eq 'default') {
			if ($val =~ /^sender$/i) { $default_cookie = 'sender'; }
			elsif ($val =~ /^dated$/i) { $default_cookie = 'dated'; }
			elsif ($val =~ /^bare$/i) { $default_cookie = 'bare'; }
			# ext can't be the default; we don't know which ext
			elsif ($val =~ /^ext$/i) { &exitwith($ERR_CONFIG,"ext can't be the default"); }
			else { &exitwith($ERR_CONFIG,"invalid default $val"); }
			&debug("  default $default_cookie");
		}
		elsif ($var eq 'key') {
			if ($val =~ /^[0-9a-fA-F]{32,32}$/) {
				$key = pack("H*",$val);
			}
			else { &exitwith($ERR_CONFIG, "key is not 32 hex digits: $val"); }
			$foundkey=1;
			&debug("  key SUPPRESSED");
		}
		else { &exitwith($ERR_CONFIG, "unknown config $var"); }
	}
	close (CONFIG);

	exitwith($ERR_CONFIG,"No encryption key found.") unless($foundkey);

return ($key, $timeout, $qmail_inject, $inject_flags, $default_cookie, );
}

#------------------------------------------------------- default_values ---
# The defaults for all the options
sub default_values {
	('', 			# no default for the key
	 $deftimeout, 		# timeout is 5 days, by default
	 $definject,		# where else?
	 $definjectflags, 	# man qmail-inject
	 $defcookietype);	# default cookie-type
}

#--------------------------------------------------------------- sendit ---
# Read the message we're filtering and send it the "right" way.
sub sendit {
	my ($timeout, $key, $user, $qmail_inject, $inject_flags) = @_;
	my @headers = ();

# Read the headers, leave the body, so we won't use so much memory.
	while (<STDIN>) {
		chomp;
		last if (length($_)==0);
		if (/^\s+(.*)$/) { $headers[$#headers] .= " " . $1; }
		else { push @headers, $_; }
	}

	if (defined $ENV{EXT}) {
	    my $recip = $ENV{EXT};
&debug("EXT=$recip");
	    $recip =~ s/^[^-]*-//;
&debug("recipient= $recip");
	    @lines = ($recip);
	} else {
# Clean up and extract the recipients (excluding bcc, which won't be here)
	    my @lines = grep(/^(To: |CC: )/i,@headers);
&debug("TO and CC\n\tlines=".join("\n\t",@lines));
	    grep(s/^\S+\s+//,@lines); # remove header-names
&debug("without header-names\n\tlines=".join("\n\t",@lines));
	    my $line = join(',',@lines);
&debug("in one line\n\tline=$line");
	    while ($line =~ s/\([^()]*?\)//g){};	# remove nested parens
&debug("without parens\n\tline=$line");
	    @lines = split(/\s*,\s*/,$line);	# one addr per line, I hope
&debug("one per line\n\tlines=".join("\n\t",@lines));
	    grep(s/.*<([^>]+?)>.*/$1/g,@lines);	# addresses only
&debug("without non-caretized stuff\n\tlines=".join("\n\t",@lines));
	    grep(s/^\s*(\S*)\s*$/$1/,@lines);	# trim extraneous whitespace
	}
&debug("trimmed whitespace\n\tlines=".join("\n\t",@lines));

# Which type of cookie do we want?
	my $cookietype = $default_cookie;
	my $found = 0;
	my ($host, @temp, $domain, @subdomains);
Address:
	foreach (reverse @lines) { # so we find the first one with less code
		next if (length($_)==0);
		$found = 1;
		tr/A-Z/a-z/;
&debug("Looking for $_");
		$found_address = $_;
		@temp = split('@',$_);
		$host = pop @temp;

# A special user@host address
		if (defined $special_addresses{$_}) {
			$cookietype = $special_addresses{$_};
			&debug("  special addr $_ = $cookietype");
			last Address;
		}

# A special @host address
		elsif (defined $special_addresses{"\@$host"}) {
			$cookietype = $special_addresses{"\@$host"};
			&debug("  special host $_ (\@$host) = $cookietype");
			last Address;
		}

# A special .sub.dom.ain address
		else {
			@subdomains = split('\.',$host);
			shift @subdomains; # discard empty first part
			while($domain=join('.',@subdomains)) {
				if (defined $special_addresses{".$domain"}) {
					$cookietype = $special_addresses{".$domain"};
					&debug("  special domain $_ (.$domain) = $cookietype");
					last Address;
				}
				shift @subdomains;
			}
		}
	}
	unless ($found) { &exitwith($ERR_INTERNAL,"No recipients found."); }

# Dispatch to the actual sending routine
	if ($cookietype eq 'bare') {     # bare, no cookie
		&send_bare($qmail_inject, $inject_flags, @headers);
	}
	elsif ($cookietype eq 'dated') { # dated cookie
		&send_dated($key, $user, $qmail_inject, $inject_flags, 
			$timeout, @headers);
	}
	elsif ($cookietype eq 'sender') { # sender cookie
		&send_sender($key, $user, $qmail_inject, $inject_flags, 
			$found_address, @headers);
	}
	elsif ($cookietype =~ /^ext=(.*)$/i) {
		&send_ext($user, $1, $qmail_inject, $inject_flags, @headers);
	}
	else { &exitwith($ERR_REMOTE,"Unknown cookie type ($cookietype); $0 is broken"); }
0;
}

#-------------------------------------------- send_dated ---
# Send a message with a dated cookie
sub send_dated {
	my ($key, $user, $qmail_inject, $inject_flags, $timeout, @headers) 
		= @_;
	&debug("send_dated:");

# Better than DES anyway.
	use Crypt::IDEA;
	my $cipher = new IDEA $key;

# Make a cookie
	my $in = sprintf("%16d",time+&seconds($timeout));
	$ENV{QMAILUSER} = "$user-dated-" 
		. unpack("H*",$cipher->encrypt(pack("H*", $in)));
	&debug("send_dated: user=$ENV{QMAILUSER}");
	&send_bare($qmail_inject, $inject_flags, @headers);
	# no return
}

#-------------------------------------------- verify_dated ---
sub verify_dated {
	my ($cookie, $key, $timeout, $user) = @_;
	my ($in, $date, $msg);

# Better than DES anyway.
	use Crypt::IDEA;
	my $cipher = new IDEA $key;

	&debug("Verifying incoming dated cookie ($cookie)");
	if (length($cookie) == 16 && length($in = pack("H*", $cookie)) == 8) {
	    $date = unpack("H*",$cipher->decrypt($in));
	    &debug("...verified");
	} else {
	    &debug("...unverified");
	    $date = 0;
	}

# It's within the window
	if ($date > time) {
		&debug ("...ok");
		&exitwith($ERR_OK);
	}

# Deal with expired addresses
	&debug("expired address");
	$in = sprintf("%16d",time+&seconds($timeout));
	$msg = "\nThis email address is an expired SPAM-proof address.  Use\n\n\t$user-dated-"
		. unpack("H*",$cipher->encrypt(pack("H*", $in))) 
		. "\@$ENV{HOST}\n\ninstead.\n";
	&debug("...try again");
	&exitwith($ERR_HARD,$msg);
}

#-------------------------------------------- send_sender ---
# Send a message with a sender cookie
sub send_sender {
	my ($key, $user, $qmail_inject, $inject_flags, $found_address, 
		@headers) = @_;
	&debug("send_sender:");

# Make a cookie
	use MD5;
	my $md5 = new MD5;
	$md5->add($key);
	$md5->add($found_address);
	$hash = $md5->hexdigest;

# Get the environment ready for qmail-inject
	$ENV{QMAILUSER} = "$user-sender-$hash" ;
	&debug("send_sender: user=$ENV{QMAILUSER}");
	&send_bare($qmail_inject, $inject_flags, @headers);
	# no return
}

#--------------------------------------------- verify_sender ---
# Verify a sender-style cookie.
sub verify_sender {
	my ($user, $key, $cookie) = @_;

	use MD5;
	my $md5 = new MD5;
	my $sender;

	if (defined $ENV{SENDER} && $ENV{SENDER} =~ /^([-a-zA-Z0-9_\@=.]+)/) {
		$sender = $1;
	}
	else { &exitwith(93,"SENDER missing; I don't know what to do.\n"); }

# eliminate serial numbers from ezmlm lists.
	$sender =~ s/-return-\d*-.*\@//; 
	$sender =~ s/nelson.*=crynwr\.com//; # eliminate VERP
	$sender =~ s/-(?=[ds])(dated|sender)-[0-9a-f]{16}//;	# eliminate our own stuff

	$md5->add($key);
	$md5->add($sender);
	$hash = $md5->hexdigest;

	&exitwith($ERR_OK) if $hash eq $cookie;

	use Crypt::IDEA;
	my $cipher = new IDEA $key;
	$in = sprintf("%16d",time+&seconds($timeout));
	$msg = "\nThis email address is a SPAM-proof address.  Use\n\n\t$user-dated-"
		. unpack("H*",$cipher->encrypt(pack("H*", $in))) 
		. "\@$ENV{HOST}\n\ninstead.\n";
	&debug("...try again");
	&exitwith($ERR_HARD,$msg);
0;
}

#------------------------------------------------------------- send_ext ---
# Send with an extension
sub send_ext {
	my ($user, $ext, $qmail_inject, $inject_flags, @headers) = @_;

	$ENV{QMAILUSER} = "$user-$ext" ;
	&debug("send_ext: user=$ENV{QMAILUSER}");
	&send_bare( $qmail_inject, $inject_flags, @headers);
	# no return
}

#------------------------------------------------------------- send_bare ---
# Just send it
sub send_bare {
	my ($qmail_inject, $inject_flags, @headers) = @_;

	&debug("send_bare: user=$ENV{QMAILUSER}");
	$ENV{QMAILINJECT} = $inject_flags;;
	my $pipe;
	if (defined $ENV{EXT}) {
	    my $recip = $ENV{EXT};
	    $recip =~ s/^[^-]*-//;
	    $pipe = "|$qmail_inject -f'$ENV{QMAILUSER}' -a $recip";
	} else {
	    $pipe = "|$qmail_inject -f'$ENV{QMAILUSER}'";
	}

# Write it to qmail-inject
	&debug("piping to: $pipe");
	open (PIPE, $pipe)
	    || &exitwith($ERR_IO,"Can't open pipe to $pipe: $!");

# Don't forget the headers
	print PIPE join("\n",@headers)."\n\n"
		|| &exitwith($ERR_IO,"write error: $!");

	while(<STDIN>) {
		print PIPE $_ || &exitwith($ERR_IO,"write error: $!");
		chomp $_; # so debug won't write two newlines
		&debug("    $_");
	}
	close(PIPE);
	&debug("...done sending");
	&exitwith($ERR_OK);
}

#------------------------------------------------------------- usage ---
sub usage {
	my ($version) = @_;
	print STDERR <<"EOD_USAGE";
$0 version $version
usage: $0 [options]
where options are:
	-c file		specify a different config-file
	-d		write a default configuration file to stdout
	-D how		debugging (how=1, write to stderr; how=file, write file)
	-e		having no config-file is an error
	-h		show this help
	-H		show how to use this
	-s		send a message instead of receiving one

EOD_USAGE
	close(STDERR);
	exit(0);
}

#----------------------------------------------------------------- howto ---
sub howto {
	print STDERR <<'EOD_HOWTO';
To use (with qmail of course), put this script somewhere in the path, e.g.:
      cp $prog bin/$prog	

Set up the .qmail files appropriately
	echo "|bin/$prog"         	> .qmail-sender-default
	echo "./Mailbox-preferred"	>>.qmail-sender-default
	echo "$USER-sender-default"	> .qmail-sender
	echo "|bin/$prog"         	> .qmail-dated-default
	echo "./Mailbox-preferred"	>>.qmail-dated-default
	echo "$USER-dated-default"	> .qmail-dated

Your mail (minus rejected ones) ends up in ./Mailbox-preferred.  If you do
	echo "$USER-dated"		> .qmail

then all your mail is routed through the filter. 

If you do this, then you can use the second feature of this script:
arrange for your MUA to call this script with an argument  of "-s" instead of
sendmail, so that your envelope sender address has the cookies added 
automatically.

In Pine you can make a line like the following in .pinerc:
sendmail-path=/wherever/you/put/$prog -s

EOD_HOWTO
	exit(0);
}

#------------------------------------------------------------ show_default ---
sub show_default {
	my ($key, $timeout, $qmail_inject, $inject_flags, $default_cookie) 
		= &default_values;
	print STDOUT <<"EOD_DEFAULT";
# .${prog}rc - configuration file for $prog
#
# Note: this file must be mode 600 or 400 or # $prog will refuse to look at it.

# The key is the only thing which has no default.  It is 32 hex digits.
# key your-32-hex-digit-key-here

# The timeout defaults to 5d (5 days).  The units can be (w=weeks, d=days, 
# h=hours, m=minutes, s=seconds)
# timeout $timeout

# qmail-inject is expected to be in /var/qmail/bin, but this lets you override
# it, in case you put it somewhere else.  If you don't know what I'm talking 
# about, look at http://www.qmail.org/ for pointers.  If you're not using qmail
# then $prog won't help you.
# qmail-inject $qmail_inject

# The default cookie type is dated.  It could be:
#	dated	can only be replyed to for timeout
#	sender	can only be replyed to by address
#	bare	no cookie
# default $default_cookie

# The rest is addresses to be treated specially. The
# types are the same as the "default" keyword.  Some
# samples:

# These addresses are allowed to reply.
# sender djb-qmail\@koobera.math.uic.edu
# sender dbj-serialmail\@koobera.math.uic.edu

# These addresses can reply for TIMEOUT interval.
# dated someone\@some.where

# These addresses just change the From: field to add an extension
# ext someone\@some.where extension

# These addresses get your bare address.
# bare friend\@some.where.else

EOD_DEFAULT
	close(STDOUT);
	exit(0);
}

#------------------------------------------------------- keep_perl_happy ---
# Make perl stop whinging about things which aren't problems.
sub keep_perl_happy {
$opt_s = $opt_h = $opt_H = $opt_d = $opt_C = $opt_e = $ERR_SOFT = $ERR_STOP = 0;
}

#-------------------------------------------------------- seconds ---
# Translate the timeout from whatever to seconds.
sub seconds {
	my ($string) = @_;

	if ($string =~ /^(\d+)s?$/i) { $seconds = $1 + 0; }
	elsif ($string =~ /^(\d+)m$/i) { $seconds = $1 * 60; }
	elsif ($string =~ /^(\d+)h$/i) { $seconds = $1 * 60 * 60; }
	elsif ($string =~ /^(\d+)d$/i) { $seconds = $1 * 60 * 60 * 24; }
	elsif ($string =~ /^(\d+)w$/i) { $seconds = $1 * 60 * 60 * 24 * 7; }
	else { &exitwith($ERR_CONFIG, "Invalid timeout units for $string."); }
$seconds;
}