aboutsummaryrefslogtreecommitdiff
path: root/t/tests/sietima/role
diff options
context:
space:
mode:
Diffstat (limited to 't/tests/sietima/role')
-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
8 files changed, 518 insertions, 0 deletions
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;
generated by cgit v1.2.3 (git 2.46.0) at 2025-05-04 14:56:27 +0000