aboutsummaryrefslogtreecommitdiff
path: root/t
diff options
context:
space:
mode:
Diffstat (limited to 't')
-rw-r--r--t/lib/Test/Sietima.pm189
-rw-r--r--t/lib/Test/Sietima/MailStore.pm63
-rw-r--r--t/tests/sietima.t24
-rw-r--r--t/tests/sietima/cmdline.t82
-rw-r--r--t/tests/sietima/mailstore.t186
-rw-r--r--t/tests/sietima/message.t35
-rw-r--r--t/tests/sietima/multi-role/debounce-moderate.t64
-rw-r--r--t/tests/sietima/role/avoid-dups.t29
-rw-r--r--t/tests/sietima/role/debounce.t37
-rw-r--r--t/tests/sietima/role/headers.t56
-rw-r--r--t/tests/sietima/role/nomail.t41
-rw-r--r--t/tests/sietima/role/replyto.t143
-rw-r--r--t/tests/sietima/role/subject-tag.t42
-rw-r--r--t/tests/sietima/role/subscriberonly/drop.t39
-rw-r--r--t/tests/sietima/role/subscriberonly/moderate.t131
-rw-r--r--t/tests/sietima/subscriber.t41
16 files changed, 1202 insertions, 0 deletions
diff --git a/t/lib/Test/Sietima.pm b/t/lib/Test/Sietima.pm
new file mode 100644
index 0000000..8a97fc6
--- /dev/null
+++ b/t/lib/Test/Sietima.pm
@@ -0,0 +1,189 @@
+package Test::Sietima;
+use lib 't/lib';
+use Import::Into;
+use Email::Stuffer;
+use Email::Sender::Transport::Test;
+use Data::Printer;
+use Sietima;
+use Test2::Bundle::Extended;
+use Test2::API qw(context);
+use Sietima::Policy;
+use namespace::clean;
+
+sub import {
+ my $target = caller;
+ Test2::Bundle::Extended->import::into($target);
+ Test2::Plugin::DieOnFail->import::into($target);
+ Data::Printer->import::into($target);
+ Sietima::Policy->import::into($target);
+
+ for my $function (qw(transport make_sietima make_mail
+ deliveries_are test_sending
+ run_cmdline_sub)) {
+ no strict 'refs';
+ "${target}::${function}"->** = __PACKAGE__->can($function);
+ }
+ return;
+}
+
+my $return_path = 'sietima-test@list.example.com';
+
+sub transport {
+ state $transport = Email::Sender::Transport::Test->new;
+ return $transport;
+}
+
+sub make_sietima (%args) {
+ my $class = 'Sietima';
+ if (my $traits = delete $args{with_traits}) {
+ $class = $class->with_traits($traits->@*);
+ }
+
+ $class->new({
+ return_path => $return_path,
+ %args,
+ transport => transport(),
+ });
+}
+
+my $maybe = sub ($obj,$method,$arg) {
+ return $obj unless $arg;
+ return $obj->$method($arg);
+};
+
+my $mapit = sub ($obj,$method,$arg) {
+ return $obj unless $arg;
+ for my $k (keys $arg->%*) {
+ $obj = $obj->$method($k, $arg->{$k});
+ }
+ return $obj;
+};
+
+sub make_mail (%args) {
+ Email::Stuffer
+ ->from($args{from}||'someone@users.example.com')
+ ->to($args{to}||$return_path)
+ ->$maybe(cc => $args{cc})
+ ->$mapit(header => $args{headers})
+ ->subject($args{subject}||'Test Message')
+ ->text_body($args{body}||'some simple message')
+ ->email;
+}
+
+sub deliveries_are (%args) {
+ my $ctx = context();
+
+ my $checker;
+ if (my @mails = ($args{mails}||[])->@*) {
+ $checker = bag {
+ for my $m (@mails) {
+ item hash {
+ if (ref($m) eq 'HASH') {
+ field email => object {
+ call [cast=>'Email::MIME'] => $m->{o};
+ };
+ field envelope => hash {
+ field to => bag {
+ item $_ for $m->{to}->@*;
+ } if $m->{to};
+ field from => $m->{from} if $m->{from};
+ etc();
+ };
+ }
+ else {
+ field email => object {
+ call [cast=>'Email::MIME'] => $m;
+ };
+ }
+ etc();
+ };
+ }
+ end();
+ };
+ }
+ elsif (my @recipients = do {my $to = $args{to}; ref($to) ? $to->@* : $to // () }) {
+ $checker = array {
+ item hash {
+ field envelope => hash {
+ field from => $args{from}||$return_path;
+ field to => bag {
+ for (@recipients) {
+ item $_;
+ }
+ end();
+ };
+ etc();
+ };
+ etc();
+ };
+ end();
+ };
+ }
+ else {
+ $checker = [];
+ }
+
+ my @deliveries = transport->deliveries;
+ is(
+ \@deliveries,
+ $checker,
+ $args{test_message}//'the deliveries should be as expected',
+ np @deliveries,
+ );
+ $ctx->release;
+}
+
+sub test_sending (%args) {
+ my $ctx = context();
+
+ my $sietima = delete $args{sietima};
+ if (!$sietima or ref($sietima) eq 'HASH') {
+ $sietima = make_sietima(%{$sietima||{}});
+ }
+ my $mail = delete $args{mail};
+ if (!$mail or ref($mail) eq 'HASH') {
+ $mail = make_mail(
+ to => $sietima->return_path,
+ %{$mail||{}},
+ );
+ }
+
+ transport->clear_deliveries;
+
+ ok(
+ lives { $sietima->handle_mail($mail) },
+ 'should handle the mail',
+ $@,
+ );
+
+ $args{from} ||= $sietima->return_path;
+ $args{to} ||= [ map { $_->address} $sietima->subscribers->@* ];
+ deliveries_are(%args);
+
+ $ctx->release;
+}
+
+sub run_cmdline_sub($sietima,$method,$options={},$parameters={}) {
+ require Sietima::Runner;
+ my $r = Sietima::Runner->new({
+ options => $options,
+ parameters => $parameters,
+ cmd => $sietima,
+ op => $method,
+ });
+ $r->response(App::Spec::Run::Response->new);
+ ok(
+ lives { $sietima->$method($r) },
+ "calling $method should live",
+ );
+ my %ret;
+ for my $output ($r->response->outputs->@*) {
+ $ret{
+ $output->error ? 'error' : 'output'
+ } .= $output->content;
+ }
+ $ret{exit} = $r->response->exit();
+ return \%ret;
+}
+
+1;
diff --git a/t/lib/Test/Sietima/MailStore.pm b/t/lib/Test/Sietima/MailStore.pm
new file mode 100644
index 0000000..df4fb03
--- /dev/null
+++ b/t/lib/Test/Sietima/MailStore.pm
@@ -0,0 +1,63 @@
+package Test::Sietima::MailStore;
+use Moo;
+use Sietima::Policy;
+use List::AllUtils qw(all first_index);
+use Digest::SHA qw(sha1_hex);
+use namespace::clean;
+
+with 'Sietima::MailStore';
+
+has _mails => (
+ is => 'rw',
+ default => sub { +{} },
+);
+
+sub clear { shift->_mails({}) }
+
+sub store ($self,$mail,@tags) {
+ my $str = $mail->as_string;
+ my $id = sha1_hex($str);
+ $self->_mails->{$id} = {
+ id => $id,
+ mail => $str,
+ tags => { map {$_ => 1;} @tags, },
+ };
+ return $id;
+}
+
+sub retrieve_ids_by_tags ($self,@tags){
+ my @ret;
+ for my $m (values $self->_mails->%*) {
+ next unless all { $m->{tags}{$_} } @tags;
+ push @ret, $m->{id};
+ }
+ return \@ret;
+}
+
+sub retrieve_by_tags ($self,@tags){
+ my @ret;
+ for my $m (values $self->_mails->%*) {
+ next unless all { $m->{tags}{$_} } @tags;
+ push @ret, {
+ $m->%{id},
+ mail => Email::MIME->new($m->{mail})
+ };
+ }
+
+ return \@ret;
+}
+
+sub retrieve_by_id ($self,$id) {
+ if (my $m = $self->_mails->{$id}) {
+ return Email::MIME->new($m->{mail});
+ }
+
+ return;
+}
+
+sub remove($self,$id) {
+ delete $self->_mails->{$id};
+ return;
+}
+
+1;
diff --git a/t/tests/sietima.t b/t/tests/sietima.t
new file mode 100644
index 0000000..987cbdd
--- /dev/null
+++ b/t/tests/sietima.t
@@ -0,0 +1,24 @@
+#!perl
+use lib 't/lib';
+use Test::Sietima;
+
+ok(make_sietima(),'should instantiate') or bail_out;
+
+subtest 'no subscribers' => sub {
+ test_sending(
+ to => [],
+ );
+};
+
+subtest 'with subscribers' => sub {
+ my @subscriber_addresses = (
+ 'one@users.example.com',
+ 'two@users.example.com',
+ );
+ test_sending(
+ sietima => { subscribers => \@subscriber_addresses },
+ to => \@subscriber_addresses,
+ );
+};
+
+done_testing;
diff --git a/t/tests/sietima/cmdline.t b/t/tests/sietima/cmdline.t
new file mode 100644
index 0000000..bd24c84
--- /dev/null
+++ b/t/tests/sietima/cmdline.t
@@ -0,0 +1,82 @@
+#!perl
+use lib 't/lib';
+use Test::Sietima;
+use Path::Tiny;
+use Sietima;
+use Sietima::CmdLine;
+
+subtest 'given instance' => sub {
+ my $s = Sietima->new({
+ return_path => 'list@example.com',
+ });
+ my $c = Sietima::CmdLine->new({
+ sietima => $s,
+ });
+ is(
+ $c,
+ object {
+ call app_spec => object {
+ call name => 'sietima';
+ call subcommands => hash {
+ field send => object {
+ call name => 'send';
+ };
+ etc;
+ };
+ };
+ call runner => object {
+ call cmd => $s;
+ };
+ },
+ 'spec & runner should be built',
+ );
+};
+
+subtest 'built via args' => sub {
+ my $c = Sietima::CmdLine->new({
+ args => {
+ return_path => 'list@example.com',
+ },
+ });
+ is(
+ $c,
+ object {
+ call sietima => object {
+ call return_path => 'list@example.com';
+ };
+ },
+ 'sietima should be built',
+ );
+};
+
+subtest 'built via args & traits' => sub {
+ my $c = Sietima::CmdLine->new({
+ traits => [ qw(ReplyTo) ],
+ args => {
+ return_path => 'list@example.com',
+ },
+ });
+ DOES_ok(
+ $c->sietima,
+ ['Sietima::Role::ReplyTo'],
+ 'sietima should be built with the given trait',
+ );
+};
+
+subtest 'extra spec' => sub {
+ my $c = Sietima::CmdLine->new({
+ extra_spec => { name => 'different' },
+ args => {
+ return_path => 'list@example.com',
+ },
+ });
+ is(
+ $c->app_spec,
+ object {
+ call name => 'different';
+ },
+ 'spec fields should be overridden',
+ );
+};
+
+done_testing;
diff --git a/t/tests/sietima/mailstore.t b/t/tests/sietima/mailstore.t
new file mode 100644
index 0000000..7a2aa08
--- /dev/null
+++ b/t/tests/sietima/mailstore.t
@@ -0,0 +1,186 @@
+#!perl
+use lib 't/lib';
+use Test::Sietima;
+use Email::Stuffer;
+use Path::Tiny;
+
+package TestClassWithMS {
+ use Moo;
+ use Sietima::Policy;
+ with 'Sietima::Role::WithMailStore';
+};
+
+subtest 'Role::WithMailStore' => sub {
+ subtest 'plain instance' => sub {
+ require Test::Sietima::MailStore;
+ ok(
+ lives {
+ TestClassWithMS->new({
+ mail_store => Test::Sietima::MailStore->new,
+ })
+ },
+ 'passing a test instance should work',
+ );
+ };
+ subtest 'type coercion' => sub {
+ my $tc;
+ my $root = Path::Tiny->tempdir;
+ ok(
+ lives {
+ $tc = TestClassWithMS->new({
+ mail_store => {
+ class => 'Sietima::MailStore::FS',
+ root => $root,
+ },
+ })
+ },
+ 'passing a hashref should work (and load the class)',
+ );
+ is(
+ $tc->mail_store,
+ object {
+ prop blessed => 'Sietima::MailStore::FS';
+ call root => $root;
+ },
+ 'the mailstore should be built correctly',
+ );
+ };
+};
+
+sub mkmail($id) {
+ Email::Stuffer
+ ->from("from-${id}\@example.com")
+ ->to("to-${id}\@example.com")
+ ->subject("subject $id")
+ ->text_body("body $id \nbody body\n")
+ ->email;
+}
+
+sub chkmail($id) {
+ object {
+ call [header=>'from'] => "from-${id}\@example.com";
+ call [header=>'to'] => "to-${id}\@example.com";
+ call [header=>'subject'] => "subject $id";
+ call body => match qr{\bbody \Q$id\E\b};
+ };
+}
+
+sub chk_multimail(@ids) {
+ return bag {
+ for my $id (@ids) {
+ item hash {
+ field id => D();
+ field mail => chkmail($id);
+ end;
+ };
+ }
+ end;
+ };
+}
+
+sub test_store($store) {
+ my %stored_id;
+
+ subtest 'storing' => sub {
+ ok($stored_id{1}=$store->store(mkmail(1),'tag1','tag2'));
+ ok($stored_id{2}=$store->store(mkmail(2),'tag2'));
+ ok($stored_id{3}=$store->store(mkmail(3),'tag1'));
+ };
+
+ subtest 'retrieving by id' => sub {
+ is(
+ $store->retrieve_by_id($stored_id{$_}),
+ chkmail($_),
+ ) for 1..3;
+ };
+
+ subtest 'retrieving by tag' => sub {
+ my $tag1 = $store->retrieve_by_tags('tag1');
+ is(
+ $tag1,
+ chk_multimail(1,3),
+ 'tag1 should have mails 1 & 3',
+ );
+
+ my $tag2 = $store->retrieve_by_tags('tag2');
+ is(
+ $tag2,
+ chk_multimail(1,2),
+ 'tag1 should have mails 1 & 2',
+ );
+
+ my $tag12 = $store->retrieve_by_tags('tag2','tag1');
+ is(
+ $tag12,
+ chk_multimail(1),
+ 'tag1+tag2 should have mail 1',
+ );
+
+ my $tag_all = $store->retrieve_by_tags();
+ is(
+ $tag_all,
+ chk_multimail(1,2,3),
+ 'no tags should retrieve all mails',
+ );
+ };
+
+ subtest 'retrieving ids by tag' => sub {
+ my $tag1 = $store->retrieve_ids_by_tags('tag1');
+ is(
+ $tag1,
+ bag { item $stored_id{1}; item $stored_id{3}; end },
+ 'tag1 should have ids 1 & 3',
+ );
+
+ my $tag2 = $store->retrieve_ids_by_tags('tag2');
+ is(
+ $tag2,
+ bag { item $stored_id{1}; item $stored_id{2}; end },
+ 'tag1 should have ids 1 & 2',
+ );
+
+ my $tag12 = $store->retrieve_ids_by_tags('tag2','tag1');
+ is(
+ $tag12,
+ bag { item $stored_id{1}; end },
+ 'tag1+tag2 should have id 1',
+ );
+
+ my $tag_all = $store->retrieve_ids_by_tags();
+ is(
+ $tag_all,
+ bag { item $stored_id{1}; item $stored_id{2}; item $stored_id{3}; end },
+ 'no tags should retrieve all ids',
+ );
+ };
+
+ subtest 'removing' => sub {
+ $store->remove($stored_id{2});
+ is(
+ $store->retrieve_by_tags('tag2'),
+ chk_multimail(1),
+ 'remove should remove',
+ );
+ };
+
+ subtest 'clearing' => sub {
+ $store->clear;
+ is(
+ $store->retrieve_by_tags(),
+ [],
+ 'clear should clear',
+ );
+ };
+}
+
+subtest 'test store' => sub {
+ test_store(Test::Sietima::MailStore->new);
+};
+
+subtest 'file store' => sub {
+ my $root = Path::Tiny->tempdir;
+
+ test_store(Sietima::MailStore::FS->new({root => $root}));
+};
+
+done_testing;
diff --git a/t/tests/sietima/message.t b/t/tests/sietima/message.t
new file mode 100644
index 0000000..d1c548a
--- /dev/null
+++ b/t/tests/sietima/message.t
@@ -0,0 +1,35 @@
+#!perl
+use lib 't/lib';
+use Test::Sietima;
+use Email::Stuffer;
+use Sietima::Message;
+
+my $mail = Email::Stuffer
+ ->from('one@example.com')
+ ->to('two@example, three@example.com')
+ ->text_body('test message')->email;
+
+my $message = Sietima::Message->new({
+ mail => $mail,
+ from => 'one@envelope.example.com',
+ to => [
+ 'two@envelope.example.com',
+ 'three@envelope.example.com',
+ ],
+});
+
+is(
+ $message->envelope,
+ {
+ from => 'one@envelope.example.com',
+ to => bag {
+ item 'two@envelope.example.com';
+ item 'three@envelope.example.com';
+ },
+ },
+ 'the envelope should be built from the attributes',
+);
+
+# I'm not sure I'll need 'clone', so I won't test it for the moment
+
+done_testing;
diff --git a/t/tests/sietima/multi-role/debounce-moderate.t b/t/tests/sietima/multi-role/debounce-moderate.t
new file mode 100644
index 0000000..e61c551
--- /dev/null
+++ b/t/tests/sietima/multi-role/debounce-moderate.t
@@ -0,0 +1,64 @@
+#!perl
+use lib 't/lib';
+use Test::Sietima;
+use Test::Sietima::MailStore;
+
+sub test_one($traits,$should_send=1) {
+ my @subscriber_addresses = (
+ 'one@users.example.com',
+ 'two@users.example.com',
+ );
+ my $owner = 'owner@lists.example.com';
+ my $ms = Test::Sietima::MailStore->new();
+
+ my $s = make_sietima(
+ with_traits => $traits,
+ subscribers => \@subscriber_addresses,
+ owner => $owner,
+ mail_store => $ms,
+ );
+
+ test_sending(
+ sietima => $s,
+ mail => { from=>'someone@users.example.com' },
+ mails => [{
+ o => object {
+ call [header_str => 'subject'] => match qr{\bheld for moderation\b};
+ },
+ }],
+ );
+ transport->clear_deliveries;
+
+ my $to_moderate = $ms->retrieve_by_tags('moderation');
+ my $msg_id = $to_moderate->[0]->{id};
+ $s->resume($msg_id);
+
+ if ($should_send) {
+ deliveries_are(
+ to => \@subscriber_addresses,
+ test_message => 'the resumed message should be sent',
+ );
+ }
+ else {
+ deliveries_are(
+ mails => [],
+ test_message => 'the resumed message should be dropped',
+ );
+ }
+}
+
+# there's an ordering dependency between Debounce and Moderate: if we
+# moderate a message that already has the X-Been-There header, it will
+# be dropped when resumed; the simplest solution is to apply Debounce
+# *before* Moderate, so messages are moderated *before* getting the
+# anti-loop header
+
+subtest 'debounce first' => sub {
+ test_one(['Debounce','SubscriberOnly::Moderate'],1);
+};
+
+subtest 'moderate first' => sub {
+ test_one(['SubscriberOnly::Moderate','Debounce'],0);
+};
+
+done_testing;
diff --git a/t/tests/sietima/role/avoid-dups.t b/t/tests/sietima/role/avoid-dups.t
new file mode 100644
index 0000000..671d898
--- /dev/null
+++ b/t/tests/sietima/role/avoid-dups.t
@@ -0,0 +1,29 @@
+#!perl
+use lib 't/lib';
+use Test::Sietima;
+
+my $s = make_sietima(
+ with_traits => ['AvoidDups'],
+ subscribers => [
+ 'one@users.example.com',
+ 'two@users.example.com',
+ ],
+);
+
+subtest 'in cc' => sub {
+ test_sending(
+ sietima => $s,
+ mail => { cc => 'one@users.example.com' },
+ to => ['two@users.example.com'],
+ );
+};
+
+subtest 'in to' => sub {
+ test_sending(
+ sietima => $s,
+ mail => { to => $s->return_path . ' one@users.example.com' },
+ to => ['two@users.example.com'],
+ );
+};
+
+done_testing;
diff --git a/t/tests/sietima/role/debounce.t b/t/tests/sietima/role/debounce.t
new file mode 100644
index 0000000..ba7566c
--- /dev/null
+++ b/t/tests/sietima/role/debounce.t
@@ -0,0 +1,37 @@
+#!perl
+use lib 't/lib';
+use Test::Sietima;
+
+my $s = make_sietima(
+ with_traits => ['Debounce'],
+ subscribers => [
+ 'one@users.example.com',
+ 'two@users.example.com',
+ ],
+);
+
+my $return_path = $s->return_path->address;
+
+subtest 'header should be added' => sub {
+ test_sending(
+ sietima => $s,
+ mails => [
+ object {
+ call [ header_str => 'X-Been-There' ] =>
+ match qr{\b\Q$return_path\E\b};
+ },
+ ],
+ );
+};
+
+subtest 'header should inhibit sending' => sub {
+ test_sending(
+ sietima => $s,
+ mail => {
+ headers => { 'x-been-there' => $return_path },
+ },
+ to => [],
+ );
+};
+
+done_testing;
diff --git a/t/tests/sietima/role/headers.t b/t/tests/sietima/role/headers.t
new file mode 100644
index 0000000..3052781
--- /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','WithOwner','ForTesting'],
+ name => 'test-list',
+ owner => 'owner@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: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 '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;
diff --git a/t/tests/sietima/role/nomail.t b/t/tests/sietima/role/nomail.t
new file mode 100644
index 0000000..2449f5a
--- /dev/null
+++ b/t/tests/sietima/role/nomail.t
@@ -0,0 +1,41 @@
+#!perl
+use lib 't/lib';
+use Test::Sietima;
+
+subtest 'disabled' => sub {
+ my $s = make_sietima(
+ with_traits => ['NoMail'],
+ subscribers => [
+ {
+ primary => 'one@users.example.com',
+ prefs => { wants_mail => 0 },
+ },
+ 'two@users.example.com',
+ ],
+ );
+
+ test_sending(
+ sietima => $s,
+ to => ['two@users.example.com'],
+ );
+};
+
+subtest 'enabled' => sub {
+ my $s = make_sietima(
+ with_traits => ['NoMail'],
+ subscribers => [
+ {
+ primary => 'one@users.example.com',
+ prefs => { wants_mail => 1 },
+ },
+ 'two@users.example.com',
+ ],
+ );
+
+ test_sending(
+ sietima => $s,
+ to => ['one@users.example.com','two@users.example.com'],
+ );
+};
+
+done_testing;
diff --git a/t/tests/sietima/role/replyto.t b/t/tests/sietima/role/replyto.t
new file mode 100644
index 0000000..e39f8b3
--- /dev/null
+++ b/t/tests/sietima/role/replyto.t
@@ -0,0 +1,143 @@
+#!perl
+use lib 't/lib';
+use Test::Sietima;
+
+subtest 'disabled' => sub {
+ my $s = make_sietima(
+ with_traits => ['ReplyTo'],
+ munge_reply_to => 0,
+ subscribers => [
+ 'one@users.example.com',
+ 'two@users.example.com',
+ ],
+ );
+
+ test_sending(
+ sietima => $s,
+ mails => [
+ object {
+ call [ header_str => 'reply-to' ] => undef;
+ },
+ ],
+ );
+};
+
+subtest 'enabled' => sub {
+ my $s = make_sietima(
+ with_traits => ['ReplyTo'],
+ munge_reply_to => 1,
+ subscribers => [
+ 'one@users.example.com',
+ 'two@users.example.com',
+ ],
+ );
+
+ test_sending(
+ sietima => $s,
+ mails => [
+ object {
+ call [ header_str => 'reply-to' ] => $s->return_path->address;
+ },
+ ],
+ );
+};
+
+subtest 'enabled, custom post address' => sub {
+ my $post_address = 'the-list@example.com';
+ my $s = make_sietima(
+ with_traits => ['ReplyTo'],
+ munge_reply_to => 1,
+ subscribers => [
+ 'one@users.example.com',
+ 'two@users.example.com',
+ ],
+ post_address => $post_address,
+ );
+
+ is(
+ $s->list_addresses,
+ hash {
+ field return_path => $s->return_path;
+ field post => object {
+ call address => $post_address;
+ };
+ },
+ 'the custom post address should be set for the headers',
+ );
+
+ test_sending(
+ sietima => $s,
+ mails => [
+ object {
+ call [ header_str => 'reply-to' ] => $post_address;
+ },
+ ],
+ );
+};
+
+subtest 'enabled for some' => sub {
+ my $s = make_sietima(
+ with_traits => ['ReplyTo'],
+ munge_reply_to => 0,
+ subscribers => [
+ {
+ primary => 'one@users.example.com',
+ prefs => { munge_reply_to => 1 },
+ },
+ 'two@users.example.com',
+ ],
+ );
+
+ test_sending(
+ sietima => $s,
+ mails => [
+ {
+ o => object {
+ call [ header_str => 'reply-to' ] => $s->return_path->address;
+ },
+ to => [ 'one@users.example.com' ],
+ },
+ {
+ o => object {
+ call [ header_str => 'reply-to' ] => undef;
+ },
+ to => [ 'two@users.example.com' ],
+ },
+ ],
+ );
+};
+
+
+subtest 'disabled for some' => sub {
+ my $s = make_sietima(
+ with_traits => ['ReplyTo'],
+ munge_reply_to => 1,
+ subscribers => [
+ {
+ primary => 'one@users.example.com',
+ prefs => { munge_reply_to => 0 },
+ },
+ 'two@users.example.com',
+ ],
+ );
+
+ test_sending(
+ sietima => $s,
+ mails => [
+ {
+ o => object {
+ call [ header_str => 'reply-to' ] => $s->return_path->address;
+ },
+ to => [ 'two@users.example.com' ],
+ },
+ {
+ o => object {
+ call [ header_str => 'reply-to' ] => undef;
+ },
+ to => [ 'one@users.example.com' ],
+ },
+ ],
+ );
+};
+
+done_testing;
diff --git a/t/tests/sietima/role/subject-tag.t b/t/tests/sietima/role/subject-tag.t
new file mode 100644
index 0000000..e3a266b
--- /dev/null
+++ b/t/tests/sietima/role/subject-tag.t
@@ -0,0 +1,42 @@
+#!perl
+use lib 't/lib';
+use Test::Sietima;
+
+my $s = make_sietima(
+ with_traits => ['SubjectTag'],
+ subscribers => [
+ 'one@users.example.com',
+ 'two@users.example.com',
+ ],
+ subject_tag => 'foo',
+);
+
+subtest 'adding tag' => sub {
+ test_sending(
+ sietima => $s,
+ mails => [
+ object {
+ call [ header_str => 'Subject' ] =>
+ '[foo] Test Message';
+ },
+ ],
+ );
+};
+
+subtest 'tag already there' => sub {
+ my $subject = "[foo] \N{HEAVY BLACK HEART} test";
+ test_sending(
+ sietima => $s,
+ mail => {
+ subject => $subject,
+ },
+ mails => [
+ object {
+ call [ header_str => 'Subject' ] =>
+ $subject;
+ },
+ ],
+ );
+};
+
+done_testing;
diff --git a/t/tests/sietima/role/subscriberonly/drop.t b/t/tests/sietima/role/subscriberonly/drop.t
new file mode 100644
index 0000000..ac37346
--- /dev/null
+++ b/t/tests/sietima/role/subscriberonly/drop.t
@@ -0,0 +1,39 @@
+#!perl
+use lib 't/lib';
+use Test::Sietima;
+
+my @subscriber_addresses = (
+ 'one@users.example.com',
+ {
+ primary => 'two@users.example.com',
+ aliases => [ 'two-two@users.example.com' ],
+ },
+);
+my $s = make_sietima(
+ with_traits => ['SubscriberOnly::Drop'],
+ subscribers => \@subscriber_addresses,
+);
+
+subtest 'from subscriber' => sub {
+ test_sending(
+ sietima => $s,
+ mail => { from=>'one@users.example.com' },
+ );
+};
+
+subtest 'from subscriber alias' => sub {
+ test_sending(
+ sietima => $s,
+ mail => { from=>'two-two@users.example.com' },
+ );
+};
+
+subtest 'from non-subscriber' => sub {
+ test_sending(
+ sietima => $s,
+ mail => { from=>'someone@users.example.com' },
+ to => [],
+ );
+};
+
+done_testing;
diff --git a/t/tests/sietima/role/subscriberonly/moderate.t b/t/tests/sietima/role/subscriberonly/moderate.t
new file mode 100644
index 0000000..44999bd
--- /dev/null
+++ b/t/tests/sietima/role/subscriberonly/moderate.t
@@ -0,0 +1,131 @@
+#!perl
+use lib 't/lib';
+use Test::Sietima;
+use Test::Sietima::MailStore;
+
+my @subscriber_addresses = (
+ 'one@users.example.com',
+ 'two@users.example.com',
+);
+my $owner = 'owner@lists.example.com';
+my $ms = Test::Sietima::MailStore->new();
+my $s = make_sietima(
+ with_traits => ['SubscriberOnly::Moderate'],
+ subscribers => \@subscriber_addresses,
+ owner => $owner,
+ mail_store => $ms,
+);
+
+subtest 'from subscriber' => sub {
+ $ms->clear;
+ test_sending(
+ sietima => $s,
+ mail => { from=>'one@users.example.com' },
+ );
+ is(
+ $ms->retrieve_by_tags('moderation'),
+ [],
+ 'no mails held for moderation',
+ );
+};
+
+sub test_from_non_sub() {
+ my $from = $s->return_path->address;
+ test_sending(
+ sietima => $s,
+ mail => { from=>'someone@users.example.com' },
+ mails => [{
+ o => object {
+ call [header_str => 'subject'] => match qr{\bheld for moderation\b};
+ call [header_str => 'from'] => match qr{\b\Q$from\E\b};
+ call [header_str => 'to'] => match qr{\b\Q$owner\E\b};
+ call_list parts => [
+ object {
+ call body => match qr{Use id \S+ to refer to it};
+ },
+ object {
+ call sub {Email::MIME->new(shift->body)} => object {
+ call [header_str => 'subject'] => 'Test Message';
+ };
+ },
+ ];
+ },
+ from => $from,
+ to => [$owner],
+ }],
+ );
+}
+
+subtest 'from non-subscriber' => sub {
+ $ms->clear;
+ test_from_non_sub;
+
+ is(
+ my $to_moderate = $ms->retrieve_by_tags('moderation'),
+ [
+ {
+ id => T(),
+ mail => object {
+ call [header_str => 'from'] => 'someone@users.example.com';
+ call [header_str => 'to'] => $s->return_path->address,
+ },
+ },
+ ],
+ 'mails was held for moderation',
+ );
+
+ like(
+ run_cmdline_sub($s, 'list_mails_in_moderation_queue'),
+ hash {
+ field exit => 0;
+ field error => DNE;
+ field output => qr{\A
+ ^\N+\b1 \s+ message\N+$ \n
+ ^\* \s+ \w+ \s+ someone\@users\.example\.com
+ \s+ "Test[ ]Message"
+ \s+ \(\N+?\)$
+ }smx;
+ },
+ 'mails in queue should be listed from command line',
+ );
+
+ my $msg_id = $to_moderate->[0]->{id};
+
+ like(
+ run_cmdline_sub(
+ $s, 'show_mail_from_moderation_queue',
+ {}, { 'mail-id' => $msg_id },
+ ),
+ hash {
+ field exit => 0;
+ field error => DNE;
+ field output => qr{\A
+ ^Message \s+ \w+:$
+ .*?
+ ^From: \s+ someone\@users\.example\.com \s*$
+ }smx;
+ },
+ 'mail in queue should be shown from command line',
+ );
+
+ transport->clear_deliveries;
+ $s->resume($msg_id);
+ deliveries_are(
+ to => \@subscriber_addresses,
+ );
+};
+
+subtest 'from non-subscriber, drop' => sub {
+ $ms->clear;
+ test_from_non_sub;
+
+ my $msg_id = $ms->retrieve_by_tags('moderation')->[0]{id};
+ $s->drop($msg_id);
+ is(
+ $ms->retrieve_by_tags('moderation'),
+ [],
+ 'message should be dropped',
+ );
+};
+
+done_testing;
diff --git a/t/tests/sietima/subscriber.t b/t/tests/sietima/subscriber.t
new file mode 100644
index 0000000..6761410
--- /dev/null
+++ b/t/tests/sietima/subscriber.t
@@ -0,0 +1,41 @@
+#!perl
+use lib 't/lib';
+use Test::Sietima;
+use Sietima::Subscriber;
+
+subtest 'simple' => sub {
+ my $s = Sietima::Subscriber->new(
+ primary => 'Gino (pino) <gino@pino.example.com>',
+ );
+
+ is(
+ $s,
+ object {
+ call address => 'gino@pino.example.com';
+ call name => 'Gino';
+ call original => 'Gino (pino) <gino@pino.example.com>';
+ call prefs => {};
+ },
+ 'construction and delegation should work',
+ );
+};
+
+subtest 'aliases' => sub {
+ my $s = Sietima::Subscriber->new(
+ primary => 'Gino (pino) <gino@pino.example.com>',
+ aliases => [qw(also-gino@pino.example.com maybe-gino@rino.example.com)],
+ );
+
+ is(
+ $s,
+ object {
+ for my $a (qw(gino@pino also-gino@pino maybe-gino@rino)) {
+ call [match => "${a}.example.com"] => T();
+ }
+ },
+ 'all addresses should ->match()',
+ );
+
+};
+
+done_testing;
generated by cgit v1.2.3 (git 2.46.0) at 2025-05-04 16:54:16 +0000