lib/Exim/Grey.pm
changeset 73 e2559ee78cb3
parent 72 f095f28db247
equal deleted inserted replaced
72:f095f28db247 73:e2559ee78cb3
     7 use Carp;
     7 use Carp;
     8 
     8 
     9 our @EXPORT_OK   = qw(unseen seen getDBDir connectDB getDefault);
     9 our @EXPORT_OK   = qw(unseen seen getDBDir connectDB getDefault);
    10 our %EXPORT_TAGS = (all => \@EXPORT_OK,);
    10 our %EXPORT_TAGS = (all => \@EXPORT_OK,);
    11 our $VERSION     = '2.0';
    11 our $VERSION     = '2.0';
       
    12 
       
    13 our $verbose;
       
    14 
       
    15 sub verbose {
       
    16     return if not $verbose;
       
    17     print STDERR __PACKAGE__ . ': ' . map { s/\0//gr } @_, "\n";
       
    18 }
       
    19 
       
    20 sub exim_bool { $_[0] ? 'yes' : 'no' }
    12 
    21 
    13 # You may choose, but DB_File's footprint is smaller.
    22 # You may choose, but DB_File's footprint is smaller.
    14 # perl -MDB_File -e 'tie %h, ...':	real    0m0.063s
    23 # perl -MDB_File -e 'tie %h, ...':	real    0m0.063s
    15 # perl -MBerkeleyDB -e 'tie %h, ...':	real	0m0.112s
    24 # perl -MBerkeleyDB -e 'tie %h, ...':	real	0m0.112s
    16 # And DB_File is part of the Perl core distribution (?)
    25 # And DB_File is part of the Perl core distribution (?)
    17 # use BerkeleyDB;
    26 # use BerkeleyDB;
    18 # use DB_File;
    27 # use DB_File;
       
    28 #
    19 # But we need locking! DB_File::Lock isn't part of the corelist.
    29 # But we need locking! DB_File::Lock isn't part of the corelist.
    20 use DB_File::Lock;
    30 use DB_File::Lock;
    21 
    31 
    22 my %DEFAULT = (
    32 my %DEFAULT = (
    23     delay => 600,
    33     delay => 600,
    28 sub getDBDir();
    38 sub getDBDir();
    29 sub findExim(;$);
    39 sub findExim(;$);
    30 sub connectDB($$);
    40 sub connectDB($$);
    31 sub getDefault() { %DEFAULT }
    41 sub getDefault() { %DEFAULT }
    32 
    42 
    33 
       
    34 # dbm file is relativ to $spool_directory/grey, EXCEPT its name
    43 # dbm file is relativ to $spool_directory/grey, EXCEPT its name
    35 # starts with "./" or "/".
    44 # starts with "/".
    36 
    45 
    37 sub unseen {
    46 sub unseen_ {
    38     my $item   = shift;
    47     my $item   = shift;
    39     my $delay  = shift // $DEFAULT{delay};
    48     my $delay  = shift // $DEFAULT{delay};
    40     my $db     = shift // $DEFAULT{db};
    49     my $db     = shift // $DEFAULT{db};
    41     my $now    = time();
    50     my $now    = time();
    42     my ($auto) = $item =~ /.*?\/(.+?)$/ # remove the /<autokey> from the item
    51     my ($auto) = $item =~ /.*?\/(.+?)$/ # remember the /<autokey> from the item
    43         and $item =~ s/\/.*?$//;
    52         and $item =~ s/\/.*?$//;        # and remove it from the item
    44     my $rc;
    53     my $rc;
    45 
    54 
    46     connectDB(\my %h, $db);
    55     connectDB(\my %h, $db);
    47 
    56 
    48     return 'no'    # not unseen, ergo known
    57     return 1    # not unseen, ergo known
    49       if defined $auto and is_whitelisted($auto, \%h);
    58       if defined $auto and is_whitelisted($auto, \%h);
    50 
    59 
    51     my $key = "$item\0";
    60     my $key = "$item\0";                # for compatibility with Exim's dbm functions
    52 
    61 
    53     # we do not know anything about the client -> unknown
    62     # We do not know anything about the client -> unknown.
       
    63     # But remember that key with the associated "auto" subkey
    54     if (not exists $h{$key}) {
    64     if (not exists $h{$key}) {
    55         $h{$key} = "$now $now 0"
    65         $h{$key} = serialize(t0 => $now, t1 => $now, count => 0, auto => [defined $auto ? $auto : ()]);
    56             . (defined $auto ? " auto=$auto" : '')
    66 
    57             . "\0";
    67         verbose "unseen: $item" if $verbose;
    58         return 'yes';
    68         return 1;
    59     }
    69     }
    60 
    70 
    61     my ($created, undef, $count, $flags) = split /[ \0]/, $h{$key};
    71     my %entry = deserialize($h{$key});
    62 
    72 
    63     # we know the client, but last contact was recently (too fast)
    73     # we know the client, but last contact was recently (too fast)
    64     if ($now - $created < $delay) {
    74     # should we add it to our list auto entries too?
    65         return 'yes';
    75     if ($now - $entry{t0} < $delay) {
       
    76         return 1;
    66     }
    77     }
    67 
    78 
    68     # we know the client, was patiently enough
    79     # we know the client, was patiently enough
    69     ++$count;
    80     whitelist(\%h, uniq($auto, $entry{auto})) if defined $auto;
    70     $h{$key} = "$created $now $count\0";
    81     $entry{count}++;
    71     whitelist(\%h, $auto, $flags =~ /auto=(\S+)/) if defined $auto;
    82     $h{$key} = $_ = serialize(%entry);
    72     return 'no';
    83     verbose "seen: $_" if $verbose;
    73 }
    84     return 0;
    74 
    85 }
    75 sub seen {
    86 
    76     return(unseen(@_) eq 'yes' ? 'no' : 'yes');
    87 sub unseen { exim_bool unseen_ @_ }
    77 }
    88 sub seen { exim_bool !unseen_ @_ }
    78 
    89 
    79 # According to a thought from "David Woodhouse <dwmw2@infradead.org>"
    90 # According to a thought from "David Woodhouse <dwmw2@infradead.org>"
    80 # on exim-users@exim.org (Thu, 08 May 2008 13:10:21 +0100,
    91 # on exim-users@exim.org (Thu, 08 May 2008 13:10:21 +0100,
    81 # Message-Id: <1210248621.25560.1088.camel@pmac.infradead.org>) we
    92 # Message-Id: <1210248621.25560.1088.camel@pmac.infradead.org>) we
    82 # should have the ability to "auto whitelist" hosts which are known
    93 # should have the ability to "auto whitelist" hosts which are known
    91 # (Where <KEY> is something like <$sender_address>+<$local_part@$domain>
   102 # (Where <KEY> is something like <$sender_address>+<$local_part@$domain>
    92 # If we see the same message a second time (same message means here:
   103 # If we see the same message a second time (same message means here:
    93 # same greylist criteria
   104 # same greylist criteria
    94 
   105 
    95 sub whitelist {
   106 sub whitelist {
    96     my ($h, @items) = @_;
   107     my ($h, @items) = (shift, uniq(@_));
    97     my $now = time;
   108     my $now = time;
       
   109     warn __PACKAGE__ . ": whitelist: @items\n"
       
   110         if $verbose;
    98     $h->{"$_\0"} = "$now $now 1 auto\0"
   111     $h->{"$_\0"} = "$now $now 1 auto\0"
    99         foreach uniq(@items);
   112         foreach uniq(@items);
   100 }
   113 }
   101 
   114 
   102 sub uniq {
   115 sub uniq {
   106 
   119 
   107 sub is_whitelisted {
   120 sub is_whitelisted {
   108     my ($item, $h) = @_;
   121     my ($item, $h) = @_;
   109     my $key = "$item\0";
   122     my $key = "$item\0";
   110 
   123 
       
   124     warn __PACKAGE__ . 'is '
       
   125         . (exists $h->{$key} ? '' : 'not')
       
   126         . "whitelisted: $item\n" if $verbose;
       
   127 
   111     return 0 if not exists $h->{$key};
   128     return 0 if not exists $h->{$key};
   112 
   129 
   113     my ($t0, undef, $cnt, $flag) = split /[ \0]/, $h->{$key};
   130     my ($t0, undef, $cnt, $flag) = split /[ \0]/, $h->{$key};
   114     $h->{$key} = join(' ' => $t0, time, ++$cnt, $flag ? $flag : ()) . "\0";
   131     $h->{$key} = join(' ' => $t0, time, ++$cnt, $flag ? $flag : ()) . "\0";
       
   132 
   115 
   133 
   116     return 1;
   134     return 1;
   117 }
   135 }
   118 
   136 
   119 # Get the directory where we could store the database file(s)
   137 # Get the directory where we could store the database file(s)
   149     die "Can't find exim binary (missing .../sbin dirs in PATH?";
   167     die "Can't find exim binary (missing .../sbin dirs in PATH?";
   150 }
   168 }
   151 
   169 
   152 sub connectDB($$) {
   170 sub connectDB($$) {
   153     my ($h, $db) = @_;
   171     my ($h, $db) = @_;
   154     $db = getDBDir() . "/$db" unless $db =~ m(^\.?/);
   172     $db = getDBDir() . "/$db" unless $db =~ m(^/);
   155 
   173 
   156     # Creation of DB-File if it doesn't exist
   174     # Creation of DB-File if it doesn't exist
   157     # to avoid races we change our own uid/gid for creation of
   175     # to avoid races we change our own uid/gid for creation of
   158     # this file.
   176     # this file.
   159     if (!-f $db) {
   177     if (!-f $db) {
   193     }
   211     }
   194 
   212 
   195     die "Can't connect to database driver";
   213     die "Can't connect to database driver";
   196 }
   214 }
   197 
   215 
       
   216 # These two functions do not truly serialize/de-serialize the data
       
   217 # passed. They're specialiased to a fixed data format:
       
   218 # serialized: <t0> <t1> <count> [auto=<item>[,<item>]...]
       
   219 # structured: (
       
   220 #   t0 => <t0>,
       
   221 #   t1 => <t1>,
       
   222 #   count => <count>,
       
   223 #   auto => [item, item, …],
       
   224 #   )
       
   225 sub serialize {
       
   226     my %data = @_;
       
   227     my $auto = (ref $data{auto} && @{$data{auto}}) ?  join ',', @{$data{auto}} : '';
       
   228     return "$data{t0} $data{t1} $data{count} auto=$auto\0";
       
   229 }
       
   230 
       
   231 sub deserialize {
       
   232     my @data = split / /, $_[0] =~ s/\0$//r;
       
   233     my %data;
       
   234     ($data{t0}, $data{t1}, $data{count}) = splice @data, 0, 3;
       
   235     if ($data[0] =~ /^auto=(.*)/) {
       
   236         $data{auto} = [split /,/, $1];
       
   237     }
       
   238     return %data;
       
   239 }
       
   240 
   198 1;
   241 1;
   199 
   242 
   200 __END__
   243 __END__
   201 =head1 NAME
   244 =head1 NAME
   202 
   245