t/mda.t

   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>
   3 use strict;
   4 use warnings;
   5 use Test::More;
   6 use Email::MIME;
   7 use File::Temp qw/tempdir/;
   8 use Cwd qw(getcwd);
   9 use PublicInbox::MID qw(mid2path);
  10 eval { require IPC::Run };
  11 plan skip_all => "missing IPC::Run for t/mda.t" if $@;
  12
  13 my $mda = "blib/script/public-inbox-mda";
  14 my $learn = "blib/script/public-inbox-learn";
  15 my $tmpdir = tempdir('pi-mda-XXXXXX', TMPDIR => 1, CLEANUP => 1);
  16 my $home = "$tmpdir/pi-home";
  17 my $pi_home = "$home/.public-inbox";
  18 my $pi_config = "$pi_home/config";
  19 my $maindir = "$tmpdir/main.git";
  20 my $main_bin = getcwd()."/t/main-bin";
  21 my $main_path = "$main_bin:$ENV{PATH}"; # for spamc ham mock
  22 my $fail_bin = getcwd()."/t/fail-bin";
  23 my $fail_path = "$fail_bin:$ENV{PATH}"; # for spamc spam mock
  24 my $addr = 'test-public@example.com';
  25 my $cfgpfx = "publicinbox.test";
  26 my $faildir = "$home/faildir/";
  27 my $mime;
  28
  29 {
  30         ok(-x "$main_bin/spamc",
  31                 "spamc ham mock found (run in top of source tree");
  32         ok(-x "$fail_bin/spamc",
  33                 "spamc mock found (run in top of source tree");
  34         ok(-x $mda, "$mda is executable");
  35         is(1, mkdir($home, 0755), "setup ~/ for testing");
  36         is(1, mkdir($pi_home, 0755), "setup ~/.public-inbox");
  37         is(0, system(qw(git init -q --bare), $maindir), "git init (main)");
  38
  39         my %cfg = (
  40                 "$cfgpfx.address" => $addr,
  41                 "$cfgpfx.mainrepo" => $maindir,
  42         );
  43         while (my ($k,$v) = each %cfg) {
  44                 is(0, system(qw(git config --file), $pi_config, $k, $v),
  45                         "setup $k");
  46         }
  47 }
  48
  49 local $ENV{GIT_COMMITTER_NAME} = eval {
  50         use PublicInbox::MDA;
  51         use PublicInbox::Address;
  52         use Encode qw/encode/;
  53         my $mbox = 't/utf8.mbox';
  54         open(my $fh, '<', $mbox) or die "failed to open mbox: $mbox\n";
  55         my $str = eval { local $/; <$fh> };
  56         close $fh;
  57         my $msg = Email::MIME->new($str);
  58
  59         my $from = $msg->header('From');
  60         my ($author) = PublicInbox::Address::names($from);
  61         my ($email) = PublicInbox::Address::emails($from);
  62         my $date = $msg->header('Date');
  63
  64         is('El&#233;anor',
  65                 encode('us-ascii', my $tmp = $author, Encode::HTMLCREF),
  66                 'HTML conversion is correct');
  67         is($email, 'e@example.com', 'email parsed correctly');
  68         is($date, 'Thu, 01 Jan 1970 00:00:00 +0000',
  69                 'message date parsed correctly');
  70         $author;
  71 };
  72 die $@ if $@;
  73
  74 {
  75         my $good_rev;
  76         local $ENV{PI_EMERGENCY} = $faildir;
  77         local $ENV{HOME} = $home;
  78         local $ENV{ORIGINAL_RECIPIENT} = $addr;
  79         my $simple = Email::Simple->new(<<EOF);
  80 From: Me <me\@example.com>
  81 To: You <you\@example.com>
  82 Cc: $addr
  83 Message-Id: <blah\@example.com>
  84 Subject: hihi
  85 Date: Thu, 01 Jan 1970 00:00:00 +0000
  86
  87 EOF
  88         my $in = $simple->as_string;
  89
  90         # ensure successful message delivery
  91         {
  92                 local $ENV{PATH} = $main_path;
  93                 IPC::Run::run([$mda], \$in);
  94                 my $rev = `git --git-dir=$maindir rev-list HEAD`;
  95                 like($rev, qr/\A[a-f0-9]{40}/, "good revision committed");
  96                 chomp $rev;
  97                 my $cmt = `git --git-dir=$maindir cat-file commit $rev`;
  98                 like($cmt, qr/^author Me <me\@example\.com> 0 \+0000\n/m,
  99                         "author info set correctly");
 100                 like($cmt, qr/^committer test <test-public\@example\.com>/m,
 101                         "committer info set correctly");
 102                 $good_rev = $rev;
 103         }
 104
 105         # ensure failures work, fail with bad spamc
 106         {
 107                 my @prev = <$faildir/new/*>;
 108                 is(scalar @prev, 0 , "nothing in PI_EMERGENCY before");
 109                 local $ENV{PATH} = $fail_path;
 110                 IPC::Run::run([$mda], \$in);
 111                 my @revs = `git --git-dir=$maindir rev-list HEAD`;
 112                 is(scalar @revs, 1, "bad revision not committed");
 113                 my @new = <$faildir/new/*>;
 114                 is(scalar @new, 1, "PI_EMERGENCY is written to");
 115         }
 116
 117         fail_bad_header($good_rev, "bad recipient", <<"");
 118 From: Me <me\@example.com>
 119 To: You <you\@example.com>
 120 Message-Id: <bad-recipient\@example.com>
 121 Subject: hihi
 122 Date: Thu, 01 Jan 1970 00:00:00 +0000
 123
 124         my $fail = fail_bad_header($good_rev, "duplicate Message-ID", <<"");
 125 From: Me <me\@example.com>
 126 To: You <you\@example.com>
 127 Cc: $addr
 128 Message-ID: <blah\@example.com>
 129 Subject: hihi
 130 Date: Thu, 01 Jan 1970 00:00:00 +0000
 131
 132         like($fail->[2], qr/CONFLICT/, "duplicate Message-ID message");
 133
 134         fail_bad_header($good_rev, "missing From:", <<"");
 135 To: $addr
 136 Message-ID: <missing-from\@example.com>
 137 Subject: hihi
 138 Date: Thu, 01 Jan 1970 00:00:00 +0000
 139
 140         fail_bad_header($good_rev, "short subject:", <<"");
 141 To: $addr
 142 From: cat\@example.com
 143 Message-ID: <short-subject\@example.com>
 144 Subject: a
 145 Date: Thu, 01 Jan 1970 00:00:00 +0000
 146
 147         fail_bad_header($good_rev, "no date", <<"");
 148 To: $addr
 149 From: u\@example.com
 150 Message-ID: <no-date\@example.com>
 151 Subject: hihi
 152
 153         fail_bad_header($good_rev, "bad date", <<"");
 154 To: $addr
 155 From: u\@example.com
 156 Message-ID: <bad-date\@example.com>
 157 Subject: hihi
 158 Date: deadbeef
 159
 160 }
 161
 162 # spam training
 163 {
 164         local $ENV{PI_EMERGENCY} = $faildir;
 165         local $ENV{HOME} = $home;
 166         local $ENV{ORIGINAL_RECIPIENT} = $addr;
 167         local $ENV{PATH} = $main_path;
 168         my $mid = 'spam-train@example.com';
 169         my $simple = Email::Simple->new(<<EOF);
 170 From: Spammer <spammer\@example.com>
 171 To: You <you\@example.com>
 172 Cc: $addr
 173 Message-ID: <$mid>
 174 Subject: this message will be trained as spam
 175 Date: Thu, 01 Jan 1970 00:00:00 +0000
 176
 177 EOF
 178         my $in = $simple->as_string;
 179
 180         {
 181                 # deliver the spam message, first
 182                 IPC::Run::run([$mda], \$in);
 183                 my $path = mid2path($mid);
 184                 my $msg = `git --git-dir=$maindir cat-file blob HEAD:$path`;
 185                 like($msg, qr/\Q$mid\E/, "message delivered");
 186
 187                 # now train it
 188                 local $ENV{GIT_AUTHOR_EMAIL} = 'trainer@example.com';
 189                 local $ENV{GIT_COMMITTER_EMAIL} = 'trainer@example.com';
 190                 local $ENV{GIT_COMMITTER_NAME} = undef;
 191                 IPC::Run::run([$learn, "spam"], \$msg);
 192                 is($?, 0, "no failure from learning spam");
 193                 IPC::Run::run([$learn, "spam"], \$msg);
 194                 is($?, 0, "no failure from learning spam idempotently");
 195         }
 196 }
 197
 198 # train ham message
 199 {
 200         local $ENV{PI_EMERGENCY} = $faildir;
 201         local $ENV{HOME} = $home;
 202         local $ENV{ORIGINAL_RECIPIENT} = $addr;
 203         local $ENV{PATH} = $main_path;
 204         my $mid = 'ham-train@example.com';
 205         my $simple = Email::Simple->new(<<EOF);
 206 From: False-positive <hammer\@example.com>
 207 To: You <you\@example.com>
 208 Cc: $addr
 209 Message-ID: <$mid>
 210 Subject: this message will be trained as spam
 211 Date: Thu, 01 Jan 1970 00:00:00 +0000
 212
 213 EOF
 214         my $in = $simple->as_string;
 215
 216         # now train it
 217         # these should be overridden
 218         local $ENV{GIT_AUTHOR_EMAIL} = 'trainer@example.com';
 219         local $ENV{GIT_COMMITTER_EMAIL} = 'trainer@example.com';
 220
 221         IPC::Run::run([$learn, "ham"], \$in);
 222         is($?, 0, "learned ham without failure");
 223         my $path = mid2path($mid);
 224         my $msg = `git --git-dir=$maindir cat-file blob HEAD:$path`;
 225         like($msg, qr/\Q$mid\E/, "ham message delivered");
 226         IPC::Run::run([$learn, "ham"], \$in);
 227         is($?, 0, "learned ham idempotently ");
 228
 229         # ensure trained email is filtered, too
 230         my $html_body = "<html><body>hi</body></html>";
 231         my $parts = [
 232                 Email::MIME->create(
 233                         attributes => {
 234                                 content_type => 'text/html; charset=UTF-8',
 235                                 encoding => 'base64',
 236                         },
 237                         body => $html_body,
 238                 ),
 239                 Email::MIME->create(
 240                         attributes => {
 241                                 content_type => 'text/plain',
 242                                 encoding => 'quoted-printable',
 243                         },
 244                         body => 'hi = "bye"',
 245                 )
 246         ];
 247         $mid = 'multipart-html-sucks@11';
 248         $mime = Email::MIME->create(
 249                 header_str => [
 250                   From => 'a@example.com',
 251                   Subject => 'blah',
 252                   Cc => $addr,
 253                   'Message-ID' => "<$mid>",
 254                   'Content-Type' => 'multipart/alternative',
 255                 ],
 256                 parts => $parts,
 257         );
 258
 259         {
 260                 $in = $mime->as_string;
 261                 IPC::Run::run([$learn, "ham"], \$in);
 262                 is($?, 0, "learned ham without failure");
 263                 my $path = mid2path($mid);
 264                 $msg = `git --git-dir=$maindir cat-file blob HEAD:$path`;
 265                 like($msg, qr/<\Q$mid\E>/, "ham message delivered");
 266                 unlike($msg, qr/<html>/i, '<html> filtered');
 267         }
 268 }
 269
 270 done_testing();
 271
 272 sub fail_bad_header {
 273         my ($good_rev, $msg, $in) = @_;
 274         my @f = glob("$faildir/*/*");
 275         unlink @f if @f;
 276         my ($out, $err) = ("", "");
 277         local $ENV{PATH} = $main_path;
 278         IPC::Run::run([$mda], \$in, \$out, \$err);
 279         my $rev = `git --git-dir=$maindir rev-list HEAD`;
 280         chomp $rev;
 281         is($rev, $good_rev, "bad revision not commited ($msg)");
 282         @f = glob("$faildir/*/*");
 283         is(scalar @f, 1, "faildir written to");
 284         [ $in, $out, $err ];
 285 }