File Coverage

blib/lib/Mail/DKIM/ARC/Signer.pm

Criterion	Covered	Total	%
statement	166	268	61.9
branch	67	122	54.9
condition	9	33	27.2
subroutine	16	25	64.0
pod	11	16	68.7
total	269	464	57.9

package Mail::DKIM::ARC::Signer;
use strict;
use warnings;
our $VERSION = '1.20230911'; # VERSION
# ABSTRACT: generates a DKIM signature for a message

# Copyright 2017 FastMail Pty Ltd.  All Rights Reserved.
# Bron Gondwana

# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

use Mail::DKIM::PrivateKey;
use Mail::DKIM::ARC::MessageSignature;
use Mail::DKIM::ARC::Seal;
use Mail::AuthenticationResults::Parser;
use Mail::AuthenticationResults::Header::AuthServID;


use base 'Mail::DKIM::Common';
use Carp;

# PROPERTIES
#
# public:
#
# $signer->{Algorithm}
#   identifies what algorithm to use when signing the message
#   default is "rsa-sha256"
#
# $signer->{Domain}
#   identifies what domain the message is signed for
#
# $signer->{SrvId}
#   identifies what authserv-id is in the A-R headers
#
# $signer->{KeyFile}
#   name of the file containing the private key used to sign
#
# $signer->{Policy}
#   a signing policy (of type Mail::DKIM::SigningPolicy)
#
# $signer->{Selector}
#   identifies name of the selector identifying the key
#
# $signer->{Key}
#   the loaded private key
#
# private:
#
# $signer->{algorithms} = []
#   an array of algorithm objects... an algorithm object is created for
#   each signature being added to the message
#
# $signer->{result}
#   result of the signing policy: "signed" or "skipped"
#
# $signer->{details}
#   why we skipped this signature
#
# $signer->{signature}
#   the created signature (of type Mail::DKIM::Signature)

sub init {
    my $self = shift;
    $self->SUPER::init;

    if ( defined $self->{KeyFile} ) {
        $self->{Key} ||=
          Mail::DKIM::PrivateKey->load( File => $self->{KeyFile} );
    }

    unless ( $self->{'Algorithm'} ) {

        # use default algorithm
        $self->{'Algorithm'} = 'rsa-sha256';
    }
    unless ( $self->{'Domain'} ) {

        # use default domain
        $self->{'Domain'} = 'example.org';
    }
    unless ( $self->{'SrvId'} ) {

        # use default domain
        $self->{'SrvId'} = $self->{'Domain'};
    }
    unless ( $self->{'Selector'} ) {

        # use default selector
        $self->{'Selector'} = 'unknown';
    }
    $self->{result} = '?';    # better update this before we finish
    die 'Invalid signing algorithm'
      unless $self->{Algorithm} eq 'rsa-sha256';    # add ed25519 sometime
    die 'Need a valid chain value'
      unless $self->{Chain} and $self->{Chain} =~ m{^(pass|fail|none|ar)$};
}

