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