aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--lib/Sietima.pm2
-rw-r--r--lib/Sietima/Role/ManualSubscription.pm53
-rw-r--r--t/tests/sietima/role/manualsubscription.t31
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;