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
  53 # run_mode=0 ensures Test::More FDs don't get shared
  54 my $td = start_script($cmd, $env, { 3 => $imaps, run_mode => 0 });
  55 my %ssl_opt;
  56 if ($TEST_TLS) {
  57         %ssl_opt = (
  58                 SSL_hostname => 'server.local',
  59                 SSL_verifycn_name => 'server.local',
  60                 SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_PEER(),
  61                 SSL_ca_file => 'certs/test-ca.pem',
  62         );
  63         my $ctx = IO::Socket::SSL::SSL_Context->new(%ssl_opt);
  64
  65         # cf. https://rt.cpan.org/Ticket/Display.html?id=129463
  66         my $mode = eval { Net::SSLeay::MODE_RELEASE_BUFFERS() };
  67         if ($mode && $ctx->{context}) {
  68                 eval { Net::SSLeay::CTX_set_mode($ctx->{context}, $mode) };
  69                 warn "W: $@ (setting SSL_MODE_RELEASE_BUFFERS)\n" if $@;
  70         }
  71
  72         $ssl_opt{SSL_reuse_ctx} = $ctx;
  73         $ssl_opt{SSL_startHandshake} = 0;
  74 }
  75 chomp(my $nfd = `/bin/sh -c 'ulimit -n'`);
  76 $nfd -= 10;
  77 ok($nfd > 0, 'positive FD count');
  78 my $MAX_FD = 10000;
  79 $nfd = $MAX_FD if $nfd >= $MAX_FD;
  80 our $DONE = 0;
  81 sub once { 0 }; # stops event loop
  82
  83 # setup the event loop so that it exits at every step
  84 # while we're still doing connect(2)
  85 PublicInbox::DS->SetLoopTimeout(0);
  86 PublicInbox::DS->SetPostLoopCallback(\&once);
  87 my $pid = $td->{pid};
  88 if ($^O eq 'linux' && open(my $f, '<', "/proc/$pid/status")) {
  89         diag(grep(/RssAnon/, <$f>));
  90 }
  91
  92 foreach my $n (1..$nfd) {
  93         my $io = tcp_connect($imaps, Blocking => 0);
  94         $io = IO::Socket::SSL->start_SSL($io, %ssl_opt) if $TEST_TLS;
  95         IMAPC->new($io);
  96
  97         # one step through the event loop
  98         # do a little work as we connect:
  99         PublicInbox::DS->EventLoop;
 100
 101         # try not to overflow the listen() backlog:
 102         if (!($n % 128) && $DONE != $n) {
 103                 diag("nr: ($n) $DONE/$nfd");
 104                 PublicInbox::DS->SetLoopTimeout(-1);
 105                 PublicInbox::DS->SetPostLoopCallback(sub { $DONE != $n });
 106
 107                 # clear the backlog:
 108                 PublicInbox::DS->EventLoop;
 109
 110                 # resume looping
 111                 PublicInbox::DS->SetLoopTimeout(0);
 112                 PublicInbox::DS->SetPostLoopCallback(\&once);
 113         }
 114 }
 115
 116 # run the event loop normally, now:
 117 diag "done?: @".time." $DONE/$nfd";
 118 if ($DONE != $nfd) {
 119         PublicInbox::DS->SetLoopTimeout(-1);
 120         PublicInbox::DS->SetPostLoopCallback(sub { $DONE != $nfd });
 121         PublicInbox::DS->EventLoop;
 122 }
 123 is($nfd, $DONE, "$nfd/$DONE done");
 124 if ($^O eq 'linux' && open(my $f, '<', "/proc/$pid/status")) {
 125         diag(grep(/RssAnon/, <$f>));
 126         diag "  SELF lsof | wc -l ".`lsof -p $$ |wc -l`;
 127         diag "SERVER lsof | wc -l ".`lsof -p $pid |wc -l`;
 128 }
 129 PublicInbox::DS->Reset;
 130 $td->kill;
 131 $td->join;
 132 is($?, 0, 'no error in exited process');
 133 done_testing;
 134
 135 package IMAPC;
 136 use strict;
 137 use parent qw(PublicInbox::DS);
 138 # fields: step: state machine, zin: Zlib inflate context
 139 use PublicInbox::Syscall qw(EPOLLIN EPOLLOUT EPOLLONESHOT);
 140 use Errno qw(EAGAIN);
 141 # determines where we start event_step
 142 use constant FIRST_STEP => ($ENV{TEST_COMPRESS} // 1) ? -2 : 0;
 143
 144 # return true if complete, false if incomplete (or failure)
 145 sub connect_tls_step {
 146         my ($self) = @_;
 147         my $sock = $self->{sock} or return;
 148         return 1 if $sock->connect_SSL;
 149         return $self->drop("$!") if $! != EAGAIN;
 150         if (my $ev = PublicInbox::TLS::epollbit()) {
 151                 unshift @{$self->{wbuf}}, \&connect_tls_step;
 152                 PublicInbox::DS::epwait($sock, $ev | EPOLLONESHOT);
 153                 0;
 154         } else {
 155                 $self->drop('BUG? EAGAIN but '.PublicInbox::TLS::err());
 156         }
 157 }
 158
 159 sub event_step {
 160         my ($self) = @_;
 161
 162         # TLS negotiation happens in flush_write via {wbuf}
 163         return unless $self->flush_write && $self->{sock};
 164
 165         if ($self->{step} == -2) {
 166                 $self->do_read(\(my $buf = ''), 128) or return;
 167                 $buf =~ /\A\* OK / or die 'no greeting';
 168                 $self->{step} = -1;
 169                 $self->write(\"1 COMPRESS DEFLATE\r\n");
 170         }
 171         if ($self->{step} == -1) {
 172                 $self->do_read(\(my $buf = ''), 128) or return;
 173                 $buf =~ /\A1 OK / or die "no compression $buf";
 174                 IMAPCdeflate->enable($self);
 175                 $self->{step} = 1;
 176                 $self->write(\"2 EXAMINE inbox.test.0\r\n");
 177         }
 178         if ($self->{step} == 0) {
 179                 $self->do_read(\(my $buf = ''), 128) or return;
 180                 $buf =~ /\A\* OK / or die 'no greeting';
 181                 $self->{step} = 1;
 182                 $self->write(\"2 EXAMINE inbox.test.0\r\n");
 183         }
 184         if ($self->{step} == 1) {
 185                 my $buf = '';
 186                 until ($buf =~ /^2 OK \[READ-ONLY/ms) {
 187                         $self->do_read(\$buf, 4096, length($buf)) or return;
 188                 }
 189                 $self->{step} = 2;
 190                 $self->write(\"3 UID FETCH 1 (UID FLAGS)\r\n");
 191         }
 192         if ($self->{step} == 2) {
 193                 my $buf = '';
 194                 until ($buf =~ /^3 OK /ms) {
 195                         $self->do_read(\$buf, 4096, length($buf)) or return;
 196                 }
 197                 $self->{step} = 3;
 198                 $self->write(\"4 IDLE\r\n");
 199         }
 200         if ($self->{step} == 3) {
 201                 $self->do_read(\(my $buf = ''), 128) or return;
 202                 no warnings 'once';
 203                 $::DONE++;
 204                 $self->{step} = 5; # all done
 205         } else {
 206                 warn "$self->{step} Should never get here $self";
 207         }
 208 }
 209
 210 sub new {
 211         my ($class, $io) = @_;
 212         my $self = bless { step => FIRST_STEP }, $class;
 213         if ($io->can('connect_SSL')) {
 214                 $self->{wbuf} = [ \&connect_tls_step ];
 215         }
 216         # wait for connect(), and maybe SSL_connect()
 217         $self->SUPER::new($io, EPOLLOUT|EPOLLONESHOT);
 218 }
 219
 220 1;
 221 package IMAPCdeflate;
 222 use strict;
 223 our @ISA;
 224 use Compress::Raw::Zlib;
 225 use PublicInbox::IMAPdeflate;
 226 my %ZIN_OPT;
 227 BEGIN {
 228         @ISA = qw(IMAPC);
 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         bless $self, $class;
 239         $self->{zin} = $in;
 240 }
 241
 242 1;