File: Greylisting.pm

package info (click to toggle)
sa-exim 4.2.1-4
  • links: PTS
  • area: main
  • in suites: etch, etch-m68k
  • size: 376 kB
  • ctags: 156
  • sloc: ansic: 1,296; perl: 274; makefile: 117; sh: 86
file content (296 lines) | stat: -rw-r--r-- 9,513 bytes parent folder | download | duplicates (5)
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
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
package Greylisting;
#
# $Id: Greylisting.pm,v 1.4 2006/01/11 17:17:28 marcmerlin Exp $
#

# General Greylisting Plugin, written by Marc MERLIN <marc_soft@merlins.org>
# (Kristopher Austin gets the credit for the original port to an SA 3.0 plugin)
#
# This was originally written to implement greylisting in SA-Exim, although
# I have tried to make it more general and allow for reuse in other MTAs
# (although they will need to
# 1) be running SA at SMTP time
# 2) Provide the list of rcpt to and env from in some headers for SA to read
# 3) Provide the IP of the connecting host )
#
# This rule should get a negative score so that if we've already seen the
# greylisting tuplet before, we lower the score, which hopefully brings us from
# a tempreject to an accept (at least that's how sa-exim does it)
# 
# -- Marc 2004/01/19

use strict;
use Mail::SpamAssassin::Plugin;
our @ISA = qw(Mail::SpamAssassin::Plugin);

sub new 
{
    my ($class, $mailsa) = @_;
    $class = ref($class) || $class;
    my $self = $class->SUPER::new($mailsa);
    bless ($self, $class);
    $self->register_eval_rule ("greylisting");
    return $self;
}


sub check_end
{
    my ($self, $permsgstatus) = @_;

    if (not $self->{'rangreylisting'})
    {
	Mail::SpamAssassin::Plugin::dbg("GREYLISTING: greylisting didn't run since the configuration wasn't setup to call us");
    }
}

