xt/imapd-validate.t

   1 #!perl -w
   2 # Copyright (C) all contributors <meta@public-inbox.org>
   3 # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
   4 # Expensive test to validate compression and TLS.
   5 use strict;
   6 use v5.10.1;
   7 use Symbol qw(gensym);
   8 use PublicInbox::DS qw(now);
   9 use PublicInbox::SHA;
  10 use POSIX qw(_exit);
  11 use PublicInbox::TestCommon;
  12 my $inbox_dir = $ENV{GIANT_INBOX_DIR};
  13 plan skip_all => "GIANT_INBOX_DIR not defined for $0" unless $inbox_dir;
  14 # how many emails to read into memory at once per-process
  15 my $BATCH = $ENV{TEST_BATCH} // 100;
  16 my $REPEAT = $ENV{TEST_REPEAT} // 1;
  17 diag "TEST_BATCH=$BATCH TEST_REPEAT=$REPEAT";
  18
  19 require_mods(qw(Mail::IMAPClient -imapd));
  20 my $imap_client = 'Mail::IMAPClient';
  21 my $can_compress = $imap_client->can('compress');
  22 if ($can_compress) { # hope this gets fixed upstream, soon
  23         require PublicInbox::IMAPClient;
  24         $imap_client = 'PublicInbox::IMAPClient';
  25 }
  26
  27 my $test_tls = $ENV{TEST_SKIP_TLS} ? 0 : eval { require IO::Socket::SSL };
  28 my ($cert, $key) = qw(certs/server-cert.pem certs/server-key.pem);
  29 if ($test_tls && !-r $key || !-r $cert) {
  30         plan skip_all =>
  31                 "certs/ missing for $0, run $^X ./certs/create-certs.perl";
  32 }
  33 my ($tmpdir, $for_destroy) = tmpdir();
  34 my %OPT = qw(User u Password p);
  35 my (%STARTTLS_OPT, %IMAPS_OPT, $td, $newsgroup, $mailbox, $make_local_server);
  36 if (($ENV{IMAP_TEST_URL} // '') =~ m!\Aimap://([^/]+)/(.+)\z!) {
  37         ($OPT{Server}, $mailbox) = ($1, $2);
  38         $OPT{Server} =~ s/:([0-9]+)\z// and $OPT{Port} = $1 + 0;
  39         %STARTTLS_OPT = %OPT;
  40         %IMAPS_OPT = (%OPT, Port => 993) if $OPT{Port} == 143;
  41 } else {
  42         require_mods(qw(DBD::SQLite));
  43         $make_local_server->();
  44         $mailbox = "$newsgroup.0";
  45 }
  46
  47 my %opts = (imap => \%OPT, 'imap+compress' => { %OPT, Compress => 1 });
  48 my $uid_max = do {
  49         my $mic = $imap_client->new(%OPT) or BAIL_OUT "new $!";
  50         $mic->examine($mailbox) or BAIL_OUT "examine: $!";
  51         my $next = $mic->uidnext($mailbox) or BAIL_OUT "uidnext: $!";
  52         $next - 1;
  53 };
  54
  55 if (scalar keys %STARTTLS_OPT) {
  56         $opts{starttls} = \%STARTTLS_OPT;
  57         $opts{'starttls+compress'} = { %STARTTLS_OPT, Compress => 1 };
  58 }
  59 if (scalar keys %IMAPS_OPT) {
  60         $opts{imaps} = \%IMAPS_OPT;
  61         $opts{'imaps+compress'} = { %IMAPS_OPT, Compress => 1 };
  62 }
  63
  64 my $do_get_all = sub {
  65         my ($desc, $opt) = @_;
  66         local $SIG{__DIE__} = sub { print STDERR $desc, ': ', @_; _exit(1) };
  67         my $t0 = now();
  68         my $dig = PublicInbox::SHA->new(1);
  69         my $mic = $imap_client->new(%$opt);
  70         $mic->examine($mailbox) or die "examine: $!";
  71         my $uid_base = 1;
  72         my $bytes = 0;
  73         my $nr = 0;
  74         until ($uid_base > $uid_max) {
  75                 my $end = $uid_base + $BATCH;
  76                 my $ret = $mic->fetch_hash("$uid_base:$end", 'BODY[]') or last;
  77                 for my $uid ($uid_base..$end) {
  78                         $dig->add($uid);
  79                         my $h = delete $ret->{$uid} or next;
  80                         my $body = delete $h->{'BODY[]'} or
  81                                                 die "no BODY[] for UID=$uid";
  82                         $dig->add($body);
  83                         $bytes += length($body);
  84                         ++$nr;
  85                 }
  86                 $uid_base = $end + 1;
  87         }
  88         $mic->logout or die "logout failed: $!";
  89         my $elapsed = sprintf('%0.3f', now() - $t0);
  90         my $res = $dig->hexdigest;
  91         print STDERR "# $desc $res (${elapsed}s) $bytes bytes, NR=$nr\n";
  92         $res;
  93 };
  94
  95 my (%pids, %res);
  96 for (1..$REPEAT) {
  97         while (my ($desc, $opt) = each %opts) {
  98                 pipe(my ($r, $w)) or die;
  99                 my $pid = fork;
 100                 if ($pid == 0) {
 101                         close $r or die;
 102                         my $res = $do_get_all->($desc, $opt);
 103                         print $w $res or die;
 104                         close $w or die;
 105                         _exit(0);
 106                 }
 107                 close $w or die;
 108                 $pids{$pid} = [ $desc, $r ];
 109         }
 110 }
 111
 112 while (scalar keys %pids) {
 113         my $pid = waitpid(-1, 0) or next;
 114         my $child = delete $pids{$pid} or next;
 115         my ($desc, $rpipe) = @$child;
 116         is($?, 0, "$desc done");
 117         my $sum = do { local $/; <$rpipe> };
 118         push @{$res{$sum}}, $desc;
 119 }
 120 is(scalar keys %res, 1, 'all got the same result');
 121 $td->kill;
 122 $td->join;
 123 is($?, 0, 'no error on -imapd exit');
 124 done_testing;
 125
 126 BEGIN {
 127
 128 $make_local_server = sub {
 129         require PublicInbox::Inbox;
 130         $newsgroup = 'inbox.test';
 131         my $ibx = { inboxdir => $inbox_dir, newsgroup => $newsgroup };
 132         $ibx = PublicInbox::Inbox->new($ibx);
 133         my $pi_config = "$tmpdir/config";
 134         {
 135                 open my $fh, '>', $pi_config or die "open($pi_config): $!";
 136                 print $fh <<"" or die "print $pi_config: $!";
 137 [publicinbox "test"]
 138         newsgroup = $newsgroup
 139         inboxdir = $inbox_dir
 140         address = test\@example.com
 141
 142                 close $fh or die "close($pi_config): $!";
 143         }
 144         my ($out, $err) = ("$tmpdir/out", "$tmpdir/err");
 145         for ($out, $err) {
 146                 open my $fh, '>', $_ or die "truncate: $!";
 147         }
 148         my $imap = tcp_server();
 149         my $rdr = { 3 => $imap };
 150         $OPT{Server} = $imap->sockhost;
 151         $OPT{Port} = $imap->sockport;
 152
 153         # not using multiple workers, here, since we want to increase
 154         # the chance of tripping concurrency bugs within PublicInbox/IMAP*.pm
 155         my $cmd = [ '-imapd', "--stdout=$out", "--stderr=$err", '-W0' ];
 156         push @$cmd, '-limap://'.tcp_host_port($imap);
 157         if ($test_tls) {
 158                 my $imaps = tcp_server();
 159                 $rdr->{4} = $imaps;
 160                 push @$cmd, '-limaps://'.tcp_host_port($imaps);
 161                 push @$cmd, "--cert=$cert", "--key=$key";
 162                 my $tls_opt = [
 163                         SSL_hostname => 'server.local',
 164                         SSL_verifycn_name => 'server.local',
 165                         SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_PEER(),
 166                         SSL_ca_file => 'certs/test-ca.pem',
 167                 ];
 168                 %STARTTLS_OPT = (%OPT, Starttls => $tls_opt);
 169                 %IMAPS_OPT = (%OPT, Ssl => $tls_opt,
 170                         Server => $imaps->sockhost,
 171                         Port => $imaps->sockport
 172                 );
 173         }
 174         print STDERR "# CMD ". join(' ', @$cmd). "\n";
 175         my $env = { PI_CONFIG => $pi_config };
 176         $td = start_script($cmd, $env, $rdr);
 177 };
 178 } # BEGIN