#!/usr/bin/perl -wT
#
# $Id: email_map.pl,v 1.11 2003/01/13 05:28:42 jmates Exp $
#
# Copyright (c) 2000-2001, Jeremy Mates.  This script is free
# software; you can redistribute it and/or modify it under the same
# terms as Perl itself.
#
# Run perldoc(1) on this file for additional documentation.
#
######################################################################
#
# REQUIREMENTS

require 5;

use strict;

# clean up env settings for taint mode (man perlsec)
sub BEGIN {
    delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
    $ENV{'PATH'} = '/bin:/usr/bin';
}

######################################################################
#
# MODULES

use Carp;			# better error reporting
use Getopt::Std;		# command line option processing

#use Mail::Mailer;		# for reply messages

######################################################################
#
# VARIABLES

my $VERSION;
($VERSION = '$Revision: 1.11 $ ') =~ s/[^0-9.]//g;

my (%opts, $logapp, $from, $to, $resend_to, $sendmail, $sendmailflags,
    $config_file, @domains, @user_map, @reply_map);

# use external logger due to buggy perl implementations of Sys::Syslog
# (RedHat Linux, among others)
$logapp = '/usr/bin/logger';

# where to locate the user mapping file
$config_file = '/etc/procmailrcs/map_config';

######################################################################
#
# MAIN

# parse command-line options
getopts('h?', \%opts);

help() if exists $opts{'h'} or exists $opts{'?'};

# pull arguments off of ARGV, should be $1 $2 in procmailrc
$from = shift || error ('no from address specified, quitting');
$to   = shift || error ('no to address specified, quittting');

# make incoming stuff "safe" to use
untaint();

# read in config file to @domains and @user_map, respectively
unless (open (FILE, $config_file)) {
    error ("problem opening $config_file: $!");
} else {
    my $count = -1;		# as perl arrays start at -1
    while (<FILE>) {
	chomp;

	next if /^\#/;		# skip comments
	next if /^\s*$/;	# blank lines, too

	# either update current domain, or pull out user entries
	if (m/^Domain\s+(.+?)\s*$/) {
	    $count++;
	    $domains[$count] = $1;
	} else {
	    my ($username, $destination, $expiration) = split;
#	    warn "Got '$username' '$destination' $count\n"; # DBG

	    # user_maps parallels domains array, but with anon hashes
	    $user_map[$count]->{$username} = $destination;

	    # as does the reply_map, for bugging the sender
	    if ($expiration) {
		$reply_map[$count]->{$username} = $expiration;
	    }
	}
    }
    close (FILE);
}

# pull apart the destination address and lookup in config file
my ($user, $domain) = split ('@', $to, 2);

# futz over various domain regex's to see which user map table to use
for my $i (0 .. $#domains) {
    # probably should do this via an eval() as regex recompile expensive?
    if ($domain =~ /$domains[$i]/) {
#	warn "Got '$user_map[$i]->{$user}' $i\n"; # DBG

	# see whether this user has a map...
	if (exists $user_map[$i]->{$user}) {
	    $resend_to = $user_map[$i]->{$user};

	    # due to Taint mode, we have to untaint new To address
	    if ($resend_to =~ m/^([A-Za-z0-9._@-]+)$/) {
		$resend_to = $1;
	    } else {
		$resend_to =~ s/[^A-Za-z0-9._@-]/_/g;
		error ("invalid characters in new To address, now: $to");
	    }

	    # attempt reply message about expiration date, if any
#  	    if (exists $reply_map[$i]->{$user}) {
#  		my $mailer = Mail::Mailer->new("sendmail");

#  		unless ($mailer->open({ "From" => $from_address,
#  					"To" => $from,
#  					"Subject" => $subject,
#  				    })) {
#  		    error ("problem sending reply message: $!");
#  		} else {
#  		    print $mailer <<"MESSAGE";
#  Hello-

#  Your message directed to:

#  $to

#  has been forwarded on to the new address of:

#  $resend_to

#  You should update your system to direct mail to the new address.
#  MESSAGE
#  	    }

	} else {
	    # damn, no map for this user
	    error ("no destination for $user\@$domain, bouncing");
	}

	last;			# only match one domain, then quit
    }
}

# return only new destination address on STDOUT; procmail should slurp
# it up into a ENV variable used in later rules.
print $resend_to;

exit;

######################################################################
#
# SUBROUTINES

# routine that handles extraction / conversion of various things to
# forms perl's Taint mode considers "safe"
sub untaint {
    # untaint to/from addresses...
    if ($from =~ m/^([A-Za-z0-9._ ()@+-]+)$/) {
	$from = $1;
    } else {
	$from =~ s/[^A-Za-z0-9._ ()@+-]/_/g;
	error ("invalid characters in From address, now: $from");
    }
    
    if ($to =~ m/^([A-Za-z0-9._ ()@+-]+)$/) {
	$to = $1;
    } else {
	$to =~ s/[^A-Za-z0-9._ ()@+-]/_/g;
	error ("invalid characters in To address, now: $to");
    }
    
    # extract ENV variables (carefully!)
    if ($ENV{'SENDMAIL'} =~ m!^([A-Za-z0-9._/:\\+-]+)$!) {
	$sendmail = $1;
    } else {
	error ("invalid characters in SENDMAIL env");
    }
    if ($ENV{'SENDMAILFLAGS'} =~ m!^([A-Za-z0-9._/:\\ +-]+)$!) {
	$sendmailflags = $1;
    } else {
	error ("invalid characters in SENDMAILFLAGS env");
    }
}

