#!perl -w

=head1 NAME

Domain-based Message Authentication, Reporting and Conformance

=head1 SYNOPSIS

DMARC is a reliable means to authenticate email.

=head1 DESCRIPTION

From the DMARC Draft: "DMARC operates as a policy layer atop DKIM and SPF. These technologies are the building blocks of DMARC as each is widely deployed, supported by mature tools, and is readily available to both senders and receivers. They are complementary, as each is resilient to many of the failure modes of the other."

DMARC provides a way to exchange authentication information and policies among mail servers.

DMARC benefits domain owners by preventing others from impersonating them. A domain owner can reliably tell other mail servers that "it it doesn't originate from this list of servers (SPF) and it is not signed (DKIM), then [ignore|quarantine|reject] it." DMARC also provides domain owners with a means to receive feedback and determine that their policies are working as desired.

DMARC benefits mail server operators by providing them with a more reliable (than SPF or DKIM alone) means to block forged emails. Is that message really from PayPal, Chase, Gmail, or Facebook? Since those organizations publish DMARC policies, operators have a definitive means to know.

=head1 HOWTO

=head2 Protect a domain with DMARC

See Section 10 of the draft: Domain Owner Actions

 1. Deploy DKIM & SPF
 2. Ensure identifier alignment.
 3. Publish a "monitor" record, ask for data reports
 4. Roll policies from monitor to reject

=head3 Publish a DMARC policy

_dmarc  IN TXT "v=DMARC1; p=reject; rua=mailto:dmarc-feedback@example.com;"

 v=DMARC1;    (version)
 p=none;      (disposition policy : reject, quarantine, none (monitor))
 sp=reject;   (subdomain policy: default, same as p)
 adkim=s;     (dkim alignment: s=strict, r=relaxed)
 aspf=r;      (spf  alignment: s=strict, r=relaxed)
 rua=mailto: dmarc-feedback@example.com; (aggregate reports)
 ruf=mailto: dmarc-feedback@example.com; (forensic reports)
 rf=afrf;     (report format: afrf, iodef)
 ri=8400;     (report interval)
 pct=50;      (percent of messages to filter)

=head2 Validate messages with DMARC

1. install Mail::DMARC

2. install this plugin

3. activate this plugin. (add to config/plugins, listing it after SPF & DKIM. Check that SPF and DKIM are configured to not reject mail.


=head1 MORE INFORMATION

http://www.dmarc.org/draft-dmarc-base-00-02.txt

https://github.com/smtpd/qpsmtpd/wiki/DMARC-FAQ

=head1 TODO

 reject messages with multiple From: headers

=head1 AUTHORS

 2013 - Matt Simerson <msimerson@cpan.org>

=cut

use strict;
use warnings;

use Qpsmtpd::Constants;

sub register {
    my ($self, $qp, @args) = @_;

    $self->log(LOGERROR, "Bad arguments") if @args % 2;
    $self->{_args} = {@args};

    $self->{_args}{reject} = 1 if !defined $self->{_args}{reject};
    $self->{_args}{reject_type} ||= 'perm';
    $self->{_args}{p_vals} = {map { $_ => 1 } qw/ none reject quarantine /};

    eval 'require Mail::DMARC::PurePerl';
    if ( $@ ) {
        $self->log(LOGERROR, "failed to load Mail::DMARC::PurePerl" );
    }
    else {
        $self->{_dmarc} = Mail::DMARC::PurePerl->new();
        $self->register_hook('data_post_headers', 'data_post_handler');
    };
}

sub data_post_handler {
    my ($self, $transaction) = @_;

    if ( $self->qp->connection->relay_client() ) {
        $self->log(LOGINFO, "skip, relay client" );
        return DECLINED;  # disable reporting to ourself
    };

    my $dmarc = $self->{_dmarc};
    $dmarc->init();
    my $from = $transaction->header->get('From');
    if ( ! $from ) {
        $self->log(LOGINFO, "skip, null sender" );
        return $self->get_reject("empty from address, null sender?");
    };
    eval { $dmarc->header_from_raw( $from ); };
    if ( $@ ) {
        $self->log(LOGERROR, "unparseable from header: $from" );
        return $self->get_reject("unparseable from header");
    };
    my @recipients = $transaction->recipients;
    eval { $dmarc->envelope_to( lc $recipients[0]->host ); }; # optional
    eval { $dmarc->envelope_from( $transaction->sender->host ); }; # may be <>
    $dmarc->spf( $transaction->notes('dmarc_spf') );
    my $dkim = $self->connection->notes('dkim_verifier');
    if ( $dkim ) {
        eval { $dmarc->dkim( $dkim ); }
    };
    $dmarc->source_ip( $self->qp->connection->remote_ip );
    eval { $dmarc->validate(); };
    if ( $@ ) {
        $self->log(LOGERROR, $@ );
        return DECLINED if $self->is_immune;
        $self->log(LOGINFO, "TODO: handle this validation failure");
        return DECLINED;
        return $self->get_reject( $@, $@ );
    };

#$self->log(LOGINFO, "result: " . Dumper( $dmarc ) );

    my $pol;
    eval { $pol = $dmarc->result->published; };
    if ( $pol ) {
        if ( $dmarc->has_valid_reporting_uri($pol->rua) ) {
            eval { $dmarc->save_aggregate(); };
            $self->log(LOGERROR, $@ ) if $@;
        }
        else {
            $self->log(LOGERROR, "has policy, no report URI" );
        };
    };

    my $disposition = $dmarc->result->disposition;
    my $auth_str = "dmarc=$disposition";
       $auth_str = " (p=" . $pol->p . ")" if $pol;

    if ( $dmarc->result->result eq 'pass' ) {
        $self->log(LOGINFO, "pass");
        $self->store_auth_results( $auth_str . " d=" . $dmarc->header_from);
        return DECLINED;
    };

    my $reason_type = my $comment = '';
    if ( $dmarc->result->reason && $dmarc->result->reason->[0] ) {
        $reason_type = $dmarc->result->reason->[0]->type;
        if ( $dmarc->result->reason->[0]->comment ) {
            $comment = $dmarc->result->reason->[0]->comment;
        };
    };
    if ( $disposition eq 'none' && $comment && $comment eq 'no policy') {
        $self->log(LOGINFO, "skip, no policy");
        return DECLINED;
    };

    my $log_mess    = $dmarc->result->result;
    $log_mess   .= ", tolerated" if $disposition eq 'none';
    $log_mess   .= ", $reason_type" if $reason_type;
    $log_mess   .= ", $comment"  if $comment;
    $self->log(LOGINFO, $log_mess);

    $self->store_auth_results( $auth_str . " d=" . $dmarc->header_from);

    return DECLINED if $disposition eq 'none';
    return DECLINED if ! $disposition;  # for safety
    return DECLINED if $self->is_immune;

    $self->adjust_karma(-3);
# at what point do we reject?
    return $self->get_reject("failed DMARC policy");
}