//depot/projects/greylistd/lib/Mail/Greylist.pm#1 – add change 58 (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.1'; |
| 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 | return join("/", $ip, $from, $to); |
| 34 | } |
| 35 | |
| 36 | # returns "DUNNO" to let postfix carry on, or a defer action |
| 37 | sub check { |
| 38 | my ($self, %req) = @_; |
| 39 | my $key = $self->triplet($req{client_address}, $req{sender}, $req{recipient}); |
| 40 | my $now = time; |
| 41 | |
| 42 | my $first = $self->{db}{$key}; |
| 43 | if (!defined $first) { |
| 44 | $self->{db}{$key} = $now; |
| 45 | return "DEFER_IF_PERMIT Greylisted, please try again later"; |
| 46 | } |
| 47 | if ($now - $first < $self->{delay}) { |
| 48 | return "DEFER_IF_PERMIT Greylisted, please try again later"; |
| 49 | } |
| 50 | return "DUNNO"; |
| 51 | } |
| 52 | |
| 53 | sub DESTROY { |
| 54 | my $self = shift; |
| 55 | untie %{ $self->{db} }; |
| 56 | } |
| 57 | |
| 58 | 1; |
| 59 | __END__ |
| 60 | |
| 61 | =head1 NAME |
| 62 | |
| 63 | Mail::Greylist - greylisting policy engine for Postfix |
| 64 | |
| 65 | =head1 SYNOPSIS |
| 66 | |
| 67 | my $gl = Mail::Greylist->new(dbfile => '/tmp/gl.db'); |
| 68 | print $gl->check(client_address => '10.0.0.7', |
| 69 | sender => 'spammer@example.com', |
| 70 | recipient => 'ksimpson@ttul.org'); |
| 71 | |
| 72 | =head1 AUTHOR |
| 73 | |
| 74 | nullbyte <nullbyte@ttul.org> |
| 75 | |
| 76 | =cut |