qpsmtpd

spam_gourmet

This plugin allows you to give out email addresses which will expire, either based upon:

• The number of delivery attempts.
• The date.

The Code

Click here to see the code.

#!/usr/bin/perl

=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://mail-scanning.com/
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" );
        }
        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" );
        }
    }


    #
    #  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;
}