fix list headers

7 files changed, 123 insertions, 22 deletions

diff --git a/Changes b/Changes
index 28179cc..55ed858 100644
--- a/Changes
+++ b/Changes
@@ -1,4 +1,8 @@
 {{$NEXT}}
+ - fix list headers:
+   * list headers are structured, should never be encoded
+   * they can have comments
+   * each header can have multiple values
 
 1.0.0     2017-03-16 17:45:48+00:00 Europe/London
  - first release
diff --git a/lib/Sietima/HeaderURI.pm b/lib/Sietima/HeaderURI.pm
new file mode 100644
index 0000000..d9c1bb0
--- /dev/null
+++ b/lib/Sietima/HeaderURI.pm
@@ -0,0 +1,83 @@
+package Sietima::HeaderURI;
+use Moo;
+use Sietima::Policy;
+use Sietima::Types qw(Address AddressFromStr is_Address);
+use Types::Standard qw(Str ClassName HashRef Optional);
+use Type::Params qw(compile);
+use Types::URI qw(Uri is_Uri);
+use namespace::clean;
+
+has uri => (
+    is => 'ro',
+    isa => Uri,
+    required => 1,
+    coerce => 1,
+);
+
+has comment => (
+    is => 'ro',
+    isa => Str,
+);
+
+# 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"
+
+around BUILDARGS => sub {
+    my ($orig, $class, @args) = @_;
+    if (@args != 1 or ref($args[0]) eq 'HASH') {
+        return $class->$orig(@args);
+    }
+
+    my $item = $args[0];
+    if (is_Address($item)) {
+        return Sietima::HeaderURI->_args_from_address($item);
+    }
+    elsif (is_Uri($item)) {
+        return { uri => $item };
+    }
+    elsif (my $address = AddressFromStr->coerce($item)) {
+        return Sietima::HeaderURI->_args_from_address($address);
+    }
+    else {
+        return { uri => $item };
+    };
+};
+
+sub _args_from_address {
+    my ($class, $address, $query) = @_;
+    $query ||= {};
+
+    my $uri = URI->new($address->address,'mailto');
+    $uri->query_form($query->%*);
+
+    return {
+        uri => $uri,
+        comment => $address->comment,
+    };
+}
+
+sub new_from_address {
+    state $check = compile(
+        ClassName,
+        Address->plus_coercions(AddressFromStr),
+        Optional[HashRef],
+    );
+    my ($class, $address, $query) = $check->(@_);
+
+    return $class->new($class->_args_from_address($address,$query));
+}
+
+sub as_header_raw {
+    my ($self) = @_;
+
+    my $str = sprintf '<%s>',$self->uri;
+    if (my $c = $self->comment) {
+        $str .= ' '.$c;
+    }
+
+    return $str;
+}
+
+1;
diff --git a/lib/Sietima/Role/Headers.pm b/lib/Sietima/Role/Headers.pm
index a1aa566..fe3f8a5 100644
--- a/lib/Sietima/Role/Headers.pm
+++ b/lib/Sietima/Role/Headers.pm
@@ -2,7 +2,10 @@ package Sietima::Role::Headers;
 use Moo::Role;
 use Try::Tiny;
 use Sietima::Policy;
+use Sietima::HeaderURI;
+use Email::Address;
 use Types::Standard qw(Str);
+use Sietima::Types qw(HeaderUriFromThings);
 use namespace::clean;
 
 # VERSION
@@ -50,6 +53,14 @@ has name => (
     required => 0,
 );
 
