File Coverage

blib/lib/Mail/Milter/Authentication/Handler/ReturnOK.pm
Criterion Covered Total %
statement 17 201 8.4
branch 0 62 0.0
condition 0 6 0.0
subroutine 6 16 37.5
pod 1 7 14.2
total 24 292 8.2


line stmt bran cond sub pod time code
1             package Mail::Milter::Authentication::Handler::ReturnOK;
2 1     1   1472 use 5.20.0;
  1         11  
3 1     1   8 use strict;
  1         3  
  1         22  
4 1     1   6 use warnings;
  1         2  
  1         32  
5 1     1   11 use Mail::Milter::Authentication::Pragmas;
  1         3  
  1         10  
6             # ABSTRACT: Handler class for Checking Return address validity
7             our $VERSION = '3.20230911'; # VERSION
8 1     1   267 use base 'Mail::Milter::Authentication::Handler';
  1         7  
  1         114  
9 1     1   8 use Net::DNS;
  1         2  
  1         2907  
10              
11             sub default_config {
12 0     0 0   return {};
13             }
14              
15             sub grafana_rows {
16 0     0 0   my ( $self ) = @_;
17 0           my @rows;
18 0           push @rows, $self->get_json( 'ReturnOK_metrics' );
19 0           return \@rows;
20             }
21              
22             sub register_metrics {
23             return {
24 0     0 1   'returnok_total' => 'The number of emails processed for ReturnOK',
25             };
26             }
27              
28             sub _check_address {
29 0     0     my ( $self, $address, $type ) = @_;
30              
31 0           my $email = $self->get_address_from( $address );
32              
33 0 0         if ( ! $email ) {
34 0           $self->log_error( "ReturnOK: No Address for $type" );
35             }
36              
37 0           my $domain = lc $self->get_domain_from( $email );
38              
39 0           $self->_check_domain ( $domain, $type );
40             }
41              
42             sub _check_domain_rr {
43 0     0     my ( $self, $domain, $rrtype ) = @_;
44 0           my $resolver = $self->get_object('resolver');
45 0           my $return = {
46             'result' => 0,
47             'error' => '',
48             'values' => [],
49             };
50 0           eval {
51 0           my $packet = $resolver->query( $domain, $rrtype );
52 0 0         if ($packet) {
53 0           foreach my $rr ( $packet->answer ) {
54 0 0         next unless $rr->type eq $rrtype;
55 0           $return->{ 'result' } = 1;
56 0 0         push @{$return->{'values'}}, $rr->exchange if $rrtype eq 'MX';
  0            
57 0 0         push @{$return->{'values'}}, $rr->address if $rrtype eq 'A';
  0            
58 0 0         push @{$return->{'values'}}, $rr->address if $rrtype eq 'AAAA';
  0            
59             ## TODO Check the returned record is in fact valid for its type
60             }
61             }
62             else {
63 0           my $error = $resolver->errorstring;
64 0 0         if ( $error ) {
65 0           $return->{ 'error' } = $error;
66             }
67             }
68             };
69 0 0         if ( my $error = $@ ) {
70 0           $self->handle_exception( $error );
71 0           $return->{ 'error' } = 'lookup_error';
72 0           $self->log_error( "ReturnOK: Domain lookup fatal error $error for $domain $rrtype" );
73             }
74 0           return $return;
75             }
76              
77             sub _check_domain {
78 0     0     my ( $self, $domain, $type ) = @_;
79              
80 0 0         return if exists $self->{ 'done' }->{ join(':',$domain,$type) };
81 0           $self->{ 'done' }->{ join(':',$domain,$type) } = 1;
82              
83 0           my $metrics = {};
84 0           my @details;
85              
86 0 0         if ( ! $domain ) {
87 0           $self->log_error( "ReturnOK: No Domain for $type" );
88 0           my $header = Mail::AuthenticationResults::Header::Entry->new()->set_key( 'x-return-mx' )->safe_set_value( 'none' );
89 0           $metrics->{ $type . '_result' } = 'none';
90 0           $self->dbgout( 'ReturnOKCheck', 'none', LOG_DEBUG );
91 0           $self->add_auth_header($header);
92 0           push @{ $self->{ 'metrics' } }, $metrics;
  0            
93 0           return;
94             }
95              
96 0           push @details, Mail::AuthenticationResults::Header::SubEntry->new()->set_key( $type . '.domain' )->safe_set_value( $domain );
97              
98             # Get Org domain and check that if different.
99 0           my $is_org = -1;
100 0           my $org_domain;
101 0 0         if ( $self->is_handler_loaded( 'DMARC' ) ) {
102 0           my $dmarc_handler = $self->get_handler('DMARC');
103 0           my $dmarc_object = $dmarc_handler->get_dmarc_object();
104 0 0         if ( $domain ) {
105 0           $org_domain = eval{ $dmarc_object->get_organizational_domain( $domain ); };
  0            
106 0           $self->handle_exception( $@ );
107 0 0         if ( $org_domain eq $domain ) {
108 0           $is_org = 1;
109 0           $metrics->{ $type . '_is_org_domain' } = 'yes';
110             }
111             else {
112 0           $is_org = 0;
113 0           $metrics->{ $type . '_is_org_domain' } = 'no';
114 0           push @details, Mail::AuthenticationResults::Header::SubEntry->new()->set_key( 'policy.org_domain' )->safe_set_value( $org_domain );
115             }
116 0 0         push @details, Mail::AuthenticationResults::Header::SubEntry->new()->set_key( 'policy.is_org' )->safe_set_value( $is_org ? 'yes' : 'no' );
117             }
118             }
119              
120 0           my $lookup_mx = $self->_check_domain_rr( $domain, 'MX' );
121 0 0         if ( $lookup_mx->{ 'error' } ) {
122 0           push @details, Mail::AuthenticationResults::Header::SubEntry->new()->set_key( 'policy.mx_error' )->safe_set_value( $lookup_mx->{ 'error' } );
123             }
124              
125             # If MX passed then that's it, stop checking
126 0 0         if ( $lookup_mx->{ 'result' } == 1 ) {
127 0           my $header = Mail::AuthenticationResults::Header::Entry->new()->set_key( 'x-return-mx' )->safe_set_value( 'pass' );
128 0           push @details, Mail::AuthenticationResults::Header::Comment->new()->safe_set_value( 'MX Records found: '.join(',',@{$lookup_mx->{'values'}}) );
  0            
129 0           $metrics->{ $type . '_result' } = 'pass';
130 0           $metrics->{ $type . '_has_mx' } = 'yes';
131 0           $self->dbgout( 'ReturnOKCheck', 'pass', LOG_DEBUG );
132 0           foreach my $detail ( @details ) {
133 0           $header->add_child( $detail );
134             }
135 0           $self->add_auth_header($header);
136 0           push @{ $self->{ 'metrics' } }, $metrics;
  0            
137 0           return;
138             }
139 0           $metrics->{ $type . '_has_mx' } = 'no';
140              
141 0           my $lookup_a = $self->_check_domain_rr( $domain, 'A' );
142 0 0         if ( $lookup_a->{ 'error' } ) {
143 0           push @details, Mail::AuthenticationResults::Header::SubEntry->new()->set_key( 'policy.a_error' )->safe_set_value( $lookup_a->{ 'error' } );
144             }
145 0           my $lookup_aaaa = $self->_check_domain_rr( $domain, 'AAAA' );
146 0 0         if ( $lookup_aaaa->{ 'error' } ) {
147 0           push @details, Mail::AuthenticationResults::Header::SubEntry->new()->set_key( 'policy.aaaa_error' )->safe_set_value( $lookup_aaaa->{ 'error' } );
148             }
149              
150             # If we have an A or AAAA recoed then consider this a warn.
151 0 0 0       if ( $lookup_a->{ 'result' } || $lookup_aaaa->{ 'result' } ) {
152 0           my $header = Mail::AuthenticationResults::Header::Entry->new()->set_key( 'x-return-mx' )->safe_set_value( 'warn' );
153 0           $metrics->{ $type . '_result' } = 'warn';
154 0           $self->dbgout( 'ReturnOKCheck', 'warn', LOG_DEBUG );
155 0 0         if ( $lookup_a->{ 'result' } == 1 ) {
156 0           $metrics->{ $type . '_has_a' } = 'yes';
157 0           push @details, Mail::AuthenticationResults::Header::Comment->new()->safe_set_value( 'A Records found: '.join(',',@{$lookup_a->{'values'}}) );
  0            
158             }
159             else {
160 0           $metrics->{ $type . '_has_a' } = 'no';
161             }
162 0 0         if ( $lookup_aaaa->{ 'result' } == 1 ) {
163 0           $metrics->{ $type . '_has_aaaa' } = 'yes';
164 0           push @details, Mail::AuthenticationResults::Header::Comment->new()->safe_set_value( 'AAAA Records found: '.join(',',@{$lookup_aaaa->{'values'}}) );
  0            
165             }
166             else {
167 0           $metrics->{ $type . '_has_aaaa' } = 'no';
168             }
169 0           foreach my $detail ( @details ) {
170 0           $header->add_child( $detail );
171             }
172 0           $self->add_auth_header($header);
173 0           push @{ $self->{ 'metrics' } }, $metrics;
  0            
174 0           return;
175             }
176 0           $metrics->{ $type . '_has_a' } = 'no';
177 0           $metrics->{ $type . '_has_aaaa' } = 'no';
178              
179 0 0         if ( $is_org == 0 ) {
180             # We have DMARC to look this up, have done so, and found that we are NOT the org domain, so recheck at the org domain
181              
182 0           my $lookup_mx = $self->_check_domain_rr( $org_domain, 'MX' );
183 0 0         if ( $lookup_mx->{ 'error' } ) {
184 0           push @details, Mail::AuthenticationResults::Header::SubEntry->new()->set_key( 'policy.org_mx_error' )->safe_set_value( $lookup_mx->{ 'error' } );
185             }
186              
187             # If MX passed then that's it, stop checking
188 0 0         if ( $lookup_mx->{ 'result' } == 1 ) {
189 0           my $header = Mail::AuthenticationResults::Header::Entry->new()->set_key( 'x-return-mx' )->safe_set_value( 'warn' );
190 0           $self->dbgout( 'ReturnOKCheck', 'warn', LOG_DEBUG );
191 0           push @details, Mail::AuthenticationResults::Header::Comment->new()->safe_set_value( 'Org Domain MX Records found: '.join(',',@{$lookup_mx->{'values'}}) );
  0            
192 0           foreach my $detail ( @details ) {
193 0           $metrics->{ $type . '_result' } = 'warn';
194 0           $metrics->{ $type . '_has_org_mx' } = 'yes';
195 0           $header->add_child( $detail );
196             }
197 0           $self->add_auth_header($header);
198 0           push @{ $self->{ 'metrics' } }, $metrics;
  0            
199 0           return;
200             }
201 0           $metrics->{ $type . '_has_org_mx' } = 'no';
202              
203 0           my $lookup_a = $self->_check_domain_rr( $org_domain, 'A' );
204 0 0         if ( $lookup_a->{ 'error' } ) {
205 0           push @details, Mail::AuthenticationResults::Header::SubEntry->new()->set_key( 'policy.org_a_error' )->safe_set_value( $lookup_a->{ 'error' } );
206             }
207 0           my $lookup_aaaa = $self->_check_domain_rr( $org_domain, 'AAAA' );
208 0 0         if ( $lookup_aaaa->{ 'error' } ) {
209 0           push @details, Mail::AuthenticationResults::Header::SubEntry->new()->set_key( 'policy.org_aaaa_error' )->safe_set_value( $lookup_aaaa->{ 'error' } );
210             }
211              
212             # If we have an A or AAAA recoed then consider this a warn.
213 0 0 0       if ( $lookup_a->{ 'result' } || $lookup_aaaa->{ 'result' } ) {
214 0           my $header = Mail::AuthenticationResults::Header::Entry->new()->set_key( 'x-return-mx' )->safe_set_value( 'warn' );
215 0           $metrics->{ $type . '_result' } = 'warn';
216 0           $self->dbgout( 'ReturnOKCheck', 'warn', LOG_DEBUG );
217 0 0         if ( $lookup_a->{ 'result' } == 1 ) {
218 0           $metrics->{ $type . '_has_org_a' } = 'yes';
219 0           push @details, Mail::AuthenticationResults::Header::Comment->new()->safe_set_value( 'Org Domain A Records found: '.join(',',@{$lookup_a->{'values'}}) );
  0            
220             }
221             else {
222 0           $metrics->{ $type . '_has_org_a' } = 'no';
223             }
224 0 0         if ( $lookup_aaaa->{ 'result' } == 1 ) {
225 0           $metrics->{ $type . '_has_org_aaaa' } = 'yes';
226 0           push @details, Mail::AuthenticationResults::Header::Comment->new()->safe_set_value( 'Org Domain AAAA Records found: '.join(',',@{$lookup_aaaa->{'values'}}) );
  0            
227             }
228             else {
229 0           $metrics->{ $type . '_has_org_aaaa' } = 'no';
230             }
231 0           foreach my $detail ( @details ) {
232 0           $header->add_child( $detail );
233             }
234 0           $self->add_auth_header($header);
235 0           push @{ $self->{ 'metrics' } }, $metrics;
  0            
236 0           return;
237             }
238 0           $metrics->{ $type . '_has_org_a' } = 'no';
239 0           $metrics->{ $type . '_has_org_aaaa' } = 'no';
240              
241             }
242              
243             # We got here, we fail!
244 0           my $header = Mail::AuthenticationResults::Header::Entry->new()->set_key( 'x-return-mx' )->safe_set_value( 'fail' );
245 0           $metrics->{ $type . '_result' } = 'fail';
246 0           $self->dbgout( 'ReturnOKCheck', 'fail', LOG_DEBUG );
247 0           foreach my $detail ( @details ) {
248 0           $header->add_child( $detail );
249             }
250 0           $self->add_auth_header($header);
251              
252 0           push @{ $self->{ 'metrics' } }, $metrics;
  0            
253             }
254              
255             sub envfrom_callback {
256 0     0 0   my ( $self, $env_from ) = @_;
257              
258 0           $self->{ 'metrics' } = [];
259 0           $self->{ 'done' } = {};
260              
261 0 0         $env_from = q{} if $env_from eq '<>';
262 0           my $addresses = $self->get_addresses_from( $env_from );
263 0           foreach my $address ( @$addresses ) {
264 0           $self->_check_address( $address, 'smtp' );
265             }
266             }
267              
268             sub header_callback {
269 0     0 0   my ( $self, $header, $value ) = @_;
270              
271 0 0         if ( $header eq 'From' ) {
272 0           my $addresses = $self->get_addresses_from( $value );
273 0           foreach my $address ( @$addresses ) {
274 0           $self->_check_address( $address, 'header' );
275             }
276             }
277             }
278              
279             sub close_callback {
280 0     0 0   my ( $self ) = @_;
281 0           delete $self->{ 'done' };
282 0           delete $self->{ 'metrics' };
283             }
284              
285             sub eom_callback {
286 0     0 0   my ( $self ) = @_;
287              
288 0           my $metrics = $self->{ 'metrics' };
289              
290 0           foreach my $metric ( @$metrics ) {
291 0           $self->metric_count( 'returnok_total', $metric );
292             }
293             }
294              
295             1;
296              
297             __END__
298              
299             =pod
300              
301             =encoding UTF-8
302              
303             =head1 NAME
304              
305             Mail::Milter::Authentication::Handler::ReturnOK - Handler class for Checking Return address validity
306              
307             =head1 VERSION
308              
309             version 3.20230911
310              
311             =head1 DESCRIPTION
312              
313             Check that return addresses have valid MX records.
314              
315             =head1 CONFIGURATION
316              
317             No configuration options exist for this handler.
318              
319             =head1 AUTHOR
320              
321             Marc Bradshaw <marc@marcbradshaw.net>
322              
323             =head1 COPYRIGHT AND LICENSE
324              
325             This software is copyright (c) 2020 by Marc Bradshaw.
326              
327             This is free software; you can redistribute it and/or modify it under
328             the same terms as the Perl 5 programming language system itself.
329              
330             =cut