#!/usr/local/bin/perl5.6.1t

# $Id: timedelay.milter.pl,v 1.10 2002/02/27 04:19:28 dredd Exp $

# Usage:
#  1  create an entry "td.yourdomain.com IN MX 0 mail.yourdomain.com"
#  2  create, in virtusertable  "@td.yourdomain.com dev-null"
#  3  create, in aliases, a user "dev-null" pointing to the /dev/null
#     device
#  4  change the %prefixes hash below to contain the prefix->username
#     mappings you want. The users MUST be local (at least, I think
#     they must be local)
#  5  Create your milter entries in sendmail.mc, recompile your .cf
#     and go for it.

use Socket;
use Sys::Syslog;
use Sendmail::Milter;
use Time::Local;

$0 = 'Sendmail Milter - Time Delay';

my $regex_lock;
my %prefixes = ('djb' => 'dredd@megacity.org',
		'sms' => 'sms@megacity.org',
		'rnd' => 'rderoo@deroo.net',
		'bc' => 'bc@bjb.org',
		'jh' => 'jhagel@megacity.org'
		);

my $DEBUG = 0;

sub connect_callback
{
    my ($ctx,$hostname,$sockaddr_in) = @_;
    my ($port,$iaddr) = sockaddr_in($sockaddr_in);
    my $ip_addr = inet_ntoa($iaddr);
    my %hash = ('ipaddr' => $ip_addr,
		'hostname' => $hostname);
    print "Connect from $ip_addr/$hostname\n" if $DEBUG;
    $ctx->setpriv(\%hash);
    return SMFIS_CONTINUE;
}

sub envfrom_callback
{
    my $ctx = shift;
    my $sender = shift;
    my $href = $ctx->getpriv();
    $$href{'sender'} = $sender;
    $ctx->setpriv($href);
    return SMFIS_CONTINUE;
}

sub envrcpt_callback
{
    my $ctx = shift;
    my @args = @_;
    
    my $recip = $args[0];
    my $lhs;
    {
	lock $regex_lock;
	($lhs) = $recip =~ /\<(.*)\@td\.megacity\.org/i;
    }

    return SMFIS_ACCEPT if ! defined $lhs;

    my %hash = ('rewrite' => 0);
    $lhs = lc $lhs;
    if ($lhs =~ /[A-Za-z]{2,3}\d{10}/)
    {
	print "$lhs is a valid timedelay address\n" if $DEBUG;
	my ($final_recipient,$date,$life) = $lhs =~ 
	    /([A-Za-z]{2,3})(\d{8})(\d{2})/;
	my ($myear,$mmon,$mday);
	{
	    lock $regex_lock;
	    ($myear,$mmon,$mday) = $date =~ /(\d{4})(\d{2})(\d{2})/;
	}
	$mmon--; $myear -= 1900;
	if (  ($mmon < 0) or ($mmon > 11) or
	      ($mday < 1) or ($mday > 31) or
	      ($myear < 101) or ($myear > 168) )
	{
	    print "$lhs has a bogus looking date.\n" if $DEBUG;
	    $ctx->setreply('551','5.7.1',"Bogus looking recipient.");
	    return SMFIS_REJECT;
	}
	my $start_date = timelocal(0,0,0,$mday,$mmon,$myear);
	my $finish_date = $start_date + ($life * 86400);
	if ( ($finish_date > time) and
	     ($start_date < time) )
	{
	    print "$lhs is a CURRENT timedelay address\n" if $DEBUG;
	    # change recipient to $prefixes{$final_recipient}
	    if (! defined $prefixes{$final_recipient})
	    {
		$ctx->setreply("551","5.7.1","What the heck?");
		return SMFIS_REJECT;
	    }
	    else
	    {
		my $end_rcpt = "<" . $prefixes{$final_recipient} . ">";
		my $href = $ctx->getpriv();
		print "Setting rewrite to $hash{'rewrite'}\n" if $DEBUG;
		if ($$href{'rewrite'} == 0)
		{
		    %hash = ('rewrite' => 1,
			     'old' => [$recip],
			     'new' => [$end_rcpt],
			     'sender' => $$href{'sender'},
			     'ipaddr' => $$href{'ipaddr'},
			     'hostname' => $$href{'hostname'}
			     );
		}
		else
		{
		    my @old_old = @{$$href{'old'}};
		    my @old_new = @{$$href{'new'}};
		    %hash = ('rewrite' => 1,
			     'old' => [@old_old, $recip],
			     'new' => [@old_new, $end_rcpt],
			     'sender' => $$href{'sender'},
			     'ipaddr' => $$href{'ipaddr'},
			     'hostname' => $$href{'hostname'}
			     );

		}
		$ctx->setpriv(\%hash);
		return SMFIS_CONTINUE;
	    }
	}
	else
	{
	    my $href = $ctx->getpriv();
	    $ctx->setpriv($href);
	    
	    print "$lhs is an EXPIRED timedelay address\n" if $DEBUG;
	    $ctx->setreply("551","5.7.1","Expiration Reached.");
	    my $end_rcpt = $prefixes{$final_recipient};

	    syslog('notice','%s/%s 551 %s <%s> timedelay "%s"', 
                   $$href{'ipaddr'}, $$href{'hostname'}, 
		   $$href{'sender'}, $end_rcpt, 
                   "Expiration Reached for $lhs\@td.megacity.org");
	    return SMFIS_REJECT;
	}
	return SMFIS_CONTINUE;
    }
    else
    {
	print "$lhs is a very wonky address\n" if $DEBUG;
	$ctx->setreply("551","5.7.1","Address not understood.");
	return SMFIS_REJECT;
    }
}

