File Coverage

blib/lib/Mail/DKIM/AuthorDomainPolicy.pm

Criterion	Covered	Total	%
statement	28	77	36.3
branch	5	28	17.8
condition	2	27	7.4
subroutine	8	16	50.0
pod	8	12	66.6
total	51	160	31.8

package Mail::DKIM::AuthorDomainPolicy;
use strict;
use warnings;
our $VERSION = '1.20230630'; # VERSION
# ABSTRACT: represents an Author Domain Signing Practices (ADSP) record

# Copyright 2005-2009 Messiah College.
# 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 base 'Mail::DKIM::Policy';

# base class is used for parse(), as_string()

use Mail::DKIM::DNS;


sub fetch {
    my $class = shift;
    my %prms  = @_;

    my $self;
    my $had_error= not eval {
        local $SIG{__DIE__};
        $self= $class->SUPER::fetch(%prms);
	1
    };
    my $E = $@;

    if ( $self && !$self->is_implied_default_policy ) {
        return $self;
    }

    # didn't find a policy; check the domain itself
    {
        #FIXME- not good to have this code duplicated between
        #here and get_lookup_name()
        #
        if ( $prms{Author} && !$prms{Domain} ) {
            $prms{Domain} = ( $prms{Author} =~ /\@([^@]*)$/ and $1 );
        }

        unless ( $prms{Domain} ) {
            die "no domain to fetch policy for\n";
        }

        my @resp = Mail::DKIM::DNS::query( $prms{Domain}, 'MX' );
        if ( !@resp && $@ eq 'NXDOMAIN' ) {
            return $class->nxdomain_policy;
        }
    }

    die $E if $had_error;
    return $self;
}

# get_lookup_name() - determine name of record to fetch
#
sub get_lookup_name {
    my $self = shift;
    my ($prms) = @_;

    # in ADSP, the record to fetch is determined based on the From header

    if ( $prms->{Author} && !$prms->{Domain} ) {
        $prms->{Domain} = ( $prms->{Author} =~ /\@([^@]*)$/ and $1 );
    }

    unless ( $prms->{Domain} ) {
        die "no domain to fetch policy for\n";
    }

    # IETF seems poised to create policy records this way
    return '_adsp._domainkey.' . $prms->{Domain};
}


sub new {
    my $class = shift;
    return $class->parse( String => '' );
}


#undocumented private class method
our $DEFAULT_POLICY;

sub default {
    my $class = shift;
    $DEFAULT_POLICY ||= $class->new;
    return $DEFAULT_POLICY;
}

#undocumented private class method
our $NXDOMAIN_POLICY;

sub nxdomain_policy {
    my $class = shift;
    if ( !$NXDOMAIN_POLICY ) {
        $NXDOMAIN_POLICY = $class->new;
        $NXDOMAIN_POLICY->policy('NXDOMAIN');
    }
    return $NXDOMAIN_POLICY;
}


sub apply {
    my $self = shift;
    my ($dkim) = @_;

    # first_party indicates whether there is a DKIM signature with
    # a d= tag matching the address in the From: header
    my $first_party;

    my @passing_signatures =
      grep { $_->result && $_->result eq 'pass' } $dkim->signatures;

    foreach my $signature (@passing_signatures) {
        my $author_domain = $dkim->message_originator->host;
        if ( lc $author_domain eq lc $signature->domain ) {

            # found a first party signature
            $first_party = 1;
            last;
        }
    }

    return 'accept' if $first_party;
    return 'reject' if ( $self->signall_strict );

    return 'neutral';
}


sub is_implied_default_policy {
    my $self           = shift;
    my $default_policy = ref($self)->default;
    return ( $self == $default_policy );
}


sub location {
    my $self = shift;
    return $self->{Domain};
}

sub name {
    return 'ADSP';
}


sub policy {
    my $self = shift;

    (@_)
      and $self->{tags}->{dkim} = shift;

    if ( defined $self->{tags}->{dkim} ) {
        return $self->{tags}->{dkim};
    }
    else {
        return 'unknown';
    }
}


sub signall {
    my $self = shift;

    return $self->policy
      && ( $self->policy =~ /all/i );
}


sub signall_strict {
    my $self = shift;

    return $self->policy
      && ( $self->policy =~ /discardable/i );
}

1;

__END__