sub finish_header {
    my $self = shift;

    # add the AAR header
    my @aar;
    my @ams;
    my @as;

    my $ar;
    HEADER:
    foreach my $header ( @{ $self->{headers} } ) {
        $header =~ s/[\r\n]+$//;
        if ( $header =~ m/^Authentication-Results:/ ) {
            my ( $arval ) = $header =~ m/^Authentication-Results:[^;]*;[\t ]*(.*)/is;
            my $parsed;
	    eval {
		$parsed= Mail::AuthenticationResults::Parser->new
		    ->parse( $header );
		1
	    } || do {
		my $error = $@;
		warn "Authentication-Results Header parse error: $error\n$header";
		next HEADER;
            };
            my $ardom = $parsed->value->value;

            next
              unless "\L$ardom" eq $self->{SrvId};   # make sure it's our domain

            $arval =~ s/;?\s*$//;    # ignore trailing semicolon and whitespace
            # preserve leading fold if there is one, otherwise set one leading space
            $arval =~ s/^\s*/ / unless ($arval =~ m/^\015\012/);
            if ($ar) {
                $ar .= ";$arval";
            }
            else {
                $ar = "$ardom;$arval";
            }

            # get chain value from A-R header
            $self->{Chain} = $1
              if $self->{Chain} eq 'ar' and $arval =~ m{\barc=(none|pass|fail)};

        }
        else {
            # parse ARC headers to make sure we have completeness

            if ( $header =~ m/^ARC-/ ) {
                if ( !$ar ) {
                    $self->{result} = 'skipped';
                    $self->{details} =
                      'ARC header seen before Authentication-Results';
                    return;
                }
                if ( $self->{Chain} eq 'ar' ) {
                    $self->{result} = 'skipped';
                    $self->{details} =
                      'No ARC result found in Authentication-Results';
                    return;
                }

            }

            if ( $header =~ m/^ARC-Seal:/ ) {
                my $seal = Mail::DKIM::ARC::Seal->parse($header);
                my $i    = $seal->instance;
                if ( $as[$i] ) {
                    $self->{result}        = 'skipped';
                    $self->{details} = "Duplicate ARC-Seal $i";
                    return;
                }
                $as[$i] = $seal;
            }
            elsif ( $header =~ m/^ARC-Message-Signature:/ ) {
                my $sig = Mail::DKIM::ARC::MessageSignature->parse($header);
                my $i   = $sig->instance;
                if ( $ams[$i] ) {
                    $self->{result} = 'skipped';
                    $self->{details} =
                      "Duplicate ARC-Message-Signature $i";
                    return;
                }
                $ams[$i] = $sig;
            }
            elsif ( $header =~ m/^ARC-Authentication-Results:\s*i=(\d+)/ ) {
                my $i = $1;
                if ( $aar[$i] ) {
                    $self->{result} = 'skipped';
                    $self->{details} =
                      "Duplicate ARC-Authentication-Results $i";
                    return;
                }

                $aar[$i] = $header;
            }
        }
    }

    unless ($ar) {
        $self->{result}        = 'skipped';
        $self->{details} = 'No authentication results seen';
        return;
    }

    $self->{Chain} = 'none' if ($self->{Chain} eq 'ar');

    if ( $#ams > $#as ) {
        $self->{result}        = 'skipped';
        $self->{details} = 'More message signatures than seals';
        return;
    }
    if ( $#aar > $#as ) {
        $self->{result}        = 'skipped';
        $self->{details} = 'More authentication results than seals';
        return;
    }

    foreach my $i ( 1 .. $#as ) {
        unless ( $as[$i] ) {
            $self->{result}        = 'skipped';
            $self->{details} = "Missing ARC-Seal $i";
            return;
        }
        unless ( $ams[$i] ) {
            $self->{result}        = 'skipped';
            $self->{details} = "Missing Arc-Message-Signature $i";
            return;
        }

        # don't care about authentication results, they are compulsary
    }

    $self->{_Instance} = @as || 1;    # next instance value

    # first add the AAR header
    $self->{_AAR} = "ARC-Authentication-Results: i=$self->{_Instance}; $ar";
    unshift @{ $self->{headers} }, $self->{_AAR};

    # set up the signer for AMS
    $self->add_signature(
        Mail::DKIM::ARC::MessageSignature->new(
            Algorithm => $self->{Algorithm},
            Headers   => $self->headers,
            Instance  => $self->{_Instance},
            Method    => 'relaxed/relaxed',
            Domain    => $self->{Domain},
            Selector  => $self->{Selector},
            Key       => $self->{Key},
            KeyFile   => $self->{KeyFile},
            ( $self->{Timestamp} ? ( Timestamp => $self->{Timestamp} ) : () ),
            ( $self->{Expiration} ? ( Expiration => $self->{Expiration} ) : () ),
            (
                $self->{'Tags'} ? ( Tags => $self->{'Tags'} )
                : ()
            ),
        )
    );

    foreach my $algorithm ( @{ $self->{algorithms} } ) {

        # output header as received so far into canonicalization
        foreach my $header ( @{ $self->{headers} } ) {
            $algorithm->add_header($header);
        }
        $algorithm->finish_header( Headers => $self->{headers} );
    }
}

