File Coverage

blib/lib/Mail/DKIM/ARC/Signer.pm
Criterion Covered Total %
statement 166 268 61.9
branch 65 118 55.0
condition 9 33 27.2
subroutine 16 25 64.0
pod 11 16 68.7
total 267 460 58.0


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