# simple little log message to syslog and STDERR
sub log {
    my $message = shift;
    warn $message;
    my $appname; ($appname = $0) =~ s!^.*?/([^/]+)$!$1!;
    system ($logapp, "-i", "-t", $appname, $message);
}

sub error {
    my $message = shift;
    &log('error: ' . $message);
    die;
}

# a generic help blarb
sub help {
    print <<"HELP";
Domain email mapper called from procmail.

Run perldoc(1) on this script for additional documentation.

HELP
    exit;
}

######################################################################
#
# DOCUMENTATION

=head1 NAME

email_map.pl - map users to new addresses from procmail

=head1 SYNOPSIS

The general setup involves sendmail mailertable entries, a procmail
config file, this script, and a config file.  See L<"EXAMPLES"> for
setup and usage notes.

=head1 DESCRIPTION

This script is meant to handle email addresses for a domain riding in
from procmail via a sendmail mailertable entry; it provides a
translation service for the entire domain by mapping user addresses to
new locations.  Typical uses for this script are to manage a domain
that the members of have moved elsewhere, and you want to expire their
email accounts slowly.

Use of procmail also allows rules to be setup that can inform the
sender of the new email address, but I have yet to write that part.

=head2 Normal Usage

Usage is non-typical, see L<"EXAMPLES"> for setup notes.

=head1 EXAMPLES

Setup involves configuring sendmail to support the mailertable
feature, which can be done by adding:

  FEATURE(`mailertable')dnl

to your sendmail.mc file, and rebuilding sendmail.cf.  See cf/README
under the sendmail source tree for more information.

Then, setup a mailertable entry for the domain you want to handle,
making sure there is a tab between the hostmask and the procmail
invocation:

  old.example.org    procmail:/etc/procmailrcs/old.example.org
  .old.example.org   procmail:/etc/procmailrcs/old.example.org

Rebuild the mailertable database (see makemap(8) for details), and
restart sendmail.

But before you do that, you will want to create the
/etc/procmailrcs/old.example.org file, which should contain procmail
rules along the lines of:

  SHELL=/bin/sh
  PATH=/bin:/usr/bin
  LOGFILE=/var/log/procmail/old.example.org
  VERBOSE=off

  # pipe all mail sent to this file to the email_map.pl perl script,
  # which should perform a lookup on the destination address, then
  # return the new address on STDOUT into NEWDEST
  :0 hi
  NEWDEST=| perl -T /etc/procmailrcs/email_map.pl $1 $2

  # check whether destination set, if blank, bounce the mail back
  # we can note whose mail is bouncing by looking at the LOGFILE for
  # error output from the perl script.
  :0
  * NEWDEST ?? ^$
  {
      EXITCODE=67
      HOST
  }

  # otherwise, we assume a valid NEWDEST is set, so we ship the mail
  # message off:
  :0
  ! $NEWDEST

You will also need to copy this script into /erc/procmailrcs, and
optionally create the LOGFILE first, plus a gaggle of permission
changes on the various files.

Finally, a map_config preferences file for this script will have to be
setup, pointed to by the $config_file variable.  The file should
contain domain and user->destination mappings:

  Domain old.example.org
      user   user@example.com
      user2  user@example.net

  # for testing
  Domain testing.example.org
      test   postmaster@example.org

The file can contain multiple domain entries, so that the various
domain procmailrcs can all call the same script/preferences file.

The text following Domain is treated as a regex; user entries are hash
keys/values treated as simple strings.

=head1 BUGS

=head2 Reporting Bugs

Newer versions of this script may be available from:

http://sial.org/code/perl/

If the bug is in the latest version, send a report to the author.
Patches that fix problems or add new features are welcome.

=head2 Known Issues

Forged messages (e.g. spam) are not handled to well, and tend to end
up doing a little loop on the server until maxhops is exceeded.
Haven't spent the time to figure out how to prevent this and abort
early on bum messages.

=head1 TODO

untaint() should accept variable and regex and handle all those petty
details.

Read lock on config file when loading said file.

Allow regex in usernames (switch to parsing array) so can redirect
stuff like user ".*" at the end to a generic account.

Make config file loading modular so could swap it out easily say with
information we're grabbing from an LDAP server...

Would like to be able to have a expiration date in the user map field;
this would allow a little note to be sent back to the sender about the
newly updated address telling them about the new address.  However,
problems arise over what email address procmail is giving us, how to
handle mail loops, and mailing lists, which are often not happy/cause
bounces when we would automagically try to respond to them.

=head1 SEE ALSO

perl(1), procmail(1), procmailrc(5), procmailex(5)

=head1 AUTHOR

Jeremy Mates, http://sial.org/contact/

=head1 COPYRIGHT

Copyright (c) 2000-2001, Jeremy Mates.  This script is free
software; you can redistribute it and/or modify it under the same
terms as Perl itself.

=head1 VERSION

$Id: email_map.pl,v 1.11 2003/01/13 05:28:42 jmates Exp $

=cut