← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:15 2021

Filename/usr/local/lib/perl5/site_perl/Mail/DKIM/ARC/Verifier.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sMail::DKIM::ARC::Verifier::::BEGIN@15Mail::DKIM::ARC::Verifier::BEGIN@15
0000s0sMail::DKIM::ARC::Verifier::::BEGIN@16Mail::DKIM::ARC::Verifier::BEGIN@16
0000s0sMail::DKIM::ARC::Verifier::::BEGIN@17Mail::DKIM::ARC::Verifier::BEGIN@17
0000s0sMail::DKIM::ARC::Verifier::::BEGIN@18Mail::DKIM::ARC::Verifier::BEGIN@18
0000s0sMail::DKIM::ARC::Verifier::::BEGIN@19Mail::DKIM::ARC::Verifier::BEGIN@19
0000s0sMail::DKIM::ARC::Verifier::::BEGIN@2Mail::DKIM::ARC::Verifier::BEGIN@2
0000s0sMail::DKIM::ARC::Verifier::::BEGIN@3Mail::DKIM::ARC::Verifier::BEGIN@3
0000s0sMail::DKIM::ARC::Verifier::::__ANON__Mail::DKIM::ARC::Verifier::__ANON__ (xsub)
0000s0sMail::DKIM::ARC::Verifier::::_check_and_verify_signatureMail::DKIM::ARC::Verifier::_check_and_verify_signature
0000s0sMail::DKIM::ARC::Verifier::::add_signatureMail::DKIM::ARC::Verifier::add_signature
0000s0sMail::DKIM::ARC::Verifier::::check_public_keyMail::DKIM::ARC::Verifier::check_public_key
0000s0sMail::DKIM::ARC::Verifier::::check_signatureMail::DKIM::ARC::Verifier::check_signature
0000s0sMail::DKIM::ARC::Verifier::::finish_bodyMail::DKIM::ARC::Verifier::finish_body
0000s0sMail::DKIM::ARC::Verifier::::finish_headerMail::DKIM::ARC::Verifier::finish_header
0000s0sMail::DKIM::ARC::Verifier::::handle_headerMail::DKIM::ARC::Verifier::handle_header
0000s0sMail::DKIM::ARC::Verifier::::initMail::DKIM::ARC::Verifier::init
0000s0sMail::DKIM::ARC::Verifier::::result_detailMail::DKIM::ARC::Verifier::result_detail
0000s0sMail::DKIM::ARC::Verifier::::signaturesMail::DKIM::ARC::Verifier::signatures
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package Mail::DKIM::ARC::Verifier;
2use strict;
3use warnings;
4our $VERSION = '1.20200907'; # VERSION
5# ABSTRACT: verifies an ARC-Sealed message
6
7# Copyright 2017 FastMail Pty Ltd. All Rights Reserved.
8# Bron Gondwana <brong@fastmailteam.com>
9
10# This program is free software; you can redistribute it and/or
11# modify it under the same terms as Perl itself.
12
- -
15use base 'Mail::DKIM::Common';
16use Mail::DKIM::ARC::MessageSignature;
17use Mail::DKIM::ARC::Seal;
18use Mail::Address;
19use Carp;
20our $MAX_SIGNATURES_TO_PROCESS = 50;
21
22sub init {
23 my $self = shift;
24 $self->SUPER::init;
25 $self->{signatures} = [];
26 $self->{result} = undef; # we're done once this is set
27}
28
29# @{$arc->{signatures}}
30# array of L<Mail::DKIM::ARC::{Signature|Seal}> 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
50sub handle_header {
51 my $self = shift;
52 my ( $field_name, $contents, $line ) = @_;
53
54 $self->SUPER::handle_header( $field_name, $contents );
55
56 if ( lc($field_name) eq 'arc-message-signature' ) {
57 eval {
58 local $SIG{__DIE__};
59 my $signature = Mail::DKIM::ARC::MessageSignature->parse($line);
60 $self->add_signature($signature);
61 1
62 } || 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 chomp( my $E = $@ );
70 $self->{signature_reject_reason} = $E;
71 };
72 }
73
74 if ( lc($field_name) eq 'arc-seal' ) {
75 eval {
76 local $SIG{__DIE__};
77 my $signature = Mail::DKIM::ARC::Seal->parse($line);
78 $self->add_signature($signature);
79 1
80 } || 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 chomp( my $E = $@ );
88 $self->{signature_reject_reason} = $E;
89 };
90 }
91
92}
93
94sub add_signature {
95 my ( $self, $signature ) = @_;
96 croak 'wrong number of arguments' unless ( @_ == 2 );
97
98 return if $self->{result}; # already failed
99
100 push @{ $self->{signatures} }, $signature;
101
102 unless ( $self->check_signature($signature) ) {
103 $signature->result( 'invalid', $self->{signature_reject_reason} );
104 return;
105 }
106
107 # signature looks ok, go ahead and query for the public key
108 $signature->fetch_public_key;
109
110 # create a canonicalization filter and algorithm
111 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 );
119
120 # push through the headers parsed prior to the signature header
121 if ( $algorithm->wants_pre_signature_headers ) {
122
123 # Note: this will include the signature header that led to this
124 # "algorithm"...
125 foreach my $head ( @{ $self->{headers} } ) {
126 $algorithm->add_header($head);
127 }
128 }
129
130 # save the algorithm
131 $self->{algorithms} ||= [];
132 push @{ $self->{algorithms} }, $algorithm;
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 my @tagkeys = keys %{ $signature->{tags_by_name} };
137 my $rawtaglen = $#{ $signature->{tags} };
138
139 # crock: ignore empty clause after trailing semicolon
140 $rawtaglen--
141 if $signature->{tags}->[ $#{ $signature->{tags} } ]->{raw} =~ /^\s*$/;
142
143 # duplicate tags
144 if ( $rawtaglen != $#tagkeys ) {
145 $self->{result} = 'fail'; # bogus
146 $self->{details} = 'Duplicate tag in signature';
147 return;
148 }
149
150 # invalid tag name
151 if ( grep { !m{[a-z][a-z0-9_]*}i } @tagkeys ) {
152 $self->{result} = 'fail'; # bogus
153 $self->{details} = 'Invalid tag in signature';
154 return;
155 }
156
157 if ( $signature->isa('Mail::DKIM::ARC::Seal') ) {
158 my ($instance);
159 $instance = $signature->instance() || '';
160
161 if ( $instance !~ m{^\d+$} or $instance < 1 or $instance > 1024 ) {
162 $self->{result} = 'fail'; # bogus
163 $self->{details} = sprintf "Invalid ARC-Seal instance '%s'",
164 $instance;
165 return;
166 }
167
168 if ( $self->{seals}[$instance] ) {
169 $self->{result} = 'fail'; # dup
170 if ( $signature eq $self->{seals}[$instance] ) {
171 $self->{details} = sprintf 'Duplicate ARC-Seal %d', $instance;
172 }
173 else {
174 $self->{details} = sprintf 'Redundant ARC-Seal %d', $instance;
175 }
176 return;
177 }
178
179 $self->{seals}[$instance] = $signature;
180 }
181 elsif ( $signature->isa('Mail::DKIM::ARC::MessageSignature') ) {
182 my $instance = $signature->instance() || '';
183
184 if ( $instance !~ m{^\d+$} or $instance < 1 or $instance > 1024 ) {
185 $self->{result} = 'fail'; # bogus
186 $self->{details} =
187 sprintf "Invalid ARC-Message-Signature instance '%s'", $instance;
188 return;
189 }
190
191 if ( $self->{messages}[$instance] ) {
192 $self->{result} = 'fail'; # dup
193 if ( $signature->as_string() eq
194 $self->{messages}[$instance]->as_string() )
195 {
196 $self->{details} = sprintf 'Duplicate ARC-Message-Signature %d',
197 $instance;
198 }
199 else {
200 $self->{details} = sprintf 'Redundant ARC-Message-Signature %d',
201 $instance;
202 }
203 return;
204 }
205 $self->{messages}[$instance] = $signature;
206 }
207}
208
209sub check_signature {
210 my $self = shift;
211 croak 'wrong number of arguments' unless ( @_ == 1 );
212 my ($signature) = @_;
213
214 unless ( $signature->check_version ) {
215
216 # unsupported version
217 if ( defined $signature->version ) {
218 $self->{signature_reject_reason} =
219 'unsupported version ' . $signature->version;
220 }
221 else {
222 $self->{signature_reject_reason} = 'missing v tag';
223 }
224 return 0;
225 }
226
227 unless ( $signature->algorithm
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 $self->{signature_reject_reason} = 'unsupported algorithm';
234 if ( defined $signature->algorithm ) {
235 $self->{signature_reject_reason} .= ' ' . $signature->algorithm;
236 }
237 return 0;
238 }
239
240 unless ( $signature->check_canonicalization ) {
241
242 # unsupported canonicalization method
243 $self->{signature_reject_reason} = 'unsupported canonicalization';
244 if ( defined $signature->canonicalization ) {
245 $self->{signature_reject_reason} .=
246 ' ' . $signature->canonicalization;
247 }
248 return 0;
249 }
250
251 unless ( $signature->check_protocol ) {
252
253 # unsupported query protocol
254 $self->{signature_reject_reason} =
255 !defined( $signature->protocol )
256 ? 'missing q tag'
257 : 'unsupported query protocol, q=' . $signature->protocol;
258 return 0;
259 }
260
261 unless ( $signature->check_expiration ) {
262
263 # signature has expired
264 $self->{signature_reject_reason} = 'signature is expired';
265 return 0;
266 }
267
268 unless ( defined $signature->domain ) {
269
270 # no domain specified
271 $self->{signature_reject_reason} = 'missing d tag';
272 return 0;
273 }
274
275 if ( $signature->domain eq '' ) {
276
277 # blank domain
278 $self->{signature_reject_reason} = 'invalid domain in d tag';
279 return 0;
280 }
281
282 unless ( defined $signature->selector ) {
283
284 # no selector specified
285 $self->{signature_reject_reason} = 'missing s tag';
286 return 0;
287 }
288
289 return 1;
290}
291
292sub check_public_key {
293 my $self = shift;
294 croak 'wrong number of arguments' unless ( @_ == 2 );
295 my ( $signature, $public_key ) = @_;
296
297 my $result = 0;
298 eval {
299 local $SIG{__DIE__};
300 $@ = 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 $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 $result &&= $public_key->check_granularity( $signature->domain, 0 );
316
317 # $signature->instance, $empty_g_means_wildcard);
318
319 die $@ if $@;
320 1
321 } || do {
322 my $E = $@;
323 chomp $E;
324 $self->{signature_reject_reason} = "public key: $E";
325 };
326 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#
333sub finish_header {
334 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 if ( @{ $self->{signatures} } == 0
340 && !defined( $self->{signature_reject_reason} ) )
341 {
342 $self->{result} = 'none';
343 return;
344 }
345
346 # check for duplicate AAR headers (dup AS and AMS checked in add_signature)
347 my @aars = [];
348 foreach my $hdr ( @{ $self->{headers} } ) {
349 if ( my ($i) = $hdr =~ m{ARC-Authentication-Results:\s*i=(\d+)\s*;}i ) {
350 if ( defined $aars[$i] ) {
351 $self->{result} = 'fail';
352 $self->{details} =
353 "Duplicate ARC-Authentication-Results header $1";
354 return;
355 }
356 $aars[$i] = $hdr;
357 }
358 }
359
360 foreach my $algorithm ( @{ $self->{algorithms} } ) {
361 $algorithm->finish_header(
362 Headers => $self->{headers},
363 Chain => 'pass'
364 );
365 }
366
367 # stop processing signatures that are already known to be invalid
368 @{ $self->{algorithms} } = grep {
369 my $sig = $_->signature;
370 !( $sig->result && $sig->result eq 'invalid' );
371 } @{ $self->{algorithms} };
372
373 if ( @{ $self->{algorithms} } == 0
374 && @{ $self->{signatures} } > 0 )
375 {
376 $self->{result} = $self->{signatures}->[0]->result || 'invalid';
377 $self->{details} = $self->{signatures}->[0]->{verify_details}
378 || $self->{signature_reject_reason};
379 return;
380 }
381}
382
383sub _check_and_verify_signature {
384 my $self = shift;
385 my ($algorithm) = @_;
386
387 # check signature
388 my $signature = $algorithm->signature;
389
390 if ( not $signature->get_tag('d') ) { # All sigs must have a D tag
391 $self->{signature_reject_reason} = 'missing D tag';
392 return ( 'fail', $self->{signature_reject_reason} );
393 }
394
395 if ( not $signature->get_tag('b') ) { # All sigs must have a B tag
396 $self->{signature_reject_reason} = 'missing B tag';
397 return ( 'fail', $self->{signature_reject_reason} );
398 }
399
400 if ( not $signature->isa('Mail::DKIM::ARC::Seal') ) { # AMS tests
401 unless ( $signature->get_tag('bh') ) { # AMS must have a BH tag
402 $self->{signature_reject_reason} = 'missing BH tag';
403 return ( 'fail', $self->{signature_reject_reason} );
404 }
405 if ( ( $signature->get_tag('h') || '' ) =~ /arc-seal/i )
406 { # cannot cover AS
407 $self->{signature_reject_reason} =
408 'Arc-Message-Signature covers Arc-Seal';
409 return ( 'fail', $self->{signature_reject_reason} );
410 }
411 }
412
413 # AMS signature must not
414
415 # get public key
416 my $pkey;
417 eval {
418 local $SIG{__DIE__};
419 $pkey = $signature->get_public_key;
420 1
421 } || do {
422 my $E = $@;
423 chomp $E;
424 $self->{signature_reject_reason} = "public key: $E";
425 return ( 'invalid', $self->{signature_reject_reason} );
426 };
427
428 unless ( $self->check_public_key( $signature, $pkey ) ) {
429 return ( 'invalid', $self->{signature_reject_reason} );
430 }
431
432 # make sure key is big enough
433 my $keysize = $pkey->cork->size * 8; # in bits
434 if ( $keysize < 1024 && $self->{Strict} ) {
435 $self->{signature_reject_reason} = "Key length $keysize too short";
436 return ( 'fail', $self->{signature_reject_reason} );
437 }
438
439 # verify signature
440 my $result;
441 my $details;
442 local $@ = undef;
443 eval {
444 local $SIG{__DIE__};
445 $result = $algorithm->verify() ? 'pass' : 'fail';
446 $details = $algorithm->{verification_details} || $@;
447 1
448 } || do {
449
450 # see also add_signature
451 chomp( my $E = $@ );
452 if ( $E =~ /(OpenSSL error: .*?) at / ) {
453 $E = $1;
454 }
455 elsif ( $E =~ /^(panic:.*?) at / ) {
456 $E = "OpenSSL $1";
457 }
458 $result = 'fail';
459 $details = $E;
460 };
461 return ( $result, $details );
462}
463
464sub finish_body {
465 my $self = shift;
466
467 return if $self->{result}; # already failed
468
469 foreach my $algorithm ( @{ $self->{algorithms} } ) {
470
471 # finish canonicalizing
472 $algorithm->finish_body;
473
474 my ( $result, $details ) =
475 $self->_check_and_verify_signature($algorithm);
476
477 # save the results of this signature verification
478 $algorithm->{result} = $result;
479 $algorithm->{details} = $details;
480 $self->{signature} ||= $algorithm->signature; # something if we fail
481 $algorithm->signature->result( $result, $details );
482 }
483
484 my $seals = $self->{seals} || [];
485 my $messages = $self->{messages} || [];
486 unless ( @$seals or @$messages ) {
487 $self->{result} = 'none';
488 $self->{details} = 'no ARC headers found';
489 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 if ( $#$seals == 0 ) {
503 $self->{result} = 'fail';
504 $self->{details} = 'missing ARC-Seal 1';
505 return;
506 }
507 if ( $#$messages == 0 ) {
508 $self->{result} = 'fail';
509 $self->{details} = 'missing ARC-Message-Signature 1';
510 return;
511 }
512
513 if ( $#$messages > $#$seals ) {
514 $self->{result} = 'fail';
515 $self->{details} = 'missing Arc-Seal ' . $#$messages;
516 return;
517 }
518
519 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 if ( !$seals->[$i] ) {
523 $self->{result} = 'fail';
524 $self->{details} = "missing ARC-Seal $i";
525 return;
526 }
527 if ( !$messages->[$i] ) {
528 $self->{result} = 'fail';
529 $self->{details} = "missing ARC-Message-Signature $i";
530 return;
531 }
532 }
533
534 # 2. All ARC-Seal header fields MUST validate;
535 foreach my $i ( 1 .. $#$seals ) {
536 my $result = $seals->[$i]->result();
537 if ( $result ne 'pass' ) {
538 $self->{signature} = $seals->[$i]->signature;
539 $self->{result} = $result;
540 $self->{details} = $seals->[$i]->result_detail();
541 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 my $cv = $seals->[1]->get_tag('cv');
548 if ( !defined $cv or $cv ne 'none' ) {
549 $self->{signature} = $seals->[1]->signature;
550 $self->{result} = 'fail';
551 $self->{details} = 'first ARC-Seal must be cv=none';
552 return;
553 }
554 foreach my $i ( 2 .. $#$seals ) {
555 my $cv = $seals->[$i]->get_tag('cv');
556 if ( $cv ne 'pass' ) {
557 $self->{signature} = $seals->[$i]->signature;
558 $self->{result} = 'fail';
559 $self->{details} = "wrong cv for ARC-Seal i=$i";
560 return;
561 }
562 }
563
564 # 4. The newest (highest instance number (i=)) AMS header field MUST
565 # validate.
566 my $result = $messages->[$#$seals]->result();
567 if ( $result ne 'pass' ) {
568 $self->{signature} = $messages->[$#$seals]->signature;
569 $self->{result} = $result;
570 $self->{details} = $messages->[$#$seals]->result_detail();
571 return;
572 }
573
574 # Success!
575 $self->{signature} = $seals->[$#$seals]->signature();
576 $self->{result} = 'pass';
577 $self->{details} = $seals->[$#$seals]->result_detail();
578}
579
580sub result_detail {
581 my $self = shift;
582
583 return 'none' if $self->{result} eq 'none';
584
585 my @items;
586 foreach my $signature ( @{ $self->{signatures} } ) {
587 my $type =
588 ref($signature) eq 'Mail::DKIM::ARC::Seal' ? 'as'
589 : ref($signature) eq 'Mail::DKIM::ARC::MessageSignature' ? 'ams'
590 : ref($signature);
591 push @items,
592 "$type."
593 . ( $signature->instance() || '' ) . '.'
594 . ( $signature->domain() || '(none)' ) . '='
595 . ( $signature->result_detail() || '?' );
596 }
597
598 return $self->{result} . ' (' . join( ', ', @items ) . ')';
599}
600
- -
603sub signatures {
604 my $self = shift;
605 croak 'unexpected argument' if @_;
606
607 return @{ $self->{signatures} };
608}
609
6101;
611
612__END__