[PATCH 1/3] lei q: limit concurrency to 4 remote connections

[PATCH 1/3] lei q: limit concurrency to 4 remote connections

[Eric Wong]

Unfortunately, this isn't a per-host limit, yet; but
nevertheless reduces load on existing PublicInbox::WWW
instances, since requesting a mboxrd is one of the more
expensive operations.
---
 lib/PublicInbox/LeiQuery.pm   |  2 +-
 lib/PublicInbox/LeiXSearch.pm | 82 +++++++++++++++++++++--------------
 2 files changed, 51 insertions(+), 33 deletions(-)

diff --git a/lib/PublicInbox/LeiQuery.pm b/lib/PublicInbox/LeiQuery.pm
index acab3c2c..a7938e8b 100644
--- a/lib/PublicInbox/LeiQuery.pm
+++ b/lib/PublicInbox/LeiQuery.pm
@@ -26,7 +26,7 @@ sub lei_q {
 		my $cb = $lxs->can('prepare_external');
 		$self->_externals_each($cb, $lxs);
 	}
-	my $xj = $opt->{thread} ? $lxs->locals : ($lxs->remotes + 1);
+	my $xj = $lxs->concurrency($opt);
 	my $ovv = PublicInbox::LeiOverview->new($self) or return;
 	$self->atfork_prepare_wq($lxs);
 	$lxs->wq_workers_start('lei_xsearch', $xj, $self->oldset);
