← Index
NYTProf Performance Profile   « line view »
For /usr/local/bin/sa-learn
  Run on Sun Nov 5 02:36:06 2017
Reported on Sun Nov 5 02:56:22 2017

Filename/usr/local/lib/perl5/site_perl/Mail/SpamAssassin/Plugin/DNSEval.pm
StatementsExecuted 38 statements in 4.84ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
111187µs452µsMail::SpamAssassin::Plugin::DNSEval::::newMail::SpamAssassin::Plugin::DNSEval::new
11146µs46µsMail::SpamAssassin::Plugin::DNSEval::::BEGIN@27Mail::SpamAssassin::Plugin::DNSEval::BEGIN@27
11131µs46µsMail::SpamAssassin::Plugin::DNSEval::::BEGIN@32Mail::SpamAssassin::Plugin::DNSEval::BEGIN@32
11131µs105µsMail::SpamAssassin::Plugin::DNSEval::::BEGIN@35Mail::SpamAssassin::Plugin::DNSEval::BEGIN@35
11131µs627µsMail::SpamAssassin::Plugin::DNSEval::::BEGIN@29Mail::SpamAssassin::Plugin::DNSEval::BEGIN@29
11129µs117µsMail::SpamAssassin::Plugin::DNSEval::::BEGIN@37Mail::SpamAssassin::Plugin::DNSEval::BEGIN@37
11128µs175µsMail::SpamAssassin::Plugin::DNSEval::::BEGIN@30Mail::SpamAssassin::Plugin::DNSEval::BEGIN@30
11126µs32µsMail::SpamAssassin::Plugin::DNSEval::::BEGIN@34Mail::SpamAssassin::Plugin::DNSEval::BEGIN@34
11126µs232µsMail::SpamAssassin::Plugin::DNSEval::::BEGIN@28Mail::SpamAssassin::Plugin::DNSEval::BEGIN@28
11126µs67µsMail::SpamAssassin::Plugin::DNSEval::::BEGIN@33Mail::SpamAssassin::Plugin::DNSEval::BEGIN@33
0000s0sMail::SpamAssassin::Plugin::DNSEval::::_check_rbl_addressesMail::SpamAssassin::Plugin::DNSEval::_check_rbl_addresses
0000s0sMail::SpamAssassin::Plugin::DNSEval::::check_dns_senderMail::SpamAssassin::Plugin::DNSEval::check_dns_sender
0000s0sMail::SpamAssassin::Plugin::DNSEval::::check_rblMail::SpamAssassin::Plugin::DNSEval::check_rbl
0000s0sMail::SpamAssassin::Plugin::DNSEval::::check_rbl_accreditorMail::SpamAssassin::Plugin::DNSEval::check_rbl_accreditor
0000s0sMail::SpamAssassin::Plugin::DNSEval::::check_rbl_backendMail::SpamAssassin::Plugin::DNSEval::check_rbl_backend
0000s0sMail::SpamAssassin::Plugin::DNSEval::::check_rbl_envfromMail::SpamAssassin::Plugin::DNSEval::check_rbl_envfrom
0000s0sMail::SpamAssassin::Plugin::DNSEval::::check_rbl_from_domainMail::SpamAssassin::Plugin::DNSEval::check_rbl_from_domain
0000s0sMail::SpamAssassin::Plugin::DNSEval::::check_rbl_from_hostMail::SpamAssassin::Plugin::DNSEval::check_rbl_from_host
0000s0sMail::SpamAssassin::Plugin::DNSEval::::check_rbl_results_forMail::SpamAssassin::Plugin::DNSEval::check_rbl_results_for
0000s0sMail::SpamAssassin::Plugin::DNSEval::::check_rbl_subMail::SpamAssassin::Plugin::DNSEval::check_rbl_sub
0000s0sMail::SpamAssassin::Plugin::DNSEval::::check_rbl_txtMail::SpamAssassin::Plugin::DNSEval::check_rbl_txt
0000s0sMail::SpamAssassin::Plugin::DNSEval::::check_startMail::SpamAssassin::Plugin::DNSEval::check_start
0000s0sMail::SpamAssassin::Plugin::DNSEval::::ip_list_uniq_and_strip_privateMail::SpamAssassin::Plugin::DNSEval::ip_list_uniq_and_strip_private
0000s0sMail::SpamAssassin::Plugin::DNSEval::::message_accreditor_tagMail::SpamAssassin::Plugin::DNSEval::message_accreditor_tag
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 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=head1 NAME
19
20DNSEVAL - look up URLs against DNS blocklists
21
22=cut
23
24
25package Mail::SpamAssassin::Plugin::DNSEval;
26
27279µs146µs
# spent 46µs within Mail::SpamAssassin::Plugin::DNSEval::BEGIN@27 which was called: # once (46µs+0s) by Mail::SpamAssassin::PluginHandler::load_plugin at line 27
use Mail::SpamAssassin::Plugin;
# spent 46µs making 1 call to Mail::SpamAssassin::Plugin::DNSEval::BEGIN@27
28280µs2438µs
# spent 232µs (26+206) within Mail::SpamAssassin::Plugin::DNSEval::BEGIN@28 which was called: # once (26µs+206µs) by Mail::SpamAssassin::PluginHandler::load_plugin at line 28
use Mail::SpamAssassin::Logger;
# spent 232µs making 1 call to Mail::SpamAssassin::Plugin::DNSEval::BEGIN@28 # spent 206µs making 1 call to Exporter::import
29282µs21.22ms
# spent 627µs (31+596) within Mail::SpamAssassin::Plugin::DNSEval::BEGIN@29 which was called: # once (31µs+596µs) by Mail::SpamAssassin::PluginHandler::load_plugin at line 29
use Mail::SpamAssassin::Constants qw(:ip);
# spent 627µs making 1 call to Mail::SpamAssassin::Plugin::DNSEval::BEGIN@29 # spent 596µs making 1 call to Exporter::import
30262µs2323µs
# spent 175µs (28+148) within Mail::SpamAssassin::Plugin::DNSEval::BEGIN@30 which was called: # once (28µs+148µs) by Mail::SpamAssassin::PluginHandler::load_plugin at line 30
use Mail::SpamAssassin::Util qw(reverse_ip_address);
# spent 175µs making 1 call to Mail::SpamAssassin::Plugin::DNSEval::BEGIN@30 # spent 148µs making 1 call to Exporter::import
31
32292µs261µs
# spent 46µs (31+15) within Mail::SpamAssassin::Plugin::DNSEval::BEGIN@32 which was called: # once (31µs+15µs) by Mail::SpamAssassin::PluginHandler::load_plugin at line 32
use strict;
# spent 46µs making 1 call to Mail::SpamAssassin::Plugin::DNSEval::BEGIN@32 # spent 15µs making 1 call to strict::import
33290µs2108µs
# spent 67µs (26+41) within Mail::SpamAssassin::Plugin::DNSEval::BEGIN@33 which was called: # once (26µs+41µs) by Mail::SpamAssassin::PluginHandler::load_plugin at line 33
use warnings;
# spent 67µs making 1 call to Mail::SpamAssassin::Plugin::DNSEval::BEGIN@33 # spent 41µs making 1 call to warnings::import
34289µs238µs
# spent 32µs (26+6) within Mail::SpamAssassin::Plugin::DNSEval::BEGIN@34 which was called: # once (26µs+6µs) by Mail::SpamAssassin::PluginHandler::load_plugin at line 34
use bytes;
# spent 32µs making 1 call to Mail::SpamAssassin::Plugin::DNSEval::BEGIN@34 # spent 6µs making 1 call to bytes::import
35290µs2180µs
# spent 105µs (31+74) within Mail::SpamAssassin::Plugin::DNSEval::BEGIN@35 which was called: # once (31µs+74µs) by Mail::SpamAssassin::PluginHandler::load_plugin at line 35
use re 'taint';
# spent 105µs making 1 call to Mail::SpamAssassin::Plugin::DNSEval::BEGIN@35 # spent 74µs making 1 call to re::import
36
3723.98ms2205µs
# spent 117µs (29+88) within Mail::SpamAssassin::Plugin::DNSEval::BEGIN@37 which was called: # once (29µs+88µs) by Mail::SpamAssassin::PluginHandler::load_plugin at line 37
use vars qw(@ISA);
# spent 117µs making 1 call to Mail::SpamAssassin::Plugin::DNSEval::BEGIN@37 # spent 88µs making 1 call to vars::import
38114µs@ISA = qw(Mail::SpamAssassin::Plugin);
39
40# constructor: register the eval rule
41
# spent 452µs (187+265) within Mail::SpamAssassin::Plugin::DNSEval::new which was called: # once (187µs+265µs) by Mail::SpamAssassin::PluginHandler::load_plugin at line 1 of (eval 93)[Mail/SpamAssassin/PluginHandler.pm:129]
sub new {
4212µs my $class = shift;
4312µs my $mailsaobject = shift;
44
45 # some boilerplate...
4612µs $class = ref($class) || $class;
47118µs128µs my $self = $class->SUPER::new($mailsaobject);
# spent 28µs making 1 call to Mail::SpamAssassin::Plugin::new
4812µs bless ($self, $class);
49
50 # this is done this way so that the same list can be used here and in
51 # check_start()
52119µs $self->{'evalrules'} = [
53 'check_rbl_accreditor',
54 'check_rbl',
55 'check_rbl_txt',
56 'check_rbl_sub',
57 'check_rbl_results_for',
58 'check_rbl_from_host',
59 'check_rbl_from_domain',
60 'check_rbl_envfrom',
61 'check_dns_sender',
62 ];
63
64219µs foreach(@{$self->{'evalrules'}}) {
65976µs9237µs $self->register_eval_rule($_);
# spent 237µs making 9 calls to Mail::SpamAssassin::Plugin::register_eval_rule, avg 26µs/call
66 }
67
68119µs return $self;
69}
70
71# this is necessary because PMS::run_rbl_eval_tests() calls these functions
72# directly as part of PMS
73sub check_start {
74 my ($self, $opts) = @_;
75
76 foreach(@{$self->{'evalrules'}}) {
77 $opts->{'permsgstatus'}->register_plugin_eval_glue($_);
78 }
79}
80
81sub ip_list_uniq_and_strip_private {
82 my ($self, @origips) = @_;
83 my @ips;
84 my %seen;
85 my $IP_PRIVATE = IP_PRIVATE;
86 foreach my $ip (@origips) {
87 next unless $ip;
88 next if (exists ($seen{$ip})); $seen{$ip} = 1;
89 next if ($ip =~ /$IP_PRIVATE/o);
90 push(@ips, $ip);
91 }
92 return @ips;
93}
94
95# check an RBL if the message contains an "accreditor assertion,"
96# that is, the message contains the name of a service that will vouch
97# for their practices.
98#
99sub check_rbl_accreditor {
100 my ($self, $pms, $rule, $set, $rbl_server, $subtest, $accreditor) = @_;
101
102 if (!defined $pms->{accreditor_tag}) {
103 $self->message_accreditor_tag($pms);
104 }
105 if ($pms->{accreditor_tag}->{$accreditor}) {
106 $self->check_rbl_backend($pms, $rule, $set, $rbl_server, 'A', $subtest);
107 }
108 return 0;
109}
110
111# Check for an Accreditor Assertion within the message, that is, the name of
112# a third-party who will vouch for the sender's practices. The accreditor
113# can be asserted in the EnvelopeFrom like this:
114#
115# listowner@a--accreditor.mail.example.com
116#
117# or in an 'Accreditor" Header field, like this:
118#
119# Accreditor: accreditor1, parm=value; accreditor2, parm-value
120#
121# This implementation supports multiple accreditors, but ignores any
122# parameters in the header field.
123#
124sub message_accreditor_tag {
125 my ($self, $pms) = @_;
126 my %acctags;
127
128 if ($pms->get('EnvelopeFrom:addr') =~ /[@.]a--([a-z0-9]{3,})\./i) {
129 (my $tag = $1) =~ tr/A-Z/a-z/;
130 $acctags{$tag} = -1;
131 }
132 my $accreditor_field = $pms->get('Accreditor',undef);
133 if (defined $accreditor_field) {
134 my @accreditors = split(/,/, $accreditor_field);
135 foreach my $accreditor (@accreditors) {
136 my @terms = split(' ', $accreditor);
137 if ($#terms >= 0) {
138 my $tag = $terms[0];
139 $tag =~ tr/A-Z/a-z/;
140 $acctags{$tag} = -1;
141 }
142 }
143 }
144 $pms->{accreditor_tag} = \%acctags;
145}
146
147sub check_rbl_backend {
148 my ($self, $pms, $rule, $set, $rbl_server, $type, $subtest) = @_;
149 local ($_);
150
151 # First check that DNS is available, if not do not perform this check
152 return 0 if $self->{main}->{conf}->{skip_rbl_checks};
153 return 0 unless $pms->is_dns_available();
154 $pms->load_resolver();
155
156 if (($rbl_server !~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) &&
157 (index($rbl_server, '.') >= 0) &&
158 ($rbl_server !~ /\.$/)) {
159 $rbl_server .= ".";
160 }
161
162 dbg("dns: checking RBL $rbl_server, set $set");
163
164 # ok, make a list of all the IPs in the untrusted set
165 my @fullips = map { $_->{ip} } @{$pms->{relays_untrusted}};
166
167 # now, make a list of all the IPs in the external set, for use in
168 # notfirsthop testing. This will often be more IPs than found
169 # in @fullips. It includes the IPs that are trusted, but
170 # not in internal_networks.
171 my @fullexternal = map {
172 (!$_->{internal}) ? ($_->{ip}) : ()
173 } @{$pms->{relays_trusted}};
174 push (@fullexternal, @fullips); # add untrusted set too
175
176 # Make sure a header significantly improves results before adding here
177 # X-Sender-Ip: could be worth using (very low occurance for me)
178 # X-Sender: has a very low bang-for-buck for me
179 my $IP_ADDRESS = IP_ADDRESS;
180 my @originating;
181 for my $header (@{$pms->{conf}->{originating_ip_headers}}) {
182 my $str = $pms->get($header,undef);
183 next unless defined $str && $str ne '';
184 push (@originating, ($str =~ m/($IP_ADDRESS)/g));
185 }
186
187 # Let's go ahead and trim away all private ips (KLC)
188 # also uniq the list and strip dups. (jm)
189 my @ips = $self->ip_list_uniq_and_strip_private(@fullips);
190
191 # if there's no untrusted IPs, it means we trust all the open-internet
192 # relays, so we can return right now.
193 return 0 unless (scalar @ips + scalar @originating > 0);
194
195 dbg("dns: IPs found: full-external: ".join(", ", @fullexternal).
196 " untrusted: ".join(", ", @ips).
197 " originating: ".join(", ", @originating));
198
199 my $trusted = $self->{main}->{conf}->{trusted_networks};
200
201 # If name is foo-notfirsthop, check all addresses except for
202 # the originating one. Suitable for use with dialup lists, like the PDL.
203 # note that if there's only 1 IP in the untrusted set, do NOT pop the
204 # list, since it'd remove that one, and a legit user is supposed to
205 # use their SMTP server (ie. have at least 1 more hop)!
206 # If name is foo-lastexternal, check only the Received header just before
207 # it enters our internal networks; we can trust it and it's the one that
208 # passed mail between networks
209 if ($set =~ /-(notfirsthop|lastexternal)$/)
210 {
211 # use the external IP set, instead of the trusted set; the user may have
212 # specified some third-party relays as trusted. Also, don't use
213 # @originating; those headers are added by a phase of relaying through
214 # a server like Hotmail, which is not going to be in dialup lists anyway.
215 @ips = $self->ip_list_uniq_and_strip_private(@fullexternal);
216 if ($1 eq "lastexternal") {
217 @ips = (defined $ips[0]) ? ($ips[0]) : ();
218 } else {
219 pop @ips if (scalar @ips > 1);
220 }
221 }
222 # If name is foo-firsttrusted, check only the Received header just
223 # after it enters our trusted networks; that's the only one we can
224 # trust the IP address from (since our relay added that header).
225 # And if name is foo-untrusted, check any untrusted IP address.
226 elsif ($set =~ /-(first|un)trusted$/)
227 {
228 my @tips;
229 foreach my $ip (@originating) {
230 if ($ip && !$trusted->contains_ip($ip)) {
231 push(@tips, $ip);
232 }
233 }
234 @ips = $self->ip_list_uniq_and_strip_private (@ips, @tips);
235 if ($1 eq "first") {
236 @ips = (defined $ips[0]) ? ($ips[0]) : ();
237 } else {
238 shift @ips;
239 }
240 }
241 else
242 {
243 my @tips;
244 foreach my $ip (@originating) {
245 if ($ip && !$trusted->contains_ip($ip)) {
246 push(@tips, $ip);
247 }
248 }
249
250 # add originating IPs as untrusted IPs (if they are untrusted)
251 @ips = reverse $self->ip_list_uniq_and_strip_private (@ips, @tips);
252 }
253
254 # How many IPs max you check in the received lines
255 my $checklast=$self->{main}->{conf}->{num_check_received};
256
257 if (scalar @ips > $checklast) {
258 splice (@ips, $checklast); # remove all others
259 }
260
261 my $tflags = $pms->{conf}->{tflags}->{$rule};
262
263 # Trusted relays should only be checked against nice rules (dnswls)
264 if (defined $tflags && $tflags !~ /\bnice\b/) {
265 # remove trusted hosts from beginning
266 while (@ips && $trusted->contains_ip($ips[0])) { shift @ips }
267 }
268
269 unless (scalar @ips > 0) {
270 dbg("dns: no untrusted IPs to check");
271 return 0;
272 }
273
274 dbg("dns: only inspecting the following IPs: ".join(", ", @ips));
275
276 eval {
277 foreach my $ip (@ips) {
278 my $revip = reverse_ip_address($ip);
279 $pms->do_rbl_lookup($rule, $set, $type,
280 $revip.'.'.$rbl_server, $subtest) if defined $revip;
281 }
282 };
283
284 # note that results are not handled here, hits are handled directly
285 # as DNS responses are harvested
286 return 0;
287}
288
289sub check_rbl {
290 my ($self, $pms, $rule, $set, $rbl_server, $subtest) = @_;
291 $self->check_rbl_backend($pms, $rule, $set, $rbl_server, 'A', $subtest);
292}
293
294sub check_rbl_txt {
295 my ($self, $pms, $rule, $set, $rbl_server, $subtest) = @_;
296 $self->check_rbl_backend($pms, $rule, $set, $rbl_server, 'TXT', $subtest);
297}
298
299# run for first message
300sub check_rbl_sub {
301 my ($self, $pms, $rule, $set, $subtest) = @_;
302
303 return 0 if $self->{main}->{conf}->{skip_rbl_checks};
304 return 0 unless $pms->is_dns_available();
305
306 $pms->register_rbl_subtest($rule, $set, $subtest);
307}
308
309# backward compatibility
310sub check_rbl_results_for {
311 #warn "dns: check_rbl_results_for() is deprecated, use check_rbl_sub()\n";
312 check_rbl_sub(@_);
313}
314
315# this only checks the address host name and not the domain name because
316# using the domain name had much worse results for dsn.rfc-ignorant.org
317sub check_rbl_from_host {
318 my ($self, $pms, $rule, $set, $rbl_server, $subtest) = @_;
319 _check_rbl_addresses($self, $pms, $rule, $set, $rbl_server, $subtest, $_[1]->all_from_addrs_domains());
320}
321
322=over 4
323
324=item check_rbl_from_domain
325
326This checks all the from addrs domain names as an alternate to check_rbl_from_host. As of v3.4.1, it has been improved to include a subtest for a specific octet.
327
328=back
329
330=cut
331sub check_rbl_from_domain {
332 my ($self, $pms, $rule, $set, $rbl_server, $subtest) = @_;
333 _check_rbl_addresses($self, $pms, $rule, $set, $rbl_server, $subtest, $_[1]->all_from_addrs_domains());
334}
335
336# this only checks the address host name and not the domain name because
337# using the domain name had much worse results for dsn.rfc-ignorant.org
338sub check_rbl_envfrom {
339 my ($self, $pms, $rule, $set, $rbl_server, $subtest) = @_;
340 _check_rbl_addresses($self, $pms, $rule, $set, $rbl_server, $subtest, $_[1]->get('EnvelopeFrom:addr',undef));
341}
342
343sub _check_rbl_addresses {
344 my ($self, $pms, $rule, $set, $rbl_server, $subtest, @addresses) = @_;
345
346 return 0 if $self->{main}->{conf}->{skip_rbl_checks};
347 return 0 unless $pms->is_dns_available();
348
349 my %hosts;
350 for (@addresses) {
351 next if !defined($_) || !/ \@ ( [^\@\s]+ )/x;
352 my $address = $1;
353 # strip leading & trailing dots (as seen in some e-mail addresses)
354 $address =~ s/^\.+//; $address =~ s/\.+\z//;
355 # squash duplicate dots to avoid an invalid DNS query with a null label
356 $address =~ tr/.//s;
357 $hosts{lc($address)} = 1 if $address =~ /\./; # must by a FQDN
358 }
359 return unless scalar keys %hosts;
360
361 $pms->load_resolver();
362
363 if (($rbl_server !~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) &&
364 (index($rbl_server, '.') >= 0) &&
365 ($rbl_server !~ /\.$/)) {
366 $rbl_server .= ".";
367 }
368 dbg("dns: _check_rbl_addresses RBL $rbl_server, set $set");
369
370 for my $host (keys %hosts) {
371 dbg("dns: checking [$host] / $rule / $set / $rbl_server");
372 $pms->do_rbl_lookup($rule, $set, 'A', "$host.$rbl_server", $subtest);
373 }
374}
375
376sub check_dns_sender {
377 my ($self, $pms, $rule) = @_;
378
379 my $host;
380 for my $from ($pms->get('EnvelopeFrom:addr',undef)) {
381 next unless defined $from;
382
383 $from =~ tr/././s; # bug 3366
384 if ($from =~ m/ \@ ( [^\@\s]+ \. [^\@\s]+ )/x ) {
385 $host = lc($1);
386 last;
387 }
388 }
389 return 0 unless defined $host;
390
391 # First check that DNS is available, if not do not perform this check
392 # TODO: need a way to skip DNS checks as a whole in configuration
393 return 0 unless $pms->is_dns_available();
394 $pms->load_resolver();
395
396 if ($host eq 'compiling.spamassassin.taint.org') {
397 # only used when compiling
398 return 0;
399 }
400
401 dbg("dns: checking A and MX for host $host");
402
403 $pms->do_dns_lookup($rule, 'A', $host);
404 $pms->do_dns_lookup($rule, 'MX', $host);
405
406 # cache name of host for later checking
407 $pms->{sender_host} = $host;
408
409 return 0;
410}
411
412117µs1;
Report produced by the NYTProf 6.04 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.