1 package Exim::Grey;

     2 

     3 use strict;

     4 use warnings;

     5 use base 'Exporter';

     6 use Carp;

     7 

     8 our @EXPORT_OK = qw(unseen getDBDir getDBs connectDB);

     9 our %EXPORT_TAGS = (

    10     all => \@EXPORT_OK,

    11 );

    12 our $VERSION = '2.0';

    13 

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

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

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

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

    18 # use BerkeleyDB;

    19 # use DB_File;

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

    21 use DB_File::Lock;

    22 

    23 my %DEFAULT = (

    24     delay => 600,

    25     db    => "seen",

    26 );

    27 

    28 sub unseen;

    29 

    30 # some helper functions

    31 sub getDBDir();

    32 sub findExim(;$);

    33 sub connectDB($$);

    34 sub getDefault() { %DEFAULT }

    35 

    36 # Usage:

    37 # 	${perl{unseen}{KEY}}

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

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

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

    41 #

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

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

    44 #

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

    46 # I recommend using $sender_host_address.

    47 #

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

    49 #

    50 # record structure: key:   item\0

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

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

    53 #

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

    55 # starts with "./" or "/".

    56 

    57 sub unseen {

    58     my $item = shift;

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

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

    61     my $now = time();

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

    63     my $rc;

    64 

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

    66 

    67     return 'no'         # not unseen, ergo known

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

    69 

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

    71 

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

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

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

    75         return 'yes';

    76     }

    77 

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

    79 

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

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

    82         return 'yes';

    83     }

    84 

    85     # we know the client, was patiently enough

    86     ++$count;

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

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

    89     return 'no';

    90 }

    91 

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

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

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

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

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

    97 #

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

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

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

   101 

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

   103 # <KEY> <$sender_host_address> <$sender_helo_name>

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

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

   106 # same greylist criteria

   107 

   108 sub whitelist {

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

   110     my $now = time;

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

   112 }

   113 

   114 sub is_whitelisted {

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

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

   117 

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

   119     

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

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

   122 

   123     return 1;

   124 }

   125 

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

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

   128 # and then ask...

   129 sub getDBDir() {

   130     my ($spooldir, $dbdir);

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

   132     if (not defined $spooldir) {

   133         my $exim = findExim();

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

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

   136     }

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

   138 

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

   140     {

   141         local $) = $group;

   142         local $> = $owner;

   143         $mode &= 0777;

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

   145     }

   146     return $dbdir;

   147 }

   148 

   149 sub findExim(;$) {

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

   151     my $exim;

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

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

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

   155     }

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

   157 }

   158 

   159 sub connectDB($$) {

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

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

   162 

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

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

   165     # this file.

   166     if (!-f $db) {

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

   168 

   169         # copy mode, uid, gid from the directory

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

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

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

   173         local $) = $group;

   174         local $> = $user;

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

   176         close(X);

   177         umask $umask;

   178     }

   179 

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

   181 

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

   183         no strict;

   184         my $umask = umask 077;

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

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

   187         return $db;

   188     }

   189 

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

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

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

   193         return $db;

   194     }

   195 

   196     if (exists &DB_File::TIEHASH) {

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

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

   199         return $db;

   200     }

   201 

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

   203 }

   204 

   205 1;

   206 

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