File Coverage

blib/lib/Mail/Milter/Authentication/Handler/Sanitize.pm

Criterion	Covered	Total	%
statement	104	118	88.1
branch	30	40	75.0
condition			n/a
subroutine	15	18	83.3
pod	2	12	16.6
total	151	188	80.3

package Mail::Milter::Authentication::Handler::Sanitize;
use 5.20.0;
use strict;
use warnings;
use Mail::Milter::Authentication::Pragmas;
# ABSTRACT: Handler class for Removing headers
our $VERSION = '3.20230629'; # VERSION
use base 'Mail::Milter::Authentication::Handler';
use List::MoreUtils qw{ uniq };

sub default_config {
    return {
        'hosts_to_remove' => [ 'example.com', 'example.net' ],
        'remove_headers'  => 'yes',
        'extra_auth_results_types' => ['X-Authentication-Results'],
    };
}

sub grafana_rows {
    my ( $self ) = @_;
    my @rows;
    push @rows, $self->get_json( 'Sanitize_metrics' );
    return \@rows;
}

sub register_metrics {
    return {
        'sanitize_remove_total' => 'The number Authentication Results headers removed',
    };
}

sub is_hostname_mine {
    my ( $self, $check_hostname ) = @_;
    my $config = $self->handler_config();

    return 0 if ! defined $check_hostname;

    if ( exists( $config->{'hosts_to_remove'} ) ) {
        foreach my $remove_hostname ( @{ $config->{'hosts_to_remove'} } ) {
            if ( $check_hostname =~ m/^(.*\.)?\Q${remove_hostname}\E$/i ) {
                return 1;
            }
        }
    }

    my $hostname = $self->get_my_hostname();
    my ($check_for) = $hostname =~ /^[^\.]+\.(.*)/;
    if ( $check_hostname =~ m/^(.*\.)?\Q${check_for}\E$/i ) {
        return 1;
    }

    my $authserv_id = $self->get_my_authserv_id();
    if ( fc( $check_hostname ) eq fc( $authserv_id ) ) {
        return 1;
    }

    return 0;
}

sub remove_auth_header {
    my ( $self, $index, $type ) = @_;
    $self->metric_count( 'sanitize_remove_total', {'header'=>$type} );
    if ( !exists( $self->{'remove_auth_headers'}->{$type} ) ) {
        $self->{'remove_auth_headers'}->{$type} = [];
    }
    push @{ $self->{'remove_auth_headers'}->{$type} }, $index;
}

{
    my $headers_to_remove = {
        'x-disposition-quarantine' => { silent => 1 },
    };

    sub add_header_to_sanitize_list {
        my ( $self, $header, $silent ) = @_;
        $headers_to_remove->{lc $header} = { silent => $silent };
    }

    sub get_headers_to_remove {
        my ( $self ) = @_;
        my @headers = sort keys $headers_to_remove->%*;
        return \@headers;
    }

    sub get_remove_header_settings {
        my ($self, $key) = @_;
        return $headers_to_remove->{lc $key};
    }
}

sub envfrom_callback {
    my ( $self, $env_from ) = @_;
    $self->{'auth_result_header_index'} = {};
    $self->{'remove_auth_headers'} = {};

    my $headers = {};
    foreach my $header ( sort @{ $self->get_headers_to_remove() } ) {
        $headers->{ lc $header } = {
            'index'  => 0,
            'silent' => $self->get_remove_header_settings($header)->{silent},
        };
    }
    $self->{'header_hash'} = $headers;
}

