From 34f5eaf6328cf9d6695d5e799e9258aa65c043e4 Mon Sep 17 00:00:00 2001 From: dakkar Date: Tue, 21 Jun 2016 16:36:33 +0100 Subject: 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 --- TODO.md | 2 - lib/Sietima/Role/ReplyTo.pm | 59 +++++++++++++++++++++ lib/Sietima/Types.pm | 2 +- t/lib/Test/Sietima.pm | 60 ++++++++++++++++------ t/tests/sietima/role/nomail.t | 48 ++++++++++++----- t/tests/sietima/role/replyto.t | 113 +++++++++++++++++++++++++++++++++++++++++ 6 files changed, 252 insertions(+), 32 deletions(-) create mode 100644 lib/Sietima/Role/ReplyTo.pm create mode 100644 t/tests/sietima/role/replyto.t diff --git a/TODO.md b/TODO.md index 08062b2..c07fe62 100644 --- a/TODO.md +++ b/TODO.md @@ -13,5 +13,3 @@ * `List-Subscribe: ` (if we can (un)subscribe) * `List-Post: ` * `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; -- cgit v1.2.3