line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# <@LICENSE> |
2
|
|
|
|
|
|
|
# Licensed to the Apache Software Foundation (ASF) under one or more |
3
|
|
|
|
|
|
|
# contributor license agreements. See the NOTICE file distributed with |
4
|
|
|
|
|
|
|
# this work for additional information regarding copyright ownership. |
5
|
|
|
|
|
|
|
# The ASF licenses this file to you under the Apache License, Version 2.0 |
6
|
|
|
|
|
|
|
# (the "License"); you may not use this file except in compliance with |
7
|
|
|
|
|
|
|
# the License. You may obtain a copy of the License at: |
8
|
|
|
|
|
|
|
# |
9
|
|
|
|
|
|
|
# http://www.apache.org/licenses/LICENSE-2.0 |
10
|
|
|
|
|
|
|
# |
11
|
|
|
|
|
|
|
# Unless required by applicable law or agreed to in writing, software |
12
|
|
|
|
|
|
|
# distributed under the License is distributed on an "AS IS" BASIS, |
13
|
|
|
|
|
|
|
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. |
14
|
|
|
|
|
|
|
# See the License for the specific language governing permissions and |
15
|
|
|
|
|
|
|
# limitations under the License. |
16
|
|
|
|
|
|
|
# </@LICENSE> |
17
|
|
|
|
|
|
|
|
18
|
40
|
|
|
40
|
|
257
|
use strict; # make Test::Perl::Critic happy |
|
40
|
|
|
|
|
95
|
|
|
40
|
|
|
|
|
1941
|
|
19
|
|
|
|
|
|
|
package Mail::SpamAssassin::Dns; 1; |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
package Mail::SpamAssassin::PerMsgStatus; |
22
|
|
|
|
|
|
|
|
23
|
40
|
|
|
40
|
|
237
|
use strict; |
|
40
|
|
|
|
|
83
|
|
|
40
|
|
|
|
|
896
|
|
24
|
40
|
|
|
40
|
|
244
|
use warnings; |
|
40
|
|
|
|
|
84
|
|
|
40
|
|
|
|
|
1386
|
|
25
|
|
|
|
|
|
|
# use bytes; |
26
|
40
|
|
|
40
|
|
269
|
use re 'taint'; |
|
40
|
|
|
|
|
73
|
|
|
40
|
|
|
|
|
1325
|
|
27
|
|
|
|
|
|
|
|
28
|
40
|
|
|
40
|
|
243
|
use Mail::SpamAssassin::Conf; |
|
40
|
|
|
|
|
78
|
|
|
40
|
|
|
|
|
1008
|
|
29
|
40
|
|
|
40
|
|
244
|
use Mail::SpamAssassin::PerMsgStatus; |
|
40
|
|
|
|
|
98
|
|
|
40
|
|
|
|
|
949
|
|
30
|
40
|
|
|
40
|
|
259
|
use Mail::SpamAssassin::AsyncLoop; |
|
40
|
|
|
|
|
76
|
|
|
40
|
|
|
|
|
1176
|
|
31
|
40
|
|
|
40
|
|
229
|
use Mail::SpamAssassin::Constants qw(:ip); |
|
40
|
|
|
|
|
87
|
|
|
40
|
|
|
|
|
4704
|
|
32
|
40
|
|
|
40
|
|
299
|
use Mail::SpamAssassin::Util qw(untaint_var am_running_on_windows); |
|
40
|
|
|
|
|
77
|
|
|
40
|
|
|
|
|
2213
|
|
33
|
|
|
|
|
|
|
|
34
|
40
|
|
|
40
|
|
276
|
use File::Spec; |
|
40
|
|
|
|
|
88
|
|
|
40
|
|
|
|
|
1110
|
|
35
|
40
|
|
|
40
|
|
3482
|
use IO::Socket; |
|
40
|
|
|
|
|
52227
|
|
|
40
|
|
|
|
|
440
|
|
36
|
40
|
|
|
40
|
|
25589
|
use POSIX ":sys_wait_h"; |
|
40
|
|
|
|
|
84
|
|
|
40
|
|
|
|
|
369
|
|
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
our $KNOWN_BAD_DIALUP_RANGES; # Nothing uses this var??? |
40
|
|
|
|
|
|
|
our $LAST_DNS_CHECK; |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
# use very well-connected domains (fast DNS response, many DNS servers, |
43
|
|
|
|
|
|
|
# geographical distribution is a plus, TTL of at least 3600s) |
44
|
|
|
|
|
|
|
our @EXISTING_DOMAINS = qw{ |
45
|
|
|
|
|
|
|
adelphia.net |
46
|
|
|
|
|
|
|
akamai.com |
47
|
|
|
|
|
|
|
apache.org |
48
|
|
|
|
|
|
|
cingular.com |
49
|
|
|
|
|
|
|
colorado.edu |
50
|
|
|
|
|
|
|
comcast.net |
51
|
|
|
|
|
|
|
doubleclick.com |
52
|
|
|
|
|
|
|
ebay.com |
53
|
|
|
|
|
|
|
gmx.net |
54
|
|
|
|
|
|
|
google.com |
55
|
|
|
|
|
|
|
intel.com |
56
|
|
|
|
|
|
|
kernel.org |
57
|
|
|
|
|
|
|
linux.org |
58
|
|
|
|
|
|
|
mit.edu |
59
|
|
|
|
|
|
|
motorola.com |
60
|
|
|
|
|
|
|
msn.com |
61
|
|
|
|
|
|
|
sourceforge.net |
62
|
|
|
|
|
|
|
sun.com |
63
|
|
|
|
|
|
|
w3.org |
64
|
|
|
|
|
|
|
yahoo.com |
65
|
|
|
|
|
|
|
}; |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
our $IS_DNS_AVAILABLE = undef; |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
#Removed $VERSION per BUG 6422 |
70
|
|
|
|
|
|
|
#$VERSION = 'bogus'; # avoid CPAN.pm picking up razor ver |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
########################################################################### |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
BEGIN { |
75
|
|
|
|
|
|
|
# some trickery. Load these modules right here, if possible; that way, if |
76
|
|
|
|
|
|
|
# the module exists, we'll get it loaded now. Very useful to avoid attempted |
77
|
|
|
|
|
|
|
# loads later (which will happen). If we do a fork(), we could wind up |
78
|
|
|
|
|
|
|
# attempting to load these modules in *every* subprocess. |
79
|
|
|
|
|
|
|
# |
80
|
|
|
|
|
|
|
# # We turn off strict and warnings, because Net::DNS and Razor both contain |
81
|
|
|
|
|
|
|
# # crud that -w complains about (perl 5.6.0). Not that this seems to work, |
82
|
|
|
|
|
|
|
# # mind ;) |
83
|
|
|
|
|
|
|
# no strict; |
84
|
|
|
|
|
|
|
# local ($^W) = 0; |
85
|
|
|
|
|
|
|
|
86
|
40
|
|
|
40
|
|
9255
|
no warnings; |
|
40
|
|
|
|
|
98
|
|
|
40
|
|
|
|
|
3280
|
|
87
|
40
|
|
|
40
|
|
129
|
eval { |
88
|
40
|
|
|
|
|
20827
|
require Net::DNS; |
89
|
40
|
|
|
|
|
2033411
|
require Net::DNS::Resolver; |
90
|
|
|
|
|
|
|
}; |
91
|
40
|
|
|
|
|
419
|
eval { |
92
|
40
|
|
|
|
|
472
|
require MIME::Base64; |
93
|
|
|
|
|
|
|
}; |
94
|
40
|
|
|
|
|
328
|
eval { |
95
|
40
|
|
|
|
|
182204
|
require IO::Socket::UNIX; |
96
|
|
|
|
|
|
|
}; |
97
|
|
|
|
|
|
|
}; |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
########################################################################### |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
sub do_rbl_lookup { |
102
|
0
|
|
|
0
|
0
|
0
|
my ($self, $rule, $set, $type, $host, $subtest) = @_; |
103
|
|
|
|
|
|
|
|
104
|
0
|
|
|
|
|
0
|
$host =~ s/\.\z//s; # strip a redundant trailing dot |
105
|
0
|
|
|
|
|
0
|
my $key = "dns:$type:$host"; |
106
|
0
|
|
|
|
|
0
|
my $existing_ent = $self->{async}->get_lookup($key); |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
# only make a specific query once |
109
|
0
|
0
|
|
|
|
0
|
if (!$existing_ent) { |
110
|
0
|
|
|
|
|
0
|
my $ent = { |
111
|
|
|
|
|
|
|
key => $key, |
112
|
|
|
|
|
|
|
zone => $host, # serves to fetch other per-zone settings |
113
|
|
|
|
|
|
|
type => "DNSBL-".$type, |
114
|
|
|
|
|
|
|
sets => [ ], # filled in below |
115
|
|
|
|
|
|
|
rules => [ ], # filled in below |
116
|
|
|
|
|
|
|
# id is filled in after we send the query below |
117
|
|
|
|
|
|
|
}; |
118
|
|
|
|
|
|
|
$existing_ent = $self->{async}->bgsend_and_start_lookup( |
119
|
|
|
|
|
|
|
$host, $type, undef, $ent, |
120
|
0
|
|
|
0
|
|
0
|
sub { my($ent, $pkt) = @_; $self->process_dnsbl_result($ent, $pkt) }, |
|
0
|
|
|
|
|
0
|
|
121
|
0
|
|
|
|
|
0
|
master_deadline => $self->{master_deadline} ); |
122
|
|
|
|
|
|
|
} |
123
|
|
|
|
|
|
|
|
124
|
0
|
0
|
|
|
|
0
|
if ($existing_ent) { |
125
|
|
|
|
|
|
|
# always add set |
126
|
0
|
|
|
|
|
0
|
push @{$existing_ent->{sets}}, $set; |
|
0
|
|
|
|
|
0
|
|
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
# sometimes match or always match |
129
|
0
|
0
|
|
|
|
0
|
if (defined $subtest) { |
130
|
0
|
|
|
|
|
0
|
$self->{dnspost}->{$set}->{$subtest} = $rule; |
131
|
|
|
|
|
|
|
} else { |
132
|
0
|
|
|
|
|
0
|
push @{$existing_ent->{rules}}, $rule; |
|
0
|
|
|
|
|
0
|
|
133
|
|
|
|
|
|
|
} |
134
|
|
|
|
|
|
|
|
135
|
0
|
|
|
|
|
0
|
$self->{rule_to_rblkey}->{$rule} = $key; |
136
|
|
|
|
|
|
|
} |
137
|
|
|
|
|
|
|
} |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
# TODO: these are constant so they should only be added once at startup |
140
|
|
|
|
|
|
|
sub register_rbl_subtest { |
141
|
0
|
|
|
0
|
0
|
0
|
my ($self, $rule, $set, $subtest) = @_; |
142
|
|
|
|
|
|
|
|
143
|
0
|
0
|
|
|
|
0
|
if ($subtest =~ /^sb:/) { |
144
|
0
|
|
|
|
|
0
|
warn("dns: ignored $rule, SenderBase rules are deprecated\n"); |
145
|
0
|
|
|
|
|
0
|
return 0; |
146
|
|
|
|
|
|
|
} |
147
|
|
|
|
|
|
|
|
148
|
0
|
|
|
|
|
0
|
$self->{dnspost}->{$set}->{$subtest} = $rule; |
149
|
|
|
|
|
|
|
} |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
sub do_dns_lookup { |
152
|
0
|
|
|
0
|
0
|
0
|
my ($self, $rule, $type, $host) = @_; |
153
|
|
|
|
|
|
|
|
154
|
0
|
|
|
|
|
0
|
$host =~ s/\.\z//s; # strip a redundant trailing dot |
155
|
0
|
|
|
|
|
0
|
my $key = "dns:$type:$host"; |
156
|
|
|
|
|
|
|
|
157
|
0
|
|
|
|
|
0
|
my $ent = { |
158
|
|
|
|
|
|
|
key => $key, |
159
|
|
|
|
|
|
|
zone => $host, # serves to fetch other per-zone settings |
160
|
|
|
|
|
|
|
type => "DNSBL-".$type, |
161
|
|
|
|
|
|
|
rules => [ $rule ], |
162
|
|
|
|
|
|
|
# id is filled in after we send the query below |
163
|
|
|
|
|
|
|
}; |
164
|
|
|
|
|
|
|
$ent = $self->{async}->bgsend_and_start_lookup( |
165
|
|
|
|
|
|
|
$host, $type, undef, $ent, |
166
|
0
|
|
|
0
|
|
0
|
sub { my($ent, $pkt) = @_; $self->process_dnsbl_result($ent, $pkt) }, |
|
0
|
|
|
|
|
0
|
|
167
|
0
|
|
|
|
|
0
|
master_deadline => $self->{master_deadline} ); |
168
|
0
|
|
|
|
|
0
|
$ent; |
169
|
|
|
|
|
|
|
} |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
########################################################################### |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
sub dnsbl_hit { |
174
|
0
|
|
|
0
|
0
|
0
|
my ($self, $rule, $question, $answer) = @_; |
175
|
|
|
|
|
|
|
|
176
|
0
|
|
|
|
|
0
|
my $log = ""; |
177
|
0
|
0
|
|
|
|
0
|
if (substr($rule, 0, 2) eq "__") { |
|
|
0
|
|
|
|
|
|
178
|
|
|
|
|
|
|
# don't bother with meta rules |
179
|
|
|
|
|
|
|
} elsif ($answer->type eq 'TXT') { |
180
|
|
|
|
|
|
|
# txtdata returns a non- zone-file-format encoded result, unlike rdstring; |
181
|
|
|
|
|
|
|
# avoid space-separated RDATA <character-string> fields if possible, |
182
|
|
|
|
|
|
|
# txtdata provides a list of strings in a list context since Net::DNS 0.69 |
183
|
0
|
|
|
|
|
0
|
$log = join('',$answer->txtdata); |
184
|
0
|
|
|
|
|
0
|
local $1; |
185
|
0
|
|
|
|
|
0
|
$log =~ s{ (?<! [<(\[] ) (https? : // \S+)}{<$1>}xgi; |
186
|
|
|
|
|
|
|
} else { # assuming $answer->type eq 'A' |
187
|
0
|
|
|
|
|
0
|
local($1,$2,$3,$4,$5); |
188
|
0
|
0
|
|
|
|
0
|
if ($question->string =~ m/^((?:[0-9a-fA-F]\.){32})(\S+\w)/) { |
|
|
0
|
|
|
|
|
|
189
|
0
|
|
|
|
|
0
|
$log = ' listed in ' . lc($2); |
190
|
0
|
|
|
|
|
0
|
my $ipv6addr = join('', reverse split(/\./, lc $1)); |
191
|
0
|
|
|
|
|
0
|
$ipv6addr =~ s/\G(....)/$1:/g; chop $ipv6addr; |
|
0
|
|
|
|
|
0
|
|
192
|
0
|
|
|
|
|
0
|
$ipv6addr =~ s/:0{1,3}/:/g; |
193
|
0
|
|
|
|
|
0
|
$log = $ipv6addr . $log; |
194
|
|
|
|
|
|
|
} elsif ($question->string =~ m/^(\d+)\.(\d+)\.(\d+)\.(\d+)\.(\S+\w)/) { |
195
|
0
|
|
|
|
|
0
|
$log = "$4.$3.$2.$1 listed in " . lc($5); |
196
|
|
|
|
|
|
|
} else { |
197
|
0
|
|
|
|
|
0
|
$log = 'listed in ' . $question->string; |
198
|
|
|
|
|
|
|
} |
199
|
|
|
|
|
|
|
} |
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
# TODO: this may result in some log messages appearing under the |
202
|
|
|
|
|
|
|
# wrong rules, since we could see this sequence: { test one hits, |
203
|
|
|
|
|
|
|
# test one's message is logged, test two hits, test one fires again |
204
|
|
|
|
|
|
|
# on another IP, test one's message is logged for that other IP -- |
205
|
|
|
|
|
|
|
# but under test two's heading }. Right now though it's better |
206
|
|
|
|
|
|
|
# than just not logging at all. |
207
|
|
|
|
|
|
|
|
208
|
0
|
|
0
|
|
|
0
|
$self->{already_logged} ||= { }; |
209
|
0
|
0
|
0
|
|
|
0
|
if ($log && !$self->{already_logged}->{$log}) { |
210
|
0
|
|
|
|
|
0
|
$self->test_log($log); |
211
|
0
|
|
|
|
|
0
|
$self->{already_logged}->{$log} = 1; |
212
|
|
|
|
|
|
|
} |
213
|
|
|
|
|
|
|
|
214
|
0
|
0
|
|
|
|
0
|
if (!$self->{tests_already_hit}->{$rule}) { |
215
|
0
|
|
|
|
|
0
|
$self->got_hit($rule, "RBL: ", ruletype => "dnsbl"); |
216
|
|
|
|
|
|
|
} |
217
|
|
|
|
|
|
|
} |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
sub dnsbl_uri { |
220
|
0
|
|
|
0
|
0
|
0
|
my ($self, $question, $answer) = @_; |
221
|
|
|
|
|
|
|
|
222
|
0
|
|
|
|
|
0
|
my $qname = $question->qname; |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
# txtdata returns a non- zone-file-format encoded result, unlike rdstring; |
225
|
|
|
|
|
|
|
# avoid space-separated RDATA <character-string> fields if possible, |
226
|
|
|
|
|
|
|
# txtdata provides a list of strings in a list context since Net::DNS 0.69 |
227
|
|
|
|
|
|
|
# |
228
|
|
|
|
|
|
|
# rdatastr() is historical/undocumented, use rdstring() since Net::DNS 0.69 |
229
|
0
|
0
|
|
|
|
0
|
my $rdatastr = $answer->UNIVERSAL::can('txtdata') ? join('',$answer->txtdata) |
|
|
0
|
|
|
|
|
|
230
|
|
|
|
|
|
|
: $answer->UNIVERSAL::can('rdstring') ? $answer->rdstring |
231
|
|
|
|
|
|
|
: $answer->rdatastr; |
232
|
0
|
0
|
0
|
|
|
0
|
if (defined $qname && defined $rdatastr) { |
233
|
0
|
|
|
|
|
0
|
my $qclass = $question->qclass; |
234
|
0
|
|
|
|
|
0
|
my $qtype = $question->qtype; |
235
|
0
|
|
|
|
|
0
|
my @vals; |
236
|
0
|
0
|
|
|
|
0
|
push(@vals, "class=$qclass") if $qclass ne "IN"; |
237
|
0
|
0
|
|
|
|
0
|
push(@vals, "type=$qtype") if $qtype ne "A"; |
238
|
0
|
0
|
|
|
|
0
|
my $uri = "dns:$qname" . (@vals ? "?" . join(";", @vals) : ""); |
239
|
0
|
|
|
|
|
0
|
push @{ $self->{dnsuri}->{$uri} }, $rdatastr; |
|
0
|
|
|
|
|
0
|
|
240
|
|
|
|
|
|
|
|
241
|
0
|
|
|
|
|
0
|
dbg("dns: hit <$uri> $rdatastr"); |
242
|
|
|
|
|
|
|
} |
243
|
|
|
|
|
|
|
} |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
# called as a completion routine to bgsend by DnsResolver::poll_responses; |
246
|
|
|
|
|
|
|
# returns 1 on successful packet processing |
247
|
|
|
|
|
|
|
sub process_dnsbl_result { |
248
|
0
|
|
|
0
|
0
|
0
|
my ($self, $ent, $pkt) = @_; |
249
|
|
|
|
|
|
|
|
250
|
0
|
0
|
|
|
|
0
|
return if !$pkt; |
251
|
0
|
|
|
|
|
0
|
my $question = ($pkt->question)[0]; |
252
|
0
|
0
|
|
|
|
0
|
return if !$question; |
253
|
|
|
|
|
|
|
|
254
|
0
|
|
0
|
|
|
0
|
my $sets = $ent->{sets} || []; |
255
|
0
|
|
|
|
|
0
|
my $rules = $ent->{rules}; |
256
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
# NO_DNS_FOR_FROM |
258
|
0
|
0
|
0
|
|
|
0
|
if ($self->{sender_host} && |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
259
|
|
|
|
|
|
|
# fishy, qname should have been "RFC 1035 zone format" -decoded first |
260
|
|
|
|
|
|
|
lc($question->qname) eq lc($self->{sender_host}) && |
261
|
|
|
|
|
|
|
$question->qtype =~ /^(?:A|MX)$/ && |
262
|
|
|
|
|
|
|
$pkt->header->rcode =~ /^(?:NXDOMAIN|SERVFAIL)$/ && |
263
|
|
|
|
|
|
|
++$self->{sender_host_fail} == 2) |
264
|
|
|
|
|
|
|
{ |
265
|
0
|
|
|
|
|
0
|
for my $rule (@{$rules}) { |
|
0
|
|
|
|
|
0
|
|
266
|
0
|
|
|
|
|
0
|
$self->got_hit($rule, "DNS: ", ruletype => "dns"); |
267
|
|
|
|
|
|
|
} |
268
|
|
|
|
|
|
|
} |
269
|
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
# DNSBL tests are here |
271
|
0
|
|
|
|
|
0
|
foreach my $answer ($pkt->answer) { |
272
|
0
|
0
|
|
|
|
0
|
next if !$answer; |
273
|
|
|
|
|
|
|
# track all responses |
274
|
0
|
|
|
|
|
0
|
$self->dnsbl_uri($question, $answer); |
275
|
0
|
|
|
|
|
0
|
my $answ_type = $answer->type; |
276
|
|
|
|
|
|
|
# TODO: there are some CNAME returns that might be useful |
277
|
0
|
0
|
0
|
|
|
0
|
next if ($answ_type ne 'A' && $answ_type ne 'TXT'); |
278
|
0
|
0
|
|
|
|
0
|
if ($answ_type eq 'A') { |
279
|
|
|
|
|
|
|
# Net::DNS::RR::A::address() is available since Net::DNS 0.69 |
280
|
0
|
0
|
|
|
|
0
|
my $ip_address = $answer->UNIVERSAL::can('address') ? $answer->address |
281
|
|
|
|
|
|
|
: $answer->rdatastr; |
282
|
|
|
|
|
|
|
# skip any A record that isn't on 127.0.0.0/8 |
283
|
0
|
0
|
|
|
|
0
|
next if $ip_address !~ /^127\./; |
284
|
|
|
|
|
|
|
} |
285
|
0
|
|
|
|
|
0
|
for my $rule (@{$rules}) { |
|
0
|
|
|
|
|
0
|
|
286
|
0
|
|
|
|
|
0
|
$self->dnsbl_hit($rule, $question, $answer); |
287
|
|
|
|
|
|
|
} |
288
|
0
|
|
|
|
|
0
|
for my $set (@{$sets}) { |
|
0
|
|
|
|
|
0
|
|
289
|
0
|
0
|
|
|
|
0
|
if ($self->{dnspost}->{$set}) { |
290
|
0
|
|
|
|
|
0
|
$self->process_dnsbl_set($set, $question, $answer); |
291
|
|
|
|
|
|
|
} |
292
|
|
|
|
|
|
|
} |
293
|
|
|
|
|
|
|
} |
294
|
0
|
|
|
|
|
0
|
return 1; |
295
|
|
|
|
|
|
|
} |
296
|
|
|
|
|
|
|
|
297
|
|
|
|
|
|
|
sub process_dnsbl_set { |
298
|
0
|
|
|
0
|
0
|
0
|
my ($self, $set, $question, $answer) = @_; |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
# txtdata returns a non- zone-file-format encoded result, unlike rdstring; |
301
|
|
|
|
|
|
|
# avoid space-separated RDATA <character-string> fields if possible, |
302
|
|
|
|
|
|
|
# txtdata provides a list of strings in a list context since Net::DNS 0.69 |
303
|
|
|
|
|
|
|
# |
304
|
|
|
|
|
|
|
# rdatastr() is historical/undocumented, use rdstring() since Net::DNS 0.69 |
305
|
0
|
0
|
|
|
|
0
|
my $rdatastr = $answer->UNIVERSAL::can('txtdata') ? join('',$answer->txtdata) |
|
|
0
|
|
|
|
|
|
306
|
|
|
|
|
|
|
: $answer->UNIVERSAL::can('rdstring') ? $answer->rdstring |
307
|
|
|
|
|
|
|
: $answer->rdatastr; |
308
|
|
|
|
|
|
|
|
309
|
0
|
|
|
|
|
0
|
while (my ($subtest, $rule) = each %{ $self->{dnspost}->{$set} }) { |
|
0
|
|
|
|
|
0
|
|
310
|
0
|
0
|
|
|
|
0
|
next if $self->{tests_already_hit}->{$rule}; |
311
|
|
|
|
|
|
|
|
312
|
0
|
0
|
|
|
|
0
|
if ($subtest =~ /^\d+\.\d+\.\d+\.\d+$/) { |
|
|
0
|
|
|
|
|
|
313
|
|
|
|
|
|
|
# test for exact equality, not a regexp (an IPv4 address) |
314
|
0
|
0
|
|
|
|
0
|
$self->dnsbl_hit($rule, $question, $answer) if $subtest eq $rdatastr; |
315
|
|
|
|
|
|
|
} |
316
|
|
|
|
|
|
|
# bitmask |
317
|
|
|
|
|
|
|
elsif ($subtest =~ /^\d+$/) { |
318
|
|
|
|
|
|
|
# Bug 6803: response should be within 127.0.0.0/8, ignore otherwise |
319
|
0
|
0
|
0
|
|
|
0
|
if ($rdatastr =~ m/^127\.\d{1,3}\.\d{1,3}\.\d{1,3}$/ && |
320
|
|
|
|
|
|
|
Mail::SpamAssassin::Util::my_inet_aton($rdatastr) & $subtest) |
321
|
|
|
|
|
|
|
{ |
322
|
0
|
|
|
|
|
0
|
$self->dnsbl_hit($rule, $question, $answer); |
323
|
|
|
|
|
|
|
} |
324
|
|
|
|
|
|
|
} |
325
|
|
|
|
|
|
|
# regular expression |
326
|
|
|
|
|
|
|
else { |
327
|
0
|
|
|
|
|
0
|
my $test = qr/$subtest/; |
328
|
0
|
0
|
|
|
|
0
|
if ($rdatastr =~ /$test/) { |
329
|
0
|
|
|
|
|
0
|
$self->dnsbl_hit($rule, $question, $answer); |
330
|
|
|
|
|
|
|
} |
331
|
|
|
|
|
|
|
} |
332
|
|
|
|
|
|
|
} |
333
|
|
|
|
|
|
|
} |
334
|
|
|
|
|
|
|
|
335
|
|
|
|
|
|
|
sub harvest_until_rule_completes { |
336
|
0
|
|
|
0
|
0
|
0
|
my ($self, $rule) = @_; |
337
|
|
|
|
|
|
|
|
338
|
0
|
|
|
|
|
0
|
dbg("dns: harvest_until_rule_completes"); |
339
|
0
|
|
|
|
|
0
|
my $result = 0; |
340
|
|
|
|
|
|
|
|
341
|
0
|
|
|
|
|
0
|
for (my $first=1; ; $first=0) { |
342
|
|
|
|
|
|
|
# complete_lookups() may call completed_callback(), which may |
343
|
|
|
|
|
|
|
# call start_lookup() again (like in Plugin::URIDNSBL) |
344
|
|
|
|
|
|
|
my ($alldone,$anydone) = |
345
|
0
|
0
|
|
|
|
0
|
$self->{async}->complete_lookups($first ? 0 : 1.0, 1); |
346
|
|
|
|
|
|
|
|
347
|
0
|
0
|
|
|
|
0
|
$result = 1 if $self->is_rule_complete($rule); |
348
|
0
|
0
|
0
|
|
|
0
|
last if $result || $alldone; |
349
|
|
|
|
|
|
|
|
350
|
0
|
|
|
|
|
0
|
dbg("dns: harvest_until_rule_completes - check_tick"); |
351
|
0
|
|
|
|
|
0
|
$self->{main}->call_plugins ("check_tick", { permsgstatus => $self }); |
352
|
|
|
|
|
|
|
} |
353
|
|
|
|
|
|
|
|
354
|
0
|
|
|
|
|
0
|
return $result; |
355
|
|
|
|
|
|
|
} |
356
|
|
|
|
|
|
|
|
357
|
|
|
|
|
|
|
sub harvest_dnsbl_queries { |
358
|
96
|
|
|
96
|
0
|
298
|
my ($self) = @_; |
359
|
|
|
|
|
|
|
|
360
|
96
|
|
|
|
|
328
|
dbg("dns: harvest_dnsbl_queries"); |
361
|
|
|
|
|
|
|
|
362
|
96
|
|
|
|
|
246
|
for (my $first=1; ; $first=0) { |
363
|
|
|
|
|
|
|
# complete_lookups() may call completed_callback(), which may |
364
|
|
|
|
|
|
|
# call start_lookup() again (like in Plugin::URIDNSBL) |
365
|
|
|
|
|
|
|
|
366
|
|
|
|
|
|
|
# the first time around we specify a 0 timeout, which gives |
367
|
|
|
|
|
|
|
# complete_lookups a chance to ripe any available results and |
368
|
|
|
|
|
|
|
# abort overdue requests, without needlessly waiting for more |
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
my ($alldone,$anydone) = |
371
|
96
|
50
|
|
|
|
493
|
$self->{async}->complete_lookups($first ? 0 : 1.0, 1); |
372
|
|
|
|
|
|
|
|
373
|
96
|
50
|
|
|
|
468
|
last if $alldone; |
374
|
|
|
|
|
|
|
|
375
|
0
|
|
|
|
|
0
|
dbg("dns: harvest_dnsbl_queries - check_tick"); |
376
|
0
|
|
|
|
|
0
|
$self->{main}->call_plugins ("check_tick", { permsgstatus => $self }); |
377
|
|
|
|
|
|
|
} |
378
|
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
# explicitly abort anything left |
380
|
96
|
|
|
|
|
586
|
$self->{async}->abort_remaining_lookups(); |
381
|
96
|
|
|
|
|
512
|
$self->{async}->log_lookups_timing(); |
382
|
96
|
|
|
|
|
542
|
$self->mark_all_async_rules_complete(); |
383
|
96
|
|
|
|
|
247
|
1; |
384
|
|
|
|
|
|
|
} |
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
# collect and process whatever DNS responses have already arrived, |
387
|
|
|
|
|
|
|
# don't waste time waiting for more, don't poll too often. |
388
|
|
|
|
|
|
|
# don't abort any queries even if overdue, |
389
|
|
|
|
|
|
|
sub harvest_completed_queries { |
390
|
3096
|
|
|
3096
|
0
|
5575
|
my ($self) = @_; |
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
# don't bother collecting responses too often |
393
|
3096
|
|
|
|
|
8677
|
my $last_poll_time = $self->{async}->last_poll_responses_time(); |
394
|
3096
|
100
|
66
|
|
|
7270
|
return if defined $last_poll_time && time - $last_poll_time < 0.1; |
395
|
|
|
|
|
|
|
|
396
|
3063
|
|
|
|
|
7025
|
my ($alldone,$anydone) = $self->{async}->complete_lookups(0, 0); |
397
|
3063
|
100
|
|
|
|
7862
|
if ($anydone) { |
398
|
3
|
|
|
|
|
10
|
dbg("dns: harvested completed queries"); |
399
|
|
|
|
|
|
|
# $self->{main}->call_plugins ("check_tick", { permsgstatus => $self }); |
400
|
|
|
|
|
|
|
} |
401
|
|
|
|
|
|
|
} |
402
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
sub set_rbl_tag_data { |
404
|
96
|
|
|
96
|
0
|
242
|
my ($self) = @_; |
405
|
|
|
|
|
|
|
|
406
|
|
|
|
|
|
|
# DNS URIs |
407
|
96
|
|
|
|
|
273
|
my $rbl_tag = $self->{tag_data}->{RBL}; # just in case, should be empty |
408
|
96
|
50
|
|
|
|
283
|
$rbl_tag = '' if !defined $rbl_tag; |
409
|
96
|
|
|
|
|
220
|
while (my ($dnsuri, $answers) = each %{ $self->{dnsuri} }) { |
|
96
|
|
|
|
|
615
|
|
410
|
|
|
|
|
|
|
# when parsing, look for elements of \".*?\" or \S+ with ", " as separator |
411
|
0
|
|
|
|
|
0
|
$rbl_tag .= "<$dnsuri>" . " [" . join(", ", @{ $answers }) . "]\n"; |
|
0
|
|
|
|
|
0
|
|
412
|
|
|
|
|
|
|
} |
413
|
96
|
50
|
33
|
|
|
892
|
if (defined $rbl_tag && $rbl_tag ne '') { |
414
|
0
|
|
|
|
|
0
|
chomp $rbl_tag; |
415
|
0
|
|
|
|
|
0
|
$self->set_tag('RBL', $rbl_tag); |
416
|
|
|
|
|
|
|
} |
417
|
|
|
|
|
|
|
} |
418
|
|
|
|
|
|
|
|
419
|
|
|
|
|
|
|
########################################################################### |
420
|
|
|
|
|
|
|
|
421
|
|
|
|
|
|
|
sub rbl_finish { |
422
|
96
|
|
|
96
|
0
|
208
|
my ($self) = @_; |
423
|
|
|
|
|
|
|
|
424
|
96
|
|
|
|
|
366
|
$self->set_rbl_tag_data(); |
425
|
|
|
|
|
|
|
|
426
|
96
|
|
|
|
|
211
|
delete $self->{dnspost}; |
427
|
96
|
|
|
|
|
320
|
delete $self->{dnsuri}; |
428
|
|
|
|
|
|
|
} |
429
|
|
|
|
|
|
|
|
430
|
|
|
|
|
|
|
########################################################################### |
431
|
|
|
|
|
|
|
|
432
|
|
|
|
|
|
|
sub load_resolver { |
433
|
1
|
|
|
1
|
0
|
2
|
my ($self) = @_; |
434
|
1
|
|
|
|
|
3
|
$self->{resolver} = $self->{main}->{resolver}; |
435
|
1
|
|
|
|
|
4
|
return $self->{resolver}->load_resolver(); |
436
|
|
|
|
|
|
|
} |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
sub clear_resolver { |
439
|
1
|
|
|
1
|
0
|
4
|
my ($self) = @_; |
440
|
1
|
|
|
|
|
5
|
dbg("dns: clear_resolver"); |
441
|
1
|
|
|
|
|
15
|
$self->{main}->{resolver}->{res} = undef; |
442
|
1
|
|
|
|
|
3
|
return 0; |
443
|
|
|
|
|
|
|
} |
444
|
|
|
|
|
|
|
|
445
|
|
|
|
|
|
|
sub lookup_ns { |
446
|
0
|
|
|
0
|
0
|
0
|
my ($self, $dom) = @_; |
447
|
|
|
|
|
|
|
|
448
|
0
|
0
|
|
|
|
0
|
return unless $self->load_resolver(); |
449
|
0
|
0
|
|
|
|
0
|
return if ($self->server_failed_to_respond_for_domain ($dom)); |
450
|
|
|
|
|
|
|
|
451
|
0
|
|
|
|
|
0
|
my $nsrecords; |
452
|
0
|
|
|
|
|
0
|
dbg("dns: looking up NS for '$dom'"); |
453
|
|
|
|
|
|
|
|
454
|
|
|
|
|
|
|
eval { |
455
|
0
|
|
|
|
|
0
|
my $query = $self->{resolver}->send($dom, 'NS'); |
456
|
0
|
|
|
|
|
0
|
my @nses; |
457
|
0
|
0
|
|
|
|
0
|
if ($query) { |
458
|
0
|
|
|
|
|
0
|
foreach my $rr ($query->answer) { |
459
|
0
|
0
|
|
|
|
0
|
if ($rr->type eq "NS") { push (@nses, $rr->nsdname); } |
|
0
|
|
|
|
|
0
|
|
460
|
|
|
|
|
|
|
} |
461
|
|
|
|
|
|
|
} |
462
|
0
|
|
|
|
|
0
|
$nsrecords = [ @nses ]; |
463
|
0
|
|
|
|
|
0
|
1; |
464
|
0
|
0
|
|
|
|
0
|
} or do { |
465
|
0
|
0
|
|
|
|
0
|
my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; |
|
0
|
|
|
|
|
0
|
|
466
|
0
|
|
|
|
|
0
|
dbg("dns: NS lookup failed horribly, perhaps bad resolv.conf setting? (%s)", $eval_stat); |
467
|
0
|
|
|
|
|
0
|
return; |
468
|
|
|
|
|
|
|
}; |
469
|
|
|
|
|
|
|
|
470
|
0
|
|
|
|
|
0
|
$nsrecords; |
471
|
|
|
|
|
|
|
} |
472
|
|
|
|
|
|
|
|
473
|
|
|
|
|
|
|
sub is_dns_available { |
474
|
336
|
|
|
336
|
0
|
657
|
my ($self) = @_; |
475
|
336
|
|
|
|
|
802
|
my $dnsopt = $self->{conf}->{dns_available}; |
476
|
336
|
|
50
|
|
|
912
|
my $dnsint = $self->{conf}->{dns_test_interval} || 600; |
477
|
336
|
|
|
|
|
501
|
my @domains; |
478
|
|
|
|
|
|
|
|
479
|
336
|
|
100
|
|
|
826
|
$LAST_DNS_CHECK ||= 0; |
480
|
336
|
|
|
|
|
914
|
my $diff = time() - $LAST_DNS_CHECK; |
481
|
|
|
|
|
|
|
|
482
|
|
|
|
|
|
|
# undef $IS_DNS_AVAILABLE if we should be testing for |
483
|
|
|
|
|
|
|
# working DNS and our check interval time has passed |
484
|
336
|
50
|
33
|
|
|
843
|
if ($dnsopt eq "test" && $diff > $dnsint) { |
485
|
0
|
|
|
|
|
0
|
$IS_DNS_AVAILABLE = undef; |
486
|
0
|
|
|
|
|
0
|
dbg("dns: is_dns_available() last checked %.1f seconds ago; re-checking", |
487
|
|
|
|
|
|
|
$diff); |
488
|
|
|
|
|
|
|
} |
489
|
|
|
|
|
|
|
|
490
|
336
|
100
|
|
|
|
1904
|
return $IS_DNS_AVAILABLE if (defined $IS_DNS_AVAILABLE); |
491
|
8
|
|
|
|
|
27
|
$LAST_DNS_CHECK = time(); |
492
|
|
|
|
|
|
|
|
493
|
8
|
|
|
|
|
16
|
$IS_DNS_AVAILABLE = 0; |
494
|
8
|
50
|
|
|
|
29
|
if ($dnsopt eq "no") { |
495
|
0
|
|
|
|
|
0
|
dbg("dns: dns_available set to no in config file, skipping test"); |
496
|
0
|
|
|
|
|
0
|
return $IS_DNS_AVAILABLE; |
497
|
|
|
|
|
|
|
} |
498
|
|
|
|
|
|
|
|
499
|
|
|
|
|
|
|
# Even if "dns_available" is explicitly set to "yes", we want to ignore |
500
|
|
|
|
|
|
|
# DNS if we're only supposed to be looking at local tests. |
501
|
8
|
100
|
|
|
|
61
|
goto done if ($self->{main}->{local_tests_only}); |
502
|
|
|
|
|
|
|
|
503
|
|
|
|
|
|
|
# Check version numbers - runtime check only |
504
|
1
|
50
|
|
|
|
3
|
if (defined $Net::DNS::VERSION) { |
505
|
1
|
50
|
|
|
|
5
|
if (am_running_on_windows()) { |
506
|
0
|
0
|
|
|
|
0
|
if ($Net::DNS::VERSION < 0.46) { |
507
|
0
|
|
|
|
|
0
|
warn("dns: Net::DNS version is $Net::DNS::VERSION, but need 0.46 for Win32"); |
508
|
0
|
|
|
|
|
0
|
return $IS_DNS_AVAILABLE; |
509
|
|
|
|
|
|
|
} |
510
|
|
|
|
|
|
|
} |
511
|
|
|
|
|
|
|
else { |
512
|
1
|
50
|
|
|
|
4
|
if ($Net::DNS::VERSION < 0.34) { |
513
|
0
|
|
|
|
|
0
|
warn("dns: Net::DNS version is $Net::DNS::VERSION, but need 0.34"); |
514
|
0
|
|
|
|
|
0
|
return $IS_DNS_AVAILABLE; |
515
|
|
|
|
|
|
|
} |
516
|
|
|
|
|
|
|
} |
517
|
|
|
|
|
|
|
} |
518
|
|
|
|
|
|
|
|
519
|
1
|
|
|
|
|
21
|
$self->clear_resolver(); |
520
|
1
|
50
|
|
|
|
4
|
goto done unless $self->load_resolver(); |
521
|
|
|
|
|
|
|
|
522
|
1
|
50
|
|
|
|
6
|
if ($dnsopt eq "yes") { |
523
|
|
|
|
|
|
|
# optionally shuffle the list of nameservers to distribute the load |
524
|
1
|
50
|
|
|
|
5
|
if ($self->{conf}->{dns_options}->{rotate}) { |
525
|
0
|
|
|
|
|
0
|
my @nameservers = $self->{resolver}->available_nameservers(); |
526
|
0
|
|
|
|
|
0
|
Mail::SpamAssassin::Util::fisher_yates_shuffle(\@nameservers); |
527
|
0
|
|
|
|
|
0
|
dbg("dns: shuffled NS list: " . join(", ", @nameservers)); |
528
|
0
|
|
|
|
|
0
|
$self->{resolver}->available_nameservers(@nameservers); |
529
|
|
|
|
|
|
|
} |
530
|
1
|
|
|
|
|
3
|
$IS_DNS_AVAILABLE = 1; |
531
|
1
|
|
|
|
|
4
|
dbg("dns: dns_available set to yes in config file, skipping test"); |
532
|
1
|
|
|
|
|
5
|
return $IS_DNS_AVAILABLE; |
533
|
|
|
|
|
|
|
} |
534
|
|
|
|
|
|
|
|
535
|
0
|
0
|
|
|
|
0
|
if ($dnsopt =~ /^test:\s*(\S.*)$/) { |
536
|
0
|
|
|
|
|
0
|
@domains = split (/\s+/, $1); |
537
|
0
|
|
|
|
|
0
|
dbg("dns: looking up NS records for user specified domains: %s", |
538
|
|
|
|
|
|
|
join(", ", @domains)); |
539
|
|
|
|
|
|
|
} else { |
540
|
0
|
|
|
|
|
0
|
@domains = @EXISTING_DOMAINS; |
541
|
0
|
|
|
|
|
0
|
dbg("dns: looking up NS records for built-in domains"); |
542
|
|
|
|
|
|
|
} |
543
|
|
|
|
|
|
|
|
544
|
|
|
|
|
|
|
# do the test with a full set of configured nameservers |
545
|
0
|
|
|
|
|
0
|
my @nameservers = $self->{resolver}->configured_nameservers(); |
546
|
|
|
|
|
|
|
|
547
|
|
|
|
|
|
|
# optionally shuffle the list of nameservers to distribute the load |
548
|
0
|
0
|
|
|
|
0
|
if ($self->{conf}->{dns_options}->{rotate}) { |
549
|
0
|
|
|
|
|
0
|
Mail::SpamAssassin::Util::fisher_yates_shuffle(\@nameservers); |
550
|
0
|
|
|
|
|
0
|
dbg("dns: shuffled NS list, testing: " . join(", ", @nameservers)); |
551
|
|
|
|
|
|
|
} else { |
552
|
0
|
|
|
|
|
0
|
dbg("dns: testing resolver nameservers: " . join(", ", @nameservers)); |
553
|
|
|
|
|
|
|
} |
554
|
|
|
|
|
|
|
|
555
|
|
|
|
|
|
|
# Try the different nameservers here and collect a list of working servers |
556
|
0
|
|
|
|
|
0
|
my @good_nameservers; |
557
|
0
|
|
|
|
|
0
|
foreach my $ns (@nameservers) { |
558
|
0
|
|
|
|
|
0
|
$self->{resolver}->available_nameservers($ns); # try just this one |
559
|
0
|
|
0
|
|
|
0
|
for (my $retry = 3; $retry > 0 && @domains; $retry--) { |
560
|
0
|
|
|
|
|
0
|
my $domain = splice(@domains, rand(@domains), 1); |
561
|
0
|
|
|
|
|
0
|
dbg("dns: trying ($retry) $domain, server $ns ..."); |
562
|
0
|
|
|
|
|
0
|
my $result = $self->lookup_ns($domain); |
563
|
0
|
|
|
|
|
0
|
$self->{resolver}->finish_socket(); |
564
|
0
|
0
|
|
|
|
0
|
if (!$result) { |
|
|
0
|
|
|
|
|
|
565
|
0
|
|
|
|
|
0
|
dbg("dns: NS lookup of $domain using $ns failed horribly, ". |
566
|
|
|
|
|
|
|
"may not be a valid nameserver"); |
567
|
0
|
|
|
|
|
0
|
last; |
568
|
|
|
|
|
|
|
} elsif (!@$result) { |
569
|
0
|
|
|
|
|
0
|
dbg("dns: NS lookup of $domain using $ns failed, no results found"); |
570
|
|
|
|
|
|
|
} else { |
571
|
0
|
|
|
|
|
0
|
dbg("dns: NS lookup of $domain using $ns succeeded => DNS available". |
572
|
|
|
|
|
|
|
" (set dns_available to override)"); |
573
|
0
|
|
|
|
|
0
|
push(@good_nameservers, $ns); |
574
|
0
|
|
|
|
|
0
|
last; |
575
|
|
|
|
|
|
|
} |
576
|
|
|
|
|
|
|
} |
577
|
|
|
|
|
|
|
} |
578
|
|
|
|
|
|
|
|
579
|
0
|
0
|
|
|
|
0
|
if (!@good_nameservers) { |
580
|
0
|
|
|
|
|
0
|
dbg("dns: all NS queries failed => DNS unavailable ". |
581
|
|
|
|
|
|
|
"(set dns_available to override)"); |
582
|
|
|
|
|
|
|
} else { |
583
|
0
|
|
|
|
|
0
|
$IS_DNS_AVAILABLE = 1; |
584
|
0
|
|
|
|
|
0
|
dbg("dns: NS list: ".join(", ", @good_nameservers)); |
585
|
0
|
|
|
|
|
0
|
$self->{resolver}->available_nameservers(@good_nameservers); |
586
|
|
|
|
|
|
|
} |
587
|
|
|
|
|
|
|
|
588
|
7
|
|
|
|
|
40
|
done: |
589
|
|
|
|
|
|
|
# jm: leaving this in! |
590
|
|
|
|
|
|
|
dbg("dns: is DNS available? " . $IS_DNS_AVAILABLE); |
591
|
7
|
|
|
|
|
48
|
return $IS_DNS_AVAILABLE; |
592
|
|
|
|
|
|
|
} |
593
|
|
|
|
|
|
|
|
594
|
|
|
|
|
|
|
########################################################################### |
595
|
|
|
|
|
|
|
|
596
|
|
|
|
|
|
|
sub server_failed_to_respond_for_domain { |
597
|
0
|
|
|
0
|
0
|
0
|
my ($self, $dom) = @_; |
598
|
0
|
0
|
|
|
|
0
|
if ($self->{dns_server_too_slow}->{$dom}) { |
599
|
0
|
|
|
|
|
0
|
dbg("dns: server for '$dom' failed to reply previously, not asking again"); |
600
|
0
|
|
|
|
|
0
|
return 1; |
601
|
|
|
|
|
|
|
} |
602
|
0
|
|
|
|
|
0
|
return 0; |
603
|
|
|
|
|
|
|
} |
604
|
|
|
|
|
|
|
|
605
|
|
|
|
|
|
|
sub set_server_failed_to_respond_for_domain { |
606
|
0
|
|
|
0
|
0
|
0
|
my ($self, $dom) = @_; |
607
|
0
|
|
|
|
|
0
|
dbg("dns: server for '$dom' failed to reply, marking as bad"); |
608
|
0
|
|
|
|
|
0
|
$self->{dns_server_too_slow}->{$dom} = 1; |
609
|
|
|
|
|
|
|
} |
610
|
|
|
|
|
|
|
|
611
|
|
|
|
|
|
|
########################################################################### |
612
|
|
|
|
|
|
|
|
613
|
|
|
|
|
|
|
sub enter_helper_run_mode { |
614
|
4
|
|
|
4
|
0
|
10
|
my ($self) = @_; |
615
|
|
|
|
|
|
|
|
616
|
4
|
|
|
|
|
12
|
dbg("dns: entering helper-app run mode"); |
617
|
4
|
|
|
|
|
14
|
$self->{old_slash} = $/; # Razor pollutes this |
618
|
4
|
|
|
|
|
11
|
%{$self->{old_env}} = (); |
|
4
|
|
|
|
|
14
|
|
619
|
4
|
50
|
|
|
|
16
|
if ( %ENV ) { |
620
|
|
|
|
|
|
|
# undefined values in %ENV can result due to autovivification elsewhere, |
621
|
|
|
|
|
|
|
# this prevents later possible warnings when we restore %ENV |
622
|
4
|
|
|
|
|
40
|
while (my ($key, $value) = each %ENV) { |
623
|
136
|
50
|
|
|
|
763
|
$self->{old_env}->{$key} = $value if defined $value; |
624
|
|
|
|
|
|
|
} |
625
|
|
|
|
|
|
|
} |
626
|
|
|
|
|
|
|
|
627
|
4
|
|
|
|
|
25
|
Mail::SpamAssassin::Util::clean_path_in_taint_mode(); |
628
|
|
|
|
|
|
|
|
629
|
4
|
|
|
|
|
8
|
my $newhome; |
630
|
4
|
50
|
|
|
|
14
|
if ($self->{main}->{home_dir_for_helpers}) { |
631
|
0
|
|
|
|
|
0
|
$newhome = $self->{main}->{home_dir_for_helpers}; |
632
|
|
|
|
|
|
|
} else { |
633
|
|
|
|
|
|
|
# use spamd -u user's home dir |
634
|
4
|
|
|
|
|
19
|
$newhome = (Mail::SpamAssassin::Util::portable_getpwuid ($>))[7]; |
635
|
|
|
|
|
|
|
} |
636
|
|
|
|
|
|
|
|
637
|
4
|
50
|
|
|
|
38
|
if ($newhome) { |
638
|
4
|
|
|
|
|
26
|
$ENV{'HOME'} = Mail::SpamAssassin::Util::untaint_file_path ($newhome); |
639
|
|
|
|
|
|
|
} |
640
|
|
|
|
|
|
|
|
641
|
|
|
|
|
|
|
# enforce SIGCHLD as DEFAULT; IGNORE causes spurious kernel warnings |
642
|
|
|
|
|
|
|
# on Red Hat NPTL kernels (bug 1536), and some users of the |
643
|
|
|
|
|
|
|
# Mail::SpamAssassin modules set SIGCHLD to be a fatal signal |
644
|
|
|
|
|
|
|
# for some reason! (bug 3507) |
645
|
4
|
|
|
|
|
27
|
$self->{old_sigchld_handler} = $SIG{CHLD}; |
646
|
4
|
|
|
|
|
120
|
$SIG{CHLD} = 'DEFAULT'; |
647
|
|
|
|
|
|
|
} |
648
|
|
|
|
|
|
|
|
649
|
|
|
|
|
|
|
sub leave_helper_run_mode { |
650
|
4
|
|
|
4
|
0
|
12
|
my ($self) = @_; |
651
|
|
|
|
|
|
|
|
652
|
4
|
|
|
|
|
17
|
dbg("dns: leaving helper-app run mode"); |
653
|
4
|
|
|
|
|
17
|
$/ = $self->{old_slash}; |
654
|
4
|
|
|
|
|
7
|
%ENV = %{$self->{old_env}}; |
|
4
|
|
|
|
|
443
|
|
655
|
|
|
|
|
|
|
|
656
|
4
|
100
|
|
|
|
29
|
if (defined $self->{old_sigchld_handler}) { |
657
|
3
|
|
|
|
|
52
|
$SIG{CHLD} = $self->{old_sigchld_handler}; |
658
|
|
|
|
|
|
|
} else { |
659
|
|
|
|
|
|
|
# if SIGCHLD has never been explicitly set, it's returned as undef. |
660
|
|
|
|
|
|
|
# however, when *setting* SIGCHLD, using undef(%) or assigning to an |
661
|
|
|
|
|
|
|
# undef value produces annoying 'Use of uninitialized value in scalar |
662
|
|
|
|
|
|
|
# assignment' warnings. That's silly. workaround: |
663
|
1
|
|
|
|
|
82
|
$SIG{CHLD} = 'DEFAULT'; |
664
|
|
|
|
|
|
|
} |
665
|
|
|
|
|
|
|
} |
666
|
|
|
|
|
|
|
|
667
|
|
|
|
|
|
|
# note: this must be called before leave_helper_run_mode() is called, |
668
|
|
|
|
|
|
|
# as the SIGCHLD signal must be set to DEFAULT for it to work. |
669
|
|
|
|
|
|
|
sub cleanup_kids { |
670
|
0
|
|
|
0
|
0
|
0
|
my ($self, $pid) = @_; |
671
|
|
|
|
|
|
|
|
672
|
0
|
0
|
0
|
|
|
0
|
if ($SIG{CHLD} && $SIG{CHLD} ne 'IGNORE') { # running from spamd |
673
|
0
|
|
|
|
|
0
|
waitpid ($pid, 0); |
674
|
|
|
|
|
|
|
} |
675
|
|
|
|
|
|
|
} |
676
|
|
|
|
|
|
|
|
677
|
|
|
|
|
|
|
########################################################################### |
678
|
|
|
|
|
|
|
|
679
|
|
|
|
|
|
|
sub register_async_rule_start { |
680
|
135
|
|
|
135
|
0
|
249
|
my ($self, $rule) = @_; |
681
|
135
|
|
|
|
|
377
|
dbg("dns: $rule lookup start"); |
682
|
135
|
|
|
|
|
395
|
$self->{rule_to_rblkey}->{$rule} = '*ASYNC_START'; |
683
|
|
|
|
|
|
|
} |
684
|
|
|
|
|
|
|
|
685
|
|
|
|
|
|
|
sub register_async_rule_finish { |
686
|
42
|
|
|
42
|
0
|
95
|
my ($self, $rule) = @_; |
687
|
42
|
|
|
|
|
146
|
dbg("dns: $rule lookup finished"); |
688
|
42
|
|
|
|
|
321
|
delete $self->{rule_to_rblkey}->{$rule}; |
689
|
|
|
|
|
|
|
} |
690
|
|
|
|
|
|
|
|
691
|
|
|
|
|
|
|
sub mark_all_async_rules_complete { |
692
|
96
|
|
|
96
|
0
|
227
|
my ($self) = @_; |
693
|
96
|
|
|
|
|
434
|
$self->{rule_to_rblkey} = { }; |
694
|
|
|
|
|
|
|
} |
695
|
|
|
|
|
|
|
|
696
|
|
|
|
|
|
|
sub is_rule_complete { |
697
|
0
|
|
|
0
|
0
|
0
|
my ($self, $rule) = @_; |
698
|
|
|
|
|
|
|
|
699
|
0
|
|
|
|
|
0
|
my $key = $self->{rule_to_rblkey}->{$rule}; |
700
|
0
|
0
|
|
|
|
0
|
if (!defined $key) { |
701
|
|
|
|
|
|
|
# dbg("dns: $rule lookup complete, not in list"); |
702
|
0
|
|
|
|
|
0
|
return 1; |
703
|
|
|
|
|
|
|
} |
704
|
|
|
|
|
|
|
|
705
|
0
|
0
|
|
|
|
0
|
if ($key eq '*ASYNC_START') { |
706
|
0
|
|
|
|
|
0
|
dbg("dns: $rule lookup not yet complete"); |
707
|
0
|
|
|
|
|
0
|
return 0; # not yet complete |
708
|
|
|
|
|
|
|
} |
709
|
|
|
|
|
|
|
|
710
|
0
|
|
|
|
|
0
|
my $ent = $self->{async}->get_lookup($key); |
711
|
0
|
0
|
|
|
|
0
|
if (!defined $ent) { |
712
|
0
|
|
|
|
|
0
|
dbg("dns: $rule lookup complete, $key no longer pending"); |
713
|
0
|
|
|
|
|
0
|
return 1; |
714
|
|
|
|
|
|
|
} |
715
|
|
|
|
|
|
|
|
716
|
0
|
|
|
|
|
0
|
dbg("dns: $rule lookup not yet complete"); |
717
|
0
|
|
|
|
|
0
|
return 0; # not yet complete |
718
|
|
|
|
|
|
|
} |
719
|
|
|
|
|
|
|
|
720
|
|
|
|
|
|
|
########################################################################### |
721
|
|
|
|
|
|
|
|
722
|
|
|
|
|
|
|
# interface called by SPF plugin |
723
|
|
|
|
|
|
|
sub check_for_from_dns { |
724
|
8
|
|
|
8
|
0
|
18
|
my ($self, $pms) = @_; |
725
|
8
|
50
|
|
|
|
53
|
if (defined $pms->{sender_host_fail}) { |
726
|
0
|
|
|
|
|
|
return ($pms->{sender_host_fail} == 2); # both MX and A need to fail |
727
|
|
|
|
|
|
|
} |
728
|
|
|
|
|
|
|
} |
729
|
|
|
|
|
|
|
|
730
|
|
|
|
|
|
|
1; |