lib/Sietima/Role/NoSpoof/DMARC.pm


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93

package Sietima::Role::NoSpoof::DMARC; 
use Moo::Role;
use Sietima::Policy;
use Email::Address;
use Mail::DMARC::PurePerl;
use namespace::clean;
 
# VERSION 
# ABSTRACT: send out messages from subscribers' addresses only if DMARC allows it 
 
=head1 SYNOPSIS
 
  my $sietima = Sietima->with_traits('NoSpoof::DMARC')->new(\%args);
 
=head1 DESCRIPTION
 
A L<< C<Sietima> >> list with this role applied will replace the
C<From> address with its own L<<
C<post_address>|Sietima::Role::WithPostAddress >> (this is a
"sub-role" of L<< C<WithPostAddress>|Sietima::Role::WithPostAddress
>>) I<if> the originating address's DMARC policy requires it.
 
This will make the list DMARC-compliant while minimising the changes
to the messages.
 
The original C<From> address will be preserved in the C<Original-From>
header, as required by RFC 5703.
 
=head2 Some more details
 
DMARC requires L<"identifier
alignment"|https://datatracker.ietf.org/doc/html/rfc7489#section-3.1>,
essentially the C<MAIL FROM> (envelope) and the header C<From> must
have the same domain (or at least belong to the same "organisational
domain", i.e. be both under a common non-top-level domain, roughly).
 
Therefore, a mailing list that forwards a message sent from a
DMARC-enabled domain, I<must> rewrite the C<From> header, otherwise
the message will be discarded by recipient servers. If the originating
domain does not publish a DMARC policy (or publishes a C<none>
policy), the mailing list can leave the C<From> as is, but should add
a C<Sender> header with the list's own address.
 
This role does exactly that.
 
=cut
 
with 'Sietima::Role::WithPostAddress';
 
# mostly for testing 
has dmarc_resolver => ( is => 'ro' );
 
around munge_mail => sub ($orig,$self,$incoming_mail) {
    my $sender = $self->post_address->address;
    my ($from) = Email::Address->parse($incoming_mail->header_str('From'));
    my $from_domain = $from->host;
 
    my $dmarc = Mail::DMARC::PurePerl->new(
        resolver => $self->dmarc_resolver,
    );
    $dmarc->header_from($from_domain);
 
    if (my $policy = $dmarc->discover_policy) {
        # sp applies to sub-domains, defaults to p; p applies to the 
        # domain itself, and is required 
        my $relevant_value = $dmarc->is_subdomain
            ? ( $policy->sp // $policy->p )
            : $policy->p;
 
        if ($relevant_value ne 'none') {
            $incoming_mail->header_str_set(
                'Original-From' => $from,
            );
 
            $from->address($sender);
 
            $incoming_mail->header_str_set(
                From => $from,
            );
 
            return $self->$orig($incoming_mail);
        }
    }
 
    $incoming_mail->header_str_set(
        Sender => $sender,
    );
 
    return $self->$orig($incoming_mail);
 
};
 
1;