File Coverage

blib/lib/Mail/DKIM/Iterator.pm
Criterion Covered Total %
statement 353 427 82.6
branch 176 260 67.6
condition 77 163 47.2
subroutine 34 43 79.0
pod 9 9 100.0
total 649 902 71.9


line stmt bran cond sub pod time code
1             package Mail::DKIM::Iterator;
2 2     2   68951 use v5.10.0;
  2         14  
3              
4             our $VERSION = '1.009';
5              
6 2     2   11 use strict;
  2         4  
  2         50  
7 2     2   10 use warnings;
  2         4  
  2         61  
8 2     2   985 use Crypt::OpenSSL::RSA;
  2         13059  
  2         70  
9 2     2   14 use Scalar::Util 'dualvar';
  2         5  
  2         204  
10              
11             # critical header fields which should be well protected
12             my @critical_headers = qw(from subject content-type content-transfer-encoding);
13             my $critical_headers_rx = do {
14             my $rx = join("|",@critical_headers);
15             qr{$rx}i;
16             };
17             # all header fields which should be included in the signature
18             my @sign_headers = (@critical_headers, 'to', 'cc', 'date');
19              
20 2     2   13 use Exporter 'import';
  2         5  
  2         237  
21             our @EXPORT = qw(
22             DKIM_POLICY
23             DKIM_PERMERROR
24             DKIM_NEUTRAL
25             DKIM_TEMPERROR
26             DKIM_FAIL
27             DKIM_PASS
28             );
29              
30             use constant {
31 2         382 DKIM_POLICY => dualvar(-4,'policy'),
32             DKIM_PERMERROR => dualvar(-3,'permerror'),
33             DKIM_NEUTRAL => dualvar(-2,'neutral'),
34             DKIM_TEMPERROR => dualvar(-1,'temperror'),
35             DKIM_FAIL => dualvar( 0,'fail'),
36             DKIM_PASS => dualvar( 1,'pass'),
37 2     2   14 };
  2         4  
38              
39             # compability to versions 1.003 and lower
40             push @EXPORT, qw(
41             DKIM_INVALID_HDR
42             DKIM_TEMPFAIL
43             DKIM_SOFTFAIL
44             DKIM_PERMFAIL
45             DKIM_SUCCESS
46             );
47              
48             use constant {
49 2         9259 DKIM_INVALID_HDR => DKIM_PERMERROR,
50             DKIM_TEMPFAIL => DKIM_TEMPERROR,
51             DKIM_SOFTFAIL => DKIM_NEUTRAL,
52             DKIM_PERMFAIL => DKIM_FAIL,
53             DKIM_SUCCESS => DKIM_PASS,
54 2     2   14 };
  2         4  
