t/extractor.t

   1 #!/usr/bin/perl -w
   2 # Copyright (C) 2013-2016 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 warnings;
   6 use Test::More;
   7 use Ssoma::Extractor;
   8 use Ssoma::Git;
   9 use Ssoma::MDA;
  10 use File::Temp qw/tempdir/;
  11
  12 my $mdadir = tempdir('ssoma-extractor-mda-XXXXXX', TMPDIR => 1, CLEANUP => 1);
  13 my $outdir = tempdir('ssoma-extractor-out-XXXXXX', TMPDIR => 1, CLEANUP => 1);
  14
  15 my $outgit = Ssoma::Git->new("$outdir/git");
  16 my $ex = Ssoma::Extractor->new($outgit);
  17 my $maildir = "$outdir/maildir/";
  18 my $mailbox = "$outdir/mbox";
  19
  20 my $mdagit = Ssoma::Git->new("$mdadir/gittest");
  21 $mdagit->init_db('-q');
  22 my $mda = Ssoma::MDA->new($mdagit);
  23 my $email = Email::MIME->new(<<'EOF');
  24 From: U <u@example.com>
  25 To: Me <me@example.com>
  26 Message-ID: <666@example.com>
  27 Subject: :o
  28
  29 HIHI
  30 EOF
  31
  32 $mda->deliver($email);
  33
  34 {
  35         my @cmd = (qw/git clone -q --mirror/,
  36                         $mdagit->{git_dir}, $outgit->{git_dir});
  37         is(system(@cmd), 0, "extractor repository cloned");
  38 }
  39
  40 {
  41         local $ENV{GIT_CONFIG} = "$outgit->{git_dir}/ssoma.state";
  42         is(system(qw/git config target.mydir.path/, $maildir), 0,
  43            "setup maildir");
  44 }
  45
  46
  47 my $check_last = sub {
  48         my ($key) = @_;
  49         local $ENV{GIT_CONFIG} = "$outgit->{git_dir}/ssoma.state";
  50         my $last = `git config $key`;
  51         is($?, 0, "git config succeeds");
  52         like($last, qr/^[a-f0-9]{40}$/, "last-imported is a SHA1");
  53 };
  54
  55 {
  56         $ex->extract("mydir");
  57         my @new = glob("$outdir/maildir/new/*");
  58         is(scalar @new, 1, "one file now exists in maildir");
  59         my $f = $new[0];
  60         open my $fh, '<', $f or die "opening $f failed: $!\n";
  61         local $/;
  62         my $s = <$fh>;
  63         my $mime = Email::MIME->new($s);
  64         is($mime->header('message-id'), '<666@example.com>',
  65                 "delivered message-id matches");
  66         $check_last->("target.mydir.last-imported");
  67         unlink $f or die "failed to unlink $f: $!\n";
  68 }
  69
  70 {
  71         local $ENV{GIT_CONFIG} = "$outgit->{git_dir}/ssoma.state";
  72         is(system(qw/git config target.mybox.path/, $mailbox), 0,
  73            "setup mailbox");
  74 }
  75
  76 {
  77         $ex->extract("mybox");
  78         open my $fh, '<', $mailbox or die "opening $mailbox failed: $!\n";
  79         local $/;
  80         my $s = <$fh>;
  81         my $mime = Email::MIME->new($s);
  82         is($mime->header('message-id'), '<666@example.com>',
  83                         "delivered message-id matches");
  84         $check_last->("target.mybox.last-imported");
  85 }
  86
  87 my $another = Email::MIME->new(<<'EOF');
  88 From: U <u@example.com>
  89 To: Me <me@example.com>
  90 Message-ID: <666666@example.com>
  91 Subject: byebye
  92
  93 *yawn*
  94 EOF
  95 $mda->deliver($another);
  96
  97 {
  98         local $ENV{GIT_DIR} = $outgit->{git_dir};
  99         is(system("git fetch -q"), 0, "fetching updates succeeds");
 100 }
 101
 102 # ensure we can update maildir without adding old messages
 103 {
 104
 105         $ex->extract("mydir");
 106         my @new = glob("$outdir/maildir/new/*");
 107         is(scalar @new, 1, "one new file now exists in maildir");
 108         my $f = $new[0];
 109         open my $fh, '<', $f or die "opening $f failed: $!\n";
 110         local $/;
 111         my $s = <$fh>;
 112         my $mime = Email::MIME->new($s);
 113         is($mime->header('message-id'), '<666666@example.com>',
 114                 "delivered message-id matches");
 115         is($mime->body, "*yawn*\n", "body matches");
 116         $check_last->("target.mydir.last-imported");
 117         unlink $f or die "failed to unlink $f: $!\n"; # for next test
 118 }
 119
 120 # ensure we can update mmbox without adding old messages
 121 {
 122
 123         $ex->extract("mybox");
 124         open my $fh, '<', $mailbox or die "opening $mailbox failed: $!\n";
 125         my @lines = <$fh>;
 126         my @subjects = grep /^Subject:/, @lines;
 127         my @from_ = grep /^From /, @lines;
 128         is(scalar @subjects, 2, "2 subjects in mbox");
 129         is(scalar @from_, 2, "2 From_ lines in mbox");
 130
 131         $check_last->("target.mydir.last-imported");
 132 }
 133
 134 # ensure we can handle conflicts w/o reimporting when the MDA
 135 # upgrades a blob to a tree.
 136 my $conflict = Email::MIME->new(<<'EOF');
 137 From: U <u@example.com>
 138 To: Me <me@example.com>
 139 Message-ID: <666666@example.com>
 140 Subject: BYE
 141
 142 *YAWN*
 143 EOF
 144 $mda->deliver($conflict);
 145
 146 {
 147         local $ENV{GIT_DIR} = $outgit->{git_dir};
 148         is(system("git fetch -q"), 0, "fetching updates succeeds");
 149 }
 150
 151 # ensure we can update maildir without adding old messages even on a
 152 # message-id conflict
 153 {
 154
 155         $ex->extract("mydir");
 156         my @new = glob("$outdir/maildir/new/*");
 157         is(scalar @new, 1, "one new file now exists in maildir");
 158         my $f = $new[0];
 159         open my $fh, '<', $f or die "opening $f failed: $!\n";
 160         local $/;
 161         my $s = <$fh>;
 162         my $mime = Email::MIME->new($s);
 163         is($mime->header('message-id'), '<666666@example.com>',
 164                 "delivered conflicting message-id matches");
 165         is($mime->body, "*YAWN*\n", "body matches on conflict");
 166         $check_last->("target.mydir.last-imported");
 167 }
 168
 169 # ensure we can pipe to commands
 170 {
 171         {
 172                 my $cat = "cat >> $outdir/cat.out";
 173                 local $ENV{GIT_CONFIG} = "$outgit->{git_dir}/ssoma.state";
 174                 is(system(qw/git config target.cat.command/, $cat), 0,
 175                    "setup delivery command");
 176         }
 177
 178         $ex->extract("cat");
 179         my $f = "$outdir/cat.out";
 180         open my $fh, '<', $f or die "open $f failed: $!\n";
 181         my @lines = <$fh>;
 182         my @subjects = grep /^Subject:/, @lines;
 183         my @from = grep /^From:/, @lines;
 184         my @mid = grep /^Message-ID:/i, @lines;
 185         is(scalar @subjects, 3, "3 subjects in dump");
 186         is(scalar @mid, 3, "3 message-ids in dump");
 187         is(scalar @from, 3, "3 From: lines in dump");
 188
 189         $check_last->("target.cat.last-imported");
 190 }
 191
 192 done_testing();