t/imapd-tls.t

   1 # Copyright (C) 2020 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 Socket qw(IPPROTO_TCP SOL_SOCKET);
   7 use PublicInbox::TestCommon;
   8 # IO::Poll is part of the standard library, but distros may split it off...
   9 require_mods(qw(DBD::SQLite IO::Socket::SSL Mail::IMAPClient IO::Poll));
  10 Mail::IMAPClient->can('starttls') or
  11         plan skip_all => 'Mail::IMAPClient does not support TLS';
  12 my $cert = 'certs/server-cert.pem';
  13 my $key = 'certs/server-key.pem';
  14 unless (-r $key && -r $cert) {
  15         plan skip_all =>
  16                 "certs/ missing for $0, run $^X ./create-certs.perl in certs/";
  17 }
  18 use_ok 'PublicInbox::TLS';
  19 use_ok 'IO::Socket::SSL';
  20 use PublicInbox::InboxWritable;
  21 require PublicInbox::SearchIdx;
  22 my $version = 1; # v2 needs newer git
  23 require_git('2.6') if $version >= 2;
  24 my ($tmpdir, $for_destroy) = tmpdir();
  25 my $err = "$tmpdir/stderr.log";
  26 my $out = "$tmpdir/stdout.log";
  27 my $inboxdir = "$tmpdir";
  28 my $pi_config = "$tmpdir/pi_config";
  29 my $group = 'test-imapd-tls';
  30 my $addr = $group . '@example.com';
  31 my $starttls = tcp_server();
  32 my $imaps = tcp_server();
  33 my $ibx = PublicInbox::Inbox->new({
  34         inboxdir => $inboxdir,
  35         name => 'imapd-tls',
  36         version => $version,
  37         -primary_address => $addr,
  38         indexlevel => 'basic',
  39 });
  40 $ibx = PublicInbox::InboxWritable->new($ibx, {nproc=>1});
  41 $ibx->init_inbox(0);
  42 {
  43         open my $fh, '>', $pi_config or BAIL_OUT "open: $!";
  44         print $fh <<EOF
  45 [publicinbox "imapd-tls"]
  46         inboxdir = $inboxdir
  47         address = $addr
  48         indexlevel = basic
  49         newsgroup = $group
  50 EOF
  51         ;
  52         close $fh or BAIL_OUT "close: $!\n";
  53 }
  54
  55 {
  56         my $im = $ibx->importer(0);
  57         ok($im->add(eml_load('t/data/0001.patch')), 'message added');
  58         $im->done;
  59         if ($version == 1) {
  60                 my $s = PublicInbox::SearchIdx->new($ibx, 1);
  61                 $s->index_sync;
  62         }
  63 }
  64
  65 my $imaps_addr = $imaps->sockhost . ':' . $imaps->sockport;
  66 my $starttls_addr = $starttls->sockhost . ':' . $starttls->sockport;
  67 my $env = { PI_CONFIG => $pi_config };
  68 my $td;
  69
  70 # Mail::IMAPClient ->compress creates cyclic reference:
  71 # https://rt.cpan.org/Ticket/Display.html?id=132654
  72 my $compress_logout = sub {
  73         my ($c) = @_;
  74         ok($c->logout, 'logout ok after ->compress');
  75         # all documented in Mail::IMAPClient manpage:
  76         for (qw(Readmoremethod Readmethod Prewritemethod)) {
  77                 $c->$_(undef);
  78         }
  79 };
  80
  81
  82 for my $args (
  83         [ "--cert=$cert", "--key=$key",
  84                 "-limaps://$imaps_addr",
  85                 "-limap://$starttls_addr" ],
  86 ) {
  87         for ($out, $err) {
  88                 open my $fh, '>', $_ or BAIL_OUT "truncate: $!";
  89         }
  90         my $cmd = [ '-imapd', '-W0', @$args, "--stdout=$out", "--stderr=$err" ];
  91         $td = start_script($cmd, $env, { 3 => $starttls, 4 => $imaps });
  92         my %o = (
  93                 SSL_hostname => 'server.local',
  94                 SSL_verifycn_name => 'server.local',
  95                 SSL_verify_mode => SSL_VERIFY_PEER(),
  96                 SSL_ca_file => 'certs/test-ca.pem',
  97         );
  98         # start negotiating a slow TLS connection
  99         my $slow = tcp_connect($imaps, Blocking => 0);
 100         $slow = IO::Socket::SSL->start_SSL($slow, SSL_startHandshake => 0, %o);
 101         my $slow_done = $slow->connect_SSL;
 102         my @poll;
 103         if ($slow_done) {
 104                 diag('W: connect_SSL early OK, slow client test invalid');
 105                 use PublicInbox::Syscall qw(EPOLLIN EPOLLOUT);
 106                 @poll = (fileno($slow), EPOLLIN | EPOLLOUT);
 107         } else {
 108                 @poll = (fileno($slow), PublicInbox::TLS::epollbit());
 109         }
 110         # we should call connect_SSL much later...
 111         my %imaps_opt = (User => 'a', Password => 'b',
 112                         Server => $imaps->sockhost,
 113                         Port => $imaps->sockport);
 114         # IMAPS
 115         my $c = Mail::IMAPClient->new(%imaps_opt, Ssl => [ %o ]);
 116         ok($c && $c->IsAuthenticated, 'authenticated');
 117         ok($c->select($group), 'SELECT works');
 118         ok(!(scalar $c->has_capability('STARTTLS')),
 119                 'starttls not advertised with IMAPS');
 120         ok(!$c->starttls, "starttls fails");
 121         ok($c->has_capability('COMPRESS'), 'compress advertised');
 122         ok($c->compress, 'compression enabled with IMAPS');
 123         ok(!$c->starttls, 'starttls still fails');
 124         ok($c->noop, 'noop succeeds');
 125         $compress_logout->($c);
 126
 127         # STARTTLS
 128         my %imap_opt = (Server => $starttls->sockhost,
 129                         Port => $starttls->sockport);
 130         $c = Mail::IMAPClient->new(%imap_opt);
 131         ok(scalar $c->has_capability('STARTTLS'),
 132                 'starttls advertised');
 133         ok($c->Starttls([ %o ]), 'set starttls options');
 134         ok($c->starttls, '->starttls works');
 135         ok(!(scalar($c->has_capability('STARTTLS'))),
 136                 'starttls not advertised');
 137         ok(!$c->starttls, '->starttls again fails');
 138         ok(!(scalar($c->has_capability('STARTTLS'))),
 139                 'starttls still not advertised');
 140         ok($c->examine($group), 'EXAMINE works');
 141         ok($c->noop, 'NOOP works');
 142         ok($c->compress, 'compression enabled with IMAPS');
 143         ok($c->noop, 'NOOP works after compress');
 144         $compress_logout->($c);
 145
 146         # STARTTLS with bad hostname
 147         $o{SSL_hostname} = $o{SSL_verifycn_name} = 'server.invalid';
 148         $c = Mail::IMAPClient->new(%imap_opt);
 149         ok(scalar $c->has_capability('STARTTLS'), 'starttls advertised');
 150         ok($c->Starttls([ %o ]), 'set starttls options');
 151         ok(!$c->starttls, '->starttls fails with bad hostname');
 152
 153         $c = Mail::IMAPClient->new(%imap_opt);
 154         ok($c->noop, 'NOOP still works from plain IMAP');
 155
 156         # IMAPS with bad hostname
 157         $c = Mail::IMAPClient->new(%imaps_opt, Ssl => [ %o ]);
 158         is($c, undef, 'IMAPS fails with bad hostname');
 159
 160         # make hostname valid
 161         $o{SSL_hostname} = $o{SSL_verifycn_name} = 'server.local';
 162         $c = Mail::IMAPClient->new(%imaps_opt, Ssl => [ %o ]);
 163         ok($c, 'IMAPS succeeds again with valid hostname');
 164
 165         # slow TLS connection did not block the other fast clients while
 166         # connecting, finish it off:
 167         until ($slow_done) {
 168                 IO::Poll::_poll(-1, @poll);
 169                 $slow_done = $slow->connect_SSL and last;
 170                 @poll = (fileno($slow), PublicInbox::TLS::epollbit());
 171         }
 172         $slow->blocking(1);
 173         ok(sysread($slow, my $greet, 4096) > 0, 'slow got a greeting');
 174         like($greet, qr/\A\* OK \[CAPABILITY IMAP4rev1 /, 'got greeting');
 175         is(syswrite($slow, "1 LOGOUT\r\n"), 10, 'slow wrote LOGOUT');
 176         ok(sysread($slow, my $end, 4096) > 0, 'got end');
 177         is(sysread($slow, my $eof, 4096), 0, 'got EOF');
 178
 179         SKIP: {
 180                 skip 'TCP_DEFER_ACCEPT is Linux-only', 2 if $^O ne 'linux';
 181                 my $var = eval { Socket::TCP_DEFER_ACCEPT() } // 9;
 182                 defined(my $x = getsockopt($imaps, IPPROTO_TCP, $var)) or die;
 183                 ok(unpack('i', $x) > 0, 'TCP_DEFER_ACCEPT set on IMAPS');
 184                 defined($x = getsockopt($starttls, IPPROTO_TCP, $var)) or die;
 185                 is(unpack('i', $x), 0, 'TCP_DEFER_ACCEPT is 0 on plain IMAP');
 186         };
 187         SKIP: {
 188                 skip 'SO_ACCEPTFILTER is FreeBSD-only', 2 if $^O ne 'freebsd';
 189                 if (system('kldstat -m accf_data >/dev/null')) {
 190                         skip 'accf_data not loaded? kldload accf_data', 2;
 191                 }
 192                 require PublicInbox::Daemon;
 193                 my $var = PublicInbox::Daemon::SO_ACCEPTFILTER();
 194                 my $x = getsockopt($imaps, SOL_SOCKET, $var);
 195                 like($x, qr/\Adataready\0+\z/, 'got dataready accf for IMAPS');
 196                 $x = getsockopt($starttls, IPPROTO_TCP, $var);
 197                 is($x, undef, 'no BSD accept filter for plain IMAP');
 198         };
 199
 200         $c = undef;
 201         $td->kill;
 202         $td->join;
 203         is($?, 0, 'no error in exited process');
 204         open my $fh, '<', $err or BAIL_OUT "open $err failed: $!";
 205         my $eout = do { local $/; <$fh> };
 206         unlike($eout, qr/wide/i, 'no Wide character warnings');
 207 }
 208
 209 done_testing;