File Coverage

blib/lib/Mail/SpamAssassin/Plugin/AskDNS.pm
Criterion Covered Total %
statement 39 203 19.2
branch 2 158 1.2
condition 1 35 2.8
subroutine 10 17 58.8
pod 2 7 28.5
total 54 420 12.8


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             =head1 NAME
19              
20             AskDNS - form a DNS query using tag values, and look up the DNSxL lists
21              
22             =head1 SYNOPSIS
23              
24             loadplugin Mail::SpamAssassin::Plugin::AskDNS
25             askdns D_IN_DWL _DKIMDOMAIN_._vouch.dwl.spamhaus.org TXT /\b(transaction|list|all)\b/
26              
27             =head1 DESCRIPTION
28              
29             Using a DNS query template as specified in a parameter of a askdns rule,
30             the plugin replaces tag names as found in the template with their values
31             and launches DNS queries as soon as tag values become available. When DNS
32             responses trickle in, filters them according to the requested DNS resource
33             record type and optional subrule filtering expression, yielding a rule hit
34             if a response meets filtering conditions.
35              
36             =head1 USER SETTINGS
37              
38             =over 4
39              
40             =item rbl_timeout t [t_min] [zone] (default: 15 3)
41              
42             The rbl_timeout setting is common to all DNS querying rules (as implemented
43             by other plugins). It can specify a DNS query timeout globally, or individually
44             for each zone. When the zone parameter is specified, the settings affects DNS
45             queries when their query domain equals the specified zone, or is its subdomain.
46             See the C<Mail::SpamAssassin::Conf> POD for details on C<rbl_timeout>.
47              
48             =back
49              
50             =head1 RULE DEFINITIONS
51              
52             =over 4
53              
54             =item askdns NAME_OF_RULE query_template [rr_type [subqueryfilter]]
55              
56             A query template is a string which will be expanded to produce a domain name
57             to be used in a DNS query. The template may include SpamAssassin tag names,
58             which will be replaced by their values to form a final query domain.
59             The final query domain must adhere to rules governing DNS domains, i.e.
60             must consist of fields each up to 63 characters long, delimited by dots.
61             There may be a trailing dot at the end, but it is redundant / carries
62             no semantics, because SpamAssassin uses a Net::DSN::Resolver::send method
63             for querying DNS, which ignores any 'search' or 'domain' DNS resolver options.
64             Domain names in DNS queries are case-insensitive.
65              
66             A tag name is a string of capital letters, preceded and followed by an
67             underscore character. This syntax mirrors the add_header setting, except that
68             tags cannot have parameters in parenthesis when used in askdns templates.
69             Tag names may appear anywhere in the template - each queried DNS zone
70             prescribes how a query should be formed.
71              
72             A query template may contain any number of tag names including none,
73             although in the most common anticipated scenario exactly one tag name would
74             appear in each askdns rule. Specified tag names are considered dependencies.
75             Askdns rules with dependencies on the same set of tags are grouped, and all
76             queries in a group are launched as soon as all their dependencies are met,
77             i.e. when the last of the awaited tag values becomes available by a call
78             to set_tag() from some other plugin or elsewhere in the SpamAssassin code.
79              
80             Launched queries from all askdns rules are grouped too according to a pair
81             of: query type and an expanded query domain name. Even if there are multiple
82             rules producing the same type/domain pair, only one DNS query is launched,
83             and a reply to such query contributes to all the constituent rules.
84              
85             A tag may produce none, one or multiple values. Askdns rules awaiting for
86             a tag which never receives its value never result in a DNS query. Tags which
87             produce multiple values will result in multiple queries launched, each with
88             an expanded template using one of the tag values. An example is a DKIMDOMAIN
89             tag which yields a list of signing domains, one for each valid signature in
90             a signed message.
91              
92             When more than one distinct tag name appears in a template, each potentially
93             resulting in multiple values, a Cartesian product is formed, and each tuple
94             results in a launch of one DNS query (duplicates excluded). For example,
95             a query template _A_._B_.example._A_.com where tag A is a list (11,22)
96             and B is (xx,yy,zz), will result in queries: 11.xx.example.11.com,
97             22.xx.example.22.com, 11.yy.example.11.com, 22.yy.example.22.com,
98             11.zz.example.11.com, 22.zz.example.22.com .
99              
100             A parameter rr_type following the query template is a comma-separated list
101             of expected DNS resource record (RR) types. Missing rr_type parameter implies
102             an 'A'. A DNS result may bring resource records of multiple types, but only
103             resource records of a type found in the rr_type parameter list are considered,
104             other resource records found in the answer section of a DNS reply are ignored
105             for this rule. A value ANY in the rr_type parameter list matches any resource
106             record type. An empty DNS answer section does not match ANY.
107              
108             The rr_type parameter not only provides a filter for RR types found in
109             the DNS answer, but also determines the DNS query type. If only a single
110             RR type is specified in the parameter (e.g. TXT), than this is also the RR
111             type of a query. When more than one RR type is specified (e.g. A, AAAA, TXT)
112             or if ANY is specified, then the DNS query type will be ANY and the rr_type
113             parameter will only act as a filter on a result.
114              
115             Currently recognized RR types in the rr_type parameter are: ANY, A, AAAA,
116             MX, TXT, PTR, NAPTR, NS, SOA, CERT, CNAME, DNAME, DHCID, HINFO, MINFO,
117             RP, HIP, IPSECKEY, KX, LOC, SRV, SSHFP, SPF.
118              
119             https://www.iana.org/assignments/dns-parameters/dns-parameters.xml
120              
121             The last optional parameter of a rule is a filtering expression, a.k.a. a
122             subrule. Its function is much like the subrule in URIDNSBL plugin rules,
123             or in the check_rbl eval rules. The main difference is that with askdns
124             rules there is no need to manually group rules according to their queried
125             zone, as the grouping is automatic and duplicate queries are implicitly
126             eliminated.
127              
128             The subrule filtering parameter can be: a plain string, a regular expression,
129             a single numerical value or a pair of numerical values, or a list of rcodes
130             (DNS status codes of a response). Absence of the filtering parameter implies
131             no filtering, i.e. any positive DNS response (rcode=NOERROR) of the requested
132             RR type will result in a rule hit, regardless of the RR value returned with
133             the response.
134              
135             When a plain string is used as a filter, it must be enclosed in single or
136             double quotes. For the rule to hit, the response must match the filtering
137             string exactly, and a RR type of a response must match the query type.
138             Typical use is an exact text string for TXT queries, or an exact quad-dotted
139             IPv4 address. In case of a TXT or SPF resource record which can return
140             multiple character-strings (as defined in Section 3.3 of [RFC1035]), these
141             strings are concatenated with no delimiters before comparing the result
142             to the filtering string. This follows requirements of several documents,
143             such as RFC 5518, RFC 7208, RFC 4871, RFC 5617. Examples of a plain text
144             filtering parameter: "127.0.0.1", "transaction", 'list' .
145              
146             A regular expression follows a familiar perl syntax like /.../ or m{...}
147             optionally followed by regexp flags (such as 'i' for case-insensitivity).
148             If a DNS response matches the requested RR type and the regular expression,
149             the rule hits. Examples: /^127\.0\.0\.\d+$/, m{\bdial up\b}i .
150              
151             A single numerical value can be a decimal number, or a hexadecimal number
152             prefixed by 0x. Such numeric filtering expression is typically used with
153             RR type-A DNS queries. The returned value (an IPv4 address) is masked
154             with a specified filtering value and tested to fall within a 127.0.0.0/8
155             network range - the rule hits if the result is nonzero:
156             ((r & n) != 0) && ((r & 0xff000000) == 0x7f000000). An example: 0x10 .
157              
158             A pair of numerical values (each a decimal, hexadecimal or quad-dotted)
159             delimited by a '-' specifies an IPv4 address range, and a pair of values
160             delimited by a '/' specifies an IPv4 address followed by a bitmask. Again,
161             this type of filtering expression is primarily intended with RR type-A
162             DNS queries. The rule hits if the RR type matches, and the returned IP
163             address falls within the specified range: (r >= n1 && r <= n2), or
164             masked with a bitmask matches the specified value: (r & m) == (n & m) .
165              
166             As a shorthand notation, a single quad-dotted value is equivalent to
167             a n-n form, i.e. it must match the returned value exactly with all its bits.
168              
169             Some typical examples of a numeric filtering parameter are: 127.0.1.2,
170             127.0.1.20-127.0.1.39, 127.0.1.0/255.255.255.0, 0.0.0.16/0.0.0.16,
171             0x10/0x10, 16, 0x10 .
172              
173             Lastly, the filtering parameter can be a comma-separated list of DNS status
174             codes (rcode), enclosed in square brackets. Rcodes can be represented either
175             by their numeric decimal values (0=NOERROR, 3=NXDOMAIN, ...), or their names.
176             See https://www.iana.org/assignments/dns-parameters for the list of names. When
177             testing for a rcode where rcode is nonzero, a RR type parameter is ignored
178             as a filter, as there is typically no answer section in a DNS reply when
179             rcode indicates an error. Example: [NXDOMAIN], or [FormErr,ServFail,4,5] .
180              
181             =back
182              
183             =cut
184              
185              
186             use strict;
187 22     22   155 use warnings;
  22         40  
  22         632  
