File Coverage

blib/lib/Mail/Milter/Authentication/Handler/ARC.pm
Criterion Covered Total %
statement 240 456 52.6
branch 60 166 36.1
condition 8 37 21.6
subroutine 25 33 75.7
pod 1 21 4.7
total 334 713 46.8


line stmt bran cond sub pod time code
1             package Mail::Milter::Authentication::Handler::ARC;
2 2     2   2156 use 5.20.0;
  2         143  
3 2     2   14 use strict;
  2         6  
  2         52  
4 2     2   11 use warnings;
  2         5  
  2         67  
5 2     2   15 use Mail::Milter::Authentication::Pragmas;
  2         9  
  2         20  
6             # ABSTRACT: Handler class for ARC
7             our $VERSION = '3.20230629'; # VERSION
8 2     2   602 use base 'Mail::Milter::Authentication::Handler';
  2         10  
  2         246  
9 2     2   43 use Mail::DKIM 1.20200824;
  2         47  
  2         54  
10 2     2   798 use Mail::DKIM::ARC::Signer;
  2         7592  
  2         131  
11 2     2   1229 use Mail::DKIM::ARC::Verifier;
  2         7528  
  2         107  
12 2     2   17 use Mail::DKIM::DNS;
  2         6  
  2         59  
13 2     2   1070 use Mail::DKIM::TextWrap;
  2         2073  
  2         14776  
14              
15             sub default_config {
16             return {
17 0     0 0 0 'hide_none' => 0,
18             'arcseal_domain' => undef,
19             'arcseal_selector' => undef,
20             'arcseal_algorithm' => 'rsa-sha256',
21             'arcseal_key' => undef,
22             'arcseal_keyfile' => undef,
23             'arcseal_headers' => undef,
24             'trusted_domains' => [],
25             'rbl_whitelist' => '',
26             'no_strict' => 0,
27             };
28             }
29              
30             sub grafana_rows {
31 0     0 0 0 my ( $self ) = @_;
32 0         0 my @rows;
33 0         0 push @rows, $self->get_json( 'ARC_metrics' );
34 0         0 return \@rows;
35             }
36              
37             sub register_metrics {
38             return {
39 1     1 1 9 'arc_total' => 'The number of emails processed for ARC',
40             'arc_signatures' => 'The number of signatures processed for ARC',
41             'arcseal_total' => 'The number of ARC seals added',
42             };
43             }
44              
45             sub is_domain_trusted {
46 5     5 0 14 my ( $self, $domain ) = @_;
47 5 50       13 return 0 if ! defined $domain;
48 5         12 $domain = lc $domain;
49 5         14 my $config = $self->handler_config();
50              
51 5         12 my $trusted_domains = $config->{ 'trusted_domains' };
52 5 50       13 if ( $trusted_domains ) {
53 5         12 foreach my $trusted_domain ( @$trusted_domains ) {
54 5 50       17 if ( $domain eq lc $trusted_domain ) {
55             #$self->dbgout( 'ARCResult', 'ARC domain trusted by static list', LOG_INFO );
56 5         14 return 1;
57             }
58             }
59             }
60              
61 0         0 my $rbl_whitelist = $config->{ 'rbl_whitelist' };
62 0 0       0 if ( $rbl_whitelist ) {
63 0 0       0 if ( $self->rbl_check_domain( $domain, $rbl_whitelist ) ) {
64             #$self->dbgout( 'ARCResult', 'ARC domain trusted by dns list', LOG_INFO );
65 0         0 return 1;
66             }
67             }
68              
69 0         0 return 0;
70             }
71              
72             sub get_trusted_spf_results {
73 2     2 0 10 my ( $self ) = @_;
74              
75 2         8 my $aar = $self->get_trusted_arc_authentication_results();
76 2 100       16 return if ! $aar;
77              
78 1         4 my @trusted_results;
79              
80 1         6 foreach my $instance ( sort keys %$aar ) {
81 1         3 eval {
82 1         8 my $results = $aar->{$instance}->search({ 'isa' => 'entry', 'key' => 'spf' })->children();
83             RESULT:
84 1         198 foreach my $result ( @$results ) {
85 0         0 my $smtp_mailfrom = eval{ $result->search({ 'isa' => 'subentry', 'key' => 'smtp.mailfrom' })->children()->[0]->value() };
  0         0  
86 0         0 $self->handle_exception( $@ );
87 0 0       0 next RESULT if ! $smtp_mailfrom;
88 0         0 my $result_domain = $self->get_domain_from( $smtp_mailfrom );
89 0         0 push @trusted_results, {
90             'domain' => $result_domain,
91             'scope' => 'mfrom',
92             'result' => $result->value(),
93             };
94             }
95             };
96 1 50       10 if ( my $error = $@ ) {
97 0         0 $self->handle_exception( $error );
98 0         0 $self->log_error( 'ARC Inherit Error ' . $error );
99             }
100             }
101 1         11 return \@trusted_results;
102             }
103              
104             sub get_trusted_dkim_results {
105 2     2 0 17 my ( $self ) = @_;
106              
107 2         6 my $aar = $self->get_trusted_arc_authentication_results();
108 2 100       9 return if ! $aar;
109              
110 1         5 my @trusted_results;
111              
112 1         5 foreach my $instance ( sort keys %$aar ) {
113 1         3 eval {
114 1         8 my $results = $aar->{$instance}->search({ 'isa' => 'entry', 'key' => 'dkim' })->children();
115             RESULT:
116 1         328 foreach my $result ( @$results ) {
117 1         3 my $entry_domain = eval{ $result->search({ 'isa' => 'subentry', 'key' => 'header.d' })->children()->[0]->value() };
  1         7  
118 1         302 $self->handle_exception( $@ );
119 1 50       9 if ( ! $entry_domain ) {
120             # No domain, check for an identifier instead
121 0         0 my $entry_domain = eval{ $result->search({ 'isa' => 'subentry', 'key' => 'header.i' })->children()->[0]->value() };
  0         0  
122 0         0 $self->handle_exception( $@ );
123 0 0       0 if ( $entry_domain ) {
124 0         0 $entry_domain =~ s/^.*\@//;
125             }
126             }
127 1 50       19 next RESULT if ! $entry_domain;
128 1         9 $entry_domain = lc $entry_domain;
129              
130 1         23 my $entry_selector = eval{ $result->search({ 'isa' => 'subentry', 'key' => 'x-selector' })->children()->[0]->value() };
  1         15  
131 1         162 $self->handle_exception( $@ );
132 1 50       5 if ( ! defined $entry_selector ) {
133             # Google are using header.s
134 1         5 $entry_selector = eval{ $result->search({ 'isa' => 'subentry', 'key' => 'header.s' })->children()->[0]->value() };
  1         9  
135 1         159 $self->handle_exception( $@ );
136             }
137             # If we don't have a selector then we fake it.
138 1 50       7 $entry_selector = 'x-arc-chain' if ! defined $entry_selector;
139 1 50       5 $entry_selector = 'x-arc-chain' if $entry_selector eq '';
140             ## TODO If we can't find this in the ar header then we could
141             ## try looking for the Signature and pull it from there.
142             ## But let's not do that right now.
143 1 50       4 next RESULT if ! $entry_selector;
144              
145             #my $result_domain = $self->get_domain_from( $smtp_mailfrom );
146 1         50 push @trusted_results, {
147             'domain' => $entry_domain,
148             'selector' => $entry_selector,,
149             'result' => $result->value(),
150             'human_result' => 'Trusted ARC entry',
151             };
152             }
153             };
154 1 50       30 if ( my $error = $@ ) {
155 0         0 $self->handle_exception( $error );
156 0         0 $self->log_error( 'ARC Inherit Error ' . $error );
157             }
158             }
159 1         11 return \@trusted_results;
160             }
161              
162             sub inherit_trusted_spf_results {
163 1     1 0 5 my ( $self ) = @_;
164              
165 1 50       6 return if ( ! $self->is_handler_loaded( 'SPF' ) );
166              
167 1         22 my $aar = $self->get_trusted_arc_authentication_results();
168 1 50       5 return if ! $aar;
169              
170 1         8 foreach my $instance ( sort keys %$aar ) {
171 1         3 eval {
172             # Find all ARC SPF results which passed
173 1         10 my $results = $aar->{$instance}->search({ 'isa' => 'entry', 'key' => 'spf', 'value' => 'pass' })->children();
174             RESULT:
175 1         407 foreach my $result ( @$results ) {
176              
177             # Does the entry have an x-arc-domain entry? if do then leave it alone.
178 0 0       0 next RESULT if ( scalar @{ $result->search({ 'isa' => 'subentry', 'key' => 'x-arc-domain' })->children() }> 0 );
  0         0  
179              
180             # Does the entry have a smtp.mailfrom entry we can match on?
181 0         0 my $smtp_mailfrom = eval{ $result->search({ 'isa' => 'subentry', 'key' => 'smtp.mailfrom' })->children()->[0]->value() };
  0         0  
182 0         0 $self->handle_exception( $@ );
183 0 0       0 next RESULT if ! $smtp_mailfrom;
184 0         0 $smtp_mailfrom = lc $smtp_mailfrom;
185              
186             # And add the new one
187 0         0 $result->add_child( Mail::AuthenticationResults::Header::SubEntry->new()->set_key( 'x-arc-instance' )->safe_set_value( $instance ) );
188 0         0 $result->add_child( Mail::AuthenticationResults::Header::SubEntry->new()->set_key( 'x-arc-domain' )->safe_set_value( $self->{ 'arc_domain'}->{ $instance } ) );
189 0         0 $result->add_child( Mail::AuthenticationResults::Header::Comment->new()->safe_set_value( 'Trusted from aar.' . $instance . '.' . $self->{ 'arc_domain' }->{ $instance } ) );
190 0         0 $result->orphan();
191 0         0 $result->set_key( 'x-arc-spf' );
192 0         0 $self->add_auth_header( $result );
193              
194             }
195             };
196 1 50       10 if ( my $error = $@ ) {
197 0         0 $self->handle_exception( $error );
198 0         0 $self->log_error( 'ARC Inherit Error ' . $error );
199             }
200             }
201             }
202              
203             sub inherit_trusted_dkim_results {
204 1     1 0 4 my ( $self ) = @_;
205              
206 1 50       5 return if ( ! $self->is_handler_loaded( 'DKIM' ) );
207              
208 1         8 my $aar = $self->get_trusted_arc_authentication_results();
209 1 50       11 return if ! $aar;
210              
211 1         6 foreach my $instance ( sort keys %$aar ) {
212 1         4 eval {
213             # Find all ARC DKIM results which passed
214 1         10 my $results = $aar->{$instance}->search({ 'isa' => 'entry', 'key' => 'dkim', 'value' => 'pass' })->children();
215             RESULT:
216 1         429 foreach my $result ( @$results ) {
217              
218             # Does the entry have an x-arc-domain entry? if do then leave it alone.
219 1 50       3 next RESULT if ( scalar @{ $result->search({ 'isa' => 'subentry', 'key' => 'x-arc-domain' })->children() }> 0 );
  1         7  
220              
221             # Does the entry have a domain identifier we can match on?
222 1         128 my $entry_domain = eval{ $result->search({ 'isa' => 'subentry', 'key' => 'header.d' })->children()->[0]->value() };
  1         7  
223 1         279 $self->handle_exception( $@ );
224 1 50       5 if ( ! $entry_domain ) {
225             # No domain, check for an identifier instead
226 0         0 my $entry_domain = eval{ $result->search({ 'isa' => 'subentry', 'key' => 'header.i' })->children()->[0]->value() };
  0         0  
227 0         0 $self->handle_exception( $@ );
228 0 0       0 if ( $entry_domain ) {
229 0         0 $entry_domain =~ s/^.*\@//;
230             }
231             }
232 1 50       3 next RESULT if ! $entry_domain;
233 1         3 $entry_domain = lc $entry_domain;
234              
235             # And add the new one
236 1         6 $result->add_child( Mail::AuthenticationResults::Header::SubEntry->new()->set_key( 'x-arc-instance' )->safe_set_value( $instance ) );
237 1         100 $result->add_child( Mail::AuthenticationResults::Header::SubEntry->new()->set_key( 'x-arc-domain' )->safe_set_value( $self->{ 'arc_domain'}->{ $instance } ) );
238 1         91 $result->add_child( Mail::AuthenticationResults::Header::Comment->new()->safe_set_value( 'Trusted from aar.' . $instance . '.' . $self->{ 'arc_domain' }->{ $instance } ) );
239 1         485 $result->orphan();
240 1         24 $result->set_key( 'x-arc-dkim' );
241 1         25 $self->add_auth_header( $result );
242              
243             }
244             };
245 1 50       10 if ( my $error = $@ ) {
246 0         0 $self->handle_exception( $error );
247 0         0 $self->log_error( 'ARC Inherit Error ' . $error );
248             }
249             }
250             }
251              
252             sub inherit_trusted_ip_results {
253 1     1 0 3 my ( $self ) = @_;
254              
255 1         4 my $aar = $self->get_trusted_arc_authentication_results();
256 1 50       4 return if ! $aar;
257              
258             # Add result from first trusted ingress hop
259 1         4 my ( $instance ) = sort keys %$aar;
260 1         5 foreach my $thing ( sort qw { iprev x-ptr } ) {
261 2         5 eval {
262 2         14 my $results = $aar->{$instance}->search({ 'isa' => 'entry', 'key' => $thing })->children();
263             RESULT:
264 2         359 foreach my $result ( @$results ) {
265 0 0       0 next RESULT if ( scalar @{ $result->search({ 'isa' => 'subentry', 'key' => 'x-arc-domain' })->children() }> 0 );
  0         0  
266 0         0 $result->add_child( Mail::AuthenticationResults::Header::SubEntry->new()->set_key( 'x-arc-instance' )->safe_set_value( $instance ) );
267 0         0 $result->add_child( Mail::AuthenticationResults::Header::SubEntry->new()->set_key( 'x-arc-domain' )->safe_set_value( $self->{ 'arc_domain'}->{ $instance } ) );
268 0         0 $result->add_child( Mail::AuthenticationResults::Header::Comment->new()->safe_set_value( 'Trusted from aar.' . $instance . '.' . $self->{ 'arc_domain' }->{ $instance } ) );
269 0         0 $result->orphan();
270 0         0 $result->set_key( 'x-arc-'.$thing );
271 0         0 $self->add_auth_header( $result );
272             }
273             };
274 2 50       18 if ( my $error = $@ ) {
275 0         0 $self->handle_exception( $error );
276 0         0 $self->log_error( 'ARC Inherit Error ' . $error );
277             }
278             }
279             }
280              
281             sub get_trusted_arc_authentication_results {
282 7     7 0 22 my ( $self ) = @_;
283              
284             # First, we need an arc pass or we trust nothing!
285 7 100       26 return if $self->{ 'arc_result' } ne 'pass';
286              
287 5         12 my $trusted_aar = {};
288             INSTANCE:
289 5         13 foreach my $instance ( reverse sort keys %{$self->{ 'arc_auth_results' } } ) {
  5         21  
290 5   50     17 my $signature_domain = $self->{'arc_domain'}->{ $instance } // q{};
291 5 50       14 if ( $self->is_domain_trusted( $signature_domain ) ) {
292             # Clone this, so we can safely modify entries later
293 5         150 $trusted_aar->{ $instance } = clone $self->{ 'arc_auth_results' }->{ $instance };
294             }
295             else {
296             # We don't trust this host, we can't trust anything before it!
297 0         0 last INSTANCE;
298             }
299             }
300              
301 5 50       27 if ( scalar keys %$trusted_aar == 0 ) {
302 0         0 return;
303             }
304 5         21 return $trusted_aar;
305             }
306              
307             # Do we trust the entire chain
308             sub is_chain_trusted {
309 0     0 0 0 my ( $self ) = @_;
310 0 0       0 return 0 if $self->{ 'arc_result' } ne 'pass';
311 0         0 foreach my $instance ( reverse sort keys %{$self->{ 'arc_auth_results' } } ) {
  0         0  
312 0   0     0 my $signature_domain = $self->{'arc_domain'}->{ $instance } // q{};
313 0 0       0 return 0 if ! $self->is_domain_trusted( $signature_domain );
314             }
315 0         0 return 1;
316             }
317              
318             # Get the trusted ingress IP
319             sub get_arc_trusted_ingress_ip {
320 0     0 0 0 my ( $self ) = @_;
321 0         0 my $aar = $self->get_trusted_arc_authentication_results();
322 0 0       0 return if ! $aar;
323 0         0 my ( $first_instance ) = sort keys %$aar;
324 0 0       0 return if ! $first_instance;
325              
326 0         0 my $ip;
327              
328 0         0 $ip = eval{ $aar->{$first_instance}->search({ 'isa' => 'entry', 'key' => 'iprev' })->children()->[0]->search({ 'isa' => 'subentry', 'key' => 'smtp.remote-ip'})->children()->[0]->value(); };
  0         0  
329 0 0       0 if ( my $error = $@ ) {
330 0         0 $self->handle_exception( $error );
331 0         0 $self->log_error( 'ARC Inherit Error ' . $error );
332             }
333 0 0       0 return $ip if $ip;
334              
335 0         0 $ip = eval{ $aar->{$first_instance}->search({ 'isa' => 'entry', 'key' => 'iprev' })->children()->[0]->search({ 'isa' => 'subentry', 'key' => 'policy.iprev'})->children()->[0]->value(); };
  0         0  
336 0 0       0 if ( my $error = $@ ) {
337 0         0 $self->handle_exception( $error );
338 0         0 $self->log_error( 'ARC Inherit Error ' . $error );
339             }
340 0         0 return $ip;
341             }
342              
343             # Find the earliest instance in the trusted chain
344             sub search_trusted_aar {
345 0     0 0 0 my ( $self, $search ) = @_;
346 0         0 my $trusted_aar = $self->get_trusted_arc_authentication_results();
347 0 0       0 return if ! $trusted_aar;
348 0         0 foreach my $instance ( sort keys %{$trusted_aar} ) {
  0         0  
349 0         0 my $found = $trusted_aar->{ $instance }->search( $search );
350 0 0       0 if ( scalar @{ $found->children() } ) {
  0         0  
351 0         0 return $found;
352             }
353             }
354             }
355              
356             sub envfrom_callback {
357 10     10 0 37 my ( $self, $env_from ) = @_;
358 10         32 $self->{'failmode'} = 0;
359 10         34 $self->{'headers'} = [];
360 10         35 $self->{'body'} = [];
361 10         36 $self->{'has_arc'} = 0;
362 10         37 $self->{'valid_domains'} = {};
363 10         49 $self->{'carry'} = q{};
364 10         54 $self->{'arc_auth_results'} = {};
365 10         46 $self->{'arc_domain'} = {};
366 10         38 $self->{'arc_result'} = '';
367 10         55 $self->destroy_object('arc');
368             }
369              
370             sub header_callback {
371 46     46 0 125 my ( $self, $header, $value, $original ) = @_;
372 46         93 my $EOL = "\015\012";
373 46         131 my $arc_chunk = $original . $EOL;
374 46         392 $arc_chunk =~ s/\015?\012/$EOL/g;
375 46         124 push @{$self->{'headers'}} , $arc_chunk;
  46         149  
376              
377 46 100       169 if ( lc($header) eq 'arc-authentication-results' ) {
378 1         5 $self->{'has_arc'} = 1;
379 1         5 my ( $instance, $aar ) = split( ';', $value, 2 );
380 1         10 $instance =~ s/.*i=(\d+).*$/$1/;
381 1         3 my $parsed = eval{ Mail::AuthenticationResults->parser()->parse( $aar ) };
  1         27  
382 1         1743 $self->handle_exception( $@ );
383 1         6 $self->{'arc_auth_results'}->{ $instance } = $parsed;
384             }
385              
386 46 100       130 if ( lc($header) eq 'arc-seal' ) {
387 1         4 $self->{'has_arc'} = 1;
388             }
389              
390 46 100       167 if ( lc($header) eq 'arc-message-signature' ) {
391 1         13 $self->{'has_arc'} = 1;
392             }
393             }
394              
395             sub eoh_callback {
396 10     10 0 50 my ($self) = @_;
397 10         49 my $config = $self->handler_config();
398              
399 10         74 $self->{'carry'} = q{};
400              
401 10 0 33     46 if ($config->{arcseal_domain} and
      0        
      0        
402             $config->{arcseal_selector} and
403             ($config->{arcseal_key} || $config->{arcseal_keyfile}))
404             {
405 0         0 $self->{has_arcseal} = 1;
406             }
407              
408 10 100       37 unless ($self->{'has_arc'}) {
409 9         75 $self->metric_count( 'arc_total', { 'result' => 'none' } );
410 9         84 $self->dbgout( 'ARCResult', 'No ARC headers', LOG_DEBUG );
411 9 50       64 unless ($config->{'hide_none'}) {
412 9         112 my $header = Mail::AuthenticationResults::Header::Entry->new()->set_key( 'arc' )->safe_set_value( 'none' );
413 9         699 $header->add_child( Mail::AuthenticationResults::Header::Comment->new()->safe_set_value( 'no signatures found' ) );
414 9         3375 $self->add_auth_header( $header );
415             }
416 9         42 $self->{arc_result} = 'none';
417 9 50       98 delete $self->{headers} unless $self->{has_arcseal};
418 9         40 return;
419             }
420              
421 1         3 my $arc;
422 1         2 eval {
423 1         3 my $UseStrict = 1;
424 1 50       5 if ( $config->{ 'no_strict' } ) {
425 0         0 $UseStrict = 0;
426             }
427 1         17 $arc = Mail::DKIM::ARC::Verifier->new( 'Strict' => $UseStrict );
428 1         71 my $resolver = $self->get_object('resolver');
429 1         10 Mail::DKIM::DNS::resolver($resolver);
430 1         13 $self->set_object('arc', $arc, 1);
431             };
432 1 50       6 if ( my $error = $@ ) {
433 0         0 $self->handle_exception( $error );
434 0         0 $self->log_error( 'ARC Setup Error ' . $error );
435 0         0 $self->_check_error( $error );
436 0         0 $self->metric_count( 'arc_total', { 'result' => 'error' } );
437 0         0 $self->{'failmode'} = 1;
438 0         0 $self->{arc_result} = 'fail'; # XXX - handle tempfail better
439 0 0       0 delete $self->{headers} unless $self->{has_arcseal};
440 0         0 return;
441             }
442              
443 1         3 eval {
444             $arc->PRINT( join q{},
445 1         4 @{ $self->{'headers'} },
  1         13  
446             "\015\012",
447             );
448             };
449 1 50       4449 if ( my $error = $@ ) {
450 0         0 $self->handle_exception( $error );
451 0         0 $self->log_error( 'ARC Headers Error ' . $error );
452 0         0 $self->_check_error( $error );
453 0         0 $self->metric_count( 'arc_total', { 'result' => 'error' } );
454 0         0 $self->{'failmode'} = 1;
455 0         0 $self->{arc_result} = 'fail'; # XXX - handle tempfail better
456 0 0       0 delete $self->{headers} unless $self->{has_arcseal};
457 0         0 return;
458             }
459             }
460              
461             sub body_callback {
462 10     10 0 46 my ( $self, $body_chunk ) = @_;
463 10         26 my $EOL = "\015\012";
464              
465 10         26 my $arc_chunk;
466 10 50       63 if ( $self->{'carry'} ne q{} ) {
467 0         0 $arc_chunk = $self->{'carry'} . $body_chunk;
468 0         0 $self->{'carry'} = q{};
469             }
470             else {
471 10         24 $arc_chunk = $body_chunk;
472             }
473              
474 10 50       58 if ( substr( $arc_chunk, -1 ) eq "\015" ) {
475 0         0 $self->{'carry'} = "\015";
476 0         0 $arc_chunk = substr( $arc_chunk, 0, -1 );
477             }
478              
479 10         98 $arc_chunk =~ s/\015?\012/$EOL/g;
480 10 50       52 push @{$self->{body}}, $arc_chunk if $self->{has_arcseal};
  0         0  
481              
482 10 100 66     74 if ($self->{has_arc} and not $self->{failmode}) {
483 1         7 my $arc = $self->get_object('arc');
484 1         3 eval {
485 1         5 $arc->PRINT( $arc_chunk );
486             };
487 1 50       150 if ( my $error = $@ ) {
488 0         0 $self->handle_exception( $error );
489 0         0 $self->log_error( 'ARC Body Error ' . $error );
490 0         0 $self->_check_error( $error );
491 0         0 $self->metric_count( 'arc_total', { 'result' => 'error' } );
492 0         0 $self->{'failmode'} = 1;
493 0         0 $self->{arc_result} = 'fail'; # XXX - handle tempfail better
494 0 0       0 delete $self->{headers} unless $self->{has_arcseal};
495             }
496             }
497             }
498              
499             sub eom_requires {
500 1     1 0 3 my ( $self ) = @_;
501 1         2 my @requires;
502              
503 1 50       21 if ( $self->is_handler_loaded( 'DKIM' ) ) {
504 1         3 push @requires, 'DKIM';
505             }
506              
507 1         3 return \@requires;
508             }
509              
510             sub eom_callback {
511 10     10 0 54 my ($self) = @_;
512              
513 10 0 33     39 push @{$self->{body}}, $self->{carry} if ($self->{carry} and $self->{has_arcseal});
  0         0  
514              
515             # the rest of eom is only used for arc, not arcseal
516 10 100       54 return unless $self->{'has_arc'};
517 1 50       5 return if $self->{'failmode'};
518              
519 1         5 my $config = $self->handler_config();
520              
521 1         5 my $arc = $self->get_object('arc');
522              
523 1         3 eval {
524 1         7 $arc->PRINT( $self->{'carry'} );
525 1         23 $arc->CLOSE();
526 1         4524 $self->check_timeout();
527              
528 1         13 my $arc_result = $arc->result;
529 1         13 my $arc_result_detail = $arc->result_detail;
530              
531 1         119 $self->metric_count( 'arc_total', { 'result' => $arc_result } );
532              
533 1         6 $self->dbgout( 'ARCResult', $arc_result_detail, LOG_DEBUG );
534              
535 1         11 my $header = Mail::AuthenticationResults::Header::Entry->new()->set_key( 'arc' )->safe_set_value( $arc_result );
536              
537 1         67 my @items;
538 1         3 foreach my $signature ( @{ $arc->{signatures} } ) {
  1         5  
539 2 50       40 my $type =
    100          
540             ref($signature) eq 'Mail::DKIM::ARC::Seal' ? 'as'
541             : ref($signature) eq 'Mail::DKIM::ARC::MessageSignature' ? 'ams'
542             : ref($signature);
543 2   50     9 push @items,
      50        
      50        
544             "$type."
545             . ( $signature->instance() || '' ) . '.'
546             . ( $signature->domain() || '(none)' ) . '='
547             . ( $signature->result_detail() || '?' );
548 2         91 $self->{ 'arc_domain' }->{ $signature->instance() } = $signature->domain();
549             }
550              
551 1 50       34 if ( @items ) {
552 1         6 my $header_comment = Mail::AuthenticationResults::Header::Comment->new();
553 1         13 my $header_comment_text = join( ', ', @items );
554             # Try set_value first (required for potential nested comment), if this fails then
555             # set using safe_set_value
556 1         2 eval { $header_comment->set_value( $header_comment_text ); };
  1         6  
557 1 50       345 if ( my $error = $@ ) {
558 0         0 $self->handle_exception( $error );
559 0         0 $header_comment->safe_set_value( $header_comment_text );
560             }
561 1         5 $header->add_child( $header_comment );
562             }
563              
564 1         47 my $ip_address = $self->ip_address();
565 1         13 $header->add_child( Mail::AuthenticationResults::Header::SubEntry->new()->set_key( 'smtp.remote-ip' )->safe_set_value( $ip_address ) );
566              
567 1         105 $self->add_auth_header( $header );
568              
569 1         5 $self->{arc_result} = $arc_result;
570             };
571 1 50       7 if ( my $error = $@ ) {
572 0         0 $self->handle_exception( $error );
573 0         0 $self->log_error( 'ARC EOM Error ' . $error );
574 0         0 $self->_check_error( $error );
575 0         0 $self->metric_count( 'arc_total', { 'result' => 'error' } );
576 0         0 $self->{'failmode'} = 1;
577 0         0 $self->{arc_result} = 'fail';
578             }
579              
580 1         12 $self->inherit_trusted_spf_results();
581 1         8 $self->inherit_trusted_dkim_results();
582 1         5 $self->inherit_trusted_ip_results();
583             }
584              
585             sub close_callback {
586 0     0 0 0 my ( $self ) = @_;
587 0         0 delete $self->{'failmode'};
588 0         0 delete $self->{'headers'};
589 0         0 delete $self->{'body'};
590 0         0 delete $self->{'carry'};
591 0         0 delete $self->{'has_arc'};
592 0         0 delete $self->{'has_arcseal'};
593 0         0 delete $self->{'valid_domains'};
594 0         0 delete $self->{'arc_domain'};
595 0         0 delete $self->{'arc_result'};
596 0         0 delete $self->{'arc_auth_results'};
597 0         0 $self->destroy_object('arc');
598             }
599              
600             sub _check_error {
601 0     0   0 my ( $self, $error ) = @_;
602 0 0 0     0 if ( $error =~ /^DNS error: query timed out/
    0 0        
    0 0        
      0        
603             or $error =~ /^DNS query timeout/
604             ){
605 0         0 $self->log_error( 'Temp ARC Error - ' . $error );
606 0         0 my $header = Mail::AuthenticationResults::Header::Entry->new()->set_key( 'arc' )->safe_set_value( 'temperror' );
607 0         0 $header->add_child( Mail::AuthenticationResults::Header::Comment->new()->safe_set_value( 'dns timeout' ) );
608 0         0 $self->add_auth_header( $header );
609             }
610             elsif ( $error =~ /^DNS error: SERVFAIL/ ){
611 0         0 $self->log_error( 'Temp ARC Error - ' . $error );
612 0         0 my $header = Mail::AuthenticationResults::Header::Entry->new()->set_key( 'arc' )->safe_set_value( 'temperror' );
613 0         0 $header->add_child( Mail::AuthenticationResults::Header::Comment->new()->safe_set_value( 'dns servfail' ) );
614 0         0 $self->add_auth_header( $header );
615             }
616             elsif ( $error =~ /^no domain to fetch policy for$/
617             or $error =~ /^policy syntax error$/
618             or $error =~ /^empty domain label/
619             or $error =~ /^invalid name /
620             ){
621 0         0 $self->log_error( 'Perm ARC Error - ' . $error );
622 0         0 my $header = Mail::AuthenticationResults::Header::Entry->new()->set_key( 'arc' )->safe_set_value( 'permerror' );
623 0         0 $header->add_child( Mail::AuthenticationResults::Header::Comment->new()->safe_set_value( 'syntax or domain error' ) );
624 0         0 $self->add_auth_header( $header );
625             }
626             else {
627 0         0 $self->exit_on_close( 'Unexpected ARC Error - ' . $error );
628 0         0 my $header = Mail::AuthenticationResults::Header::Entry->new()->set_key( 'arc' )->safe_set_value( 'temperror' );
629 0         0 $self->add_auth_header( $header );
630             # Fill these in as they occur, but for unknowns err on the side of caution
631             # and tempfail/exit
632 0         0 $self->tempfail_on_error();
633             }
634             }
635              
636             sub _fmtheader {
637 0     0   0 my $header = shift;
638 0         0 my $value = $header->{value};
639 0         0 $value =~ s/\015?\012/\015\012/gs; # make sure line endings are right
640 0         0 return "$header->{field}: $value\015\012";
641             }
642              
643             sub addheader_callback {
644 20     20 0 44 my $self = shift;
645 20         37 my $handler = shift;
646              
647 20 50       128 return unless $self->{has_arcseal};
648              
649 0           my $config = $self->handler_config();
650              
651 0           eval {
652 0           my %KeyOpts;
653 0 0         if ($config->{arcseal_keyfile}) {
654 0           $KeyOpts{KeyFile} = $config->{arcseal_keyfile};
655             }
656             else {
657             $KeyOpts{Key} = Mail::DKIM::PrivateKey->load(
658 0           Data => $config->{arcseal_key});
659             }
660             my $arcseal = Mail::DKIM::ARC::Signer->new(
661             Algorithm => $config->{arcseal_algorithm},
662             Domain => $config->{arcseal_domain},
663             SrvId => $self->get_my_authserv_id(),
664             Selector => $config->{arcseal_selector},
665             Headers => $config->{arcseal_headers},
666             # chain value is arc_result from previous seal validation
667             Chain => $self->{arc_result},
668 0           Timestamp => time(),
669             %KeyOpts,
670             );
671              
672             # pre-headers from handler (reversed as they will add in reverse)
673 0 0         foreach my $header (reverse @{$handler->{pre_headers} || []}) {
  0            
674 0           $arcseal->PRINT(_fmtheader($header));
675             }
676              
677             # then all the original headers: XXX - this doesn't deal with
678             # the change_header command, but only sanitize uses that.
679             # It would be a massive pain to make that work consistently,
680             # as it would need to modify the already cached headers in
681             # each handler with the current architecture
682 0 0         foreach my $chunk (@{$self->{headers} || []}) {
  0            
683 0           $arcseal->PRINT($chunk);
684             }
685              
686             # post-headers from handler (these are in order)
687 0 0         foreach my $header (@{$handler->{add_headers} || []}) {
  0            
688 0           $arcseal->PRINT(_fmtheader($header));
689 0           $self->check_timeout();
690             }
691              
692             # finish header block with a blank line
693 0           $arcseal->PRINT("\015\012");
694              
695             # all the body chunks
696 0           foreach my $chunk (@{$self->{body}}) {
  0            
697 0           $arcseal->PRINT($chunk);
698             }
699              
700             # and we're done
701 0           $arcseal->CLOSE;
702 0           $self->check_timeout();
703              
704 0           my $arcseal_result = $arcseal->result();
705 0           my $arcseal_result_detail = $arcseal->result_detail();
706              
707 0           $self->metric_count( 'arcseal_total', { 'result' => $arcseal_result } );
708              
709 0           $self->dbgout( 'ARCSealResult', $arcseal_result_detail, LOG_DEBUG );
710              
711             # we need to extract the headers from ARCSeal and re-format them
712             # back to the format that pre_headers expects
713 0           my $headers = $arcseal->as_string();
714 0           my @list;
715              
716 0           my $current_header = q{};
717 0           my $current_value = q{};
718 0           foreach my $header_line ( (split ( /\015?\012/, $headers ) ) ) {
719 0 0         if ( $header_line =~ /^\s/ ) {
720             # Line begins with whitespace, add to previous header
721 0           $header_line =~ s/^\s+/ /; # for consistency
722 0           $current_value .= "\n" . $header_line;
723             }
724             else {
725             # This is a brand new header!
726 0 0         if ( $current_header ne q{} ) {
727             # We have a cached header, add it now.
728 0           push @list, { 'field' => $current_header, 'value' => $current_value };
729 0           $current_value = q{};
730             }
731 0           ( $current_header, $current_value ) = split ( ':', $header_line, 2 );
732 0           $current_value =~ s/^ +//;
733             }
734             }
735 0 0         if ( $current_header ne q{} ) {
736             # We have a cached header, add it now.
737 0           push @list, { 'field' => $current_header, 'value' => $current_value };
738 0           $current_value = q{};
739             }
740              
741             # these will prepend in reverse
742 0           push @{$handler->{pre_headers}}, reverse @list;
  0            
743             };
744              
745 0 0         if ( my $error = $@ ) {
746 0           $self->handle_exception( $error );
747 0           $self->log_error( 'ARCSeal Error ' . $error );
748 0           $self->metric_count( 'arcseal_total', { 'result' => 'error' } );
749 0           return;
750             }
751             }
752              
753             1;
754              
755             __END__
756              
757             =pod
758              
759             =encoding UTF-8
760              
761             =head1 NAME
762              
763             Mail::Milter::Authentication::Handler::ARC - Handler class for ARC
764              
765             =head1 VERSION
766              
767             version 3.20230629
768              
769             =head1 DESCRIPTION
770              
771             Module for validation of ARC signatures
772              
773             =head1 CONFIGURATION
774              
775             "ARC" : { | Config for the ARC Module
776             "hide_none" : 0, | Hide auth line if the result is 'none'
777             "arcseal_domain" : "example.com", | Domain to sign ARC Seal with (not sealed if blank)
778             "arcseal_selector" : undef, | Selector to use for ARC Seal (not sealed if blank)
779             "arcseal_algorithm" : 'rsa-sha256', | Algorithm to use on ARC Seal (default rsa-sha256)
780             "arcseal_key" : undef, | Key (base64) string to sign ARC Seal with; or
781             "arcseal_keyfile" : undef, | File containing ARC Seal key
782             "arcseal_headers" : undef, | Additional headers to cover in ARC-Message-Signature
783             "trusted_domains" : [], | Trust these domains when traversing ARC chains
784             "rbl_whitelist" : undef, | rhs list for looking up trusted signing domains
785             "no_strict" : 0, | Ignore rfc 8301 security considerations (not recommended)
786             },
787              
788             =head1 AUTHOR
789              
790             Marc Bradshaw <marc@marcbradshaw.net>
791              
792             =head1 COPYRIGHT AND LICENSE
793              
794             This software is copyright (c) 2020 by Marc Bradshaw.
795              
796             This is free software; you can redistribute it and/or modify it under
797             the same terms as the Perl 5 programming language system itself.
798              
799             =cut