//depot/projects/greylistd/lib/Mail/Greylist.pm#5 – edit change 110 (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.31'; |
| 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 | white => $args{whitelist} || [], |
| 25 | db => {}, |
| 26 | }; |
| 27 | tie %{ $self->{db} }, 'DB_File', $self->{dbfile}, O_RDWR|O_CREAT, 0600, $DB_HASH |
| 28 | or die "can't tie $self->{dbfile}: $!"; |
| 29 | return bless $self, $class; |
| 30 | } |
| 31 | |
| 32 | sub triplet { |
| 33 | my ($self, $ip, $from, $to) = @_; |
| 34 | # big ISPs retry from a different box in the same farm; key on the /24 |
| 35 | (my $net = $ip) =~ s/\.\d+$//; |
| 36 | return join("/", $net, lc($from || '<>'), lc $to); |
| 37 | } |
| 38 | |
| 39 | # returns "DUNNO" to let postfix carry on, or a defer action |
| 40 | sub check { |
| 41 | my ($self, %req) = @_; |
| 42 | for my $re (@{ $self->{white} }) { |
| 43 | return "DUNNO" if $req{client_address} =~ $re; |
| 44 | } |
| 45 | my $key = $self->triplet($req{client_address}, $req{sender}, $req{recipient}); |
| 46 | my $now = time; |
| 47 | |
| 48 | my $first = $self->{db}{$key}; |
| 49 | if (!defined $first) { |
| 50 | $self->{db}{$key} = $now; |
| 51 | return "DEFER_IF_PERMIT Greylisted, please try again later"; |
| 52 | } |
| 53 | if ($now - $first < $self->{delay}) { |
| 54 | return "DEFER_IF_PERMIT Greylisted, please try again later"; |
| 55 | } |
| 56 | return "DUNNO"; |
| 57 | } |
| 58 | |
| 59 | sub purge { |
| 60 | my $self = shift; |
| 61 | my $now = time; |
| 62 | my @old = grep { $now - $self->{db}{$_} > $LIFETIME } keys %{ $self->{db} }; |
| 63 | delete @{ $self->{db} }{@old}; |
| 64 | return scalar @old; |
| 65 | } |
| 66 | |
| 67 | sub DESTROY { |
| 68 | my $self = shift; |
| 69 | untie %{ $self->{db} }; |
| 70 | } |
| 71 | |
| 72 | 1; |
| 73 | __END__ |
| 74 | |
| 75 | =head1 NAME |
| 76 | |
| 77 | Mail::Greylist - greylisting policy engine for Postfix |
| 78 | |
| 79 | =head1 SYNOPSIS |
| 80 | |
| 81 | my $gl = Mail::Greylist->new(dbfile => '/tmp/gl.db'); |
| 82 | print $gl->check(client_address => '10.0.0.7', |
| 83 | sender => 'spammer@example.com', |
| 84 | recipient => 'ksimpson@ttul.org'); |
| 85 | |
| 86 | =head1 AUTHOR |
| 87 | |
| 88 | nullbyte <nullbyte@ttul.org> |
| 89 | |
| 90 | =cut |