sub finish_body {
    my $self = shift;

    if ( $self->{result} eq 'skipped' ) {    # already failed
        $self->{_AS} = undef;
        return;
    }

    foreach my $algorithm ( @{ $self->{algorithms} } ) {

        # finished canonicalizing
        $algorithm->finish_body;

        # load the private key file if necessary
        my $signature = $algorithm->signature;
        my $key =
             $signature->{Key}
          || $signature->{KeyFile}
          || $self->{Key}
          || $self->{KeyFile};
        if ( defined($key) && !ref($key) ) {
            $key = Mail::DKIM::PrivateKey->load( File => $key );
        }
        $key
          or die "no key available to sign with\n";

        # compute signature value
        my $signb64 = $algorithm->sign($key);
        $signature->data($signb64);

        # insert linebreaks in signature data, if desired
        $signature->prettify_safe();

        $self->{_AMS} = $signature->as_string();
        unshift @{ $self->{headers} }, $self->{_AMS};
    }

    # reset the internal state
    $self->{signatures} = [];
    $self->{algorithms} = [];

    $self->add_signature(
        Mail::DKIM::ARC::Seal->new(
            Algorithm => $self->{Algorithm},
            Chain     => $self->{Chain},
            Headers   => $self->headers,
            Instance  => $self->{_Instance},
            Domain    => $self->{Domain},
            Selector  => $self->{Selector},
            Key       => $self->{Key},
            KeyFile   => $self->{KeyFile},
            ( $self->{Timestamp} ? ( Timestamp => $self->{Timestamp} ) : () ),
            ( $self->{Expiration} ? ( Expiration => $self->{Expiration} ) : () ),
            (
                $self->{'SealTags'} ? ( Tags => $self->{'SealTags'} )
                : ()
            ),

        )
    );

    foreach my $algorithm ( @{ $self->{algorithms} } ) {

        # output header as received so far into canonicalization
        foreach my $header ( @{ $self->{headers} } ) {
            $algorithm->add_header($header);
        }

        # chain needed for seal canonicalization
        $algorithm->finish_header(
            Headers => $self->{headers},
            Chain   => $self->{Chain}
        );

        # no body is required for ARC-Seal
        # finished canonicalizing
        $algorithm->finish_body;

        # load the private key file if necessary
        my $signature = $algorithm->signature;
        my $key =
             $signature->{Key}
          || $signature->{KeyFile}
          || $self->{Key}
          || $self->{KeyFile};
        if ( defined($key) && !ref($key) ) {
            $key = Mail::DKIM::PrivateKey->load( File => $key );
        }
        $key
          or die "no key available to sign ARC-Seal\n";

        # compute signature value
        my $signb64 = $algorithm->sign($key);
        $signature->data($signb64);

        # insert linebreaks in signature data, if desired
        $signature->prettify_safe();

        $self->{_AS} = $signature->as_string();
    }

    $self->{result} = 'sealed';
}


sub add_signature {
    my $self      = shift;
    my $signature = shift;

    # create a canonicalization filter and algorithm
    my $algorithm_class =
      $signature->get_algorithm_class( $signature->algorithm )
      or die 'unsupported algorithm ' . ( $signature->algorithm || '' ) . "\n";
    my $algorithm = $algorithm_class->new(
        Signature              => $signature,
        Debug_Canonicalization => $self->{Debug_Canonicalization},
    );
    push @{ $self->{algorithms} }, $algorithm;
    return;
}


sub algorithm {
    my $self = shift;
    if ( @_ == 1 ) {
        $self->{Algorithm} = shift;
    }
    return $self->{Algorithm};
}


sub domain {
    my $self = shift;
    if ( @_ == 1 ) {
        $self->{Domain} = shift;
    }
    return $self->{Domain};
}



# these are headers that "should" be included in the signature,
# according to the DKIM spec.
my @DEFAULT_HEADERS = qw(From Sender Reply-To Subject Date
  Message-ID To Cc MIME-Version
  Content-Type Content-Transfer-Encoding Content-ID Content-Description
  Resent-Date Resent-From Resent-Sender Resent-To Resent-cc
  Resent-Message-ID
  In-Reply-To References
  List-Id List-Help List-Unsubscribe List-Subscribe
  List-Post List-Owner List-Archive);

