File Coverage

blib/lib/Mail/SpamAssassin/Plugin/WLBLEval.pm
Criterion Covered Total %
statement 108 289 37.3
branch 26 148 17.5
condition 2 24 8.3
subroutine 19 30 63.3
pod 1 18 5.5
total 156 509 30.6


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              
19             use strict;
20 22     22   142 use warnings;
  22         42  
  22         658  
21 22     22   132 # use bytes;
  22         41  
  22         635  
22             use re 'taint';
23 22     22   120  
  22         43  
  22         800  
24             use NetAddr::IP 4.000;
25 22     22   130  
  22         843  
  22         322  
26             use Mail::SpamAssassin::Plugin;
27 22     22   4892 use Mail::SpamAssassin::Logger;
  22         58  
  22         598  
28 22     22   122  
  22         52  
  22         62142  
29             our @ISA = qw(Mail::SpamAssassin::Plugin);
30              
31             # constructor: register the eval rule
32             my $class = shift;
33             my $mailsaobject = shift;
34 63     63 1 225  
35 63         153 # some boilerplate...
36             $class = ref($class) || $class;
37             my $self = $class->SUPER::new($mailsaobject);
38 63   33     444 bless ($self, $class);
39 63         309  
40 63         181 # the important bit!
41             $self->register_eval_rule("check_from_in_blacklist");
42             $self->register_eval_rule("check_to_in_blacklist");
43 63         281 $self->register_eval_rule("check_to_in_whitelist");
44 63         203 $self->register_eval_rule("check_to_in_more_spam");
45 63         169 $self->register_eval_rule("check_to_in_all_spam");
46 63         208 $self->register_eval_rule("check_from_in_list");
47 63         246 $self->register_eval_rule("check_replyto_in_list");
48 63         199 $self->register_eval_rule("check_to_in_list");
49 63         214 $self->register_eval_rule("check_from_in_whitelist");
50 63         175 $self->register_eval_rule("check_forged_in_whitelist");
51 63         184 $self->register_eval_rule("check_from_in_default_whitelist");
52 63         188 $self->register_eval_rule("check_forged_in_default_whitelist");
53 63         210 $self->register_eval_rule("check_mailfrom_matches_rcvd");
54 63         213 $self->register_eval_rule("check_uri_host_listed");
55 63         186 # same as: eval:check_uri_host_listed('BLACK') :
56 63         195 $self->register_eval_rule("check_uri_host_in_blacklist");
57             # same as: eval:check_uri_host_listed('WHITE') :
58 63         179 $self->register_eval_rule("check_uri_host_in_whitelist");
59              
60 63         166 return $self;
61             }
62 63         543  
63             my ($self, $pms) = @_;
64             foreach ($pms->all_from_addrs()) {
65             if ($self->_check_whitelist ($self->{main}->{conf}->{blacklist_from}, $_)) {
66 81     81 0 203 return 1;
67 81         274 }
68 42 50       215 }
69 0         0 }
70              
71             my ($self, $pms) = @_;
72             foreach ($pms->all_to_addrs()) {
73             if ($self->_check_whitelist ($self->{main}->{conf}->{blacklist_to}, $_)) {
74             return 1;
75 81     81 0 188 }
76 81         258 }
77 57 50       165 }
78 0         0  
79             my ($self, $pms) = @_;
80             foreach ($pms->all_to_addrs()) {
81             if ($self->_check_whitelist ($self->{main}->{conf}->{whitelist_to}, $_)) {
82             return 1;
83             }
84 81     81 0 164 }
85 81         282 }
86 57 50       122  
87 0         0 my ($self, $pms) = @_;
88             foreach ($pms->all_to_addrs()) {
89             if ($self->_check_whitelist ($self->{main}->{conf}->{more_spam_to}, $_)) {
90             return 1;
91             }
92             }
93 0     0 0 0 }
94 0         0  
95 0 0       0 my ($self, $pms) = @_;
96 0         0 foreach ($pms->all_to_addrs()) {
97             if ($self->_check_whitelist ($self->{main}->{conf}->{all_spam_to}, $_)) {
98             return 1;
99             }
100             }
101             }
102 0     0 0 0  
103 0         0 my ($self, $pms, $list) = @_;
104 0 0       0 my $list_ref = $self->{main}{conf}{$list};
105 0         0 unless (defined $list_ref) {
106             warn "eval: could not find list $list";
107             return;
108             }
109              
110             foreach my $addr ($pms->all_from_addrs()) {
111 14     14 0 45 if ($self->_check_whitelist ($list_ref, $addr)) {
112 14         76 return 1;
113 14 50       59 }
114 0         0 }
115 0         0  
116             return 0;
117             }
118 14         94  
119 22 50       95 my ($self, $pms, $list) = @_;
120 0         0 my $list_ref = $self->{main}{conf}{$list};
121             unless (defined $list_ref) {
122             warn "eval: could not find list $list";
123             return;
124 14         59 }
125              
126             my $replyto = $pms->get("Reply-To:addr");
127             return 0 if $replyto eq '';
128 0     0 0 0  
129 0         0 if ($self->_check_whitelist ($list_ref, $replyto)) {
130 0 0       0 return 1;
131 0         0 }
132 0         0  
133             return 0;
134             }
135 0         0  
136 0 0       0 # TODO: this should be moved to a utility module off PerMsgStatus,
137             # rather than a plugin API; it's used in Bayes.pm as a utility
138 0 0       0 my ($self, $params) = @_;
139 0         0  
140             return unless (defined $params->{permsgstatus});
141             return unless (defined $params->{type});
142 0         0 return unless (defined $params->{list});
143              
144             if (lc $params->{type} eq "to") {
145             return $self->check_to_in_list($params->{permsgstatus}, $params->{list});
146             }
147             elsif (lc $params->{type} eq "from") {
148 28     28 0 73 return $self->check_from_in_list($params->{permsgstatus}, $params->{list});
149             }
150 28 50       102  
151 28 50       75 return;
152 28 50       73 }
153              
154 28 100       119 my ($self,$pms,$list) = @_;
    50          
