File Coverage

blib/lib/Mail/DKIM/ARC/Verifier.pm
Criterion Covered Total %
statement 269 303 88.7
branch 102 134 76.1
condition 48 71 67.6
subroutine 16 17 94.1
pod 2 9 22.2
total 437 534 81.8


line stmt bran cond sub pod time code
1             package Mail::DKIM::ARC::Verifier;
2 2     2   1151 use strict;
  2         7  
  2         61  
3 2     2   10 use warnings;
  2         5  
  2         100  
4             our $VERSION = '1.20230212'; # VERSION
5             # ABSTRACT: verifies an ARC-Sealed message
6              
7             # Copyright 2017 FastMail Pty Ltd. All Rights Reserved.
8             # Bron Gondwana
9              
10             # This program is free software; you can redistribute it and/or
11             # modify it under the same terms as Perl itself.
12              
13              
14              
15 2     2   15 use base 'Mail::DKIM::Common';
  2         3  
  2         199  
16 2     2   15 use Mail::DKIM::ARC::MessageSignature;
  2         4  
  2         52  
17 2     2   11 use Mail::DKIM::ARC::Seal;
  2         5  
  2         50  
18 2     2   12 use Mail::Address;
  2         4  
  2         40  
19 2     2   19 use Carp;
  2         4  
  2         5818  
