aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Changes4
-rw-r--r--lib/Sietima/HeaderURI.pm83
-rw-r--r--lib/Sietima/Role/Headers.pm26
-rw-r--r--lib/Sietima/Role/ManualSubscription.pm17
-rw-r--r--lib/Sietima/Types.pm9
-rw-r--r--t/tests/sietima/role/headers.t4
-rw-r--r--t/tests/sietima/role/manualsubscription.t2
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>';
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-01 00:38:19 +0000