From 7f40cd0feda1e73cb79ac800762d19f4d5699a7b Mon Sep 17 00:00:00 2001 From: dakkar Date: Fri, 24 Mar 2017 16:25:53 +0000 Subject: fix list headers --- Changes | 4 ++ lib/Sietima/HeaderURI.pm | 83 +++++++++++++++++++++++++++++++ lib/Sietima/Role/Headers.pm | 26 ++++++---- lib/Sietima/Role/ManualSubscription.pm | 17 ++++--- lib/Sietima/Types.pm | 9 +++- t/tests/sietima/role/headers.t | 4 +- t/tests/sietima/role/manualsubscription.t | 2 +- 7 files changed, 123 insertions(+), 22 deletions(-) create mode 100644 lib/Sietima/HeaderURI.pm 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 '',$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, 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 >>. 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 An instance of L<< C >>. 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 '), 'test+2' => 'http://test.example.com', + test3 => ['name (comment) ','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 '; field 'List-Owner' => ''; field 'List-Post' => ''; field 'List-Test1' => ''; field 'List-Test-2' => ''; + field 'List-Test3' => ' (comment), '; 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' => ''; field 'List-Unsubscribe' => ''; -- cgit v1.2.3