diff options
-rw-r--r-- | lib/Sietima.pm | 2 | ||||
-rw-r--r-- | lib/Sietima/Role/ManualSubscription.pm | 53 | ||||
-rw-r--r-- | t/tests/sietima/role/manualsubscription.t | 31 |
3 files changed, 86 insertions, 0 deletions
diff --git a/lib/Sietima.pm b/lib/Sietima.pm index e317147..98859ab 100644 --- a/lib/Sietima.pm +++ b/lib/Sietima.pm @@ -51,6 +51,8 @@ prevents the sender from receiving copies of their own messages avoids mail-loops using a C<X-Been-There> header = L<< C<Headers>|Sietima::Role::Headers >> adds C<List-*> headers to all outgoing messages += L<< C<ManualSubscription>|Sietima::Role::ManualSubscription >> +specifies that to (un)subscribe, people should write to the list owner = L<< C<NoMail>|Sietima::Role::NoMail >> avoids sending messages to subscribers who don't want them = L<< C<ReplyTo>|Sietima::Role::ReplyTo >> diff --git a/lib/Sietima/Role/ManualSubscription.pm b/lib/Sietima/Role/ManualSubscription.pm new file mode 100644 index 0000000..fd75f80 --- /dev/null +++ b/lib/Sietima/Role/ManualSubscription.pm @@ -0,0 +1,53 @@ +package Sietima::Role::ManualSubscription; +use Moo::Role; +use Sietima::Policy; +use URI; +use namespace::clean; + +# VERSION +# ABSTRACT: adds standard list-related headers to messages + +with 'Sietima::Role::WithOwner'; + +=head1 SYNOPSIS + + my $sietima = Sietima->with_traits( + 'Headers', + 'ManualSubscription', + )->new({ + %args, + owner => 'listmaster@example.com', + }); + +=head1 DESCRIPTION + +A L<< C<Sietima> >> list with this role (and L<< +C<Headers>|Sietima::Role::Headers >>) applied will add, to each +outgoing message, headers specifying that to subscribe and +unsubscribe, people sould email the list owner. + +=modif C<list_addresses> + +This method declares two "addresses", C<subscribe> and +C<unsubscribe>. Both are C<mailto:> URLs for the list +L<owner|Sietima::Role::WithOwner/owner>, with different subjects. + +=cut + +around list_addresses => sub($orig,$self) { + my $list_name = $self->name // 'the list'; + my $mail_owner_uri = URI->new($self->owner,'mailto'); + my $sub_uri = $mail_owner_uri->clone; + $sub_uri->query_form(subject => "Please add me to $list_name"); + my $unsub_uri = $mail_owner_uri->clone; + $unsub_uri->query_form(subject => "Please remove me from $list_name"); + + return +{ + $self->$orig->%*, + subscribe => $sub_uri, + unsubscribe => $unsub_uri, + }; +}; + + +1; diff --git a/t/tests/sietima/role/manualsubscription.t b/t/tests/sietima/role/manualsubscription.t new file mode 100644 index 0000000..f99805d --- /dev/null +++ b/t/tests/sietima/role/manualsubscription.t @@ -0,0 +1,31 @@ +#!perl +use lib 't/lib'; +use Test::Sietima; + +my $s = make_sietima( + with_traits => ['Headers','ManualSubscription'], + name => 'test-list', + owner => 'owner@example.com', + subscribers => [ + 'one@users.example.com', + 'two@users.example.com', + ], +); + +subtest '(un)sub headers should be added' => sub { + test_sending( + sietima => $s, + mails => [ + object { + call sub { +{ shift->header_str_pairs } } => hash { + field 'List-Subscribe' => '<mailto:owner@example.com?subject=Please+add+me+to+test-list>'; + field 'List-Unsubscribe' => '<mailto:owner@example.com?subject=Please+remove+me+from+test-list>'; + + etc; + }; + }, + ], + ); +}; + +done_testing; |