File Coverage

blib/lib/Mail/DKIM/Verifier.pm

Criterion	Covered	Total	%
statement	199	232	85.7
branch	67	94	71.2
condition	24	39	61.5
subroutine	21	25	84.0
pod	5	14	35.7
total	316	404	78.2

package Mail::DKIM::Verifier;
use strict;
use warnings;
our $VERSION = '1.20240923'; # VERSION
# ABSTRACT: verifies a DKIM-signed message

# Copyright 2005-2009 Messiah College. All rights reserved.
# Jason Long

# Copyright (c) 2004 Anthony D. Urso. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

use Mail::DKIM::Signature;
use Mail::DKIM::DkSignature;
use Mail::Address;



use base 'Mail::DKIM::Common';
use Carp;
our $MAX_SIGNATURES_TO_PROCESS = 50;

sub init {
    my $self = shift;
    $self->SUPER::init;
    $self->{signatures} = [];
}

# @{$dkim->{signatures}}
#   array of L objects, representing all
#   parseable signatures found in the header,
#   ordered from the top of the header to the bottom.
#
# $dkim->{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.
#
# $dkim->{signature}
#   the L selected as the "best" signature.
#
# @{$dkim->{headers}}
#   array of strings, each member is one header, in its original format.
#
# $dkim->{algorithms}
#   array of algorithms, one for each signature being verified.
#
# $dkim->{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 'dkim-signature' ) {
        eval {
            local $SIG{__DIE__};
            my $signature = Mail::DKIM::Signature->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 'domainkey-signature' ) {
        eval {
            local $SIG{__DIE__};
            my $signature = Mail::DKIM::DkSignature->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 = shift;
    croak 'wrong number of arguments' unless ( @_ == 1 );
    my ($signature) = @_;

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

    # ignore signature headers once we've seen 50 or so
    # this protects against abuse.
    return if ( @{ $self->{signatures} } > $MAX_SIGNATURES_TO_PROCESS );

    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 => $self->{Debug_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;
}

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 ) )
    {
        # unsupported algorithm
        $self->{signature_reject_reason} = 'unsupported algorithm';
        if ( defined $signature->algorithm ) {
            $self->{signature_reject_reason} .= ' ' . $signature->algorithm;
        }
        return 0;
    }

    if ( $self->{Strict} ) {
        if ( $signature->algorithm eq 'rsa-sha1' ) {
            $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->identity,
            $empty_g_means_wildcard );

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

# returns true if the i= tag is an address with a domain matching or
# a subdomain of the d= tag
#
sub check_signature_identity {
    my ($signature) = @_;

    my $d = $signature->domain;
    my $i = $signature->identity;
    if ( defined($i) && $i =~ /\@([^@]*)$/ ) {
        return match_subdomain( $1, $d );
    }
    return 0;
}

sub match_subdomain {
    croak 'wrong number of arguments' unless ( @_ == 2 );
    my ( $subdomain, $superdomain ) = @_;

    my $tmp = substr( ".$subdomain", -1 - length($superdomain) );
    return ( lc ".$superdomain" eq lc $tmp );
}

#
# 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;
    }

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

    # 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;
    unless ( check_signature_identity($signature) ) {
        $self->{signature_reject_reason} = 'bad identity';
        return ( 'invalid', $self->{signature_reject_reason} );
    }

    # get public key
    my $pkey;
    eval { $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} );
    }

    # special handling for RSA signatures
    my $k = $pkey->get_tag('k') || 'rsa';
    if ($k eq 'rsa') {
        # 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 {
        $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";
        }
        elsif ( $E =~ /^FATAL: (.*) at / ) {
            $E = "Ed25519 $1";
        }
        $result  = 'fail';
        $details = $E;
    };
    return ( $result, $details );
}

sub finish_body {
    my $self = shift;

    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;
        $algorithm->signature->result( $result, $details );

        # collate results ... ignore failed signatures if we already got
        # one to pass
        if ( !$self->{result} || $result eq 'pass' ) {
            $self->{signature} = $algorithm->signature;
            $self->{result}    = $result;
            $self->{details}   = $details;
        }
    }
}


sub fetch_author_domain_policies {
    my $self = shift;
    use Mail::DKIM::AuthorDomainPolicy;

    return () unless $self->{headers_by_name}->{from};
    my @list = Mail::Address->parse( $self->{headers_by_name}->{from} );
    my @authors = map { $_->address } @list;

    # fetch the policies
    return map {
        Mail::DKIM::AuthorDomainPolicy->fetch(
            Protocol => 'dns',
            Author   => $_,
          )
    } @authors;
}


sub fetch_author_policy {
    my $self = shift;
    my ($author) = @_;
    use Mail::DKIM::DkimPolicy;

    # determine address found in the "From"
    $author ||= $self->message_originator->address;

    # fetch the policy
    return Mail::DKIM::DkimPolicy->fetch(
        Protocol => 'dns',
        Author   => $author,
    );
}


sub fetch_sender_policy {
    my $self = shift;
    use Mail::DKIM::DkPolicy;

    # determine addresses found in the "From" and "Sender" headers
    my $author = $self->message_originator->address;
    my $sender = $self->message_sender->address;

    # fetch the policy
    return Mail::DKIM::DkPolicy->fetch(
        Protocol => 'dns',
        Author   => $author,
        Sender   => $sender,
    );
}


sub policies {
    my $self = shift;

    my $sender_policy = eval { $self->fetch_sender_policy() };
    my $author_policy = eval { $self->fetch_author_policy() };
    return (
        $sender_policy ? $sender_policy : (),
        $author_policy ? $author_policy : (),
        $self->fetch_author_domain_policies(),
    );
}




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

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

1;

__END__