role: ReplyTo

per-user reply-to munging!

also:
* deliveries_are can now test whole messages
* deliveries_are fails on extra recipients
* easier-to-use Subscriber-from-HashRef coercion
* nomail.t checks more

6 files changed, 252 insertions, 32 deletions

diff --git a/TODO.md b/TODO.md
index 08062b2..c07fe62 100644
--- a/TODO.md
+++ b/TODO.md
@@ -13,5 +13,3 @@
     * `List-Subscribe: <mailto:$sub_address>` (if we can (un)subscribe)
     * `List-Post: <mailto:$post_address>`
     * `List-Archive: NO` (configurable)
-* reply-to munging
-  * set `Reply-to` to list's post address (return path)
diff --git a/lib/Sietima/Role/ReplyTo.pm b/lib/Sietima/Role/ReplyTo.pm
new file mode 100644
index 0000000..d4eb5e5
--- /dev/null
+++ b/lib/Sietima/Role/ReplyTo.pm
@@ -0,0 +1,59 @@
+package Sietima::Role::ReplyTo;
+use 5.024;
+use Moo::Role;
+use Types::Standard qw(Bool);
+use List::AllUtils qw(part);
+use namespace::clean;
+
+has munge_reply_to => (
+    is => 'ro',
+    isa => Bool,
+    default => 0,
+);
+
+around munge_mail => sub {
+    my ($orig,$self,$mail) = @_;
+
+    my @messages = $self->$orig($mail);
+    my @ret;
+    for my $m (@messages) {
+        my ($leave,$munge) = part {
+            my $m = $_->prefs->{munge_reply_to};
+            defined $m ? (
+                $m ? 1 : 0
+            ) : ( $self->munge_reply_to ? 1 : 0 )
+        } $m->to->@*;
+
+        if (not ($munge and $munge->@*)) {
+            # nothing to do
+            push @ret,$m;
+        }
+        elsif (not ($leave and $leave->@*)) {
+            # all these recipients want munging
+            $m->mail->header_str_set('Reply-To',$self->return_path->address);
+            push @ret,$m;
+        }
+        else {
+            # some want it, some don't: create two different messages
+            my $leave_message = Sietima::Message->new({
+                mail => $m->mail,
+                from => $m->from,
+                to => $leave,
+            });
+
+            my $munged_mail = Email::MIME->new($m->mail->as_string);
+            $munged_mail->header_str_set('Reply-To',$self->return_path->address);
+
+            my $munged_message = Sietima::Message->new({
+                mail => $munged_mail,
+                from => $m->from,
+                to => $munge,
+            });
+
+            push @ret,$leave_message,$munged_message;
+        }
+    }
+    return @ret;
+};
+
+1;
diff --git a/lib/Sietima/Types.pm b/lib/Sietima/Types.pm
index f8b5faf..af650b9 100644
--- a/lib/Sietima/Types.pm
+++ b/lib/Sietima/Types.pm
@@ -33,6 +33,6 @@ declare_coercion SubscriberFromStr,
 
 declare_coercion SubscriberFromHashRef,
     to_type Subscriber, from HashRef,
-    q{ Sietima::Subscriber->new($_) };
+    q{ my $a = delete $_->{address};Sietima::Subscriber->new({raw_address => $a, prefs => $_ }) };
 
 1;
