]> Sergey Matveev's repositories - public-inbox.git/blob - t/mda.t
doc: update v1.3.0.eml with actual headers, start v1.4.0
[public-inbox.git] / t / mda.t
1 # Copyright (C) 2014-2020 all contributors <meta@public-inbox.org>
2 # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
3 use strict;
4 use warnings;
5 use Test::More;
6 use Email::MIME;
7 use Cwd qw(getcwd);
8 use PublicInbox::MID qw(mid2path);
9 use PublicInbox::Git;
10 use PublicInbox::TestCommon;
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/";
23 my $mime;
24 my $git = PublicInbox::Git->new($maindir);
25
26 my $fail_bad_header = sub ($$$) {
27         my ($good_rev, $msg, $in) = @_;
28         my @f = glob("$faildir/*/*");
29         unlink @f if @f;
30         my ($out, $err) = ("", "");
31         my $opt = { 0 => \$in, 1 => \$out, 2 => \$err };
32         local $ENV{PATH} = $main_path;
33         ok(run_script(['-mda'], undef, $opt),
34                 "no error on undeliverable ($msg)");
35         my $rev = $git->qx(qw(rev-list HEAD));
36         chomp $rev;
37         is($rev, $good_rev, "bad revision not commited ($msg)");
38         @f = glob("$faildir/*/*");
39         is(scalar @f, 1, "faildir written to");
40         [ $in, $out, $err ];
41 };
42
43 {
44         ok(-x "$main_bin/spamc",
45                 "spamc ham mock found (run in top of source tree");
46         ok(-x "$fail_bin/spamc",
47                 "spamc mock found (run in top of source tree");
48         is(1, mkdir($home, 0755), "setup ~/ for testing");
49         is(1, mkdir($pi_home, 0755), "setup ~/.public-inbox");
50         is(0, system(qw(git init -q --bare), $maindir), "git init (main)");
51
52         open my $fh, '>>', $pi_config or die;
53         print $fh <<EOF or die;
54 [publicinbox "test"]
55         address = $addr
56         inboxdir = $maindir
57 EOF
58         close $fh or die;
59 }
60
61 local $ENV{GIT_COMMITTER_NAME} = eval {
62         use PublicInbox::MDA;
63         use PublicInbox::Address;
64         use Encode qw/encode/;
65         my $mbox = 't/utf8.mbox';
66         open(my $fh, '<', $mbox) or die "failed to open mbox: $mbox\n";
67         my $str = eval { local $/; <$fh> };
68         close $fh;
69         my $msg = Email::MIME->new($str);
70
71         my $from = $msg->header('From');
72         my ($author) = PublicInbox::Address::names($from);
73         my ($email) = PublicInbox::Address::emails($from);
74         my $date = $msg->header('Date');
75
76         is('El&#233;anor',
77                 encode('us-ascii', my $tmp = $author, Encode::HTMLCREF),
78                 'HTML conversion is correct');
79         is($email, 'e@example.com', 'email parsed correctly');
80         is($date, 'Thu, 01 Jan 1970 00:00:00 +0000',
81                 'message date parsed correctly');
82         $author;
83 };
84 die $@ if $@;
85
86 {
87         my $good_rev;
88         local $ENV{PI_EMERGENCY} = $faildir;
89         local $ENV{HOME} = $home;
90         local $ENV{ORIGINAL_RECIPIENT} = $addr;
91         my $simple = Email::Simple->new(<<EOF);
92 From: Me <me\@example.com>
93 To: You <you\@example.com>
94 Cc: $addr
95 Message-Id: <blah\@example.com>
96 Subject: hihi
97 Date: Thu, 01 Jan 1970 00:00:00 +0000
98
99 EOF
100         my $in = $simple->as_string;
101
102         # ensure successful message delivery
103         {
104                 local $ENV{PATH} = $main_path;
105                 ok(run_script(['-mda'], undef, { 0 => \$in }));
106                 my $rev = $git->qx(qw(rev-list HEAD));
107                 like($rev, qr/\A[a-f0-9]{40}/, "good revision committed");
108                 chomp $rev;
109                 my $cmt = $git->cat_file($rev);
110                 like($$cmt, qr/^author Me <me\@example\.com> 0 \+0000\n/m,
111                         "author info set correctly");
112                 like($$cmt, qr/^committer test <test-public\@example\.com>/m,
113                         "committer info set correctly");
114                 $good_rev = $rev;
115         }
116
117         # ensure failures work, fail with bad spamc
118         {
119                 my @prev = <$faildir/new/*>;
120                 is(scalar @prev, 0 , "nothing in PI_EMERGENCY before");
121                 local $ENV{PATH} = $fail_path;
122                 ok(run_script(['-mda'], undef, { 0 => \$in }));
123                 my @revs = $git->qx(qw(rev-list HEAD));
124                 is(scalar @revs, 1, "bad revision not committed");
125                 my @new = <$faildir/new/*>;
126                 is(scalar @new, 1, "PI_EMERGENCY is written to");
127         }
128
129         $fail_bad_header->($good_rev, "bad recipient", <<"");
130 From: Me <me\@example.com>
131 To: You <you\@example.com>
132 Message-Id: <bad-recipient\@example.com>
133 Subject: hihi
134 Date: Thu, 01 Jan 1970 00:00:00 +0000
135
136         my $fail = $fail_bad_header->($good_rev, "duplicate Message-ID", <<"");
137 From: Me <me\@example.com>
138 To: You <you\@example.com>
139 Cc: $addr
140 Message-ID: <blah\@example.com>
141 Subject: hihi
142 Date: Thu, 01 Jan 1970 00:00:00 +0000
143
144         like($fail->[2], qr/CONFLICT/, "duplicate Message-ID message");
145
146         $fail_bad_header->($good_rev, "missing From:", <<"");
147 To: $addr
148 Message-ID: <missing-from\@example.com>
149 Subject: hihi
150 Date: Thu, 01 Jan 1970 00:00:00 +0000
151
152         $fail_bad_header->($good_rev, "short subject:", <<"");
153 To: $addr
154 From: cat\@example.com
155 Message-ID: <short-subject\@example.com>
156 Subject: a
157 Date: Thu, 01 Jan 1970 00:00:00 +0000
158
159         $fail_bad_header->($good_rev, "no date", <<"");
160 To: $addr
161 From: u\@example.com
162 Message-ID: <no-date\@example.com>
163 Subject: hihi
164
165         $fail_bad_header->($good_rev, "bad date", <<"");
166 To: $addr
167 From: u\@example.com
168 Message-ID: <bad-date\@example.com>
169 Subject: hihi
170 Date: deadbeef
171
172 }
173
174 # spam training
175 {
176         local $ENV{PI_EMERGENCY} = $faildir;
177         local $ENV{HOME} = $home;
178         local $ENV{ORIGINAL_RECIPIENT} = $addr;
179         local $ENV{PATH} = $main_path;
180         my $mid = 'spam-train@example.com';
181         my $simple = Email::Simple->new(<<EOF);
182 From: Spammer <spammer\@example.com>
183 To: You <you\@example.com>
184 Cc: $addr
185 Message-ID: <$mid>
186 Subject: this message will be trained as spam
187 Date: Thu, 01 Jan 1970 00:00:00 +0000
188
189 EOF
190         my $in = $simple->as_string;
191
192         {
193                 # deliver the spam message, first
194                 ok(run_script(['-mda'], undef, { 0 => \$in }));
195                 my $path = mid2path($mid);
196                 my $msg = $git->cat_file("HEAD:$path");
197                 like($$msg, qr/\Q$mid\E/, "message delivered");
198
199                 # now train it
200                 local $ENV{GIT_AUTHOR_EMAIL} = 'trainer@example.com';
201                 local $ENV{GIT_COMMITTER_EMAIL} = 'trainer@example.com';
202                 local $ENV{GIT_COMMITTER_NAME};
203                 delete $ENV{GIT_COMMITTER_NAME};
204                 ok(run_script(['-learn', 'spam'], undef, { 0 => $msg }),
205                         "no failure from learning spam");
206                 ok(run_script(['-learn', 'spam'], undef, { 0 => $msg }),
207                         "no failure from learning spam idempotently");
208         }
209 }
210
211 # train ham message
212 {
213         local $ENV{PI_EMERGENCY} = $faildir;
214         local $ENV{HOME} = $home;
215         local $ENV{ORIGINAL_RECIPIENT} = $addr;
216         local $ENV{PATH} = $main_path;
217         my $mid = 'ham-train@example.com';
218         my $simple = Email::Simple->new(<<EOF);
219 From: False-positive <hammer\@example.com>
220 To: You <you\@example.com>
221 Cc: $addr
222 Message-ID: <$mid>
223 Subject: this message will be trained as spam
224 Date: Thu, 01 Jan 1970 00:00:00 +0000
225
226 EOF
227         my $in = $simple->as_string;
228
229         # now train it
230         # these should be overridden
231         local $ENV{GIT_AUTHOR_EMAIL} = 'trainer@example.com';
232         local $ENV{GIT_COMMITTER_EMAIL} = 'trainer@example.com';
233
234         ok(run_script(['-learn', 'ham'], undef, { 0 => \$in }),
235                 "learned ham without failure");
236         my $path = mid2path($mid);
237         my $msg = $git->cat_file("HEAD:$path");
238         like($$msg, qr/\Q$mid\E/, "ham message delivered");
239         ok(run_script(['-learn', 'ham'], undef, { 0 => \$in }),
240                 "learned ham idempotently ");
241
242         # ensure trained email is filtered, too
243         my $html_body = "<html><body>hi</body></html>";
244         my $parts = [
245                 Email::MIME->create(
246                         attributes => {
247                                 content_type => 'text/html; charset=UTF-8',
248                                 encoding => 'base64',
249                         },
250                         body => $html_body,
251                 ),
252                 Email::MIME->create(
253                         attributes => {
254                                 content_type => 'text/plain',
255                                 encoding => 'quoted-printable',
256                         },
257                         body => 'hi = "bye"',
258                 )
259         ];
260         $mid = 'multipart-html-sucks@11';
261         $mime = Email::MIME->create(
262                 header_str => [
263                   From => 'a@example.com',
264                   Subject => 'blah',
265                   Cc => $addr,
266                   'Message-ID' => "<$mid>",
267                   'Content-Type' => 'multipart/alternative',
268                 ],
269                 parts => $parts,
270         );
271
272         {
273                 $in = $mime->as_string;
274                 ok(run_script(['-learn', 'ham'], undef, { 0 => \$in }),
275                         "learned ham without failure");
276                 my $path = mid2path($mid);
277                 $msg = $git->cat_file("HEAD:$path");
278                 like($$msg, qr/<\Q$mid\E>/, "ham message delivered");
279                 unlike($$msg, qr/<html>/i, '<html> filtered');
280         }
281 }
282
283 # List-ID based delivery
284 {
285         local $ENV{PI_EMERGENCY} = $faildir;
286         local $ENV{HOME} = $home;
287         local $ENV{ORIGINAL_RECIPIENT} = undef;
288         delete $ENV{ORIGINAL_RECIPIENT};
289         local $ENV{PATH} = $main_path;
290         my $list_id = 'foo.example.com';
291         my $mid = 'list-id-delivery@example.com';
292         my $simple = Email::Simple->new(<<EOF);
293 From: user <user\@example.com>
294 To: You <you\@example.com>
295 Cc: $addr
296 Message-ID: <$mid>
297 List-Id: <$list_id>
298 Subject: this message will be trained as spam
299 Date: Thu, 01 Jan 1970 00:00:00 +0000
300
301 EOF
302         system(qw(git config --file), $pi_config, "$cfgpfx.listid", $list_id);
303         $? == 0 or die "failed to set listid $?";
304         my $in = $simple->as_string;
305         ok(run_script(['-mda'], undef, { 0 => \$in }),
306                 'mda OK with List-Id match');
307         my $path = mid2path($mid);
308         my $msg = $git->cat_file("HEAD:$path");
309         like($$msg, qr/\Q$list_id\E/, 'delivered message w/ List-ID matches');
310
311         # try a message w/o precheck
312         $simple = Email::Simple->new(<<EOF);
313 To: You <you\@example.com>
314 List-Id: <$list_id>
315
316 this message would not be accepted without --no-precheck
317 EOF
318         $in = $simple->as_string;
319         my ($out, $err) = ('', '');
320         my $rdr = { 0 => \$in, 1 => \$out, 2 => \$err };
321         ok(run_script(['-mda', '--no-precheck'], undef, $rdr),
322                 'mda OK with List-Id match and --no-precheck');
323         my $cur = $git->qx(qw(diff HEAD~1..HEAD));
324         like($cur, qr/this message would not be accepted without --no-precheck/,
325                 '--no-precheck delivered message anyways');
326
327         # try a message with multiple List-ID headers
328         $in = <<EOF;
329 List-ID: <foo.bar>
330 List-ID: <$list_id>
331 Message-ID: <2lids\@example>
332 Subject: two List-IDs
333 From: user <user\@example.com>
334 To: $addr
335 Date: Fri, 02 Oct 1993 00:00:00 +0000
336
337 EOF
338         ($out, $err) = ('', '');
339         ok(run_script(['-mda'], undef, $rdr),
340                 'mda OK with multiple List-Id matches');
341         $cur = $git->qx(qw(diff HEAD~1..HEAD));
342         like($cur, qr/Message-ID: <2lids\@example>/,
343                 'multi List-ID match delivered');
344         like($err, qr/multiple List-ID/, 'warned about multiple List-ID');
345 }
346
347 done_testing();