+sub _normalise_address($self,$address) {
+    my @items = ref($address) eq 'ARRAY' ? $address->@* : $address;
+
+    return map {
+        HeaderUriFromThings->coerce($_)
+    } @items;
+}
+
 sub _add_headers_to($self,$message) {
     my $addresses = $self->list_addresses;
     my $mail = $message->mail;
@@ -58,7 +69,7 @@ sub _add_headers_to($self,$message) {
     # Identification of Mailing Lists"
     my $return_path = delete $addresses->{return_path};
     if (my $name = $self->name) {
-        $mail->header_str_set(
+        $mail->header_raw_set(
             'List-Id',
             sprintf '%s <%s>', $name,$return_path->address =~ s{\@}{.}r,
         );
@@ -70,17 +81,10 @@ sub _add_headers_to($self,$message) {
 
     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"
+        my @items = $self->_normalise_address($addresses->{$name});
 
-        $mail->header_str_set(
-            $header_name => try {
-                sprintf '<mailto:%s>',$address->address
-            } catch { "<$address>" },
+        $mail->header_raw_set(
+            $header_name => join ', ', map { $_->as_header_raw } @items,
         );
     }
     return;
diff --git a/lib/Sietima/Role/ManualSubscription.pm b/lib/Sietima/Role/ManualSubscription.pm
index fd75f80..c2711f0 100644
--- a/lib/Sietima/Role/ManualSubscription.pm
+++ b/lib/Sietima/Role/ManualSubscription.pm
@@ -1,7 +1,7 @@
 package Sietima::Role::ManualSubscription;
 use Moo::Role;
 use Sietima::Policy;
-use URI;
+use Sietima::HeaderURI;
 use namespace::clean;
 
 # VERSION
@@ -36,16 +36,17 @@ L<owner|Sietima::Role::WithOwner/owner>, with different subjects.
 
 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,
+        subscribe => Sietima::HeaderURI->new_from_address(
+            $self->owner,
+            { subject => "Please add me to $list_name" },
+        ),
+        unsubscribe => Sietima::HeaderURI->new_from_address(
+            $self->owner,
+            { subject => "Please remove me from $list_name" },
+        ),
     };
 };
 
diff --git a/lib/Sietima/Types.pm b/lib/Sietima/Types.pm
index 9f052e3..c6c7381 100644
--- a/lib/Sietima/Types.pm
+++ b/lib/Sietima/Types.pm
@@ -1,7 +1,7 @@
 package Sietima::Types;
 use Sietima::Policy;
 use Type::Utils -all;
-use Types::Standard qw(Str HashRef);
+use Types::Standard qw(Str HashRef Defined Str);
 use namespace::clean;
 use Type::Library
     -base,
@@ -9,6 +9,7 @@ use Type::Library
                    Address AddressFromStr
                    TagName
                    EmailMIME Message
+                   HeaderUri HeaderUriFromThings
                    Subscriber SubscriberFromAddress SubscriberFromStr SubscriberFromHashRef
                    Transport MailStore MailStoreFromHashRef);
 
@@ -124,6 +125,12 @@ An instance of L<< C<Sietima::Message> >>.
 
 class_type Message, { class => 'Sietima::Message' };
 
+class_type HeaderUri, { class => 'Sietima::HeaderURI' };
+
+declare_coercion HeaderUriFromThings,
+    to_type HeaderUri, from Defined,
+q{ Sietima::HeaderURI->new($_) };
+
 =type C<Subscriber>
 
 An instance of L<< C<Sietima::Subscriber> >>.
diff --git a/t/tests/sietima/role/headers.t b/t/tests/sietima/role/headers.t
index 9f3e664..eb96dd2 100644
--- a/t/tests/sietima/role/headers.t
+++ b/t/tests/sietima/role/headers.t
@@ -12,6 +12,7 @@ package Sietima::Role::ForTesting {
             $self->$orig->%*,
             test1 => AddressFromStr->coerce('name <someone@example.com>'),
             'test+2' => 'http://test.example.com',
+            test3 => ['name (comment) <other@example.com>','mailto:thing@example.com' ],
         };
     };
 };
@@ -31,12 +32,13 @@ subtest 'list headers should be added' => sub {
         sietima => $s,
         mails => [
             object {
-                call sub { +{ shift->header_str_pairs } } => hash {
+                call sub { +{ shift->header_raw_pairs } } => hash {
                     field 'List-Id' => 'test-list <sietima-test.list.example.com>';
                     field 'List-Owner' => '<mailto:owner@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 'List-Test3' => '<mailto:other@example.com> (comment), <mailto:thing@example.com>';
 
                     field 'Date' => D();
                     field 'MIME-Version' => D();
diff --git a/t/tests/sietima/role/manualsubscription.t b/t/tests/sietima/role/manualsubscription.t
index f99805d..ade2062 100644
--- a/t/tests/sietima/role/manualsubscription.t
+++ b/t/tests/sietima/role/manualsubscription.t
@@ -17,7 +17,7 @@ subtest '(un)sub headers should be added' => sub {
         sietima => $s,
         mails => [
             object {
-                call sub { +{ shift->header_str_pairs } } => hash {
+                call sub { +{ shift->header_raw_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>';