sub abort_callback
{
	my $ctx = shift;

	print "my_abort:\n" if $DEBUG;

	$ctx->setpriv(undef);
	print "   + private data cleared.\n" if $DEBUG;

	print "   + callback completed.\n" if $DEBUG;

	return SMFIS_CONTINUE;
}

sub close_callback
{
	my $ctx = shift;

	$ctx->setpriv(undef);
	print "   + private data cleared.\n" if $DEBUG;

	print "my_close:\n" if $DEBUG;
	print "   + callback completed.\n" if $DEBUG;

	return SMFIS_CONTINUE;
}

sub eom_callback
{
    my $ctx = shift;
    my $chunk;

    my $href = $ctx->getpriv();
    print "Rewrite = $$href{'rewrite'}\n" if $DEBUG;
    if ($$href{'rewrite'})
    {
	print "Deleting @{$$href{'old'}}, Adding @{$$href{'new'}}\n" if $DEBUG;
	foreach my $del_old (@{$$href{'old'}})
	{
	    if (not $ctx->delrcpt($del_old))
	    {
		print "Unable to delrcpt $del_old\n";
	    }
	}
	foreach my $add_new (@{$$href{'new'}})
	{
	    if (not $ctx->addrcpt($add_new))
	    {
		print "Unable to addrcpt $add_new\n";
	    }
	}
    }

    return SMFIS_CONTINUE;
}


my %callbacks =
(
 'connect' =>   \&connect_callback,
 'envfrom' =>   \&envfrom_callback,
 'envrcpt' =>	\&envrcpt_callback,
 'eom' =>	\&eom_callback,
 'abort' =>	\&abort_callback,
 'close' =>	\&close_callback,
);

BEGIN:
{
    if (scalar(@ARGV) < 2)
    {
	print "Usage: perl $0 <name_of_filter> <path_to_sendmail.cf>\n";
	exit;
    }
    
    my $conn = Sendmail::Milter::auto_getconn($ARGV[0], $ARGV[1]);
    
    my $DEBUG = 0;
    
    openlog ('timedelay','cons,pid','local4');

    print "Found connection info for '$ARGV[0]': $conn\n" if $DEBUG;
    
    if ($conn =~ /^local:(.+)$/)
    {
	my $unix_socket = $1;
	
	if (-e $unix_socket)
	{
	    print "Attempting to unlink UNIX socket '$conn' ... " if $DEBUG;
	    
	    if (unlink($unix_socket) == 0)
	    {
		print "failed.\n" if $DEBUG;
		exit;
	    }
	    print "successful.\n" if $DEBUG;
	}
    }
    
    if (not Sendmail::Milter::auto_setconn($ARGV[0], $ARGV[1]))
    {
	print "Failed to detect connection information.\n";
	exit;
    }
    
    #
    #  The flags parameter is optional. SMFI_CURR_ACTS sets all of the
    #  current version's filtering capabilities.
    #
    #  %Sendmail::Milter::DEFAULT_CALLBACKS is provided for you in getting
    #  up to speed quickly. I highly recommend creating a callback table
    #  of your own with only the callbacks that you need.
    #
    
    if (not Sendmail::Milter::register($ARGV[0], \%callbacks,
				       SMFI_CURR_ACTS))
    {
	print "Failed to register callbacks for $ARGV[0].\n";
	exit;
	}
    
    print "Starting Sendmail::Milter $Sendmail::Milter::VERSION engine.\n" if $DEBUG;
    
    if (Sendmail::Milter::main())
    {
	print "Successful exit from the Sendmail::Milter engine.\n" if $DEBUG;
	}
    else
    {
	print "Unsuccessful exit from the Sendmail::Milter engine.\n" if $DEBUG;
    }
}