#!/usr/bin/perl
=pod

=head1 NAME

Spline::DMARC - Methods to check the DMARC policy of mails.

=head1 SYNOPSIS

    use Spline::DMARC qw(...);

    $policy = get_dmarc_policy($domain);
    $would_reject = check_addresses($from); 

=head1 DESCRIPTION

=cut

package Spline::DMARC;

use strict;
use warnings;

use Mail::DMARC::PurePerl;
use Email::Address::XS;
use Spline::Log qw(info debug);

use base 'Exporter';
our @EXPORT = qw();
our @EXPORT_OK = qw(
    check_addresses
    get_dmarc_policy
); 

=head2 get_dmarc_policy

    $policy = get_dmarc_policy($domain);

Get the DMARC policy for the specified domain. It will only return the
"p" value ('reject', 'none', ...) or the "sp" value (if the policy is
defined on a parent domain).

If there is no DMARC policy defined, 'none' is returned.

=cut

sub get_dmarc_policy($) {
    my $domain = shift;
    my $effective_p = 'none';

    debug "Checking DMARC policy for $domain";

    my $dmarc;
    eval {
        $dmarc = Mail::DMARC::PurePerl->new(
            header_from => $domain,
        );
    };

    if ($@) {
        chomp($@);
        debug "Error: $@";
        info "Skipping invalid domain: $domain";
    }
    elsif ($dmarc->exists_in_dns()) {
        my $policy = $dmarc->discover_policy();
    
        if (defined $policy && $policy->is_valid()) {
            if ($dmarc->is_subdomain && defined $policy->sp) {
                 debug 'Found policy on parent domain, using sp: ' . $policy->sp;
                 $effective_p = $policy->sp;
            }
            else {
                 debug 'Found policy: ' . $policy->p;
                 $effective_p = $policy->p;
            }
        }
    }
    else {
        debug 'No policy found';
    }

    return $effective_p;
}

=head2 check_addresses

    $would_reject = check_addresses($from);

Check if any of the addresses in the specified from header has a DMARC
policy with the value 'reject'. This would cause the messasge to
bounce on all DMARC respecting receivers (like hotmail) after mailman
resends it.

We do not try to validate the DMARC policy, because it will always
fail after mailman, because the Envelop-From and From header will not
match.

If there is a policy defined with the value 'reject', this method
returns 1. If there is no policy or a policy with any other value then
'reject', this method returns 0.

=cut

sub check_addresses($) {
    my $from = shift;

    my @addresses = Email::Address::XS->parse($from);
    foreach my $addr (@addresses) {
        my $policy = get_dmarc_policy($addr->host);
        if ($policy eq 'reject') {
            info '"' . $addr->host . '" has reject policy!';
            return 1;
        }
    }
    
    return 0;
}

=head1 AUTHOR

Alexander Sulfrian <alex@spline.inf.fu-berlin.de>

=cut

1;
# vim: set et tabstop=4 tw=70: