xt/mem-imapd-tls.t

   1 #!perl -w
   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 # Idle client memory usage test, particularly after EXAMINE when
   5 # Message Sequence Numbers are loaded
   6 use strict;
   7 use Test::More;
   8 use Socket qw(SOCK_STREAM IPPROTO_TCP SOL_SOCKET);
   9 use PublicInbox::TestCommon;
  10 use PublicInbox::Syscall qw(:epoll);
  11 use PublicInbox::DS;
  12 require_mods(qw(DBD::SQLite Email::Address::XS||Mail::Address
  13         Parse::RecDescent));
  14 my $inboxdir = $ENV{GIANT_INBOX_DIR};
  15 my $TEST_TLS;
  16 SKIP: {
  17         require_mods('IO::Socket::SSL', 1);
  18         $TEST_TLS = $ENV{TEST_TLS} // 1;
  19 };
  20 plan skip_all => "GIANT_INBOX_DIR not defined for $0" unless $inboxdir;
  21 diag 'TEST_COMPRESS='.($ENV{TEST_COMPRESS} // 1) . " TEST_TLS=$TEST_TLS";
  22
  23 my ($cert, $key) = qw(certs/server-cert.pem certs/server-key.pem);
  24 if ($TEST_TLS) {
  25         if (!-r $key || !-r $cert) {
  26                 plan skip_all =>
  27                         "certs/ missing for $0, run ./certs/create-certs.perl";
  28         }
  29         use_ok 'PublicInbox::TLS';
  30 }
  31 my ($tmpdir, $for_destroy) = tmpdir();
  32 my ($out, $err) = ("$tmpdir/stdout.log", "$tmpdir/stderr.log");
  33 my $pi_config = "$tmpdir/pi_config";
  34 my $group = 'inbox.test';
  35 local $SIG{PIPE} = 'IGNORE'; # for IMAPC (below)
  36 my $imaps = tcp_server();
  37 {
  38         open my $fh, '>', $pi_config or die "open: $!\n";
  39         print $fh <<EOF or die;
  40 [publicinbox "imapd-tls"]
  41         inboxdir = $inboxdir
  42         address = $group\@example.com
  43         newsgroup = $group
  44         indexlevel = basic
  45 EOF
  46         close $fh or die "close: $!\n";
  47 }
  48 my $imaps_addr = $imaps->sockhost . ':' . $imaps->sockport;
  49 my $env = { PI_CONFIG => $pi_config };
  50 my $arg = $TEST_TLS ? [ "-limaps://$imaps_addr/?cert=$cert,key=$key" ] : [];
  51 my $cmd = [ '-imapd', '-W0', @$arg, "--stdout=$out", "--stderr=$err" ];
  52 my $td = start_script($cmd, $env, { 3 => $imaps });
  53 my %ssl_opt;
  54 if ($TEST_TLS) {
  55         %ssl_opt = (
  56                 SSL_hostname => 'server.local',
  57                 SSL_verifycn_name => 'server.local',
  58                 SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_PEER(),
  59                 SSL_ca_file => 'certs/test-ca.pem',
  60         );
  61         my $ctx = IO::Socket::SSL::SSL_Context->new(%ssl_opt);
  62
  63         # cf. https://rt.cpan.org/Ticket/Display.html?id=129463
  64         my $mode = eval { Net::SSLeay::MODE_RELEASE_BUFFERS() };
  65         if ($mode && $ctx->{context}) {
  66                 eval { Net::SSLeay::CTX_set_mode($ctx->{context}, $mode) };
  67                 warn "W: $@ (setting SSL_MODE_RELEASE_BUFFERS)\n" if $@;
  68         }
  69
  70         $ssl_opt{SSL_reuse_ctx} = $ctx;
  71         $ssl_opt{SSL_startHandshake} = 0;
  72 }
  73 chomp(my $nfd = `/bin/sh -c 'ulimit -n'`);
  74 $nfd -= 10;
  75 ok($nfd > 0, 'positive FD count');
  76 my $MAX_FD = 10000;
  77 $nfd = $MAX_FD if $nfd >= $MAX_FD;
  78 our $DONE = 0;
  79 sub once { 0 }; # stops event loop
  80
  81 # setup the event loop so that it exits at every step
  82 # while we're still doing connect(2)
  83 PublicInbox::DS->SetLoopTimeout(0);
  84 PublicInbox::DS->SetPostLoopCallback(\&once);
  85 my $pid = $td->{pid};
  86 if ($^O eq 'linux' && open(my $f, '<', "/proc/$pid/status")) {
  87         diag(grep(/RssAnon/, <$f>));
  88 }
  89
  90 foreach my $n (1..$nfd) {
  91         my $io = tcp_connect($imaps, Blocking => 0);
  92         $io = IO::Socket::SSL->start_SSL($io, %ssl_opt) if $TEST_TLS;
  93         IMAPC->new($io);
  94
  95         # one step through the event loop
  96         # do a little work as we connect:
  97         PublicInbox::DS->EventLoop;
  98
  99         # try not to overflow the listen() backlog:
 100         if (!($n % 128) && $DONE != $n) {
 101                 diag("nr: ($n) $DONE/$nfd");
 102                 PublicInbox::DS->SetLoopTimeout(-1);
 103                 PublicInbox::DS->SetPostLoopCallback(sub { $DONE != $n });
 104
 105                 # clear the backlog:
 106                 PublicInbox::DS->EventLoop;
 107
 108                 # resume looping
 109                 PublicInbox::DS->SetLoopTimeout(0);
 110                 PublicInbox::DS->SetPostLoopCallback(\&once);
 111         }
 112 }
 113
 114 # run the event loop normally, now:
 115 diag "done?: @".time." $DONE/$nfd";
 116 if ($DONE != $nfd) {
 117         PublicInbox::DS->SetLoopTimeout(-1);
 118         PublicInbox::DS->SetPostLoopCallback(sub { $DONE != $nfd });
 119         PublicInbox::DS->EventLoop;
 120 }
 121 is($nfd, $DONE, "$nfd/$DONE done");
 122 if ($^O eq 'linux' && open(my $f, '<', "/proc/$pid/status")) {
 123         diag(grep(/RssAnon/, <$f>));
 124         diag "  SELF lsof | wc -l ".`lsof -p $$ |wc -l`;
 125         diag "SERVER lsof | wc -l ".`lsof -p $pid |wc -l`;
 126 }
 127 PublicInbox::DS->Reset;
 128 $td->kill;
 129 $td->join;
 130 is($?, 0, 'no error in exited process');
 131 done_testing;
 132
 133 package IMAPC;
 134 use strict;
 135 use base qw(PublicInbox::DS);
 136 use fields qw(step zin);
 137 use PublicInbox::Syscall qw(EPOLLIN EPOLLOUT EPOLLONESHOT);
 138 use Errno qw(EAGAIN);
 139 # determines where we start event_step
 140 use constant FIRST_STEP => ($ENV{TEST_COMPRESS} // 1) ? -2 : 0;
 141
 142 # return true if complete, false if incomplete (or failure)
 143 sub connect_tls_step {
 144         my ($self) = @_;
 145         my $sock = $self->{sock} or return;
 146         return 1 if $sock->connect_SSL;
 147         return $self->drop("$!") if $! != EAGAIN;
 148         if (my $ev = PublicInbox::TLS::epollbit()) {
 149                 unshift @{$self->{wbuf}}, \&connect_tls_step;
 150                 PublicInbox::DS::epwait($sock, $ev | EPOLLONESHOT);
 151                 0;
 152         } else {
 153                 $self->drop('BUG? EAGAIN but '.PublicInbox::TLS::err());
 154         }
 155 }
 156
 157 sub event_step {
 158         my ($self) = @_;
 159
 160         # TLS negotiation happens in flush_write via {wbuf}
 161         return unless $self->flush_write && $self->{sock};
 162
 163         if ($self->{step} == -2) {
 164                 $self->do_read(\(my $buf = ''), 128) or return;
 165                 $buf =~ /\A\* OK / or die 'no greeting';
 166                 $self->{step} = -1;
 167                 $self->write(\"1 COMPRESS DEFLATE\r\n");
 168         }
 169         if ($self->{step} == -1) {
 170                 $self->do_read(\(my $buf = ''), 128) or return;
 171                 $buf =~ /\A1 OK / or die "no compression $buf";
 172                 IMAPCdeflate->enable($self);
 173                 $self->{step} = 1;
 174                 $self->write(\"2 EXAMINE inbox.test.0\r\n");
 175         }
 176         if ($self->{step} == 0) {
 177                 $self->do_read(\(my $buf = ''), 128) or return;
 178                 $buf =~ /\A\* OK / or die 'no greeting';
 179                 $self->{step} = 1;
 180                 $self->write(\"2 EXAMINE inbox.test.0\r\n");
 181         }
 182         if ($self->{step} == 1) {
 183                 my $buf = '';
 184                 until ($buf =~ /^2 OK \[READ-ONLY/ms) {
 185                         $self->do_read(\$buf, 4096, length($buf)) or return;
 186                 }
 187                 $self->{step} = 2;
 188                 $self->write(\"3 UID FETCH 1 (UID FLAGS)\r\n");
 189         }
 190         if ($self->{step} == 2) {
 191                 my $buf = '';
 192                 until ($buf =~ /^3 OK /ms) {
 193                         $self->do_read(\$buf, 4096, length($buf)) or return;
 194                 }
 195                 $self->{step} = 3;
 196                 $self->write(\"4 IDLE\r\n");
 197         }
 198         if ($self->{step} == 3) {
 199                 $self->do_read(\(my $buf = ''), 128) or return;
 200                 no warnings 'once';
 201                 $::DONE++;
 202                 $self->{step} = 5; # all done
 203         } else {
 204                 warn "$self->{step} Should never get here $self";
 205         }
 206 }
 207
 208 sub new {
 209         my ($class, $io) = @_;
 210         my $self = fields::new($class);
 211
 212         # wait for connect(), and maybe SSL_connect()
 213         $self->SUPER::new($io, EPOLLOUT|EPOLLONESHOT);
 214         if ($io->can('connect_SSL')) {
 215                 $self->{wbuf} = [ \&connect_tls_step ];
 216         }
 217         $self->{step} = FIRST_STEP;
 218         $self;
 219 }
 220
 221 1;
 222 package IMAPCdeflate;
 223 use strict;
 224 use base qw(IMAPC); # parent doesn't work for fields
 225 use Hash::Util qw(unlock_hash); # dependency of fields for perl 5.10+, anyways
 226 use Compress::Raw::Zlib;
 227 use PublicInbox::IMAPdeflate;
 228 my %ZIN_OPT;
 229 BEGIN {
 230         %ZIN_OPT = ( -WindowBits => -15, -AppendOutput => 1 );
 231         *write = \&PublicInbox::IMAPdeflate::write;
 232         *do_read = \&PublicInbox::IMAPdeflate::do_read;
 233 };
 234
 235 sub enable {
 236         my ($class, $self) = @_;
 237         my ($in, $err) = Compress::Raw::Zlib::Inflate->new(%ZIN_OPT);
 238         die "Inflate->new failed: $err" if $err != Z_OK;
 239         unlock_hash(%$self);
 240         bless $self, $class;
 241         $self->{zin} = $in;
 242 }
 243
 244 1;