diff options
| -rw-r--r-- | TODO.md | 2 | ||||
| -rw-r--r-- | lib/Sietima/Role/Debounce.pm | 22 | ||||
| -rw-r--r-- | t/lib/Test/Sietima.pm | 10 | ||||
| -rw-r--r-- | t/tests/sietima/role/debounce.t | 45 |
4 files changed, 77 insertions, 2 deletions
@@ -13,8 +13,6 @@ * `List-Subscribe: <mailto:$sub_address>` (if we can (un)subscribe) * `List-Post: <mailto:$post_address>` * `List-Archive: NO` (configurable) -* de-bounce - * add `X-Been-There` header * subject [tag] * test what happens with mime-word-encoded subjects! * reply-to munging diff --git a/lib/Sietima/Role/Debounce.pm b/lib/Sietima/Role/Debounce.pm new file mode 100644 index 0000000..490dfc8 --- /dev/null +++ b/lib/Sietima/Role/Debounce.pm @@ -0,0 +1,22 @@ +package Sietima::Role::Debounce; +use 5.020; +use Moo::Role; + +my $been_there = 'X-Been-There'; + +around munge_mail => sub { + my ($orig,$self,$incoming_mail) = @_; + + my $return_path = $self->return_path->address; + if (my $there = $incoming_mail->header_str($been_there)) { + return if $there =~ m{\b\Q$return_path\E\b}; + } + + $incoming_mail->header_str_set( + $been_there => $return_path, + ); + + return $self->$orig($incoming_mail); +}; + +1; diff --git a/t/lib/Test/Sietima.pm b/t/lib/Test/Sietima.pm index 48c92cc..549d654 100644 --- a/t/lib/Test/Sietima.pm +++ b/t/lib/Test/Sietima.pm @@ -54,6 +54,15 @@ my $maybe = sub { return $obj->$method($arg); }; +my $mapit = sub { + my ($obj,$method,$arg) = @_; + return $obj unless $arg; + for my $k (keys %{$arg}) { + $obj = $obj->$method($k, $arg->{$k}); + } + return $obj; +}; + sub make_mail { my (%args) = @_; @@ -61,6 +70,7 @@ sub make_mail { ->from($args{from}||'someone@users.example.com') ->to($args{to}||$return_path) ->$maybe(cc => $args{cc}) + ->$mapit(header => $args{headers}) ->subject($args{subject}||'Test Message') ->text_body($args{body}||'some simple message') ->email; diff --git a/t/tests/sietima/role/debounce.t b/t/tests/sietima/role/debounce.t new file mode 100644 index 0000000..6021f2b --- /dev/null +++ b/t/tests/sietima/role/debounce.t @@ -0,0 +1,45 @@ +#!perl +use strict; +use warnings; +use 5.020; +use lib 't/lib'; +use Test::Sietima; + +my $s = make_sietima( + with_traits => ['Debounce'], + subscribers => [ + 'one@users.example.com', + 'two@users.example.com', + ], +); + +test_sending( + sietima => $s, +); + +my $return_path = $s->return_path->address; + +is( + [ transport->deliveries ], + array { + item hash { + field email => object { + call [cast=>'Email::MIME'] => object { + call [ header_str => 'X-Been-There' ] => + match qr{\b\Q$return_path\E\b}; + }; + }; + }; + }, + 'header should be added to all messages', +); + +test_sending( + sietima => $s, + mail => { + headers => { 'x-been-there' => $return_path }, + }, + to => [], +); + +done_testing; |