sub process_headers_hash {
    my $self = shift;
    my @headers;

    # these are the header fields we found in the message we're signing
    my @found_headers = @{ $self->{header_field_names} };

    # Convert all keys to lower case
    foreach my $header ( keys %{ $self->{'ExtendedHeaders'} } ) {
        next if $header eq lc $header;
        if ( exists $self->{'ExtendedHeaders'}->{ lc $header } ) {

            # Merge
            my $first  = $self->{'ExtendedHeaders'}->{ lc $header };
            my $second = $self->{'ExtendedHeaders'}->{$header};
            if ( $first eq '+' || $second eq '+' ) {
                $self->{'ExtendedHeaders'}->{ lc $header } = '+';
            }
            elsif ( $first eq '*' || $second eq '*' ) {
                $self->{'ExtendedHeaders'}->{ lc $header } = '*';
            }
            else {
                $self->{'ExtendedHeaders'}->{ lc $header } = $first + $second;
            }
        }
        else {
            # Rename
            $self->{'ExtendedHeaders'}->{ lc $header } =
              $self->{'ExtendedHeaders'}->{$header};
        }
        delete $self->{'ExtendedHeaders'}->{$header};
    }

    # Add the default headers
    if ( !$self->{'NoDefaultHeaders'} ) {
        foreach my $default (@DEFAULT_HEADERS) {
            if ( !exists $self->{'ExtendedHeaders'}->{ lc $default } ) {
                $self->{'ExtendedHeaders'}->{ lc $default } = '*';
            }
        }
    }

    # Build a count of found headers
    my $header_counts = {};
    foreach my $header (@found_headers) {
        if ( !exists $header_counts->{ lc $header } ) {
            $header_counts->{ lc $header } = 1;
        }
        else {
            $header_counts->{ lc $header } = $header_counts->{ lc $header } + 1;
        }
    }

    foreach my $header ( sort keys %{ $self->{'ExtendedHeaders'} } ) {
        my $want_count = $self->{'ExtendedHeaders'}->{$header};
        my $have_count = $header_counts->{ lc $header } || 0;
        my $add_count  = 0;
        if ( $want_count eq '+' ) {
            $add_count = $have_count + 1;
        }
        elsif ( $want_count eq '*' ) {
            $add_count = $have_count;
        }
        else {
            if ( $want_count > $have_count ) {
                $add_count = $have_count;
            }
            else {
                $add_count = $want_count;
            }
        }
        for ( 1 .. $add_count ) {
            push @headers, $header;
        }
    }
    return join( ':', @headers );
}

sub extended_headers {
    my $self = shift;
    $self->{'ExtendedHeaders'} = shift;
    return;
}

sub headers {
    my $self = shift;
    croak 'unexpected argument' if @_;

    if ( exists $self->{'ExtendedHeaders'} ) {
        return $self->process_headers_hash();
    }

    # these are the header fields we found in the message we're signing
    my @found_headers = @{ $self->{header_field_names} };

    # these are the headers we actually want to sign
    my @wanted_headers;
    if ( !$self->{'NoDefaultHeaders'} ) {
        @wanted_headers = @DEFAULT_HEADERS;
    }
    if ( $self->{Headers} ) {
        push @wanted_headers, split /:/, $self->{Headers};
    }

    my @headers =
      grep {
        my $a = $_;
        scalar grep { lc($a) eq lc($_) } @wanted_headers
      } @found_headers;
    return join( ':', @headers );
}

# return nonzero if this is header we should sign
sub want_header {
    my $self = shift;
    my ($header_name) = @_;

    #TODO- provide a way for user to specify which headers to sign
    return scalar grep { lc($_) eq lc($header_name) } @DEFAULT_HEADERS;
}


sub key {
    my $self = shift;
    if (@_) {
        $self->{Key}     = shift;
        $self->{KeyFile} = undef;
    }
    return $self->{Key};
}


sub key_file {
    my $self = shift;
    if (@_) {
        $self->{Key}     = undef;
        $self->{KeyFile} = shift;
    }
    return $self->{KeyFile};
}



sub selector {
    my $self = shift;
    if ( @_ == 1 ) {
        $self->{Selector} = shift;
    }
    return $self->{Selector};
}


sub signatures {
    my $self = shift;
    croak 'no arguments allowed' if @_;
    return map { $_->signature } @{ $self->{algorithms} };
}


sub as_string {
    my $self = shift;
    return '' unless $self->{_AS};    # skipped, no signature

    return join( "\015\012", $self->{_AS}, $self->{_AMS}, $self->{_AAR}, '' );
}


sub as_strings {
    my $self = shift;
    return ( $self->{_AS}, $self->{_AMS}, $self->{_AAR} );
}

1;

__END__