diff --git a/t/lib/Test/Sietima.pm b/t/lib/Test/Sietima.pm
index 867fd5a..31fb809 100644
--- a/t/lib/Test/Sietima.pm
+++ b/t/lib/Test/Sietima.pm
@@ -80,26 +80,56 @@ sub deliveries_are {
     my (%args) = @_;
 
     my $ctx = context();
-    my $to = $args{to};
-    my @recipients = ref($to) ? $to->@* : $to;
-    my @deliveries = transport->deliveries;
-    is(
-        \@deliveries,
-        array {
-            if (@recipients) {
+
+    my $checker;
+    if (my @mails = ($args{mails}||[])->@*) {
+        $checker = bag {
+            for my $m (@mails) {
                 item hash {
-                    field envelope => hash {
-                        field from => $args{from}||$return_path;
-                        field to => bag {
-                            for (@recipients) {
-                                item $_;
-                            }
+                    if (ref($m) eq 'HASH') {
+                        field email => object {
+                            call [cast=>'Email::MIME'] => $m->{o};
                         };
-                    };
+                        field envelope => hash {
+                            field to => bag {
+                                item $_ for $m->{to}->@*;
+                            };
+                        };
+                    }
+                    else {
+                        field email => object {
+                            call [cast=>'Email::MIME'] => $m;
+                        };
+                    }
                 };
             }
             end();
-        },
+        };
+    }
+    elsif (my @recipients = do {my $to = $args{to}; ref($to) ? $to->@* : $to }) {
+        $checker = array {
+            item hash {
+                field envelope => hash {
+                    field from => $args{from}||$return_path;
+                    field to => bag {
+                        for (@recipients) {
+                            item $_;
+                        }
+                        end();
+                    };
+                };
+            };
+            end();
+        };
+    }
+    else {
+        $checker = [];
+    }
+
+    my @deliveries = transport->deliveries;
+    is(
+        \@deliveries,
+        $checker,
         'the deliveries should be as expected',
         np @deliveries,
     );
diff --git a/t/tests/sietima/role/nomail.t b/t/tests/sietima/role/nomail.t
index fe64e84..a0be192 100644
--- a/t/tests/sietima/role/nomail.t
+++ b/t/tests/sietima/role/nomail.t
@@ -5,20 +5,40 @@ use 5.024;
 use lib 't/lib';
 use Test::Sietima;
 
-my $s = make_sietima(
-    with_traits => ['NoMail'],
-    subscribers => [
-        {
-            raw_address => 'one@users.example.com',
-            wants_mail => 0,
-        },
-        'two@users.example.com',
-    ],
-);
+subtest 'disabled' => sub {
+    my $s = make_sietima(
+        with_traits => ['NoMail'],
+        subscribers => [
+            {
+                address => 'one@users.example.com',
+                wants_mail => 0,
+            },
+            'two@users.example.com',
+        ],
+    );
 
-test_sending(
-    sietima => $s,
-    to => ['two@users.example.com'],
-);
+    test_sending(
+        sietima => $s,
+        to => ['two@users.example.com'],
+    );
+};
+
+subtest 'enabled' => sub {
+    my $s = make_sietima(
+        with_traits => ['NoMail'],
+        subscribers => [
+            {
+                address => 'one@users.example.com',
+                wants_mail => 1,
+            },
+            'two@users.example.com',
+        ],
+    );
+
+    test_sending(
+        sietima => $s,
+        to => ['one@users.example.com','two@users.example.com'],
+    );
+};
 
 done_testing;
diff --git a/t/tests/sietima/role/replyto.t b/t/tests/sietima/role/replyto.t
new file mode 100644
index 0000000..1bd2d02
--- /dev/null
+++ b/t/tests/sietima/role/replyto.t
@@ -0,0 +1,113 @@
+#!perl
+use strict;
+use warnings;
+use 5.024;
+use lib 't/lib';
+use Test::Sietima;
+
+subtest 'disabled' => sub {
+    my $s = make_sietima(
+        with_traits => ['ReplyTo'],
+        munge_reply_to => 0,
+        subscribers => [
+            'one@users.example.com',
+            'two@users.example.com',
+        ],
+    );
+
+    test_sending(
+        sietima => $s,
+        mails => [
+            object {
+                call [ header_str => 'reply-to' ] => undef;
+            },
+        ],
+    );
+};
+
+subtest 'enabled' => sub {
+    my $s = make_sietima(
+        with_traits => ['ReplyTo'],
+        munge_reply_to => 1,
+        subscribers => [
+            'one@users.example.com',
+            'two@users.example.com',
+        ],
+    );
+
+    test_sending(
+        sietima => $s,
+        mails => [
+            object {
+                call [ header_str => 'reply-to' ] => $s->return_path->address;
+            },
+        ],
+    );
+};
+
+subtest 'enabled for some' => sub {
+    my $s = make_sietima(
+        with_traits => ['ReplyTo'],
+        munge_reply_to => 0,
+        subscribers => [
+            {
+                address => 'one@users.example.com',
+                munge_reply_to => 1,
+            },
+            'two@users.example.com',
+        ],
+    );
+
+    test_sending(
+        sietima => $s,
+        mails => [
+            {
+                o => object {
+                    call [ header_str => 'reply-to' ] => $s->return_path->address;
+                },
+                to => [ 'one@users.example.com' ],
+            },
+            {
+                o => object {
+                    call [ header_str => 'reply-to' ] => undef;
+                },
+                to => [ 'two@users.example.com' ],
+            },
+        ],
+    );
+};
+
+
+subtest 'disabled for some' => sub {
+    my $s = make_sietima(
+        with_traits => ['ReplyTo'],
+        munge_reply_to => 1,
+        subscribers => [
+            {
+                address => 'one@users.example.com',
+                munge_reply_to => 0,
+            },
+            'two@users.example.com',
+        ],
+    );
+
+    test_sending(
+        sietima => $s,
+        mails => [
+            {
+                o => object {
+                    call [ header_str => 'reply-to' ] => $s->return_path->address;
+                },
+                to => [ 'two@users.example.com' ],
+            },
+            {
+                o => object {
+                    call [ header_str => 'reply-to' ] => undef;
+                },
+                to => [ 'one@users.example.com' ],
+            },
+        ],
+    );
+};
+
+done_testing;