//depot/projects/greylistd/lib/Mail/Greylist.pm#4 – edit change 77 (ktext) ·revision history
| 1 | package Mail::Greylist; |
| 2 | |
| 3 | # $Id$ |
| 4 | # |
| 5 | # Greylisting for Postfix: tempfail the first delivery attempt from any |
| 6 | # (client, sender, recipient) triplet we haven't seen before. Real MTAs |
| 7 | # retry. Ratware doesn't. |
| 8 | |
| 9 | use strict; |
| 10 | use warnings; |
| 11 | use DB_File; |
| 12 | use Fcntl; |
| 13 | |
| 14 | our $VERSION = '0.3'; |
| 15 | |
| 16 | my $DELAY = 300; # seconds a new triplet must wait |
| 17 | my $LIFETIME = 36 * 86400; # forget triplets after this long |
| 18 | |
| 19 | sub new { |
| 20 | my ($class, %args) = @_; |
| 21 | my $self = { |
| 22 | dbfile => $args{dbfile} || '/var/lib/greylistd/triplets.db', |
| 23 | delay => defined $args{delay} ? $args{delay} : $DELAY, |
| 24 | db => {}, |
| 25 | }; |
| 26 | tie %{ $self->{db} }, 'DB_File', $self->{dbfile}, O_RDWR|O_CREAT, 0600, $DB_HASH |
| 27 | or die "can't tie $self->{dbfile}: $!"; |
| 28 | return bless $self, $class; |
| 29 | } |
| 30 | |
| 31 | sub triplet { |
| 32 | my ($self, $ip, $from, $to) = @_; |
| 33 | # big ISPs retry from a different box in the same farm; key on the /24 |
| 34 | (my $net = $ip) =~ s/\.\d+$//; |
| 35 | return join("/", $net, lc($from || '<>'), lc $to); |
| 36 | } |
| 37 | |
| 38 | # returns "DUNNO" to let postfix carry on, or a defer action |
| 39 | sub check { |
| 40 | my ($self, %req) = @_; |
| 41 | my $key = $self->triplet($req{client_address}, $req{sender}, $req{recipient}); |
| 42 | my $now = time; |
| 43 | |
| 44 | my $first = $self->{db}{$key}; |
| 45 | if (!defined $first) { |
| 46 | $self->{db}{$key} = $now; |
| 47 | return "DEFER_IF_PERMIT Greylisted, please try again later"; |
| 48 | } |
| 49 | if ($now - $first < $self->{delay}) { |
| 50 | return "DEFER_IF_PERMIT Greylisted, please try again later"; |
| 51 | } |
| 52 | return "DUNNO"; |
| 53 | } |
| 54 | |
| 55 | sub purge { |
| 56 | my $self = shift; |
| 57 | my $now = time; |
| 58 | my @old = grep { $now - $self->{db}{$_} > $LIFETIME } keys %{ $self->{db} }; |
| 59 | delete @{ $self->{db} }{@old}; |
| 60 | return scalar @old; |
| 61 | } |
| 62 | |
| 63 | sub DESTROY { |
| 64 | my $self = shift; |
| 65 | untie %{ $self->{db} }; |
| 66 | } |
| 67 | |
| 68 | 1; |
| 69 | __END__ |
| 70 | |
| 71 | =head1 NAME |
| 72 | |
| 73 | Mail::Greylist - greylisting policy engine for Postfix |
| 74 | |
| 75 | =head1 SYNOPSIS |
| 76 | |
| 77 | my $gl = Mail::Greylist->new(dbfile => '/tmp/gl.db'); |
| 78 | print $gl->check(client_address => '10.0.0.7', |
| 79 | sender => 'spammer@example.com', |
| 80 | recipient => 'ksimpson@ttul.org'); |
| 81 | |
| 82 | =head1 AUTHOR |
| 83 | |
| 84 | nullbyte <nullbyte@ttul.org> |
| 85 | |
| 86 | =cut |