diff --git a/lib/PublicInbox/LeiXSearch.pm b/lib/PublicInbox/LeiXSearch.pm
index defe5e67..1c093a94 100644
--- a/lib/PublicInbox/LeiXSearch.pm
+++ b/lib/PublicInbox/LeiXSearch.pm
@@ -182,25 +182,16 @@ sub each_eml { # callback for MboxReader->mboxrd
 }
 
 sub query_remote_mboxrd {
-	my ($self, $lei, $uri) = @_;
+	my ($self, $lei, $uris) = @_;
 	local $0 = "$0 query_remote_mboxrd";
 	my %sig = $lei->atfork_child_wq($self); # keep $self->{5} startq
 	local @SIG{keys %sig} = values %sig;
-	my $opt = $lei->{opt};
-	$uri->query_form(q => $lei->{mset_opt}->{qstr}, x => 'm',
-			$opt->{thread} ? (t => 1) : ());
-	my $each_smsg = $lei->{ovv}->ovv_each_smsg_cb($lei, $uri);
+	my ($opt, $env) = @$lei{qw(opt env)};
+	my @qform = (q => $lei->{mset_opt}->{qstr}, x => 'm');
+	push(@qform, t => 1) if $opt->{thread};
 	my $dedupe = $lei->{dedupe} // die 'BUG: {dedupe} missing';
 	$dedupe->prepare_dedupe;
 	my @cmd = qw(curl -XPOST -sSf);
-	$opt->{torsocks} = 'false' if $opt->{'no-torsocks'};
-	my $tor = $opt->{torsocks} //= 'auto';
-	if ($tor eq 'auto' && substr($uri->host, -6) eq '.onion' &&
-			(($lei->{env}->{LD_PRELOAD}//'') !~ /torsocks/)) {
-		unshift @cmd, 'torsocks';
-	} elsif (PublicInbox::Config::git_bool($tor)) {
-		unshift @cmd, 'torsocks';
-	}
 	my $verbose = $opt->{verbose};
 	push @cmd, '-v' if $verbose;
 	for my $o ($lei->curl_opt) {
@@ -215,25 +206,36 @@ sub query_remote_mboxrd {
 			push @cmd, "--$o";
 		}
 	}
-	push @cmd, $uri->as_string;
-	$lei->err("# @cmd") if $verbose;
-	$? = 0;
-	my $fh = popen_rd(\@cmd, $lei->{env}, { 2 => $lei->{2} });
-	$fh = IO::Uncompress::Gunzip->new($fh);
-	eval {
-		PublicInbox::MboxReader->mboxrd($fh, \&each_eml,
-						$self, $lei, $each_smsg);
-	};
-	return $lei->fail("E: @cmd: $@") if $@;
-	if (($? >> 8) == 22) { # HTTP 404 from curl(1)
-		$uri->query_form(q => $lei->{mset_opt}->{qstr});
-		$lei->err('# no results from '.$uri->as_string);
-	} elsif ($?) {
-		$uri->query_form(q => $lei->{mset_opt}->{qstr});
-		$lei->err('E: '.$uri->as_string);
-		$lei->child_error($?);
+	$opt->{torsocks} = 'false' if $opt->{'no-torsocks'};
+	my $tor = $opt->{torsocks} //= 'auto';
+	for my $uri (@$uris) {
+		$uri->query_form(@qform);
+		my $each_smsg = $lei->{ovv}->ovv_each_smsg_cb($lei, $uri);
+		my $cmd = [ @cmd, $uri->as_string ];
+		if ($tor eq 'auto' && substr($uri->host, -6) eq '.onion' &&
+				(($env->{LD_PRELOAD}//'') !~ /torsocks/)) {
+			unshift @$cmd, 'torsocks';
+		} elsif (PublicInbox::Config::git_bool($tor)) {
+			unshift @$cmd, 'torsocks';
+		}
+		$lei->err("# @$cmd") if $verbose;
+		$? = 0;
+		my $fh = popen_rd($cmd, $env, { 2 => $lei->{2} });
+		$fh = IO::Uncompress::Gunzip->new($fh);
+		eval {
+			PublicInbox::MboxReader->mboxrd($fh, \&each_eml, $self,
+							$lei, $each_smsg);
+		};
+		return $lei->fail("E: @$cmd: $@") if $@;
+		if (($? >> 8) == 22) { # HTTP 404 from curl(1)
+			$uri->query_form(q => $lei->{mset_opt}->{qstr});
+			$lei->err('# no results from '.$uri->as_string);
+		} elsif ($?) {
+			$uri->query_form(q => $lei->{mset_opt}->{qstr});
+			$lei->err('E: '.$uri->as_string);
+			$lei->child_error($?);
+		}
 	}
-	undef $each_smsg;
 	$lei->{ovv}->ovv_atexit_child($lei);
 }
 
@@ -292,6 +294,17 @@ sub do_post_augment {
 	close $au_done; # triggers wait_startq
 }
 
+my $MAX_PER_HOST = 4;
+sub MAX_PER_HOST { $MAX_PER_HOST }
+
+sub concurrency {
+	my ($self, $opt) = @_;
+	my $nl = $opt->{thread} ? locals($self) : 1;
+	my $nr = remotes($self);
+	$nr = $MAX_PER_HOST if $nr > $MAX_PER_HOST;
+	$nl + $nr;
+}
+
 sub start_query { # always runs in main (lei-daemon) process
 	my ($self, $io, $lei) = @_;
 	if ($lei->{opt}->{thread}) {
@@ -301,8 +314,13 @@ sub start_query { # always runs in main (lei-daemon) process
 	} else {
 		$self->wq_do('query_mset', $io, $lei);
 	}
+	my $i = 0;
+	my $q = [];
 	for my $uri (remotes($self)) {
-		$self->wq_do('query_remote_mboxrd', $io, $lei, $uri);
+		push @{$q->[$i++ % $MAX_PER_HOST]}, $uri;
+	}
+	for my $uris (@$q) {
+		$self->wq_do('query_remote_mboxrd', $io, $lei, $uris);
 	}
 	@$io = ();
 }

[PATCH 2/3] ipc: wq supports arbitrarily large payloads

[Eric Wong]

This should not be needed, but somebody using lei could
theoretically create thousands of external URLs and
only have a handful of workers, which means the per-worker
URI list could be large.
---
 lib/PublicInbox/IPC.pm | 82 +++++++++++++++++++++++++++++-------------
 t/cmd_ipc.t            | 16 +++++++++
 t/ipc.t                | 22 +++++++++++-
 3 files changed, 94 insertions(+), 26 deletions(-)

diff --git a/lib/PublicInbox/IPC.pm b/lib/PublicInbox/IPC.pm
index 6efaff38..592efd21 100644
--- a/lib/PublicInbox/IPC.pm
+++ b/lib/PublicInbox/IPC.pm
@@ -8,8 +8,10 @@ use v5.10.1;
 use Carp qw(confess croak);
 use PublicInbox::DS qw(dwaitpid);
 use PublicInbox::Spawn;
-use POSIX qw(WNOHANG);
-use Socket qw(AF_UNIX MSG_EOR);
+use POSIX qw(mkfifo WNOHANG);
+use Socket qw(AF_UNIX MSG_EOR SOCK_STREAM);
+use Errno qw(EMSGSIZE);
+use File::Temp 0.19 (); # 0.19 for ->newdir
 my $SEQPACKET = eval { Socket::SOCK_SEQPACKET() }; # portable enough?
 use constant PIPE_BUF => $^O eq 'linux' ? 4096 : POSIX::_POSIX_PIPE_BUF();
 my $WQ_MAX_WORKERS = 4096;
@@ -245,39 +247,69 @@ sub ipc_sibling_atfork_child {
 	$pid == $$ and die "BUG: $$ ipc_atfork_child called on itself";
 }
 
+sub _recv_and_run {
+	my ($self, $s2, $len, $full_stream) = @_;
+	my @fds = $recv_cmd->($s2, my $buf, $len);
+	my $n = length($buf // '') or return;
+	my @m = @{$self->{-wq_recv_modes} // [qw( +<&= >&= >&= )]};
+	my $nfd = 0;
+	for my $fd (@fds) {
+		my $mode = shift(@m);
+		if (open(my $cmdfh, $mode, $fd)) {
+			$self->{$nfd++} = $cmdfh;
+			$cmdfh->autoflush(1);
+		} else {
+			die "$$ open($mode$fd) (FD:$nfd): $!";
+		}
+	}
+	while ($full_stream && $n < $len) {
+		my $r = sysread($s2, $buf, $len - $n, $n) // croak "read: $!";
+		croak "read EOF after $n/$len bytes" if $r == 0;
+		$n = length($buf);
+	}
+	# Sereal dies on truncated data, Storable returns undef
+	my $args = thaw($buf) // die "thaw error on buffer of size: $n";
+	undef $buf;
+	my $sub = shift @$args;
+	eval { $self->$sub(@$args) };
+	warn "$$ wq_worker: $@" if $@ && ref($@) ne 'PublicInbox::SIGPIPE';
+	delete @$self{0..($nfd-1)};
+	$n;
+}
+
 sub wq_worker_loop ($) {
 	my ($self) = @_;
 	my $len = $self->{wq_req_len} // (4096 * 33);
 	my $s2 = $self->{-wq_s2} // die 'BUG: no -wq_s2';
-	while (1) {
-		my @fds = $recv_cmd->($s2, my $buf, $len) or return; # EOF
-		my @m = @{$self->{-wq_recv_modes} // [qw( +<&= >&= >&= )]};
-		my $nfd = 0;
-		for my $fd (@fds) {
-			my $mode = shift(@m);
-			if (open(my $cmdfh, $mode, $fd)) {
-				$self->{$nfd++} = $cmdfh;
-				$cmdfh->autoflush(1);
-			} else {
-				die "$$ open($mode$fd) (FD:$nfd): $!";
-			}
-		}
-		# Sereal dies on truncated data, Storable returns undef
-		my $args = thaw($buf) //
-			die "thaw error on buffer of size:".length($buf);
-		my $sub = shift @$args;
-		eval { $self->$sub(@$args) };
-		warn "$$ wq_worker: $@" if $@ &&
-					ref($@) ne 'PublicInbox::SIGPIPE';
-		delete @$self{0..($nfd-1)};
-	}
+	1 while (_recv_and_run($self, $s2, $len));
+}
+
+sub do_sock_stream { # via wq_do, for big requests
+	my ($self, $len) = @_;
+	_recv_and_run($self, delete $self->{0}, $len, 1);
 }
 
 sub wq_do { # always async
 	my ($self, $sub, $ios, @args) = @_;
 	if (my $s1 = $self->{-wq_s1}) { # run in worker
 		my $fds = [ map { fileno($_) } @$ios ];
-		$send_cmd->($s1, $fds, freeze([$sub, @args]), MSG_EOR);
+		my $n = $send_cmd->($s1, $fds, freeze([$sub, @args]), MSG_EOR);
+		return if defined($n);
+		croak "sendmsg error: $!" if $! != EMSGSIZE;
+		socketpair(my $r, my $w, AF_UNIX, SOCK_STREAM, 0) or
+			croak "socketpair: $!";
+		my $buf = freeze([$sub, @args]);
+		$n = $send_cmd->($s1, [ fileno($r) ],
+				freeze(['do_sock_stream', length($buf)]),
+				MSG_EOR) // croak "sendmsg: $!";
+		undef $r;
+		$n = $send_cmd->($w, $fds, $buf, 0) // croak "sendmsg: $!";
+		while ($n < length($buf)) {
+			my $x = syswrite($w, $buf, length($buf) - $n, $n) //
+					croak "syswrite: $!";
+			croak "syswrite wrote 0 bytes" if $x == 0;
+			$n += $x;
+		}
 	} else {
 		@$self{0..$#$ios} = @$ios;
 		eval { $self->$sub(@args) };
diff --git a/t/cmd_ipc.t b/t/cmd_ipc.t
index 96510175..84f8fb4d 100644
--- a/t/cmd_ipc.t
+++ b/t/cmd_ipc.t
@@ -82,6 +82,22 @@ my $do_test = sub { SKIP: {
 		@fds = $recv->($s2, $buf, length($src));
 		is(scalar(@fds), 0, 'no FDs received');
 		is($buf, $src, 'recv w/o FDs');
+
+		my $nr = 2 * 1024 * 1024;
+		while (1) {
+			vec(my $vec = '', $nr * 8 - 1, 1) = 1;
+			my $n = $send->($s1, [], $vec, $flag);
+			if (defined($n)) {
+				$n == length($vec) or
+					fail "short send: $n != ".length($vec);
+				diag "sent $nr, retrying with more";
+				$nr += 2 * 1024 * 1024;
+			} else {
+				ok($!{EMSGSIZE}, 'got EMSGSIZE');
+				# diag "$nr bytes hits EMSGSIZE";
+				last;
+			}
+		}
 	}
 } };
 
diff --git a/t/ipc.t b/t/ipc.t
index 22423a78..f25f2491 100644
--- a/t/ipc.t
+++ b/t/ipc.t
@@ -6,11 +6,13 @@ use v5.10.1;
 use Test::More;
 use PublicInbox::TestCommon;
 use Fcntl qw(SEEK_SET);
+use Digest::SHA qw(sha1_hex);
 require_mods(qw(Storable||Sereal));
 require_ok 'PublicInbox::IPC';
 state $once = eval <<'';
 package PublicInbox::IPC;
 use strict;
+use Digest::SHA qw(sha1_hex);
 sub test_array { qw(test array) }
 sub test_scalar { 'scalar' }
 sub test_scalarref { \'scalarref' }
@@ -24,6 +26,11 @@ sub test_write_each_fd {
 		$self->{$fd}->flush;
 	}
 }
+sub test_sha {
+	my ($self, $buf) = @_;
+	print { $self->{1} } sha1_hex($buf), "\n";
+	$self->{1}->flush;
+}
 1;
 
 my $ipc = bless {}, 'PublicInbox::IPC';
@@ -112,7 +119,7 @@ $test->('local');
 $ipc->ipc_worker_stop; # idempotent
 
 # work queues
-$ipc->wq_set_recv_modes(qw( >&= >&= >&= ));
+$ipc->wq_set_recv_modes(qw( +>&= >&= >&= ));
 pipe(my ($ra, $wa)) or BAIL_OUT $!;
 pipe(my ($rb, $wb)) or BAIL_OUT $!;
 pipe(my ($rc, $wc)) or BAIL_OUT $!;
@@ -120,6 +127,10 @@ open my $warn, '+>', undef or BAIL_OUT;
 $warn->autoflush(0);
 local $SIG{__WARN__} = sub { print $warn "PID:$$ ", @_ };
 my @ppids;
+open my $agpl, '<', 'COPYING' or BAIL_OUT "AGPL-3 missing: $!";
+my $big = do { local $/; <$agpl> } // BAIL_OUT "read: $!";
+close $agpl or BAIL_OUT "close: $!";
+
 for my $t ('local', 'worker', 'worker again') {
 	$ipc->wq_do('test_write_each_fd', [ $wa, $wb, $wc ], 'hello world');
 	my $i = 0;
@@ -130,6 +141,15 @@ for my $t ('local', 'worker', 'worker again') {
 		$i++;
 	}
 	$ipc->wq_do('test_die', [ $wa, $wb, $wc ]);
+	$ipc->wq_do('test_sha', [ $wa, $wb ], 'hello world');
+	is(readline($rb), sha1_hex('hello world')."\n", "SHA small ($t)");
+	{
+		my $bigger = $big x 10;
+		$ipc->wq_do('test_sha', [ $wa, $wb ], $bigger);
+		my $exp = sha1_hex($bigger)."\n";
+		undef $bigger;
+		is(readline($rb), $exp, "SHA big ($t)");
+	}
 	my $ppid = $ipc->wq_workers_start('wq', 1);
 	push(@ppids, $ppid);
 }

[PATCH 3/3] ipc: get rid of wq_set_recv_modes

[Eric Wong]

Just open every FD as read/write.  Perl (or any non-broken
runtime) won't care and won't attempt to use F_SETFL to alter
file description flags.
---
 lib/PublicInbox/IPC.pm        | 11 ++---------
 lib/PublicInbox/LEI.pm        |  7 +++----
 lib/PublicInbox/LeiToMail.pm  |  7 ++-----
 lib/PublicInbox/LeiXSearch.pm |  5 ++---
 script/lei                    | 11 +++++------
 t/ipc.t                       |  1 -
 6 files changed, 14 insertions(+), 28 deletions(-)

diff --git a/lib/PublicInbox/IPC.pm b/lib/PublicInbox/IPC.pm
index 592efd21..c52441f7 100644
--- a/lib/PublicInbox/IPC.pm
+++ b/lib/PublicInbox/IPC.pm
@@ -46,11 +46,6 @@ my $send_cmd = PublicInbox::Spawn->can('send_cmd4') // do {
 	PublicInbox::CmdIPC4->can('send_cmd4');
 };
 
-sub wq_set_recv_modes {
-	my ($self, @modes) = @_;
-	$self->{-wq_recv_modes} = \@modes;
-}
-
 sub _get_rec ($) {
 	my ($r) = @_;
 	defined(my $len = <$r>) or return;
@@ -251,15 +246,13 @@ sub _recv_and_run {
 	my ($self, $s2, $len, $full_stream) = @_;
 	my @fds = $recv_cmd->($s2, my $buf, $len);
 	my $n = length($buf // '') or return;
-	my @m = @{$self->{-wq_recv_modes} // [qw( +<&= >&= >&= )]};
 	my $nfd = 0;
 	for my $fd (@fds) {
-		my $mode = shift(@m);
-		if (open(my $cmdfh, $mode, $fd)) {
+		if (open(my $cmdfh, '+<&=', $fd)) {
 			$self->{$nfd++} = $cmdfh;
 			$cmdfh->autoflush(1);
 		} else {
-			die "$$ open($mode$fd) (FD:$nfd): $!";
+			die "$$ open(+<&=$fd) (FD:$nfd): $!";
 		}
 	}
 	while ($full_stream && $n < $len) {
diff --git a/lib/PublicInbox/LEI.pm b/lib/PublicInbox/LEI.pm
index a9123c6e..473a28a9 100644
--- a/lib/PublicInbox/LEI.pm
+++ b/lib/PublicInbox/LEI.pm
@@ -765,11 +765,10 @@ sub accept_dispatch { # Listener {post_accept} callback
 		return send($sock, 'timed out waiting to recv FDs', MSG_EOR);
 	my @fds = $recv_cmd->($sock, my $buf, 4096 * 33); # >MAX_ARG_STRLEN
 	if (scalar(@fds) == 4) {
-		my $i = 0;
-		for my $rdr (qw(<&= >&= >&= <&=)) {
+		for my $i (0..3) {
 			my $fd = shift(@fds);
-			open($self->{$i++}, $rdr, $fd) and next;
-			send($sock, "open($rdr$fd) (FD=$i): $!", MSG_EOR);
+			open($self->{$i}, '+<&=', $fd) and next;
+			send($sock, "open(+<&=$fd) (FD=$i): $!", MSG_EOR);
 		}
 	} else {
 		return send($sock, "recv_cmd failed: $!", MSG_EOR);
diff --git a/lib/PublicInbox/LeiToMail.pm b/lib/PublicInbox/LeiToMail.pm
index 5f38add1..08a1570d 100644
--- a/lib/PublicInbox/LeiToMail.pm
+++ b/lib/PublicInbox/LeiToMail.pm
@@ -227,9 +227,7 @@ sub decompress_src ($$$) {
 
 sub dup_src ($) {
 	my ($in) = @_;
-	# fileno needed because wq_set_recv_modes only used ">&=" for {1}
-	# and Perl blindly trusts that to reject the '+' (readability flag)
-	open my $dup, '+>>&=', fileno($in) or die "dup: $!";
+	open my $dup, '+>>&', $in or die "dup: $!";
 	$dup;
 }
 
@@ -475,8 +473,7 @@ sub write_mail { # via ->wq_do
 
 sub ipc_atfork_prepare {
 	my ($self) = @_;
-	# (done_wr, stdout|mbox, stderr, 3: sock, 4: each_smsg_done_wr)
-	$self->wq_set_recv_modes(qw[+<&= >&= >&= +<&= >&=]);
+	# FDs: (done_wr, stdout|mbox, stderr, 3: sock, 4: each_smsg_done_wr)
 	$self->SUPER::ipc_atfork_prepare; # PublicInbox::IPC
 }
 
diff --git a/lib/PublicInbox/LeiXSearch.pm b/lib/PublicInbox/LeiXSearch.pm
index 1c093a94..c396c597 100644
--- a/lib/PublicInbox/LeiXSearch.pm
+++ b/lib/PublicInbox/LeiXSearch.pm
@@ -389,9 +389,8 @@ sub ipc_atfork_prepare {
 		require PublicInbox::MboxReader;
 		require IO::Uncompress::Gunzip;
 	}
-	# (0: done_wr, 1: stdout|mbox, 2: stderr,
-	#  3: sock, 4: $l2m->{-wq_s1}, 5: $startq)
-	$self->wq_set_recv_modes(qw[+<&= >&= >&= +<&= +<&= <&=]);
+	# FDS: (0: done_wr, 1: stdout|mbox, 2: stderr,
+	#       3: sock, 4: $l2m->{-wq_s1}, 5: $startq)
 	$self->SUPER::ipc_atfork_prepare; # PublicInbox::IPC
 }
 
diff --git a/script/lei b/script/lei
index 8c40bf12..006c1180 100755
--- a/script/lei
+++ b/script/lei
@@ -23,20 +23,19 @@ sub sigchld {
 
 sub exec_cmd {
 	my ($fds, $argc, @argv) = @_;
-	my @m = (*STDIN{IO}, '<&=',  *STDOUT{IO}, '>&=', *STDERR{IO}, '>&=');
+	my @old = (*STDIN{IO}, *STDOUT{IO}, *STDERR{IO});
 	my @rdr;
 	for my $fd (@$fds) {
-		my ($old_io, $mode) = splice(@m, 0, 2);
-		open(my $tmpfh, $mode, $fd) or die "open $mode$fd: $!";
-		push @rdr, $old_io, $mode, $tmpfh;
+		open(my $tmpfh, '+<&=', $fd) or die "open +<&=$fd: $!";
+		push @rdr, shift(@old), $tmpfh;
 	}
 	require POSIX; # WNOHANG
 	$SIG{CHLD} = \&sigchld;
 	my $pid = fork // die "fork: $!";
 	if ($pid == 0) {
 		my %env = map { split(/=/, $_, 2) } splice(@argv, $argc);
-		while (my ($old_io, $mode, $tmpfh) = splice(@rdr, 0, 3)) {
-			open $old_io, $mode, $tmpfh or die "open $mode: $!";
+		while (my ($old_io, $tmpfh) = splice(@rdr, 0, 2)) {
+			open $old_io, '+<&', $tmpfh or die "open +<&=: $!";
 		}
 		%ENV = (%ENV, %env);
 		exec(@argv);
diff --git a/t/ipc.t b/t/ipc.t
index f25f2491..5801c760 100644
--- a/t/ipc.t
+++ b/t/ipc.t
@@ -119,7 +119,6 @@ $test->('local');
 $ipc->ipc_worker_stop; # idempotent
 
 # work queues
-$ipc->wq_set_recv_modes(qw( +>&= >&= >&= ));
 pipe(my ($ra, $wa)) or BAIL_OUT $!;
 pipe(my ($rb, $wb)) or BAIL_OUT $!;
 pipe(my ($rc, $wc)) or BAIL_OUT $!;