new role NoSpoof::DMARC

3 files changed, 159 insertions, 0 deletions

diff --git a/Changes b/Changes
index 6a6f2ef..da9f872 100644
--- a/Changes
+++ b/Changes
@@ -1,4 +1,5 @@
 {{$NEXT}}
+ - new role NoSpoof::DMARC, which replaces the From only when needed
 
 1.1.1     2023-02-28 13:02:33+00:00 Europe/London
  - documentation fixes
diff --git a/lib/Sietima/Role/NoSpoof/DMARC.pm b/lib/Sietima/Role/NoSpoof/DMARC.pm
new file mode 100644
index 0000000..de021da
--- /dev/null
+++ b/lib/Sietima/Role/NoSpoof/DMARC.pm
@@ -0,0 +1,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;
diff --git a/t/tests/sietima/role/nospoof/dmarc.t b/t/tests/sietima/role/nospoof/dmarc.t
new file mode 100644
index 0000000..18d70c8
--- /dev/null
+++ b/t/tests/sietima/role/nospoof/dmarc.t
@@ -0,0 +1,65 @@
+#!perl
+use lib 't/lib';
+use Test::Sietima;
+use Net::DNS::Resolver::Mock;
+
+my $resolver = Net::DNS::Resolver::Mock->new();
+
+my $s = make_sietima(
+    with_traits => ['NoSpoof::DMARC'],
+    subscribers => [
+        'one@users.example.com',
+    ],
+    dmarc_resolver => $resolver,
+);
+
+sub test_rewriting($from) {
+    subtest "$from should rewrite" => sub {
+        test_sending(
+            sietima => $s,
+            mail => {
+                from => "a user <$from>",
+            },
+            mails => [
+                object {
+                    call [ header_str => 'from' ] => '"a user" <'.$s->return_path->address.'>';
+                    call [ header_str => 'original-from' ] => qq{"a user" <$from>};
+                },
+            ],
+        );
+    }
+}
+
+sub test_no_rewriting($from) {
+    subtest "$from should not rewrite" => sub {
+        test_sending(
+            sietima => $s,
+            mail => {
+                from => "a user <$from>",
+            },
+            mails => [
+                object {
+                    call [ header_str => 'sender' ] => $s->return_path->address;
+                    call [ header_str => 'from' ] => qq{"a user" <$from>};
+                },
+            ],
+        );
+    }
+}
+
+$resolver->zonefile_parse(<<'EOZ');
+_dmarc.none-none-pol.com 3600 TXT "v=DMARC1; p=none; sp=none; rua=mailto:foo@example.com"
+_dmarc.none-q-pol.com 3600 TXT "v=DMARC1; p=none; sp=quarantine; rua=mailto:foo@example.com"
+_dmarc.q-q-pol.com 3600 TXT "v=DMARC1; p=quarantine; sp=quarantine; rua=mailto:foo@example.com"
+EOZ
+
+test_no_rewriting 'foo@none-none-pol.com';
+test_no_rewriting 'foo@sub.none-none-pol.com';
+
+test_no_rewriting 'foo@none-q-pol.com';
+test_rewriting    'foo@sub.none-q-pol.com';
+
+test_rewriting    'foo@q-q-pol.com';
+test_rewriting    'foo@sub.q-q-pol.com';
+
+done_testing;