From bd61cb1b18c7f38588e0c3b166dd265b738242cc Mon Sep 17 00:00:00 2001 From: Eric Wong Date: Mon, 24 Jun 2019 02:52:24 +0000 Subject: spawn: remove `Blocking' flag handling Instead, the O_NONBLOCK flag is set by PublicInbox::HTTPD::Async; and we won't be setting it elsewhere. --- t/spawn.t | 11 ----------- 1 file changed, 11 deletions(-) (limited to 't') diff --git a/t/spawn.t b/t/spawn.t index 88404282..1d71b26d 100644 --- a/t/spawn.t +++ b/t/spawn.t @@ -81,17 +81,6 @@ use PublicInbox::Spawn qw(which spawn popen_rd); isnt($?, 0, '$? set properly: '.$?); } -{ - my ($fh, $pid) = popen_rd([qw(sleep 60)], undef, { Blocking => 0 }); - ok(defined $pid && $pid > 0, 'returned pid when array requested'); - is(kill(0, $pid), 1, 'child process is running'); - ok(!defined(sysread($fh, my $buf, 1)) && $!{EAGAIN}, - 'sysread returned quickly with EAGAIN'); - is(kill(9, $pid), 1, 'child process killed early'); - is(waitpid($pid, 0), $pid, 'child process reapable'); - isnt($?, 0, '$? set properly: '.$?); -} - SKIP: { eval { require BSD::Resource; -- cgit v1.2.3-24-ge0c7 From b70cf61f0c1f70621b88fe6420083a576d47f19f Mon Sep 17 00:00:00 2001 From: Eric Wong Date: Mon, 24 Jun 2019 02:52:38 +0000 Subject: nntp: NNTPS and NNTP+STARTTLS working It kinda, barely works, and I'm most happy I got it working without any modifications to the main NNTP::event_step callback thanks to the DS->write(CODE) support we inherited from Danga::Socket. --- t/nntpd-tls.t | 156 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ t/nntpd.t | 2 + 2 files changed, 158 insertions(+) create mode 100644 t/nntpd-tls.t (limited to 't') diff --git a/t/nntpd-tls.t b/t/nntpd-tls.t new file mode 100644 index 00000000..53890ff2 --- /dev/null +++ b/t/nntpd-tls.t @@ -0,0 +1,156 @@ +# Copyright (C) 2019 all contributors +# License: AGPL-3.0+ +use strict; +use warnings; +use Test::More; +use File::Temp qw(tempdir); +use Socket qw(SOCK_STREAM); +foreach my $mod (qw(DBD::SQLite IO::Socket::SSL Net::NNTP)) { + eval "require $mod"; + plan skip_all => "$mod missing for $0" if $@; +} +my $cert = 'certs/server-cert.pem'; +my $key = 'certs/server-key.pem'; +unless (-r $key && -r $cert) { + plan skip_all => + "certs/ missing for $0, run ./create-certs.perl in certs/"; +} + +use_ok 'PublicInbox::TLS'; +use_ok 'IO::Socket::SSL'; +require './t/common.perl'; +require PublicInbox::InboxWritable; +require PublicInbox::MIME; +require PublicInbox::SearchIdx; +my $version = 2; # v2 needs newer git +require_git('2.6') if $version >= 2; +my $tmpdir = tempdir('pi-nntpd-tls-XXXXXX', TMPDIR => 1, CLEANUP => 1); +my $err = "$tmpdir/stderr.log"; +my $out = "$tmpdir/stdout.log"; +my $mainrepo = "$tmpdir"; +my $pi_config = "$tmpdir/pi_config"; +my $group = 'test-nntpd-tls'; +my $addr = $group . '@example.com'; +my $nntpd = 'blib/script/public-inbox-nntpd'; +my %opts = ( + LocalAddr => '127.0.0.1', + ReuseAddr => 1, + Proto => 'tcp', + Type => SOCK_STREAM, + Listen => 1024, +); +my $starttls = IO::Socket::INET->new(%opts); +my $nntps = IO::Socket::INET->new(%opts); +my ($pid, $tail_pid); +END { + foreach ($pid, $tail_pid) { + kill 'TERM', $_ if defined $_; + } +}; + +my $ibx = PublicInbox::Inbox->new({ + mainrepo => $mainrepo, + name => 'nntpd-tls', + version => $version, + -primary_address => $addr, + indexlevel => 'basic', +}); +$ibx = PublicInbox::InboxWritable->new($ibx, {nproc=>1}); +$ibx->init_inbox(0); +{ + open my $fh, '>', $pi_config or die "open: $!\n"; + print $fh <importer(0); + my $mime = PublicInbox::MIME->new(do { + open my $fh, '<', 't/data/0001.patch' or die; + local $/; + <$fh> + }); + ok($im->add($mime), 'message added'); + $im->done; + if ($version == 1) { + my $s = PublicInbox::SearchIdx->new($ibx, 1); + $s->index_sync; + } +} + +my $nntps_addr = $nntps->sockhost . ':' . $nntps->sockport; +my $starttls_addr = $starttls->sockhost . ':' . $starttls->sockport; +my $env = { PI_CONFIG => $pi_config }; + +for my $args ( + [ "--cert=$cert", "--key=$key", + "-lnntps://$nntps_addr", + "-lnntp://$starttls_addr" ], +) { + for ($out, $err) { + open my $fh, '>', $_ or die "truncate: $!"; + } + if (my $tail_cmd = $ENV{TAIL}) { # don't assume GNU tail + $tail_pid = fork; + if (defined $tail_pid && $tail_pid == 0) { + exec(split(' ', $tail_cmd), $out, $err); + } + } + my $cmd = [ $nntpd, '-W0', @$args, "--stdout=$out", "--stderr=$err" ]; + $pid = spawn_listener($env, $cmd, [ $starttls, $nntps ]); + my %o = ( + SSL_hostname => 'server.local', + SSL_verifycn_name => 'server.local', + SSL => 1, + SSL_verify_mode => SSL_VERIFY_PEER(), + SSL_ca_file => 'certs/test-ca.pem', + ); + my $expect = { $group => [qw(1 1 n)] }; + + # NNTPS + my $c = Net::NNTP->new($nntps_addr, %o); + my $list = $c->list; + is_deeply($list, $expect, 'NNTPS LIST works'); + + # STARTTLS + delete $o{SSL}; + $c = Net::NNTP->new($starttls_addr, %o); + $list = $c->list; + is_deeply($list, $expect, 'plain LIST works'); + ok($c->starttls, 'STARTTLS succeeds'); + is($c->code, 382, 'got 382 for STARTTLS'); + $list = $c->list; + is_deeply($list, $expect, 'LIST works after STARTTLS'); + + # Net::NNTP won't let us do dumb things, but we need to test + # dumb things, so use Net::Cmd directly: + my $n = $c->command('STARTTLS')->response(); + is($n, Net::Cmd::CMD_ERROR(), 'error attempting STARTTLS again'); + is($c->code, 502, '502 according to RFC 4642 sec#2.2.1'); + + $c = undef; + kill('TERM', $pid); + is($pid, waitpid($pid, 0), 'nntpd exited successfully'); + is($?, 0, 'no error in exited process'); + $pid = undef; + my $eout = eval { + open my $fh, '<', $err or die "open $err failed: $!"; + local $/; + <$fh>; + }; + unlike($eout, qr/wide/i, 'no Wide character warnings'); + if (defined $tail_pid) { + kill 'TERM', $tail_pid; + waitpid($tail_pid, 0); + $tail_pid = undef; + } +} +done_testing(); +1; diff --git a/t/nntpd.t b/t/nntpd.t index c37880bf..6cba2be4 100644 --- a/t/nntpd.t +++ b/t/nntpd.t @@ -106,6 +106,8 @@ EOF is_deeply($list, { $group => [ qw(1 1 n) ] }, 'LIST works'); is_deeply([$n->group($group)], [ qw(0 1 1), $group ], 'GROUP works'); is_deeply($n->listgroup($group), [1], 'listgroup OK'); + ok(!$n->starttls, 'STARTTLS fails when unconfigured'); + is($n->code, 580, 'got 580 code on server w/o TLS'); %opts = ( PeerAddr => $host_port, -- cgit v1.2.3-24-ge0c7 From b3e4b3b3c67b9df7868518978e721417b0aa7c9c Mon Sep 17 00:00:00 2001 From: Eric Wong Date: Mon, 24 Jun 2019 02:52:41 +0000 Subject: ds|nntp: use CORE::close on socket IO::Socket::SSL will try to re-bless back to the original class on TLS negotiation failure. Unfortunately, the original class is 'GLOB', and re-blessing to 'GLOB' takes away all the IO::Handle methods, because Filehandle/IO are a special case in Perl5. Anyways, since we already use syswrite() and sysread() as functions on our socket, we might as well use CORE::close(), as well (and it plays nicely with tied classes). --- t/nntpd-tls.t | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) (limited to 't') diff --git a/t/nntpd-tls.t b/t/nntpd-tls.t index 53890ff2..4727ee5b 100644 --- a/t/nntpd-tls.t +++ b/t/nntpd-tls.t @@ -135,6 +135,23 @@ for my $args ( is($n, Net::Cmd::CMD_ERROR(), 'error attempting STARTTLS again'); is($c->code, 502, '502 according to RFC 4642 sec#2.2.1'); + # STARTTLS with bad hostname + $o{SSL_hostname} = $o{SSL_verifycn_name} = 'server.invalid'; + $c = Net::NNTP->new($starttls_addr, %o); + $list = $c->list; + is_deeply($list, $expect, 'plain LIST works again'); + ok(!$c->starttls, 'STARTTLS fails with bad hostname'); + $c = Net::NNTP->new($starttls_addr, %o); + $list = $c->list; + is_deeply($list, $expect, 'not broken after bad negotiation'); + + # NNTPS with bad hostname + $c = Net::NNTP->new($nntps_addr, %o, SSL => 1); + is($c, undef, 'NNTPS fails with bad hostname'); + $o{SSL_hostname} = $o{SSL_verifycn_name} = 'server.local'; + $c = Net::NNTP->new($nntps_addr, %o, SSL => 1); + ok($c, 'NNTPS succeeds again with valid hostname'); + $c = undef; kill('TERM', $pid); is($pid, waitpid($pid, 0), 'nntpd exited successfully'); -- cgit v1.2.3-24-ge0c7 From 595854982a59f369ab605794f05c046c86253468 Mon Sep 17 00:00:00 2001 From: Eric Wong Date: Mon, 24 Jun 2019 02:52:42 +0000 Subject: nntp: call SSL_shutdown in normal cases This is in accordance with TLS standards and will be needed to support session caching/reuse in the future. However, we don't issue shutdown(2) since we know not to inadvertantly share our sockets with other processes. --- t/nntpd-tls.t | 2 ++ 1 file changed, 2 insertions(+) (limited to 't') diff --git a/t/nntpd-tls.t b/t/nntpd-tls.t index 4727ee5b..00b03b66 100644 --- a/t/nntpd-tls.t +++ b/t/nntpd-tls.t @@ -118,6 +118,8 @@ for my $args ( my $c = Net::NNTP->new($nntps_addr, %o); my $list = $c->list; is_deeply($list, $expect, 'NNTPS LIST works'); + is($c->command('QUIT')->response(), Net::Cmd::CMD_OK(), 'QUIT works'); + is(0, sysread($c, my $buf, 1), 'got EOF after QUIT'); # STARTTLS delete $o{SSL}; -- cgit v1.2.3-24-ge0c7 From 1dc4d2f75a387c9113fc7646c463e3aac2d3de1f Mon Sep 17 00:00:00 2001 From: Eric Wong Date: Mon, 24 Jun 2019 02:52:43 +0000 Subject: t/nntpd-tls: slow client connection test We need to ensure slowly negotiating TLS clients don't block the event loop. This is why I added the size check of {wbuf} before and after calling the CODE ref in DS::flush_write. --- t/nntpd-tls.t | 36 ++++++++++++++++++++++++++++++++---- 1 file changed, 32 insertions(+), 4 deletions(-) (limited to 't') diff --git a/t/nntpd-tls.t b/t/nntpd-tls.t index 00b03b66..e8fb63b4 100644 --- a/t/nntpd-tls.t +++ b/t/nntpd-tls.t @@ -5,7 +5,9 @@ use warnings; use Test::More; use File::Temp qw(tempdir); use Socket qw(SOCK_STREAM); -foreach my $mod (qw(DBD::SQLite IO::Socket::SSL Net::NNTP)) { +# IO::Poll and Net::NNTP are part of the standard library, but +# distros may split them off... +foreach my $mod (qw(DBD::SQLite IO::Socket::SSL Net::NNTP IO::Poll)) { eval "require $mod"; plan skip_all => "$mod missing for $0" if $@; } @@ -108,21 +110,32 @@ for my $args ( my %o = ( SSL_hostname => 'server.local', SSL_verifycn_name => 'server.local', - SSL => 1, SSL_verify_mode => SSL_VERIFY_PEER(), SSL_ca_file => 'certs/test-ca.pem', ); my $expect = { $group => [qw(1 1 n)] }; + # start negotiating a slow TLS connection + my $slow = IO::Socket::INET->new( + Proto => 'tcp', + PeerAddr => $nntps_addr, + Type => SOCK_STREAM, + Blocking => 0, + ); + $slow = IO::Socket::SSL->start_SSL($slow, SSL_startHandshake => 0, %o); + my $slow_done = $slow->connect_SSL; + diag('W: connect_SSL early OK, slow client test invalid') if $slow_done; + my @poll = (fileno($slow), PublicInbox::TLS::epollbit()); + # we should call connect_SSL much later... + # NNTPS - my $c = Net::NNTP->new($nntps_addr, %o); + my $c = Net::NNTP->new($nntps_addr, %o, SSL => 1); my $list = $c->list; is_deeply($list, $expect, 'NNTPS LIST works'); is($c->command('QUIT')->response(), Net::Cmd::CMD_OK(), 'QUIT works'); is(0, sysread($c, my $buf, 1), 'got EOF after QUIT'); # STARTTLS - delete $o{SSL}; $c = Net::NNTP->new($starttls_addr, %o); $list = $c->list; is_deeply($list, $expect, 'plain LIST works'); @@ -154,6 +167,21 @@ for my $args ( $c = Net::NNTP->new($nntps_addr, %o, SSL => 1); ok($c, 'NNTPS succeeds again with valid hostname'); + # slow TLS connection did not block the other fast clients while + # connecting, finish it off: + until ($slow_done) { + IO::Poll::_poll(-1, @poll); + $slow_done = $slow->connect_SSL and last; + @poll = (fileno($slow), PublicInbox::TLS::epollbit()); + } + $slow->blocking(1); + ok(sysread($slow, my $greet, 4096) > 0, 'slow got greeting'); + like($greet, qr/\A201 /, 'got expected greeting'); + is(syswrite($slow, "QUIT\r\n"), 6, 'slow wrote QUIT'); + ok(sysread($slow, my $end, 4096) > 0, 'got EOF'); + is(sysread($slow, my $eof, 4096), 0, 'got EOF'); + $slow = undef; + $c = undef; kill('TERM', $pid); is($pid, waitpid($pid, 0), 'nntpd exited successfully'); -- cgit v1.2.3-24-ge0c7 From 4e1a84c2a97c319862c960a34e3a7a8bf31d5274 Mon Sep 17 00:00:00 2001 From: Eric Wong Date: Mon, 24 Jun 2019 02:52:53 +0000 Subject: daemon: set TCP_DEFER_ACCEPT on everything but NNTP This Linux-specific option can save us some wakeups during the TLS negotiation phase, and it can help with ordinary HTTP, too. Plain NNTP (and in the future, POP3) are the only things which require the server send messages, first. --- t/httpd-corner.t | 19 +++++++++++++++++++ t/httpd.t | 8 ++++++++ t/nntpd-tls.t | 11 ++++++++++- 3 files changed, 37 insertions(+), 1 deletion(-) (limited to 't') diff --git a/t/httpd-corner.t b/t/httpd-corner.t index c1dc77db..13befcf1 100644 --- a/t/httpd-corner.t +++ b/t/httpd-corner.t @@ -36,6 +36,17 @@ my %opts = ( Listen => 1024, ); my $sock = IO::Socket::INET->new(%opts); +my $defer_accept_val; +if ($^O eq 'linux') { + setsockopt($sock, IPPROTO_TCP, Socket::TCP_DEFER_ACCEPT(), 5) or die; + my $x = getsockopt($sock, IPPROTO_TCP, Socket::TCP_DEFER_ACCEPT()); + defined $x or die "getsockopt: $!"; + $defer_accept_val = unpack('i', $x); + if ($defer_accept_val <= 0) { + die "unexpected TCP_DEFER_ACCEPT value: $defer_accept_val"; + } +} + my $upath = "$tmpdir/s"; my $unix = IO::Socket::UNIX->new( Listen => 1024, @@ -497,6 +508,14 @@ SKIP: { is($body, sha1_hex(''), 'read expected body #2'); } +SKIP: { + skip 'TCP_DEFER_ACCEPT is Linux-only', 1 if $^O ne 'linux'; + my $var = Socket::TCP_DEFER_ACCEPT(); + defined(my $x = getsockopt($sock, IPPROTO_TCP, $var)) or die; + is(unpack('i', $x), $defer_accept_val, + 'TCP_DEFER_ACCEPT unchanged if previously set'); +}; + done_testing(); sub capture { diff --git a/t/httpd.t b/t/httpd.t index c061031c..8c2a3173 100644 --- a/t/httpd.t +++ b/t/httpd.t @@ -10,6 +10,7 @@ foreach my $mod (qw(Plack::Util Plack::Builder HTTP::Date HTTP::Status)) { } use File::Temp qw/tempdir/; use IO::Socket::INET; +use Socket qw(IPPROTO_TCP); require './t/common.perl'; # FIXME: too much setup @@ -99,6 +100,13 @@ EOF 'fsck on cloned directory successful'); } +SKIP: { + skip 'TCP_DEFER_ACCEPT is Linux-only', 1 if $^O ne 'linux'; + my $var = Socket::TCP_DEFER_ACCEPT(); + defined(my $x = getsockopt($sock, IPPROTO_TCP, $var)) or die; + ok(unpack('i', $x) > 0, 'TCP_DEFER_ACCEPT set'); +}; + done_testing(); 1; diff --git a/t/nntpd-tls.t b/t/nntpd-tls.t index e8fb63b4..ef683cab 100644 --- a/t/nntpd-tls.t +++ b/t/nntpd-tls.t @@ -4,7 +4,7 @@ use strict; use warnings; use Test::More; use File::Temp qw(tempdir); -use Socket qw(SOCK_STREAM); +use Socket qw(SOCK_STREAM IPPROTO_TCP); # IO::Poll and Net::NNTP are part of the standard library, but # distros may split them off... foreach my $mod (qw(DBD::SQLite IO::Socket::SSL Net::NNTP IO::Poll)) { @@ -182,6 +182,15 @@ for my $args ( is(sysread($slow, my $eof, 4096), 0, 'got EOF'); $slow = undef; + SKIP: { + skip 'TCP_DEFER_ACCEPT is Linux-only', 2 if $^O ne 'linux'; + my $var = Socket::TCP_DEFER_ACCEPT(); + defined(my $x = getsockopt($nntps, IPPROTO_TCP, $var)) or die; + ok(unpack('i', $x) > 0, 'TCP_DEFER_ACCEPT set on NNTPS'); + defined($x = getsockopt($starttls, IPPROTO_TCP, $var)) or die; + is(unpack('i', $x), 0, 'TCP_DEFER_ACCEPT is 0 on plain NNTP'); + }; + $c = undef; kill('TERM', $pid); is($pid, waitpid($pid, 0), 'nntpd exited successfully'); -- cgit v1.2.3-24-ge0c7 From fbcd2b5eb401a8e1811d803cef9b1c156acb50f6 Mon Sep 17 00:00:00 2001 From: Eric Wong Date: Mon, 24 Jun 2019 02:52:54 +0000 Subject: daemon: use FreeBSD accept filters on non-NNTP Similar to TCP_DEFER_ACCEPT on Linux, FreeBSD has a 'dataready' accept filter which we can use to reduce wakeups when doing TLS negotiation or plain HTTP. There's also a 'httpready' which we can use for plain HTTP connections. --- t/httpd-corner.t | 21 ++++++++++++++++++--- t/httpd.t | 10 ++++++++++ t/nntpd-tls.t | 14 +++++++++++++- 3 files changed, 41 insertions(+), 4 deletions(-) (limited to 't') diff --git a/t/httpd-corner.t b/t/httpd-corner.t index 13befcf1..1cfc2565 100644 --- a/t/httpd-corner.t +++ b/t/httpd-corner.t @@ -18,7 +18,7 @@ use File::Temp qw/tempdir/; use IO::Socket; use IO::Socket::UNIX; use Fcntl qw(:seek); -use Socket qw(IPPROTO_TCP TCP_NODELAY); +use Socket qw(IPPROTO_TCP TCP_NODELAY SOL_SOCKET); use POSIX qw(mkfifo); require './t/common.perl'; my $tmpdir = tempdir('httpd-corner-XXXXXX', TMPDIR => 1, CLEANUP => 1); @@ -36,7 +36,10 @@ my %opts = ( Listen => 1024, ); my $sock = IO::Socket::INET->new(%opts); -my $defer_accept_val; + +# Make sure we don't clobber socket options set by systemd or similar +# using socket activation: +my ($defer_accept_val, $accf_arg); if ($^O eq 'linux') { setsockopt($sock, IPPROTO_TCP, Socket::TCP_DEFER_ACCEPT(), 5) or die; my $x = getsockopt($sock, IPPROTO_TCP, Socket::TCP_DEFER_ACCEPT()); @@ -45,6 +48,11 @@ if ($^O eq 'linux') { if ($defer_accept_val <= 0) { die "unexpected TCP_DEFER_ACCEPT value: $defer_accept_val"; } +} elsif ($^O eq 'freebsd' && system('kldstat -m accf_data >/dev/null') == 0) { + require PublicInbox::Daemon; + my $var = PublicInbox::Daemon::SO_ACCEPTFILTER(); + $accf_arg = pack('a16a240', 'dataready', ''); + setsockopt($sock, SOL_SOCKET, $var, $accf_arg) or die "setsockopt: $!"; } my $upath = "$tmpdir/s"; @@ -100,7 +108,7 @@ my $spawn_httpd = sub { is(scalar(grep(/CLOSE FAIL/, @$after)), 1, 'body->close not called'); } -{ +SKIP: { my $conn = conn_for($sock, 'excessive header'); $SIG{PIPE} = 'IGNORE'; $conn->write("GET /callback HTTP/1.0\r\n"); @@ -515,6 +523,13 @@ SKIP: { is(unpack('i', $x), $defer_accept_val, 'TCP_DEFER_ACCEPT unchanged if previously set'); }; +SKIP: { + skip 'SO_ACCEPTFILTER is FreeBSD-only', 1 if $^O ne 'freebsd'; + skip 'accf_data not loaded: kldload accf_data' if !defined $accf_arg; + my $var = PublicInbox::Daemon::SO_ACCEPTFILTER(); + defined(my $x = getsockopt($sock, SOL_SOCKET, $var)) or die; + is($x, $accf_arg, 'SO_ACCEPTFILTER unchanged if previously set'); +}; done_testing(); diff --git a/t/httpd.t b/t/httpd.t index 8c2a3173..e085c4b9 100644 --- a/t/httpd.t +++ b/t/httpd.t @@ -106,6 +106,16 @@ SKIP: { defined(my $x = getsockopt($sock, IPPROTO_TCP, $var)) or die; ok(unpack('i', $x) > 0, 'TCP_DEFER_ACCEPT set'); }; +SKIP: { + skip 'SO_ACCEPTFILTER is FreeBSD-only', 1 if $^O ne 'freebsd'; + if (system('kldstat -m accf_http >/dev/null') != 0) { + skip 'accf_http not loaded: kldload accf_http', 1; + } + require PublicInbox::Daemon; + my $var = PublicInbox::Daemon::SO_ACCEPTFILTER(); + my $x = getsockopt($sock, SOL_SOCKET, $var); + like($x, qr/\Ahttpready\0+\z/, 'got httpready accf for HTTP'); +}; done_testing(); diff --git a/t/nntpd-tls.t b/t/nntpd-tls.t index ef683cab..427d370f 100644 --- a/t/nntpd-tls.t +++ b/t/nntpd-tls.t @@ -4,7 +4,7 @@ use strict; use warnings; use Test::More; use File::Temp qw(tempdir); -use Socket qw(SOCK_STREAM IPPROTO_TCP); +use Socket qw(SOCK_STREAM IPPROTO_TCP SOL_SOCKET); # IO::Poll and Net::NNTP are part of the standard library, but # distros may split them off... foreach my $mod (qw(DBD::SQLite IO::Socket::SSL Net::NNTP IO::Poll)) { @@ -190,6 +190,18 @@ for my $args ( defined($x = getsockopt($starttls, IPPROTO_TCP, $var)) or die; is(unpack('i', $x), 0, 'TCP_DEFER_ACCEPT is 0 on plain NNTP'); }; + SKIP: { + skip 'SO_ACCEPTFILTER is FreeBSD-only', 2 if $^O ne 'freebsd'; + if (system('kldstat -m accf_data >/dev/null')) { + skip 'accf_data not loaded? kldload accf_data', 2; + } + require PublicInbox::Daemon; + my $var = PublicInbox::Daemon::SO_ACCEPTFILTER(); + my $x = getsockopt($nntps, SOL_SOCKET, $var); + like($x, qr/\Adataready\0+\z/, 'got dataready accf for NNTPS'); + $x = getsockopt($starttls, IPPROTO_TCP, $var); + is($x, undef, 'no BSD accept filter for plain NNTP'); + }; $c = undef; kill('TERM', $pid); -- cgit v1.2.3-24-ge0c7 From 4f868db3675eeee5994edc4fe79a9a2583623747 Mon Sep 17 00:00:00 2001 From: Eric Wong Date: Mon, 24 Jun 2019 02:52:56 +0000 Subject: ds: reimplement IO::Poll support to look like epoll At least the subset of epoll we use. EPOLLET might be difficult to emulate if we end up using it. --- t/ds-poll.t | 58 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 58 insertions(+) create mode 100644 t/ds-poll.t (limited to 't') diff --git a/t/ds-poll.t b/t/ds-poll.t new file mode 100644 index 00000000..a397ee06 --- /dev/null +++ b/t/ds-poll.t @@ -0,0 +1,58 @@ +# Copyright (C) 2019 all contributors +# Licensed the same as Danga::Socket (and Perl5) +# License: GPL-1.0+ or Artistic-1.0-Perl +# +# +use strict; +use warnings; +use Test::More; +use PublicInbox::Syscall qw(:epoll); +my $cls = 'PublicInbox::DSPoll'; +use_ok $cls; +my $p = $cls->new; + +my ($r, $w, $x, $y); +pipe($r, $w) or die; +pipe($x, $y) or die; +is(epoll_ctl($p, EPOLL_CTL_ADD, fileno($r), EPOLLIN), 0, 'add EPOLLIN'); +my $events = []; +my $n = epoll_wait($p, 9, 0, $events); +is_deeply($events, [], 'no events set'); +is($n, 0, 'nothing ready, yet'); +is(epoll_ctl($p, EPOLL_CTL_ADD, fileno($w), EPOLLOUT|EPOLLONESHOT), 0, + 'add EPOLLOUT|EPOLLONESHOT'); +$n = epoll_wait($p, 9, -1, $events); +is($n, 1, 'got POLLOUT event'); +is($events->[0]->[0], fileno($w), '$w ready'); + +$n = epoll_wait($p, 9, 0, $events); +is($n, 0, 'nothing ready after oneshot'); +is_deeply($events, [], 'no events set after oneshot'); + +syswrite($w, '1') == 1 or die; +for my $t (0..1) { + $n = epoll_wait($p, 9, $t, $events); + is($events->[0]->[0], fileno($r), "level-trigger POLLIN ready #$t"); + is($n, 1, "only event ready #$t"); +} +syswrite($y, '1') == 1 or die; +is(epoll_ctl($p, EPOLL_CTL_ADD, fileno($x), EPOLLIN|EPOLLONESHOT), 0, + 'EPOLLIN|EPOLLONESHOT add'); +is(epoll_wait($p, 9, -1, $events), 2, 'epoll_wait has 2 ready'); +my @fds = sort(map { $_->[0] } @$events); +my @exp = sort((fileno($r), fileno($x))); +is_deeply(\@fds, \@exp, 'got both ready FDs'); + +# EPOLL_CTL_DEL doesn't matter for kqueue, we do it in native epoll +# to avoid a kernel-wide lock; but its not needed for native kqueue +# paths so DSKQXS makes it a noop (as did Danga::Socket::close). +SKIP: { + if ($cls ne 'PublicInbox::DSPoll') { + skip "$cls doesn't handle EPOLL_CTL_DEL", 2; + } + is(epoll_ctl($p, EPOLL_CTL_DEL, fileno($r), 0), 0, 'EPOLL_CTL_DEL OK'); + $n = epoll_wait($p, 9, 0, $events); + is($n, 0, 'nothing ready after EPOLL_CTL_DEL'); +}; + +done_testing; -- cgit v1.2.3-24-ge0c7