Mail-Milter-Authentication/lib/Mail/Milter/Authentication/Tester/HandlerTester.pm
package Mail::Milter::Authentication::Tester::HandlerTester;
use 5.20.0;
use strict;
use warnings;
use Mail::Milter::Authentication::Pragmas;
# ABSTRACT: Class for testing handlers
our $VERSION = '4.20250811'; # VERSION
use Mail::Milter::Authentication;
use Mail::Milter::Authentication::Protocol::Milter;
use Mail::Milter::Authentication::Protocol::SMTP;
use Net::DNS::Resolver::Mock;
use Net::IP;
sub _build_config_smtp {
my ( $self, $handler_config ) = @_;
my $config = {
'_is_test' => 1,
'debug' => 1,
'dryrun' => 0,
'logtoerr' => 1,
'error_log' => 'tmp/smtp.err',
'connection' => 'unix:tmp/authentication_milter_test.sock',
'umask' => '0000',
'connect_timeout' => 55,
'command_timeout' => 55,
'content_timeout' => 595,
'tempfail_on_error' => 1,
'tempfail_on_error_authenticated' => 1,
'tempfail_on_error_local' => 1,
'tempfail_on_error_trusted' => 1,
'#metric_connection' => 'unix:tmp/authentication_milter_test_metrics.sock',
'#metric_umask' => '0000',
'protocol' => 'smtp',
'smtp' => {
'sock_type' => 'unix',
'sock_path' => 'tmp/authentication_milter_smtp_out.sock',
'pipeline_limit' => '4',
},
'handlers' => $handler_config,
};
return $config;
}
sub _build_config_milter {
my ( $self, $handler_config ) = @_;
my $config = {
'_is_test' => 1,
'debug' => 1,
'dryrun' => 0,
'logtoerr' => 1,
'error_log' => 'tmp/milter.err',
'connection' => 'unix:tmp/authentication_milter_test.sock',
'umask' => '0000',
'connect_timeout' => 55,
'command_timeout' => 55,
'content_timeout' => 595,
'tempfail_on_error' => 1,
'tempfail_on_error_authenticated' => 1,
'tempfail_on_error_local' => 1,
'tempfail_on_error_trusted' => 1,
'#metric_connection' => 'unix:tmp/authentication_milter_test_metrics.sock',
'#metric_umask' => '0000',
'protocol' => 'milter',
'handlers' => $handler_config,
};
return $config;
}
sub new {
my ( $class, $args ) = @_;
my $self = {};
bless $self, $class;
$self->{ 'snapshots' } = {};
foreach my $arg ( qw{ prefix zonefile zonedata } ) {
$self->{ $arg } = $args->{ $arg } if exists $args->{ $arg };
}
croak 'prefix must be supplies' if ! exists $self->{ 'prefix' };
croak 'zonefile or zonedata cannot both be supplied' if ( exists $self->{ 'zonefile' } ) && ( exists $self->{ 'zonedata' });
$self->{ 'zonedata' } = q{} if ( ! exists $self->{ 'zonefile' } ) && ( ! exists $self->{ 'zonedata' });
my $protocol = $args->{ 'protocol' } // 'smtp';
if ( exists( $args->{ 'handler_config' } ) ) {
if ( $protocol eq 'smtp' ) {
set_config( $self->_build_config_smtp( $args->{ 'handler_config' } ) );
}
else {
set_config( $self->_build_config_milter( $args->{ 'handler_config' } ) );
}
}
$Mail::Milter::Authentication::Config::PREFIX = $self->{ 'prefix' };
Mail::Milter::Authentication::Config::setup_config;
my $config = get_config();
my $Resolver = Net::DNS::Resolver::Mock->new();
$Resolver->zonefile_read( $self->{ 'zonefile' } ) if exists $self->{ 'zonefile' };
$Resolver->zonefile_parse( $self->{ 'zonedata' } ) if exists $self->{ 'zonedata' };
$Mail::Milter::Authentication::Handler::TestResolver = $Resolver;
# Setup a new authentication milter object
my $authmilter = Mail::Milter::Authentication->new();
$authmilter->{'metric'} = Mail::Milter::Authentication::Metric->new($authmilter);
$authmilter->{'config'} = $config;
# if ( $protocol eq 'smtp' ) {
push @Mail::Milter::Authentication::ISA, 'Mail::Milter::Authentication::Protocol::SMTP';
#}
#else {
#push @Mail::Milter::Authentication::ISA, 'Mail::Milter::Authentication::Protocol::Milter';
#}
# Setup a fake server object
$authmilter->{ 'server' }->{ 'ppid' } = $PID;
# Load handlers
foreach my $name ( @{$config->{'load_handlers'}} ) {
$authmilter->load_handler( $name );
my $package = "Mail::Milter::Authentication::Handler::$name";
my $object = $package->new( $authmilter );
if ( $object->can( 'pre_loop_setup' ) ) {
$object->pre_loop_setup();
}
if ( $object->can( 'register_metrics' ) ) {
$authmilter->{'metric'}->register_metrics( $object->register_metrics() );
}
}
# Init handlers
my $callbacks_list = {};
my $callbacks = {};
my $handler = {};
my $object = {};
my $object_maker = {};
my $count = 0;
$authmilter->{'callbacks_list'} = $callbacks_list;
$authmilter->{'callbacks'} = $callbacks;
$authmilter->{'count'} = $count;
$authmilter->{'handler'} = $handler;
$authmilter->{'object'} = $object;
$authmilter->{'object_maker'} = $object_maker;
$authmilter->setup_handlers();
$self->{ 'authmilter' } = $authmilter;
$self->handler()->top_setup_callback();
$self->snapshot( '_new' );
return $self;
}
sub snapshot {
my ( $self, $name ) = @_;
my $snapshot = clone( $self->{ 'authmilter' } );
$self->{ 'snapshots' }->{ $name } = $snapshot;
}
sub switch {
my ( $self, $name ) = @_;
croak 'unknown snapshot' if ! exists ( $self->{ 'snapshots' }->{ $name } );
my $snapshot = clone( $self->{ 'snapshots' }->{ $name } );
$self->{ 'authmilter' } = $snapshot;
}
sub handler {
my ( $self ) = @_;
return $self->{ 'authmilter' }->{ 'handler' }->{ '_Handler' };
}
sub connect { ## no critic
my ( $self, $name, $ip ) = @_;
my $authmilter = $self->{ 'authmilter' };
my $ip_obj = eval{ Net::IP->new( $ip ) } // undef;
# An undef here should not make it through to handlers, however
# for testing we will allow this.
$self->handler()->remap_connect_callback( $name, $ip_obj );
return $self->handler()->top_connect_callback( $name, $self->handler()->{ 'ip_object' } );
}
sub helo {
my ( $self, $helo ) = @_;
$self->handler()->remap_helo_callback( $helo );
return $self->handler()->top_helo_callback( $self->handler()->{ 'helo_name' } );
}
sub mailfrom {
my ( $self, $from ) = @_;
return $self->handler()->top_envfrom_callback( $from );
}
sub rcptto {
my ( $self, $to ) = @_;
return $self->handler()->top_envrcpt_callback( $to );
}
sub header {
my ( $self, $key, $value, $original ) = @_;
$original = "$key: $value" if ! defined $original;
return $self->handler()->top_header_callback( $key, $value, $original );
}
sub end_of_headers {
my ( $self ) = @_;
return $self->handler()->top_eoh_callback();
}
sub body {
my ( $self, $body ) = @_;
return $self->handler()->top_body_callback( $body );
}
sub end_of_message {
my ( $self ) = @_;
return $self->handler()->top_eom_callback();
}
sub close { ## no critic
my ( $self ) = @_;
return $self->handler()->top_close_callback();
}
sub abort {
my ( $self ) = @_;
return $self->handler()->top_abort_callback();
}
sub addheader {
my ( $self ) = @_;
return $self->handler()->top_addheader_callback();
}
sub run {
my ( $self, $args ) = @_;
$self->switch( '_new' );
my $returncode;
$returncode = $self->connect( $args->{ 'connect_name' }, $args->{ 'connect_ip' } );
die 'connect' if ( $returncode != SMFIS_CONTINUE );
$returncode = $self->helo( $args->{ 'helo' } );
die 'helo' if ( $returncode != SMFIS_CONTINUE );
$returncode = $self->mailfrom( $args->{ 'mailfrom' } );
die 'mailfrom' if ( $returncode != SMFIS_CONTINUE );
foreach my $rcptto ( @{ $args->{ 'rcptto' } } ) {
$returncode = $self->rcptto( $rcptto );
die 'rcptto ' . $rcptto if ( $returncode != SMFIS_CONTINUE );
}
my $body = $args->{ 'body' };
$body =~ s/\r?\n/\n/g;
my @lines = split( /\n/, $body );
# Process headers
my $buffer = q{};
while ( my $line = shift @lines ) {
chomp $line;
last if $line eq q{};
if ( $line =~ /^\s/ ) {
$buffer .= "\n" . $line;
}
else {
if ( $buffer ) {
my ( $key, $value ) = split( ':', $buffer, 2 );
$key =~ s/\s+$//;
$value =~ s/^\s+//;
$returncode = $self->header( $key, $value );
die "header $key: $value" if ( $returncode != SMFIS_CONTINUE );
}
$buffer = $line;
}
}
if ( $buffer ) {
my ( $key, $value ) = split( ':', $buffer, 2 );
$key =~ s/\s+$//;
$value =~ s/^\s+//;
$returncode = $self->header( $key, $value );
die "header $key: $value" if ( $returncode != SMFIS_CONTINUE );
}
$returncode = $self->end_of_headers();
die 'eoh' if ( $returncode != SMFIS_CONTINUE );
$returncode = $self->body( join( "\n", @lines) . "\n" );
die 'body' if ( $returncode != SMFIS_CONTINUE );
$returncode = $self->end_of_message();
die 'body' if ( $returncode != SMFIS_CONTINUE );
$self->addheader();
# $self->close();
}
sub get_return {
my ( $self ) = @_;
return $self->handler()->get_return();
}
sub get_reject_mail {
my ( $self ) = @_;
return $self->handler()->get_reject_mail();
}
sub servername {
my ( $self ) = @_;
return 'handlertester.test.authmilter.org';
}
sub get_authresults_header {
my ( $self ) = @_;
# Build a Mail::AuthenticationReslts object
my $c_auth_headers = eval{ clone( $self->handler()->{ 'c_auth_headers'}->{'Authentication-Results'} ) } // [];
my $auth_headers = eval{ clone( $self->handler()->{ 'auth_headers'}->{'Authentication-Results'} ) } // [];
my @added_ar_headers = ( @{ $c_auth_headers }, @{ $auth_headers } );
my $header = Mail::AuthenticationResults::Header->new()->set_value( Mail::AuthenticationResults::Header::AuthServID->new()->set_value( $self->servername() ) );
foreach my $ar_header ( @added_ar_headers ) {
eval{ $ar_header->orphan(); }; # Remove parent for testing.
$header->add_child( $ar_header );
}
return $header;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Mail::Milter::Authentication::Tester::HandlerTester - Class for testing handlers
=head1 VERSION
version 4.20250811
=head1 SYNOPSIS
Emulates an Authentication Milter environment with methods for testing Handlers.
Can snapshot and restore state at any point.
=head1 DESCRIPTION
Make testing of Authentication Milter Handler modules easier.
=head1 NAME
Mail::Milter::Authentication::Tester::HandlerTester - Test harness for testing Authentication Milter Handlers
=head1 CONSTRUCTOR
=over
=item new( $args )
Instantiate a new HandlerTester object.
$args is a hashref with the following entries.
=over
=item prefix
Required
The Prefix path containing the authentication milter config file(s). This should contain
all configuration files required for your test, the main authentication_milter.json file
can be overridden by the handler_config option (see below).
This location should, for example, contain a valid mail-dmarc.ini for any tests using
the DMARC handler.
=item handler_config
If present, the config will be built from a generic default SMTP environment, with the given
HASHREF substituted as the Handler configuration. This eliminates the need to have a config file
for each handler configuration you wish to test.
=item zonedata
The zonefile data for use with Net::DNS::Resolver::Mock
=item zonefile
A zonefile for use with Net::DNS::Resolver::Mock
=back
=back
=head1 METHODS
=over
=item snapshot( $name )
Save a snapshot with the given name
=item switch( $name )
Restore state from the given snapshot
=item handler()
Returns the Handler object
=item connect( $name, $ip )
Call the connect callbacks with the given data.
Returns the value of get_return()
=item helo( $name )
Call the helo callbacks with the given data.
Returns the value of get_return();
=item mailfrom( $email )
Call the envfrom callbacks with the given data.
Returns the value of get_return();
=item rcptto( $email )
Call the envrcpt callbacks with the given data.
Returns the value of get_return();
=item header( $key, $value )
Call the header callbacks with the given data.
Returns the value of get_return()
=item end_of_headers()
Call the end_of_headers callbacks.
Returns the value of get_return()
=item body( $body_chunk )
Call the body callbacks with the given data.
Returns the value of get_return()
=item end_of_message()
Call the eom callbacks.
Returns the value of get_return()
=item close()
Call the close callbacks.
Returns the value of get_return()
=item abort()
Call the abort callbacks.
=item addheader()
Call the addheader callbacks.
=item run( $args )
Run with a given set of data as defined in $args hashref.
Dies if the mail would be rejected.
Arguments of $args are.
=over
=item connect_name
The name of the connecting server.
=item connect_ip
The ip address of the connecting server.
=item helo
The helo string.
=item mailfrom
The envelope MAILFROM address.
=item rcptto
Arrayref of the envelope RCPTTO addresses.
=item body
The email body.
=back
=item get_return()
Returns the value of get_return() from the current handler object.
=item get_reject_mail()
Returns the value of get_reject_mail() from the current handler object.
=item servername()
Returns a dummy authservid servername.
=item get_authresults_header()
Returns a Mail::AuthenticationResults::Header object representing the authentication results
header which would be added to the message.
=back
=head1 DEPENDENCIES
Carp
Clone
Mail::AuthenticationResults::Header
Mail::AuthenticationResults::Header::AuthServID
Mail::Milter::Authentication
Mail::Milter::Authentication::Protocol::Milter
Mail::Milter::Authentication::Protocol::SMTP
Mail::Milter::Authentication::Config
Module::Load
Net::DNS::Resolver::Mock
=head1 AUTHORS
Marc Bradshaw E<lt>marc@marcbradshaw.netE<gt>
=head1 COPYRIGHT
Copyright 2018
This library is free software; you may redistribute it and/or
modify it under the same terms as Perl itself.
=head1 AUTHOR
Marc Bradshaw <marc@marcbradshaw.net>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Marc Bradshaw.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut