t/lei_to_mail.t

   1 #!perl -w
   2 # Copyright (C) 2020-2021 all contributors <meta@public-inbox.org>
   3 # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
   4 use strict;
   5 use v5.10.1;
   6 use Test::More;
   7 use PublicInbox::TestCommon;
   8 use PublicInbox::Eml;
   9 use Fcntl qw(SEEK_SET);
  10 use PublicInbox::Spawn qw(popen_rd which);
  11 use List::Util qw(shuffle);
  12 require_mods(qw(DBD::SQLite));
  13 require PublicInbox::MboxReader;
  14 require PublicInbox::LeiOverview;
  15 use_ok 'PublicInbox::LeiToMail';
  16 my $from = "Content-Length: 10\nSubject: x\n\nFrom hell\n";
  17 my $noeol = "Subject: x\n\nFrom hell";
  18 my $crlf = $noeol;
  19 $crlf =~ s/\n/\r\n/g;
  20 my $kw = [qw(seen answered flagged)];
  21 my @MBOX = qw(mboxcl2 mboxrd mboxcl mboxo);
  22 for my $mbox (@MBOX) {
  23         my $m = "eml2$mbox";
  24         my $cb = PublicInbox::LeiToMail->can($m);
  25         my $s = $cb->(PublicInbox::Eml->new($from), $kw);
  26         is(substr($$s, -1, 1), "\n", "trailing LF in normal $mbox");
  27         my $eml = PublicInbox::Eml->new($s);
  28         is($eml->header('Status'), 'R', "Status: set by $m");
  29         is($eml->header('X-Status'), 'AF', "X-Status: set by $m");
  30         if ($mbox eq 'mboxcl2') {
  31                 like($eml->body_raw, qr/^From /, "From not escaped $m");
  32         } else {
  33                 like($eml->body_raw, qr/^>From /, "From escaped once by $m");
  34         }
  35         my @cl = $eml->header('Content-Length');
  36         if ($mbox =~ /mboxcl/) {
  37                 is(scalar(@cl), 1, "$m only has one Content-Length header");
  38                 is($cl[0] + length("\n"),
  39                         length($eml->body_raw), "$m Content-Length matches");
  40         } else {
  41                 is(scalar(@cl), 0, "$m clobbered Content-Length");
  42         }
  43         $s = $cb->(PublicInbox::Eml->new($noeol), $kw);
  44         is(substr($$s, -1, 1), "\n",
  45                 "trailing LF added by $m when original lacks EOL");
  46         $eml = PublicInbox::Eml->new($s);
  47         if ($mbox eq 'mboxcl2') {
  48                 is($eml->body_raw, "From hell\n", "From not escaped by $m");
  49         } else {
  50                 is($eml->body_raw, ">From hell\n", "From escaped once by $m");
  51         }
  52         $s = $cb->(PublicInbox::Eml->new($crlf), $kw);
  53         is(substr($$s, -2, 2), "\r\n",
  54                 "trailing CRLF added $m by original lacks EOL");
  55         $eml = PublicInbox::Eml->new($s);
  56         if ($mbox eq 'mboxcl2') {
  57                 is($eml->body_raw, "From hell\r\n", "From not escaped by $m");
  58         } else {
  59                 is($eml->body_raw, ">From hell\r\n", "From escaped once by $m");
  60         }
  61         if ($mbox =~ /mboxcl/) {
  62                 is($eml->header('Content-Length') + length("\r\n"),
  63                         length($eml->body_raw), "$m Content-Length matches");
  64         } elsif ($mbox eq 'mboxrd') {
  65                 $s = $cb->($eml, $kw);
  66                 $eml = PublicInbox::Eml->new($s);
  67                 is($eml->body_raw,
  68                         ">>From hell\r\n\r\n", "From escaped again by $m");
  69         }
  70 }
  71
  72 my ($tmpdir, $for_destroy) = tmpdir();
  73 local $ENV{TMPDIR} = $tmpdir;
  74 open my $err, '>>', "$tmpdir/lei.err" or BAIL_OUT $!;
  75 my $lei = { 2 => $err };
  76 my $buf = <<'EOM';
  77 From: x@example.com
  78 Subject: x
  79
  80 blah
  81 EOM
  82 my $fn = "$tmpdir/x.mbox";
  83 my ($mbox) = shuffle(@MBOX); # pick one, shouldn't matter
  84 my $wcb_get = sub {
  85         my ($fmt, $dst) = @_;
  86         delete $lei->{dedupe};
  87         $lei->{ovv} = bless {
  88                 fmt => $fmt,
  89                 dst => $dst
  90         }, 'PublicInbox::LeiOverview';
  91         my $l2m = PublicInbox::LeiToMail->new($lei);
  92         SKIP: {
  93                 require_mods('Storable', 1);
  94                 my $dup = Storable::thaw(Storable::freeze($l2m));
  95                 is_deeply($dup, $l2m, "$fmt round-trips through storable");
  96         }
  97         $l2m->pre_augment($lei);
  98         $l2m->do_augment($lei);
  99         $l2m->post_augment($lei);
 100         my $cb = $l2m->write_cb($lei);
 101         delete $lei->{1};
 102         $cb;
 103 };
 104
 105 my $orig = do {
 106         my $wcb = $wcb_get->($mbox, $fn);
 107         is(ref $wcb, 'CODE', 'write_cb returned callback');
 108         ok(-f $fn && !-s _, 'empty file created');
 109         $wcb->(\(my $dup = $buf), 'deadbeef', [ qw(seen) ]);
 110         undef $wcb;
 111         open my $fh, '<', $fn or BAIL_OUT $!;
 112         my $raw = do { local $/; <$fh> };
 113         like($raw, qr/^blah\n/sm, 'wrote content');
 114         unlink $fn or BAIL_OUT $!;
 115
 116         local $lei->{opt} = { jobs => 2 };
 117         $wcb = $wcb_get->($mbox, $fn);
 118         ok(-f $fn && !-s _, 'truncated mbox destination');
 119         $wcb->(\($dup = $buf), 'deadbeef', [ qw(seen) ]);
 120         undef $wcb;
 121         open $fh, '<', $fn or BAIL_OUT $!;
 122         is(do { local $/; <$fh> }, $raw, 'jobs > 1');
 123         $raw;
 124 };
 125 for my $zsfx (qw(gz bz2 xz)) { # XXX should we support zst, zz, lzo, lzma?
 126         my $zsfx2cmd = PublicInbox::LeiToMail->can('zsfx2cmd');
 127         SKIP: {
 128                 my $cmd = eval { $zsfx2cmd->($zsfx, 0, $lei) };
 129                 skip $@, 3 if $@;
 130                 my $dc_cmd = eval { $zsfx2cmd->($zsfx, 1, $lei) };
 131                 ok($dc_cmd, "decompressor for .$zsfx");
 132                 my $f = "$fn.$zsfx";
 133                 my $wcb = $wcb_get->($mbox, $f);
 134                 $wcb->(\(my $dup = $buf), 'deadbeef', [ qw(seen) ]);
 135                 undef $wcb;
 136                 my $uncompressed = xqx([@$dc_cmd, $f]);
 137                 is($uncompressed, $orig, "$zsfx works unlocked");
 138
 139                 local $lei->{opt} = { jobs => 2 }; # for atomic writes
 140                 unlink $f or BAIL_OUT "unlink $!";
 141                 $wcb = $wcb_get->($mbox, $f);
 142                 $wcb->(\($dup = $buf), 'deadbeef', [ qw(seen) ]);
 143                 undef $wcb;
 144                 is(xqx([@$dc_cmd, $f]), $orig, "$zsfx matches with lock");
 145
 146                 local $lei->{opt} = { augment => 1 };
 147                 $wcb = $wcb_get->($mbox, $f);
 148                 $wcb->(\($dup = $buf . "\nx\n"), 'deadbeef', [ qw(seen) ]);
 149                 undef $wcb; # commit
 150
 151                 my $cat = popen_rd([@$dc_cmd, $f]);
 152                 my @raw;
 153                 PublicInbox::MboxReader->$mbox($cat,
 154                         sub { push @raw, shift->as_string });
 155                 like($raw[1], qr/\nblah\n\nx\n\z/s, "augmented $zsfx");
 156                 like($raw[0], qr/\nblah\n\z/s, "original preserved $zsfx");
 157
 158                 local $lei->{opt} = { augment => 1, jobs => 2 };
 159                 $wcb = $wcb_get->($mbox, $f);
 160                 $wcb->(\($dup = $buf . "\ny\n"), 'deadbeef', [ qw(seen) ]);
 161                 undef $wcb; # commit
 162
 163                 my @raw3;
 164                 $cat = popen_rd([@$dc_cmd, $f]);
 165                 PublicInbox::MboxReader->$mbox($cat,
 166                         sub { push @raw3, shift->as_string });
 167                 my $y = pop @raw3;
 168                 is_deeply(\@raw3, \@raw, 'previous messages preserved');
 169                 like($y, qr/\nblah\n\ny\n\z/s, "augmented $zsfx (atomic)");
 170         }
 171 }
 172
 173 unlink $fn or BAIL_OUT $!;
 174 if ('default deduplication uses content_hash') {
 175         my $wcb = $wcb_get->('mboxo', $fn);
 176         $wcb->(\(my $x = $buf), 'deadbeef', []) for (1..2);
 177         undef $wcb; # undef to commit changes
 178         my $cmp = '';
 179         open my $fh, '<', $fn or BAIL_OUT $!;
 180         PublicInbox::MboxReader->mboxo($fh, sub { $cmp .= shift->as_string });
 181         is($cmp, $buf, 'only one message written');
 182
 183         local $lei->{opt} = { augment => 1 };
 184         $wcb = $wcb_get->('mboxo', $fn);
 185         $wcb->(\($x = $buf . "\nx\n"), 'deadbeef', []) for (1..2);
 186         undef $wcb; # undef to commit changes
 187         open $fh, '<', $fn or BAIL_OUT $!;
 188         my @x;
 189         PublicInbox::MboxReader->mboxo($fh, sub { push @x, shift->as_string });
 190         is(scalar(@x), 2, 'augmented mboxo');
 191         is($x[0], $cmp, 'original message preserved');
 192         is($x[1], $buf . "\nx\n", 'new message appended');
 193 }
 194
 195 { # stdout support
 196         open my $tmp, '+>', undef or BAIL_OUT $!;
 197         local $lei->{1} = $tmp;
 198         my $wcb = $wcb_get->('mboxrd', '/dev/stdout');
 199         $wcb->(\(my $x = $buf), 'deadbeef', []);
 200         undef $wcb; # commit
 201         seek($tmp, 0, SEEK_SET) or BAIL_OUT $!;
 202         my $cmp = '';
 203         PublicInbox::MboxReader->mboxrd($tmp, sub { $cmp .= shift->as_string });
 204         is($cmp, $buf, 'message written to stdout');
 205 }
 206
 207 SKIP: { # FIFO support
 208         use POSIX qw(mkfifo);
 209         my $fn = "$tmpdir/fifo";
 210         mkfifo($fn, 0600) or skip("mkfifo not supported: $!", 1);
 211         my $cat = popen_rd([which('cat'), $fn]);
 212         my $wcb = $wcb_get->('mboxo', $fn);
 213         $wcb->(\(my $x = $buf), 'deadbeef', []);
 214         undef $wcb; # commit
 215         my $cmp = '';
 216         PublicInbox::MboxReader->mboxo($cat, sub { $cmp .= shift->as_string });
 217         is($cmp, $buf, 'message written to FIFO');
 218 }
 219
 220 { # Maildir support
 221         my $md = "$tmpdir/maildir/";
 222         my $wcb = $wcb_get->('maildir', $md);
 223         is(ref($wcb), 'CODE', 'got Maildir callback');
 224         $wcb->(\(my $x = $buf), 'badc0ffee', []);
 225
 226         my @f;
 227         PublicInbox::LeiToMail::_maildir_each_file($md, sub { push @f, shift });
 228         open my $fh, $f[0] or BAIL_OUT $!;
 229         is(do { local $/; <$fh> }, $buf, 'wrote to Maildir');
 230
 231         $wcb = $wcb_get->('maildir', $md);
 232         $wcb->(\($x = $buf."\nx\n"), 'deadcafe', []);
 233
 234         my @x = ();
 235         PublicInbox::LeiToMail::_maildir_each_file($md, sub { push @x, shift });
 236         is(scalar(@x), 1, 'wrote one new file');
 237         ok(!-f $f[0], 'old file clobbered');
 238         open $fh, $x[0] or BAIL_OUT $!;
 239         is(do { local $/; <$fh> }, $buf."\nx\n", 'wrote new file to Maildir');
 240
 241         local $lei->{opt}->{augment} = 1;
 242         $wcb = $wcb_get->('maildir', $md);
 243         $wcb->(\($x = $buf."\ny\n"), 'deadcafe', []);
 244         $wcb->(\($x = $buf."\ny\n"), 'b4dc0ffee', []); # skipped by dedupe
 245         @f = ();
 246         PublicInbox::LeiToMail::_maildir_each_file($md, sub { push @f, shift });
 247         is(scalar grep(/\A\Q$x[0]\E\z/, @f), 1, 'old file still there');
 248         my @new = grep(!/\A\Q$x[0]\E\z/, @f);
 249         is(scalar @new, 1, '1 new file written (b4dc0ffee skipped)');
 250         open $fh, $x[0] or BAIL_OUT $!;
 251         is(do { local $/; <$fh> }, $buf."\nx\n", 'old file untouched');
 252         open $fh, $new[0] or BAIL_OUT $!;
 253         is(do { local $/; <$fh> }, $buf."\ny\n", 'new file written');
 254 }
 255
 256 done_testing;