← 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:14 2021

Filename/usr/local/lib/perl5/site_perl/Mail/DKIM/Verifier.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sMail::DKIM::Verifier::::BEGIN@14Mail::DKIM::Verifier::BEGIN@14
0000s0sMail::DKIM::Verifier::::BEGIN@15Mail::DKIM::Verifier::BEGIN@15
0000s0sMail::DKIM::Verifier::::BEGIN@16Mail::DKIM::Verifier::BEGIN@16
0000s0sMail::DKIM::Verifier::::BEGIN@2Mail::DKIM::Verifier::BEGIN@2
0000s0sMail::DKIM::Verifier::::BEGIN@20Mail::DKIM::Verifier::BEGIN@20
0000s0sMail::DKIM::Verifier::::BEGIN@21Mail::DKIM::Verifier::BEGIN@21
0000s0sMail::DKIM::Verifier::::BEGIN@3Mail::DKIM::Verifier::BEGIN@3
0000s0sMail::DKIM::Verifier::::BEGIN@411Mail::DKIM::Verifier::BEGIN@411
0000s0sMail::DKIM::Verifier::::BEGIN@430Mail::DKIM::Verifier::BEGIN@430
0000s0sMail::DKIM::Verifier::::BEGIN@445Mail::DKIM::Verifier::BEGIN@445
0000s0sMail::DKIM::Verifier::::__ANON__Mail::DKIM::Verifier::__ANON__ (xsub)
0000s0sMail::DKIM::Verifier::::_check_and_verify_signatureMail::DKIM::Verifier::_check_and_verify_signature
0000s0sMail::DKIM::Verifier::::add_signatureMail::DKIM::Verifier::add_signature
0000s0sMail::DKIM::Verifier::::check_public_keyMail::DKIM::Verifier::check_public_key
0000s0sMail::DKIM::Verifier::::check_signatureMail::DKIM::Verifier::check_signature
0000s0sMail::DKIM::Verifier::::check_signature_identityMail::DKIM::Verifier::check_signature_identity
0000s0sMail::DKIM::Verifier::::fetch_author_domain_policiesMail::DKIM::Verifier::fetch_author_domain_policies
0000s0sMail::DKIM::Verifier::::fetch_author_policyMail::DKIM::Verifier::fetch_author_policy
0000s0sMail::DKIM::Verifier::::fetch_sender_policyMail::DKIM::Verifier::fetch_sender_policy
0000s0sMail::DKIM::Verifier::::finish_bodyMail::DKIM::Verifier::finish_body
0000s0sMail::DKIM::Verifier::::finish_headerMail::DKIM::Verifier::finish_header
0000s0sMail::DKIM::Verifier::::handle_headerMail::DKIM::Verifier::handle_header
0000s0sMail::DKIM::Verifier::::initMail::DKIM::Verifier::init
0000s0sMail::DKIM::Verifier::::match_subdomainMail::DKIM::Verifier::match_subdomain
0000s0sMail::DKIM::Verifier::::policiesMail::DKIM::Verifier::policies
0000s0sMail::DKIM::Verifier::::signaturesMail::DKIM::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::Verifier;
2use strict;
3use warnings;
4our $VERSION = '1.20200907'; # VERSION
5# ABSTRACT: verifies a DKIM-signed message
6
7# Copyright 2005-2009 Messiah College. All rights reserved.
8# Jason Long <jlong@messiah.edu>
9
10# Copyright (c) 2004 Anthony D. Urso. All rights reserved.
11# This program is free software; you can redistribute it and/or
12# modify it under the same terms as Perl itself.
13
14use Mail::DKIM::Signature;
15use Mail::DKIM::DkSignature;
16use Mail::Address;
17
- -
20use base 'Mail::DKIM::Common';
21use Carp;
22our $MAX_SIGNATURES_TO_PROCESS = 50;
23
24sub init {
25 my $self = shift;
26 $self->SUPER::init;
27 $self->{signatures} = [];
28}
29
30# @{$dkim->{signatures}}
31# array of L<Mail::DKIM::Signature> objects, representing all
32# parseable signatures found in the header,
33# ordered from the top of the header to the bottom.
34#
35# $dkim->{signature_reject_reason}
36# simple string listing a reason, if any, for not using a signature.
37# This may be a helpful diagnostic if there is a signature in the header,
38# but was found not to be valid. It will be ambiguous if there are more
39# than one signatures that could not be used.
40#
41# $dkim->{signature}
42# the L<Mail::DKIM::Signature> selected as the "best" signature.
43#
44# @{$dkim->{headers}}
45# array of strings, each member is one header, in its original format.
46#
47# $dkim->{algorithms}
48# array of algorithms, one for each signature being verified.
49#
50# $dkim->{result}
51# string; the result of the verification (see the result() method)
52#
53
54sub handle_header {
55 my $self = shift;
56 my ( $field_name, $contents, $line ) = @_;
57
58 $self->SUPER::handle_header( $field_name, $contents );
59
60 if ( lc($field_name) eq 'dkim-signature' ) {
61 eval {
62 local $SIG{__DIE__};
63 my $signature = Mail::DKIM::Signature->parse($line);
64 $self->add_signature($signature);
65 1
66 } || do {
67
68 # the only reason an error should be thrown is if the
69 # signature really is unparse-able
70
71 # otherwise, invalid signatures are caught in finish_header()
72
73 chomp( my $E = $@ );
74 $self->{signature_reject_reason} = $E;
75 };
76 }
77
78 if ( lc($field_name) eq 'domainkey-signature' ) {
79 eval {
80 local $SIG{__DIE__};
81 my $signature = Mail::DKIM::DkSignature->parse($line);
82 $self->add_signature($signature);
83 1
84 } || do {
85
86 # the only reason an error should be thrown is if the
87 # signature really is unparse-able
88
89 # otherwise, invalid signatures are caught in finish_header()
90
91 chomp( my $E = $@ );
92 $self->{signature_reject_reason} = $E;
93 };
94 }
95}
96
97sub add_signature {
98 my $self = shift;
99 croak 'wrong number of arguments' unless ( @_ == 1 );
100 my ($signature) = @_;
101
102 # ignore signature headers once we've seen 50 or so
103 # this protects against abuse.
104 return if ( @{ $self->{signatures} } > $MAX_SIGNATURES_TO_PROCESS );
105
106 push @{ $self->{signatures} }, $signature;
107
108 unless ( $self->check_signature($signature) ) {
109 $signature->result( 'invalid', $self->{signature_reject_reason} );
110 return;
111 }
112
113 # signature looks ok, go ahead and query for the public key
114 $signature->fetch_public_key;
115
116 # create a canonicalization filter and algorithm
117 my $algorithm_class =
118 $signature->get_algorithm_class( $signature->algorithm );
119 my $algorithm = $algorithm_class->new(
120 Signature => $signature,
121 Debug_Canonicalization => $self->{Debug_Canonicalization},
122 );
123
124 # push through the headers parsed prior to the signature header
125 if ( $algorithm->wants_pre_signature_headers ) {
126
127 # Note: this will include the signature header that led to this
128 # "algorithm"...
129 foreach my $head ( @{ $self->{headers} } ) {
130 $algorithm->add_header($head);
131 }
132 }
133
134 # save the algorithm
135 $self->{algorithms} ||= [];
136 push @{ $self->{algorithms} }, $algorithm;
137}
138
139sub check_signature {
140 my $self = shift;
141 croak 'wrong number of arguments' unless ( @_ == 1 );
142 my ($signature) = @_;
143
144 unless ( $signature->check_version ) {
145
146 # unsupported version
147 if ( defined $signature->version ) {
148 $self->{signature_reject_reason} =
149 'unsupported version ' . $signature->version;
150 }
151 else {
152 $self->{signature_reject_reason} = 'missing v tag';
153 }
154 return 0;
155 }
156
157 unless ( $signature->algorithm
158 && $signature->get_algorithm_class( $signature->algorithm ) )
159 {
160 # unsupported algorithm
161 $self->{signature_reject_reason} = 'unsupported algorithm';
162 if ( defined $signature->algorithm ) {
163 $self->{signature_reject_reason} .= ' ' . $signature->algorithm;
164 }
165 return 0;
166 }
167
168 if ( $self->{Strict} ) {
169 if ( $signature->algorithm eq 'rsa-sha1' ) {
170 $self->{signature_reject_reason} = 'unsupported algorithm';
171 if ( defined $signature->algorithm ) {
172 $self->{signature_reject_reason} .= ' ' . $signature->algorithm;
173 }
174 return 0;
175 }
176 }
177
178 unless ( $signature->check_canonicalization ) {
179
180 # unsupported canonicalization method
181 $self->{signature_reject_reason} = 'unsupported canonicalization';
182 if ( defined $signature->canonicalization ) {
183 $self->{signature_reject_reason} .=
184 ' ' . $signature->canonicalization;
185 }
186 return 0;
187 }
188
189 unless ( $signature->check_protocol ) {
190
191 # unsupported query protocol
192 $self->{signature_reject_reason} =
193 !defined( $signature->protocol )
194 ? 'missing q tag'
195 : 'unsupported query protocol, q=' . $signature->protocol;
196 return 0;
197 }
198
199 unless ( $signature->check_expiration ) {
200
201 # signature has expired
202 $self->{signature_reject_reason} = 'signature is expired';
203 return 0;
204 }
205
206 unless ( defined $signature->domain ) {
207
208 # no domain specified
209 $self->{signature_reject_reason} = 'missing d tag';
210 return 0;
211 }
212
213 if ( $signature->domain eq '' ) {
214
215 # blank domain
216 $self->{signature_reject_reason} = 'invalid domain in d tag';
217 return 0;
218 }
219
220 unless ( defined $signature->selector ) {
221
222 # no selector specified
223 $self->{signature_reject_reason} = 'missing s tag';
224 return 0;
225 }
226
227 return 1;
228}
229
230sub check_public_key {
231 my $self = shift;
232 croak 'wrong number of arguments' unless ( @_ == 2 );
233 my ( $signature, $public_key ) = @_;
234
235 my $result = 0;
236 eval {
237 local $SIG{__DIE__};
238 $@ = undef;
239
240 # HACK- I'm indecisive here about whether I want the
241 # check_foo functions to return false or to "die"
242 # on failure
243
244 # check public key's allowed hash algorithms
245 $result =
246 $public_key->check_hash_algorithm( $signature->hash_algorithm );
247
248 # HACK- DomainKeys signatures are allowed to have an empty g=
249 # tag in the public key
250 my $empty_g_means_wildcard = $signature->isa('Mail::DKIM::DkSignature');
251
252 # check public key's granularity
253 $result &&=
254 $public_key->check_granularity( $signature->identity,
255 $empty_g_means_wildcard );
256
257 die $@ if $@;
258 1
259 } || do {
260 my $E = $@;
261 chomp $E;
262 $self->{signature_reject_reason} = "public key: $E";
263 };
264 return $result;
265}
266
267# returns true if the i= tag is an address with a domain matching or
268# a subdomain of the d= tag
269#
270sub check_signature_identity {
271 my ($signature) = @_;
272
273 my $d = $signature->domain;
274 my $i = $signature->identity;
275 if ( defined($i) && $i =~ /\@([^@]*)$/ ) {
276 return match_subdomain( $1, $d );
277 }
278 return 0;
279}
280
281sub match_subdomain {
282 croak 'wrong number of arguments' unless ( @_ == 2 );
283 my ( $subdomain, $superdomain ) = @_;
284
285 my $tmp = substr( ".$subdomain", -1 - length($superdomain) );
286 return ( lc ".$superdomain" eq lc $tmp );
287}
288
289#
290# called when the verifier has received the last of the message headers
291# (body is still to come)
292#
293sub finish_header {
294 my $self = shift;
295
296 # Signatures we found and were successfully parsed are stored in
297 # $self->{signatures}. If none were found, our result is "none".
298
299 if ( @{ $self->{signatures} } == 0
300 && !defined( $self->{signature_reject_reason} ) )
301 {
302 $self->{result} = 'none';
303 return;
304 }
305
306 foreach my $algorithm ( @{ $self->{algorithms} } ) {
307 $algorithm->finish_header( Headers => $self->{headers} );
308 }
309
310 # stop processing signatures that are already known to be invalid
311 @{ $self->{algorithms} } = grep {
312 my $sig = $_->signature;
313 !( $sig->result && $sig->result eq 'invalid' );
314 } @{ $self->{algorithms} };
315
316 if ( @{ $self->{algorithms} } == 0
317 && @{ $self->{signatures} } > 0 )
318 {
319 $self->{result} = $self->{signatures}->[0]->result || 'invalid';
320 $self->{details} = $self->{signatures}->[0]->{verify_details}
321 || $self->{signature_reject_reason};
322 return;
323 }
324}
325
326sub _check_and_verify_signature {
327 my $self = shift;
328 my ($algorithm) = @_;
329
330 # check signature
331 my $signature = $algorithm->signature;
332 unless ( check_signature_identity($signature) ) {
333 $self->{signature_reject_reason} = 'bad identity';
334 return ( 'invalid', $self->{signature_reject_reason} );
335 }
336
337 # get public key
338 my $pkey;
339 eval { $pkey = $signature->get_public_key; 1 }
340 || do {
341 my $E = $@;
342 chomp $E;
343 $self->{signature_reject_reason} = "public key: $E";
344 return ( 'invalid', $self->{signature_reject_reason} );
345 };
346
347 unless ( $self->check_public_key( $signature, $pkey ) ) {
348 return ( 'invalid', $self->{signature_reject_reason} );
349 }
350
351 # make sure key is big enough
352 my $keysize = $pkey->cork->size * 8; # in bits
353 if ( $keysize < 1024 && $self->{Strict} ) {
354 $self->{signature_reject_reason} = "Key length $keysize too short";
355 return ( 'fail', $self->{signature_reject_reason} );
356 }
357
358 # verify signature
359 my $result;
360 my $details;
361 local $@ = undef;
362 eval {
363 $result = $algorithm->verify() ? 'pass' : 'fail';
364 $details = $algorithm->{verification_details} || $@;
365 1
366 } || do {
367
368 # see also add_signature
369 chomp( my $E = $@ );
370 if ( $E =~ /(OpenSSL error: .*?) at / ) {
371 $E = $1;
372 }
373 elsif ( $E =~ /^(panic:.*?) at / ) {
374 $E = "OpenSSL $1";
375 }
376 $result = 'fail';
377 $details = $E;
378 };
379 return ( $result, $details );
380}
381
382sub finish_body {
383 my $self = shift;
384
385 foreach my $algorithm ( @{ $self->{algorithms} } ) {
386
387 # finish canonicalizing
388 $algorithm->finish_body;
389
390 my ( $result, $details ) =
391 $self->_check_and_verify_signature($algorithm);
392
393 # save the results of this signature verification
394 $algorithm->{result} = $result;
395 $algorithm->{details} = $details;
396 $algorithm->signature->result( $result, $details );
397
398 # collate results ... ignore failed signatures if we already got
399 # one to pass
400 if ( !$self->{result} || $result eq 'pass' ) {
401 $self->{signature} = $algorithm->signature;
402 $self->{result} = $result;
403 $self->{details} = $details;
404 }
405 }
406}
407
408
409sub fetch_author_domain_policies {
410 my $self = shift;
411 use Mail::DKIM::AuthorDomainPolicy;
412
413 return () unless $self->{headers_by_name}->{from};
414 my @list = Mail::Address->parse( $self->{headers_by_name}->{from} );
415 my @authors = map { $_->address } @list;
416
417 # fetch the policies
418 return map {
419 Mail::DKIM::AuthorDomainPolicy->fetch(
420 Protocol => 'dns',
421 Author => $_,
422 )
423 } @authors;
424}
425
426
427sub fetch_author_policy {
428 my $self = shift;
429 my ($author) = @_;
430 use Mail::DKIM::DkimPolicy;
431
432 # determine address found in the "From"
433 $author ||= $self->message_originator->address;
434
435 # fetch the policy
436 return Mail::DKIM::DkimPolicy->fetch(
437 Protocol => 'dns',
438 Author => $author,
439 );
440}
441
442
443sub fetch_sender_policy {
444 my $self = shift;
445 use Mail::DKIM::DkPolicy;
446
447 # determine addresses found in the "From" and "Sender" headers
448 my $author = $self->message_originator->address;
449 my $sender = $self->message_sender->address;
450
451 # fetch the policy
452 return Mail::DKIM::DkPolicy->fetch(
453 Protocol => 'dns',
454 Author => $author,
455 Sender => $sender,
456 );
457}
458
459
460sub policies {
461 my $self = shift;
462
463 my $sender_policy = eval { $self->fetch_sender_policy() };
464 my $author_policy = eval { $self->fetch_author_policy() };
465 return (
466 $sender_policy ? $sender_policy : (),
467 $author_policy ? $author_policy : (),
468 $self->fetch_author_domain_policies(),
469 );
470}
471
- -
475sub signatures {
476 my $self = shift;
477 croak 'unexpected argument' if @_;
478
479 return @{ $self->{signatures} };
480}
481
4821;
483
484__END__