155 14         58 my $list_ref = $self->{main}{conf}{$list};
156             unless (defined $list_ref) {
157             warn "eval: could not find list $list";
158 14         78 return;
159             }
160              
161 0         0 foreach my $addr ($pms->all_to_addrs()) {
162             if ($self->_check_whitelist ($list_ref, $addr)) {
163             return 1;
164             }
165 14     14 0 38 }
166 14         48  
167 14 50       41 return 0;
168 0         0 }
169 0         0  
170             ###########################################################################
171              
172 14         109 my ($self, $pms) = @_;
173 24 50       64 $self->_check_from_in_whitelist($pms) unless exists $pms->{from_in_whitelist};
174 0         0 return ($pms->{from_in_whitelist} > 0);
175             }
176              
177             my ($self, $pms) = @_;
178 14         62 $self->_check_from_in_whitelist($pms) unless exists $pms->{from_in_whitelist};
179             $self->_check_from_in_default_whitelist($pms) unless exists $pms->{from_in_default_whitelist};
180             return ($pms->{from_in_whitelist} < 0) && ($pms->{from_in_default_whitelist} == 0);
181             }
182              
183             my ($self, $pms) = @_;
184 81     81 0 203 $self->_check_from_in_default_whitelist($pms) unless exists $pms->{from_in_default_whitelist};
185 81 50       456 return ($pms->{from_in_default_whitelist} > 0);
186 81         1358 }
187              
188             my ($self, $pms) = @_;
189             $self->_check_from_in_default_whitelist($pms) unless exists $pms->{from_in_default_whitelist};
190 0     0 0 0 $self->_check_from_in_whitelist($pms) unless exists $pms->{from_in_whitelist};
191 0 0       0 return ($pms->{from_in_default_whitelist} < 0) && ($pms->{from_in_whitelist} == 0);
192 0 0       0 }
193 0   0     0  
194             ###########################################################################
195              
196             my ($self, $pms) = @_;
197 81     81 0 200 my $found_match = 0;
198 81 50       419 foreach ($pms->all_from_addrs()) {
199 81         1365 if ($self->_check_whitelist ($self->{main}->{conf}->{whitelist_from}, $_)) {
200             $pms->{from_in_whitelist} = 1;
201             return;
202             }
203 0     0 0 0 my $wh = $self->_check_whitelist_rcvd ($pms, $self->{main}->{conf}->{whitelist_from_rcvd}, $_);
204 0 0       0 if ($wh == 1) {
205 0 0       0 $pms->{from_in_whitelist} = 1;
206 0   0     0 return;
207             }
208             elsif ($wh == -1) {
209             $found_match = -1;
210             }
211             }
212 81     81   195  
213 81         149 $pms->{from_in_whitelist} = $found_match;
214 81         254 return;
215 42 50       194 }
216 0         0  
217 0         0 ###########################################################################
218              
219 42         175 my ($self, $pms) = @_;
220 42 50       265 my $found_match = 0;
    50          
