File Coverage

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

Criterion	Covered	Total	%
statement	270	305	88.5
branch	103	136	75.7
condition	48	71	67.6
subroutine	16	17	94.1
pod	2	9	22.2
total	439	538	81.6

package Mail::DKIM::ARC::Verifier;
use strict;
use warnings;
our $VERSION = '1.20240923'; # VERSION
# ABSTRACT: verifies an ARC-Sealed 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 base 'Mail::DKIM::Common';
use Mail::DKIM::ARC::MessageSignature;
use Mail::DKIM::ARC::Seal;
use Mail::Address;
use Carp;
our $MAX_SIGNATURES_TO_PROCESS = 50;

sub init {
    my $self = shift;
    $self->SUPER::init;
    $self->{signatures} = [];
    $self->{result}     = undef;    # we're done once this is set
}

# @{$arc->{signatures}}
#   array of L objects, representing all
#   parseable message signatures and seals found in the header,
#   ordered from the top of the header to the bottom.
#
# $arc->{signature_reject_reason}
#   simple string listing a reason, if any, for not using a signature.
#   This may be a helpful diagnostic if there is a signature in the header,
#   but was found not to be valid. It will be ambiguous if there are more
#   than one signatures that could not be used.
#
# @{$arc->{headers}}
#   array of strings, each member is one header, in its original format.
#
# $arc->{algorithms}
#   array of algorithms, one for each signature being verified.
#
# $arc->{result}
#   string; the result of the verification (see the result() method)
#

sub handle_header {
    my $self = shift;
    my ( $field_name, $contents, $line ) = @_;

    $self->SUPER::handle_header( $field_name, $contents );

    if ( lc($field_name) eq 'arc-message-signature' ) {
        eval {
            local $SIG{__DIE__};
            my $signature = Mail::DKIM::ARC::MessageSignature->parse($line);
            $self->add_signature($signature);
	    1
        } || do {

            # the only reason an error should be thrown is if the
            # signature really is unparse-able

            # otherwise, invalid signatures are caught in finish_header()

            chomp( my $E = $@ );
            $self->{signature_reject_reason} = $E;
        };
    }

    if ( lc($field_name) eq 'arc-seal' ) {
        eval {
            local $SIG{__DIE__};
            my $signature = Mail::DKIM::ARC::Seal->parse($line);
            $self->add_signature($signature);
	    1
        } || do {

            # the only reason an error should be thrown is if the
            # signature really is unparse-able

            # otherwise, invalid signatures are caught in finish_header()

            chomp( my $E = $@ );
            $self->{signature_reject_reason} = $E;
        };
    }

}