# Greylisting happens depending on the SA score, so we want to run it last,
# which is why we give it a high priority
sub greylisting 
{
    my ($self, $permsgstatus, $optionhash) = @_;

    my $connectip; 
    my $envfrom;
    my $rcptto;
    my @rcptto;
    my $iswhitelisted=0;
    my $err;
    my $mesgid = $permsgstatus->get('Message-Id')."\n"; 
    my $mesgidfn;
    my $tuplet;
    my $sascore = $permsgstatus->get_score();
    my $dontcheckscore;
    my %option;

    Mail::SpamAssassin::Plugin::dbg("GREYLISTING: called function");

    $optionhash  =~ s/;/,/g;
    # This is safe, right? (users shouldn't be able to set it in their config)
    %option=eval $optionhash;
    $self->{'rangreylisting'}=1;

    foreach my $reqoption (qw ( method greylistsecs dontgreylistthreshold
	connectiphdr envfromhdr rcpttohdr greylistnullfrom greylistfourthbyte ))
    {
	die "Greylist option $reqoption missing from SA config" unless (defined $option{$reqoption});
    }

    $dontcheckscore = $option{'dontgreylistthreshold'};


    # No newlines, thank you (yes, you need this twice apparently)
    chomp ($mesgid);
    chomp ($mesgid);
    # Newline in the middle mesgids, are you serious? Get rid of them here
    $mesgid =~ s/\012/|/g;

    # For stuff that we know is spam, don't greylist the host
    # (that might help later spam with a lower score to come in)
    if ($sascore >= $dontcheckscore)
    {
	Mail::SpamAssassin::Plugin::dbg("GREYLISTING: skipping greylisting on $mesgid, since score is already $sascore and you configured greylisting not to bother with anything above $dontcheckscore");
	return 0;
    }
    else
    {
	Mail::SpamAssassin::Plugin::dbg("GREYLISTING: running greylisting on $mesgid, since score is too low ($sascore) and you configured greylisting to greylist anything under $dontcheckscore");
    }

    if (not $connectip = $permsgstatus->get($option{'connectiphdr'}))
    {
	warn "Couldn't get Connecting IP header $option{'connectiphdr'} for message $mesgid, skipping greylisting call\n";
	return 0;
    }
    chomp($connectip);
    # Clean up input (for security, if you use files/dirs)
    $connectip =~ /([\d.:]+)/;
    $connectip = ($1 or "");

    # Account for a null envelope from
    if (not defined ($envfrom = $permsgstatus->get($option{'envfromhdr'})))
    {
	warn "Couldn't get Envelope From header $option{'envfromhdr'} for message $mesgid, skipping greylisting call\n";
	return 0;
    }
    chomp($envfrom);
    # Clean up input (for security, if you use files/dirs)
    $envfrom =~ s#/#-#g;
    if (not $envfrom)
    {
	$envfrom="<>";
	return 0 if (not $option{'greylistnullfrom'});
    }

    if (not $rcptto = $permsgstatus->get($option{'rcpttohdr'}))
    {
	warn "Couldn't get Rcpt To header $option{'rcpttohdr'} for message $mesgid, skipping greylisting call\n";
	return 0;
    }
    chomp($rcptto);
    # Clean up input (for security, if you use files/dirs)
    $rcptto =~ s#/#-#g;
    @rcptto = split(/, /, $rcptto);


    umask 0007;

    foreach $rcptto (@rcptto)
    {
	# The dir method is easy to fiddle with and expire records in (with
	# a find | rm) but it's probably more I/O extensive than a real DB
	# and suffers from directory size problems if a specific IP is sending
	# generating tens of thousands of tuplets. -- Marc
	# That said, I prefer formats I can easily tinker with, and not having
	# to worry about buggy locking and so forth

	if ($option{'method'} eq "dir")
	{
	    my $tmpvar;

	    # The clean strings are hardcoded because it's hard to do a variable
	    # substitution within a tr (and using the eval solution is too
	    # resource expensive)
	    # envfrom could be cleaned outside of the loop, but the other method 
            # options might now want that
	    $envfrom =~ tr/!#%()*+,-.0123456789:<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[]^_abcdefghijklmnopqrstuvwxyz{|}~/_/c;
	    # clean variables to run properly under -T
	    $envfrom =~ /(.+)/;
	    $tmpvar = ($1 or "");
	    # work around bug in perl untaint in perl 5.8
	    $envfrom=undef;
	    $envfrom=$tmpvar;
	    $rcptto  =~ tr/!#%()*+,-.0123456789:<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[]^_abcdefghijklmnopqrstuvwxyz{|}~/_/c;
	    $rcptto =~ /(.+)/;
	    $tmpvar = ($1 or "");
	    $rcptto=undef;
	    $rcptto=$tmpvar;

	    die "greylist option dir not passed, even though method was set to dir" unless ($option{'dir'});
	    
	    # connectip is supposed to be untainted now, but I was still getting
	    # some insecure dependecy error messages sometimes (perl 5.8 problem apparently)
	    $connectip =~ /(\d+)\.(\d+)\.(\d+)\.(\d+)/;
	    my ($ipbyte1, $ipbyte2, $ipbyte3, $ipbyte4) = ($1, $2, $3, $4);
	    my $ipdir1 = "$option{'dir'}/$ipbyte1";
	    my $ipdir2 = "$ipdir1/$ipbyte2";
	    my $ipdir3 = "$ipdir2/$ipbyte3";
	    my $ipdir4;
	    my $tupletdir;

	    $ipdir4 = "$ipdir3";
	    $ipdir4 .= "/$ipbyte4" if ($option{'greylistfourthbyte'});
	    $tupletdir = "$ipdir4/$envfrom";

	    $tuplet = "$tupletdir/$rcptto";

	    # make directory whether it's there or not (faster than test and set)
	    mkdir $ipdir1;
	    mkdir $ipdir2;
	    mkdir $ipdir3;
	    mkdir $ipdir4;
	    mkdir $tupletdir;

	    if (not -e $tuplet) 
	    {
		# If the tuplets aren't there, we create them and continue in
		# case there are other ones (one of them might be whitelisted
		# already)
		$err="creating $tuplet";
		open (TUPLET, ">$tuplet") or goto greylisterror;
		print TUPLET time."\n";
		print TUPLET "Status: Greylisted\n";
		print TUPLET "Last Message-Id: $mesgid\n";
		print TUPLET "Whitelisted Count: 0\n";
		print TUPLET "Query Count: 1\n";
		print TUPLET "SA Score: $sascore\n";
		$err="closing first-written $tuplet";
		close TUPLET or goto greylisterror;
	    }
	    else
	    {
		my $time;
		my $status;
		my $whitelistcount;
		my $querycount;

		# Take into account race condition of expiring deletes and us
		# running
		$err="reading $tuplet";
		open (TUPLET, "<$tuplet") or goto greylisterror;
		$err="Couldn't read time";
		defined ($time=<TUPLET>) or goto greylisterror;
		chomp ($time);

		$err="Couldn't read status";
		defined ($status=<TUPLET>) or goto greylisterror;
		chomp ($status);
		$err="Couldn't extract Status from $status";
		$status =~ s/^Status: // or goto greylisterror;

		# Skip Mesg-Id
		$err="Couldn't skip Mesg-Id";
		defined ($_=<TUPLET>) or goto greylisterror;

		$err="Couldn't read whitelistcount";
		defined ($whitelistcount=<TUPLET>) or goto greylisterror;
		chomp ($whitelistcount);
		$err="Couldn't extract Whitelisted Count from $whitelistcount";
		$whitelistcount =~ s/^Whitelisted Count: // or goto greylisterror;

		$err="Couldn't read querycount";
		defined ($querycount=<TUPLET>) or goto greylisterror;
		chomp ($querycount);
		$err="Couldn't extract Query Count from $querycount";
		$querycount =~ s/^Query Count: // or goto greylisterror;
		close (TUPLET);

		$querycount++;
		if ((time - $time) > $option{'greylistsecs'})
		{
		    $status="Whitelisted";
		    $whitelistcount++;
		}

		$err="re-writing $tuplet";
		open (TUPLET, ">$tuplet") or goto greylisterror;
		print TUPLET "$time\n";
		print TUPLET "Status: $status\n";
		print TUPLET "Last Message-Id: $mesgid\n";
		print TUPLET "Whitelisted Count: $whitelistcount\n";
		print TUPLET "Query Count: $querycount\n";
		print TUPLET "SA Score: $sascore\n";
		$err="closing re-written $tuplet";
		close TUPLET or goto greylisterror;

		# We continue processing the other recipients, to setup or
		# update their counters
		if ($status eq "Whitelisted")
		{
		    $iswhitelisted=1;
		}
	    }
	}
	elsif ($option{'method'} eq "file")
	{
	    warn "codeme (file greylisting)\n";
	}
	elsif ($option{'method'} eq "db")
	{
	    warn "codeme (db greylisting)\n";
	}
    }
    
    Mail::SpamAssassin::Plugin::dbg("GREYLISTING: computed greylisting on tuplet, saved info in $tuplet and whitelist status is $iswhitelisted");
    return $iswhitelisted;
    
    greylisterror:
    warn "Reached greylisterror: $err / $!";
    # delete tuplet since it apparently had issues but don't check for errors
    # in case it was a permission denied on write
    unlink ($tuplet);
    return $iswhitelisted;
}


1;