File Coverage

blib/lib/Mail/DMARC/Iterator.pm
Criterion Covered Total %
statement 259 399 64.9
branch 140 354 39.5
condition 43 124 34.6
subroutine 21 25 84.0
pod 5 5 100.0
total 468 907 51.6


line stmt bran cond sub pod time code
1             package Mail::DMARC::Iterator;
2 2     2   65837 use strict;
  2         12  
  2         57  
3 2     2   10 use warnings;
  2         4  
  2         57  
4 2     2   1049 use Mail::DKIM::Iterator 1.002;
  2         34657  
  2         142  
5 2     2   1385 use Mail::SPF::Iterator 1.115 qw(:DEFAULT $DEBUG);
  2         236929  
  2         34  
6 2     2   816 use Net::DNS;
  2         9  
  2         202  
7 2     2   15 use Scalar::Util 'dualvar';
  2         14  
  2         109  
8 2     2   12 use Exporter;
  2         10  
  2         341  
9              
10             our $VERSION = '0.013';
11              
12             # TODO
13             # provide some way to get reports (rua)
14             # But to implement this we need the crude mechanism to verify external rua
15              
16              
17             # constants pass(>0), fail(0), error(<0)
18             # pass: At least one of the identifier aligned DKIM or SPF reported pass
19             # invalid-from: Mail contains no usable From, i.e. none or multiple or invalid
20             # perm-error: Invalid DMARC policy record
21             # temp-error: No pass and at least one temporary error
22             # none: No DMARC policy record found
23             # fail: Everything else
24             use constant {
25 2         3123 DMARC_PASS => dualvar( 1,'pass'),
26             DMARC_FAIL => dualvar( 0,'fail'),
27             DMARC_INVALID_FROM => dualvar(-1,'invalid-from'),
28             DMARC_NONE => dualvar(-2,'none'),
29             DMARC_PERMERROR => dualvar(-3,'perm-error'),
30             DMARC_TEMPERROR => dualvar(-4,'temp-error'),
31 2     2   15 };
  2         4  
32              
33             our @EXPORT_OK = qw($DEBUG);
34             our @EXPORT = qw(
35             DMARC_PASS DMARC_FAIL
36             DMARC_INVALID_FROM DMARC_PERMERROR DMARC_TEMPERROR DMARC_NONE
37             );
38              
39             *debug = \&Mail::SPF::Iterator::DEBUG;
40             sub import {
41 2 50   2   293 goto &Exporter::import if @_ == 1; # implicit :DEFAULT
42 0         0 my $i = 1;
43 0         0 while ( $i<@_ ) {
44 0 0 0     0 if ( $_[$i] eq 'DebugFunc' || $_[$i] eq 'Debug' ) {
45 0         0 Mail::SPF::Iterator->import(splice( @_,$i,2 ));
46 0         0 next;
47             }
48 0         0 ++$i;
49             }
50 0 0       0 goto &Exporter::import if @_ >1; # not implicit :DEFAULT
51             }
52              
53              
54             # defined at the end, based on the public suffix module we have installed
55             sub organizational_domain($);
56              
57             sub new {
58 7     7 1 23546 my ($class,%args) = @_;
59             # for SPF: $ip, $mailfrom, $helo, [$myname]
60             # If no SPF information -> try to extract from Received-SPF header in mail
61              
62 7         61 my $self = bless {
63             result => undef, # cached final result
64              
65             domain => undef, # \@domains extracted from mail header
66             record => undef, # DMARC record for domain
67             _hdrbuf => '', # temporary buf to collect header
68             _from => undef, # list of sender domains during collection in header
69             _dmarc_domain => undef, # list of domains to check for DMARC record
70              
71             dkim => undef, # internal DKIM object
72             dkim_sub => undef, # external function which computes dkim_result
73             dkim_result => undef, # result from DKIM
74              
75             spf => undef, # SPF object
76             spf_result => undef, # result from SPF
77              
78             dnscache => undef, # external DNS cache
79             _dnsq => {}, # local mapping to DNS packet for open queries
80             authentication_results => [],
81             },$class;
82              
83 7 50 66     48 if ($args{spf_result}) {
    100 33        
    50          
84 0         0 $self->{spf_result} = delete $args{spf_result};
85             } elsif ($args{ip} && $args{mailfrom} && $args{helo}) {
86             $self->{spf} = Mail::SPF::Iterator->new(
87 4         28 delete @args{qw(ip mailfrom helo myname)});
88 4         4152 $self->{spf_result} = [ $self->{spf}->next ];
89             } elsif (exists $args{spf_result}) {
90             # explicitely set to undef - extract from Received-SPF header
91             } else {
92             # we cannot lookup SPF ourself so we need to rely on DKIM only
93 3         7 $self->{spf_result} = [];
94             }
95              
96 7 50       854 if ($args{dkim_result}) {
    100          
97 0         0 $self->{dkim_result}[0] = delete $args{dkim_result};
98             } elsif ($args{dkim_sub}) {
99 2         4 $self->{dkim_sub} = delete $args{dkim_sub};
100 2         6 $self->{dkim_result}[0] = $self->{dkim_sub}();
101             } else {
102 5         20 $self->{dkim} = Mail::DKIM::Iterator->new;
103 5         67 $self->{dkim_result} = [ $self->{dkim}->next ];
104             }
105              
106 7         71 $self->{domain} = delete $args{domain};
107 7         14 $self->{dnscache} = delete $args{dnscache};
108              
109             # maybe we have already enough data to compute result?
110 7         19 $self->next;
111 7         16 return $self;
112             }
113              
114              
115             # input
116             # - (string): data from mail
117             # - (Net::DNS::Packet): DNS packet with answer for DKIM or SPF
118             # - ([Net::DNS::Packet, error]): DNS query where lookup failed
119             # - (): just recompute final result
120             # output:
121             # - ($rv,@todo) with $rv the (preliminary) results and @todo the list of things
122             # to do, that is either need more data ('D') or DNS lookups (DNS query packet)
123             sub next {
124 34     34 1 30067 my ($self,@input) = @_;
125              
126             process_input:
127 60 50       177 goto return_result if $self->{result};
128 60 100       163 goto recalc if ! @input;
129              
130 26         44 my $data = shift(@input);
131              
132             # If we got a string append it to mail and if this is part of the header
133             # extract data from it. The string '' means EOF.
134             # ---------------------------------------------------------------------
135 26 100       58 if (!ref($data)) {
136 12 50       24 $DEBUG && debug("new mail data");
137 12 100 66     48 if (!$self->{domain} && defined $self->{_hdrbuf}) {
138             # Scan for From header, fills self.domain
139 8         17 _inspect_header($self,$data);
140             }
141 12 100       33 if ($self->{dkim}) {
142             # feed into DKIM object
143 10         30 $self->{dkim_result} = [ $self->{dkim}->next($data) ];
144             }
145 12         6903 goto process_input;
146             }
147              
148             # Assume DNS packet. It might also be [ dns-question, error ].
149             # Find the related callback to handle the response.
150             # ---------------------------------------------------------------------
151 14         19 my $error;
152 14 50       56 if ( ! UNIVERSAL::isa( $data, 'Net::DNS::Packet' )) {
153 0         0 ($data,$error) = @$data;
154 0   0     0 $error ||= 'unknown error';
155 0 0       0 $DEBUG && debug("error for DNS response to %s: %s ",
156             ($data->question)[0]->string, $error);
157             } else {
158 14 50       35 $DEBUG && debug("got DNS response to ".($data->question)[0]->string);
159             }
160              
161 14         35 my $dq = ($data->question)[0];
162 14         88 my $cachekey = $dq->qtype.':'.$dq->qname;
163 14         296 my $qid = $cachekey.':'.$data->header->id;
164 14         162 my $cb = $self->{cb}{$qid};
165 14 50       31 if (!$cb) {
166             # undefined -> unexpected response: complain
167             # defined but false -> possible duplicate: ignore
168 0 0       0 warn "unexpected packet $qid does not match any of the todos\n"
169             if !defined $cb;
170 0         0 goto process_input;
171             };
172              
173 14         29 delete $self->{_dnsq}{$cachekey};
174 14 50       30 $self->{dnscache}{$cachekey} = $data if $self->{dnscache};
175              
176 14         29 ($cb,my @arg) = @$cb;
177 14         39 $cb->($self,$data,$error,@arg);
178 14         913 goto process_input;
179              
180              
181             recalc:
182 35 50       79 goto return_result if $self->{result};
183 35 100       88 goto compute_todos if ! $self->{domain};
184              
185             # Check if we can compute a final result based on the existing DKIM
186             # and SPF results
187             # ---------------------------------------------------------------------
188              
189 27 100       63 my $rec = $self->{record} or goto compute_todos;
190              
191 20         30 my $dkim_result;
192 20 100 100     66 if ($self->{dkim_sub} and
193             my $r = $self->{dkim_result}[0] = $self->{dkim_sub}()) {
194 2 50       15 @$r = grep { $_->sig->{d} =~ $self->{domrx} } @$r if $self->{domrx};
  4         22  
195             }
196 20 50       61 if ($self->{dkim_result}) {
197 20 100 100     81 if ($self->{dkim} and !$self->{dkim_result}[1]) {
198 4         16 push @{$self->{authentication_results}}, $_->authentication_results
199 4 50       9 for @{ $self->{dkim_result}[0] || []};
  4         10  
200 4 50       56 $DEBUG && debug("internal dkim done");
201 4         29 delete $self->{dkim};
202             }
203 20 100       36 for(@{ $self->{dkim_result}[0] || [] }) {
  20         57  
204 19 50 0     41 $DEBUG && debug("got identifier aligned DKIM record, status=%s",
205             $_->status // '');
206 19   100     51 my $st = $_->status // next;
207 6 50 0     34 if ($st == DKIM_SUCCESS) {
    0          
    0          
208             # Identifier aligned DKIM-Received passed.
209             # Alignment was already checked in _got_dmarc_record.
210 6         14 $self->{result} = [ DMARC_PASS, 'DKIM' ];
211 6         66 goto return_result;
212              
213             } elsif ( $st == DKIM_SOFTFAIL || $st == DKIM_TEMPFAIL) {
214 0         0 $dkim_result = [ DMARC_TEMPERROR, $_->error ];
215             } elsif ($st == DKIM_PERMFAIL) {
216 0         0 $dkim_result = [ DMARC_FAIL, $_->error ];
217             } else {
218 0         0 $dkim_result = [ DMARC_PERMERROR, $_->error ];
219             }
220             }
221             }
222              
223 14         63 my $spf_result;
224             {
225 14 50       15 my $sr = $self->{spf_result} or last;
  14         40  
226 14 100       36 defined $sr->[0] or last;
227              
228             # check if envelope-from of SPF-Record matches from
229 5   0     13 my $from = $sr->[2]{'envelope-from'} || $sr->[2]{helo} || last;
230 5         26 $from =~s{.*\@}{};
231 5         16 $from =~s{>.*}{};
232 5 50       134 if ( $rec->{aspf} eq 's'
    100          
233             ? lc($from) ne $rec->{domain}
234             : $from !~m{^([\w\-\.]+\.)?\Q$rec->{domain}\E}i) {
235             # Identifier alignment failed
236 1 50       4 $DEBUG && debug("SPF identifier alignment failed");
237 1         2 $spf_result = [ DMARC_FAIL,
238             'envelope-from does not match From header' ];
239 1         8 delete $self->{spf};
240 1         2 $self->{spf_result} = [];
241 1         4 last;
242             }
243             # Successful identifier alignment, use result from check.
244 4 50       12 $DEBUG && debug("SPF identifier alignment sucess, status=%s",
245             $sr->[0]);
246 4 100       12 if ($sr->[0] eq SPF_Pass) {
247             # fast pass through - it is enough if SPF passes
248 1         4 $self->{result} = [ DMARC_PASS, 'SPF' ];
249 1         13 goto return_result;
250             }
251              
252             $spf_result =
253 3 0 50     15 $sr->[0] eq SPF_Fail ? [ DMARC_FAIL, $sr->[3] // 'SPF Fail' ] :
    0 0        
    0 0        
    50 0        
254             $sr->[0] eq SPF_SoftFail ? [ DMARC_FAIL, $sr->[3] // 'SPF SoftFail' ] :
255             $sr->[0] eq SPF_PermError ? [ DMARC_PERMERROR, $sr->[3] // 'SPF PermError' ] :
256             $sr->[0] eq SPF_TempError ? [ DMARC_TEMPERROR, $sr->[3] // 'SPF TempError' ] :
257             [ DMARC_NONE, "SPF result neutral or none" ];
258             }
259              
260 13 50 66     57 if ($dkim_result || !$self->{dkim} and $spf_result || !$self->{spf}) {
      33        
      66        
261             # We can compute the final result since we either have both DKIM and SPF
262             # or we will not be able to get additional information for the missing
263             # validator.
264             # Pick the result with the best rating. This makes use of the fact that
265             # DMARC_PASS > DMARC_FAIL > DMARC_...ERROR ..
266 1         2 my $best;
267 1 0       4 $DEBUG && debug("compute final result from dkim=%s spf=%s",
    0          
    50          
268             $dkim_result ? $dkim_result->[0] : '',
269             $spf_result ? $spf_result->[0] : '');
270 1         4 for($dkim_result,$spf_result) {
271 2 50       7 defined $_->[0] or next;
272 0 0 0     0 if (!$best) {
    0          
273 0         0 $best = $_
274             } elsif ($_->[0] && $_->[0]>$best->[0]) {
275 0         0 $best = $_
276             }
277             }
278 1 50 33     10 if ($self->{dkim_sub} and
      33        
      33        
      33        
279             !$best || $best->[0] != DMARC_PASS and
280             ! $self->{dkim_result}[0] || grep { !$_->status } @{$self->{dkim_result}[0]}) {
281 1 50       4 $DEBUG && debug("wating with final result for DKIM to complete");
282 1         7 return (undef);
283             }
284 2     2   18 warn Dumper([$self->{dkim_sub},$self->{dkim_result}[0]]); use Data::Dumper;
  2         4  
  2         1586  
  0         0  
285 0   0     0 $self->{result} = $best ||
286             [ DMARC_FAIL, "neither DKIM nor SPF information" ];
287 0         0 goto return_result;
288             }
289              
290              
291              
292             compute_todos:
293              
294             # No final result yet - compute list of todos.
295             # ---------------------------------------------------------------------
296 27         52 my (@need_dns,$need_data,@todo) = ();
297 27 100       91 if (!$self->{domain}) {
    100          
298             # Need more data to find From header
299 8 50       20 $DEBUG && debug("no domain yet, need more data from mail");
300 8         13 $need_data++;
301             } elsif (my $dom = $self->{_dmarc_domain}) {
302             # Ask for the DMARC TXT record
303 7 50       18 $DEBUG && debug("need DMARC record for @$dom");
304             push @need_dns, [
305 7   33     54 $self->{_dnsq}{"TXT:_dmarc.$dom->[0]"}
306             ||= Net::DNS::Packet->new('_dmarc.'.$dom->[0],'TXT'),
307             \&_got_dmarc_record,
308             $dom
309             ];
310             }
311              
312             # we have no DMARC record yet, so wait before handling DKIM and SPF
313 27 100       532 goto return_todos if ! $self->{record};
314              
315 12 50       24 if ($self->{dkim}) {
316             # Still have a DKIM object so we probably don't have the final DKIM
317             # result yet. Check the first element of the result to see if the result
318             # is final (defined) or if we still have something to do.
319 12 50       25 if (!$self->{dkim_result}[1]) {
320             # no more todos from DKIM - remove DKIM object and keep result
321 0 0       0 $DEBUG && debug("DKIM done (no more todos)");
322 0         0 goto recalc;
323             } else {
324             # Parse todos in dkim_result and translate them to local todos.
325             # Todo in dkim_result is either \'' for more data or the DNS
326             # name to look up the the DKIM record.
327 12         21 for(my $i=1;1;$i++) {
328 32   100     445 my $todo = $self->{dkim_result}[$i] // last;
329 20 100       41 if (ref($todo)) {
330 12 50       20 $DEBUG && debug("DKIM needs more mail data");
331 12         24 $need_data++;
332             } else {
333 8 50       14 $DEBUG && debug("DKIM needs TXT record for $todo");
334             push @need_dns, [
335 8   66     49 $self->{_dnsq}{"TXT:$todo"}
336             ||= Net::DNS::Packet->new($todo,'TXT'),
337             \&_feed_dkim,
338             $todo
339             ];
340             }
341             }
342             }
343             }
344              
345 12 100       30 if ($self->{spf}) {
    50          
346             # Still have a SPF object so we probably don't have the final SPF
347             # result yet. Check the first element of the result to see if the result
348             # is final (defined) or we still have something to do.
349 6 100       19 if ($self->{spf_result}[0]) {
350 1         2 my $sr = $self->{spf_result};
351             # no more todos - remove SPF object and keep result
352 1 50       4 $DEBUG && debug("SPF is final - $sr->[0]");
353 1         13 push @{$self->{authentication_results}}, "spf=$sr->[0] " .
354 1   50     2 ($sr->[2] && $sr->[2]{problem} && " ($sr->[2]{problem})" || "") .
355             " smtp.mailfrom=$self->{spf}{sender}";
356 1         8 delete $self->{spf};
357 1         12 goto recalc;
358             } else {
359 5         11 for(my $i=1;1;$i++) {
360             # Todos in spf_result are Net::DNS objects.
361 10   100     22 my $dnspkt = $self->{spf_result}[$i] // last;
362 5 50       10 $DEBUG && debug("SPF needs DNS lookup for %s",
363             ($dnspkt->question)[0]->string);
364 5         13 push @need_dns, [ $dnspkt, \&_feed_spf ]
365             }
366             }
367             } elsif (!$self->{spf_result}) {
368             # Extract Received-SPF information from mail
369 0 0       0 $DEBUG && debug("SPF needs more mail data to extract Received-SPF");
370 0         0 $need_data++;
371             }
372              
373             # Translate $need_data and @need_dns in todos we can return
374             # ---------------------------------------------------------------------
375             return_todos:
376 26 100       60 push @todo,'D' if $need_data;
377 26         67 my $qid2cb = $self->{cb} = {};
378 26         53 for(@need_dns) {
379 19         47 my ($pkt,$sub,@arg) = @$_;
380 19         51 my ($q) = $pkt->question;
381 19         127 $qid2cb->{ join(':', $q->qtype, $q->qname, $pkt->header->id) }
382             = [ $sub, @arg ];
383 19 50 33     813 if ($self->{dnscache} and
384             my $cached = $self->{dnscache}{ $q->qtype.':'.$q->qname }) {
385             # we have a cache hit - adapt header id
386 0 0       0 $DEBUG && debug("answer %s:%s from dns cache",
387             $q->qtype,$q->qname);
388 0         0 $cached->header->id($pkt->header->id);
389 0         0 unshift @input,$cached;
390             } else {
391 19         37 push @todo,$pkt;
392 19 50       52 $DEBUG && debug("NEW TODO qid=".join(':',
393             $q->qtype, $q->qname, $pkt->header->id)." q=".$pkt->string);
394             }
395             }
396 26 50       50 goto process_input if @input; # process results from cache
397              
398 26 50       54 if ($DEBUG) {
399 0         0 for(@todo) {
400 0 0       0 if (!ref($_)) {
401 0         0 debug("TODO: need more mail data");
402             } else {
403 0         0 debug("TODO: DNS ".($_->question)[0]->string);
404             }
405             }
406             }
407 26         144 return (undef,@todo);
408              
409              
410             # We have a final result
411             # ---------------------------------------------------------------------
412             return_result:
413 7 50       17 $self->{result} or die "why am I here?";
414 7 50       19 if (!defined $self->{result}[2]) {
415 7 50       15 if ($self->{result}[0] == DMARC_FAIL) {
416 0 0 0     0 if ($rec->{sp} && $rec->{domain} ne $self->{domain}[0]) {
417 0         0 $self->{result}[2] = $rec->{sp};
418             } else {
419 0         0 $self->{result}[2] = $rec->{p};
420             }
421             } else {
422 7         17 $self->{result}[2] = '';
423             }
424             }
425 2 50   2   16 $DEBUG && do { no warnings; debug("final result: @{$self->{result}}"); };
  2         4  
  2         7870  
  7         15  
  0         0  
  0         0  
426 7         9 return @{$self->{result}};
  7         36  
427             }
428              
429             sub authentication_results {
430 0     0 1 0 my $self = shift;
431 0 0       0 $self->{result} or return;
432             return "dmarc=$self->{result}[0] header.from=" . $self->domain
433             . ' reason="'.($self->{result}[1] // '').'"',
434 0   0     0 @{$self->{authentication_results}};
  0         0  
435             }
436              
437              
438             # returns DMARC record
439 0     0 1 0 sub record { return shift->{record} }
440              
441             # returns extracted domain
442             sub domain {
443 0     0 1 0 my $self = shift;
444 0   0     0 return $self->{domain} && $self->{domain}[0];
445             }
446              
447              
448             *parse_taglist = \&Mail::DKIM::Iterator::parse_taglist;
449             sub _got_dmarc_record {
450 7     7   15 my ($self,$pkt,$error,$dom) = @_;
451 7 50       12 goto error if $error; # NXDOMAIN or similar
452              
453             # Answer received, if we need to ask again we will set it again
454             # to the new value.
455 7         12 delete $self->{_dmarc_domain};
456              
457             # extract any usable DMARC records...
458 7         13 my @record;
459 7         17 for($pkt->answer) {
460 7 50       48 $_->type eq 'TXT' or next;
461 7         74 my $error;
462 7         18 my $txt = $_->txtdata;
463 7 50       263 $txt =~m{^\s*v=DMARC1[\s;]} or next;
464 7 50       17 $DEBUG && debug("found possible DMARC record '$txt'");
465 7 50       48 my $v = parse_taglist($txt,\$error) or next;
466 7 50       587 $v = _check_dmarc_record($v) or next;
467 7         17 push @record,$v;
468             }
469              
470 7 50       19 goto error if !@record;
471              
472             # take first usable record and ignore the rest
473 7         18 $record[0]{domain} = $dom->[0];
474 7         42 $self->{record} = $record[0];
475              
476 7 50 33     24 if ($record[0]{pct}<100 && rand(100)<$record[0]{pct}) {
477             $DEBUG && debug("skipping policy validation because of pct=%d",
478 0 0       0 $record[0]{pct});
479             $self->{result} = [
480 0         0 DMARC_NONE,
481             'skipped policy validation due to pct<100'
482             ];
483 0         0 return;
484             }
485              
486             # if the DMARC record was for the organizational domain ignore sp
487 7 50 33     11 if (@{$self->{domain}}>1 && $dom ne $self->{domain}[0]) {
  7         23  
488 0         0 $record[0]{sp} = undef;
489             }
490              
491             $DEBUG && debug("use DMARC record ".join(" ",
492 7 50       17 map { "$_=$record[0]{$_}" } sort keys %{$record[0]}));
  0         0  
  0         0  
493              
494             # only consider DKIM signatures which match From
495 7         8 my $domrx;
496 7 50       16 if ($record[0]{adkim} eq 'r') {
497             # relaxed mode - must match organizational domain
498 7         65 $domrx = qr{(^|\.)\Q$self->{domain}[-1]\E\z};
499             } else {
500             # strict mode - must match domain of from
501 0         0 $domrx = qr{^\Q$self->{domain}[0]\E\z};
502             }
503 7         16 $self->{domrx} = $domrx;
504 7 100       21 if ($self->{dkim}) {
    50          
505 5     6   47 $self->{dkim}->filter(sub { shift->{d} =~ $domrx });
  6         90  
506 5         28 $self->{dkim_result} = [ $self->{dkim}->next ];
507             } elsif ($self->{dkim_result}) {
508 2         6 @{ $self->{dkim_result}[0] } = grep { $_->sig->{d} =~ $domrx }
  0         0  
509 2         4 @{ $self->{dkim_result}[0] };
  2         6  
510             }
511              
512             # if we have spf_result built from Received-SPF header filter
513             # for identifier alignment
514 7 50 33     344 if ($self->{spf_result} && ref($self->{spf_result}[0]) eq 'ARRAY') {
515             $domrx =
516             $record[0]{aspf} eq $record[0]{adkim} ? $domrx :
517 0 0       0 $record[0]{aspf} eq 'r' ? qr{(^|\.)\Q$self->{domain}[-1]\E\z} :
    0          
518             qr{^\Q$self->{domain}[0]\E\z};
519              
520 0         0 my @aligned;
521 0         0 for(@{ $self->{spf_result}[0] }) {
  0         0  
522 0 0       0 my $from = $_->[1]{'envelope-from'} or next;
523 0         0 $from =~s{.*\@}{}s;
524 0         0 $from =~s{>.*}{}s;
525 0 0       0 $from =~ $domrx or next;
526 0         0 push @aligned, $_
527             }
528 0 0       0 if (@aligned>1) {
    0          
529             # if we have multiple aligned records match the best
530 0         0 for(SPF_Pass,SPF_Fail,SPF_SoftFail) {
531 0 0       0 my @a = grep { $_->[0] eq $_ } @aligned or next;
  0         0  
532 0         0 @aligned = @a;
533 0         0 last;
534             }
535 0 0       0 $DEBUG && debug("multiple aligned Received-SPF found, pick $aligned[0][0]");
536             } elsif (@aligned) {
537 0 0       0 $DEBUG && debug("found aligned Received-SPF with $aligned[0][0] ");
538             } else {
539 0 0       0 $DEBUG && debug("none of the Received-SPF is aligned with $domrx");
540             }
541 0 0       0 $self->{spf_result} = !@aligned ? [ SPF_None ] : [
542             $aligned[0][0], # result
543             '', # comment
544             $aligned[0][1], # hash
545             ];
546             }
547 7         16 return;
548              
549 0 0 0     0 error:
    0          
550             # retry with next domain if possible
551             $DEBUG && debug("error for DMARC query %s: %s - %s",
552             $dom->[0],$error || 'no DMARC records',
553 0         0 (@$dom>1 ? "retry with @{$dom}[1..$#$dom]":"no retries"));
554              
555 0         0 shift @$dom;
556 0 0       0 if (@$dom) {
557 0         0 $self->{_dmarc_domain} = $dom;
558             } else {
559             # No usable record found and no retries possible
560 0         0 $self->{record} = '';
561             # XXX This is not fully correct - some errors might be permanent
562             # (NXDOMAIN) while others might be temporary only. For now we assume
563             # that any given error is temporary only.
564 0 0 0     0 $DEBUG && debug("finally no DMARC record: %s",
565             $error || 'no DMARC records');
566 0 0       0 $self->{result} = $error
567             ? [ DMARC_TEMPERROR, $error ]
568             : [ DMARC_PERMERROR, 'no DMARC record found' ];
569             }
570 0         0 return;
571             }
572              
573             sub _check_dmarc_record {
574 7     7   30 my $v = shift;
575 7         14 my %h;
576 7         116 for (
577             [ v => qr{^DMARC1\z}, \'' ],
578             [ adkim => qr{^[rs]\z}, 'r' ],
579             [ aspf => qr{^[rs]\z}, 'r' ],
580             [ p => qr{^(none|quarantine|reject)\z}, \'' ],
581             [ sp => qr{^(none|quarantine|reject)\z} ],
582             # These are extracted but ignored for now
583             [ fo => qr{^[01ds]\z}, '0' ],
584             [ pct => qr{^\d+\z}, 100 ],
585             [ rf => qr{^afrf\z},'afrf' ],
586             [ ri => qr{^\d+\z}, 86400 ],
587             [ rua => qr{.}, ],
588             [ ruf => qr{.}, ],
589             ) {
590 77         133 my ($k,$rx,$default) = @$_;
591 77 100       174 if (defined $v->{$k}) {
    100          
592 21 50       105 $v->{$k} =~ $rx or do {
593 0 0       0 $DEBUG && debug("DMARC $k does not match $rx");
594 0         0 return;
595             };
596 21         53 $h{$k} = $v->{$k}
597             } elsif (defined $default) {
598 42 50       69 ref($default) and do {
599 0 0       0 $DEBUG && debug("DMARC $k is missing but mandatory");
600 0         0 return;
601             };
602 42         94 $h{$k} = $default;
603             }
604             }
605 7         56 return \%h;
606             }
607              
608             sub _feed_dkim {
609 4     4   10 my ($self,$pkt,$error,$name) = @_;
610 4 50       9 if ($error) {
611 0 0       0 $DEBUG && debug("error getting DKIM record for $name");
612 0         0 $self->{dkim_result} = [ $self->{dkim}->next({ $name => undef }) ];
613             } else {
614 4 50       20 my @txt = map { $_->type eq 'TXT' ? ($_->txtdata) : () } $pkt->answer;
  4         28  
615 4 50       163 $DEBUG && debug("got %d txt records for $name",int(@txt));
616 4         19 $self->{dkim_result} = [ $self->{dkim}->next({ $name => \@txt }) ];
617             }
618             }
619              
620             sub _feed_spf {
621 3     3   6 my ($self,$pkt,$error) = @_;
622 3 50       8 if ($error) {
623 0         0 $self->{spf_result} = [ $self->{spf}->next([ $pkt,$error ]) ];
624             } else {
625 3         10 my @rv = $self->{spf}->next($pkt);
626             # Mail::SPF::Iterator returns '' as result if there are still
627             # open questions and it needs input from these
628 3 50 33     1243 if (!defined $rv[0] || $rv[0] ne '') {
629 3         10 $self->{spf_result} = \@rv;
630             } else {
631             # ask SPF object for the open todos
632 0         0 $self->{spf_result} = [ undef, $self->{spf}->todo ];
633             }
634             }
635             }
636              
637              
638             # Extract information from header. We need:
639             # - domain of From header
640             # - information from Received-SPF header if no SPF object
641              
642             sub _inspect_header {
643 8     8   15 my ($self,$data) = @_;
644 8         11 my @hdr;
645              
646             # on EOF analyze the last field in the header
647 8 50       18 goto analyze if $data eq '';
648              
649             # Extract full headers from mail, i.e. make sure that no more parts of the
650             # header line could follow (incl. line folding).
651             # Look out for end of header too.
652 8         24 $self->{_hdrbuf} .= $data;
653 8         630 while ( $self->{_hdrbuf} =~m{\G
654             (
655             (?:\S.*?) # line starting with no space (hopefully key:...)
656             (?:\n[ \t].*?)* # optional line folding
657             )
658             \r?\n
659             (?=(\r?\n)|([^ \t\r\n]))
660             }xgc) {
661 31         82 push @hdr,$1;
662 31 100       431 if ($2) {
663             # empty line: end of header
664 7 50       16 $DEBUG && debug("end of mail header");
665 7         14 $self->{_hdrbuf} = undef;
666 7         13 last;
667             }
668             }
669             # remove what we extracted from the header
670             substr($self->{_hdrbuf},0,pos($self->{_hdrbuf}),'')
671 8 50 66     43 if @hdr && defined $self->{_hdrbuf};
672              
673             # Look for useful stuff in @hdr
674             # RFC 2822 does not allow white-space before colon but RFC 822 did.
675             # Because we never know what the MUA does we accept it for the From
676             # header, but not for the Received-SPF header.
677 8         21 for(@hdr) {
678             ($self->{spf} || $self->{spf_result})
679 31 50 66     147 ? s{^(From)\s*:\s*}{}i
    100          
680             : s{^(?:(From)\s*|Received-SPF):\s*}{}i
681             or next;
682 7 50       22 if($1) {
683             # From
684 7 50       15 $DEBUG && debug("mail header from: $_");
685 7   50     8 push @{ $self->{_from} ||= [] }, _extract_domains_from_address($_);
  7         35  
686             } else {
687             # Received-SPF
688 0 0       0 $DEBUG && debug("mail header received-spf: $_");
689 0   0     0 push @{ $self->{_spfr} ||= [] }, $_;
  0         0  
690             }
691             }
692              
693             analyze:
694 8 100       20 if (defined $self->{_hdrbuf}) {
695 1 50       5 return if $data ne ''; # no end of header yet, collect more
696             # end of data = end of header - set to undef to no longer collect data
697 0         0 $self->{_hdrbuf} = undef;
698             }
699              
700             # header done
701 7 50       17 if (!$self->{domain}) {
702 7         19 my $from = delete $self->{_from};
703 7 50       22 if (!$from) {
    50          
704 0 0       0 $DEBUG && debug("DMARC no usable From header found");
705 0         0 $self->{result} = [ DMARC_PERMERROR, 'no sender domain in From' ];
706 0         0 return;
707             } elsif (@$from!=1) {
708 0 0       0 $DEBUG && debug("DMARC multiple domains in From");
709 0         0 $self->{result} = [ DMARC_PERMERROR,
710             'multiple sender domains in From' ];
711 0         0 return;
712             }
713 7         18 $self->{domain} = [ $from->[0] ];
714 7 50       19 if (my $dom = organizational_domain($from->[0])) {
715 7 50       620 push @{$self->{domain}}, $dom if $dom ne $from->[0];
  0         0  
716             }
717             # Check for DMARC record in from-domain. If nothing is found check in
718             # organizational domain.
719 7 50       16 $DEBUG && debug("domains from: @{$self->{domain}}");
  0         0  
720 7         11 $self->{_dmarc_domain} = [ @{$self->{domain}} ];
  7         21  
721             }
722              
723 7 50 33     30 if (!$self->{spf_result} && !$self->{spf}) {
724 0         0 my @records;
725 0 0       0 for(@{ delete $self->{_spfr} || [] }) {
  0         0  
726 0 0       0 my ($result,$hash) = _parse_spfreceived($_) or next;
727 0 0       0 my $from = $hash->{'envelope-from'} or do {
728 0 0       0 $DEBUG && debug(
729             "skip Received-SPF because of no envelope-from: $_");
730 0         0 next;
731             };
732 0         0 my @dom = _extract_domains_from_address($from);
733 0 0       0 @dom == 1 or next;
734             $DEBUG && debug("found Received-SPF: $result ".
735 0 0       0 join(" ",map { "$_=$hash->{$_}" } sort keys %$hash));
  0         0  
736 0         0 push @records, [ $result, $hash ];
737             }
738 0 0       0 $self->{spf_result} = @records ? [ \@records ] : [ SPF_None ];
739             }
740             }
741              
742             {
743             # Extract domains from addresslist.
744             my $addr = qr{[^\s<>@]+\@([\w\-.]+)};
745             sub _extract_domains_from_address {
746 7     7   23 local $_ = shift;
747 7         13 s{\r?\n([ \t])}{$1}sg;
748 7         13 my (@state,%domains);
749 7         10 while (1) {
750 14 50       33 if (!@state) {
    0          
    0          
    0          
751 14 50       55 m{\G ([^<,\"\(]*) (?: ([<\(\"]) | (,) | \z) }xgc or last;
752 14 50       58 if ($2) {
    100          
    50          
753 0         0 push @state,$2
754             } elsif ($1 ne '') {
755 7 50       180 $domains{lc($1)}++ if (my $x = $1) =~ m{^\s*$addr\s*\z};
756             } elsif (!$3) {
757 7         12 last; # end of string
758             }
759             } elsif ($state[-1] eq '<') {
760             # address - extract domain
761 0 0       0 m{\G(?: $addr | (?:[^>]*) ) > }xgc or last; # missing final '>'
762 0         0 pop @state;
763 0 0       0 $domains{lc($1)}++ if $1;
764             } elsif ($state[-1] eq '"') {
765             # skip quoted text
766 0 0       0 m{\G (?:[^"\\]+|\\.)* \"}xgc or last; # missing final \"
767 0         0 pop @state;
768             } elsif ($state[-1] eq '(') {
769             # skip comments (can be nested)
770 0 0       0 m{\G .*? ([()]) }xsgc or last; # missing final ')'
771 0 0       0 if ($1 eq ')') {
772 0         0 pop @state;
773             } else {
774 0         0 push @state,'('
775             }
776             }
777             }
778 7 50       16 $DEBUG && debug("extract: $_ -> ".join(" ",sort keys %domains));
779 7         39 return sort keys %domains;
780             }
781             }
782              
783             {
784             # Parse Received-SPF header into (result,\%hash).
785             my %res;
786             $res{ lc($_) } = $_ for(SPF_Pass, SPF_Fail, SPF_SoftFail, SPF_Neutral,
787             SPF_None, SPF_TempError, SPF_PermError);
788             my $res = join("|",keys %res);
789             $res = qr{$res}i;
790             my $fws = qr{(?:[ \t]*\r?\n)?[ \t]+};
791             my $key = qr{\w[\w\-]*};
792             my $atext = qr{[0-9a-zA-Z!#$%&'*+\-/=?^_`{|}~]+};
793             my $dotatom = qr{$atext(?:\.$atext)*};
794             my $qstring = qr{"(?:[^"\\]+|\\.)*"};
795             my $val = qr{$dotatom|$qstring};
796              
797             sub _parse_spfreceived {
798 0     0   0 local $_ = shift;
799 0 0       0 m{\G($res)\s+}igc or return;
800 0         0 my $result = $res{ lc($1) };
801 0         0 my %hash;
802             my $comment;
803 0         0 while (1) {
804 0 0 0     0 if ($comment) {
    0 0        
    0          
805 0 0       0 last if ! m{\G[^()]*([()])\s*}gc; # no end of comment found
806 0 0       0 $comment += $1 eq '(' ? +1:-1;
807             } elsif (m{\G($key)$fws?=$fws?($val)\s*(;\s*)?}gc) {
808 0         0 my ($k,$v,$delim) = ($1,$2,$3);
809 0 0       0 $v =~s{\\(.)}{$1}g if $v =~s{\A\"(.*)\"\z}{$1};
810 0         0 $hash{$k} = $v;
811 0 0       0 last if ! $delim; # no delimeter-> end
812             } elsif (!%hash && !defined $comment && m{\G\(}gc) {
813 0         0 $comment++;
814             } else {
815             last
816 0         0 }
817             }
818 0         0 return ($result,\%hash);
819             }
820             }
821              
822             {
823             # Define function organizational_domain based on which package we have to
824             # calculate the public suffix.
825             if (eval { require IO::Socket::SSL::PublicSuffix }) {
826             my $ps = IO::Socket::SSL::PublicSuffix->default;
827             *organizational_domain = sub {
828 7   33 7   28 return $ps->public_suffix($_[0],1) || $_[0];
829             };
830             } elsif (eval { require Domain::PublicSuffix }) {
831             my $ps = Domain::PublicSuffix->new;
832             *organizational_domain = sub {
833             return $ps->get_root_domain($_[0]) || $_[0];
834             };
835              
836             } elsif (eval { require Mozilla::PublicSuffix }) {
837             *organizational_domain = sub {
838             my $domain = shift;
839             if (my $suffix = Mozilla::PublicSuffix::public_suffix($domain)) {
840             return $1 if $domain =~m{([^\.]+\.\Q$suffix\E$)}i;
841             }
842             return $domain;
843             }
844             } else {
845             die "failed to find any package for calculating the public suffix";
846             }
847             }
848              
849             1;
850              
851             __END__