2 # Copyright (C) 2020 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.
8 use PublicInbox::DS qw(now);
10 use PublicInbox::TestCommon;
11 my $inbox_dir = $ENV{GIANT_INBOX_DIR};
12 plan skip_all => "GIANT_INBOX_DIR not defined for $0" unless $inbox_dir;
13 # how many emails to read into memory at once per-process
14 my $BATCH = $ENV{TEST_BATCH} // 100;
15 my $REPEAT = $ENV{TEST_REPEAT} // 1;
16 diag "TEST_BATCH=$BATCH TEST_REPEAT=$REPEAT";
18 require_mods(qw(Mail::IMAPClient Email::Address::XS||Mail::Address));
19 my $imap_client = 'Mail::IMAPClient';
20 my $can_compress = $imap_client->can('compress');
21 if ($can_compress) { # hope this gets fixed upstream, soon
22 require PublicInbox::IMAPClient;
23 $imap_client = 'PublicInbox::IMAPClient';
26 my $test_tls = $ENV{TEST_SKIP_TLS} ? 0 : eval { require IO::Socket::SSL };
27 my ($cert, $key) = qw(certs/server-cert.pem certs/server-key.pem);
28 if ($test_tls && !-r $key || !-r $cert) {
30 "certs/ missing for $0, run $^X ./certs/create-certs.perl";
32 my ($tmpdir, $for_destroy) = tmpdir();
33 my %OPT = qw(User u Password p);
34 my (%STARTTLS_OPT, %IMAPS_OPT, $td, $newsgroup, $mailbox, $make_local_server);
35 if (($ENV{IMAP_TEST_URL} // '') =~ m!\Aimap://([^/]+)/(.+)\z!) {
36 ($OPT{Server}, $mailbox) = ($1, $2);
37 $OPT{Server} =~ s/:([0-9]+)\z// and $OPT{Port} = $1 + 0;
39 %IMAPS_OPT = (%OPT, Port => 993) if $OPT{Port} == 143;
41 require_mods(qw(DBD::SQLite));
42 $make_local_server->();
43 $mailbox = "$newsgroup.0";
46 my %opts = (imap => \%OPT, 'imap+compress' => { %OPT, Compress => 1 });
48 my $mic = $imap_client->new(%OPT) or BAIL_OUT "new $!";
49 $mic->examine($mailbox) or BAIL_OUT "examine: $!";
50 my $next = $mic->uidnext($mailbox) or BAIL_OUT "uidnext: $!";
54 if (scalar keys %STARTTLS_OPT) {
55 $opts{starttls} = \%STARTTLS_OPT;
56 $opts{'starttls+compress'} = { %STARTTLS_OPT, Compress => 1 };
58 if (scalar keys %IMAPS_OPT) {
59 $opts{imaps} = \%IMAPS_OPT;
60 $opts{'imaps+compress'} = { %IMAPS_OPT, Compress => 1 };
63 my $do_get_all = sub {
64 my ($desc, $opt) = @_;
65 local $SIG{__DIE__} = sub { print STDERR $desc, ': ', @_; _exit(1) };
67 my $dig = Digest::SHA->new(1);
68 my $mic = $imap_client->new(%$opt);
69 $mic->examine($mailbox) or die "examine: $!";
73 until ($uid_base > $uid_max) {
74 my $end = $uid_base + $BATCH;
75 my $ret = $mic->fetch_hash("$uid_base:$end", 'BODY[]') or last;
76 for my $uid ($uid_base..$end) {
78 my $h = delete $ret->{$uid} or next;
79 my $body = delete $h->{'BODY[]'} or
80 die "no BODY[] for UID=$uid";
82 $bytes += length($body);
87 $mic->logout or die "logout failed: $!";
88 my $elapsed = sprintf('%0.3f', now() - $t0);
89 my $res = $dig->hexdigest;
90 print STDERR "# $desc $res (${elapsed}s) $bytes bytes, NR=$nr\n";
96 while (my ($desc, $opt) = each %opts) {
97 pipe(my ($r, $w)) or die;
101 my $res = $do_get_all->($desc, $opt);
102 print $w $res or die;
107 $pids{$pid} = [ $desc, $r ];
111 while (scalar keys %pids) {
112 my $pid = waitpid(-1, 0) or next;
113 my $child = delete $pids{$pid} or next;
114 my ($desc, $rpipe) = @$child;
115 is($?, 0, "$desc done");
116 my $sum = do { local $/; <$rpipe> };
117 push @{$res{$sum}}, $desc;
119 is(scalar keys %res, 1, 'all got the same result');
122 is($?, 0, 'no error on -imapd exit');
127 $make_local_server = sub {
128 require PublicInbox::Inbox;
129 $newsgroup = 'inbox.test';
130 my $ibx = { inboxdir => $inbox_dir, newsgroup => $newsgroup };
131 $ibx = PublicInbox::Inbox->new($ibx);
132 my $pi_config = "$tmpdir/config";
134 open my $fh, '>', $pi_config or die "open($pi_config): $!";
135 print $fh <<"" or die "print $pi_config: $!";
137 newsgroup = $newsgroup
138 inboxdir = $inbox_dir
139 address = test\@example.com
141 close $fh or die "close($pi_config): $!";
143 my ($out, $err) = ("$tmpdir/out", "$tmpdir/err");
145 open my $fh, '>', $_ or die "truncate: $!";
147 my $imap = tcp_server();
148 my $rdr = { 3 => $imap };
149 $OPT{Server} = $imap->sockhost;
150 $OPT{Port} = $imap->sockport;
152 # not using multiple workers, here, since we want to increase
153 # the chance of tripping concurrency bugs within PublicInbox/IMAP*.pm
154 my $cmd = [ '-imapd', "--stdout=$out", "--stderr=$err", '-W0' ];
155 push @$cmd, '-limap://'.$imap->sockhost.':'.$imap->sockport;
157 my $imaps = tcp_server();
159 push @$cmd, '-limaps://'.$imaps->sockhost.':'.$imaps->sockport;
160 push @$cmd, "--cert=$cert", "--key=$key";
162 SSL_hostname => 'server.local',
163 SSL_verifycn_name => 'server.local',
164 SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_PEER(),
165 SSL_ca_file => 'certs/test-ca.pem',
167 %STARTTLS_OPT = (%OPT, Starttls => $tls_opt);
168 %IMAPS_OPT = (%OPT, Ssl => $tls_opt,
169 Server => $imaps->sockhost,
170 Port => $imaps->sockport
173 print STDERR "# CMD ". join(' ', @$cmd). "\n";
174 my $env = { PI_CONFIG => $pi_config };
175 $td = start_script($cmd, $env, $rdr);