t/mda.t

   1 # Copyright (C) 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 Cwd qw(getcwd);
   6 use PublicInbox::MID qw(mid2path);
   7 use PublicInbox::Git;
   8 use PublicInbox::InboxWritable;
   9 use PublicInbox::TestCommon;
  10 use PublicInbox::Import;
  11 use PublicInbox::IO qw(write_file);
  12 use File::Path qw(remove_tree);
  13 my ($tmpdir, $for_destroy) = tmpdir();
  14 my $home = "$tmpdir/pi-home";
  15 my $pi_home = "$home/.public-inbox";
  16 my $pi_config = "$pi_home/config";
  17 my $maindir = "$tmpdir/main.git";
  18 my $main_bin = getcwd()."/t/main-bin";
  19 my $main_path = "$main_bin:$ENV{PATH}"; # for spamc ham mock
  20 my $fail_bin = getcwd()."/t/fail-bin";
  21 my $fail_path = "$fail_bin:$ENV{PATH}"; # for spamc spam mock
  22 my $addr = 'test-public@example.com';
  23 my $cfgpfx = "publicinbox.test";
  24 my $faildir = "$home/faildir/";
  25 my $git = PublicInbox::Git->new($maindir);
  26
  27 my $fail_bad_header = sub ($$$) {
  28         my ($good_rev, $msg, $in) = @_;
  29         my @f = glob("$faildir/*/*");
  30         unlink @f if @f;
  31         my ($out, $err) = ("", "");
  32         my $opt = { 0 => \$in, 1 => \$out, 2 => \$err };
  33         local $ENV{PATH} = $main_path;
  34         ok(run_script(['-mda'], undef, $opt),
  35                 "no error on undeliverable ($msg)");
  36         my $rev = $git->qx(qw(rev-list HEAD));
  37         chomp $rev;
  38         is($rev, $good_rev, "bad revision not committed ($msg)");
  39         @f = glob("$faildir/*/*");
  40         is(scalar @f, 1, "faildir written to");
  41         [ $in, $out, $err ];
  42 };
  43
  44 {
  45         ok(-x "$main_bin/spamc",
  46                 "spamc ham mock found (run in top of source tree");
  47         ok(-x "$fail_bin/spamc",
  48                 "spamc mock found (run in top of source tree");
  49         is(1, mkdir($home, 0755), "setup ~/ for testing");
  50         is(1, mkdir($pi_home, 0755), "setup ~/.public-inbox");
  51         PublicInbox::Import::init_bare($maindir);
  52
  53         write_file '>>', $pi_config, <<EOF;
  54 [publicinbox "test"]
  55         address = $addr
  56         inboxdir = $maindir
  57 EOF
  58 }
  59
  60 local $ENV{GIT_COMMITTER_NAME} = eval {
  61         use PublicInbox::MDA;
  62         use PublicInbox::Address;
  63         use Encode qw/encode/;
  64         my $msg = eml_load 't/utf8.eml';
  65         my $from = $msg->header('From');
  66         my ($author) = PublicInbox::Address::names($from);
  67         my ($email) = PublicInbox::Address::emails($from);
  68         my $date = $msg->header('Date');
  69
  70         is('El&#233;anor',
  71                 encode('us-ascii', my $tmp = $author, Encode::HTMLCREF),
  72                 'HTML conversion is correct');
  73         is($email, 'e@example.com', 'email parsed correctly');
  74         is($date, 'Thu, 01 Jan 1970 00:00:00 +0000',
  75                 'message date parsed correctly');
  76         $author;
  77 };
  78 die $@ if $@;
  79
  80 {
  81         my $good_rev;
  82         local $ENV{PI_EMERGENCY} = $faildir;
  83         local $ENV{HOME} = $home;
  84         local $ENV{ORIGINAL_RECIPIENT} = $addr;
  85         ok(run_script([qw(-mda --help)], undef,
  86                 { 1 => \my $out, 2 => \my $err }), '-mda --help');
  87         like $out, qr/usage:/, 'usage shown w/ --help';
  88         ok(!run_script([qw(-mda --bogus)], undef,
  89                 { 1 => \$out, 2 => \$err }), '-mda --bogus fails');
  90         like $err, qr/usage:/, 'usage shown on bogus switch';
  91
  92         my $in = <<EOF;
  93 From: Me <me\@example.com>
  94 To: You <you\@example.com>
  95 Cc: $addr
  96 Message-Id: <blah\@example.com>
  97 Subject: hihi
  98 Date: Thu, 01 Jan 1970 00:00:00 +0000
  99
 100 EOF
 101         {
 102                 local $ENV{PATH} = $main_path;
 103                 ok(!run_script(['-mda'], { ORIGINAL_RECIPIENT => undef },
 104                         { 0 => \$in, 2 => \$err }),
 105                         'missing ORIGINAL_RECIPIENT fails');
 106                 is($? >> 8, 67, 'got EX_NOUSER');
 107                 like $err, qr/\bORIGINAL_RECIPIENT\b/,
 108                         'ORIGINAL_RECIPIENT noted in stderr';
 109                 is unlink(glob("$faildir/*/*")), 1, 'unlinked failed message';
 110         }
 111
 112         # ensure successful message delivery
 113         {
 114                 local $ENV{PATH} = $main_path;
 115                 ok(run_script(['-mda'], undef, { 0 => \$in }));
 116                 my $rev = $git->qx(qw(rev-list HEAD));
 117                 like($rev, qr/\A[a-f0-9]{40,64}/, "good revision committed");
 118                 chomp $rev;
 119                 my $cmt = $git->cat_file($rev);
 120                 like($$cmt, qr/^author Me <me\@example\.com> 0 \+0000\n/m,
 121                         "author info set correctly");
 122                 like($$cmt, qr/^committer test <test-public\@example\.com>/m,
 123                         "committer info set correctly");
 124                 $good_rev = $rev;
 125         }
 126
 127         # ensure failures work, fail with bad spamc
 128         {
 129                 my @prev = <$faildir/new/*>;
 130                 is(scalar @prev, 0 , "nothing in PI_EMERGENCY before");
 131                 local $ENV{PATH} = $fail_path;
 132                 ok(run_script(['-mda'], undef, { 0 => \$in }));
 133                 my @revs = $git->qx(qw(rev-list HEAD));
 134                 is(scalar @revs, 1, "bad revision not committed");
 135                 my @new = <$faildir/new/*>;
 136                 is(scalar @new, 1, "PI_EMERGENCY is written to");
 137         }
 138
 139         $fail_bad_header->($good_rev, "bad recipient", <<"");
 140 From: Me <me\@example.com>
 141 To: You <you\@example.com>
 142 Message-Id: <bad-recipient\@example.com>
 143 Subject: hihi
 144 Date: Thu, 01 Jan 1970 00:00:00 +0000
 145
 146         my $fail = $fail_bad_header->($good_rev, "duplicate Message-ID", <<"");
 147 From: Me <me\@example.com>
 148 To: You <you\@example.com>
 149 Cc: $addr
 150 Message-ID: <blah\@example.com>
 151 Subject: hihi
 152 Date: Thu, 01 Jan 1970 00:00:00 +0000
 153
 154         like($fail->[2], qr/CONFLICT/, "duplicate Message-ID message");
 155
 156         $fail_bad_header->($good_rev, "missing From:", <<"");
 157 To: $addr
 158 Message-ID: <missing-from\@example.com>
 159 Subject: hihi
 160 Date: Thu, 01 Jan 1970 00:00:00 +0000
 161
 162         $fail_bad_header->($good_rev, "short subject:", <<"");
 163 To: $addr
 164 From: cat\@example.com
 165 Message-ID: <short-subject\@example.com>
 166 Subject: a
 167 Date: Thu, 01 Jan 1970 00:00:00 +0000
 168
 169         $fail_bad_header->($good_rev, "no date", <<"");
 170 To: $addr
 171 From: u\@example.com
 172 Message-ID: <no-date\@example.com>
 173 Subject: hihi
 174
 175         $fail_bad_header->($good_rev, "bad date", <<"");
 176 To: $addr
 177 From: u\@example.com
 178 Message-ID: <bad-date\@example.com>
 179 Subject: hihi
 180 Date: deadbeef
 181
 182 }
 183
 184 # spam training
 185 {
 186         local $ENV{PI_EMERGENCY} = $faildir;
 187         local $ENV{HOME} = $home;
 188         local $ENV{ORIGINAL_RECIPIENT} = $addr;
 189         local $ENV{PATH} = $main_path;
 190         my $mid = 'spam-train@example.com';
 191         my $in = <<EOF;
 192 From: Spammer <spammer\@example.com>
 193 To: You <you\@example.com>
 194 Cc: $addr
 195 Message-ID: <$mid>
 196 Subject: this message will be trained as spam
 197 Date: Thu, 01 Jan 1970 00:00:00 +0000
 198
 199 EOF
 200         {
 201                 # deliver the spam message, first
 202                 ok(run_script(['-mda'], undef, { 0 => \$in }));
 203                 my $path = mid2path($mid);
 204                 my $msg = $git->cat_file("HEAD:$path");
 205                 like($$msg, qr/\Q$mid\E/, "message delivered");
 206
 207                 # now train it
 208                 local $ENV{GIT_AUTHOR_EMAIL} = 'trainer@example.com';
 209                 local $ENV{GIT_COMMITTER_EMAIL} = 'trainer@example.com';
 210                 local $ENV{GIT_COMMITTER_NAME};
 211                 delete $ENV{GIT_COMMITTER_NAME};
 212                 ok(run_script(['-learn', 'spam'], undef, { 0 => $msg }),
 213                         "no failure from learning spam");
 214                 ok(run_script(['-learn', 'spam'], undef, { 0 => $msg }),
 215                         "no failure from learning spam idempotently");
 216         }
 217 }
 218
 219 # train ham message
 220 {
 221         local $ENV{PI_EMERGENCY} = $faildir;
 222         local $ENV{HOME} = $home;
 223         local $ENV{ORIGINAL_RECIPIENT} = $addr;
 224         local $ENV{PATH} = $main_path;
 225         my $mid = 'ham-train@example.com';
 226         my $in = <<EOF;
 227 From: False-positive <hammer\@example.com>
 228 To: You <you\@example.com>
 229 Cc: $addr
 230 Message-ID: <$mid>
 231 Subject: this message will be trained as spam
 232 Date: Thu, 01 Jan 1970 00:00:00 +0000
 233
 234 EOF
 235         # now train it
 236         # these should be overridden
 237         local $ENV{GIT_AUTHOR_EMAIL} = 'trainer@example.com';
 238         local $ENV{GIT_COMMITTER_EMAIL} = 'trainer@example.com';
 239
 240         ok(run_script(['-learn', 'ham'], undef, { 0 => \$in }),
 241                 "learned ham without failure");
 242         my $path = mid2path($mid);
 243         my $msg = $git->cat_file("HEAD:$path");
 244         like($$msg, qr/\Q$mid\E/, "ham message delivered");
 245         ok(run_script(['-learn', 'ham'], undef, { 0 => \$in }),
 246                 "learned ham idempotently ");
 247
 248         # ensure trained email is filtered, too
 249         my $mime = eml_load 't/mda-mime.eml';
 250         ($mid) = ($mime->header_raw('message-id') =~ /<([^>]+)>/);
 251         {
 252                 $in = $mime->as_string;
 253                 ok(run_script(['-learn', 'ham'], undef, { 0 => \$in }),
 254                         "learned ham without failure");
 255                 my $path = mid2path($mid);
 256                 $msg = $git->cat_file("HEAD:$path");
 257                 like($$msg, qr/<\Q$mid\E>/, "ham message delivered");
 258                 unlike($$msg, qr/<html>/i, '<html> filtered');
 259         }
 260 }
 261
 262 # List-ID based delivery
 263 {
 264         local $ENV{PI_EMERGENCY} = $faildir;
 265         local $ENV{HOME} = $home;
 266         local $ENV{ORIGINAL_RECIPIENT} = undef;
 267         delete $ENV{ORIGINAL_RECIPIENT};
 268         local $ENV{PATH} = $main_path;
 269         my $list_id = 'foo.example.com';
 270         my $mid = 'list-id-delivery@example.com';
 271         my $in = <<EOF;
 272 From: user <user\@example.com>
 273 To: You <you\@example.com>
 274 Cc: $addr
 275 Message-ID: <$mid>
 276 List-Id: <$list_id>
 277 Subject: this message will be trained as spam
 278 Date: Thu, 01 Jan 1970 00:00:00 +0000
 279
 280 EOF
 281         xsys(qw(git config --file), $pi_config, "$cfgpfx.listid", uc $list_id);
 282         $? == 0 or die "failed to set listid $?";
 283         ok(run_script(['-mda'], undef, { 0 => \$in }),
 284                 'mda OK with List-Id match');
 285         my $path = mid2path($mid);
 286         my $msg = $git->cat_file("HEAD:$path");
 287         like($$msg, qr/\Q$list_id\E/, 'delivered message w/ List-ID matches');
 288
 289         # try a message w/o precheck
 290         $in = <<EOF;
 291 To: You <you\@example.com>
 292 List-Id: <$list_id>
 293
 294 this message would not be accepted without --no-precheck
 295 EOF
 296         my ($out, $err) = ('', '');
 297         my $rdr = { 0 => \$in, 1 => \$out, 2 => \$err };
 298         ok(run_script(['-mda', '--no-precheck'], undef, $rdr),
 299                 'mda OK with List-Id match and --no-precheck');
 300         my $cur = $git->qx(qw(diff HEAD~1..HEAD));
 301         like($cur, qr/this message would not be accepted without --no-precheck/,
 302                 '--no-precheck delivered message anyways');
 303
 304         # try a message with multiple List-ID headers
 305         $in = <<EOF;
 306 List-ID: <foo.bar>
 307 List-ID: <$list_id>
 308 Message-ID: <2lids\@example>
 309 Subject: two List-IDs
 310 From: user <user\@example.com>
 311 To: $addr
 312 Date: Fri, 02 Oct 1993 00:00:00 +0000
 313
 314 EOF
 315         ($out, $err) = ('', '');
 316         ok(run_script(['-mda'], undef, $rdr),
 317                 'mda OK with multiple List-Id matches');
 318         $cur = $git->qx(qw(diff HEAD~1..HEAD));
 319         like($cur, qr/^\+Message-ID: <2lids\@example>/sm,
 320                 'multi List-ID match delivered');
 321         like($err, qr/multiple List-ID/, 'warned about multiple List-ID');
 322
 323         # ensure -learn rm works after inbox address is updated
 324         ($out, $err) = ('', '');
 325         xsys(qw(git config --file), $pi_config, "$cfgpfx.address",
 326                 $addr = 'updated-address@example.com');
 327         ok(run_script(['-learn', 'rm'], undef, $rdr), 'rm-ed via -learn');
 328         $cur = $git->qx(qw(diff HEAD~1..HEAD));
 329         like($cur, qr/^-Message-ID: <2lids\@example>/sm, 'changed in git');
 330
 331         # ensure we can strip List-Unsubscribe
 332         $in = <<EOF;
 333 To: You <you\@example.com>
 334 List-Id: <$list_id>
 335 Message-ID: <unsubscribe-1\@example>
 336 Subject: unsubscribe-1
 337 From: user <user\@example.com>
 338 To: $addr
 339 Date: Fri, 02 Oct 1993 00:00:00 +0000
 340 List-Unsubscribe: <https://example.com/some-UUID-here/listname>
 341 List-Unsubscribe-Post: List-Unsubscribe=One-Click
 342
 343 List-Unsubscribe should be stripped
 344 EOF
 345         write_file '>>', $pi_config, <<EOM;
 346 [publicinboxImport]
 347         dropUniqueUnsubscribe
 348 EOM
 349         $out = $err = '';
 350         ok(run_script([qw(-mda)], undef, $rdr), 'mda w/ dropUniqueUnsubscribe');
 351         $cur = join('', grep(/^\+/, $git->qx(qw(diff HEAD~1..HEAD))));
 352         like $cur, qr/Message-ID: <unsubscribe-1/, 'imported new message';
 353         unlike $cur, qr/some-UUID-here/, 'List-Unsubscribe gone';
 354         unlike $cur, qr/List-Unsubscribe-Post/i, 'List-Unsubscribe-Post gone';
 355
 356         $in =~ s/unsubscribe-1/unsubscribe-2/g or xbail 'BUG: s// fail';
 357         ok(run_script([qw(-learn ham)], undef, $rdr),
 358                         'learn ham w/ dropUniqueUnsubscribe');
 359         $cur = join('', grep(/^\+/, $git->qx(qw(diff HEAD~1..HEAD))));
 360         like $cur, qr/Message-ID: <unsubscribe-2/, 'learn ham';
 361         unlike $cur, qr/some-UUID-here/, 'List-Unsubscribe gone on learn ham';
 362         unlike $cur, qr/List-Unsubscribe-Post/i,
 363                 'List-Unsubscribe-Post gone on learn ham';
 364 }
 365
 366 SKIP: {
 367         require_mods(qw(DBD::SQLite Xapian), 1);
 368         local $ENV{PI_EMERGENCY} = $faildir;
 369         local $ENV{HOME} = $home;
 370         local $ENV{PATH} = $main_path;
 371         my $rdr = { 1 => \(my $out = ''), 2 => \(my $err = '') };
 372         ok(run_script([qw(-index -L medium), $maindir], undef, $rdr),
 373                 'index inbox');
 374         my $in = <<'EOM';
 375 From: a@example.com
 376 To: updated-address@example.com
 377 Subject: this is a ham message for learn
 378 Date: Fri, 02 Oct 1993 00:00:00 +0000
 379 Message-ID: <medium-ham@example>
 380
 381 yum
 382 EOM
 383         $rdr->{0} = \$in;
 384         ok(run_script([qw(-learn ham)], undef, $rdr), 'learn medium ham');
 385         is($err, '', 'nothing in stderr after medium -learn');
 386         my $msg = $git->cat_file('HEAD:'.mid2path('medium-ham@example'));
 387         like($$msg, qr/medium-ham/, 'medium ham added via -learn');
 388         my @xap = grep(!m!/over\.sqlite3!,
 389                         glob("$maindir/public-inbox/xapian*/*"));
 390         ok(remove_tree(@xap), 'rm Xapian files to convert to indexlevel=basic');
 391         $in =~ s/medium-ham/basic-ham/g or xbail 'BUG: no s//';
 392         ok(run_script([qw(-learn ham)], undef, $rdr), 'learn basic ham');
 393         is($err, '', 'nothing in stderr after basic -learn');
 394         $msg = $git->cat_file('HEAD:'.mid2path('basic-ham@example'));
 395         like($$msg, qr/basic-ham/, 'basic ham added via -learn');
 396         @xap = grep(!m!/over\.sqlite3!,
 397                         glob("$maindir/public-inbox/xapian*/*"));
 398         is_deeply(\@xap, [], 'no Xapian files created by -learn');
 399 };
 400
 401 done_testing();