1 # Copyright (C) 2014-2019 all contributors <meta@public-inbox.org>
2 # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
8 use PublicInbox::MID qw(mid2path);
10 require './t/common.perl';
11 my ($tmpdir, $for_destroy) = tmpdir();
12 my $home = "$tmpdir/pi-home";
13 my $pi_home = "$home/.public-inbox";
14 my $pi_config = "$pi_home/config";
15 my $maindir = "$tmpdir/main.git";
16 my $main_bin = getcwd()."/t/main-bin";
17 my $main_path = "$main_bin:$ENV{PATH}"; # for spamc ham mock
18 my $fail_bin = getcwd()."/t/fail-bin";
19 my $fail_path = "$fail_bin:$ENV{PATH}"; # for spamc spam mock
20 my $addr = 'test-public@example.com';
21 my $cfgpfx = "publicinbox.test";
22 my $faildir = "$home/faildir/";
24 my $git = PublicInbox::Git->new($maindir);
27 ok(-x "$main_bin/spamc",
28 "spamc ham mock found (run in top of source tree");
29 ok(-x "$fail_bin/spamc",
30 "spamc mock found (run in top of source tree");
31 is(1, mkdir($home, 0755), "setup ~/ for testing");
32 is(1, mkdir($pi_home, 0755), "setup ~/.public-inbox");
33 is(0, system(qw(git init -q --bare), $maindir), "git init (main)");
36 "$cfgpfx.address" => $addr,
37 "$cfgpfx.inboxdir" => $maindir,
39 while (my ($k,$v) = each %cfg) {
40 is(0, system(qw(git config --file), $pi_config, $k, $v),
45 local $ENV{GIT_COMMITTER_NAME} = eval {
47 use PublicInbox::Address;
48 use Encode qw/encode/;
49 my $mbox = 't/utf8.mbox';
50 open(my $fh, '<', $mbox) or die "failed to open mbox: $mbox\n";
51 my $str = eval { local $/; <$fh> };
53 my $msg = Email::MIME->new($str);
55 my $from = $msg->header('From');
56 my ($author) = PublicInbox::Address::names($from);
57 my ($email) = PublicInbox::Address::emails($from);
58 my $date = $msg->header('Date');
61 encode('us-ascii', my $tmp = $author, Encode::HTMLCREF),
62 'HTML conversion is correct');
63 is($email, 'e@example.com', 'email parsed correctly');
64 is($date, 'Thu, 01 Jan 1970 00:00:00 +0000',
65 'message date parsed correctly');
72 local $ENV{PI_EMERGENCY} = $faildir;
73 local $ENV{HOME} = $home;
74 local $ENV{ORIGINAL_RECIPIENT} = $addr;
75 my $simple = Email::Simple->new(<<EOF);
76 From: Me <me\@example.com>
77 To: You <you\@example.com>
79 Message-Id: <blah\@example.com>
81 Date: Thu, 01 Jan 1970 00:00:00 +0000
84 my $in = $simple->as_string;
86 # ensure successful message delivery
88 local $ENV{PATH} = $main_path;
89 ok(run_script(['-mda'], undef, { 0 => \$in }));
90 my $rev = $git->qx(qw(rev-list HEAD));
91 like($rev, qr/\A[a-f0-9]{40}/, "good revision committed");
93 my $cmt = $git->cat_file($rev);
94 like($$cmt, qr/^author Me <me\@example\.com> 0 \+0000\n/m,
95 "author info set correctly");
96 like($$cmt, qr/^committer test <test-public\@example\.com>/m,
97 "committer info set correctly");
101 # ensure failures work, fail with bad spamc
103 my @prev = <$faildir/new/*>;
104 is(scalar @prev, 0 , "nothing in PI_EMERGENCY before");
105 local $ENV{PATH} = $fail_path;
106 ok(run_script(['-mda'], undef, { 0 => \$in }));
107 my @revs = $git->qx(qw(rev-list HEAD));
108 is(scalar @revs, 1, "bad revision not committed");
109 my @new = <$faildir/new/*>;
110 is(scalar @new, 1, "PI_EMERGENCY is written to");
113 fail_bad_header($good_rev, "bad recipient", <<"");
114 From: Me <me\@example.com>
115 To: You <you\@example.com>
116 Message-Id: <bad-recipient\@example.com>
118 Date: Thu, 01 Jan 1970 00:00:00 +0000
120 my $fail = fail_bad_header($good_rev, "duplicate Message-ID", <<"");
121 From: Me <me\@example.com>
122 To: You <you\@example.com>
124 Message-ID: <blah\@example.com>
126 Date: Thu, 01 Jan 1970 00:00:00 +0000
128 like($fail->[2], qr/CONFLICT/, "duplicate Message-ID message");
130 fail_bad_header($good_rev, "missing From:", <<"");
132 Message-ID: <missing-from\@example.com>
134 Date: Thu, 01 Jan 1970 00:00:00 +0000
136 fail_bad_header($good_rev, "short subject:", <<"");
138 From: cat\@example.com
139 Message-ID: <short-subject\@example.com>
141 Date: Thu, 01 Jan 1970 00:00:00 +0000
143 fail_bad_header($good_rev, "no date", <<"");
146 Message-ID: <no-date\@example.com>
149 fail_bad_header($good_rev, "bad date", <<"");
152 Message-ID: <bad-date\@example.com>
160 local $ENV{PI_EMERGENCY} = $faildir;
161 local $ENV{HOME} = $home;
162 local $ENV{ORIGINAL_RECIPIENT} = $addr;
163 local $ENV{PATH} = $main_path;
164 my $mid = 'spam-train@example.com';
165 my $simple = Email::Simple->new(<<EOF);
166 From: Spammer <spammer\@example.com>
167 To: You <you\@example.com>
170 Subject: this message will be trained as spam
171 Date: Thu, 01 Jan 1970 00:00:00 +0000
174 my $in = $simple->as_string;
177 # deliver the spam message, first
178 ok(run_script(['-mda'], undef, { 0 => \$in }));
179 my $path = mid2path($mid);
180 my $msg = $git->cat_file("HEAD:$path");
181 like($$msg, qr/\Q$mid\E/, "message delivered");
184 local $ENV{GIT_AUTHOR_EMAIL} = 'trainer@example.com';
185 local $ENV{GIT_COMMITTER_EMAIL} = 'trainer@example.com';
186 local $ENV{GIT_COMMITTER_NAME};
187 delete $ENV{GIT_COMMITTER_NAME};
188 ok(run_script(['-learn', 'spam'], undef, { 0 => $msg }),
189 "no failure from learning spam");
190 ok(run_script(['-learn', 'spam'], undef, { 0 => $msg }),
191 "no failure from learning spam idempotently");
197 local $ENV{PI_EMERGENCY} = $faildir;
198 local $ENV{HOME} = $home;
199 local $ENV{ORIGINAL_RECIPIENT} = $addr;
200 local $ENV{PATH} = $main_path;
201 my $mid = 'ham-train@example.com';
202 my $simple = Email::Simple->new(<<EOF);
203 From: False-positive <hammer\@example.com>
204 To: You <you\@example.com>
207 Subject: this message will be trained as spam
208 Date: Thu, 01 Jan 1970 00:00:00 +0000
211 my $in = $simple->as_string;
214 # these should be overridden
215 local $ENV{GIT_AUTHOR_EMAIL} = 'trainer@example.com';
216 local $ENV{GIT_COMMITTER_EMAIL} = 'trainer@example.com';
218 ok(run_script(['-learn', 'ham'], undef, { 0 => \$in }),
219 "learned ham without failure");
220 my $path = mid2path($mid);
221 my $msg = $git->cat_file("HEAD:$path");
222 like($$msg, qr/\Q$mid\E/, "ham message delivered");
223 ok(run_script(['-learn', 'ham'], undef, { 0 => \$in }),
224 "learned ham idempotently ");
226 # ensure trained email is filtered, too
227 my $html_body = "<html><body>hi</body></html>";
231 content_type => 'text/html; charset=UTF-8',
232 encoding => 'base64',
238 content_type => 'text/plain',
239 encoding => 'quoted-printable',
241 body => 'hi = "bye"',
244 $mid = 'multipart-html-sucks@11';
245 $mime = Email::MIME->create(
247 From => 'a@example.com',
250 'Message-ID' => "<$mid>",
251 'Content-Type' => 'multipart/alternative',
257 $in = $mime->as_string;
258 ok(run_script(['-learn', 'ham'], undef, { 0 => \$in }),
259 "learned ham without failure");
260 my $path = mid2path($mid);
261 $msg = $git->cat_file("HEAD:$path");
262 like($$msg, qr/<\Q$mid\E>/, "ham message delivered");
263 unlike($$msg, qr/<html>/i, '<html> filtered');
267 # List-ID based delivery
269 local $ENV{PI_EMERGENCY} = $faildir;
270 local $ENV{HOME} = $home;
271 local $ENV{ORIGINAL_RECIPIENT} = undef;
272 delete $ENV{ORIGINAL_RECIPIENT};
273 local $ENV{PATH} = $main_path;
274 my $list_id = 'foo.example.com';
275 my $mid = 'list-id-delivery@example.com';
276 my $simple = Email::Simple->new(<<EOF);
277 From: user <user\@example.com>
278 To: You <you\@example.com>
282 Subject: this message will be trained as spam
283 Date: Thu, 01 Jan 1970 00:00:00 +0000
286 system(qw(git config --file), $pi_config, "$cfgpfx.listid", $list_id);
287 $? == 0 or die "failed to set listid $?";
288 my $in = $simple->as_string;
289 ok(run_script(['-mda'], undef, { 0 => \$in }),
290 'mda OK with List-Id match');
291 my $path = mid2path($mid);
292 my $msg = $git->cat_file("HEAD:$path");
293 like($$msg, qr/\Q$list_id\E/, 'delivered message w/ List-ID matches');
295 # try a message w/o precheck
296 $simple = Email::Simple->new(<<EOF);
297 To: You <you\@example.com>
300 this message would not be accepted without --no-precheck
302 $in = $simple->as_string;
303 my ($out, $err) = ('', '');
304 my $rdr = { 0 => \$in, 1 => \$out, 2 => \$err };
305 ok(run_script(['-mda', '--no-precheck'], undef, $rdr),
306 'mda OK with List-Id match and --no-precheck');
307 my $cur = $git->qx(qw(diff HEAD~1..HEAD));
308 like($cur, qr/this message would not be accepted without --no-precheck/,
309 '--no-precheck delivered message anyways');
311 # try a message with multiple List-ID headers
315 Message-ID: <2lids\@example>
316 Subject: two List-IDs
317 From: user <user\@example.com>
319 Date: Fri, 02 Oct 1993 00:00:00 +0000
322 ($out, $err) = ('', '');
323 ok(run_script(['-mda'], undef, $rdr),
324 'mda OK with multiple List-Id matches');
325 $cur = $git->qx(qw(diff HEAD~1..HEAD));
326 like($cur, qr/Message-ID: <2lids\@example>/,
327 'multi List-ID match delivered');
328 like($err, qr/multiple List-ID/, 'warned about multiple List-ID');
333 sub fail_bad_header {
334 my ($good_rev, $msg, $in) = @_;
335 my @f = glob("$faildir/*/*");
337 my ($out, $err) = ("", "");
338 my $opt = { 0 => \$in, 1 => \$out, 2 => \$err };
339 local $ENV{PATH} = $main_path;
340 ok(run_script(['-mda'], undef, $opt),
341 "no error on undeliverable ($msg)");
342 my $rev = $git->qx(qw(rev-list HEAD));
344 is($rev, $good_rev, "bad revision not commited ($msg)");
345 @f = glob("$faildir/*/*");
346 is(scalar @f, 1, "faildir written to");