lib/DAKKAR/Graylister.pm


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150

package DAKKAR::Graylister; 
use strict;
use warnings;
use DAKKAR::Net::DNSBLLookup;
use DBI;
 
my $DBNAME;
 
sub get_from_env {
    my $from=$ENV{SMTPMAILFROM};
    die "No from??\n" unless defined $from;
    my $to=$ENV{SMTPRCPTTO};
    die "No to??\n" unless defined $to;
    my $host=$ENV{TCPREMOTEIP};
    die "No ip??\n" unless defined $host;
    $DBNAME=$ENV{DAKGL_DBNAME}
        or die "No dbname??\n";
    return _cleanup_data($host,$from,$to);
}
 
sub _cleanup_data {
    my ($host,$from,$to)=@_;
    # EZMLM changes the "from" at each attempt... 
    $from=~s{-return-\d+-}{-return-\$-};
    return ($host,$from,$to);
}
 
sub check {
    my ($host,$from,$to)=@_;
 
    remove_old_attempts();
    if (is_whitelisted($host)) {
        accept_message();return;
    }
    if (is_second_attempt($host,$from,$to)) {
        if (is_blacklisted($host)) {
            cleanup_attempt($host,$from,$to);
            accept_message();return;
        }
        else {
            add_to_whitelist($host);
            accept_message();return;
        }
    }
    record_first_attempt($host,$from,$to);
    reject_temporarily($from);
    return;
}
 
{my $dbh;
 
 sub _init_dbh {
     return if defined $dbh;
     $dbh=DBI->connect("dbi:SQLite:dbname=$DBNAME",'','',
                   {RaiseError=>1,PrintError=>0});
     my $ver=$dbh->selectall_arrayref(q{SELECT count(*) FROM SQLite_Master WHERE Type = 'table' AND name = 'version'});
     if ((!defined $ver) or (!@$ver) or ($ver->[0]->[0]==0)) {
         _prepare_db();
     }
 }
 
 {my @sts=(
     q{create table version(version integer)},
     q{insert into version(version) values (1)},
     q{create table whitelist(host varchar)},
     q{create table attempts(host varchar,smtpfrom varchar,smtprcpt varchar,time integer)},
  );
  sub _prepare_db {
      for my $s (@sts) {
          $dbh->do($s);
      }
  }
 }
 
 sub add_to_whitelist {
     my ($host)=@_;
 
     _init_dbh();
     my $ret=$dbh->do('INSERT INTO whitelist(host) VALUES (?)',
                      {},$host);
 }
 
 sub is_whitelisted {
     my ($host)=@_;
 
     _init_dbh();
     my $ret=$dbh->selectall_arrayref('SELECT * FROM whitelist WHERE host=?',
                                      {Slice=>{}},$host);
     return @$ret>0;
 }
 
 sub record_first_attempt {
     my ($host,$from,$to)=@_;
     _init_dbh();
     my $ret=$dbh->do('INSERT INTO attempts(host,smtpfrom,smtprcpt,time) VALUES (?,?,?,?)',
                      {},$host,$from,$to,time());
 }
 
 sub is_second_attempt {
     my ($host,$from,$to)=@_;
     _init_dbh();
     my $ret=$dbh->selectall_arrayref('SELECT * FROM attempts WHERE host=? AND smtpfrom=? AND smtprcpt=?',
                                      {Slice=>{}},$host,$from,$to);
     return @$ret>0;
 }
 
 sub cleanup_attempt {
     my ($host,$from,$to)=@_;
     _init_dbh();
     if ($from) {
         my $ret=$dbh->do('UPDATE attempts SET time=? WHERE host=? AND smtpfrom=? AND smtprcpt=?',
                      {},time(),$host,$from,$to);
     }
     else {
         # probably a bounce 
         my $ret=$dbh->do('DELETE FROM attempts WHERE host=? AND smtpfrom=? AND smtprcpt=?',
                          {},$host,$from,$to);
     }
 }
 
 sub remove_old_attempts {
     _init_dbh();
     my $ret=$dbh->do('DELETE FROM attempts WHERE time<?',
                      {},(time()-86400));
 }
}
 
 
sub is_blacklisted {
    my ($host)=@_;
    my $look=DAKKAR::Net::DNSBLLookup->new();
    my $ret=$look->lookup($host);
    my ($proxy, $spam, $dyn, $unknown) = $ret->breakdown;
    return ($proxy+$spam+$dyn+$unknown > 0);
}
 
sub accept_message {}
 
{my $message='DAKKAR-Graylister temproray reject, try again later';
 sub reject_temporarily {
     my ($from)=@_;
 
     if ($from eq '' or $from=~/^postmaster@/) {
         print "LD451 $message\n";
     }
     else {
         print "E451 $message\n";
     }
 }
}