t/pop3d.t

   1 #!perl -w
   2 # Copyright (C) all contributors <meta@public-inbox.org>
   3 # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
   4 use v5.12;
   5 use PublicInbox::TestCommon;
   6 use Socket qw(IPPROTO_TCP SOL_SOCKET);
   7 # Net::POP3 is part of the standard library, but distros may split it off...
   8 require_mods(qw(DBD::SQLite Net::POP3 IO::Socket::SSL));
   9 require_git('2.6'); # for v2
  10 require_mods(qw(File::FcntlLock)) if $^O !~ /\A(?:linux|freebsd)\z/;
  11 use_ok 'IO::Socket::SSL';
  12 use_ok 'PublicInbox::TLS';
  13 my ($tmpdir, $for_destroy) = tmpdir();
  14 mkdir("$tmpdir/p3state") or xbail "mkdir: $!";
  15 my $err = "$tmpdir/stderr.log";
  16 my $out = "$tmpdir/stdout.log";
  17 my $olderr = "$tmpdir/plain.err";
  18 my $group = 'test-pop3';
  19 my $addr = $group . '@example.com';
  20 my $stls = tcp_server();
  21 my $plain = tcp_server();
  22 my $pop3s = tcp_server();
  23 my $patch = eml_load('t/data/0001.patch');
  24 my $ibx = create_inbox 'pop3d', version => 2, -primary_address => $addr,
  25                         indexlevel => 'basic', sub {
  26         my ($im, $ibx) = @_;
  27         $im->add(eml_load('t/plack-qp.eml')) or BAIL_OUT '->add';
  28         $im->add($patch) or BAIL_OUT '->add';
  29 };
  30 my $pi_config = "$tmpdir/pi_config";
  31 open my $fh, '>', $pi_config or BAIL_OUT "open: $!";
  32 print $fh <<EOF or BAIL_OUT "print: $!";
  33 [publicinbox]
  34         pop3state = $tmpdir/p3state
  35 [publicinbox "pop3"]
  36         inboxdir = $ibx->{inboxdir}
  37         address = $addr
  38         indexlevel = basic
  39         newsgroup = $group
  40 EOF
  41 close $fh or BAIL_OUT "close: $!\n";
  42
  43 my $pop3s_addr = tcp_host_port($pop3s);
  44 my $stls_addr = tcp_host_port($stls);
  45 my $plain_addr = tcp_host_port($plain);
  46 my $env = { PI_CONFIG => $pi_config };
  47 my $cert = 'certs/server-cert.pem';
  48 my $key = 'certs/server-key.pem';
  49
  50 unless (-r $key && -r $cert) {
  51         plan skip_all =>
  52                 "certs/ missing for $0, run $^X ./create-certs.perl in certs/";
  53 }
  54
  55 my $old = start_script(['-pop3d', '-W0',
  56         "--stdout=$tmpdir/plain.out", "--stderr=$olderr" ],
  57         $env, { 3 => $plain });
  58 my @old_args = ($plain->sockhost, Port => $plain->sockport);
  59 my $oldc = Net::POP3->new(@old_args);
  60 my $locked_mb = ('e'x32)."\@$group";
  61 ok($oldc->apop("$locked_mb.0", 'anonymous'), 'APOP to old');
  62
  63 my $dbh = DBI->connect("dbi:SQLite:dbname=$tmpdir/p3state/db.sqlite3",'','', {
  64         AutoCommit => 1,
  65         RaiseError => 1,
  66         PrintError => 0,
  67         sqlite_use_immediate_transaction => 1,
  68         sqlite_see_if_its_a_number => 1,
  69 });
  70
  71 { # locking within the same process
  72         my $x = Net::POP3->new(@old_args);
  73         ok(!$x->apop("$locked_mb.0", 'anonymous'), 'APOP lock failure');
  74         like($x->message, qr/unable to lock/, 'diagnostic message');
  75
  76         $x = Net::POP3->new(@old_args);
  77         ok($x->apop($locked_mb, 'anonymous'), 'APOP lock acquire');
  78
  79         my $y = Net::POP3->new(@old_args);
  80         ok(!$y->apop($locked_mb, 'anonymous'), 'APOP lock fails once');
  81
  82         undef $x;
  83         $y = Net::POP3->new(@old_args);
  84         ok($y->apop($locked_mb, 'anonymous'), 'APOP lock works after release');
  85 }
  86
  87 for my $args (
  88         [ "--cert=$cert", "--key=$key",
  89                 "-lpop3s://$pop3s_addr",
  90                 "-lpop3://$stls_addr" ],
  91 ) {
  92         for ($out, $err) { open my $fh, '>', $_ or BAIL_OUT "truncate: $!" }
  93         my $cmd = [ '-netd', '-W0', @$args, "--stdout=$out", "--stderr=$err" ];
  94         my $td = start_script($cmd, $env, { 3 => $stls, 4 => $pop3s });
  95
  96         my %o = (
  97                 SSL_hostname => 'server.local',
  98                 SSL_verifycn_name => 'server.local',
  99                 SSL_verify_mode => SSL_VERIFY_PEER(),
 100                 SSL_ca_file => 'certs/test-ca.pem',
 101         );
 102         # start negotiating a slow TLS connection
 103         my $slow = tcp_connect($pop3s, Blocking => 0);
 104         $slow = IO::Socket::SSL->start_SSL($slow, SSL_startHandshake => 0, %o);
 105         my $slow_done = $slow->connect_SSL;
 106         my @poll;
 107         if ($slow_done) {
 108                 diag('W: connect_SSL early OK, slow client test invalid');
 109                 use PublicInbox::Syscall qw(EPOLLIN EPOLLOUT);
 110                 @poll = (fileno($slow), EPOLLIN | EPOLLOUT);
 111         } else {
 112                 @poll = (fileno($slow), PublicInbox::TLS::epollbit());
 113         }
 114
 115         my @p3s_args = ($pop3s->sockhost,
 116                         Port => $pop3s->sockport, SSL => 1, %o);
 117         my $p3s = Net::POP3->new(@p3s_args);
 118         my $capa = $p3s->capa;
 119         ok(!exists $capa->{STLS}, 'no STLS CAPA for POP3S');
 120         ok($p3s->quit, 'QUIT works w/POP3S');
 121         {
 122                 $p3s = Net::POP3->new(@p3s_args);
 123                 ok(!$p3s->apop("$locked_mb.0", 'anonymous'),
 124                         'APOP lock failure w/ another daemon');
 125                 like($p3s->message, qr/unable to lock/, 'diagnostic message');
 126         }
 127
 128         # slow TLS connection did not block the other fast clients while
 129         # connecting, finish it off:
 130         until ($slow_done) {
 131                 IO::Poll::_poll(-1, @poll);
 132                 $slow_done = $slow->connect_SSL and last;
 133                 @poll = (fileno($slow), PublicInbox::TLS::epollbit());
 134         }
 135         $slow->blocking(1);
 136         ok(sysread($slow, my $greet, 4096) > 0, 'slow got a greeting');
 137         my @np3_args = ($stls->sockhost, Port => $stls->sockport);
 138         my $np3 = Net::POP3->new(@np3_args);
 139         ok($np3->quit, 'plain QUIT works');
 140         $np3 = Net::POP3->new(@np3_args, %o);
 141         $capa = $np3->capa;
 142         ok(exists $capa->{STLS}, 'STLS CAPA advertised before STLS');
 143         ok($np3->starttls, 'STLS works');
 144         $capa = $np3->capa;
 145         ok(!exists $capa->{STLS}, 'STLS CAPA not advertised after STLS');
 146         ok($np3->quit, 'QUIT works after STLS');
 147
 148         for my $mailbox (('x'x32)."\@$group", $group, ('a'x32)."\@z.$group") {
 149                 $np3 = Net::POP3->new(@np3_args);
 150                 ok(!$np3->user($mailbox), "USER $mailbox reject");
 151                 ok($np3->quit, 'QUIT after USER fail');
 152
 153                 $np3 = Net::POP3->new(@np3_args);
 154                 ok(!$np3->apop($mailbox, 'anonymous'), "APOP $mailbox reject");
 155                 ok($np3->quit, "QUIT after APOP fail $mailbox");
 156         }
 157
 158         # we do connect+QUIT bumps to try ensuring non-QUIT disconnects
 159         # get processed below:
 160         for my $mailbox ($group, "$group.0") {
 161                 my $u = ('f'x32)."\@$mailbox";
 162                 undef $np3;
 163                 ok(Net::POP3->new(@np3_args)->quit, 'connect+QUIT bump');
 164                 $np3 = Net::POP3->new(@np3_args);
 165                 my $n0 = $dbh->selectrow_array('SELECT COUNT(*) FROM deletes');
 166                 my $u0 = $dbh->selectrow_array('SELECT COUNT(*) FROM users');
 167                 ok($np3->user($u), "UUID\@$mailbox accept");
 168                 ok($np3->pass('anonymous'), 'pass works');
 169                 my $n1 = $dbh->selectrow_array('SELECT COUNT(*) FROM deletes');
 170                 is($n1 - $n0, 1, 'deletes bumped while connected');
 171                 ok($np3->quit, 'client QUIT');
 172
 173                 $n1 = $dbh->selectrow_array('SELECT COUNT(*) FROM deletes');
 174                 is($n1, $n0, 'deletes row gone on no-op after QUIT');
 175                 my $u1 = $dbh->selectrow_array('SELECT COUNT(*) FROM users');
 176                 is($u1, $u0, 'users row gone on no-op after QUIT');
 177
 178                 $np3 = Net::POP3->new(@np3_args);
 179                 ok($np3->user($u), "UUID\@$mailbox accept");
 180                 ok($np3->pass('anonymous'), 'pass works');
 181
 182                 my $list = $np3->list;
 183                 my $uidl = $np3->uidl;
 184                 is_deeply([sort keys %$list], [sort keys %$uidl],
 185                         'LIST and UIDL keys match');
 186                 ok($_ > 0, 'bytes in LIST result') for values %$list;
 187                 like($_, qr/\A[a-z0-9]{40,}\z/,
 188                         'blob IDs in UIDL result') for values %$uidl;
 189                 ok($np3->quit, 'QUIT after LIST+UIDL');
 190                 $n1 = $dbh->selectrow_array('SELECT COUNT(*) FROM deletes');
 191                 is($n1, $n0, 'deletes row gone on no-op after LIST+UIDL');
 192                 $n0 = $n1;
 193
 194                 $np3 = Net::POP3->new(@np3_args);
 195                 ok($np3->user($u), "UUID\@$mailbox accept");
 196                 ok($np3->pass('anonymous'), 'pass works');
 197                 undef $np3; # QUIT-less disconnect
 198                 ok(Net::POP3->new(@np3_args)->quit, 'connect+QUIT bump');
 199
 200                 $u1 = $dbh->selectrow_array('SELECT COUNT(*) FROM users');
 201                 is($u1, $u0, 'users row gone on QUIT-less disconnect');
 202                 $n1 = $dbh->selectrow_array('SELECT COUNT(*) FROM deletes');
 203                 is($n1, $n0, 'deletes row gone on QUIT-less disconnect');
 204                 $n0 = $n1;
 205
 206                 $np3 = Net::POP3->new(@np3_args);
 207                 ok(!$np3->apop($u, 'anonumuss'), 'APOP wrong pass reject');
 208                 $n1 = $dbh->selectrow_array('SELECT COUNT(*) FROM deletes');
 209                 is($n1, $n0, 'deletes row not bumped w/ wrong pass');
 210                 undef $np3; # QUIT-less disconnect
 211                 ok(Net::POP3->new(@np3_args)->quit, 'connect+QUIT bump');
 212
 213                 $n1 = $dbh->selectrow_array('SELECT COUNT(*) FROM deletes');
 214                 is($n1, $n0, 'deletes row not bumped w/ wrong pass');
 215
 216                 $np3 = Net::POP3->new(@np3_args);
 217                 ok($np3->apop($u, 'anonymous'), "APOP UUID\@$mailbox");
 218                 my @res = $np3->popstat;
 219                 is($res[0], 2, 'STAT knows about 2 messages');
 220
 221                 my $msg = $np3->get(2);
 222                 $msg = join('', @$msg);
 223                 $msg =~ s/\r\n/\n/g;
 224                 is_deeply(PublicInbox::Eml->new($msg), $patch,
 225                         't/data/0001.patch round-tripped');
 226
 227                 ok(!$np3->get(22), 'missing message');
 228
 229                 $msg = $np3->top(2, 0);
 230                 $msg = join('', @$msg);
 231                 $msg =~ s/\r\n/\n/g;
 232                 is($msg, $patch->header_obj->as_string . "\n",
 233                         'TOP numlines=0');
 234
 235                 ok(!$np3->top(2, -1), 'negative TOP numlines');
 236
 237                 $msg = $np3->top(2, 1);
 238                 $msg = join('', @$msg);
 239                 $msg =~ s/\r\n/\n/g;
 240                 is($msg, $patch->header_obj->as_string . <<EOF,
 241
 242 Filenames within a project tend to be reasonably stable within a
 243 EOF
 244                         'TOP numlines=1');
 245
 246                 $msg = $np3->top(2, 10000);
 247                 $msg = join('', @$msg);
 248                 $msg =~ s/\r\n/\n/g;
 249                 is_deeply(PublicInbox::Eml->new($msg), $patch,
 250                         'TOP numlines=10000 (excess)');
 251
 252                 $np3 = Net::POP3->new(@np3_args, %o);
 253                 ok($np3->starttls, 'STLS works before APOP');
 254                 ok($np3->apop($u, 'anonymous'), "APOP UUID\@$mailbox w/ STLS");
 255
 256                 # undocumented:
 257                 ok($np3->_NOOP, 'NOOP works') if $np3->can('_NOOP');
 258         }
 259
 260         SKIP: {
 261                 skip 'TCP_DEFER_ACCEPT is Linux-only', 2 if $^O ne 'linux';
 262                 my $var = eval { Socket::TCP_DEFER_ACCEPT() } // 9;
 263                 my $x = getsockopt($pop3s, IPPROTO_TCP, $var) //
 264                         xbail "IPPROTO_TCP: $!";
 265                 ok(unpack('i', $x) > 0, 'TCP_DEFER_ACCEPT set on POP3S');
 266                 $x = getsockopt($stls, IPPROTO_TCP, $var) //
 267                         xbail "IPPROTO_TCP: $!";
 268                 is(unpack('i', $x), 0, 'TCP_DEFER_ACCEPT is 0 on plain POP3');
 269         };
 270         SKIP: {
 271                 skip 'SO_ACCEPTFILTER is FreeBSD-only', 2 if $^O ne 'freebsd';
 272                 system('kldstat -m accf_data >/dev/null') and
 273                         skip 'accf_data not loaded? kldload accf_data', 2;
 274                 require PublicInbox::Daemon;
 275                 my $x = getsockopt($pop3s, SOL_SOCKET,
 276                                 $PublicInbox::Daemon::SO_ACCEPTFILTER);
 277                 like($x, qr/\Adataready\0+\z/, 'got dataready accf for pop3s');
 278                 $x = getsockopt($stls, IPPROTO_TCP,
 279                                 $PublicInbox::Daemon::SO_ACCEPTFILTER);
 280                 is($x, undef, 'no BSD accept filter for plain IMAP');
 281         };
 282
 283         $td->kill;
 284         $td->join;
 285         is($?, 0, 'no error in exited -netd');
 286         open my $fh, '<', $err or BAIL_OUT "open $err failed: $!";
 287         my $eout = do { local $/; <$fh> };
 288         unlike($eout, qr/wide/i, 'no Wide character warnings in -netd');
 289 }
 290
 291 {
 292         my $capa = $oldc->capa;
 293         ok(defined($capa->{PIPELINING}), 'pipelining supported by CAPA');
 294         is($capa->{EXPIRE}, 0, 'EXPIRE 0 set');
 295         ok(!exists $capa->{STLS}, 'STLS unset w/o daemon certs');
 296
 297         # ensure TOP doesn't trigger "EXPIRE 0" like RETR does (cf. RFC2449)
 298         my $list = $oldc->list;
 299         ok(scalar keys %$list, 'got a listing of messages');
 300         ok($oldc->top($_, 1), "TOP $_ 1") for keys %$list;
 301         ok($oldc->quit, 'QUIT after TOP');
 302
 303         # clients which see "EXPIRE 0" can elide DELE requests
 304         $oldc = Net::POP3->new(@old_args);
 305         ok($oldc->apop("$locked_mb.0", 'anonymous'), 'APOP for RETR');
 306         is_deeply($oldc->capa, $capa, 'CAPA unchanged');
 307         is_deeply($oldc->list, $list, 'LIST unchanged by previous TOP');
 308         ok($oldc->get($_), "RETR $_") for keys %$list;
 309         ok($oldc->quit, 'QUIT after RETR');
 310
 311         $oldc = Net::POP3->new(@old_args);
 312         ok($oldc->apop("$locked_mb.0", 'anonymous'), 'APOP reconnect');
 313         my $cont = $oldc->list;
 314         is_deeply($cont, {}, 'no messages after implicit DELE from EXPIRE 0');
 315         ok($oldc->quit, 'QUIT on noop');
 316
 317         # test w/o checking CAPA to trigger EXPIRE 0
 318         $oldc = Net::POP3->new(@old_args);
 319         ok($oldc->apop($locked_mb, 'anonymous'), 'APOP on latest slice');
 320         my $l2 = $oldc->list;
 321         is_deeply($l2, $list, 'different mailbox, different deletes');
 322         ok($oldc->get($_), "RETR $_") for keys %$list;
 323         ok($oldc->quit, 'QUIT w/o EXPIRE nor DELE');
 324
 325         $oldc = Net::POP3->new(@old_args);
 326         ok($oldc->apop($locked_mb, 'anonymous'), 'APOP again on latest');
 327         $l2 = $oldc->list;
 328         is_deeply($l2, $list, 'no DELE nor EXPIRE preserves messages');
 329         ok($oldc->delete(2), 'explicit DELE on latest');
 330         ok($oldc->quit, 'QUIT w/ highest DELE');
 331
 332         # this is non-standard behavior, but necessary if we expect hundreds
 333         # of thousands of users on cheap HW
 334         $oldc = Net::POP3->new(@old_args);
 335         ok($oldc->apop($locked_mb, 'anonymous'), 'APOP yet again on latest');
 336         is_deeply($oldc->list, {}, 'highest DELE deletes older messages, too');
 337 }
 338
 339 # TODO: more tests, but mpop was really helpful in helping me
 340 # figure out bugs with larger newsgroups (>50K messages) which
 341 # probably isn't suited for this test suite.
 342
 343 $old->kill;
 344 $old->join;
 345 is($?, 0, 'no error in exited -pop3d');
 346 open $fh, '<', $olderr or BAIL_OUT "open $olderr failed: $!";
 347 my $eout = do { local $/; <$fh> };
 348 unlike($eout, qr/wide/i, 'no Wide character warnings in -pop3d');
 349
 350 done_testing;