188 22     22   189 use re 'taint';
  22         44  
  22         637  
189 22     22   124  
  22         64  
  22         717  
190             use Mail::SpamAssassin::Plugin;
191 22     22   120 use Mail::SpamAssassin::Util qw(decode_dns_question_entry);
  22         60  
  22         589  
192 22     22   116 use Mail::SpamAssassin::Logger;
  22         41  
  22         1042  
193 22     22   130 use version 0.77;
  22         52  
  22         1283  
194 22     22   165  
  22         397  
  22         161  
195             our @ISA = qw(Mail::SpamAssassin::Plugin);
196              
197             our %rcode_value = ( # https://www.iana.org/assignments/dns-parameters, RFC 6195
198             NOERROR => 0, FORMERR => 1, SERVFAIL => 2, NXDOMAIN => 3, NOTIMP => 4,
199             REFUSED => 5, YXDOMAIN => 6, YXRRSET => 7, NXRRSET => 8, NOTAUTH => 9,
200             NOTZONE => 10, BADVERS => 16, BADSIG => 16, BADKEY => 17, BADTIME => 18,
201             BADMODE => 19, BADNAME => 20, BADALG => 21, BADTRUNC => 22,
202             );
203              
204             our $txtdata_can_provide_a_list;
205              
206             my($class,$sa_main) = @_;
207              
208 63     63 1 249 $class = ref($class) || $class;
209             my $self = $class->SUPER::new($sa_main);
210 63   33     5153 bless($self, $class);
211 63         342  
212 63         179 $self->set_config($sa_main->{conf});
213              
214 63         325 #$txtdata_can_provide_a_list = Net::DNS->VERSION >= 0.69;
215             #more robust version check from Damyan Ivanov - Bug 7095
216             $txtdata_can_provide_a_list = version->parse(Net::DNS->VERSION) >= version->parse('0.69');
217              
218 63         2745 return $self;
219             }
220 63         753  
221             # ---------------------------------------------------------------------------
222              
223             # Accepts argument as a string in single or double quotes, or as a regular
224             # expression in // or m{} notation, or as a numerical value or a pair of
225             # numerical values, or as a bracketed and comma-separated list of DNS rcode
226             # names or their numerical codes. Recognized numerical forms are: m, n1-n2,
227             # or n/m, where n,n1,n2,m can be any of: decimal digits, 0x followed by
228             # up to 8 hexadecimal digits, or an IPv4 address in quad-dotted notation.
229             # The argument is checked for syntax, undef is returned on syntax errors.
230             # A string that looks like a regular expression is converted to a compiled
231             # Regexp object and returned as a result. Otherwise, numeric components of
232             # the remaining three forms are converted as follows: hex or decimal numeric
233             # strings are converted to a number and a quad-dot is converted to a number,
234             # then components are reassembled into a string delimited by '-' or '/'.
235             # As a special backward compatibility measure, a single quad-dot (with no
236             # second number) is converted into n-n, to distinguish it from a traditional
237             # mask-only form. A list or rcodes is returned as a hashref, where keys
238             # represent specified numerical rcodes.
239             #
240             # Arguments like the following are anticipated:
241             # "127.0.0.1", "some text", 'some "more" text',
242             # /regexp/flags, m{regexp}flags,
243             # 127.0.1.2 (same as 127.0.1.2-127.0.1.2 or 127.0.1.2/255.255.255.255)
244             # 127.0.1.20-127.0.1.39 (= 0x7f000114-0x7f000127 or 2130706708-2130706727)
245             # 0.0.0.16/0.0.0.16 (same as 0x10/0x10 or 16/0x10 or 16/16)
246             # 16 (traditional style mask-only, same as 0x10)
247             # [NXDOMAIN], [FormErr,ServFail,4,5]
248             #
249             my($subtest) = @_;
250             my $result;
251              
252 0     0 0 0 local($1,$2,$3);
253 0         0 # modifiers /a, /d, /l, /u in suffix form were added with perl 5.13.10 (5.14)
254             # currently known modifiers are [msixoadlu], but let's not be too picky here
255 0         0 if ( $subtest =~ m{^ / (.+) / ([a-z]*) \z}xs) {
256             $result = $2 ne '' ? qr{(?$2)$1} : qr{$1};
257             } elsif ($subtest =~ m{^ m \s* \( (.+) \) ([a-z]*) \z}xs) {
258 0 0       0 $result = $2 ne '' ? qr{(?$2)$1} : qr{$1};
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
259 0 0       0 } elsif ($subtest =~ m{^ m \s* \[ (.+) \] ([a-z]*) \z}xs) {
260             $result = $2 ne '' ? qr{(?$2)$1} : qr{$1};
261 0 0       0 } elsif ($subtest =~ m{^ m \s* \{ (.+) \} ([a-z]*) \z}xs) {
262             $result = $2 ne '' ? qr{(?$2)$1} : qr{$1};
263 0 0       0 } elsif ($subtest =~ m{^ m \s* < (.+) > ([a-z]*) \z}xs) {
264             $result = $2 ne '' ? qr{(?$2)$1} : qr{$1};
265 0 0       0 } elsif ($subtest =~ m{^ m \s* (\S) (.+) \1 ([a-z]*) \z}xs) {
266             $result = $2 ne '' ? qr{(?$2)$1} : qr{$1};
267 0 0       0 } elsif ($subtest =~ m{^ (["']) (.*) \1 \z}xs) { # quoted string
268             $result = $2;
269 0 0       0 } elsif ($subtest =~ m{^ \[ ( (?:[A-Z]+|\d+)
270             (?: \s* , \s* (?:[A-Z]+|\d+) )* ) \] \z}xis) {
271 0         0 # a comma-separated list of rcode names or their decimal values
272             my @rcodes = split(/\s*,\s*/, uc $1);
273             for (@rcodes) { $_ = $rcode_value{$_} if exists $rcode_value{$_} }
274             return if grep(!/^\d+\z/, @rcodes);
275 0         0 # a hashref indicates a list of DNS rcodes (stored as hash keys)
276 0 0       0 $result = { map( ($_,1), @rcodes) };
  0         0  
277 0 0       0 } elsif ($subtest =~ m{^ ([^/-]+) (?: ([/-]) (.+) )? \z}xs) {
278             my($n1,$delim,$n2) = ($1,$2,$3);
279 0         0 my $any_quad_dot;
280             for ($n1,$n2) {
281 0         0 if (!defined $_) {
282 0         0 # ok, $n2 may not exist
283 0         0 } elsif (/^\d{1,10}\z/) {
284 0 0       0 $_ = 0 + $_; # decimal string -> number
    0          
    0          
    0          
285             } elsif (/^0x[0-9a-zA-Z]{1,8}\z/) {
286             $_ = hex($_); # hex string -> number
287 0         0 } elsif (/^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}\z/) {
288             $_ = Mail::SpamAssassin::Util::my_inet_aton($_); # quad-dot -> number
289 0         0 $any_quad_dot = 1;
290             } else {
291 0         0 return;
292 0         0 }
293             }
294 0         0 $result = defined $n2 ? $n1.$delim.$n2
295             : $any_quad_dot ? $n1.'-'.$n1 : "$n1";
296             }
297 0 0       0 return $result;
    0          
298             }
299              
300 0         0 my($self, $conf) = @_;
301             my @cmds;
302              
303             push(@cmds, {
304 63     63 0 151 setting => 'askdns',
305 63         126 is_admin => 1,
306             type => $Mail::SpamAssassin::Conf::CONF_TYPE_HASH_KEY_VALUE,
307             code => sub {
308             my($self, $key, $value, $line) = @_;
309             local($1,$2,$3,$4);
310             if (!defined $value || $value =~ /^$/) {
311             return $Mail::SpamAssassin::Conf::MISSING_REQUIRED_VALUE;
312 0     0   0 } elsif ($value !~ /^ (\S+) \s+ (\S+)
313 0         0 (?: \s+ ([A-Za-z0-9,]+)
314 0 0 0     0 (?: \s+ (.*?) )? )? \s* $/xs) {
    0          
315 0         0 return $Mail::SpamAssassin::Conf::INVALID_VALUE;
316             } else {
317             my($rulename,$query_template,$query_type,$subtest) = ($1,$2,$3,$4);
318             $query_type = 'A' if !defined $query_type;
319 0         0 $query_type = uc $query_type;
320             my @answer_types = split(/,/, $query_type);
321 0         0 # https://www.iana.org/assignments/dns-parameters/dns-parameters.xml
322 0 0       0 if (grep(!/^(?:ANY|A|AAAA|MX|TXT|PTR|NAPTR|NS|SOA|CERT|CNAME|DNAME|
323 0         0 DHCID|HINFO|MINFO|RP|HIP|IPSECKEY|KX|LOC|SRV|
324 0         0 SSHFP|SPF)\z/x, @answer_types)) {
325             return $Mail::SpamAssassin::Conf::INVALID_VALUE;
326 0 0       0 }
327             $query_type = 'ANY' if @answer_types > 1 || $answer_types[0] eq 'ANY';
328             if (defined $subtest) {
329 0         0 $subtest = parse_and_canonicalize_subtest($subtest);
330             defined $subtest or return $Mail::SpamAssassin::Conf::INVALID_VALUE;
331 0 0 0     0 }
332 0 0       0 # collect tag names as used in each query template
333 0         0 my @tags = $query_template =~ /_([A-Z][A-Z0-9]*)_/g;
334 0 0       0 my %seen; @tags = grep(!$seen{$_}++, @tags); # filter out duplicates
335              
336             # group rules by tag names used in them (to be used as a hash key)
337 0         0 my $depends_on_tags = !@tags ? '' : join(',',@tags);
338 0         0  
  0         0  
339             # subgroup rules by a DNS RR type and a nonexpanded query template
340             my $query_template_key = $query_type . ':' . $query_template;
341 0 0       0  
342             $self->{askdns}{$depends_on_tags}{$query_template_key} ||=
343             { query => $query_template, rules => {}, q_type => $query_type,
344 0         0 a_types => # optimization: undef means "same as q_type"
345             @answer_types == 1 && $answer_types[0] eq $query_type ? undef
346 0 0 0     0 : \@answer_types };
      0        
347             $self->{askdns}{$depends_on_tags}{$query_template_key}{rules}{$rulename}
348             = $subtest;
349             # dbg("askdns: rule: %s, config dep: %s, domkey: %s, subtest: %s",
350             # $rulename, $depends_on_tags, $query_template_key, $subtest);
351 0         0  
352             # just define the test so that scores and lint works
353             $self->{parser}->add_test($rulename, undef,
354             $Mail::SpamAssassin::Conf::TYPE_EMPTY_TESTS);
355             }
356             }
357 0         0 });
358              
359             $conf->{parser}->register_commands(\@cmds);
360             }
361 63         750  
362             # run as early as possible, launching DNS queries as soon as their
363 63         359 # dependencies are fulfilled
364             #
365             my($self, $opts) = @_;
366             my $pms = $opts->{permsgstatus};
367             my $conf = $pms->{conf};
368              
369             return if !$pms->is_dns_available;
370 81     81 1 223 $pms->{askdns_map_dnskey_to_rules} = {};
371 81         176  
372 81         176 # walk through all collected askdns rules, obtain tag values whenever
373             # they may become available, and launch DNS queries right after
374 81 100       202 #
375 4         10 for my $depends_on_tags (keys %{$conf->{askdns}}) {
376             my @tags;
377             @tags = split(/,/, $depends_on_tags) if $depends_on_tags ne '';
378              
379             if (would_log("dbg","askdns")) {
380 4         6 while ( my($query_template_key, $struct) =
  4         21  
381 0           each %{$conf->{askdns}{$depends_on_tags}} ) {
382 0 0         my($query_template, $query_type, $answer_types_ref, $rules) =
383             @$struct{qw(query q_type a_types rules)};
384 0 0         dbg("askdns: depend on tags %s, rules: %s ",
385 0           $depends_on_tags, join(', ', keys %$rules));
386 0           }
387             }
388 0            
389 0           if (!@tags) {
390             # no dependencies on tags, just call directly
391             $self->launch_queries($pms,$depends_on_tags);
392             } else {
393             # enqueue callback for tags needed
394 0 0         $pms->action_depends_on_tags(@tags == 1 ? $tags[0] : \@tags,
395             sub { my($pms,@args) = @_;
396 0           $self->launch_queries($pms,$depends_on_tags) }
397             );
398             }
399             }
400 0     0     }
401 0            
402 0 0         # generate DNS queries - called for each set of rules
403             # when their tag dependencies are met
404             #
405             my($self, $pms, $depends_on_tags) = @_;
406             my $conf = $pms->{conf};
407              
408             my %tags;
409             # obtain tag/value pairs of tags we depend upon in this set of rules
410             if ($depends_on_tags ne '') {
411 0     0 0   %tags = map( ($_,$pms->get_tag($_)), split(/,/,$depends_on_tags) );
412 0           }
413             dbg("askdns: preparing queries which depend on tags: %s",
414 0           join(', ', map($_.' => '.$tags{$_}, keys %tags)));
415              
416 0 0         # replace tag names in a query template with actual tag values
417 0           # and launch DNS queries
418             while ( my($query_template_key, $struct) =
419             each %{$conf->{askdns}{$depends_on_tags}} ) {
420 0           my($query_template, $query_type, $answer_types_ref, $rules) =
421             @$struct{qw(query q_type a_types rules)};
422              
423             my @rulenames = keys %$rules;
424 0           if (grep($conf->{scores}->{$_}, @rulenames)) {
425 0           dbg("askdns: query template %s, type %s, rules: %s",
426             $query_template,
427 0           !$answer_types_ref ? $query_type
428             : $query_type.'/'.join(',',@$answer_types_ref),
429 0           join(', ', @rulenames));
430 0 0         } else {
431 0 0         dbg("askdns: query template %s, type %s, all rules disabled: %s",
432             $query_template, $query_type, join(', ', @rulenames));
433             next;
434             }
435              
436             # collect all tag names from a template, each may occur more than once
437 0           my @templ_tags = $query_template =~ /_([A-Z][A-Z0-9]*)_/gs;
438              
439 0           # filter out duplicate tag names, and tags with undefined or empty value
440             my %seen;
441             @templ_tags = grep(!$seen{$_}++ && defined $tags{$_} && $tags{$_} ne '',
442             @templ_tags);
443 0            
444             my %templ_vals; # values that each tag takes
445             for my $t (@templ_tags) {
446 0           my %seen;
447 0   0       # a tag value may be a space-separated list,
448             # store it as an arrayref, removing duplicate values
449             $templ_vals{$t} = [ grep(!$seen{$_}++, split(' ',$tags{$t})) ];
450 0           }
451 0            
452 0           # count through all tag value tuples
453             my @digit = (0) x @templ_tags; # counting accumulator
454             OUTER:
455 0           for (;;) {
456             my %current_tag_val; # maps a tag name to its current iteration value
457             for my $j (0 .. $#templ_tags) {
458             my $t = $templ_tags[$j];
459 0           $current_tag_val{$t} = $templ_vals{$t}[$digit[$j]];
460             }
461 0           local $1;
462 0           my $query_domain = $query_template;
463 0           $query_domain =~ s{_([A-Z][A-Z0-9]*)_}
464 0           { defined $current_tag_val{$1} ? $current_tag_val{$1}
465 0           : '' }ge;
466              
467 0           # the $dnskey identifies this query in AsyncLoop's pending_lookups
468 0           my $dnskey = join(':', 'askdns', $query_type, $query_domain);
469 0 0         dbg("askdns: expanded query %s, dns key %s", $query_domain, $dnskey);
  0            
470              
471             if ($query_domain eq '') {
472             # ignore, just in case
473 0           } else {
474 0           if (!exists $pms->{askdns_map_dnskey_to_rules}{$dnskey}) {
475             $pms->{askdns_map_dnskey_to_rules}{$dnskey} =
476 0 0         [ [$query_type, $answer_types_ref, $rules] ];
477             } else {
478             push(@{$pms->{askdns_map_dnskey_to_rules}{$dnskey}},
479 0 0         [$query_type, $answer_types_ref, $rules] );
480 0           }
481             # launch a new DNS query for $query_type and $query_domain
482             my $ent = $pms->{async}->bgsend_and_start_lookup(
483 0           $query_domain, $query_type, undef,
  0            
484             { key => $dnskey, zone => $query_domain },
485             sub { my ($ent2,$pkt) = @_;
486             $self->process_response_packet($pms, $ent2, $pkt, $dnskey) },
487             master_deadline => $pms->{master_deadline} );
488             # these rules are now underway; unless the rule hits, these will
489             # not be considered "finished" until harvest_dnsbl_queries() completes
490 0     0     $pms->register_async_rule_start($dnskey) if $ent;
491 0           }
492 0            
493             last if !@templ_tags;
494             # increment accumulator, little-endian
495 0 0         for (my $j = 0; ; $j++) {
496             last if ++$digit[$j] <= $#{$templ_vals{$templ_tags[$j]}};
497             $digit[$j] = 0; # and carry
498 0 0         last OUTER if $j >= $#templ_tags;
499             }
500 0           }
501 0 0         }
  0            
