role to add list command headers

it's a bit wonky, in that it expects either Email::Address
objects (which get turned into mailto: URIs) or strings (which should be
full URIs already), but we can make it better later

5 files changed, 128 insertions, 9 deletions

diff --git a/TODO.md b/TODO.md
index 195bfd7..b6a0217 100644
--- a/TODO.md
+++ b/TODO.md
@@ -4,12 +4,3 @@
   * append to plain text single part
   * or add a plain text (or HTML?) part if multi-part
   * how do we deal with signed messages?
-* list headers
-  * RFC 2919 `List-Id: $name <$post-address=~s/@/./>`
-  * RFC 2369
-    * `List-Help: <mailto:$admin>` (if can `->admin`)
-    * `List-Owner: <mailto:$admin>` (if can `->admin`)
-    * `List-Unsubscribe: <mailto:$unsub_address>` (if we can (un)subscribe)
-    * `List-Subscribe: <mailto:$sub_address>` (if we can (un)subscribe)
-    * `List-Post: <mailto:$post_address>`
-    * `List-Archive: NO` (configurable)
diff --git a/lib/Sietima.pm b/lib/Sietima.pm
index 2a3c80b..6a7a83e 100644
--- a/lib/Sietima.pm
+++ b/lib/Sietima.pm
@@ -23,6 +23,12 @@ has return_path => (
     coerce => AddressFromStr,
 );
 
+sub list_addresses($self) {
+    return +{
+        return_path => $self->return_path,
+    };
+}
+
 my $subscribers_array = ArrayRef[
     Subscriber->plus_coercions(
         SubscriberFromAddress,
diff --git a/lib/Sietima/Role/Headers.pm b/lib/Sietima/Role/Headers.pm
new file mode 100644
index 0000000..3a91c6f
--- /dev/null
+++ b/lib/Sietima/Role/Headers.pm
@@ -0,0 +1,59 @@
+package Sietima::Role::Headers;
+use Moo::Role;
+use Try::Tiny;
+use Sietima::Policy;
+use Types::Standard qw(Str);
+use namespace::clean;
+
+has name => (
+    isa => Str,
+    is => 'ro',
+    required => 0,
+);
+
+sub _add_headers_to($self,$message) {
+    my $addresses = $self->list_addresses;
+    my $mail = $message->mail;
+
+    # see RFC 2919 "List-Id: A Structured Field and Namespace for the
+    # Identification of Mailing Lists"
+    my $return_path = delete $addresses->{return_path};
+    if (my $name = $self->name) {
+        $mail->header_str_set(
+            'List-Id',
+            sprintf '%s <%s>', $name,$return_path->address =~ s{\@}{.}r,
+        );
+    }
+
+    # little renaming
+    $addresses->{owner} = delete $addresses->{admin};
+
+    # if nobody declared a "post" address, let's guess it's the same
+    # as the address we send from
+    $addresses->{post} //= $return_path;
+
+    for my $name (sort keys $addresses->%*) {
+        my $header_name = 'List-' . ucfirst($name =~ s{[^[:alnum:]]+}{-}gr);
+        my $address = $addresses->{$name};
+
+        # if it's not an Email::Address obect, we'll just take it as a
+        # string: it could be a non-mailto URI, see RFC 2369 "The Use
+        # of URLs as Meta-Syntax for Core Mail List Commands and their
+        # Transport through Message Header Fields"
+
+        $mail->header_str_set(
+            $header_name => try {
+                sprintf '<mailto:%s>',$address->address
+            } catch { "$address" },
+        );
+    }
+    return;
+}
+
+around munge_mail => sub ($orig,$self,$mail) {
+    my @messages = $self->$orig($mail);
+    $self->_add_headers_to($_) for @messages;
+    return @messages;
+};
+
+1;
diff --git a/lib/Sietima/Role/WithAdmin.pm b/lib/Sietima/Role/WithAdmin.pm
index 49b0f51..8293621 100644
--- a/lib/Sietima/Role/WithAdmin.pm
+++ b/lib/Sietima/Role/WithAdmin.pm
@@ -11,4 +11,11 @@ has admin => (
     coerce => AddressFromStr,
 );
 
+around list_addresses => sub($orig,$self) {
+    return +{
+        $self->$orig->%*,
+        admin => $self->admin,
+    };
+};
+
 1;
diff --git a/t/tests/sietima/role/headers.t b/t/tests/sietima/role/headers.t
new file mode 100644
index 0000000..7b3e4b7
--- /dev/null
+++ b/t/tests/sietima/role/headers.t
@@ -0,0 +1,56 @@
+#!perl
+use lib 't/lib';
+use Test::Sietima;
+
+package Sietima::Role::ForTesting {
+    use Moo::Role;
+    use Sietima::Policy;
+    use Sietima::Types qw(AddressFromStr);
+
+    around list_addresses => sub($orig,$self) {
+        return {
+            $self->$orig->%*,
+            test1 => AddressFromStr->coerce('name <someone@example.com>'),
+            'test+2' => 'http://test.example.com',
+        };
+    };
+};
+
+my $s = make_sietima(
+    with_traits => ['Headers','WithAdmin','ForTesting'],
+    name => 'test-list',
+    admin => 'admin@example.com',
+    subscribers => [
+        'one@users.example.com',
+        'two@users.example.com',
+    ],
+);
+
+subtest 'list headers should be added' => sub {
+    test_sending(
+        sietima => $s,
+        mails => [
+            object {
+                call sub { +{ shift->header_str_pairs } } => hash {
+                    field 'List-Id' => 'test-list <sietima-test.list.example.com>';
+                    field 'List-Owner' => '<mailto:admin@example.com>';
+                    field 'List-Post' => '<mailto:sietima-test@list.example.com>';
+                    field 'List-Test1' => '<mailto:someone@example.com>';
+                    field 'List-Test-2' => 'http://test.example.com';
+
+                    field 'Date' => D();
+                    field 'MIME-Version' => D();
+                    field 'Content-Type' => D();
+                    field 'Content-Transfer-Encoding' => D();
+                    field 'From' => 'someone@users.example.com';
+                    field 'To' => 'sietima-test@list.example.com';
+                    field 'Subject' => 'Test Message';
+
+                    end;
+                };
+            },
+        ],
+    );
+};
+
+done_testing;