221 0         0 foreach ($pms->all_from_addrs()) {
222 0         0 my $wh = $self->_check_whitelist_rcvd ($pms, $self->{main}->{conf}->{def_whitelist_from_rcvd}, $_);
223             if ($wh == 1) {
224             $pms->{from_in_default_whitelist} = 1;
225 0         0 return;
226             }
227             elsif ($wh == -1) {
228             $found_match = -1;
229 81         194 }
230 81         138 }
231              
232             $pms->{from_in_default_whitelist} = $found_match;
233             return;
234             }
235              
236 81     81   160 ###########################################################################
237 81         123  
238 81         252 # check if domain name of an envelope sender address matches a domain name
239 42         212 # of the first untrusted relay (if any), or any trusted relay otherwise
240 42 50       211 my ($self, $pms) = @_;
    50          
241 0         0 my $sender = $pms->get("EnvelopeFrom:addr");
242 0         0 return 0 if $sender eq '';
243             return $self->_check_addr_matches_rcvd($pms,$sender);
244             }
245 0         0  
246             # check if domain name of a supplied e-mail address matches a domain name
247             # of the first untrusted relay (if any), or any trusted relay otherwise
248             my ($self, $pms, $addr) = @_;
249 81         196  
250 81         142 local $1;
251             return 0 if $addr !~ / \@ ( [^\@]+ \. [^\@]+ ) \z/x;
252             my $addr_domain = lc $1;
253              
254             my @relays;
255             if ($pms->{num_relays_untrusted} > 0) {
256             # check against the first untrusted, if present
257             @relays = $pms->{relays_untrusted}->[0];
258 0     0 0 0 } elsif ($pms->{num_relays_trusted} > 0) {
259 0         0 # otherwise try all trusted ones, but only do so
260 0 0       0 # if there are no untrusted relays to avoid forgery
261 0         0 push(@relays, @{$pms->{relays_trusted}});
262             }
263             return 0 if !@relays;
264              
265             my($adrh,$adrd) =
266             $self->{main}->{registryboundaries}->split_domain($addr_domain);
267 0     0   0 my $match = 0;
268             my $any_tried = 0;
269 0         0 foreach my $rly (@relays) {
270 0 0       0 my $relay_rdns = $rly->{lc_rdns};
271 0         0 next if !defined $relay_rdns || $relay_rdns eq '';
272             my($rlyh,$rlyd) =
273 0         0 $self->{main}->{registryboundaries}->split_domain($relay_rdns);
274 0 0       0 $any_tried = 1;
    0          
275             if ($adrd eq $rlyd) {
276 0         0 dbg("rules: $addr MATCHES relay $relay_rdns ($adrd)");
277             $match = 1; last;
278             }
279             }
280 0         0 if ($any_tried && !$match) {
  0         0  
281             dbg("rules: %s does NOT match relay(s) %s",
282 0 0       0 $addr, join(', ', map { $_->{lc_rdns} } @relays));
283             }
284             return $match;
285 0         0 }
286 0         0  
287 0         0 ###########################################################################
288 0         0  
289 0         0 # look up $addr and trusted relays in a whitelist with rcvd
290 0 0 0     0 # note if it appears to be a forgery and $addr is not in any-relay list
291             my ($self, $pms, $list, $addr) = @_;
292 0         0  
293 0         0 # we can only match this if we have at least 1 trusted or untrusted header
294 0 0       0 return 0 unless ($pms->{num_relays_untrusted}+$pms->{num_relays_trusted} > 0);
295 0         0  
296 0         0 my @relays;
  0         0  
297             # try the untrusted one first
298             if ($pms->{num_relays_untrusted} > 0) {
299 0 0 0     0 @relays = $pms->{relays_untrusted}->[0];
300             }
301 0         0 # then try the trusted ones; the user could have whitelisted a trusted
  0         0  
