1 files changed, 53 insertions, 0 deletions
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;