#!/usr/bin/perl -w
=begin doc
SpamGourmet-alike Plugin
========================
This plugin allows you to distribute email address which have an
in-built self-destruct.
There are two types of self-destruction possible:
1. Delivery Count
2. Date-based
An email address with a date component will only be accepted for
delivery providing the date contained in it is not in the past.
Similarly the delivery-count based restriction will keep a running
total of each delivery attempt. No more than the proscribed number
of deliveries will be attempted.
Both these systems work by adding a extra part to the email address,
separeted with "." characters. These extra componants will be filtered
out of the mails which are accepted for delivery.
Delivery Count Restrictions
---------------------------
If the email address is of the form:
foo.3.count@example.org
or
foo.count.3@example.org
No more than three delivery attempts will be accepted. Each time
a delivery attempt is made a note will be made upon the local disk,
so that it may persist.
Date Restrictions
-----------------
If an email address contains the "date" string, and a date, in the
following forms it will only accept mail if the date specified is not
in the past:
foo.21-02-08.date@example.org
foo.date.21-02-08@example.org
The example addresses listed above will accept delivery until the
specified date has passed.
Note: That if you current day is March 10th 2008, then the following
will work on until March 11th:
steve.10-3-2008@example.org
(ie. The current day is not considered to be in the past.)
Date Formatting
---------------
Leading zeros do not need to be specified, and if the year is not
fully qualified it will be added to 2000.
This means that "1-2-8" will be intepretted as 1st February 2008.
Address Re-Writing
------------------
Each of the following will be rewritting such that the mail is
delivered to: <steve@example.com>
steve.count.1@example.com
steve.1.count@example.com
steve.date.10-03-2008@example.com
steve.10-3-8.date@example.com
steve.10-03-2008.date@example.com
steve.10-3-8.date@example.com
(ie. Both the "count" and "date" portions of the address will be
removed, and the restriction-specific data will be removed.)
Author
------
Steve Kemp
Links
-----
http://www.spam-gourmet.com/
=end doc
=cut
use strict;
use warnings;
use File::Path;
use Qpsmtpd::Constants;
=begin doc
The registration routine accepts only a single optional argument,
the location of the directory to use for persistant storage.
(The persistant storage is required for the count-testing only.)
=end doc
=cut
sub register
{
my ( $self, $qp, @args ) = @_;
if ( @args > 0 )
{
( $self->{ _storage } ) = ( $args[0] =~ m!([/\w\.]+)! );
}
#
# Default will be used if nothing is specified.
#
unless ( $self->{ _storage } )
{
$self->{ _storage } = "/var/tmp/qcount";
}
}
=begin doc
This is where we test to see if the recipient is one of our special ones.
There are two possible return values:
DENY, "message" -> The delivery should be rejected.
ON, "recipient" -> The mail should be delivered to the recipient
The recipient is rewritten if the message is to be accepted, see the
earlier note on that.
=end doc
=cut
sub hook_rcpt
{
my ( $self, $transaction ) = ( shift, shift );
#
# The user + domain the message is delivered to.
#
my $user = $_[0]->user();
my $domain = $_[0]->host();
#
# The rewritten address, if any.
#
my $real = undef;
#
# Testing for a local domain could be done here. Something like:
#
# return DECLINED if ( ! -e "/etc/exim4/virtual/$domain" );
#
# Still rcpt_ok will do this already - the only issue is that
# we'll write files to local disk if we receive emails to
#
# blah.1.count@bogus.tld
#
# even if that domain isn't a local one. Probably not a big
# deal.
#
#
# username.$number.count@example.com
#
# or
#
# username.count.$number@example.com
#
if ( ( $user =~ /^(.*)\.([0-9]+)\.count$/ ) ||
( $user =~ /^(.*)\.count\.([0-9]+)$/ ) )
{
#
# The real local-part - to whom the mail will be delivered
# if it is valid.
#
$real = $1;
# the count for this alias
my $count = $2;
if (
count_exceeded( $self->{ _storage }, $real . "-" . $domain, $count
) )
{
$self->log( LOGWARN, "spam_gourmet: count exceeded for $user" );
return ( DENY, "Quota exceeded $user" );
}
else
{
increase_count( $self->{ _storage }, $real . "-" . $domain,
$count );
}
}
#
# username.DD-MM-YY[YY].date@example.org
#
# or
#
# username.date.DD-MM-YY@example.org
#
#
if ( ( $user =~ /^(.*)\.([0-9]+)-([0-9]+)-([0-9]+)\.date$/ ) ||
( $user =~ /^(.*)\.date\.([0-9]+)-([0-9]+)-([0-9]+)$/ ) )
{
#
# The real local-part - to whom the mail will be delivered
# if it is valid.
#
$real = $1;
# the date.
my $day = $2;
my $mon = $3;
my $year = $4;
#
# Reject if in the past.
#
if ( in_past( $day, $mon, $year ) )
{
$self->log( LOGWARN, "spam_gourmet: Date in the past $user" );
return ( DENY, "Date in past $day-$mon-$year" );
}
}
#
# Change the address?
#
if ( defined($real) && ( $real ne $user ) )
{
# used for logging
my $old = "<" . $user . '@' . $domain . ">";
my $new = "<" . $real . '@' . $domain . ">";
# replace the address.
$_[0] = Qpsmtpd::Address->new($new);
# log
$self->log( LOGWARN, "spam_gourmet: replaced $old with $new" );
}
#
# OK, we're going to accept the mail, with the rewritten destination
# address.
#
return (DECLINED);
}
=begin doc
Test if the count has been exceeded.
=end doc
=cut
sub count_exceeded
{
my ( $dir, $user, $count ) = (@_);
#
# Make sure we have a storage directory
#
if ( !-d $dir )
{
mkpath( $dir, 0 );
}
#
# normalise the username to avoid directory traversals, etc.
#
$user =~ s/[^a-z0-9]/_/g;
#
# Has the count been met?
#
if ( -e "$dir/$user.$count" )
{
return 1;
}
else
{
return 0;
}
}
=begin doc
Bump the count for the given user.
=end doc
=cut
sub increase_count
{
my ( $dir, $user ) = (@_);
#
# Make sure we have a storage directory
#
if ( !-d $dir )
{
mkpath( $dir, 0 );
}
#
# normalise the username to avoid directory traversals, etc.
#
$user =~ s/[^a-z0-9]/_/g;
#
# Find the current count.
#
my $max = 0;
foreach my $file ( sort( glob( $dir . "/$user.[0-9]*" ) ) )
{
if ( $file =~ /\.([0-9]+)$/ )
{
my $c = $1;
$max = $c if ( $c > $max );
}
}
#
# Bump the count by one, and record it.
#
$max += 1;
open( FILE, ">", "$dir/$user.$max" );
print FILE "\n";
close(FILE);
}
=begin doc
Is the given date in the past?
=end doc
=cut
sub in_past
{
my ( $day, $mon, $year ) = (@_);
#
# Get the current date.
#
my ( undef, undef, undef, $cday, $cmon, $cyear, undef, undef, undef ) =
localtime(time);
#
# normalise the current date.
#
$cyear += 1900;
$cmon += 1;
#
# Add on century to the year we're testing if it is missing.
#
if ( length($year) < 4 )
{
$year += 2000;
}
#
# previous year.
#
return 1 if ( $year < $cyear );
#
# previous month
#
return 1 if ( $mon < $cmon );
#
# previous day
#
if ( ( $year eq $cyear ) &&
( $mon eq $cmon ) &&
( $day < $cday ) )
{
return 1;
}
#
# Must be ok.
#
return 0;
}