sub add_signature {
    my ( $self, $signature ) = @_;
    croak 'wrong number of arguments' unless ( @_ == 2 );

    return if $self->{result};    # already failed

    # Set verification time if we have one
    if ($self->{verify_time}) {
        $signature->set_verify_time($self->{verify_time});
    }

    push @{ $self->{signatures} }, $signature;

    unless ( $self->check_signature($signature) ) {
        $signature->result( 'invalid', $self->{signature_reject_reason} );
        return;
    }

    # signature looks ok, go ahead and query for the public key
    $signature->fetch_public_key;

    # create a canonicalization filter and algorithm
    my $algorithm_class =
      $signature->get_algorithm_class( $signature->algorithm );
    my $algorithm = $algorithm_class->new(
        Signature              => $signature,
        Debug_Canonicalization => $signature->isa('Mail::DKIM::ARC::Seal')
        ? $self->{AS_Canonicalization}
        : $self->{AMS_Canonicalization},
    );

    # push through the headers parsed prior to the signature header
    if ( $algorithm->wants_pre_signature_headers ) {

        # Note: this will include the signature header that led to this
        # "algorithm"...
        foreach my $head ( @{ $self->{headers} } ) {
            $algorithm->add_header($head);
        }
    }

    # save the algorithm
    $self->{algorithms} ||= [];
    push @{ $self->{algorithms} }, $algorithm;

 # check for bogus tags (should be done much earlier but better late than never)
 # tagkeys is uniq'd via a hash, rawtaglen counts all the tags
    my @tagkeys   = keys %{ $signature->{tags_by_name} };
    my $rawtaglen = $#{ $signature->{tags} };

    # crock: ignore empty clause after trailing semicolon
    $rawtaglen--
      if $signature->{tags}->[ $#{ $signature->{tags} } ]->{raw} =~ /^\s*$/;

    # duplicate tags
    if ( $rawtaglen != $#tagkeys ) {
        $self->{result}  = 'fail';                         # bogus
        $self->{details} = 'Duplicate tag in signature';
        return;
    }

    # invalid tag name
    if ( grep { !m{[a-z][a-z0-9_]*}i } @tagkeys ) {
        $self->{result}  = 'fail';                         # bogus
        $self->{details} = 'Invalid tag in signature';
        return;
    }

    if ( $signature->isa('Mail::DKIM::ARC::Seal') ) {
        my ($instance);
        $instance = $signature->instance() || '';

        if ( $instance !~ m{^\d+$} or $instance < 1 or $instance > $MAX_SIGNATURES_TO_PROCESS ) {
            $self->{result}  = 'fail';                                   # bogus
            $self->{details} = sprintf "Invalid ARC-Seal instance '%s'",
              $instance;
            return;
        }

        if ( $self->{seals}[$instance] ) {
            $self->{result} = 'fail';                                    # dup
            if ( $signature eq $self->{seals}[$instance] ) {
                $self->{details} = sprintf 'Duplicate ARC-Seal %d', $instance;
            }
            else {
                $self->{details} = sprintf 'Redundant ARC-Seal %d', $instance;
            }
            return;
        }

        $self->{seals}[$instance] = $signature;
    }
    elsif ( $signature->isa('Mail::DKIM::ARC::MessageSignature') ) {
        my $instance = $signature->instance() || '';

        if ( $instance !~ m{^\d+$} or $instance < 1 or $instance > $MAX_SIGNATURES_TO_PROCESS ) {
            $self->{result} = 'fail';    # bogus
            $self->{details} =
              sprintf "Invalid ARC-Message-Signature instance '%s'", $instance;
            return;
        }

        if ( $self->{messages}[$instance] ) {
            $self->{result} = 'fail';    # dup
            if ( $signature->as_string() eq
                $self->{messages}[$instance]->as_string() )
            {
                $self->{details} = sprintf 'Duplicate ARC-Message-Signature %d',
                  $instance;
            }
            else {
                $self->{details} = sprintf 'Redundant ARC-Message-Signature %d',
                  $instance;
            }
            return;
        }
        $self->{messages}[$instance] = $signature;
    }
}

sub check_signature {
    my $self = shift;
    croak 'wrong number of arguments' unless ( @_ == 1 );
    my ($signature) = @_;

    unless ( $signature->check_version ) {

        # unsupported version
        if ( defined $signature->version ) {
            $self->{signature_reject_reason} =
              'unsupported version ' . $signature->version;
        }
        else {
            $self->{signature_reject_reason} = 'missing v tag';
        }
        return 0;
    }

    unless ( $signature->algorithm
        && $signature->get_algorithm_class( $signature->algorithm )
        && ( !$self->{Strict} || $signature->algorithm ne 'rsa-sha1' )
      )    # no more SHA1 for us in strict mode
    {
        # unsupported algorithm
        $self->{signature_reject_reason} = 'unsupported algorithm';
        if ( defined $signature->algorithm ) {
            $self->{signature_reject_reason} .= ' ' . $signature->algorithm;
        }
        return 0;
    }

    unless ( $signature->check_canonicalization ) {

        # unsupported canonicalization method
        $self->{signature_reject_reason} = 'unsupported canonicalization';
        if ( defined $signature->canonicalization ) {
            $self->{signature_reject_reason} .=
              ' ' . $signature->canonicalization;
        }
        return 0;
    }

    unless ( $signature->check_protocol ) {

        # unsupported query protocol
        $self->{signature_reject_reason} =
          !defined( $signature->protocol )
          ? 'missing q tag'
          : 'unsupported query protocol, q=' . $signature->protocol;
        return 0;
    }

    unless ( $signature->check_expiration ) {

        # signature has expired
        $self->{signature_reject_reason} = 'signature is expired';
        return 0;
    }

    unless ( defined $signature->domain ) {

        # no domain specified
        $self->{signature_reject_reason} = 'missing d tag';
        return 0;
    }

    if ( $signature->domain eq '' ) {

        # blank domain
        $self->{signature_reject_reason} = 'invalid domain in d tag';
        return 0;
    }

    unless ( defined $signature->selector ) {

        # no selector specified
        $self->{signature_reject_reason} = 'missing s tag';
        return 0;
    }

    return 1;
}

sub check_public_key {
    my $self = shift;
    croak 'wrong number of arguments' unless ( @_ == 2 );
    my ( $signature, $public_key ) = @_;

    my $result = 0;
    eval {
        local $SIG{__DIE__};
        $@ = undef;

        # HACK- I'm indecisive here about whether I want the
        # check_foo functions to return false or to "die"
        # on failure

        # check public key's allowed hash algorithms
        $result =
          $public_key->check_hash_algorithm( $signature->hash_algorithm );

# HACK- DomainKeys signatures are allowed to have an empty g=
# tag in the public key
#        my $empty_g_means_wildcard = $signature->isa('Mail::DKIM::DkSignature');

        # check public key's granularity
        $result &&= $public_key->check_granularity( $signature->domain, 0 );

        #                $signature->instance, $empty_g_means_wildcard);

        die $@ if $@;
	1
    } || do {
        my $E = $@;
        chomp $E;
        $self->{signature_reject_reason} = "public key: $E";
    };
    return $result;
}

#
# called when the verifier has received the last of the message headers
# (body is still to come)
#
sub finish_header {
    my $self = shift;

    # Signatures we found and were successfully parsed are stored in
    # $self->{signatures}. If none were found, our result is "none".

    if ( @{ $self->{signatures} } == 0
        && !defined( $self->{signature_reject_reason} ) )
    {
        $self->{result} = 'none';
        return;
    }

    # check for duplicate AAR headers (dup AS and AMS checked in add_signature)
    my @aars = [];
    foreach my $hdr ( @{ $self->{headers} } ) {
        if ( my ($i) = $hdr =~ m{ARC-Authentication-Results:\s*i=(\d+)\s*;}i ) {
            if ( defined $aars[$i] ) {
                $self->{result} = 'fail';
                $self->{details} =
                  "Duplicate ARC-Authentication-Results header $1";
                return;
            }
            $aars[$i] = $hdr;
        }
    }

    foreach my $algorithm ( @{ $self->{algorithms} } ) {
        $algorithm->finish_header(
            Headers => $self->{headers},
            Chain   => 'pass'
        );
    }

    # stop processing signatures that are already known to be invalid
    @{ $self->{algorithms} } = grep {
        my $sig = $_->signature;
        !( $sig->result && $sig->result eq 'invalid' );
    } @{ $self->{algorithms} };

    if (   @{ $self->{algorithms} } == 0
        && @{ $self->{signatures} } > 0 )
    {
        $self->{result} = $self->{signatures}->[0]->result || 'invalid';
        $self->{details} = $self->{signatures}->[0]->{verify_details}
          || $self->{signature_reject_reason};
        return;
    }
}

sub _check_and_verify_signature {
    my $self = shift;
    my ($algorithm) = @_;

    # check signature
    my $signature = $algorithm->signature;

    if ( not $signature->get_tag('d') ) {    # All sigs must have a D tag
        $self->{signature_reject_reason} = 'missing D tag';
        return ( 'fail', $self->{signature_reject_reason} );
    }

    if ( not $signature->get_tag('b') ) {    # All sigs must have a B tag
        $self->{signature_reject_reason} = 'missing B tag';
        return ( 'fail', $self->{signature_reject_reason} );
    }

    if ( not $signature->isa('Mail::DKIM::ARC::Seal') ) {    # AMS tests
        unless ( $signature->get_tag('bh') ) {    # AMS must have a BH tag
            $self->{signature_reject_reason} = 'missing BH tag';
            return ( 'fail', $self->{signature_reject_reason} );
        }
        if ( ( $signature->get_tag('h') || '' ) =~ /arc-seal/i )
        {                                         # cannot cover AS
            $self->{signature_reject_reason} =
              'Arc-Message-Signature covers Arc-Seal';
            return ( 'fail', $self->{signature_reject_reason} );
        }
    }

    # AMS signature must not

    # get public key
    my $pkey;
    eval {
        local $SIG{__DIE__};
        $pkey = $signature->get_public_key;
	1
    } || do  {
        my $E = $@;
        chomp $E;
        $self->{signature_reject_reason} = "public key: $E";
        return ( 'invalid', $self->{signature_reject_reason} );
    };

    unless ( $self->check_public_key( $signature, $pkey ) ) {
        return ( 'invalid', $self->{signature_reject_reason} );
    }

    # make sure key is big enough
    my $keysize = $pkey->cork->size * 8;    # in bits
    if ( $keysize < 1024 && $self->{Strict} ) {
        $self->{signature_reject_reason} = "Key length $keysize too short";
        return ( 'fail', $self->{signature_reject_reason} );
    }

    # verify signature
    my $result;
    my $details;
    local $@ = undef;
    eval {
        local $SIG{__DIE__};
        $result = $algorithm->verify() ? 'pass' : 'fail';
        $details = $algorithm->{verification_details} || $@;
	1
    } || do {

        # see also add_signature
        chomp( my $E = $@ );
        if ( $E =~ /(OpenSSL error: .*?) at / ) {
            $E = $1;
        }
        elsif ( $E =~ /^(panic:.*?) at / ) {
            $E = "OpenSSL $1";
        }
        $result  = 'fail';
        $details = $E;
    };
    return ( $result, $details );
}

sub finish_body {
    my $self = shift;

    return if $self->{result};    # already failed

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

        # finish canonicalizing
        $algorithm->finish_body;

        my ( $result, $details ) =
          $self->_check_and_verify_signature($algorithm);

        # save the results of this signature verification
        $algorithm->{result}  = $result;
        $algorithm->{details} = $details;
        $self->{signature} ||= $algorithm->signature;    # something if we fail
        $algorithm->signature->result( $result, $details );
    }

    my $seals    = $self->{seals}    || [];
    my $messages = $self->{messages} || [];
    unless ( @$seals or @$messages ) {
        $self->{result}  = 'none';
        $self->{details} = 'no ARC headers found';
        return;
    }

    # determine if it's valid:
    # 5.1.1.5.  Determining the 'cv' Tag Value for ARC-Seal

    #    In order for a series of ARC sets to be considered valid, the
    #    following statements MUST be satisfied:

    #    1.  The chain of ARC sets must have structural integrity (no sets or
    #        set component header fields missing, no duplicates, excessive
    #        hops (cf.  Section 5.1.1.1.1), etc.);

    if ( $#$seals == 0 ) {
        $self->{result}  = 'fail';
        $self->{details} = 'missing ARC-Seal 1';
        return;
    }
    if ( $#$messages == 0 ) {
        $self->{result}  = 'fail';
        $self->{details} = 'missing ARC-Message-Signature 1';
        return;
    }

    if ( $#$messages > $#$seals ) {
        $self->{result}  = 'fail';
        $self->{details} = 'missing Arc-Seal ' . $#$messages;
        return;
    }

    foreach my $i ( 1 .. $#$seals ) {

# XXX - we should error if it's already present, but that's done above if at all
        if ( !$seals->[$i] ) {
            $self->{result}  = 'fail';
            $self->{details} = "missing ARC-Seal $i";
            return;
        }
        if ( !$messages->[$i] ) {
            $self->{result}  = 'fail';
            $self->{details} = "missing ARC-Message-Signature $i";
            return;
        }
    }

    # 2. All ARC-Seal header fields MUST validate;
    foreach my $i ( 1 .. $#$seals ) {
        my $result = $seals->[$i]->result();
        if ( $result ne 'pass' ) {
            $self->{signature} = $seals->[$i]->signature;
            $self->{result}    = $result;
            $self->{details}   = $seals->[$i]->result_detail();
            return;
        }
    }

    #    3.  All ARC-Seal header fields MUST have a chain value (cv=) status
    #        of "pass" (except the first which MUST be "none"); and
    my $cv = $seals->[1]->get_tag('cv');
    if ( !defined $cv or $cv ne 'none' ) {
        $self->{signature} = $seals->[1]->signature;
        $self->{result}    = 'fail';
        $self->{details}   = 'first ARC-Seal must be cv=none';
        return;
    }
    foreach my $i ( 2 .. $#$seals ) {
        my $cv = $seals->[$i]->get_tag('cv');
        if ( $cv ne 'pass' ) {
            $self->{signature} = $seals->[$i]->signature;
            $self->{result}    = 'fail';
            $self->{details}   = "wrong cv for ARC-Seal i=$i";
            return;
        }
    }

    #    4.  The newest (highest instance number (i=)) AMS header field MUST
    #        validate.
    my $result = $messages->[$#$seals]->result();
    if ( $result ne 'pass' ) {
        $self->{signature} = $messages->[$#$seals]->signature;
        $self->{result}    = $result;
        $self->{details}   = $messages->[$#$seals]->result_detail();
        return;
    }

    # Success!
    $self->{signature} = $seals->[$#$seals]->signature();
    $self->{result}    = 'pass';
    $self->{details}   = $seals->[$#$seals]->result_detail();
}

sub result_detail {
    my $self = shift;

    return 'none' if $self->{result} eq 'none';

    my @items;
    foreach my $signature ( @{ $self->{signatures} } ) {
        my $type =
            ref($signature) eq 'Mail::DKIM::ARC::Seal'             ? 'as'
          : ref($signature) eq 'Mail::DKIM::ARC::MessageSignature' ? 'ams'
          :   ref($signature);
        push @items,
            "$type."
          . ( $signature->instance()      || '' ) . '.'
          . ( $signature->domain()        || '(none)' ) . '='
          . ( $signature->result_detail() || '?' );
    }

    return $self->{result} . ' (' . join( ', ', @items ) . ')';
}



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

    return @{ $self->{signatures} };
}

1;

__END__