302             # relay, totally permitted
303 0         0 # but do not do this if any untrusted relays, to avoid forgery -- bug 4425
304             if ($pms->{num_relays_trusted} > 0 && !$pms->{num_relays_untrusted} ) {
305             push (@relays, @{$pms->{relays_trusted}});
306             }
307              
308             $addr = lc $addr;
309             my $found_forged = 0;
310             foreach my $white_addr (keys %{$list}) {
311 84     84   259 my $regexp = qr/$list->{$white_addr}{re}/i;
312             foreach my $domain (@{$list->{$white_addr}{domain}}) {
313             # $domain is a second param in whitelist_from_rcvd: a domain name or an IP address
314 84 100       319
315             if ($addr =~ $regexp) {
316 2         4 # From or sender address matching the first param in whitelist_from_rcvd
317             my $match;
318 2 50       6 foreach my $lastunt (@relays) {
319 2         7 local($1,$2);
320             if ($domain =~ m{^ \[ (.*) \] ( / \d{1,3} )? \z}sx) {
321             # matching by IP address
322             my($wl_ip, $rly_ip) = ($1, $lastunt->{ip});
323             $wl_ip .= $2 if defined $2; # allow prefix len even after bracket
324 2 50 33     6  
325 0         0 if (!defined $rly_ip || $rly_ip eq '') {
  0         0  
326             # relay's IP address not provided or unparseable
327              
328 2         5 } elsif ($wl_ip =~ /^\d+\.\d+\.\d+\.\d+\z/s) {
329 2         4 # an IPv4 whitelist entry can only be matched by an IPv4 relay
330 2         3 if ($wl_ip eq $rly_ip) { $match = 1; last } # exact match
  2         5  
331 0         0  
332 0         0 } elsif ($wl_ip =~ /^[\d\.]+\z/s) { # an IPv4 classful subnet?
  0         0  
333             $wl_ip =~ s/\.*\z/./; # enforce trailing dot
334             if ($rly_ip =~ /^\Q$wl_ip\E/) { $match = 1; last } # subnet
335 0 0       0  
336             } else { # either an wl entry is an IPv6 addr, or has a prefix len
337 0         0 my $rly_ip_obj = NetAddr::IP->new($rly_ip); # TCP-info field
338 0         0 if (!defined $rly_ip_obj) {
339 0         0 dbg("rules: bad IP address in relay: %s, sender: %s",
340 0 0       0 $rly_ip, $addr);
341             } else {
342 0         0 my $wl_ip_obj = NetAddr::IP->new($wl_ip); # whitelist 2nd param
343 0 0       0 if (!defined $wl_ip_obj) {
344             info("rules: bad IP address in whitelist: %s", $wl_ip);
345 0 0 0     0 } elsif ($wl_ip_obj->contains($rly_ip_obj)) {
    0          
    0          
346             # note: an IPv4-compatible IPv6 address can match an IPv4 addr
347             dbg("rules: relay addr %s matches whitelist %s, sender: %s",
348             $rly_ip, $wl_ip_obj, $addr);
349             $match = 1; last;
350 0 0       0 } else {
  0         0  
  0         0  
351             dbg("rules: relay addr %s does not match wl %s, sender %s",
352             $rly_ip, $wl_ip_obj, $addr);
353 0         0 }
354 0 0       0 }
  0         0  
  0         0  
355             }
356              
357 0         0 } else { # match by an rdns name
358 0 0       0 my $rdns = $lastunt->{lc_rdns};
359 0         0 if ($rdns =~ /(?:^|\.)\Q${domain}\E$/i) { $match=1; last }
360             }
361             }
362 0         0 if ($match) {
363 0 0       0 dbg("rules: address %s matches (def_)whitelist_from_rcvd %s %s",
    0          
364 0         0 $addr, $list->{$white_addr}{re}, $domain);
365             return 1;
366             }
367 0         0 # found address match but no relay match. note as possible forgery
368             $found_forged = -1;
369 0         0 }
  0         0  
370             }
371 0         0 }
372             if ($found_forged) { # might be forgery. check if in list of exempted
373             my $wlist = $self->{main}->{conf}->{whitelist_allows_relays};
374             foreach my $fuzzy_addr (values %{$wlist}) {
375             if ($addr =~ /$fuzzy_addr/i) {
376             $found_forged = 0;
377             last;
378 0         0 }
379 0 0       0 }
  0         0  
  0         0  
380             }
381             return $found_forged;
382 0 0       0 }
383              
384 0         0 ###########################################################################
385 0         0  
386             my ($self, $list, $addr) = @_;
387             $addr = lc $addr;
388 0         0 if (defined ($list->{$addr})) { return 1; }
389             study $addr; # study is a no-op since perl 5.16.0, eliminating related bugs
390             foreach my $regexp (values %{$list}) {
391             if ($addr =~ qr/$regexp/i) {
392 2 50       5 dbg("rules: address $addr matches whitelist or blacklist regexp: $regexp");
393 0         0 return 1;
394 0         0 }
  0         0  
395 0 0       0 }
396 0         0  
397 0         0 return 0;
398             }
399              
400             ###########################################################################
401 2         5  
402             my ($self, $pms) = @_;
403             $self->check_uri_host_listed($pms, 'BLACK');
404             }
405              
406             my ($self, $pms) = @_;
407 244     244   539 $self->check_uri_host_listed($pms, 'WHITE');
408 244         484 }
409 244 50       616  
  0         0  