502 0           }
503 0 0          
504             my($self, $pms, $ent, $pkt, $dnskey) = @_;
505              
506             my $conf = $pms->{conf};
507             my %rulenames_hit;
508              
509             # map a dnskey back to info on queries which caused this DNS lookup
510 0     0 0   my $queries_ref = $pms->{askdns_map_dnskey_to_rules}{$dnskey};
511              
512 0           my($header, @question, @answer, $qtype, $rcode);
513 0           # NOTE: $pkt will be undef if the DNS query was aborted (e.g. timed out)
514             if ($pkt) {
515             @answer = $pkt->answer;
516 0           $header = $pkt->header;
517             @question = $pkt->question;
518 0           $qtype = uc $question[0]->qtype if @question;
519             $rcode = uc $header->rcode if $header; # 'NOERROR', 'NXDOMAIN', ...
520 0 0          
521 0           # NOTE: qname is encoded in RFC 1035 zone format, decode it
522 0           dbg("askdns: answer received, rcode %s, query %s, answer has %d records",
523 0           $rcode,
524 0 0         join(', ', map(join('/', decode_dns_question_entry($_)), @question)),
525 0 0         scalar @answer);
526              
527             if (defined $rcode && exists $rcode_value{$rcode}) {
528 0           # Net::DNS return a rcode name for codes it knows about,
529             # and returns a number for the rest; we deal with numbers from here on
530             $rcode = $rcode_value{$rcode} if exists $rcode_value{$rcode};
531             }
532             }
533 0 0 0       if (!@answer) {
534             # a trick to make the following loop run at least once, so that we can
535             # evaluate also rules which only care for rcode status
536 0 0         @answer = ( undef );
537             }
538              
539 0 0         # NOTE: $rr->rdstring returns the result encoded in a DNS zone file
540             # format, i.e. enclosed in double quotes if a result contains whitespace
541             # (or other funny characters), and may use \DDD encoding or \X quoting as
542 0           # per RFC 1035. Using $rr->txtdata instead avoids this unnecessary encoding
543             # step and a need for decoding by a caller, returning an unmodified string.
544             # Caveat: in case of multiple RDATA <character-string> fields contained
545             # in a resource record (TXT, SPF, HINFO), starting with Net::DNS 0.69
546             # the $rr->txtdata in a list context returns these strings as a list.
547             # The $rr->txtdata in a scalar context always returns a single string
548             # with <character-string> fields joined by a single space character as
549             # a separator. The $rr->txtdata in Net::DNS 0.68 and older returned
550             # such joined space-separated string even in a list context.
551              
552             # RFC 5518: If the RDATA in a TXT record contains multiple
553             # character-strings (as defined in Section 3.3 of [RFC1035]),
554             # the code handling such reply from DNS MUST assemble all of these
555             # marshaled text blocks into a single one before any syntactical
556             # verification takes place.
557             # The same goes for RFC 4408 (SPF), RFC 4871 (DKIM), RFC 5617 (ADSP),
558             # draft-kucherawy-dmarc-base (DMARC), ...
559              
560             for my $rr (@answer) {
561             my($rr_rdatastr, $rdatanum, $rr_type);
562             if (!$rr) {
563             # special case, no answer records, only rcode can be tested
564             } else {
565             $rr_type = uc $rr->type;
566 0           if ($rr_type eq 'A') {
567 0           # Net::DNS::RR::A::address() is available since Net::DNS 0.69
568 0 0         $rr_rdatastr = $rr->UNIVERSAL::can('address') ? $rr->address
569             : $rr->rdatastr;
570             if ($rr_rdatastr =~ m/^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}\z/) {
571 0           $rdatanum = Mail::SpamAssassin::Util::my_inet_aton($rr_rdatastr);
572 0 0         }
    0          
573              
574 0 0         } elsif ($rr->UNIVERSAL::can('txtdata')) {
575             # TXT, SPF: join with no intervening spaces, as per RFC 5518
576 0 0         if ($txtdata_can_provide_a_list || $rr_type ne 'TXT') {
577 0           $rr_rdatastr = join('', $rr->txtdata); # txtdata() in list context!
578             } else { # char_str_list() is only available for TXT records
579             $rr_rdatastr = join('', $rr->char_str_list); # historical
580             }
581             } else {
582 0 0 0       # rdatastr() is historical, use rdstring() since Net::DNS 0.69
583 0           $rr_rdatastr = $rr->UNIVERSAL::can('rdstring') ? $rr->rdstring
584             : $rr->rdatastr;
585 0           utf8::encode($rr_rdatastr) if utf8::is_utf8($rr_rdatastr);
586             }
587             # dbg("askdns: received rr type %s, data: %s", $rr_type, $rr_rdatastr);
588             }
589 0 0          
590             for my $q_tuple (!ref $queries_ref ? () : @$queries_ref) {
591 0 0         next if !$q_tuple;
592             my($query_type, $answer_types_ref, $rules) = @$q_tuple;
593              
594             next if !defined $qtype;
595             $answer_types_ref = [$query_type] if !defined $answer_types_ref;
596 0 0          
597 0 0         while (my($rulename,$subtest) = each %$rules) {
598 0           my $match;
599             local($1,$2,$3);
600 0 0         if (ref $subtest eq 'HASH') { # a list of DNS rcodes (as hash keys)
601 0 0         $match = 1 if $subtest->{$rcode};
602             } elsif ($rcode != 0) {
603 0           # skip remaining tests on DNS error
604 0           } elsif (!defined($rr_type) ||
605 0           !grep($_ eq 'ANY' || $_ eq $rr_type, @$answer_types_ref) ) {
606 0 0 0       # skip remaining tests on wrong RR type
    0 0        
    0          
    0          
    0          
    0          
    0          
607 0 0         } elsif (!defined $subtest) {
608             $match = 1; # any valid response of the requested RR type matches
609             } elsif (ref $subtest eq 'Regexp') { # a regular expression
610             $match = 1 if $rr_rdatastr =~ $subtest;
611             } elsif ($rr_rdatastr eq $subtest) { # exact equality
612             $match = 1;
613             } elsif (defined $rdatanum &&
614 0           $subtest =~ m{^ (\d+) (?: ([/-]) (\d+) )? \z}x) {
615             my($n1,$delim,$n2) = ($1,$2,$3);
616 0 0         $match =
617             !defined $n2 ? ($rdatanum & $n1) && # mask only
618 0           (($rdatanum & 0xff000000) == 0x7f000000) # 127/8
619             : $delim eq '-' ? $rdatanum >= $n1 && $rdatanum <= $n2 # range
620             : $delim eq '/' ? ($rdatanum & $n2) == (int($n1) & $n2) # value/mask
621 0           : 0; # notice int($n1) to fix perl ~5.14 taint bug (Bug 7725)
622 0 0 0       }
    0 0        
    0          
623             if ($match) {
624             $self->askdns_hit($pms, $ent->{query_domain}, $qtype,
625             $rr_rdatastr, $rulename);
626             $rulenames_hit{$rulename} = 1;
627             }
628             }
629 0 0         }
630 0           }
631             # these rules have completed (since they got at least 1 hit)
632 0           $pms->register_async_rule_finish($_) for keys %rulenames_hit;
633             }
634              
635             my($self, $pms, $query_domain, $qtype, $rr_rdatastr, $rulename) = @_;
636              
637             $rr_rdatastr = '' if !defined $rr_rdatastr; # e.g. with rules testing rcode
638 0           dbg('askdns: domain "%s" listed (%s): %s',
639             $query_domain, $rulename, $rr_rdatastr);
640              
641             # only the first hit will show in the test log report, even if
642 0     0 0   # an answer section matches more than once - got_hit() handles this
643             $pms->clear_test_state;
644 0 0         $pms->test_log(sprintf("%s %s:%s", $query_domain,$qtype,$rr_rdatastr));
645 0           $pms->got_hit($rulename, 'ASKDNS: ', ruletype => 'askdns'); # score=>$score
646             }
647              
648             1;