1 # © 2006,2007,2008 Heiko Schlittermann <hs@schlittermann.de>

     2 # $Id$

     3 # $URL$

     4 

     5 use strict;

     6 use warnings;

     7 use Carp;

     8 

     9 # You may choose, but DB_File's footprint is smaller.

    10 # perl -MDB_File -e 'tie %h, ...':	real    0m0.063s

    11 # perl -MBerkeleyDB -e 'tie %h, ...':	real	0m0.112s

    12 # And DB_File is part of the Perl core distribution (?)

    13 # use BerkeleyDB;

    14 # use DB_File;

    15 # But we need locking! DB_File::Lock isn't part of the corelist.

    16 use DB_File::Lock;

    17 

    18 my %DEFAULT = (

    19     delay => 600,

    20     db    => "seen",

    21 );

    22 

    23 sub unseen;

    24 

    25 # some helper functions

    26 sub getDBDir();

    27 sub findExim(;$);

    28 sub connectDB($$);

    29 sub getDefault() { %DEFAULT }

    30 

    31 # Usage:

    32 # 	${perl{unseen}{KEY}}

    33 # 	${perl{unseen}{KEY}{600}}

    34 # 	${perl{unseen}{KEY}{600}{seen}}

    35 # 	${perl{unseen}{KEY}{600}{$spool_directory/grey/seen}}

    36 #

    37 # With KEY being something to identify the second delivery attempt

    38 # I recommend using <$sender_address>:<$local_part@$domain>

    39 #

    40 # If KEY has a /... suffix, this suffix is used for auto-whitelisting.

    41 # I recommend using $sender_host_address.

    42 #

    43 # defer  condition = ${perl{unseen}{<$sender_address>:<$local_part@$domain>/$sender_host_address}}

    44 #

    45 # record structure: key:   item\0

    46 #                   value: timestamp(creation) timestamp(usage)[ auto]\0

    47 # (This way we're compatible with ${lookup{...}dbm{...}})

    48 #

    49 # dbm file is relativ to $spool_directory/grey, EXCEPT its name

    50 # starts with "./" or "/".

    51 

    52 sub unseen {

    53     my $item = shift;

    54     my $delay = shift // $DEFAULT{delay};

    55     my $db = shift // $DEFAULT{db};

    56     my $now = time();

    57     my ($auto) = $item =~ /.*?\/(.+?)$/;

    58     my $rc;

    59 

    60     connectDB(\my %h, $db);

    61 

    62     return 'no'         # not unseen, ergo known

    63         if defined $auto and is_whitelisted($auto, \%h);

    64 

    65     my $key = "$item\0";

    66 

    67     # we do not know anything about the client -> unknown

    68     if (not exists $h{$key}) {

    69         $h{$key} = "$now $now 0\0";

    70         return 'yes';

    71     }

    72 

    73     my ($created, undef, $count) = split ' ', $h{$key};

    74 

    75     # we know the client, but last contact was recently (too fast)

    76     if ($now - $created < $delay) { 

    77         return 'yes';

    78     }

    79 

    80     # we know the client, was patiently enough

    81     ++$count;

    82     $h{$key} = "$created $now $count\0";

    83     whitelist($auto, \%h) if defined $auto;

    84     return 'no';

    85 }

    86 

    87 # According to a thought from "David Woodhouse <dwmw2@infradead.org>"

    88 # on exim-users@exim.org (Thu, 08 May 2008 13:10:21 +0100, 

    89 # Message-Id: <1210248621.25560.1088.camel@pmac.infradead.org>) we

    90 # should have the ability to "auto whitelist" hosts which are known

    91 # for retries, because there is no benefit in greylisting them.

    92 #

    93 # Most safe approach would be something based on message id.

    94 # If we see the message id a second time it indicates successful retry.

    95 # But we do not see the message id the first time we reject the message.

    96 

    97 # This function has to be called twice per message delivery attempt

    98 # <KEY> <$sender_host_address> <$sender_helo_name>

    99 # (Where <KEY> is something like <$sender_address>+<$local_part@$domain>

   100 # If we see the same message a second time (same message means here:

   101 # same greylist criteria

   102 

   103 sub whitelist {

   104     my ($item, $h) = @_;

   105     my $now = time;

   106     $h->{"$item\0"} = "$now $now 1 auto\0";

   107 }

   108 

   109 sub is_whitelisted {

   110     my ($item, $h) = @_;

   111     my $key = "$item\0";

   112 

   113     return 0 if not exists $h->{$key};

   114     

   115     my ($t0, undef, $cnt, $flag) = split ' ', $h->{$key};

   116     $h->{$key} = join(' ' => $t0, time, ++$cnt, $flag ? $flag : ()) . "\0";

   117 

   118     return 1;

   119 }

   120 

   121 # Get the directory where we could store the database file(s)

   122 # If we're running under exim it's easy, otherwise we've to find exim

   123 # and then ask...

   124 sub getDBDir() {

   125     my ($spooldir, $dbdir);

   126     eval { $spooldir = Exim::expand_string('$spool_directory') };

   127     if (not defined $spooldir) {

   128         my $exim = findExim();

   129         chomp($spooldir = `$exim -be '\$spool_directory'`);

   130         die "Can't find spooldir" if not defined $spooldir;

   131     }

   132     -d ($dbdir = "$spooldir/grey") and return $dbdir;

   133 

   134     my ($mode, $owner, $group) = (stat $spooldir)[ 2, 4, 5 ];

   135     {

   136         local $) = $group;

   137         local $> = $owner;

   138         $mode &= 0777;

   139         mkdir $dbdir, $mode or die "Can't create $dbdir: $!";

   140     }

   141     return $dbdir;

   142 }

   143 

   144 sub findExim(;$) {

   145     my $path = shift || $ENV{PATH};

   146     my $exim;

   147     foreach (split /:/, $ENV{PATH}) {

   148         -x ($exim = "$_/exim")  and return $exim;

   149         -x ($exim = "$_/exim4") and return $exim;

   150     }

   151     die "Can't find exim binary (missing .../sbin dirs in PATH?";

   152 }

   153 

   154 sub connectDB($$) {

   155     my ($h, $db) = @_;

   156     $db = getDBDir() . "/$db" unless $db =~ m(^\.?/);

   157 

   158     # Creation of DB-File if it doesn't exist

   159     # to avoid races we change our own uid/gid for creation of

   160     # this file.

   161     if (!-f $db) {

   162         (my $dir = $db) =~ s/^(.*)\/.*?$/$1/;

   163 

   164         # copy mode, uid, gid from the directory

   165         my ($mode, $user, $group) = (stat $dir)[ 2, 4, 5 ]

   166           or die "Can't stat $dir: $!";

   167         my $umask = umask(($mode & 0777) ^ 0777);

   168         local $) = $group;

   169         local $> = $user;

   170         open(X, ">>$db") or die "Can't create $db: $!";

   171         close(X);

   172         umask $umask;

   173     }

   174 

   175     # now test which of the DB-Modules has been loaded

   176 

   177     if (exists &BerkeleyDB::Hash::TIEHASH) {

   178         no strict;

   179         my $umask = umask 077;

   180         tie %$h, "BerkeleyDB::Hash", -Filename => $db

   181           or die "$0: $db: $!";

   182         return $db;

   183     }

   184 

   185     if (exists &DB_File::Lock::TIEHASH) {

   186         tie %$h, 'DB_File::Lock', [ $db ], 'write'

   187           or die "$0: $db: $!";

   188         return $db;

   189     }

   190 

   191     if (exists &DB_File::TIEHASH) {

   192         tie %$h, 'DB_File', $db or die "$0: $db: $!";

   193         warn "$0: using DB_File, no locking is possible!\n";

   194         return $db;

   195     }

   196 

   197     die "Can't connect to database driver";

   198 }

   199 

   200 1;

   201 

   202 # vim:aw et sw=4 ts=4: