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

3 files changed, 72 insertions, 0 deletions

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;