2 # Copyright (C) all contributors <meta@public-inbox.org>
3 # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
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 {
27 $im->add(eml_load('t/plack-qp.eml')) or BAIL_OUT '->add';
28 $im->add($patch) or BAIL_OUT '->add';
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: $!";
34 pop3state = $tmpdir/p3state
36 inboxdir = $ibx->{inboxdir}
41 close $fh or BAIL_OUT "close: $!\n";
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';
50 unless (-r $key && -r $cert) {
52 "certs/ missing for $0, run $^X ./create-certs.perl in certs/";
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');
63 my $dbh = DBI->connect("dbi:SQLite:dbname=$tmpdir/p3state/db.sqlite3",'','', {
67 sqlite_use_immediate_transaction => 1,
68 sqlite_see_if_its_a_number => 1,
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');
76 $x = Net::POP3->new(@old_args);
77 ok($x->apop($locked_mb, 'anonymous'), 'APOP lock acquire');
79 my $y = Net::POP3->new(@old_args);
80 ok(!$y->apop($locked_mb, 'anonymous'), 'APOP lock fails once');
83 $y = Net::POP3->new(@old_args);
84 ok($y->apop($locked_mb, 'anonymous'), 'APOP lock works after release');
88 [ "--cert=$cert", "--key=$key",
89 "-lpop3s://$pop3s_addr",
90 "-lpop3://$stls_addr" ],
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 });
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',
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;
108 diag('W: connect_SSL early OK, slow client test invalid');
109 use PublicInbox::Syscall qw(EPOLLIN EPOLLOUT);
110 @poll = (fileno($slow), EPOLLIN | EPOLLOUT);
112 @poll = (fileno($slow), PublicInbox::TLS::epollbit());
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');
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');
128 # slow TLS connection did not block the other fast clients while
129 # connecting, finish it off:
131 IO::Poll::_poll(-1, @poll);
132 $slow_done = $slow->connect_SSL and last;
133 @poll = (fileno($slow), PublicInbox::TLS::epollbit());
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);
142 ok(exists $capa->{STLS}, 'STLS CAPA advertised before STLS');
143 ok($np3->starttls, 'STLS works');
145 ok(!exists $capa->{STLS}, 'STLS CAPA not advertised after STLS');
146 ok($np3->quit, 'QUIT works after STLS');
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');
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");
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";
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');
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');
178 $np3 = Net::POP3->new(@np3_args);
179 ok($np3->user($u), "UUID\@$mailbox accept");
180 ok($np3->pass('anonymous'), 'pass works');
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');
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');
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');
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');
213 $n1 = $dbh->selectrow_array('SELECT COUNT(*) FROM deletes');
214 is($n1, $n0, 'deletes row not bumped w/ wrong pass');
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');
221 my $msg = $np3->get(2);
222 $msg = join('', @$msg);
224 is_deeply(PublicInbox::Eml->new($msg), $patch,
225 't/data/0001.patch round-tripped');
227 ok(!$np3->get(22), 'missing message');
229 $msg = $np3->top(2, 0);
230 $msg = join('', @$msg);
232 is($msg, $patch->header_obj->as_string . "\n",
235 ok(!$np3->top(2, -1), 'negative TOP numlines');
237 $msg = $np3->top(2, 1);
238 $msg = join('', @$msg);
240 is($msg, $patch->header_obj->as_string . <<EOF,
242 Filenames within a project tend to be reasonably stable within a
246 $msg = $np3->top(2, 10000);
247 $msg = join('', @$msg);
249 is_deeply(PublicInbox::Eml->new($msg), $patch,
250 'TOP numlines=10000 (excess)');
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");
257 ok($np3->_NOOP, 'NOOP works') if $np3->can('_NOOP');
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');
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');
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');
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');
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');
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');
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');
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');
325 $oldc = Net::POP3->new(@old_args);
326 ok($oldc->apop($locked_mb, 'anonymous'), 'APOP again on latest');
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');
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');
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.
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');