File Coverage

blib/lib/Mail/Milter/Authentication/Resolver.pm
Criterion Covered Total %
statement 20 79 25.3
branch 0 20 0.0
condition 0 12 0.0
subroutine 7 14 50.0
pod 4 5 80.0
total 31 130 23.8


line stmt bran cond sub pod time code
1             package Mail::Milter::Authentication::Resolver;
2 126     126   3772 use 5.20.0;
  126         509  
3 126     126   754 use strict;
  126         259  
  126         2660  
4 126     126   574 use warnings;
  126         312  
  126         2910  
5 126     126   1722 use Mail::Milter::Authentication::Pragmas;
  126         426  
  126         849  
6             # ABSTRACT: DNS Recolver methods
7             our $VERSION = '3.20230629'; # VERSION
8 126     126   28786 use base 'Net::DNS::Resolver';
  126         375  
  126         27262  
9 126     126   1042132 use Scalar::Util qw{ weaken };
  126         420  
  126         12815  
10 126     126   12943 use Time::HiRes qw{ ualarm gettimeofday };
  126         26006  
  126         2193  
11              
12              
13             {
14             sub new { ## no critic
15 0     0 1   my $class = shift;
16 0           my %args = @_;
17 0           my $self = $class->SUPER::new( @_ );
18 0           weaken($args{_handler});
19 0           $self->{ _handler } = $args{_handler};
20 0           $self->{ _timedout } = {};
21 0           return $self;
22             }
23             }
24              
25             sub clear_error_cache {
26 0     0 0   my $self = shift;
27 0           $self->{ _timedout } = {};
28             }
29              
30             sub _get_microseconds {
31 0     0     my ( $self ) = @_;
32 0           my ($seconds, $microseconds) = gettimeofday;
33 0           return ( ( $seconds * 1000000 ) + $microseconds );
34             }
35              
36             sub _do { ## no critic
37 0     0     my $self = shift;
38 0           my $what = shift;
39              
40 0           my $handler = $self->{_handler};
41 0           my $config = $handler->config();
42 0           my $timeout = $config->{'dns_timeout'};
43              
44 0           my $return;
45 0           my $domain = $_[0];
46 0           my $org_domain = $_[0];
47 0           my $query = $_[1];
48 0 0         if ( $handler->is_handler_loaded( 'DMARC' ) ) {
49 0           my $dmarc_object = $handler->get_handler('DMARC')->get_dmarc_object();
50 0           $org_domain = eval{ $dmarc_object->get_organizational_domain( $org_domain ) };
  0            
51 0           $handler->handle_exception( $@ );
52             }
53              
54             # If we have a 'cached' timeout for this org domain then return
55 0 0         if ( $self->{ _timedout }->{ $org_domain } ) {
56 0           $handler->log_error( "Lookup $query $domain aborted due to previous DNS Lookup timeout on $org_domain" );
57 0           $self->errorstring('query timed out');
58 0           return;
59             }
60              
61 0           my $start_time = $self->_get_microseconds;
62              
63 0           eval {
64 0           $handler->set_handler_alarm( ( $timeout + 0.2 ) * 1000000 ); # 0.2 seconds over that passed to Net::DNS::Resolver
65 0 0         $return = $self->SUPER::send( @_ ) if $what eq 'send';
66 0 0         $return = $self->SUPER::query( @_ ) if $what eq 'query';
67 0 0         $return = $self->SUPER::search( @_ ) if $what eq 'search';
68 0           $handler->reset_alarm();
69             };
70              
71 0 0         if ( my $error = $@ ) {
72 0           $handler->reset_alarm();
73 0           my $type = $handler->is_exception_type( $error );
74 0 0 0       if ( $type && $type eq 'Timeout' ) {
75             # We have a timeout, is it global or is it ours?
76 0 0         if ( $handler->get_time_remaining() > 0 ) {
77             # We have time left, but the lookup timed out
78             # Log this and move on!
79 0           $handler->log_error( "DNS Lookup $query $domain error, hold set on $org_domain : Timeout calling Net::DNS::Resolver" );
80 0           $self->{ _timedout }->{ $org_domain } = 1;
81 0           $self->errorstring('query timed out');
82 0           return;
83             }
84             }
85 0           $handler->handle_exception( $error );
86             }
87              
88 0           my $time_taken = $self->_get_microseconds - $start_time;
89 0 0         my $servfail_timeout = exists $config->{'dns_servfail_timeout'} ? $config->{'dns_servfail_timeout'} : 1000000; # Consider a servfail as a timeout after (default) 1 second;
90              
91             # Timeouts or SERVFAIL are unlikely to recover within the lifetime of this transaction,
92             # when we encounter them, don't lookup this org domain again.
93 0 0 0       if ( ( $self->errorstring =~ /timeout/i ) || ( $self->errorstring eq 'query timed out' ) || ( $self->errorstring eq 'SERVFAIL' && $time_taken > $servfail_timeout ) ) {
      0        
      0        
94 0           $self->{ _timedout }->{ $org_domain } = 1;
95 0           $handler->log_error( "DNS Lookup $query $domain error, hold set on $org_domain : ".$self->errorstring );
96             }
97              
98 0           return $return;
99             }
100              
101             sub query { ## no critic
102 0     0 1   my $self = shift;
103 0           return $self->_do( 'query', @_ );
104             }
105              
106             sub search { ## no critic
107 0     0 1   my $self = shift;
108 0           return $self->_do( 'search', @_ );
109             }
110              
111             sub send { ## no critic
112 0     0 1   my $self = shift;
113 0           return $self->_do( 'send', @_ );
114             }
115              
116             1;
117              
118             __END__
119              
120             =pod
121              
122             =encoding UTF-8
123              
124             =head1 NAME
125              
126             Mail::Milter::Authentication::Resolver - DNS Recolver methods
127              
128             =head1 VERSION
129              
130             version 3.20230629
131              
132             =head1 DESCRIPTION
133              
134             Subclass for Net::DNS::Resolver, Versions of Net::DNS::Resolver from 1.03 up (to at least
135             1.18 at time of writing) do not timeout as expected. This introduces a wrapper timeout around
136             the query, send, and search calls which will fire 0.1 seconds after the timeout value passed
137             to Net::DNS::Resolver
138              
139             =head1 AUTHOR
140              
141             Marc Bradshaw <marc@marcbradshaw.net>
142              
143             =head1 COPYRIGHT AND LICENSE
144              
145             This software is copyright (c) 2020 by Marc Bradshaw.
146              
147             This is free software; you can redistribute it and/or modify it under
148             the same terms as the Perl 5 programming language system itself.
149              
150             =cut