File Coverage

blib/lib/Mail/Milter/Authentication/Tester/HandlerTester.pm
Criterion Covered Total %
statement 194 200 97.0
branch 32 50 64.0
condition 11 14 78.5
subroutine 34 37 91.8
pod 20 20 100.0
total 291 321 90.6


line stmt bran cond sub pod time code
1             package Mail::Milter::Authentication::Tester::HandlerTester;
2              
3 8     8   235232 use strict;
  8         62  
  8         230  
4 8     8   40 use warnings;
  8         14  
  8         287  
5             our $VERSION = '20191206'; # VERSION
6              
7 8     8   39 use Carp;
  8         15  
  8         555  
8 8     8   2509 use Clone qw{ clone };
  8         14414  
  8         388  
9 8     8   2805 use English qw{ -no_match_vars };
  8         20928  
  8         42  
10 8     8   5352 use Mail::AuthenticationResults::Header;
  8         80362  
  8         228  
11 8     8   51 use Mail::AuthenticationResults::Header::AuthServID;
  8         18  
  8         136  
12 8     8   3499 use Mail::Milter::Authentication;
  8         53  
  8         586  
13 8     8   57 use Mail::Milter::Authentication::Config qw{ set_config get_config default_config };
  8         19  
  8         531  
14 8     8   53 use Mail::Milter::Authentication::Constants qw{ :all };
  8         18  
  8         1952  
15 8     8   56 use Mail::Milter::Authentication::Protocol::Milter;
  8         16  
  8         147  
16 8     8   71 use Mail::Milter::Authentication::Protocol::SMTP;
  8         18  
  8         154  
17 8     8   47 use Module::Load;
  8         17  
  8         54  
18 8     8   3316 use Net::DNS::Resolver::Mock;
  8         40932  
  8         260  
19 8     8   52 use Net::IP;
  8         17  
  8         15464  
