← 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/ARC/Signer.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sMail::DKIM::ARC::Signer::::BEGIN@13Mail::DKIM::ARC::Signer::BEGIN@13
0000s0sMail::DKIM::ARC::Signer::::BEGIN@14Mail::DKIM::ARC::Signer::BEGIN@14
0000s0sMail::DKIM::ARC::Signer::::BEGIN@15Mail::DKIM::ARC::Signer::BEGIN@15
0000s0sMail::DKIM::ARC::Signer::::BEGIN@16Mail::DKIM::ARC::Signer::BEGIN@16
0000s0sMail::DKIM::ARC::Signer::::BEGIN@17Mail::DKIM::ARC::Signer::BEGIN@17
0000s0sMail::DKIM::ARC::Signer::::BEGIN@2Mail::DKIM::ARC::Signer::BEGIN@2
0000s0sMail::DKIM::ARC::Signer::::BEGIN@20Mail::DKIM::ARC::Signer::BEGIN@20
0000s0sMail::DKIM::ARC::Signer::::BEGIN@21Mail::DKIM::ARC::Signer::BEGIN@21
0000s0sMail::DKIM::ARC::Signer::::BEGIN@3Mail::DKIM::ARC::Signer::BEGIN@3
0000s0sMail::DKIM::ARC::Signer::::__ANON__Mail::DKIM::ARC::Signer::__ANON__ (xsub)
0000s0sMail::DKIM::ARC::Signer::::add_signatureMail::DKIM::ARC::Signer::add_signature
0000s0sMail::DKIM::ARC::Signer::::algorithmMail::DKIM::ARC::Signer::algorithm
0000s0sMail::DKIM::ARC::Signer::::as_stringMail::DKIM::ARC::Signer::as_string
0000s0sMail::DKIM::ARC::Signer::::as_stringsMail::DKIM::ARC::Signer::as_strings
0000s0sMail::DKIM::ARC::Signer::::domainMail::DKIM::ARC::Signer::domain
0000s0sMail::DKIM::ARC::Signer::::extended_headersMail::DKIM::ARC::Signer::extended_headers
0000s0sMail::DKIM::ARC::Signer::::finish_bodyMail::DKIM::ARC::Signer::finish_body
0000s0sMail::DKIM::ARC::Signer::::finish_headerMail::DKIM::ARC::Signer::finish_header
0000s0sMail::DKIM::ARC::Signer::::headersMail::DKIM::ARC::Signer::headers
0000s0sMail::DKIM::ARC::Signer::::initMail::DKIM::ARC::Signer::init
0000s0sMail::DKIM::ARC::Signer::::keyMail::DKIM::ARC::Signer::key
0000s0sMail::DKIM::ARC::Signer::::key_fileMail::DKIM::ARC::Signer::key_file
0000s0sMail::DKIM::ARC::Signer::::process_headers_hashMail::DKIM::ARC::Signer::process_headers_hash
0000s0sMail::DKIM::ARC::Signer::::selectorMail::DKIM::ARC::Signer::selector
0000s0sMail::DKIM::ARC::Signer::::signaturesMail::DKIM::ARC::Signer::signatures
0000s0sMail::DKIM::ARC::Signer::::want_headerMail::DKIM::ARC::Signer::want_header
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::Signer;
2use strict;
3use warnings;
4our $VERSION = '1.20200907'; # VERSION
5# ABSTRACT: generates a DKIM signature for a 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
13use Mail::DKIM::PrivateKey;
14use Mail::DKIM::ARC::MessageSignature;
15use Mail::DKIM::ARC::Seal;
16use Mail::AuthenticationResults::Parser;
17use Mail::AuthenticationResults::Header::AuthServID;
18
19
20use base 'Mail::DKIM::Common';
21use Carp;
22
23# PROPERTIES
24#
25# public:
26#
27# $signer->{Algorithm}
28# identifies what algorithm to use when signing the message
29# default is "rsa-sha256"
30#
31# $signer->{Domain}
32# identifies what domain the message is signed for
33#
34# $signer->{SrvId}
35# identifies what authserv-id is in the A-R headers
36#
37# $signer->{KeyFile}
38# name of the file containing the private key used to sign
39#
40# $signer->{Policy}
41# a signing policy (of type Mail::DKIM::SigningPolicy)
42#
43# $signer->{Selector}
44# identifies name of the selector identifying the key
45#
46# $signer->{Key}
47# the loaded private key
48#
49# private:
50#
51# $signer->{algorithms} = []
52# an array of algorithm objects... an algorithm object is created for
53# each signature being added to the message
54#
55# $signer->{result}
56# result of the signing policy: "signed" or "skipped"
57#
58# $signer->{details}
59# why we skipped this signature
60#
61# $signer->{signature}
62# the created signature (of type Mail::DKIM::Signature)
63
64sub init {
65 my $self = shift;
66 $self->SUPER::init;
67
68 if ( defined $self->{KeyFile} ) {
69 $self->{Key} ||=
70 Mail::DKIM::PrivateKey->load( File => $self->{KeyFile} );
71 }
72
73 unless ( $self->{'Algorithm'} ) {
74
75 # use default algorithm
76 $self->{'Algorithm'} = 'rsa-sha256';
77 }
78 unless ( $self->{'Domain'} ) {
79
80 # use default domain
81 $self->{'Domain'} = 'example.org';
82 }
83 unless ( $self->{'SrvId'} ) {
84
85 # use default domain
86 $self->{'SrvId'} = $self->{'Domain'};
87 }
88 unless ( $self->{'Selector'} ) {
89
90 # use default selector
91 $self->{'Selector'} = 'unknown';
92 }
93 $self->{result} = '?'; # better update this before we finish
94 die 'Invalid signing algorithm'
95 unless $self->{Algorithm} eq 'rsa-sha256'; # add ed25519 sometime
96 die 'Need a valid chain value'
97 unless $self->{Chain} and $self->{Chain} =~ m{^(pass|fail|none|ar)$};
98}
99
100sub finish_header {
101 my $self = shift;
102
103 # add the AAR header
104 my @aar;
105 my @ams;
106 my @as;
107
108 my $ar;
109 HEADER:
110 foreach my $header ( @{ $self->{headers} } ) {
111 $header =~ s/[\r\n]+$//;
112 if ( $header =~ m/^Authentication-Results:/ ) {
113 my ( $arval ) = $header =~ m/^Authentication-Results:[^;]*;[\t ]*(.*)/is;
114 my $parsed;
115 eval {
116 $parsed= Mail::AuthenticationResults::Parser->new
117 ->parse( $header );
118 1
119 } || do {
120 my $error = $@;
121 warn "Authentication-Results Header parse error: $error\n$header";
122 next HEADER;
123 };
124 my $ardom = $parsed->value->value;
125
126 next
127 unless "\L$ardom" eq $self->{SrvId}; # make sure it's our domain
128
129 $arval =~ s/;?\s*$//; # ignore trailing semicolon and whitespace
130 # preserve leading fold if there is one, otherwise set one leading space
131 $arval =~ s/^\s*/ / unless ($arval =~ m/^\015\012/);
132 if ($ar) {
133 $ar .= ";$arval";
134 }
135 else {
136 $ar = "$ardom;$arval";
137 }
138
139 # get chain value from A-R header
140 $self->{Chain} = $1
141 if $self->{Chain} eq 'ar' and $arval =~ m{\barc=(none|pass|fail)};
142
143 }
144 else {
145 # parse ARC headers to make sure we have completeness
146
147 if ( $header =~ m/^ARC-/ ) {
148 if ( !$ar ) {
149 $self->{result} = 'skipped';
150 $self->{details} =
151 'ARC header seen before Authentication-Results';
152 return;
153 }
154 if ( $self->{Chain} eq 'ar' ) {
155 $self->{result} = 'skipped';
156 $self->{details} =
157 'No ARC result found in Authentication-Results';
158 return;
159 }
160
161 }
162
163 if ( $header =~ m/^ARC-Seal:/ ) {
164 my $seal = Mail::DKIM::ARC::Seal->parse($header);
165 my $i = $seal->instance;
166 if ( $as[$i] ) {
167 $self->{result} = 'skipped';
168 $self->{details} = "Duplicate ARC-Seal $i";
169 return;
170 }
171 $as[$i] = $seal;
172 }
173 elsif ( $header =~ m/^ARC-Message-Signature:/ ) {
174 my $sig = Mail::DKIM::ARC::MessageSignature->parse($header);
175 my $i = $sig->instance;
176 if ( $ams[$i] ) {
177 $self->{result} = 'skipped';
178 $self->{details} =
179 "Duplicate ARC-Message-Signature $i";
180 return;
181 }
182 $ams[$i] = $sig;
183 }
184 elsif ( $header =~ m/^ARC-Authentication-Results:\s*i=(\d+)/ ) {
185 my $i = $1;
186 if ( $aar[$i] ) {
187 $self->{result} = 'skipped';
188 $self->{details} =
189 "Duplicate ARC-Authentication-Results $i";
190 return;
191 }
192
193 $aar[$i] = $header;
194 }
195 }
196 }
197
198 unless ($ar) {
199 $self->{result} = 'skipped';
200 $self->{details} = 'No authentication results seen';
201 return;
202 }
203
204 $self->{Chain} = 'none' if ($self->{Chain} eq 'ar');
205
206 if ( $#ams > $#as ) {
207 $self->{result} = 'skipped';
208 $self->{details} = 'More message signatures than seals';
209 return;
210 }
211 if ( $#aar > $#as ) {
212 $self->{result} = 'skipped';
213 $self->{details} = 'More authentication results than seals';
214 return;
215 }
216
217 foreach my $i ( 1 .. $#as ) {
218 unless ( $as[$i] ) {
219 $self->{result} = 'skipped';
220 $self->{details} = "Missing ARC-Seal $i";
221 return;
222 }
223 unless ( $ams[$i] ) {
224 $self->{result} = 'skipped';
225 $self->{details} = "Missing Arc-Message-Signature $i";
226 return;
227 }
228
229 # don't care about authentication results, they are compulsary
230 }
231
232 $self->{_Instance} = @as || 1; # next instance value
233
234 # first add the AAR header
235 $self->{_AAR} = "ARC-Authentication-Results: i=$self->{_Instance}; $ar";
236 unshift @{ $self->{headers} }, $self->{_AAR};
237
238 # set up the signer for AMS
239 $self->add_signature(
240 Mail::DKIM::ARC::MessageSignature->new(
241 Algorithm => $self->{Algorithm},
242 Headers => $self->headers,
243 Instance => $self->{_Instance},
244 Method => 'relaxed/relaxed',
245 Domain => $self->{Domain},
246 Selector => $self->{Selector},
247 Key => $self->{Key},
248 KeyFile => $self->{KeyFile},
249 ( $self->{Timestamp} ? ( Timestamp => $self->{Timestamp} ) : () ),
250 )
251 );
252
253 foreach my $algorithm ( @{ $self->{algorithms} } ) {
254
255 # output header as received so far into canonicalization
256 foreach my $header ( @{ $self->{headers} } ) {
257 $algorithm->add_header($header);
258 }
259 $algorithm->finish_header( Headers => $self->{headers} );
260 }
261}
262
263sub finish_body {
264 my $self = shift;
265
266 if ( $self->{result} eq 'skipped' ) { # already failed
267 $self->{_AS} = undef;
268 return;
269 }
270
271 foreach my $algorithm ( @{ $self->{algorithms} } ) {
272
273 # finished canonicalizing
274 $algorithm->finish_body;
275
276 # load the private key file if necessary
277 my $signature = $algorithm->signature;
278 my $key =
279 $signature->{Key}
280 || $signature->{KeyFile}
281 || $self->{Key}
282 || $self->{KeyFile};
283 if ( defined($key) && !ref($key) ) {
284 $key = Mail::DKIM::PrivateKey->load( File => $key );
285 }
286 $key
287 or die "no key available to sign with\n";
288
289 # compute signature value
290 my $signb64 = $algorithm->sign($key);
291 $signature->data($signb64);
292
293 # insert linebreaks in signature data, if desired
294 $signature->prettify_safe();
295
296 $self->{_AMS} = $signature->as_string();
297 unshift @{ $self->{headers} }, $self->{_AMS};
298 }
299
300 # reset the internal state
301 $self->{signatures} = [];
302 $self->{algorithms} = [];
303
304 $self->add_signature(
305 Mail::DKIM::ARC::Seal->new(
306 Algorithm => $self->{Algorithm},
307 Chain => $self->{Chain},
308 Headers => $self->headers,
309 Instance => $self->{_Instance},
310 Domain => $self->{Domain},
311 Selector => $self->{Selector},
312 Key => $self->{Key},
313 KeyFile => $self->{KeyFile},
314 ( $self->{Timestamp} ? ( Timestamp => $self->{Timestamp} ) : () ),
315 )
316 );
317
318 foreach my $algorithm ( @{ $self->{algorithms} } ) {
319
320 # output header as received so far into canonicalization
321 foreach my $header ( @{ $self->{headers} } ) {
322 $algorithm->add_header($header);
323 }
324
325 # chain needed for seal canonicalization
326 $algorithm->finish_header(
327 Headers => $self->{headers},
328 Chain => $self->{Chain}
329 );
330
331 # no body is required for ARC-Seal
332 # finished canonicalizing
333 $algorithm->finish_body;
334
335 # load the private key file if necessary
336 my $signature = $algorithm->signature;
337 my $key =
338 $signature->{Key}
339 || $signature->{KeyFile}
340 || $self->{Key}
341 || $self->{KeyFile};
342 if ( defined($key) && !ref($key) ) {
343 $key = Mail::DKIM::PrivateKey->load( File => $key );
344 }
345 $key
346 or die "no key available to sign ARC-Seal\n";
347
348 # compute signature value
349 my $signb64 = $algorithm->sign($key);
350 $signature->data($signb64);
351
352 # insert linebreaks in signature data, if desired
353 $signature->prettify_safe();
354
355 $self->{_AS} = $signature->as_string();
356 }
357
358 $self->{result} = 'sealed';
359}
360
361
362sub add_signature {
363 my $self = shift;
364 my $signature = shift;
365
366 # create a canonicalization filter and algorithm
367 my $algorithm_class =
368 $signature->get_algorithm_class( $signature->algorithm )
369 or die 'unsupported algorithm ' . ( $signature->algorithm || '' ) . "\n";
370 my $algorithm = $algorithm_class->new(
371 Signature => $signature,
372 Debug_Canonicalization => $self->{Debug_Canonicalization},
373 );
374 push @{ $self->{algorithms} }, $algorithm;
375 return;
376}
377
378
379sub algorithm {
380 my $self = shift;
381 if ( @_ == 1 ) {
382 $self->{Algorithm} = shift;
383 }
384 return $self->{Algorithm};
385}
386
387
388sub domain {
389 my $self = shift;
390 if ( @_ == 1 ) {
391 $self->{Domain} = shift;
392 }
393 return $self->{Domain};
394}
395
- -
398# these are headers that "should" be included in the signature,
399# according to the DKIM spec.
400my @DEFAULT_HEADERS = qw(From Sender Reply-To Subject Date
401 Message-ID To Cc MIME-Version
402 Content-Type Content-Transfer-Encoding Content-ID Content-Description
403 Resent-Date Resent-From Resent-Sender Resent-To Resent-cc
404 Resent-Message-ID
405 In-Reply-To References
406 List-Id List-Help List-Unsubscribe List-Subscribe
407 List-Post List-Owner List-Archive);
408
409sub process_headers_hash {
410 my $self = shift;
411 my @headers;
412
413 # these are the header fields we found in the message we're signing
414 my @found_headers = @{ $self->{header_field_names} };
415
416 # Convert all keys to lower case
417 foreach my $header ( keys %{ $self->{'ExtendedHeaders'} } ) {
418 next if $header eq lc $header;
419 if ( exists $self->{'ExtendedHeaders'}->{ lc $header } ) {
420
421 # Merge
422 my $first = $self->{'ExtendedHeaders'}->{ lc $header };
423 my $second = $self->{'ExtendedHeaders'}->{$header};
424 if ( $first eq '+' || $second eq '+' ) {
425 $self->{'ExtendedHeaders'}->{ lc $header } = '+';
426 }
427 elsif ( $first eq '*' || $second eq '*' ) {
428 $self->{'ExtendedHeaders'}->{ lc $header } = '*';
429 }
430 else {
431 $self->{'ExtendedHeaders'}->{ lc $header } = $first + $second;
432 }
433 }
434 else {
435 # Rename
436 $self->{'ExtendedHeaders'}->{ lc $header } =
437 $self->{'ExtendedHeaders'}->{$header};
438 }
439 delete $self->{'ExtendedHeaders'}->{$header};
440 }
441
442 # Add the default headers
443 if ( !$self->{'NoDefaultHeaders'} ) {
444 foreach my $default (@DEFAULT_HEADERS) {
445 if ( !exists $self->{'ExtendedHeaders'}->{ lc $default } ) {
446 $self->{'ExtendedHeaders'}->{ lc $default } = '*';
447 }
448 }
449 }
450
451 # Build a count of found headers
452 my $header_counts = {};
453 foreach my $header (@found_headers) {
454 if ( !exists $header_counts->{ lc $header } ) {
455 $header_counts->{ lc $header } = 1;
456 }
457 else {
458 $header_counts->{ lc $header } = $header_counts->{ lc $header } + 1;
459 }
460 }
461
462 foreach my $header ( sort keys %{ $self->{'ExtendedHeaders'} } ) {
463 my $want_count = $self->{'ExtendedHeaders'}->{$header};
464 my $have_count = $header_counts->{ lc $header } || 0;
465 my $add_count = 0;
466 if ( $want_count eq '+' ) {
467 $add_count = $have_count + 1;
468 }
469 elsif ( $want_count eq '*' ) {
470 $add_count = $have_count;
471 }
472 else {
473 if ( $want_count > $have_count ) {
474 $add_count = $have_count;
475 }
476 else {
477 $add_count = $want_count;
478 }
479 }
480 for ( 1 .. $add_count ) {
481 push @headers, $header;
482 }
483 }
484 return join( ':', @headers );
485}
486
487sub extended_headers {
488 my $self = shift;
489 $self->{'ExtendedHeaders'} = shift;
490 return;
491}
492
493sub headers {
494 my $self = shift;
495 croak 'unexpected argument' if @_;
496
497 if ( exists $self->{'ExtendedHeaders'} ) {
498 return $self->process_headers_hash();
499 }
500
501 # these are the header fields we found in the message we're signing
502 my @found_headers = @{ $self->{header_field_names} };
503
504 # these are the headers we actually want to sign
505 my @wanted_headers;
506 if ( !$self->{'NoDefaultHeaders'} ) {
507 @wanted_headers = @DEFAULT_HEADERS;
508 }
509 if ( $self->{Headers} ) {
510 push @wanted_headers, split /:/, $self->{Headers};
511 }
512
513 my @headers =
514 grep {
515 my $a = $_;
516 scalar grep { lc($a) eq lc($_) } @wanted_headers
517 } @found_headers;
518 return join( ':', @headers );
519}
520
521# return nonzero if this is header we should sign
522sub want_header {
523 my $self = shift;
524 my ($header_name) = @_;
525
526 #TODO- provide a way for user to specify which headers to sign
527 return scalar grep { lc($_) eq lc($header_name) } @DEFAULT_HEADERS;
528}
529
530
531sub key {
532 my $self = shift;
533 if (@_) {
534 $self->{Key} = shift;
535 $self->{KeyFile} = undef;
536 }
537 return $self->{Key};
538}
539
540
541sub key_file {
542 my $self = shift;
543 if (@_) {
544 $self->{Key} = undef;
545 $self->{KeyFile} = shift;
546 }
547 return $self->{KeyFile};
548}
549
- -
552sub selector {
553 my $self = shift;
554 if ( @_ == 1 ) {
555 $self->{Selector} = shift;
556 }
557 return $self->{Selector};
558}
559
560
561sub signatures {
562 my $self = shift;
563 croak 'no arguments allowed' if @_;
564 return map { $_->signature } @{ $self->{algorithms} };
565}
566
567
568sub as_string {
569 my $self = shift;
570 return '' unless $self->{_AS}; # skipped, no signature
571
572 return join( "\015\012", $self->{_AS}, $self->{_AMS}, $self->{_AAR}, '' );
573}
574
575
576sub as_strings {
577 my $self = shift;
578 return ( $self->{_AS}, $self->{_AMS}, $self->{_AAR} );
579}
580
5811;
582
583__END__