20             our $MAX_SIGNATURES_TO_PROCESS = 50;
21              
22             sub init {
23 168     168 0 258 my $self = shift;
24 168         551 $self->SUPER::init;
25 168         352 $self->{signatures} = [];
26 168         496 $self->{result} = undef; # we're done once this is set
27             }
28              
29             # @{$arc->{signatures}}
30             # array of L objects, representing all
31             # parseable message signatures and seals found in the header,
32             # ordered from the top of the header to the bottom.
33             #
34             # $arc->{signature_reject_reason}
35             # simple string listing a reason, if any, for not using a signature.
36             # This may be a helpful diagnostic if there is a signature in the header,
37             # but was found not to be valid. It will be ambiguous if there are more
38             # than one signatures that could not be used.
39             #
40             # @{$arc->{headers}}
41             # array of strings, each member is one header, in its original format.
42             #
43             # $arc->{algorithms}
44             # array of algorithms, one for each signature being verified.
45             #
46             # $arc->{result}
47             # string; the result of the verification (see the result() method)
48             #
49              
50             sub handle_header {
51 2408     2408 0 3511 my $self = shift;
52 2408         4382 my ( $field_name, $contents, $line ) = @_;
53              
54 2408         5809 $self->SUPER::handle_header( $field_name, $contents );
55              
56 2408 100       5085 if ( lc($field_name) eq 'arc-message-signature' ) {
57             eval {
58 189         560 local $SIG{__DIE__};
59 189         607 my $signature = Mail::DKIM::ARC::MessageSignature->parse($line);
60 188         633 $self->add_signature($signature);
61 187         845 1
62 189 100       311 } || do {
63              
64             # the only reason an error should be thrown is if the
65             # signature really is unparse-able
66              
67             # otherwise, invalid signatures are caught in finish_header()
68              
69 2         9 chomp( my $E = $@ );
70 2         6 $self->{signature_reject_reason} = $E;
71             };
72             }
73              
74 2408 100       5867 if ( lc($field_name) eq 'arc-seal' ) {
75             eval {
76 188         624 local $SIG{__DIE__};
77 188         644 my $signature = Mail::DKIM::ARC::Seal->parse($line);
78 188         606 $self->add_signature($signature);
79 187         1147 1
80 188 100       338 } || do {
81              
82             # the only reason an error should be thrown is if the
83             # signature really is unparse-able
84              
85             # otherwise, invalid signatures are caught in finish_header()
86              
87 1         14 chomp( my $E = $@ );
88 1         6 $self->{signature_reject_reason} = $E;
89             };
90             }
91              
92             }
93              
94             sub add_signature {
95 376     376 0 683 my ( $self, $signature ) = @_;
96 376 50       845 croak 'wrong number of arguments' unless ( @_ == 2 );
97              
98 376 100       828 return if $self->{result}; # already failed
99              
100 364         496 push @{ $self->{signatures} }, $signature;
  364         729  
101              
102 364 100       765 unless ( $self->check_signature($signature) ) {
103 14         59 $signature->result( 'invalid', $self->{signature_reject_reason} );
104 14         26 return;
105             }
106              
107             # signature looks ok, go ahead and query for the public key
108 350         1006 $signature->fetch_public_key;
109              
110             # create a canonicalization filter and algorithm
111 348         830 my $algorithm_class =
112             $signature->get_algorithm_class( $signature->algorithm );
113             my $algorithm = $algorithm_class->new(
114             Signature => $signature,
115             Debug_Canonicalization => $signature->isa('Mail::DKIM::ARC::Seal')
116             ? $self->{AS_Canonicalization}
117             : $self->{AMS_Canonicalization},
118 348 100       2591 );
119              
120             # push through the headers parsed prior to the signature header
121 348 50       1208 if ( $algorithm->wants_pre_signature_headers ) {
122              
123             # Note: this will include the signature header that led to this
124             # "algorithm"...
125 348         589 foreach my $head ( @{ $self->{headers} } ) {
  348         872  
126 1036         2013 $algorithm->add_header($head);
127             }
128             }
129              
130             # save the algorithm
131 348   50     822 $self->{algorithms} ||= [];
132 348         543 push @{ $self->{algorithms} }, $algorithm;
  348         672  
133              
134             # check for bogus tags (should be done much earlier but better late than never)
135             # tagkeys is uniq'd via a hash, rawtaglen counts all the tags
136 348         481 my @tagkeys = keys %{ $signature->{tags_by_name} };
  348         1475  
137 348         571 my $rawtaglen = $#{ $signature->{tags} };
  348         666  
138              
139             # crock: ignore empty clause after trailing semicolon
140             $rawtaglen--
141 348 100       584 if $signature->{tags}->[ $#{ $signature->{tags} } ]->{raw} =~ /^\s*$/;
  348         1564  
142              
143             # duplicate tags
144 348 100       783 if ( $rawtaglen != $#tagkeys ) {
145 4         11 $self->{result} = 'fail'; # bogus
146 4         11 $self->{details} = 'Duplicate tag in signature';
147 4         10 return;
148             }
149              
150             # invalid tag name
151 344 100       682 if ( grep { !m{[a-z][a-z0-9_]*}i } @tagkeys ) {
  2735         6780  
152 2         7 $self->{result} = 'fail'; # bogus
153 2         6 $self->{details} = 'Invalid tag in signature';
154 2         5 return;
155             }
156              
157 342 100       1558 if ( $signature->isa('Mail::DKIM::ARC::Seal') ) {
    50          
158 176         234 my ($instance);
159 176   100     477 $instance = $signature->instance() || '';
160              
161 176 50 66     1230 if ( $instance !~ m{^\d+$} or $instance < 1 or $instance > 1024 ) {
      66        
162 5         12 $self->{result} = 'fail'; # bogus
163 5         25 $self->{details} = sprintf "Invalid ARC-Seal instance '%s'",
164             $instance;
165 5         15 return;
166             }
167              
168 171 100       476 if ( $self->{seals}[$instance] ) {
169 3         8 $self->{result} = 'fail'; # dup
170 3 50       14 if ( $signature eq $self->{seals}[$instance] ) {
171 0         0 $self->{details} = sprintf 'Duplicate ARC-Seal %d', $instance;
172             }
173             else {
174 3         29 $self->{details} = sprintf 'Redundant ARC-Seal %d', $instance;
175             }
176 3         14 return;
177             }
178              
179 168         514 $self->{seals}[$instance] = $signature;
180             }
181             elsif ( $signature->isa('Mail::DKIM::ARC::MessageSignature') ) {
182 166   100     537 my $instance = $signature->instance() || '';
183              
184 166 50 66     1177 if ( $instance !~ m{^\d+$} or $instance < 1 or $instance > 1024 ) {
      66        
185 4         18 $self->{result} = 'fail'; # bogus
186             $self->{details} =
187 4         19 sprintf "Invalid ARC-Message-Signature instance '%s'", $instance;
188 4         13 return;
189             }
190              
191 162 100       526 if ( $self->{messages}[$instance] ) {
192 3         10 $self->{result} = 'fail'; # dup
193 3 50       10 if ( $signature->as_string() eq
194             $self->{messages}[$instance]->as_string() )
195             {
196 0         0 $self->{details} = sprintf 'Duplicate ARC-Message-Signature %d',
197             $instance;
198             }
199             else {
200 3         17 $self->{details} = sprintf 'Redundant ARC-Message-Signature %d',
201             $instance;
202             }
203 3         10 return;
204             }
205 159         491 $self->{messages}[$instance] = $signature;
206             }
207             }
208              
209             sub check_signature {
210 364     364 0 526 my $self = shift;
211 364 50       663 croak 'wrong number of arguments' unless ( @_ == 1 );
212 364         582 my ($signature) = @_;
213              
214 364 50       918 unless ( $signature->check_version ) {
215              
216             # unsupported version
217 0 0       0 if ( defined $signature->version ) {
218             $self->{signature_reject_reason} =
219 0         0 'unsupported version ' . $signature->version;
220             }
221             else {
222 0         0 $self->{signature_reject_reason} = 'missing v tag';
223             }
224 0         0 return 0;
225             }
226              
227 364 100 100     853 unless ( $signature->algorithm
      33        
      66        
228             && $signature->get_algorithm_class( $signature->algorithm )
229             && ( !$self->{Strict} || $signature->algorithm ne 'rsa-sha1' )
230             ) # no more SHA1 for us in strict mode
231             {
232             # unsupported algorithm
233 6         26 $self->{signature_reject_reason} = 'unsupported algorithm';
234 6 100       19 if ( defined $signature->algorithm ) {
235 4         13 $self->{signature_reject_reason} .= ' ' . $signature->algorithm;
236             }
237 6         24 return 0;
238             }
239              
240 358 100       1042 unless ( $signature->check_canonicalization ) {
241              
242             # unsupported canonicalization method
243 1         4 $self->{signature_reject_reason} = 'unsupported canonicalization';
244 1 50       5 if ( defined $signature->canonicalization ) {
245             $self->{signature_reject_reason} .=
246 1         4 ' ' . $signature->canonicalization;
247             }
248 1         4 return 0;
249             }
250              
251 357 50       839 unless ( $signature->check_protocol ) {
252              
253             # unsupported query protocol
254             $self->{signature_reject_reason} =
255 0 0       0 !defined( $signature->protocol )
256             ? 'missing q tag'
257             : 'unsupported query protocol, q=' . $signature->protocol;
258 0         0 return 0;
259             }
260              
261 357 50       887 unless ( $signature->check_expiration ) {
262              
263             # signature has expired
264 0         0 $self->{signature_reject_reason} = 'signature is expired';
265 0         0 return 0;
266             }
267              
268 357 100       749 unless ( defined $signature->domain ) {
269              
270             # no domain specified
271 2         13 $self->{signature_reject_reason} = 'missing d tag';
272 2         6 return 0;
273             }
274              
275 355 100       811 if ( $signature->domain eq '' ) {
276              
277             # blank domain
278 2         20 $self->{signature_reject_reason} = 'invalid domain in d tag';
279 2         10 return 0;
280             }
281              
282 353 100       810 unless ( defined $signature->selector ) {
283              
284             # no selector specified
285 3         10 $self->{signature_reject_reason} = 'missing s tag';
286 3         9 return 0;
287             }
288              
289 350         900 return 1;
290             }
291              
292             sub check_public_key {
293 295     295 0 477 my $self = shift;
294 295 50       641 croak 'wrong number of arguments' unless ( @_ == 2 );
295 295         548 my ( $signature, $public_key ) = @_;
296              
297 295         455 my $result = 0;
298             eval {
299 295         1035 local $SIG{__DIE__};
300 295         472 $@ = undef;
301              
302             # HACK- I'm indecisive here about whether I want the
303             # check_foo functions to return false or to "die"
304             # on failure
305              
306             # check public key's allowed hash algorithms
307 295         782 $result =
308             $public_key->check_hash_algorithm( $signature->hash_algorithm );
309              
310             # HACK- DomainKeys signatures are allowed to have an empty g=
311             # tag in the public key
312             # my $empty_g_means_wildcard = $signature->isa('Mail::DKIM::DkSignature');
313              
314             # check public key's granularity
315 295   33     1160 $result &&= $public_key->check_granularity( $signature->domain, 0 );
316              
317             # $signature->instance, $empty_g_means_wildcard);
318              
319 295 50       615 die $@ if $@;
320 295         1042 1
321 295 50       447 } || do {
322 0         0 my $E = $@;
323 0         0 chomp $E;
324 0         0 $self->{signature_reject_reason} = "public key: $E";
325             };
326 295         744 return $result;
327             }
328              
329             #
330             # called when the verifier has received the last of the message headers
331             # (body is still to come)
332             #
333             sub finish_header {
334 168     168 0 280 my $self = shift;
335              
336             # Signatures we found and were successfully parsed are stored in
337             # $self->{signatures}. If none were found, our result is "none".
338              
339 168 100 66     304 if ( @{ $self->{signatures} } == 0
  168         570  
340             && !defined( $self->{signature_reject_reason} ) )
341             {
342 5         50 $self->{result} = 'none';
343 5         12 return;
344             }
345              
346             # check for duplicate AAR headers (dup AS and AMS checked in add_signature)
347 163         409 my @aars = [];
348 163         244 foreach my $hdr ( @{ $self->{headers} } ) {
  163         345  
349 2366 100       6750 if ( my ($i) = $hdr =~ m{ARC-Authentication-Results:\s*i=(\d+)\s*;}i ) {
350 180 100       496 if ( defined $aars[$i] ) {
351 2         9 $self->{result} = 'fail';
352             $self->{details} =
353 2         10 "Duplicate ARC-Authentication-Results header $1";
354 2         6 return;
355             }
356 178         404 $aars[$i] = $hdr;
357             }
358             }
359              
360 161         244 foreach my $algorithm ( @{ $self->{algorithms} } ) {
  161         302  
361             $algorithm->finish_header(
362             Headers => $self->{headers},
363 344         1080 Chain => 'pass'
364             );
365             }
366              
367             # stop processing signatures that are already known to be invalid
368 161         405 @{ $self->{algorithms} } = grep {
369 344         825 my $sig = $_->signature;
370 344   33     799 !( $sig->result && $sig->result eq 'invalid' );
371 161         326 } @{ $self->{algorithms} };
  161         446  
372              
373 161 50 33     284 if ( @{ $self->{algorithms} } == 0
  161         617  
374 0         0 && @{ $self->{signatures} } > 0 )
375             {
376 0   0     0 $self->{result} = $self->{signatures}->[0]->result || 'invalid';
377             $self->{details} = $self->{signatures}->[0]->{verify_details}
378 0   0     0 || $self->{signature_reject_reason};
379 0         0 return;
380             }
381             }
382              
383             sub _check_and_verify_signature {
384 306     306   491 my $self = shift;
385 306         512 my ($algorithm) = @_;
386              
387             # check signature
388 306         687 my $signature = $algorithm->signature;
389              
390 306 50       764 if ( not $signature->get_tag('d') ) { # All sigs must have a D tag
391 0         0 $self->{signature_reject_reason} = 'missing D tag';
392 0         0 return ( 'fail', $self->{signature_reject_reason} );
393             }
394              
395 306 100       703 if ( not $signature->get_tag('b') ) { # All sigs must have a B tag
396 4         28 $self->{signature_reject_reason} = 'missing B tag';
397 4         15 return ( 'fail', $self->{signature_reject_reason} );
398             }
399              
400 302 100       1289 if ( not $signature->isa('Mail::DKIM::ARC::Seal') ) { # AMS tests
401 151 100       342 unless ( $signature->get_tag('bh') ) { # AMS must have a BH tag
402 2         7 $self->{signature_reject_reason} = 'missing BH tag';
403 2         8 return ( 'fail', $self->{signature_reject_reason} );
404             }
405 149 100 100     371 if ( ( $signature->get_tag('h') || '' ) =~ /arc-seal/i )
406             { # cannot cover AS
407             $self->{signature_reject_reason} =
408 1         6 'Arc-Message-Signature covers Arc-Seal';
409 1         5 return ( 'fail', $self->{signature_reject_reason} );
410             }
411             }
412              
413             # AMS signature must not
414              
415             # get public key
416 299         449 my $pkey;
417             eval {
418 299         1023 local $SIG{__DIE__};
419 299         752 $pkey = $signature->get_public_key;
420 295         1176 1
421 299 100       522 } || do {
422 4         13 my $E = $@;
423 4         13 chomp $E;
424 4         16 $self->{signature_reject_reason} = "public key: $E";
425 4         17 return ( 'invalid', $self->{signature_reject_reason} );
426             };
427              
428 295 50       807 unless ( $self->check_public_key( $signature, $pkey ) ) {
429 0         0 return ( 'invalid', $self->{signature_reject_reason} );
430             }
431              
432             # make sure key is big enough
433 295         827 my $keysize = $pkey->cork->size * 8; # in bits
434 295 50 66     731 if ( $keysize < 1024 && $self->{Strict} ) {
435 2         9 $self->{signature_reject_reason} = "Key length $keysize too short";
436 2         7 return ( 'fail', $self->{signature_reject_reason} );
437             }
438              
439             # verify signature
440 293         461 my $result;
441             my $details;
442 293         461 local $@ = undef;
443             eval {
444 293         803 local $SIG{__DIE__};
445 293 100       972 $result = $algorithm->verify() ? 'pass' : 'fail';
446 287   100     990 $details = $algorithm->{verification_details} || $@;
447 287         1134 1
448 293 100       515 } || do {
449              
450             # see also add_signature
451 6         33 chomp( my $E = $@ );
452 6 50       59 if ( $E =~ /(OpenSSL error: .*?) at / ) {
    0          
453 6         23 $E = $1;
454             }
455             elsif ( $E =~ /^(panic:.*?) at / ) {
456 0         0 $E = "OpenSSL $1";
457             }
458 6         12 $result = 'fail';
459 6         14 $details = $E;
460             };
461 293         1051 return ( $result, $details );
462             }
463              
464             sub finish_body {
465 168     168 0 259 my $self = shift;
466              
467 168 100       381 return if $self->{result}; # already failed
468              
469 140         210 foreach my $algorithm ( @{ $self->{algorithms} } ) {
  140         309  
470              
471             # finish canonicalizing
472 306         839 $algorithm->finish_body;
473              
474 306         822 my ( $result, $details ) =
475             $self->_check_and_verify_signature($algorithm);
476              
477             # save the results of this signature verification
478 306         768 $algorithm->{result} = $result;
479 306         672 $algorithm->{details} = $details;
480 306   66     943 $self->{signature} ||= $algorithm->signature; # something if we fail
481 306         697 $algorithm->signature->result( $result, $details );
482             }
483              
484 140   100     435 my $seals = $self->{seals} || [];
485 140   100     387 my $messages = $self->{messages} || [];
486 140 50 66     372 unless ( @$seals or @$messages ) {
487 0         0 $self->{result} = 'none';
488 0         0 $self->{details} = 'no ARC headers found';
489 0         0 return;
490             }
491              
492             # determine if it's valid:
493             # 5.1.1.5. Determining the 'cv' Tag Value for ARC-Seal
494              
495             # In order for a series of ARC sets to be considered valid, the
496             # following statements MUST be satisfied:
497              
498             # 1. The chain of ARC sets must have structural integrity (no sets or
499             # set component header fields missing, no duplicates, excessive
500             # hops (cf. Section 5.1.1.1.1), etc.);
501              
502 140 50       312 if ( $#$seals == 0 ) {
503 0         0 $self->{result} = 'fail';
504 0         0 $self->{details} = 'missing ARC-Seal 1';
505 0         0 return;
506             }
507 140 50       341 if ( $#$messages == 0 ) {
508 0         0 $self->{result} = 'fail';
509 0         0 $self->{details} = 'missing ARC-Message-Signature 1';
510 0         0 return;
511             }
512              
513 140 100       304 if ( $#$messages > $#$seals ) {
514 11         27 $self->{result} = 'fail';
515 11         37 $self->{details} = 'missing Arc-Seal ' . $#$messages;
516 11         35 return;
517             }
518              
519 129         397 foreach my $i ( 1 .. $#$seals ) {
520              
521             # XXX - we should error if it's already present, but that's done above if at all
522 152 100       371 if ( !$seals->[$i] ) {
523 1         3 $self->{result} = 'fail';
524 1         4 $self->{details} = "missing ARC-Seal $i";
525 1         4 return;
526             }
527 151 100       362 if ( !$messages->[$i] ) {
528 12         30 $self->{result} = 'fail';
529 12         39 $self->{details} = "missing ARC-Message-Signature $i";
530 12         36 return;
531             }
532             }
533              
534             # 2. All ARC-Seal header fields MUST validate;
535 116         250 foreach my $i ( 1 .. $#$seals ) {
536 137         346 my $result = $seals->[$i]->result();
537 137 100       442 if ( $result ne 'pass' ) {
538 38         124 $self->{signature} = $seals->[$i]->signature;
539 38         118 $self->{result} = $result;
540 38         116 $self->{details} = $seals->[$i]->result_detail();
541 38         121 return;
542             }
543             }
544              
545             # 3. All ARC-Seal header fields MUST have a chain value (cv=) status
546             # of "pass" (except the first which MUST be "none"); and
547 78         254 my $cv = $seals->[1]->get_tag('cv');
548 78 100 100     333 if ( !defined $cv or $cv ne 'none' ) {
549 7         23 $self->{signature} = $seals->[1]->signature;
550 7         26 $self->{result} = 'fail';
551 7         17 $self->{details} = 'first ARC-Seal must be cv=none';
552 7         17 return;
553             }
554 71         224 foreach my $i ( 2 .. $#$seals ) {
555 16         55 my $cv = $seals->[$i]->get_tag('cv');
556 16 100       54 if ( $cv ne 'pass' ) {
557 2         10 $self->{signature} = $seals->[$i]->signature;
558 2         5 $self->{result} = 'fail';
559 2         10 $self->{details} = "wrong cv for ARC-Seal i=$i";
560 2         7 return;
561             }
562             }
563              
564             # 4. The newest (highest instance number (i=)) AMS header field MUST
565             # validate.
566 69         205 my $result = $messages->[$#$seals]->result();
567 69 100       198 if ( $result ne 'pass' ) {
568 16         55 $self->{signature} = $messages->[$#$seals]->signature;
569 16         39 $self->{result} = $result;
570 16         51 $self->{details} = $messages->[$#$seals]->result_detail();
571 16         43 return;
572             }
573              
574             # Success!
575 53         190 $self->{signature} = $seals->[$#$seals]->signature();
576 53         143 $self->{result} = 'pass';
577 53         179 $self->{details} = $seals->[$#$seals]->result_detail();
578             }
579              
580             sub result_detail {
581 168     168 1 559 my $self = shift;
582              
583 168 100       368 return 'none' if $self->{result} eq 'none';
584              
585 163         264 my @items;
586 163         242 foreach my $signature ( @{ $self->{signatures} } ) {
  163         393  
587 364 50       967 my $type =
    100          
588             ref($signature) eq 'Mail::DKIM::ARC::Seal' ? 'as'
589             : ref($signature) eq 'Mail::DKIM::ARC::MessageSignature' ? 'ams'
590             : ref($signature);
591 364   100     1012 push @items,
      100        
      100        
592             "$type."
593             . ( $signature->instance() || '' ) . '.'
594             . ( $signature->domain() || '(none)' ) . '='
595             . ( $signature->result_detail() || '?' );
596             }
597              
598 163         752 return $self->{result} . ' (' . join( ', ', @items ) . ')';
599             }
600              
601              
602              
603             sub signatures {
604 0     0 1   my $self = shift;
605 0 0         croak 'unexpected argument' if @_;
606              
607 0           return @{ $self->{signatures} };
  0            
608             }
609              
610             1;
611              
612             __END__