20              
21             sub _build_config_smtp {
22 5     5   17 my ( $self, $handler_config ) = @_;
23              
24 5         89 my $config = {
25              
26             '_is_test' => 1,
27             'debug' => 1,
28             'dryrun' => 0,
29             'logtoerr' => 1,
30             'error_log' => 'tmp/smtp.err',
31             'connection' => 'unix:tmp/authentication_milter_test.sock',
32             'umask' => '0000',
33             'connect_timeout' => 55,
34             'command_timeout' => 55,
35             'content_timeout' => 595,
36             'tempfail_on_error' => 1,
37             'tempfail_on_error_authenticated' => 1,
38             'tempfail_on_error_local' => 1,
39             'tempfail_on_error_trusted' => 1,
40              
41             '#metric_connection' => 'unix:tmp/authentication_milter_test_metrics.sock',
42             '#metric_umask' => '0000',
43              
44             'protocol' => 'smtp',
45             'smtp' => {
46             'sock_type' => 'unix',
47             'sock_path' => 'tmp/authentication_milter_smtp_out.sock',
48             'pipeline_limit' => '4',
49             },
50              
51             'handlers' => $handler_config,
52              
53             };
54              
55 5         59 return $config;
56             }
57              
58             sub _build_config_milter {
59 4     4   10 my ( $self, $handler_config ) = @_;
60              
61 4         46 my $config = {
62              
63             '_is_test' => 1,
64             'debug' => 1,
65             'dryrun' => 0,
66             'logtoerr' => 1,
67             'error_log' => 'tmp/milter.err',
68             'connection' => 'unix:tmp/authentication_milter_test.sock',
69             'umask' => '0000',
70             'connect_timeout' => 55,
71             'command_timeout' => 55,
72             'content_timeout' => 595,
73             'tempfail_on_error' => 1,
74             'tempfail_on_error_authenticated' => 1,
75             'tempfail_on_error_local' => 1,
76             'tempfail_on_error_trusted' => 1,
77              
78             '#metric_connection' => 'unix:tmp/authentication_milter_test_metrics.sock',
79             '#metric_umask' => '0000',
80              
81             'protocol' => 'milter',
82              
83             'handlers' => $handler_config,
84              
85             };
86              
87 4         32 return $config;
88             }
89              
90             sub new {
91 9     9 1 774350 my ( $class, $args ) = @_;
92 9         23 my $self = {};
93 9         28 bless $self, $class;
94              
95 9         83 $self->{ 'snapshots' } = {};
96              
97 9         33 foreach my $arg ( qw{ prefix zonefile zonedata } ) {
98 27 100       95 $self->{ $arg } = $args->{ $arg } if exists $args->{ $arg };
99             }
100              
101 9 50       36 croak 'prefix must be supplies' if ! exists $self->{ 'prefix' };
102 9 50 66     45 croak 'zonefile or zonedata cannot both be supplied' if ( exists $self->{ 'zonefile' } ) && ( exists $self->{ 'zonedata' });
103 9 50 66     80 $self->{ 'zonedata' } = q{} if ( ! exists $self->{ 'zonefile' } ) && ( ! exists $self->{ 'zonedata' });
104              
105 9   100     45 my $protocol = $args->{ 'protocol' } // 'smtp';
106              
107 9 50       40 if ( exists( $args->{ 'handler_config' } ) ) {
108 9 100       38 if ( $protocol eq 'smtp' ) {
109 5         26 set_config( $self->_build_config_smtp( $args->{ 'handler_config' } ) );
110             }
111             else {
112 4         17 set_config( $self->_build_config_milter( $args->{ 'handler_config' } ) );
113             }
114             }
115              
116 9         30 $Mail::Milter::Authentication::Config::PREFIX = $self->{ 'prefix' };
117 9         39 my $config = get_config();
118              
119 9         152 my $Resolver = Net::DNS::Resolver::Mock->new();
120 9 100       2885 $Resolver->zonefile_read( $self->{ 'zonefile' } ) if exists $self->{ 'zonefile' };
121 9 100       50131 $Resolver->zonefile_parse( $self->{ 'zonedata' } ) if exists $self->{ 'zonedata' };
122 9         12722 $Mail::Milter::Authentication::Handler::TestResolver = $Resolver;
123              
124             # Setup a new authentication milter object
125 9         174 my $authmilter = Mail::Milter::Authentication->new();
126 9         186 $authmilter->{'metric'} = Mail::Milter::Authentication::Metric->new();
127 9         30 $authmilter->{'config'} = $config;
128              
129             # if ( $protocol eq 'smtp' ) {
130 9         174 push @Mail::Milter::Authentication::ISA, 'Mail::Milter::Authentication::Protocol::SMTP';
131             #}
132             #else {
133             #push @Mail::Milter::Authentication::ISA, 'Mail::Milter::Authentication::Protocol::Milter';
134             #}
135              
136             # Setup a fake server object
137 9         73 $authmilter->{ 'server' }->{ 'ppid' } = $PID;
138              
139             # Load handlers
140 9         21 foreach my $name ( @{$config->{'load_handlers'}} ) {
  9         34  
141 16         103 $authmilter->load_handler( $name );
142              
143 16         57 my $package = "Mail::Milter::Authentication::Handler::$name";
144 16         174 my $object = $package->new( $authmilter );
145 16 100       126 if ( $object->can( 'pre_loop_setup' ) ) {
146 3         13 $object->pre_loop_setup();
147             }
148 16 50       79 if ( $object->can( 'register_metrics' ) ) {
149 16         69 $authmilter->{'metric'}->register_metrics( $object->register_metrics() );
150             }
151              
152             }
153              
154             # Init handlers
155              
156 9         26 my $callbacks_list = {};
157 9         19 my $callbacks = {};
158 9         19 my $handler = {};
159 9         19 my $object = {};
160 9         16 my $object_maker = {};
161 9         23 my $count = 0;
162              
163 9         27 $authmilter->{'callbacks_list'} = $callbacks_list;
164 9         23 $authmilter->{'callbacks'} = $callbacks;
165 9         36 $authmilter->{'count'} = $count;
166 9         22 $authmilter->{'handler'} = $handler;
167 9         30 $authmilter->{'object'} = $object;
168 9         24 $authmilter->{'object_maker'} = $object_maker;
169              
170 9         43 $authmilter->setup_handlers();
171              
172 9         30 $self->{ 'authmilter' } = $authmilter;
173              
174 9         43 $self->handler()->top_setup_callback();
175              
176 9         99 $self->snapshot( '_new' );
177              
178 9         65 return $self;
179             }
180              
181             sub snapshot {
182 9     9 1 27 my ( $self, $name ) = @_;
183 9         1483 my $snapshot = clone( $self->{ 'authmilter' } );
184 9         71 $self->{ 'snapshots' }->{ $name } = $snapshot;
185 9         21 return;
186             }
187              
188             sub switch {
189 146     146 1 1963 my ( $self, $name ) = @_;
190 146 50       755 croak 'unknown snapshot' if ! exists ( $self->{ 'snapshots' }->{ $name } );
191 146         21675 my $snapshot = clone( $self->{ 'snapshots' }->{ $name } );
192 146         869 $self->{ 'authmilter' } = $snapshot;
193 146         378 return;
194             }
195              
196             sub handler {
197 2130     2130 1 3706 my ( $self ) = @_;
198 2130         17609 return $self->{ 'authmilter' }->{ 'handler' }->{ '_Handler' };
199             }
200              
201             sub connect { ## no critic
202 146     146 1 518 my ( $self, $name, $ip ) = @_;
203 146         393 my $authmilter = $self->{ 'authmilter' };
204 146   50     315 my $ip_obj = eval{ Net::IP->new( $ip ) } // undef;
  146         1360  
205             # An undef here should not make it through to handlers, however
206             # for testing we will allow this.
207 146         141286 return $self->handler()->top_connect_callback( $name, $ip_obj );
208             }
209              
210             sub helo {
211 146     146 1 418 my ( $self, $helo ) = @_;
212 146         389 return $self->handler()->top_helo_callback( $helo );
213             }
214              
215             sub mailfrom {
216 146     146 1 462 my ( $self, $from ) = @_;
217 146         394 return $self->handler()->top_envfrom_callback( $from );
218             }
219              
220             sub rcptto {
221 146     146 1 375 my ( $self, $to ) = @_;
222 146         365 return $self->handler()->top_envrcpt_callback( $to );
223             }
224              
225             sub header {
226 553     553 1 1279 my ( $self, $key, $value, $original ) = @_;
227 553 50       1592 $original = "$key: $value" if ! defined $original;
228 553         1156 return $self->handler()->top_header_callback( $key, $value, $original );
229             }
230              
231             sub end_of_headers {
232 146     146 1 341 my ( $self ) = @_;
233 146         393 return $self->handler()->top_eoh_callback();
234             }
235              
236             sub body {
237 146     146 1 427 my ( $self, $body ) = @_;
238 146         468 return $self->handler()->top_body_callback( $body );
239             }
240              
241             sub end_of_message {
242 146     146 1 352 my ( $self ) = @_;
243 146         435 return $self->handler()->top_eom_callback();
244             }
245              
246             sub close { ## no critic
247 12     12 1 36584 my ( $self ) = @_;
248 12         47 return $self->handler()->top_close_callback();
249             }
250              
251             sub abort {
252 0     0 1 0 my ( $self ) = @_;
253 0         0 return $self->handler()->top_abort_callback();
254             }
255              
256             sub addheader {
257 145     145 1 335 my ( $self ) = @_;
258 145         417 return $self->handler()->top_addheader_callback();
259             }
260              
261             sub run {
262 145     145 1 2024251 my ( $self, $args ) = @_;
263              
264 145         844 $self->switch( '_new' );
265              
266 145         283 my $returncode;
267 145         651 $returncode = $self->connect( $args->{ 'connect_name' }, $args->{ 'connect_ip' } );
268 145 50       476 die 'connect' if ( $returncode != SMFIS_CONTINUE );
269 145         522 $returncode = $self->helo( $args->{ 'helo' } );
270 145 50       442 die 'helo' if ( $returncode != SMFIS_CONTINUE );
271 145         631 $returncode = $self->mailfrom( $args->{ 'mailfrom' } );
272 145 50       564 die 'mailfrom' if ( $returncode != SMFIS_CONTINUE );
273 145         282 foreach my $rcptto ( @{ $args->{ 'rcptto' } } ) {
  145         497  
274 145         525 $returncode = $self->rcptto( $rcptto );
275 145 50       593 die 'rcptto ' . $rcptto if ( $returncode != SMFIS_CONTINUE );
276             }
277              
278 145         416 my $body = $args->{ 'body' };
279 145         2037 $body =~ s/\r?\n/\n/g;
280              
281 145         885 my @lines = split( /\n/, $body );
282              
283             # Process headers
284 145         346 my $buffer = q{};
285 145         531 while ( my $line = shift @lines ) {
286 1167         1687 chomp $line;
287 1167 50       2045 last if $line eq q{};
288              
289 1167 100       2941 if ( $line =~ /^\s/ ) {
290 616         1357 $buffer .= "\n" . $line;
291             }
292             else {
293 551 100       1125 if ( $buffer ) {
294 406         1500 my ( $key, $value ) = split( ':', $buffer, 2 );
295 406         1059 $key =~ s/\s+$//;
296 406         1514 $value =~ s/^\s+//;
297 406         1185 $returncode = $self->header( $key, $value );
298 406 50       1073 die "header $key: $value" if ( $returncode != SMFIS_CONTINUE );
299             }
300 551         1888 $buffer = $line;
301             }
302              
303             }
304 145 50       457 if ( $buffer ) {
305 145         639 my ( $key, $value ) = split( ':', $buffer, 2 );
306 145         532 $key =~ s/\s+$//;
307 145         718 $value =~ s/^\s+//;
308 145         460 $returncode = $self->header( $key, $value );
309 145 50       469 die "header $key: $value" if ( $returncode != SMFIS_CONTINUE );
310             }
311              
312 145         485 $returncode = $self->end_of_headers();
313 145 50       551 die 'eoh' if ( $returncode != SMFIS_CONTINUE );
314              
315 145         1009 $returncode = $self->body( join( "\n", @lines) . "\n" );
316 145 50       493 die 'body' if ( $returncode != SMFIS_CONTINUE );
317              
318 145         498 $returncode = $self->end_of_message();
319 145 50       507 die 'body' if ( $returncode != SMFIS_CONTINUE );
320              
321 145         615 $self->addheader();
322             # $self->close();
323              
324 145         643 return;
325             }
326              
327             sub get_return {
328 0     0 1 0 my ( $self ) = @_;
329 0         0 return $self->handler()->get_return();
330             }
331              
332             sub get_reject_mail {
333 0     0 1 0 my ( $self ) = @_;
334 0         0 return $self->handler()->get_reject_mail();
335             }
336              
337             sub servername {
338 194     194 1 2802 my ( $self ) = @_;
339 194         634 return 'handlertester.test.authmilter.org';
340             }
341              
342             sub get_authresults_header {
343 194     194 1 60691 my ( $self ) = @_;
344             # Build a Mail::AuthenticationReslts object
345 194   100     612 my $c_auth_headers = clone( $self->handler()->{ 'c_auth_headers'} ) // [];
346 194   100     655 my $auth_headers = clone( $self->handler()->{ 'auth_headers'} ) // [];
347 194         632 my @added_ar_headers = ( @{ $c_auth_headers }, @{ $auth_headers } );
  194         397  
  194         474  
348 194         936 my $header = Mail::AuthenticationResults::Header->new()->set_value( Mail::AuthenticationResults::Header::AuthServID->new()->set_value( $self->servername() ) );
349 194         5912 foreach my $ar_header ( @added_ar_headers ) {
350 335         6332 eval{ $ar_header->orphan(); }; # Remove parent for testing.
  335         912  
351 335         2713 $header->add_child( $ar_header );
352             }
353 194         7656 return $header;
354             }
355              
356             1;
357              
358             __END__
359              
360             =pod
361              
362             =encoding UTF-8
363              
364             =head1 NAME
365              
366             Mail::Milter::Authentication::Tester::HandlerTester
367              
368             =head1 VERSION
369              
370             version 20191206
371              
372             =head1 SYNOPSIS
373              
374             Emulates an Authentication Milter environment with methods for testing Handlers.
375              
376             Can snapshot and restore state at any point.
377              
378             =head1 DESCRIPTION
379              
380             Make testing of Authentication Milter Handler modules easier.
381              
382             =head1 NAME
383              
384             Mail::Milter::Authentication::Tester::HandlerTester - Test harness for testing Authentication Milter Handlers
385              
386             =head1 CONSTRUCTOR
387              
388             =over
389              
390             =item new( $args )
391              
392             Instantiate a new HandlerTester object.
393              
394             $args is a hashref with the following entries.
395              
396             =over
397              
398             =item prefix
399              
400             Required
401              
402             The Prefix path containing the authentication milter config file(s). This should contain
403             all configuration files required for your test, the main authentication_milter.json file
404             can be overridden by the handler_config option (see below).
405              
406             This location should, for example, contain a valid mail-dmarc.ini for any tests using
407             the DMARC handler.
408              
409             =item handler_config
410              
411             If present, the config will be built from a generic default SMTP environment, with the given
412             HASHREF substituted as the Handler configuration. This eliminates the need to have a config file
413             for each handler configuration you wish to test.
414              
415             =item zonedata
416              
417             The zonefile data for use with Net::DNS::Resolver::Mock
418              
419             =item zonefile
420              
421             A zonefile for use with Net::DNS::Resolver::Mock
422              
423             =back
424              
425             =back
426              
427             =head1 METHODS
428              
429             =over
430              
431             =item snapshot( $name )
432              
433             Save a snapshot with the given name
434              
435             =item switch( $name )
436              
437             Restore state from the given snapshot
438              
439             =item handler()
440              
441             Returns the Handler object
442              
443             =item connect( $name, $ip )
444              
445             Call the connect callbacks with the given data.
446              
447             Returns the value of get_return()
448              
449             =item helo( $name )
450              
451             Call the helo callbacks with the given data.
452              
453             Returns the value of get_return();
454              
455             =item mailfrom( $email )
456              
457             Call the envfrom callbacks with the given data.
458              
459             Returns the value of get_return();
460              
461             =item rcptto( $email )
462              
463             Call the envrcpt callbacks with the given data.
464              
465             Returns the value of get_return();
466              
467             =item header( $key, $value )
468              
469             Call the header callbacks with the given data.
470              
471             Returns the value of get_return()
472              
473             =item end_of_headers()
474              
475             Call the end_of_headers callbacks.
476              
477             Returns the value of get_return()
478              
479             =item body( $body_chunk )
480              
481             Call the body callbacks with the given data.
482              
483             Returns the value of get_return()
484              
485             =item end_of_message()
486              
487             Call the eom callbacks.
488              
489             Returns the value of get_return()
490              
491             =item close()
492              
493             Call the close callbacks.
494              
495             Returns the value of get_return()
496              
497             =item abort()
498              
499             Call the abort callbacks.
500              
501             =item addheader()
502              
503             Call the addheader callbacks.
504              
505             =item run( $args )
506              
507             Run with a given set of data as defined in $args hashref.
508              
509             Dies if the mail would be rejected.
510              
511             Arguments of $args are.
512              
513             =over
514              
515             =item connect_name
516              
517             The name of the connecting server.
518              
519             =item connect_ip
520              
521             The ip address of the connecting server.
522              
523             =item helo
524              
525             The helo string.
526              
527             =item mailfrom
528              
529             The envelope MAILFROM address.
530              
531             =item rcptto
532              
533             Arrayref of the envelope RCPTTO addresses.
534              
535             =item body
536              
537             The email body.
538              
539             =back
540              
541             =item get_return()
542              
543             Returns the value of get_return() from the current handler object.
544              
545             =item get_reject_mail()
546              
547             Returns the value of get_reject_mail() from the current handler object.
548              
549             =item servername()
550              
551             Returns a dummy authservid servername.
552              
553             =item get_authresults_header()
554              
555             Returns a Mail::AuthenticationResults::Header object representing the authentication results
556             header which would be added to the message.
557              
558             =back
559              
560             =head1 DEPENDENCIES
561              
562             Carp
563             Clone
564             Mail::AuthenticationResults::Header
565             Mail::AuthenticationResults::Header::AuthServID
566             Mail::Milter::Authentication
567             Mail::Milter::Authentication::Protocol::Milter
568             Mail::Milter::Authentication::Protocol::SMTP
569             Mail::Milter::Authentication::Config
570             Module::Load
571             Net::DNS::Resolver::Mock
572              
573             =head1 AUTHORS
574              
575             Marc Bradshaw E<lt>marc@marcbradshaw.netE<gt>
576              
577             =head1 COPYRIGHT
578              
579             Copyright 2018
580              
581             This library is free software; you may redistribute it and/or
582             modify it under the same terms as Perl itself.
583              
584             =head1 AUTHOR
585              
586             Marc Bradshaw <marc@marcbradshaw.net>
587              
588             =head1 COPYRIGHT AND LICENSE
589              
590             This software is copyright (c) 2018 by Marc Bradshaw.
591              
592             This is free software; you can redistribute it and/or modify it under
593             the same terms as the Perl 5 programming language system itself.
594              
595             =cut