sub header_callback {
    my ( $self, $header, $value ) = @_;
    my $config = $self->handler_config();

    return if ( $self->is_trusted_ip_address() );
    return if ( lc $config->{'remove_headers'} eq 'no' );

    my @types = ('Authentication-Results');
    if ( exists $config->{extra_auth_results_types} ) {
        push @types, $config->{extra_auth_results_types}->@*;
    }
    for my $type (uniq sort @types) {

        # Sanitize Authentication-Results headers
        if ( lc $header eq lc $type ) {
            if ( !exists $self->{'auth_result_header_index'}->{$type} ) {
                $self->{'auth_result_header_index'}->{$type} = 0;
            }
            $self->{'auth_result_header_index'}->{$type} =
              $self->{'auth_result_header_index'}->{$type} + 1;

            my $authserv_id = '';
            eval {
                my $parsed = Mail::AuthenticationResults::Parser->new()->parse($value);
                $authserv_id = $parsed->value()->value();
            };
            if ( my $error = $@ ) {
                $self->handle_exception($error);
                $self->log_error("Error parsing existing Authentication-Results header: $value");
            }

            my $remove = 0;
            my $silent = lc $config->{'remove_headers'} eq 'silent';
            if ( $authserv_id ) {
                $remove = $self->is_hostname_mine($authserv_id);
            }
            else {
                # We couldn't parse the authserv_id, removing this header is the safest option
                # Add to X-Received headers for analysis later
                $remove = 1;
                $silent = 0;
            }

            if ( $remove ) {
                $self->remove_auth_header( $self->{'auth_result_header_index'}->{$type}, $type );
                if ( ! $silent ) {
                    my $forged_header =
                      '(Received '.$type.' header removed by '
                      . $self->get_my_hostname()
                      . ')' . "\n"
                      . '    '
                      . $value;
                    $self->append_header( 'X-Received-'.$type,
                        $forged_header );
                }
            }
        }
    }

    # Sanitize other headers
    foreach my $remove_header ( sort @{ $self->get_headers_to_remove() } ) {
        next if ( lc $remove_header ne lc $header );
        $self->{'header_hash'}->{ lc $header }->{'index'} = $self->{'header_hash'}->{ lc $header }->{'index'} + 1;
        $self->metric_count( 'sanitize_remove_total', {'header'=> lc $header} );

        if ( ! $self->{'header_hash'}->{ lc $header }->{'silent'} ) {
            my $forged_header =
              '(Received ' . $remove_header . ' header removed by '
              . $self->get_my_hostname()
              . ')' . "\n"
              . '    '
              . $value;
            $self->append_header( 'X-Received-' . $remove_header,
                $forged_header );
        }
    }
}

sub eom_callback {
    my ($self) = @_;
    my $config = $self->handler_config();
    return if ( lc $config->{'remove_headers'} eq 'no' );

    if ( exists( $self->{'remove_auth_headers'} ) ) {
        foreach my $type ( sort keys $self->{'remove_auth_headers'}->%* ) {
            foreach my $index ( reverse @{ $self->{'remove_auth_headers'}->{$type} } ) {
                $self->dbgout( 'RemoveAuthHeader', "$type $index", LOG_DEBUG );
                $self->change_header( $type, $index, q{} );
            }
       }
    }

    foreach my $remove_header ( sort @{ $self->get_headers_to_remove() } ) {
        my $max_index = $self->{'header_hash'}->{ lc $remove_header }->{'index'};
        if ( $max_index ) {
            for ( my $index = $max_index; $index > 0; $index-- ) {
                $self->dbgout( 'RemoveHeader', "$remove_header $index", LOG_DEBUG );
                $self->change_header( $remove_header, $index, q{} );
            }
        }
    }
}

sub close_callback {
    my ( $self ) = @_;
    delete $self->{'remove_auth_headers'};
    delete $self->{'auth_result_header_index'};
    delete $self->{'header_hash'};
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Mail::Milter::Authentication::Handler::Sanitize - Handler class for Removing headers

=head1 VERSION

version 3.20230629

=head1 DESCRIPTION

Remove unauthorized (forged) Authentication-Results headers from processed email.

=head1 CONFIGURATION

        "Sanitize" : {                                  | Config for the Sanitize Module
                                                        | Remove conflicting Auth-results headers from inbound mail
            "hosts_to_remove" : [                       | Hostnames (including subdomains thereof) for which we
                "example.com",                          | want to remove existing authentication results headers.
                "example.net"
            ],
            "remove_headers" : "yes",                   | Remove headers with conflicting host names (as defined above)
                                                        | "no" : do not remove
                                                        | "yes" : remove and add a header for each one
                                                        | "silent" : remove silently
                                                        | Does not run for trusted IP address connections

            "extra_auth_results_types" : [              | List of extra Authentication-Results style headers which we
                "X-Authentication-Results",             | want to treat as Authentication-Results and sanitize.
            ],
        }

=head1 AUTHOR

Marc Bradshaw <[e-mail]>

=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