55              
56              
57             # create new object
58             sub new {
59 44     44 1 14503 my ($class,%args) = @_;
60             my $self = bless {
61             records => $args{dns} || {}, # mapping (dnsname,dkim_key)
62             extract_sig => 1, # extract signatures from mail header
63             filter => $args{filter}, # filter which signatures are relevant
64             # sig => [...], # list of signatures from header or to sign
65 44   50     272 _hdrbuf => '', # used while collecting the mail header
66             }, $class;
67              
68 44 100       129 if (my $sig = delete $args{sign}) {
69             # signatures given for signing, either as [{},...] or {}
70             # add to self.sig
71 22 50       76 $sig = [$sig] if ref($sig) ne 'ARRAY';
72 22         41 $self->{extract_sig} = delete $args{sign_and_verify};
73 22         35 my $error;
74 22         46 for(@$sig) {
75 22 50 100     101 $_->{h} //= 'from' if ref($_); # minimal
76 22         62 my $s = parse_signature($_,\$error,1);
77 22 50       48 die "bad signature '$_': $error" if !$s;
78 22   100     92 $s->{h_auto} //= 1; # secure version will be detected based on mail
79 22         35 push @{$self->{sig}}, $s
  22         73  
80             }
81             }
82 44         126 return $self;
83             }
84              
85             # Iterator: feed object with information and get back what to do next
86             sub next {
87 104     104 1 1051 my $self = shift;
88 104         147 my $rv;
89 104         209 while (@_) {
90 104         183 my $arg = shift;
91 104 100       202 if (ref($arg)) {
92             # ref: mapping (host,dkim_key)
93 19         123 while (my ($k,$v) = each %$arg) {
94 19         73 $self->{records}{$k} = $v;
95             }
96 19         48 $rv = _compute_result($self);
97             } else {
98             # string: append data from mail
99 85 100       162 if (defined $self->{_hdrbuf}) {
100             # header not fully read: append and try to find end of header
101 44         125 $self->{_hdrbuf} .= $arg;
102 44 50       474 $self->{_hdrbuf} =~m{(\r?\n)\1}g or last; # no end of header
103              
104             # Extract header into self.header and look for DKIM signatures
105             # inside. The rest of _hdrbuf will be appended as part of the
106             # body and the attribute _hdrbuf itself is no longer needed
107 44         244 $self->{header} = substr($self->{_hdrbuf},0,$+[0],'');
108 44 100 66     162 if ($self->{extract_sig}
109             and my @sig = _parse_header($self->{header})) {
110 22 50       59 if (my $f = $self->{filter}) {
111 0         0 @sig = grep { $f->($_,$self->{header}) } @sig;
  0         0  
112             }
113 22 50 50     45 push @{$self->{sig} ||= []}, @sig if @sig;
  22         94  
114             }
115 44         110 $arg = delete $self->{_hdrbuf};
116 44 50       146 _append_body($self,$arg) if $arg ne '';
117              
118             } else {
119             # header already read: append as part of body
120 41         83 _append_body($self,$arg);
121             }
122              
123 85 50       194 if (!$self->{sig}) {
124             # No signatures found in body -> empty return list
125 0         0 $rv = [];
126             } else {
127 85         167 $rv = _compute_result($self);
128             }
129             }
130             }
131 104 50       272 $rv = _compute_result($self) if ! @_;
132              
133             # If we have no results yet just return that we need more data
134 104 50       221 $rv or return ([],\'');
135              
136             # Extract the DNS names for the partial results where the DKIM key is needed
137             # and return the as todo. If the body hash could not yet computed for a
138             # signature mark also that we need more data
139 104         162 my (%need_dns,$need_more_data);
140 104         237 for(@$rv) {
141 104 100       191 $_->status and next;
142 60         144 my $sig = $_->sig;
143              
144             # Need more data to compute the body hash?
145 60 100       136 $need_more_data = 1 if !$sig->{'bh:computed'};
146              
147             # Need to get DKIM key to validate signature?
148             # Only if we have sig.b, i.e. an extracted signature from the header.
149 60 100       135 if ($sig->{b}) {
150 38         67 my $name = $_->dnsname;
151 38 50       119 $need_dns{$name}++ if ! $self->{records}{$name};
152             }
153             }
154              
155             # return preliminary results and @todo
156 104 100       671 return ($rv,$need_more_data ? (\''):(),sort keys %need_dns);
157             }
158              
159             sub filter {
160 0     0 1 0 my ($self,$filter) = @_;
161 0         0 $self->{filter} = $filter;
162 0         0 @{$self->{sig}} = grep { $filter->($_,$self->{header}) } @{$self->{sig}}
  0         0  
  0         0  
163 0 0 0     0 if $self->{header} && $self->{sig};
164             }
165              
166             sub result {
167 0     0 1 0 my $self = shift;
168 0         0 return $self->{_last_result};
169             }
170              
171             sub authentication_results {
172             return join(";\n",map {
173 0         0 my $ar = $_->authentication_results;
174 0 0       0 $ar ? (' '.$ar) : (),
175 0 0   0 1 0 } @{shift->result || []});
  0         0  
176             }
177              
178             # Compute result based on current data.
179             # This might add more DKIM records to validate signatures.
180             sub _compute_result {
181 208     208   400 my $self = shift;
182 208 50       428 return if defined $self->{_hdrbuf}; # need more header
183 208 50       386 return [] if !$self->{sig}; # nothing to verify
184              
185 208         274 my @rv;
186 208         284 for my $sig (@{$self->{sig}}) {
  208         390  
187              
188             # use final result if we have one already
189 208 100       380 if ($sig->{':result'}) {
190 44         76 push @rv, $sig->{':result'};
191 44         79 next;
192             }
193              
194 164 100       306 if ($sig->{error}) {
195             # something wrong with the DKIM-Signature header, return error
196             push @rv, $sig->{':result'} =
197             Mail::DKIM::Iterator::VerifyRecord->new(
198             $sig,
199             ($sig->{s}//'UNKNOWN')."_domainkey".($sig->{d}//'UNKNOWN'),
200             DKIM_PERMERROR,
201             $sig->{error}
202 1   50     14 );
      50        
203 1         3 next;
204             }
205              
206 163 100       297 if (!$sig->{b}) {
207             # sig is not for verification but for signing
208 66 100       116 if (!$sig->{'bh:computed'}) {
209             # incomplete: still need more data to compute signature
210 44         102 push @rv, Mail::DKIM::Iterator::SignRecord->new($sig);
211             } else {
212             # complete: compute signature and save it in :result
213 22         32 my $err;
214 22         57 my $dkim_sig = sign($sig,$sig->{':key'},$self->{header},\$err);
215 22 50       99 push @rv, $sig->{':result'} =
216             Mail::DKIM::Iterator::SignRecord->new(
217             $dkim_sig ? ($sig,$dkim_sig,DKIM_PASS)
218             : ($sig,undef,DKIM_FAIL,$err)
219             );
220             }
221 66         144 next;
222             }
223              
224 97         255 my $dns = "$sig->{s}._domainkey.$sig->{d}";
225              
226 97 100 66     215 if ($sig->{x} && $sig->{x} < time()) {
227 1         6 push @rv, $sig->{':result'} = Mail::DKIM::Iterator::VerifyRecord
228             ->new($sig,$dns, DKIM_POLICY, "signature e[x]pired");
229 1         3 next;
230             }
231              
232 96         167 my $txt = $self->{records}{$dns};
233 96 100 33     333 if ($txt and !ref($txt) || ref($txt) eq 'ARRAY') {
    100 66        
      66        
234             # Take the first syntactically valid DKIM key from the list of
235             # TXT records.
236 18         27 my $error = "no TXT records";
237 18 50       44 for(ref($txt) ? @$txt:$txt) {
238 18 100       48 if (my $r = parse_dkimkey($_,\$error)) {
239 17         42 $self->{records}{$dns} = $txt = $r;
240 17         28 $error = undef;
241 17         28 last;
242             }
243             }
244 18 100       42 $self->{records}{$dns} = $txt = { permfail => $error }
245             if $error;
246             } elsif (exists $self->{records}{$dns} && ! $txt) {
247 1         3 $self->{records}{$dns} = $txt = { tempfail => "dns lookup failed" }
248             }
249              
250 96         179 my @v = _verify_sig($sig,$txt);
251 96         220 push @rv, Mail::DKIM::Iterator::VerifyRecord->new($sig,$dns,@v);
252 96 100       282 $sig->{':result'} = $rv[-1] if @v; # we got a final result
253             }
254 208         636 return ($self->{_last_result} = \@rv);
255             }
256              
257             # Parse DKIM-Signature value into hash and fill in necessary default values.
258             # Input can be string or hash.
259             sub parse_signature {
260 66     66 1 159 my ($v,$error,$for_signing) = @_;
261 66 100 50     175 $v = parse_taglist($v,$error) or return if !ref($v);
262              
263 66 100       141 if ($for_signing) {
264             # some defaults
265 44   100     128 $v->{v} //= '1';
266             }
267              
268 66 100 50     392 if (($v->{v}//'') ne '1') {
    50 66        
    50          
    50          
    50          
    50          
269 1   50     6 $$error = "bad DKIM signature version: ".($v->{v}||'');
270             } elsif (!$v->{d}) {
271 0         0 $$error = "required [d]omain not given";
272             } elsif (!$v->{s}) {
273 0         0 $$error = "required [s]elector not given";
274             } elsif (!$v->{h}) {
275 0         0 $$error = "required [h]eader fields not given";
276             } elsif ($v->{l} && $v->{l} !~m{^\d{1,76}\z}) {
277 0         0 $$error = "invalid body [l]ength";
278             } elsif (do {
279 65   100     223 $v->{q} = lc($v->{q}//'dns/txt');
280 65         177 $v->{q} ne 'dns/txt'
281             }) {
282 0         0 $$error = "unsupported query method $v->{q}";
283             }
284 66 100       169 return if $$error;
285              
286 65         118 $v->{d} = lc($v->{d});
287 65   100     179 $v->{a} = lc($v->{a}//'rsa-sha256');
288 65   100     172 $v->{c} = lc($v->{c}//'simple/simple');
289              
290 65         610 my @h = split(/\s*:\s*/,lc($v->{h}));
291             $$error = "'from' missing from [h]eader fields"
292 65 50       148 if ! grep { $_ eq 'from' } @h;
  473         862  
293 65         146 $v->{'h:list'} = \@h;
294              
295 65 100       138 if ($for_signing) {
296 44         79 delete $v->{b};
297 44         55 delete $v->{bh};
298 44 50       94 $v->{t} = undef if exists $v->{t};
299 44 50 66     113 if (defined $v->{x} && $v->{x} !~m{^\+?\d{1,12}\z}) {
300 0         0 $$error = "invalid e[x]piration time";
301             }
302             } else {
303 21 50 33     73 if (!$v->{b} or not $v->{'b:bin'} = _decode64($v->{b})) {
    50 33        
    50 33        
    100          
304 0   0     0 $$error = "invalid body signature: ".($v->{b}||'');
305             } elsif (!$v->{bh} or not $v->{'bh:bin'} = _decode64($v->{bh})) {
306 0   0     0 $$error = "invalid header signature: ".($v->{bh}||'');
307             } elsif ($v->{t} && $v->{t} !~m{^\d{1,12}\z}) {
308 0         0 $$error = "invalid [t]imestamp";
309             } elsif ($v->{x}) {
310 1 50 33     11 if ($v->{x} !~m{^\d{1,12}\z}) {
    50          
311 0         0 $$error = "invalid e[x]piration time";
312             } elsif ($v->{t} && $v->{x} < $v->{t}) {
313 0         0 $$error = "expiration precedes timestamp";
314             }
315             }
316              
317 21 50       48 if ($v->{i}) {
318 0         0 $v->{i} = _decodeQP($v->{i});
319 0 0       0 if (lc($v->{i}) =~m{\@([^@]+)$}) {
320 0         0 $v->{'i:domain'} = $1;
321             $$error ||= "[i]dentity does not match [d]omain"
322 0 0 0     0 if $v->{'i:domain'} !~m{^(.+\.)?\Q$v->{d}\E\z};
323             } else {
324 0         0 $$error = "no domain in identity";
325             }
326             } else {
327 21         54 $v->{i} = '@'.$v->{d};
328             }
329             }
330              
331             my ($hdrc,$bodyc) = $v->{c}
332 65 50       453 =~m{^(relaxed|simple)(?:/(relaxed|simple))?$} or do {
333 0   0     0 $$error ||= "invalid canonicalization $v->{c}";
334             };
335 65   100     180 $bodyc ||= 'simple';
336 65 50       293 my ($kalgo,$halgo) = $v->{a} =~m{^(rsa)-(sha(?:1|256))$} or do {
337 0   0     0 $$error ||= "unsupported algorithm $v->{a}";
338             };
339 65 50       148 return if $$error;
340              
341 65         111 $v->{'c:hdr'} = $hdrc;
342 65         119 $v->{'c:body'} = $bodyc;
343 65         105 $v->{'a:key'} = $kalgo;
344 65         93 $v->{'a:hash'} = $halgo;
345              
346             # ignore: z
347 65         182 return $v;
348             }
349              
350             # Parse DKIM key into hash and fill in necessary default values.
351             # Input can be string or hash.
352             sub parse_dkimkey {
353 18     18 1 32 my ($v,$error) = @_;
354 18 50 50     49 $v = parse_taglist($v,$error) or return if !ref($v);
355 18 100 66     85 if (!$v || !%$v) {
356 1         3 $$error = "invalid or empty DKIM record";
357 1         4 return;
358             }
359              
360 17 50 50     97 if (($v->{v}||='DKIM1') ne 'DKIM1') {
    50 50        
361 0         0 $$error = "bad DKIM record version: $v->{v}";
362             } elsif (($v->{k}//='rsa') ne 'rsa') {
363 0         0 $$error = "unsupported key type $v->{k}";
364             } else {
365 17 50       53 if (exists $v->{g}) {
366             # g is deprecated in RFC 6376
367 0         0 if (1) {
368             delete $v->{g}
369 0         0 } else {
370             $v->{g} = ($v->{g}//'') =~m{^(.*)\*(.*)$}
371             ? qr{^\Q$1\E.*\Q$2\E\@[^@]+\z}
372             : qr{^\Q$v->{g}\E\@[^@]+\z};
373             }
374             }
375 17   50     81 $v->{t} = { map { $_ => 1 } split(':',lc($v->{t} || '')) };
  0         0  
376 17   50     72 $v->{h} = { map { $_ => 1 } split(':',lc($v->{h} || 'sha1:sha256')) };
  34         124  
377 17   50     80 $v->{s} = { map { $_ => 1 } split(':',lc($v->{s} || '*')) };
  17         54  
378 17 0 33     46 if (!$v->{s}{'*'} && !$v->{s}{email}) {
379 0         0 $$error = "service type " . join(':',keys %{$v->{s}})
  0         0  
380             . " does not match";
381 0         0 return;
382             }
383 17         51 return $v;
384             }
385 0         0 return;
386             }
387              
388             # Finalize signature, i.e add the 'b' parameter.
389             # Input is signature (hash or string), the private key (PEM or
390             # Crypto::OpenSSL::RSA object) and the mail header.
391             # Output is "DKIM-Signature: .... " string with proper line length so that it
392             # can be inserted into the mail header.
393             sub sign {
394 22     22 1 54 my ($sig,$key,$hdr,$error) = @_;
395 22 100 66     111 if (ref($sig) && $sig->{h_auto}) {
396             # add a useful default based on the header which makes sure that no all
397             # relevant headers are covered and no additional important headers can
398             # be added
399 20         30 my (%oh,@nh);
400 20   50     110 $oh{lc($_)}++ for split(':',$sig->{h} ||'');
401 20         47 for my $k (@sign_headers) {
402 140         1722 for($hdr =~m{^($k):}mgi) {
403 80         192 push @nh,$k; # cover each instance in header
404             }
405 140         275 push @nh,$k; # cover non-existance so that no instance can be added
406 140 100 66     383 delete $oh{$k} if exists $oh{$k} and --$oh{$k} == 0;
407             }
408 20         43 push @nh,($_) x $oh{$_} for keys %oh;
409 20         100 $sig->{h} = join(':',@nh);
410             }
411 22 50       56 $sig = parse_signature($sig,$error,1) or return;
412              
413              
414 22         182 my %sig = %$sig;
415 22 50 33     111 $sig{t} = time() if !$sig{t} && exists $sig{t};
416             $sig{x} = ($sig{t} || time()) + $1
417 22 50 0     57 if $sig{x} && $sig{x} =~m{^\+(\d+)$};
      66        
418 22 50       50 $sig{'a:key'} eq 'rsa' or do {
419 0         0 $$error = "unsupported algorithm ".$sig{'a:key'};
420 0         0 return;
421             };
422 22         33 delete $sig{b};
423 22 50       42 $sig{i} = _encodeQP($sig{':i'}) if $sig{':i'};
424 22 50       42 $sig{z} = _encodeQP($sig{':z'}) if $sig{':z'};
425 22   33     63 $sig{bh} = _encode64($sig{'bh:computed'} || $sig{'bh:bin'});
426 22         39 $sig{h} = join(':',@{$sig{'h:list'}});
  22         68  
427              
428 22         48 my @v;
429 22         58 for (qw(v a c d q s t x h l i z bh)) {
430 286   100     576 my $v = delete $sig{$_} // next;
431 178         432 push @v, "$_=$v"
432             }
433 22         130 for(sort keys %sig) {
434 176 100       353 m{:} and next;
435 22   50     68 my $v = _encodeQP(delete $sig{$_} // next);
436 22         66 push @v, "$_=$v"
437             }
438              
439 22         55 my @lines = shift(@v);
440 22         39 for(@v,"b=") {
441 200         260 $lines[-1] .= ';';
442 200         321 my $append = " $_";
443 200 100       348 my $x80 = (@lines == 1 ? 64 : 80) - length($lines[-1]);
444 200 100       370 if (length($append)<=$x80) {
    100          
445 159         300 $lines[-1] .= $append;
446             } elsif (length($append)<=80) {
447 21         43 push @lines,$append;
448             } else {
449 20         29 while (1) {
450 44 100       91 if ( $x80>10) {
451 40         95 $lines[-1] .= substr($append,0,$x80,'');
452 40 100       98 $append eq '' and last;
453             }
454 24         40 push @lines,' ';
455 24         35 $x80 = 80;
456             }
457             }
458             }
459              
460 22         66 my $dkh = 'DKIM-Signature: '.join("\r\n",@lines);
461 22 50       64 $sig->{'a:key'} eq 'rsa' or do {
462 0         0 $$error = "unsupported signature algorithm $sig->{'a:key'}";
463 0         0 return;
464             };
465             my $hash = _compute_hdrhash($hdr,
466 22         58 $sig{'h:list'},$sig->{'a:hash'},$sig->{'c:hdr'},$dkh);
467              
468 22 50       758 my $priv = ref($key) ? $key : Crypt::OpenSSL::RSA->new_private_key($key);
469 22 50       76 $priv or do {
470 0         0 $$error = "using private key failed";
471 0         0 return;
472             };
473 22         68 $priv->use_no_padding;
474              
475             my $data = _encode64($priv->decrypt(
476 22         94 _emsa_pkcs1_v15($sig->{'a:hash'},$hash,$priv->size)));
477              
478 22   33     272 my $x80 = 80 - ($dkh =~m{\n([^\n]+)\z} && length($1));
479 22         63 while ($data ne '') {
480 77 100       208 $dkh .= substr($data,0,$x80,'') if $x80>10;
481 77 100       158 $dkh .= "\r\n " if $data ne '';
482 77         133 $x80 = 80;
483             }
484 22         34 $dkh .= "\r\n";
485 22         329 return $dkh;
486             }
487              
488             # Verify a DKIM signature (hash from parse_signature) using a DKIM key (hash
489             # from parse_dkimkey). Output is (error_code,error_string) or simply
490             # (DKIM_PASS) in case of no error or () if no final result can be computed yet.
491             sub _verify_sig {
492 96     96   168 my ($sig,$param) = @_;
493              
494             # check pre-computed hash over body if body done
495 96 100 100     362 if (defined $sig->{'bh:computed'}
496             and $sig->{'bh:computed'} ne $sig->{'bh:bin'}) {
497 1         5 return (DKIM_FAIL, 'body hash mismatch');
498             }
499 95 100       217 return if ! $param;
500              
501 19 50       46 return (DKIM_PERMERROR,"none or invalid dkim record") if ! %$param;
502 19 100       40 return (DKIM_TEMPERROR,$param->{tempfail}) if $param->{tempfail};
503 18 100       41 return (DKIM_PERMERROR,$param->{permfail}) if $param->{permfail};
504              
505 17 50       40 my $FAIL = $param->{t}{y} ? DKIM_NEUTRAL : DKIM_FAIL;
506 17 50       46 return ($FAIL,"key revoked") if ! $param->{p};
507              
508             return ($FAIL,"hash algorithm not allowed")
509 17 50       47 if ! $param->{h}{$sig->{'a:hash'}};
510              
511             return ($FAIL,"identity does not match domain") if $param->{t}{s}
512 17 0 33     37 && $sig->{'i:domain'} && $sig->{'i:domain'} ne $sig->{d};
      0        
513              
514             return ($FAIL,"identity does not match granularity")
515 17 50 33     37 if $param->{g} && $sig->{i} !~ $param->{g};
516              
517             # needs bh:computed to continue
518 17 50       35 return if ! defined $sig->{'bh:computed'};
519              
520 17 100       29 if (!eval {
521 17 50       24 my $rsa = Crypt::OpenSSL::RSA->new_public_key(do {
522 17         31 local $_ = $param->{p};
523 17         50 s{\s+}{}g;
524 17         166 s{(.{1,64})}{$1\n}g;
525 17         536 "-----BEGIN PUBLIC KEY-----\n$_-----END PUBLIC KEY-----\n";
526             }) or die [DKIM_PERMERROR,"using public key failed"];
527 16         1248 $rsa->use_no_padding;
528 16 100       26 my $bencrypt = eval { $rsa->encrypt($sig->{'b:bin'}) }
  16         674  
529             or die [DKIM_PERMERROR,"header sig corrupt"];
530             my $expect = _emsa_pkcs1_v15(
531 15         64 $sig->{'a:hash'},$sig->{'h:hash'},$rsa->size);
532 15 100       43 if ($expect ne $bencrypt) {
533             # warn "expect= "._encode64($expect)."\n";
534             # warn "encrypt="._encode64($bencrypt)."\n";
535 1         10 die [$FAIL,"header sig mismatch"];
536             }
537 14         80 1;
538             }) {
539 3 100       39 return @{$@} if ref($@);
  2         11  
540 1         5 return (DKIM_PERMERROR,"using public key failed");
541             }
542 14 100       28 return (DKIM_PASS, join(' + ', @{$sig->{':warning'} || []}));
  14         89  
543             }
544              
545             # parse the header and extract
546             sub _parse_header {
547 22     22   40 my $hdr = shift;
548 22         50 my %all_critical = map { $_ => 0 } @critical_headers;
  88         203  
549 22         353 $all_critical{lc($_)}-- for $hdr =~m{^($critical_headers_rx):}mig;
550 22         54 my @sig;
551 22         155 while ( $hdr =~m{^(DKIM-Signature:\s*(.*\n(?:[ \t].*\n)*))}mig ) {
552 22         73 my $dkh = $1; # original value to exclude it when computing hash
553              
554 22         30 my $error;
555 22         57 my $sig = parse_signature($2,\$error);
556 22 100       53 if ($sig) {
557             $sig->{'h:hash'} = _compute_hdrhash($hdr,
558 21         59 $sig->{'h:list'},$sig->{'a:hash'},$sig->{'c:hdr'},$dkh);
559              
560 21         98 my %critical = %all_critical;
561 21         39 $critical{$_}++ for @{$sig->{'h:list'}};
  21         137  
562 21 100       64 if (my @h = grep { $critical{$_} < 0 } keys %critical) {
  155         320  
563 2         4 push @{$sig->{':warning'}},
  2         29  
564             "unprotected critical header ".join(",",sort @h);
565             }
566             } else {
567 1         5 $sig = { error => "invalid DKIM-Signature header: $error" };
568             }
569              
570 22         111 push @sig,$sig;
571             }
572 22         125 return @sig;
573             }
574              
575             {
576             # EMSA-PKCS1-v1_5 encapsulation, see RFC 3447 9.2
577             my %sig_prefix = (
578             'sha1' => pack("H*","3021300906052B0E03021A05000414"),
579             'sha256' => pack("H*","3031300d060960864801650304020105000420"),
580             );
581             sub _emsa_pkcs1_v15 {
582 37     37   94 my ($algo,$hash,$len) = @_;
583 37   50     124 my $t = ($sig_prefix{$algo} || die "unsupport digest $algo") . $hash;
584 37         80 my $pad = $len - length($t) -3;
585 37 50       78 $pad < 8 and die;
586 37         13860 return "\x00\x01" . ("\xff" x $pad) . "\x00" . $t;
587             }
588             }
589              
590             {
591              
592             # simple header canonicalization:
593             my $simple_hdrc = sub {
594             my $line = shift;
595             $line =~s{(?
596             return $line;
597             };
598              
599             # relaxed header canonicalization:
600             my $relaxed_hdrc = sub {
601             my ($k,$v) = shift() =~m{\A([^:]+:[ \t]*)?(.*)\z}s;
602             $v =~s{\r?\n([ \t])}{$1}g; # unfold lines
603             $v =~s{[ \t]+}{ }g; # WSP+ -> SP
604             $v =~s{\s+\z}{\r\n}; # eliminate all WS from end, normalize line end
605             $k = lc($k||''); # lower case key
606             $k=~s{[ \t]*:[ \t]*}{:}; # remove white-space around colon
607             return $k.$v;
608             };
609              
610             my %hdrc = (
611             simple => $simple_hdrc,
612             relaxed => $relaxed_hdrc,
613             );
614              
615 2     2   1104 use Digest::SHA;
  2         6157  
  2         4495  
616             my %digest = (
617             sha1 => sub { Digest::SHA->new(1) },
618             sha256 => sub { Digest::SHA->new(256) },
619             );
620              
621             # compute the hash over the header
622             sub _compute_hdrhash {
623 43     43   111 my ($hdr,$headers,$hash,$canon,$dkh) = @_;
624             #warn "XXX $hash | $canon";
625 43         104 $hash = $digest{$hash}();
626 43         572 $canon = $hdrc{$canon};
627 43         64 my @hdr;
628             my %kv;
629 43         91 for my $k (@$headers) {
630 445 50       787 if ($k eq 'dkim-signature') {
631 0         0 for($hdr =~m{^($k:[^\n]*\n(?:[ \t][^\n]*\n)*)}mig) {
632 0 0       0 $_ eq $dkh and next;
633 0         0 push @hdr,$_;
634             }
635             } else {
636 445   100     6936 my $v = $kv{$k} ||=
637             [ $hdr =~m{^($k:[^\n]*\n(?:[ \t][^\n]*\n)*)}mig ];
638             # take last matching kv in mail header
639 445   100     1683 push @hdr, pop(@$v) // '';
640             }
641             }
642 43         218 $dkh =~s{([ \t;:]b=)([a-zA-Z0-9/+= \t\r\n]+)}{$1};
643 43         181 $dkh =~s{[\r\n]+\z}{};
644 43         85 push @hdr,$dkh;
645 43         120 $_ = $canon->($_) for (@hdr);
646             #warn Dumper(\@hdr); use Data::Dumper;
647 43         323 $hash->add(@hdr);
648 43         435 return $hash->digest;
649             }
650              
651             # simple body canonicalization:
652             # - normalize to \r\n line end
653             # - remove all empty lines at the end
654             # - make sure that body consists at least of a single empty line
655             # relaxed body canonicalization:
656             # - like simple, but additionally...
657             # - remove any white-space at the end of a line (excluding \r\n)
658             # - compact any white-space inside the line to a single space
659              
660             my $bodyc = sub {
661             my $relaxed = shift;
662             my $empty = my $no_line_yet = '';
663             my $realdata;
664             sub {
665             my $data = shift;
666             if ($data eq '') {
667             return $no_line_yet if $realdata;
668             return "\r\n";
669             }
670             my $nl = rindex($data,"\n");
671             if ($nl == -1) {
672             $no_line_yet .= $data;
673             return '';
674             }
675              
676             if ($nl == length($data)-1) {
677             # newline at end of data
678             $data = $no_line_yet . $data if $no_line_yet ne '';
679             $no_line_yet = '';
680             } else {
681             # newline somewhere inside
682             $no_line_yet .= substr($data,0,$nl+1,'');
683             ($data,$no_line_yet) = ($no_line_yet,$data);
684             }
685              
686             $data =~s{(?
687             if ($relaxed) {
688             $data =~s{[ \t]+}{ }g; # compact WSP+ to SP
689             $data =~s{ \r\n}{\r\n}g; # remove WSP+ at eol
690             }
691              
692             if ($data =~m{(^|\n)(?:\r\n)+\z}) {
693             if (!$+[1]) {
694             # everything empty
695             $empty .= $data;
696             return '';
697             } else {
698             # part empty
699             $empty .= substr($data,0,$+[1],'');
700             ($empty,$data) = ($data,$empty);
701             }
702             } else {
703             # nothing empty
704             if ($empty ne '') {
705             $data = $empty . $data;
706             $empty = '';
707             }
708             }
709             $realdata = 1;
710             return $data;
711             };
712             };
713              
714             my %bodyc = (
715             simple => sub { $bodyc->(0) },
716             relaxed => sub { $bodyc->(1) },
717             );
718              
719             # add data to the body
720             sub _append_body {
721 85     85   195 my ($self,$buf) = @_;
722 85         117 for my $sig (@{$self->{sig}}) {
  85         176  
723 85 50       170 $sig->{'bh:computed'} and next;
724 85   66     204 my $bh = $sig->{'bh:collecting'} ||= do {
725 44 100 66     167 if (!$sig->{error} and
      66        
726             my $digest = $digest{$sig->{'a:hash'}}() and
727             my $transform = $bodyc{$sig->{'c:body'}}()
728             ) {
729             {
730             digest => $digest,
731             transform => $transform,
732             $sig->{l} ? (l => $sig->{l}) :
733 43 100       224 defined($sig->{l}) ? (l => \$sig->{l}) : # capture l
    100          
734             (),
735             };
736             } else {
737 1         5 { done => 1 };
738             }
739             };
740              
741 85 100       174 $bh->{done} and next;
742 84 100       187 if ($buf eq '') {
743 41         65 $bh->{done} = 1;
744 41         160 goto compute_signature;
745             }
746 43         86 my $tbuf = $bh->{transform}($buf);
747 43 50       86 $tbuf eq '' and next;
748             {
749 43 100       82 defined $bh->{l} or last;
  43         106  
750 2 100       8 if (ref $bh->{l}) {
751 1         3 ${$bh->{l}} += length($tbuf);
  1         6  
752 1         2 next;
753             }
754 1 50       5 if ($bh->{l} > 0) {
755 1 50       5 last if ($bh->{l} -= length($tbuf))>0;
756             $bh->{_data_after_l} ||=
757 1   33     13 substr($tbuf,$bh->{l},-$bh->{l},'') =~m{\S} & 1;
758 1         2 $bh->{l} = 0;
759             } else {
760 0   0     0 $bh->{_data_after_l} ||= $tbuf =~m{\S} & 1;
761 0         0 $tbuf = '';
762             }
763 1         2 $bh->{done} = 1;
764             }
765 43 50       197 $bh->{digest}->add($tbuf) if $tbuf ne '';
766 43 100       131 $bh->{done} or next;
767              
768             compute_signature:
769 42         77 delete $sig->{'bh:collecting'};
770 42         268 $sig->{'bh:computed'} = $bh->{digest}->digest;
771 1         13 push @{$sig->{':warning'}}, 'data after signed body'
772 42 100       512 if $bh->{_data_after_l};
773             }
774             }
775             }
776              
777             {
778              
779             # parse_taglist($val,\$error)
780             # Parse a tag-list, like in the DKIM signature and in the DKIM key.
781             # Returns a hash of the parsed list. If error occur $error will be set and
782             # undef will be returned.
783              
784             my $fws = qr{
785             [ \t]+ (?:\r?\n[ \t]+)? |
786             \r?\n[ \t]+
787             }x;
788             my $tagname = qr{[a-z]\w*}i;
789             my $tval = qr{[\x21-\x3a\x3c-\x7e]+};
790             my $tagval = qr{$tval(?:$fws$tval)*};
791             my $end = qr{(?:\r?\n)?\z};
792             my $delim_or_end = qr{ $fws? (?: $end | ; (?: $fws?$end|)) }x;
793              
794             sub parse_taglist {
795 40     40 1 74 my ($v,$error) = @_;
796 40         48 my %v;
797 40         674 while ( $v =~m{\G $fws? (?:
798             ($tagname) $fws?=$fws? ($tagval?) $delim_or_end |
799             | (.+)
800             )}xgcs) {
801 295 50       698 if (defined $3) {
802 0         0 $$error = "invalid data at end: '$3'";
803 0         0 return;
804             }
805 295 100       544 last if ! defined $1;
806 255 50       499 exists($v{$1}) && do {
807 0         0 $$error = "duplicate key $1";
808 0         0 return;
809             };
810 255         2736 $v{$1} = $2;
811             }
812             #warn Dumper(\%v); use Data::Dumper;
813 40         146 return \%v;
814             }
815             }
816              
817             sub _encode64 {
818 44     44   114 my $data = shift;
819 44         113 my $pad = ( 3 - length($data) % 3 ) % 3;
820 44         172 $data = pack('u',$data);
821 44         796 $data =~s{(^.|\n)}{}mg;
822 44         110 $data =~tr{` -_}{AA-Za-z0-9+/};
823 44 50       150 substr($data,-$pad) = '=' x $pad if $pad;
824 44         113 return $data;
825             }
826              
827             sub _decode64 {
828 42     42   84 my $data = shift;
829 42         165 $data =~s{\s+}{}g;
830 42         149 $data =~s{=+$}{};
831 42         85 $data =~tr{A-Za-z0-9+/}{`!-_};
832 42         137 $data =~s{(.{1,60})}{ chr(32 + length($1)*3/4) . $1 . "\n" }eg;
  82         430  
833 42         340 return unpack("u",$data);
834             }
835              
836             sub _encodeQP {
837 22     22   59 (my $data = shift)
838 0         0 =~s{([^\x21-\x3a\x3c\x3e-\x7e])}{ sprintf('=%02X',ord($1)) }esg;
839 22         53 return $data;
840             }
841              
842             sub _decodeQP {
843 0     0   0 my $data = shift;
844 0         0 $data =~s{\s+}{}g;
845 0         0 $data =~s{=([0-9A-F][0-9A-F])}{ chr(hex($1)) }esg;
  0         0  
846 0         0 return $data;
847             }
848              
849              
850             # ResultRecord for verification.
851             package Mail::DKIM::Iterator::VerifyRecord;
852             sub new {
853 98     98   154 my $class = shift;
854 98         286 bless [@_],$class;
855             }
856 38     38   69 sub sig { shift->[0] }
857 0     0   0 sub domain { shift->[0]{d} }
858 38     38   63 sub dnsname { shift->[1] }
859 90     90   371 sub status { shift->[2] }
860 8 50   8   37 sub error { $_[0]->[2] >0 ? undef : $_[0]->[3] }
861 16 50   16   108 sub warning { $_[0]->[2] >0 ? $_[0]->[3] : undef }
862              
863             sub authentication_results {
864 0     0   0 my $self = shift;
865 0 0       0 return if ! $self->[2];
866 0         0 my $ar = "dkim=$self->[2]";
867 0 0 0     0 $ar .= " ($self->[3])" if defined $self->[3] and $self->[3] ne '';
868 0   0     0 $ar .= " header.d=".( $self->[0]{d} // 'unknown');
869 0         0 return $ar;
870             }
871              
872             # ResultRecord for signing.
873             package Mail::DKIM::Iterator::SignRecord;
874             sub new {
875 66     66   108 my $class = shift;
876 66         253 bless [@_],$class;
877             }
878 22     22   61 sub sig { shift->[0] }
879 0     0   0 sub domain { shift->[0]{d} }
880             sub dnsname {
881 0     0   0 my $sig = shift->[0];
882 0   0     0 return ($sig->{s} || 'UNKNOWN').'_domainkey'.($sig->{d} || 'UNKNOWN');
      0        
883             }
884 22     22   96 sub signature { shift->[1] }
885 66     66   369 sub status { shift->[2] }
886 0     0     sub error { shift->[3] }
887              
888             1;
889              
890             __END__