410 244         340 my ($self, $pms, $subname) = @_;
411 244         295 my $host_enlisted_ref = $self->_check_uri_host_listed($pms);
  244         524  
412 0 0       0 if ($host_enlisted_ref) {
413 0         0 my $matched_host = $host_enlisted_ref->{$subname};
414 0         0 if ($matched_host) {
415             dbg("rules: uri host enlisted (%s): %s", $subname, $matched_host);
416             $pms->test_log("URI: $matched_host");
417             return 1;
418 244         1641 }
419             }
420             return 0;
421             }
422              
423             my ($self, $pms) = @_;
424 0     0 0    
425 0           if ($pms->{'uri_host_enlisted'}) {
426             return $pms->{'uri_host_enlisted'}; # just provide a cached result
427             }
428              
429 0     0 0   my $uri_lists_href = $self->{main}{conf}{uri_host_lists};
430 0           if (!$uri_lists_href || !%$uri_lists_href) {
431             $pms->{'uri_host_enlisted'} = {}; # no URI host lists
432             return $pms->{'uri_host_enlisted'};
433             }
434 0     0 0    
435 0           my %host_enlisted;
436 0 0         my @uri_listnames = sort keys %$uri_lists_href;
437 0           if (would_log("dbg","rules")) {
438 0 0         foreach my $nm (@uri_listnames) {
439 0           dbg("rules: check_uri_host_listed: (%s) %s",
440 0           $nm, join(', ', map { $uri_lists_href->{$nm}{$_} ? $_ : '!'.$_ }
441 0           sort keys %{$uri_lists_href->{$nm}}));
442             }
443             }
444 0           # obtain a complete list of html-parsed domains
445             my $uris = $pms->get_uri_detail_list();
446             my %seen;
447             while (my($uri,$info) = each %$uris) {
448 0     0     next if $uri =~ /^mailto:/i; # we may want to skip mailto: uris (?)
449             while (my($host,$domain) = each( %{$info->{hosts}} )) { # typically one
450 0 0         next if $seen{$host};
451 0           $seen{$host} = 1;
452             local($1,$2);
453             my @query_keys;
454 0           if ($host =~ /^\[(.*)\]\z/) { # looks like an address literal
455 0 0 0       @query_keys = ( $1 );
456 0           } elsif ($host =~ /^\d+\.\d+\.\d+\.\d+\z/) { # IPv4 address
457 0           @query_keys = ( $host );
458             } elsif ($host ne '') {
459             my($h) = $host;
460 0           for (;;) {
461 0           shift @query_keys if @query_keys > 10; # sanity limit, keep tail
462 0 0         push(@query_keys, $h); # sub.example.com, example.com, com
463 0           last if $h !~ s{^([^.]*)\.(.*)\z}{$2}s;
464             }
465 0 0         }
466 0           foreach my $nm (@uri_listnames) {
  0            
467             my $match;
468             my $verdict;
469             my $hash_nm_ref = $uri_lists_href->{$nm};
470 0           foreach my $q (@query_keys) {
471 0           $verdict = $hash_nm_ref->{$q};
472 0           if (defined $verdict) {
473 0 0         $match = $q eq $host ? $host : "$host ($q)";
474 0           $match = '!' if !$verdict;
  0            
475 0 0         last;
476 0           }
477 0           }
478 0           if (defined $verdict) {
479 0 0         $host_enlisted{$nm} = $match if $verdict;
    0          
    0          
480 0           dbg("rules: check_uri_host_listed %s, (%s): %s, search: %s",
481             $uri, $nm, $match, join(', ',@query_keys));
482 0           }
483             }
484 0           }
485 0           }
486 0 0         $pms->{'uri_host_enlisted'} = \%host_enlisted;
487 0           return $pms->{'uri_host_enlisted'};
488 0 0         }
489              
490             1;