#!/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.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; }