diff options
Diffstat (limited to 'xt')
| -rw-r--r-- | xt/check-debris.t | 30 | ||||
| -rwxr-xr-x | xt/check-run.t | 271 | ||||
| -rw-r--r-- | xt/cmp-msgstr.t | 107 | ||||
| -rw-r--r-- | xt/create-many-inboxes.t | 100 | ||||
| -rw-r--r-- | xt/eml_check_limits.t | 78 | ||||
| -rw-r--r-- | xt/eml_octet-stream.t | 77 | ||||
| -rw-r--r-- | xt/git-http-backend.t | 52 | ||||
| -rw-r--r-- | xt/git_async_cmp.t | 18 | ||||
| -rw-r--r-- | xt/httpd-async-stream.t | 136 | ||||
| -rw-r--r-- | xt/imapd-mbsync-oimap.t | 136 | ||||
| -rw-r--r-- | xt/imapd-validate.t | 178 | ||||
| -rw-r--r-- | xt/lei-auth-fail.t | 24 | ||||
| -rw-r--r-- | xt/lei-onion-convert.t | 77 | ||||
| -rw-r--r-- | xt/mem-imapd-tls.t | 241 | ||||
| -rw-r--r-- | xt/mem-msgview.t | 3 | ||||
| -rw-r--r-- | xt/mem-nntpd-tls.t | 254 | ||||
| -rw-r--r-- | xt/msgtime_cmp.t | 28 | ||||
| -rw-r--r-- | xt/net_nntp_socks.t | 22 | ||||
| -rw-r--r-- | xt/net_writer-imap.t | 274 | ||||
| -rw-r--r-- | xt/nntpd-validate.t | 8 | ||||
| -rw-r--r-- | xt/over-fsck.perl | 44 | ||||
| -rw-r--r-- | xt/perf-msgview.t | 79 | ||||
| -rw-r--r-- | xt/perf-nntpd.t | 18 | ||||
| -rw-r--r-- | xt/perf-threading.t | 6 | ||||
| -rw-r--r-- | xt/pop3d-mpop.t | 76 | ||||
| -rw-r--r-- | xt/solver.t | 56 | ||||
| -rw-r--r-- | xt/stress-sharedkv.t | 50 |
27 files changed, 2330 insertions, 113 deletions
diff --git a/xt/check-debris.t b/xt/check-debris.t new file mode 100644 index 00000000..0bb5091d --- /dev/null +++ b/xt/check-debris.t @@ -0,0 +1,30 @@ +#!perl -w +use v5.12; +use autodie qw(open); +use PublicInbox::TestCommon; +use File::Spec; +my $tmpdir = File::Spec->tmpdir; + +diag "note: writes to `$tmpdir' by others results in false-positives"; + +my %cur = map { $_ => 1 } glob("$tmpdir/*"); +for my $t (@ARGV ? @ARGV : glob('t/*.t')) { + open my $fh, '-|', $^X, '-w', $t; + my @out; + while (<$fh>) { + chomp; + push @out, $_; + next if /^ok / || /\A[0-9]+\.\.[0-9]+\z/; + diag $_; + } + ok(close($fh), $t) or diag(explain(\@out)); + + no_coredump($tmpdir); + + my @remain = grep { !$cur{$_}++ } glob("$tmpdir/*"); + next if !@remain; + is_deeply(\@remain, [], "$t has no leftovers") or + diag "$t added: ",explain(\@remain); +} + +done_testing; diff --git a/xt/check-run.t b/xt/check-run.t new file mode 100755 index 00000000..d12b925d --- /dev/null +++ b/xt/check-run.t @@ -0,0 +1,271 @@ +#!/usr/bin/perl -w +# Copyright (C) all contributors <meta@public-inbox.org> +# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt> +# +# Parallel test runner which preloads code and reuses worker processes +# to give a nice speedup over prove(1). It also generates per-test +# .log files (similar to automake tests). +# +# *.t files run by this should not rely on global state. +# +# Usage: $PERL -I lib -w xt/check-run.t -j4 +# Or via prove(1): prove -lvw xt/check-run.t :: -j4 +use v5.12; +use IO::Handle; # ->autoflush +use PublicInbox::TestCommon; +use PublicInbox::Spawn; +use PublicInbox::DS; # already loaded by Spawn via PublicInbox::IO +use Getopt::Long qw(:config gnu_getopt no_ignore_case auto_abbrev); +use Errno qw(EINTR); +use Fcntl qw(:seek); +use POSIX qw(WNOHANG); +use File::Temp (); +my $jobs = 1; +my $repeat = 1; +$| = 1; +our $log_suffix = '.log'; +my ($shuffle, %pids, @err); +GetOptions('j|jobs=i' => \$jobs, + 'repeat=i' => \$repeat, + 'log=s' => \$log_suffix, + 's|shuffle' => \$shuffle, +) or die "Usage: $0 [-j JOBS] [--log=SUFFIX] [--repeat RUNS]"; +if (($ENV{TEST_RUN_MODE} // 2) == 0) { + die "$0 is not compatible with TEST_RUN_MODE=0\n"; +} +my @tests = scalar(@ARGV) ? @ARGV : glob('t/*.t'); +open my $cwd_fh, '<', '.' or die "open .: $!"; +open my $OLDOUT, '>&STDOUT' or die "dup STDOUT: $!"; +open my $OLDERR, '>&STDERR' or die "dup STDERR: $!"; +$OLDOUT->autoflush(1); +$OLDERR->autoflush(1); + +my ($run_log, $tmp_rl); +my $rl = $ENV{TEST_RUN_LOG}; +unless ($rl) { + $tmp_rl = File::Temp->new(CLEANUP => 1); + $rl = $tmp_rl->filename; +} +open $run_log, '+>>', $rl or die "open $rl: $!"; +$run_log->autoflush(1); # one reader, many writers + +key2sub($_) for @tests; # precache + +my ($for_destroy, $lei_env, $lei_daemon_pid, $owner_pid); + +# TEST_LEI_DAEMON_PERSIST is currently broken. I get ECONNRESET from +# lei even with high kern.ipc.soacceptqueue=1073741823 or SOMAXCONN, not +# sure why. Also, testing our internal inotify usage is unreliable +# because lei-daemon uses a single inotify FD for all clients. +if ($ENV{TEST_LEI_DAEMON_PERSIST} && !$ENV{TEST_LEI_DAEMON_PERSIST_DIR} && + (PublicInbox::Spawn->can('recv_cmd4') || + eval { require Socket::MsgHdr })) { + $lei_env = {}; + ($lei_env->{XDG_RUNTIME_DIR}, $for_destroy) = tmpdir; + $ENV{TEST_LEI_DAEMON_PERSIST_DIR} = $lei_env->{XDG_RUNTIME_DIR}; + run_script([qw(lei daemon-pid)], $lei_env, { 1 => \$lei_daemon_pid }); + chomp $lei_daemon_pid; + $lei_daemon_pid =~ /\A[0-9]+\z/ or die "no daemon pid: $lei_daemon_pid"; + kill(0, $lei_daemon_pid) or die "kill $lei_daemon_pid: $!"; + if (my $t = $ENV{GNU_TAIL}) { + system("$t --pid=$lei_daemon_pid -F " . + "$lei_env->{XDG_RUNTIME_DIR}/lei/errors.log >&2 &"); + } + if (my $strace_cmd = $ENV{STRACE_CMD}) { + system("$strace_cmd -p $lei_daemon_pid &"); + } + $owner_pid = $$; +} + +if ($shuffle) { + require List::Util; +} elsif (open(my $prove_state, '<', '.prove') && eval { require YAML::XS }) { + # reuse "prove --state=save" data to start slowest tests, first + my $state = YAML::XS::Load(do { local $/; <$prove_state> }); + my $t = $state->{tests}; + @tests = sort { + ($t->{$b}->{elapsed} // 0) <=> ($t->{$a}->{elapsed} // 0) + } @tests; + if (scalar(@tests) > 1) { + my $end = $#tests > 9 ? 9 : $#tests; + my $nr = $end + 1; + say "# top $nr longest tests (`make check' regenerates)"; + for (grep defined, @tests[0..$end]) { + printf "# %0.6f %s\n", $t->{$_}->{elapsed}, $_; + } + } +} + +our $tb = Test::More->builder; + +sub DIE (;$) { + print $OLDERR @_; + exit(1); +} + +our ($worker, $worker_test); + +sub test_status () { + $? = 255 if $? == 0 && !$tb->is_passing; + my $status = $? ? 'not ok' : 'ok'; + chdir($cwd_fh) or DIE "fchdir: $!"; + if ($log_suffix ne '') { + my $log = $worker_test; + $log =~ s/\.t\z/$log_suffix/; + my $skip = ''; + if (open my $fh, '<', $log) { + my @not_ok = grep(!/^(?:ok |[ \t]*#)/ms, <$fh>); + my $last = $not_ok[-1] // ''; + pop @not_ok if $last =~ /^[0-9]+\.\.[0-9]+$/; + my $pfx = "# $log: "; + print $OLDERR map { $pfx.$_ } @not_ok; + seek($fh, 0, SEEK_SET) or die "seek: $!"; + + # show unique skip texts and the number of times + # each text was skipped + local $/; + my @sk = (<$fh> =~ m/^ok [0-9]+ (# skip [^\n]+)/mgs); + if (@sk) { + my %nr; + my @err = grep { !$nr{$_}++ } @sk; + print $OLDERR "$pfx$_ ($nr{$_})\n" for @err; + $skip = ' # total skipped: '.scalar(@sk); + } + } else { + print $OLDERR "could not open: $log: $!\n"; + } + print $OLDOUT "$status $worker_test$skip\n"; + } +} + +# Test::Builder or Test2::Hub may call exit() from plan(skip_all => ...) +END { test_status() if (defined($worker_test) && $worker == $$) } + +sub run_test ($) { + my ($test) = @_; + syswrite($run_log, "$$ $test\n"); + my $log_fh; + if ($log_suffix ne '') { + my $log = $test; + $log =~ s/\.[^\.]+\z/$log_suffix/ or DIE "can't log for $test"; + open $log_fh, '>', $log or DIE "open $log: $!"; + $log_fh->autoflush(1); + $tb->output($log_fh); + $tb->failure_output($log_fh); + $tb->todo_output($log_fh); + open STDOUT, '>&', $log_fh or DIE "1>$log: $!"; + open STDERR, '>&', $log_fh or DIE "2>$log: $!"; + } + $worker_test = $test; + run_script([$test]); + test_status(); + $worker_test = undef; + push @err, "$test ($?)" if $?; +} + +sub UINT_SIZE () { 4 } + +# worker processes will SIGUSR1 the producer process when it +# sees EOF on the pipe. On FreeBSD 11.2 and Perl 5.30.0, +# sys/ioctl.ph gives the wrong value for FIONREAD(). +my $producer = $$; +my $eof; # we stop respawning if true + +my $start_worker = sub { + my ($j, $rd, $wr, $todo) = @_; + my $pid = fork // DIE "fork: $!"; + if ($pid == 0) { + close $wr; + $SIG{USR1} = undef; # undo parent $SIG{USR1} + $worker = $$; + while (1) { + my $r = sysread($rd, my $buf, UINT_SIZE); + if (!defined($r)) { + next if $! == EINTR; + DIE "sysread: $!"; + } + last if $r == 0; + DIE "short read $r" if $r != UINT_SIZE; + my $t = unpack('I', $buf); + run_test($todo->[$t]); + PublicInbox::DS->Reset; + $tb->reset; + } + kill 'USR1', $producer if !$eof; # sets $eof in $producer + if (@err) { # write to run_log for $sigchld handler + syswrite($run_log, "$$ @err\n"); + DIE join('', map { "E: $_\n" } @err); + } + exit(0); + } else { + $pids{$pid} = $j; + } +}; + +# negative $repeat means loop forever: +for (my $i = $repeat; $i != 0; $i--) { + my @todo = $shuffle ? List::Util::shuffle(@tests) : @tests; + + # single-producer, multi-consumer queue relying on POSIX pipe semantics + # POSIX.1-2008 stipulates a regular file should work, but Linux <3.14 + # had broken read(2) semantics according to the read(2) manpage + pipe(my ($rd, $wr)) or DIE "pipe: $!"; + + # fill the queue before forking so children can start earlier + $wr->autoflush(1); + $wr->blocking(0); + my $todo_buf = pack('I*', 0..$#todo); + my $woff = syswrite($wr, $todo_buf) // DIE "syswrite: $!"; + substr($todo_buf, 0, $woff, ''); + $eof = undef; + local $SIG{USR1} = sub { $eof = 1 }; + my $sigchld = sub { + my ($sig) = @_; + my $flags = $sig ? WNOHANG : 0; + while (1) { + my $pid = waitpid(-1, $flags) or return; + return if $pid < 0; + my $j = delete $pids{$pid}; + if (!defined($j)) { + push @err, "reaped unknown $pid ($?)"; + next; + } + if ($?) { + seek($run_log, 0, SEEK_SET); + chomp(my @t = grep(/^$pid /, <$run_log>)); + $t[0] //= "$pid unknown"; + push @err, "job[$j] ($?) PID=$t[-1]"; + } + # skip_all can exit(0), respawn if needed: + if (!$eof) { + print $OLDERR "# respawning job[$j]\n"; + $start_worker->($j, $rd, $wr, \@todo); + } + } + }; + + # start the workers to consume the queue + for (my $j = 0; $j < $jobs; $j++) { + $start_worker->($j, $rd, $wr, \@todo); + } + { + local $SIG{CHLD} = $sigchld; + # too many tests to fit in the pipe before starting workers, + # send the rest now the workers are running + $wr->blocking(1); + print $wr $todo_buf or DIE; + close $wr; + } + + $sigchld->(0) while scalar(keys(%pids)); + DIE join('', map { "E: $_\n" } @err) if @err; +} + +print $OLDOUT "1..".($repeat * scalar(@tests))."\n" if $repeat >= 0; +if ($lei_env && $$ == $owner_pid) { + my $opt = { 1 => $OLDOUT, 2 => $OLDERR }; + my $cur_daemon_pid; + run_script([qw(lei daemon-pid)], $lei_env, { 1 => \$cur_daemon_pid }); + run_script([qw(lei daemon-kill)], $lei_env, $opt); + DIE "lei daemon restarted\n" if $cur_daemon_pid != $lei_daemon_pid; +} diff --git a/xt/cmp-msgstr.t b/xt/cmp-msgstr.t new file mode 100644 index 00000000..b6c8ec65 --- /dev/null +++ b/xt/cmp-msgstr.t @@ -0,0 +1,107 @@ +#!perl -w +# Copyright (C) 2020-2021 all contributors <meta@public-inbox.org> +# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt> +use strict; +use Test::More; +use Benchmark qw(:all); +use PublicInbox::Inbox; +use PublicInbox::View; +use PublicInbox::TestCommon; +use PublicInbox::Eml; +use Digest::MD5; +use PublicInbox::MsgIter; +require_mods(qw(Data::Dumper Email::MIME)); +Data::Dumper->import('Dumper'); +require PublicInbox::MIME; +require_git(2.19); +my ($tmpdir, $for_destroy) = tmpdir(); +my $inboxdir = $ENV{GIANT_INBOX_DIR}; +plan skip_all => "GIANT_INBOX_DIR not defined for $0" unless $inboxdir; +my @cat = qw(cat-file --buffer --batch-check --batch-all-objects --unordered); +my $ibx = PublicInbox::Inbox->new({ inboxdir => $inboxdir, name => 'cmp' }); +my $git = $ibx->git; +my $fh = $git->popen(@cat); +vec(my $vec = '', fileno($fh), 1) = 1; +select($vec, undef, undef, 60) or die "timed out waiting for --batch-check"; +my $n = 0; +my $m = 0; +my $dig_cls = 'Digest::MD5'; +sub h ($) { + s/\s+\z//s; # E::M leaves trailing white space + s/\s+/ /sg; + "$_[0]: $_"; +} + +my $cmp = sub { + my ($p, $cmp_arg) = @_; + my $part = shift @$p; + push @$cmp_arg, '---'.join(', ', @$p).'---'; + my $ct = $part->content_type // 'text/plain'; + $ct =~ s/[ \t]+.*\z//s; + my ($s, $err); + eval { + push @$cmp_arg, map { h 'f' } $part->header('From'); + push @$cmp_arg, map { h 't' } $part->header('To'); + push @$cmp_arg, map { h 'cc' } $part->header('Cc'); + push @$cmp_arg, map { h 'mid' } $part->header('Message-ID'); + push @$cmp_arg, map { h 'refs' } $part->header('References'); + push @$cmp_arg, map { h 'irt' } $part->header('In-Reply-To'); + push @$cmp_arg, map { h 's' } $part->header('Subject'); + push @$cmp_arg, map { h 'cd' } + $part->header('Content-Description'); + ($s, $err) = msg_part_text($part, $ct); + if (defined $s) { + $s =~ s/\s+\z//s; + push @$cmp_arg, "S: ".$s; + } else { + $part = $part->body; + push @$cmp_arg, "T: $ct"; + if ($part =~ /[^\p{XPosixPrint}\s]/s) { # binary + my $dig = $dig_cls->new; + $dig->add($part); + push @$cmp_arg, "M: ".$dig->hexdigest; + push @$cmp_arg, "B: ".length($part); + } else { + $part =~ s/\s+\z//s; + push @$cmp_arg, "X: ".$part; + } + } + }; + if ($@) { + $err //= ''; + push @$cmp_arg, "E: $@ ($err)"; + } +}; + +my $ndiff = 0; +my $git_cb = sub { + my ($bref, $oid) = @_; + local $SIG{__WARN__} = sub { diag "$inboxdir $oid ", @_ }; + ++$m; + PublicInbox::MIME->new($$bref)->each_part($cmp, my $m_ctx = [], 1); + PublicInbox::Eml->new($$bref)->each_part($cmp, my $e_ctx = [], 1); + if (join("\0", @$e_ctx) ne join("\0", @$m_ctx)) { + ++$ndiff; + open my $fh, '>', "$tmpdir/mime" or die $!; + print $fh Dumper($m_ctx) or die $!; + close $fh or die $!; + open $fh, '>', "$tmpdir/eml" or die $!; + print $fh Dumper($e_ctx) or die $!; + close $fh or die $!; + diag "$inboxdir $oid differ"; + # using `git diff', diff(1) may not be installed + diag xqx([qw(git diff), "$tmpdir/mime", "$tmpdir/eml"]); + } +}; +my $t = timeit(1, sub { + while (<$fh>) { + my ($oid, $type) = split / /; + next if $type ne 'blob'; + ++$n; + $git->cat_async($oid, $git_cb); + } + $git->async_wait_all; +}); +is($m, $n, "$inboxdir rendered all $m <=> $n messages"); +is($ndiff, 0, "$inboxdir $ndiff differences"); +done_testing(); diff --git a/xt/create-many-inboxes.t b/xt/create-many-inboxes.t new file mode 100644 index 00000000..3d8932b7 --- /dev/null +++ b/xt/create-many-inboxes.t @@ -0,0 +1,100 @@ +#!perl -w +# Copyright (C) 2020-2021 all contributors <meta@public-inbox.org> +# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt> +use strict; +use v5.10.1; +use PublicInbox::TestCommon; +use PublicInbox::Eml; +use PublicInbox::IPC; +use File::Path qw(mkpath); +use IO::Handle (); # autoflush +use POSIX qw(_exit); +use Cwd qw(getcwd abs_path); +use File::Spec; +my $many_root = $ENV{TEST_MANY_ROOT} or + plan skip_all => 'TEST_MANY_ROOT not defined'; +my $cwd = getcwd(); +mkpath($many_root); +-d $many_root or BAIL_OUT "$many_root: $!"; +$many_root = abs_path($many_root); +$many_root =~ m!\A\Q$cwd\E/! and BAIL_OUT "$many_root must not be in $cwd"; +require_git 2.6; +require_mods(qw(DBD::SQLite Xapian)); +use_ok 'PublicInbox::V2Writable'; +my $nr_inbox = $ENV{NR_INBOX} // 10; +my $nproc = $ENV{NPROC} || PublicInbox::IPC::detect_nproc() || 2; +my $indexlevel = $ENV{TEST_INDEXLEVEL} // 'basic'; +diag "NR_INBOX=$nr_inbox NPROC=$nproc TEST_INDEXLEVEL=$indexlevel"; +diag "TEST_MANY_ROOT=$many_root"; +my $level_cfg = $indexlevel eq 'full' ? '' : "\tindexlevel = $indexlevel\n"; +my $pfx = "$many_root/$nr_inbox-$indexlevel"; +mkpath($pfx); +open my $cfg_fh, '>>', "$pfx/config" or BAIL_OUT $!; +$cfg_fh->autoflush(1); +my $v2_init_add = sub { + my ($i) = @_; + my $ibx = PublicInbox::Inbox->new({ + inboxdir => "$pfx/test-$i", + name => "test-$i", + newsgroup => "inbox.comp.test.foo.test-$i", + address => [ "test-$i\@example.com" ], + url => [ "//example.com/test-$i" ], + version => 2, + -no_fsync => 1, + }); + $ibx->{indexlevel} = $indexlevel if $level_cfg ne ''; + my $entry = <<EOF; +[publicinbox "$ibx->{name}"] + address = $ibx->{-primary_address} + url = $ibx->{url}->[0] + newsgroup = $ibx->{newsgroup} + inboxdir = $ibx->{inboxdir} +EOF + $entry .= $level_cfg; + print $cfg_fh $entry or die $!; + my $v2w = PublicInbox::V2Writable->new($ibx, { nproc => 0 }); + $v2w->init_inbox(0); + $v2w->add(PublicInbox::Eml->new(<<EOM)); +Date: Sat, 02 Oct 2010 00:00:00 +0000 +From: Lorelei <l\@example.com> +To: test-$i\@example.com +Message-ID: <20101002-000000-$i\@example.com> +Subject: hello world $i + +hi +EOM + $v2w->done; +}; + +my @children; +for my $i (1..$nproc) { + my ($r, $w); + pipe($r, $w) or BAIL_OUT $!; + my $pid = fork // BAIL_OUT "fork: $!"; + if ($pid == 0) { + close $w; + while (my $i = <$r>) { + chomp $i; + $v2_init_add->($i); + } + _exit(0); + } + close $r or BAIL_OUT $!; + push @children, [ $w, $pid ]; + $w->autoflush(1); +} + +for my $i (0..$nr_inbox) { + print { $children[$i % @children]->[0] } "$i\n" or BAIL_OUT $!; +} + +for my $c (@children) { + close $c->[0] or BAIL_OUT "close $!"; +} +my $i = 0; +for my $c (@children) { + my $pid = waitpid($c->[1], 0); + is($?, 0, ++$i.' exited ok'); +} +ok(close($cfg_fh), 'config written'); +done_testing; diff --git a/xt/eml_check_limits.t b/xt/eml_check_limits.t new file mode 100644 index 00000000..1f89c6d4 --- /dev/null +++ b/xt/eml_check_limits.t @@ -0,0 +1,78 @@ +#!perl -w +# Copyright (C) all contributors <meta@public-inbox.org> +# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt> +use strict; +use v5.10.1; +use PublicInbox::TestCommon; +use PublicInbox::Eml; +use PublicInbox::Inbox; +use List::Util qw(max); +use Benchmark qw(:all :hireswallclock); +use Carp (); +require_git(2.19); # for --unordered +require_mods(qw(BSD::Resource)); +BSD::Resource->import(qw(getrusage)); +my $cls = $ENV{TEST_CLASS}; +if ($cls) { + diag "TEST_CLASS=$cls"; + require_mods($cls); +} +$cls //= 'PublicInbox::Eml'; +my $inboxdir = $ENV{GIANT_INBOX_DIR}; +plan skip_all => "GIANT_INBOX_DIR not defined for $0" unless $inboxdir; +local $PublicInbox::Eml::mime_nesting_limit = 0x7fffffff; +local $PublicInbox::Eml::mime_parts_limit = 0x7fffffff; +local $PublicInbox::Eml::header_size_limit = 0x7fffffff; +my $ibx = PublicInbox::Inbox->new({ inboxdir => $inboxdir, name => 'x' }); +my $git = $ibx->git; +my @cat = qw(cat-file --buffer --batch-check --batch-all-objects --unordered); +my $fh = $git->popen(@cat); +my ($m, $n); +my $max_nest = [ 0, '' ]; # [ bytes, blob oid ] +my $max_idx = [ 0, '' ]; +my $max_parts = [ 0, '' ]; +my $max_size = [ 0, '' ]; +my $max_hdr = [ 0, '' ]; +my $info = [ 0, '' ]; +my $each_part_cb = sub { + my ($p) = @_; + my ($part, $depth, $idx) = @$p; + $max_nest = [ $depth, $info->[1] ] if $depth > $max_nest->[0]; + my $max = max(split(/\./, $idx)); + $max_idx = [ $max, $info->[1] ] if $max > $max_idx->[0]; + ++$info->[0]; +}; + +my ($bref, $oid, $size); +local $SIG{__WARN__} = sub { diag "$inboxdir $oid ", @_ }; +my $cat_cb = sub { + ($bref, $oid, undef, $size) = @_; + ++$m; + $info = [ 0, $oid ]; + my $eml = $cls->new($bref); + my $hdr_len = length($eml->header_obj->as_string); + $max_hdr = [ $hdr_len, $oid ] if $hdr_len > $max_hdr->[0]; + $eml->each_part($each_part_cb, $info, 1); + $max_parts = $info if $info->[0] > $max_parts->[0]; + $max_size = [ $size, $oid ] if $size > $max_size->[0]; +}; + +my $t = timeit(1, sub { + my ($blob, $type); + while (<$fh>) { + ($blob, $type) = split / /; + next if $type ne 'blob'; + ++$n; + $git->cat_async($blob, $cat_cb); + } + $git->async_wait_all; +}); +is($m, $n, 'scanned all messages'); +diag "$$ $inboxdir took ".timestr($t)." for $n <=> $m messages"; +diag "$$ max_nest $max_nest->[0] @ $max_nest->[1]"; +diag "$$ max_idx $max_idx->[0] @ $max_idx->[1]"; +diag "$$ max_parts $max_parts->[0] @ $max_parts->[1]"; +diag "$$ max_size $max_size->[0] @ $max_size->[1]"; +diag "$$ max_hdr $max_hdr->[0] @ $max_hdr->[1]"; +diag "$$ RSS ".getrusage()->maxrss. ' k'; +done_testing; diff --git a/xt/eml_octet-stream.t b/xt/eml_octet-stream.t new file mode 100644 index 00000000..3914f089 --- /dev/null +++ b/xt/eml_octet-stream.t @@ -0,0 +1,77 @@ +#!perl -w +# Copyright (C) 2021 all contributors <meta@public-inbox.org> +# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt> +use strict; use v5.10.1; use PublicInbox::TestCommon; +use PublicInbox::Git; +use PublicInbox::Eml; +use PublicInbox::MsgIter qw(msg_part_text); +use PublicInbox::LeiToMail; +my $eml2mboxcl2 = PublicInbox::LeiToMail->can('eml2mboxcl2'); +my $git_dir = $ENV{GIANT_GIT_DIR}; +plan 'skip_all' => "GIANT_GIT_DIR not defined for $0" unless defined($git_dir); +use Data::Dumper; +$Data::Dumper::Useqq = 1; +my $mboxfh; +if (my $out = $ENV{DEBUG_MBOXCL2}) { + BAIL_OUT("$out exists") if -s $out; + open $mboxfh, '>', $out or BAIL_OUT "open $out: $!"; +} else { + diag "DEBUG_MBOXCL2 unset, not saving debug output"; +} + +my $git = PublicInbox::Git->new($git_dir); +my @cat = qw(cat-file --buffer --batch-check --batch-all-objects); +if (require_git(2.19, 1)) { + push @cat, '--unordered'; +} else { + warn "git <2.19, cat-file lacks --unordered, locality suffers\n"; +} +my ($errs, $ok, $tot); +$errs = $ok = $tot = 0; +my $ep = sub { # eml->each_part callback + my ($part, $level, @ex) = @{$_[0]}; + ++$tot; + my $ct = $part->content_type // return; + $ct =~ m!\bapplication/octet-stream\b!i or return; + my ($s, $err) = msg_part_text($part, $ct); + if (defined $s) { + ++$ok; + } else { + warn "binary $err\n"; + ++$errs; + my $x = eval { $part->body }; + if ($@) { + warn "decode totally failed: $@"; + } else { + my ($bad) = ($x =~ m/([\p{XPosixPrint}\s]{0,10} + [^\p{XPosixPrint}\s]+ + [\p{XPosixPrint}\s]{0,10})/sx); + warn Dumper([$bad]); + } + + push @{$_[1]}, $err; # $fail + } +}; + +my $cb = sub { + my ($bref, $oid) = @_; + my $eml = PublicInbox::Eml->new($bref); + local $SIG{__WARN__} = sub { diag("$oid ", @_) }; + $eml->each_part($ep, my $fail = []); + if (@$fail && $mboxfh) { + diag "@$fail"; + print $mboxfh ${$eml2mboxcl2->($eml, { blob => $oid })} or + BAIL_OUT "print: $!"; + } +}; +my $cat = $git->popen(@cat); +while (<$cat>) { + my ($oid, $type, $size) = split(/ /); + $git->cat_async($oid, $cb) if $size && $type eq 'blob'; +} +$git->async_wait_all; +note "$errs errors"; +note "$ok/$tot messages had text as application/octet-stream"; +ok 1; + +done_testing; diff --git a/xt/git-http-backend.t b/xt/git-http-backend.t index f2ae44fe..6c384faf 100644 --- a/xt/git-http-backend.t +++ b/xt/git-http-backend.t @@ -1,43 +1,37 @@ -# Copyright (C) 2016-2020 all contributors <meta@public-inbox.org> +#!perl -w +# Copyright (C) all contributors <meta@public-inbox.org> # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt> # # Ensure buffering behavior in -httpd doesn't cause runaway memory use # or data corruption use strict; -use warnings; -use Test::More; +use v5.10.1; use POSIX qw(setsid); use PublicInbox::TestCommon; -use PublicInbox::Spawn qw(which); my $git_dir = $ENV{GIANT_GIT_DIR}; plan 'skip_all' => 'GIANT_GIT_DIR not defined' unless $git_dir; require_mods(qw(BSD::Resource Plack::Util Plack::Builder - HTTP::Date HTTP::Status Net::HTTP)); + HTTP::Date HTTP::Status HTTP::Tiny)); my $psgi = "./t/git-http-backend.psgi"; my ($tmpdir, $for_destroy) = tmpdir(); my $err = "$tmpdir/stderr.log"; my $out = "$tmpdir/stdout.log"; my $sock = tcp_server(); -my $host = $sock->sockhost; -my $port = $sock->sockport; +my ($host, $port) = tcp_host_port($sock); my $td; +my $http = HTTP::Tiny->new; my $get_maxrss = sub { - my $http = Net::HTTP->new(Host => "$host:$port"); - ok($http, 'Net::HTTP object created for maxrss'); - $http->write_request(GET => '/'); - my ($code, $mess, %h) = $http->read_response_headers; - is($code, 200, 'success reading maxrss'); - my $n = $http->read_entity_body(my $buf, 256); - ok(defined $n, 'read response body'); + my $res = $http->get("http://$host:$port/"); + is($res->{status}, 200, 'success reading maxrss'); + my $buf = $res->{content}; like($buf, qr/\A\d+\n\z/, 'got memory response'); ok(int($buf) > 0, 'got non-zero memory response'); int($buf); }; { - ok($sock, 'sock created'); my $cmd = [ '-httpd', '-W0', "--stdout=$out", "--stderr=$err", $psgi ]; $td = start_script($cmd, undef, { 3 => $sock }); } @@ -55,19 +49,18 @@ SKIP: { } } skip "no packs found in $git_dir" unless defined $pack; - if ($pack !~ m!(/objects/pack/pack-[a-f0-9]{40}.pack)\z!) { + if ($pack !~ m!(/objects/pack/pack-[a-f0-9]{40,64}.pack)\z!) { skip "bad pack name: $pack"; } - my $url = $1; - my $http = Net::HTTP->new(Host => "$host:$port"); - ok($http, 'Net::HTTP object created'); - $http->write_request(GET => $url); - my ($code, $mess, %h) = $http->read_response_headers; - is(200, $code, 'got 200 success for pack'); - is($max, $h{'Content-Length'}, 'got expected Content-Length for pack'); + my $s = tcp_connect($sock); + print $s "GET $1 HTTP/1.1\r\nHost: $host:$port\r\n\r\n" or xbail $!; + my $hdr = do { local $/ = "\r\n\r\n"; readline($s) }; + like $hdr, qr!\AHTTP/1\.1\s+200\b!, 'got 200 success for pack'; + like $hdr, qr/^content-length:\s*$max\r\n/ims, + 'got expected Content-Length for pack'; - # no $http->read_entity_body, here, since we want to force buffering - foreach my $i (1..3) { + # don't read the body + for my $i (1..3) { sleep 1; my $diff = $get_maxrss->() - $mem_a; note "${diff}K memory increase after $i seconds"; @@ -79,17 +72,16 @@ SKIP: { # make sure Last-Modified + If-Modified-Since works with curl my $nr = 6; skip 'no description', $nr unless -f "$git_dir/description"; my $mtime = (stat(_))[9]; - my $curl = which('curl'); - skip 'curl(1) not found', $nr unless $curl; + my $curl = require_cmd('curl', 1) or skip 'curl(1) not found', $nr; my $url = "http://$host:$port/description"; my $dst = "$tmpdir/desc"; - is(system($curl, qw(-RsSf), '-o', $dst, $url), 0, 'curl -R'); + is(xsys($curl, qw(-RsSf), '-o', $dst, $url), 0, 'curl -R'); is((stat($dst))[9], $mtime, 'curl used remote mtime'); - is(system($curl, qw(-sSf), '-z', $dst, '-o', "$dst.2", $url), 0, + is(xsys($curl, qw(-sSf), '-z', $dst, '-o', "$dst.2", $url), 0, 'curl -z noop'); ok(!-e "$dst.2", 'no modification, nothing retrieved'); utime(0, 0, $dst) or die "utime failed: $!"; - is(system($curl, qw(-sSfR), '-z', $dst, '-o', "$dst.2", $url), 0, + is(xsys($curl, qw(-sSfR), '-z', $dst, '-o', "$dst.2", $url), 0, 'curl -z updates'); ok(-e "$dst.2", 'faked modification, got new file retrieved'); } diff --git a/xt/git_async_cmp.t b/xt/git_async_cmp.t index 46d27b26..4038898b 100644 --- a/xt/git_async_cmp.t +++ b/xt/git_async_cmp.t @@ -1,10 +1,10 @@ #!perl -w -# Copyright (C) 2019-2020 all contributors <meta@public-inbox.org> +# Copyright (C) all contributors <meta@public-inbox.org> # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt> use strict; use Test::More; use Benchmark qw(:all); -use Digest::SHA; +use PublicInbox::SHA; use PublicInbox::TestCommon; my $git_dir = $ENV{GIANT_GIT_DIR}; plan 'skip_all' => "GIANT_GIT_DIR not defined for $0" unless defined($git_dir); @@ -18,40 +18,40 @@ if (require_git(2.19, 1)) { } my @dig; my $nr = $ENV{NR} || 1; +diag "NR=$nr"; my $async = timeit($nr, sub { - my $dig = Digest::SHA->new(1); + my $dig = PublicInbox::SHA->new(1); my $cb = sub { my ($bref) = @_; $dig->add($$bref); }; my $cat = $git->popen(@cat); - $git->cat_async_begin; while (<$cat>) { my ($oid, undef, undef) = split(/ /); $git->cat_async($oid, $cb); } - close $cat or die "cat: $?"; - $git->cat_async_wait; + $cat->close or xbail "cat: $?"; + $git->async_wait_all; push @dig, ['async', $dig->hexdigest ]; }); my $sync = timeit($nr, sub { - my $dig = Digest::SHA->new(1); + my $dig = PublicInbox::SHA->new(1); my $cat = $git->popen(@cat); while (<$cat>) { my ($oid, undef, undef) = split(/ /); my $bref = $git->cat_file($oid); $dig->add($$bref); } - close $cat or die "cat: $?"; + $cat->close or xbail "cat: $?"; push @dig, ['sync', $dig->hexdigest ]; }); ok(scalar(@dig) >= 2, 'got some digests'); my $ref = shift @dig; my $exp = $ref->[1]; -isnt($exp, Digest::SHA->new(1)->hexdigest, 'not empty'); +isnt($exp, PublicInbox::SHA->new(1)->hexdigest, 'not empty'); foreach (@dig) { is($_->[1], $exp, "digest matches $_->[0] <=> $ref->[0]"); } diff --git a/xt/httpd-async-stream.t b/xt/httpd-async-stream.t new file mode 100644 index 00000000..21d09331 --- /dev/null +++ b/xt/httpd-async-stream.t @@ -0,0 +1,136 @@ +#!perl -w +# Copyright (C) all contributors <meta@public-inbox.org> +# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt> +# Expensive test to validate compression and TLS. +use v5.12; +use autodie; +use PublicInbox::IO qw(write_file); +use IO::Uncompress::Gunzip qw(gunzip $GunzipError); +use PublicInbox::TestCommon; +use PublicInbox::DS qw(now); +use PublicInbox::Spawn qw(popen_rd); +use Digest::MD5; +use POSIX qw(_exit); +my $inboxdir = $ENV{GIANT_INBOX_DIR}; +plan skip_all => "GIANT_INBOX_DIR not defined for $0" unless $inboxdir; +my $curl = require_cmd('curl'); +my ($tmpdir, $for_destroy) = tmpdir(); +require_mods(qw(DBD::SQLite)); +my $JOBS = $ENV{TEST_JOBS} // 4; +my $endpoint = $ENV{TEST_ENDPOINT} // 'all.mbox.gz'; +my $curl_opt = $ENV{TEST_CURL_OPT} // ''; +diag "TEST_JOBS=$JOBS TEST_ENDPOINT=$endpoint TEST_CURL_OPT=$curl_opt"; + +# we set Host: to ensure stable results across test runs +my @CURL_OPT = (qw(-HHost:example.com -sSf), split(' ', $curl_opt)); + +my $make_local_server = sub { + my ($http) = @_; + my $pi_config = "$tmpdir/config"; + write_file '>', $pi_config, <<""; +[publicinbox "test"] +inboxdir = $inboxdir +address = test\@example.com + + my ($out, $err) = ("$tmpdir/out", "$tmpdir/err"); + for ($out, $err) { open my $fh, '>', $_ } + + # not using multiple workers, here, since we want to increase + # the chance of tripping concurrency bugs within PublicInbox/HTTP*.pm + my $cmd = [ '-httpd', "--stdout=$out", "--stderr=$err", '-W0' ]; + my $host_port = tcp_host_port($http); + push @$cmd, "-lhttp://$host_port"; + my $url = "$host_port/test/$endpoint"; + print STDERR "# CMD ". join(' ', @$cmd). "\n"; + my $env = { PI_CONFIG => $pi_config }; + (start_script($cmd, $env, { 3 => $http }), $url) +}; + +my ($td, $url) = $make_local_server->(my $http = tcp_server()); + +my $s1 = tcp_connect($http); +my $rbuf = do { # pipeline while reading long response + my $req = <<EOM; +GET /test/$endpoint HTTP/1.1\r +Host: example.com\r +\r +EOM + is syswrite($s1, $req), length($req), 'initial long req'; + <$s1>; +}; +like $rbuf, qr!\AHTTP/1\.1 200\b!, 'started reading 200 response'; + +my $do_get_all = sub { + my ($job) = @_; + local $SIG{__DIE__} = sub { print STDERR $job, ': ', @_; _exit(1) }; + my $dig = Digest::MD5->new; + my ($buf, $nr); + my $bytes = 0; + my $t0 = now(); + my $rd = popen_rd([$curl, @CURL_OPT, $url]); + while (1) { + $nr = sysread($rd, $buf, 65536); + last if !$nr; + $dig->add($buf); + $bytes += $nr; + } + my $res = $dig->hexdigest; + my $elapsed = sprintf('%0.3f', now() - $t0); + $rd->close or xbail "close curl failed: $! \$?=$?\n"; + print STDERR "# $job $$ ($?) $res (${elapsed}s) $bytes bytes\n"; + $res; +}; + +my (%pids, %res); +for my $job (1..$JOBS) { + pipe(my $r, my $w); + my $pid = fork; + if ($pid == 0) { + close $r; + my $res = $do_get_all->($job); + print $w $res; + close $w; + _exit(0); + } + close $w; + $pids{$pid} = [ $job, $r ]; +} + +while (scalar keys %pids) { + my $pid = waitpid(-1, 0) or next; + my $child = delete $pids{$pid} or next; + my ($job, $rpipe) = @$child; + is($?, 0, "$job done"); + my $sum = do { local $/; <$rpipe> }; + push @{$res{$sum}}, $job; +} +is(scalar keys %res, 1, 'all got the same result'); +{ + my $req = <<EOM; +GET /test/manifest.js.gz HTTP/1.1\r +Host: example.com\r +Connection: close\r +\r +EOM + is syswrite($s1, $req), length($req), + 'pipeline another request while reading long response'; + diag 'reading remainder of slow response'; + my $res = do { local $/ = "\r\n\r\n"; <$s1> }; + like $res, qr/^Transfer-Encoding: chunked\r\n/sm, 'chunked response'; + { + local $/ = "\r\n"; # get to final chunk + while (defined(my $l = <$s1>)) { last if $l eq "0\r\n" } + }; + is scalar(readline($s1)), "\r\n", 'got final CRLF from 1st response'; + diag "second response:"; + $res = do { local $/ = "\r\n\r\n"; <$s1> }; + like $res, qr!\AHTTP/1\.1 200 !, 'response for pipelined req'; + gunzip($s1 => \my $json) or xbail "gunzip $GunzipError"; + my $m = PublicInbox::Config::json()->decode($json); + like $m->{'/test'}->{fingerprint}, qr/\A[0-9a-f]{40,}\z/, + 'acceptable fingerprint in response'; +} +$td->kill; +$td->join; +is($?, 0, 'no error on -httpd exit'); +done_testing; diff --git a/xt/imapd-mbsync-oimap.t b/xt/imapd-mbsync-oimap.t new file mode 100644 index 00000000..f99779a1 --- /dev/null +++ b/xt/imapd-mbsync-oimap.t @@ -0,0 +1,136 @@ +#!perl -w +# Copyright (C) all contributors <meta@public-inbox.org> +# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt> +# ensure mbsync and offlineimap compatibility +use strict; +use v5.10.1; +use File::Path qw(make_path); +use PublicInbox::TestCommon; +use PublicInbox::Spawn qw(spawn); +require_mods(qw(-imapd)); +my $inboxdir = $ENV{GIANT_INBOX_DIR}; +(defined($inboxdir) && -d $inboxdir) or + plan skip_all => "GIANT_INBOX_DIR not defined for $0"; +plan skip_all => "bad characters in $inboxdir" if $inboxdir =~ m![^\w\.\-/]!; +my ($tmpdir, $for_destroy) = tmpdir(); +my $cfg = "$tmpdir/cfg"; +my $newsgroup = 'inbox.test'; +my $mailbox = "$newsgroup.0"; +{ + open my $fh, '>', $cfg or BAIL_OUT "open: $!"; + print $fh <<EOF or BAIL_OUT "print: $!"; +[publicinbox "test"] + newsgroup = $newsgroup + address = oimap\@example.com + inboxdir = $inboxdir +EOF + close $fh or BAIL_OUT "close: $!"; +} +my ($out, $err) = ("$tmpdir/stdout.log", "$tmpdir/stderr.log"); +my $sock = tcp_server(); +my $cmd = [ '-imapd', '-W0', "--stdout=$out", "--stderr=$err" ]; +my $env = { PI_CONFIG => $cfg }; +my $td = start_script($cmd, $env, { 3 => $sock }) or BAIL_OUT "-imapd: $?"; +{ + my $c = tcp_connect($sock); + like(readline($c), qr/CAPABILITY /, 'got greeting'); +} + +my $host_port = tcp_host_port($sock); +my ($host, $port) = ($sock->sockhost, $sock->sockport); +my %pids; + +SKIP: { + make_path(map { "$tmpdir/oimapdir/$_" } qw(cur new tmp)); + my $oimap = require_cmd('offlineimap', 1) or + skip 'no offlineimap(1)', 1; + open my $fh, '>', "$tmpdir/.offlineimaprc" or BAIL_OUT "open: $!"; + print $fh <<EOF or BAIL_OUT "print: $!"; +[general] +accounts = test +socktimeout = 10 +fsync = false + +[Account test] +localrepository = l.test +remoterepository = r.test + +[Repository l.test] +type = Maildir +localfolders = ~/oimapdir + +[Repository r.test] +type = IMAP +ssl = no +remotehost = $host +remoteport = $port +remoteuser = anonymous +remotepass = Hunter2 + +# python-imaplib2 times out on select/poll when compression is enabled +# <https://bugs.debian.org/961713> +usecompression = no +EOF + close $fh or BAIL_OUT "close: $!"; + my $cmd = [ $oimap, qw(-o -q -u quiet) ]; + my $pid = spawn($cmd, { HOME => $tmpdir }, { 1 => 2 }); + $pids{$pid} = $cmd; +} + +SKIP: { + make_path(map { "$tmpdir/mbsyncdir/test/$_" } qw(cur new tmp)); + my $mbsync = require_cmd('mbsync', 1) or skip 'no mbsync(1)', 1; + open my $fh, '>', "$tmpdir/.mbsyncrc" or BAIL_OUT "open: $!"; + print $fh <<EOF or BAIL_OUT "print: $!"; +Create Slave +SyncState * +Remove None +FSync no + +MaildirStore local +Path ~/mbsyncdir/ +Inbox ~/mbsyncdir/test +SubFolders verbatim + +IMAPStore remote +Host $host +Port $port +User anonymous +Pass Hunter2 +SSLType None +UseNamespace no +# DisableExtension COMPRESS=DEFLATE + +Channel "test" +Master ":remote:INBOX" +Slave ":local:test" +Expunge None +Sync PullNew +Patterns * +EOF + close $fh or BAIL_OUT "close: $!"; + my $cmd = [ $mbsync, qw(-aqq) ]; + my $pid = spawn($cmd, { HOME => $tmpdir }, { 1 => 2 }); + $pids{$pid} = $cmd; +} + +while (scalar keys %pids) { + my $pid = waitpid(-1, 0) or next; + my $cmd = delete $pids{$pid} or next; + is($?, 0, join(' ', @$cmd, 'done')); +} + +my $sec = $ENV{TEST_PERSIST} // 0; +diag "TEST_PERSIST=$sec"; +if ($sec) { + diag "sleeping ${sec}s, imap://$host_port/$mailbox available"; + diag "tmpdir=$tmpdir (Maildirs available)"; + diag "stdout=$out"; + diag "stderr=$err"; + diag "pid=$td->{pid}"; + sleep $sec; +} +$td->kill; +$td->join; +is($?, 0, 'no error on -imapd exit'); +done_testing; diff --git a/xt/imapd-validate.t b/xt/imapd-validate.t new file mode 100644 index 00000000..5d665fa9 --- /dev/null +++ b/xt/imapd-validate.t @@ -0,0 +1,178 @@ +#!perl -w +# Copyright (C) all contributors <meta@public-inbox.org> +# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt> +# Expensive test to validate compression and TLS. +use strict; +use v5.10.1; +use Symbol qw(gensym); +use PublicInbox::DS qw(now); +use PublicInbox::SHA; +use POSIX qw(_exit); +use PublicInbox::TestCommon; +my $inbox_dir = $ENV{GIANT_INBOX_DIR}; +plan skip_all => "GIANT_INBOX_DIR not defined for $0" unless $inbox_dir; +# how many emails to read into memory at once per-process +my $BATCH = $ENV{TEST_BATCH} // 100; +my $REPEAT = $ENV{TEST_REPEAT} // 1; +diag "TEST_BATCH=$BATCH TEST_REPEAT=$REPEAT"; + +require_mods(qw(Mail::IMAPClient -imapd)); +my $imap_client = 'Mail::IMAPClient'; +my $can_compress = $imap_client->can('compress'); +if ($can_compress) { # hope this gets fixed upstream, soon + require PublicInbox::IMAPClient; + $imap_client = 'PublicInbox::IMAPClient'; +} + +my $test_tls = $ENV{TEST_SKIP_TLS} ? 0 : eval { require IO::Socket::SSL }; +my ($cert, $key) = qw(certs/server-cert.pem certs/server-key.pem); +if ($test_tls && !-r $key || !-r $cert) { + plan skip_all => + "certs/ missing for $0, run $^X ./certs/create-certs.perl"; +} +my ($tmpdir, $for_destroy) = tmpdir(); +my %OPT = qw(User u Password p); +my (%STARTTLS_OPT, %IMAPS_OPT, $td, $newsgroup, $mailbox, $make_local_server); +if (($ENV{IMAP_TEST_URL} // '') =~ m!\Aimap://([^/]+)/(.+)\z!) { + ($OPT{Server}, $mailbox) = ($1, $2); + $OPT{Server} =~ s/:([0-9]+)\z// and $OPT{Port} = $1 + 0; + %STARTTLS_OPT = %OPT; + %IMAPS_OPT = (%OPT, Port => 993) if $OPT{Port} == 143; +} else { + require_mods(qw(DBD::SQLite)); + $make_local_server->(); + $mailbox = "$newsgroup.0"; +} + +my %opts = (imap => \%OPT, 'imap+compress' => { %OPT, Compress => 1 }); +my $uid_max = do { + my $mic = $imap_client->new(%OPT) or BAIL_OUT "new $!"; + $mic->examine($mailbox) or BAIL_OUT "examine: $!"; + my $next = $mic->uidnext($mailbox) or BAIL_OUT "uidnext: $!"; + $next - 1; +}; + +if (scalar keys %STARTTLS_OPT) { + $opts{starttls} = \%STARTTLS_OPT; + $opts{'starttls+compress'} = { %STARTTLS_OPT, Compress => 1 }; +} +if (scalar keys %IMAPS_OPT) { + $opts{imaps} = \%IMAPS_OPT; + $opts{'imaps+compress'} = { %IMAPS_OPT, Compress => 1 }; +} + +my $do_get_all = sub { + my ($desc, $opt) = @_; + local $SIG{__DIE__} = sub { print STDERR $desc, ': ', @_; _exit(1) }; + my $t0 = now(); + my $dig = PublicInbox::SHA->new(1); + my $mic = $imap_client->new(%$opt); + $mic->examine($mailbox) or die "examine: $!"; + my $uid_base = 1; + my $bytes = 0; + my $nr = 0; + until ($uid_base > $uid_max) { + my $end = $uid_base + $BATCH; + my $ret = $mic->fetch_hash("$uid_base:$end", 'BODY[]') or last; + for my $uid ($uid_base..$end) { + $dig->add($uid); + my $h = delete $ret->{$uid} or next; + my $body = delete $h->{'BODY[]'} or + die "no BODY[] for UID=$uid"; + $dig->add($body); + $bytes += length($body); + ++$nr; + } + $uid_base = $end + 1; + } + $mic->logout or die "logout failed: $!"; + my $elapsed = sprintf('%0.3f', now() - $t0); + my $res = $dig->hexdigest; + print STDERR "# $desc $res (${elapsed}s) $bytes bytes, NR=$nr\n"; + $res; +}; + +my (%pids, %res); +for (1..$REPEAT) { + while (my ($desc, $opt) = each %opts) { + pipe(my ($r, $w)) or die; + my $pid = fork; + if ($pid == 0) { + close $r or die; + my $res = $do_get_all->($desc, $opt); + print $w $res or die; + close $w or die; + _exit(0); + } + close $w or die; + $pids{$pid} = [ $desc, $r ]; + } +} + +while (scalar keys %pids) { + my $pid = waitpid(-1, 0) or next; + my $child = delete $pids{$pid} or next; + my ($desc, $rpipe) = @$child; + is($?, 0, "$desc done"); + my $sum = do { local $/; <$rpipe> }; + push @{$res{$sum}}, $desc; +} +is(scalar keys %res, 1, 'all got the same result'); +$td->kill; +$td->join; +is($?, 0, 'no error on -imapd exit'); +done_testing; + +BEGIN { + +$make_local_server = sub { + require PublicInbox::Inbox; + $newsgroup = 'inbox.test'; + my $ibx = { inboxdir => $inbox_dir, newsgroup => $newsgroup }; + $ibx = PublicInbox::Inbox->new($ibx); + my $pi_config = "$tmpdir/config"; + { + open my $fh, '>', $pi_config or die "open($pi_config): $!"; + print $fh <<"" or die "print $pi_config: $!"; +[publicinbox "test"] + newsgroup = $newsgroup + inboxdir = $inbox_dir + address = test\@example.com + + close $fh or die "close($pi_config): $!"; + } + my ($out, $err) = ("$tmpdir/out", "$tmpdir/err"); + for ($out, $err) { + open my $fh, '>', $_ or die "truncate: $!"; + } + my $imap = tcp_server(); + my $rdr = { 3 => $imap }; + $OPT{Server} = $imap->sockhost; + $OPT{Port} = $imap->sockport; + + # not using multiple workers, here, since we want to increase + # the chance of tripping concurrency bugs within PublicInbox/IMAP*.pm + my $cmd = [ '-imapd', "--stdout=$out", "--stderr=$err", '-W0' ]; + push @$cmd, '-limap://'.tcp_host_port($imap); + if ($test_tls) { + my $imaps = tcp_server(); + $rdr->{4} = $imaps; + push @$cmd, '-limaps://'.tcp_host_port($imaps); + push @$cmd, "--cert=$cert", "--key=$key"; + my $tls_opt = [ + SSL_hostname => 'server.local', + SSL_verifycn_name => 'server.local', + SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_PEER(), + SSL_ca_file => 'certs/test-ca.pem', + ]; + %STARTTLS_OPT = (%OPT, Starttls => $tls_opt); + %IMAPS_OPT = (%OPT, Ssl => $tls_opt, + Server => $imaps->sockhost, + Port => $imaps->sockport + ); + } + print STDERR "# CMD ". join(' ', @$cmd). "\n"; + my $env = { PI_CONFIG => $pi_config }; + $td = start_script($cmd, $env, $rdr); +}; +} # BEGIN diff --git a/xt/lei-auth-fail.t b/xt/lei-auth-fail.t new file mode 100644 index 00000000..1ccc2ab2 --- /dev/null +++ b/xt/lei-auth-fail.t @@ -0,0 +1,24 @@ +#!perl -w +# Copyright (C) all contributors <meta@public-inbox.org> +# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt> +use v5.12; +use PublicInbox::TestCommon; +require_mods(qw(Mail::IMAPClient lei)); + +# TODO: mock IMAP server which fails at authentication so we don't +# have to make external connections to test this: +my $imap_fail = $ENV{TEST_LEI_IMAP_FAIL_URL} // + 'imaps://AzureDiamond:Hunter2@public-inbox.org:994/INBOX'; +my ($ro_home, $cfg_path) = setup_public_inboxes; +test_lei(sub { + for my $pfx ([qw(q z:0.. --only), "$ro_home/t1", '-o'], + [qw(convert -o mboxrd:/dev/stdout)], + [qw(convert t/utf8.eml -o), $imap_fail], + ['import'], [qw(tag +L:inbox)]) { + ok(!lei(@$pfx, $imap_fail), "IMAP auth failure on @$pfx"); + like($lei_err, qr!\bE:.*?imaps?://.*?!sm, 'error shown'); + unlike($lei_err, qr!Hunter2!s, 'password not shown'); + is($lei_out, '', 'nothing output'); + } +}); +done_testing; diff --git a/xt/lei-onion-convert.t b/xt/lei-onion-convert.t new file mode 100644 index 00000000..d3afbbb9 --- /dev/null +++ b/xt/lei-onion-convert.t @@ -0,0 +1,77 @@ +#!perl -w +# Copyright (C) all contributors <meta@public-inbox.org> +# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt> +use v5.12; use PublicInbox::TestCommon; +use PublicInbox::MboxReader; +use autodie qw(pipe close); +my $test_tor = $ENV{TEST_TOR}; +plan skip_all => "TEST_TOR unset" unless $test_tor; +require_mods qw(IO::Socket::Socks IO::Socket::SSL Mail::IMAPClient Net::NNTP); +unless ($test_tor =~ m!\Asocks5h://!i) { + my $default = 'socks5h://127.0.0.1:9050'; + diag "using $default (set TEST_TOR=socks5h://ADDR:PORT to override)"; + $test_tor = $default; +} +my $onion = $ENV{TEST_ONION_HOST} // + '7fh6tueqddpjyxjmgtdiueylzoqt6pt7hec3pukyptlmohoowvhde4yd.onion'; +my $ng = 'inbox.comp.mail.public-inbox.meta'; +my $nntp_url = $ENV{TEST_NNTP_ONION_URL} // "nntp://$onion/$ng"; +my $imap_url = $ENV{TEST_IMAP_ONION_URL} // "imap://$onion/$ng.0"; +my @cnv = qw(lei convert -o mboxrd:/dev/stdout); +my @proxy_cli = ("--proxy=$test_tor"); +my $proxy_cfg = "proxy=$test_tor"; +test_lei(sub { + # ensure TLS + SOCKS works + ok !lei(qw(ls-mail-source imaps://mews.public-inbox.org/ + -c), "imap.$proxy_cfg"), + 'imaps fails on wrong hostname w/ Tor'; + ok !lei(qw(ls-mail-source nntps://mews.public-inbox.org/ + -c), "nntp.$proxy_cfg"), + 'nntps fails on wrong hostname w/ Tor'; + + lei_ok qw(ls-mail-source imaps://news.public-inbox.org/ + -c), "imap.$proxy_cfg"; + lei_ok qw(ls-mail-source nntps://news.public-inbox.org/ + -c), "nntp.$proxy_cfg"; + + my $run = {}; + for my $args ([$nntp_url, @proxy_cli], [$imap_url, @proxy_cli], + [ $nntp_url, '-c', "nntp.$proxy_cfg" ], + [ $imap_url, '-c', "imap.$proxy_cfg" ]) { + pipe(my $r, my $w); + my $cmd = [@cnv, @$args]; + my $td = start_script($cmd, undef, { 1 => $w, run_mode => 0 }); + $args->[0] =~ s!\A(.+?://).*!$1...!; + my $key = "@$args"; + ok($td, "$key running"); + $run->{$key} = { td => $td, r => $r }; + } + while (my ($key, $x) = each %$run) { + my ($td, $r) = delete(@$x{qw(td r)}); + eval { + PublicInbox::MboxReader->mboxrd($r, sub { + my ($eml) = @_; + if ($key =~ m!\Anntps?://!i) { + for (qw(Xref Newsgroups Path)) { + $eml->header_set($_); + } + } + push @{$x->{eml}}, $eml; + close $r; + $td->kill('-INT'); + die "$key done\n"; + }); + }; + chomp(my $done = $@); + like($done, qr/\Q$key\E done/, $done); + $td->join; + } + my @keys = keys %$run; + my $first_key = shift @keys; + for my $key (@keys) { + is_deeply($run->{$key}, $run->{$first_key}, + "`$key' matches `$first_key'"); + } +}); + +done_testing; diff --git a/xt/mem-imapd-tls.t b/xt/mem-imapd-tls.t new file mode 100644 index 00000000..53adb11b --- /dev/null +++ b/xt/mem-imapd-tls.t @@ -0,0 +1,241 @@ +#!perl -w +# Copyright (C) all contributors <meta@public-inbox.org> +# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt> +# Idle client memory usage test, particularly after EXAMINE when +# Message Sequence Numbers are loaded +use strict; +use v5.10.1; +use Socket qw(SOCK_STREAM IPPROTO_TCP SOL_SOCKET); +use PublicInbox::Spawn qw(which); +use PublicInbox::TestCommon; +use PublicInbox::DS; +require_mods(qw(-imapd)); +my $inboxdir = $ENV{GIANT_INBOX_DIR}; +my $TEST_TLS; +SKIP: { + require_mods('IO::Socket::SSL', 1); + $TEST_TLS = $ENV{TEST_TLS} // 1; +}; +plan skip_all => "GIANT_INBOX_DIR not defined for $0" unless $inboxdir; +diag 'TEST_COMPRESS='.($ENV{TEST_COMPRESS} // 1) . " TEST_TLS=$TEST_TLS"; + +my ($cert, $key) = qw(certs/server-cert.pem certs/server-key.pem); +if ($TEST_TLS) { + if (!-r $key || !-r $cert) { + plan skip_all => + "certs/ missing for $0, run ./certs/create-certs.perl"; + } + use_ok 'PublicInbox::TLS'; +} +my ($tmpdir, $for_destroy) = tmpdir(); +my ($out, $err) = ("$tmpdir/stdout.log", "$tmpdir/stderr.log"); +my $pi_config = "$tmpdir/pi_config"; +my $group = 'inbox.test'; +local $SIG{PIPE} = 'IGNORE'; # for IMAPC (below) +my $imaps = tcp_server(); +{ + open my $fh, '>', $pi_config or die "open: $!\n"; + print $fh <<EOF or die; +[publicinbox "imapd-tls"] + inboxdir = $inboxdir + address = $group\@example.com + newsgroup = $group + indexlevel = basic +EOF + close $fh or die "close: $!\n"; +} +my $imaps_addr = tcp_host_port($imaps); +my $env = { PI_CONFIG => $pi_config }; +my $arg = $TEST_TLS ? [ "-limaps://$imaps_addr/?cert=$cert,key=$key" ] : []; +my $cmd = [ '-imapd', '-W0', @$arg, "--stdout=$out", "--stderr=$err" ]; + +# run_mode=0 ensures Test::More FDs don't get shared +my $td = start_script($cmd, $env, { 3 => $imaps, run_mode => 0 }); +my %ssl_opt; +if ($TEST_TLS) { + %ssl_opt = ( + SSL_hostname => 'server.local', + SSL_verifycn_name => 'server.local', + SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_PEER(), + SSL_ca_file => 'certs/test-ca.pem', + ); + my $ctx = IO::Socket::SSL::SSL_Context->new(%ssl_opt); + + # cf. https://rt.cpan.org/Ticket/Display.html?id=129463 + my $mode = eval { Net::SSLeay::MODE_RELEASE_BUFFERS() }; + if ($mode && $ctx->{context}) { + eval { Net::SSLeay::CTX_set_mode($ctx->{context}, $mode) }; + warn "W: $@ (setting SSL_MODE_RELEASE_BUFFERS)\n" if $@; + } + + $ssl_opt{SSL_reuse_ctx} = $ctx; + $ssl_opt{SSL_startHandshake} = 0; +} +chomp(my $nfd = `/bin/sh -c 'ulimit -n'`); +$nfd -= 20; +ok($nfd > 0, 'positive FD count'); +my $MAX_FD = 10000; +$nfd = $MAX_FD if $nfd >= $MAX_FD; +our $DONE = 0; +sub once { 0 }; # stops event loop + +# setup the event loop so that it exits at every step +# while we're still doing connect(2) +$PublicInbox::DS::loop_timeout = 0; +local @PublicInbox::DS::post_loop_do = (\&once); +my $pid = $td->{pid}; +if ($^O eq 'linux' && open(my $f, '<', "/proc/$pid/status")) { + diag(grep(/RssAnon/, <$f>)); +} + +foreach my $n (1..$nfd) { + my $io = tcp_connect($imaps, Blocking => 0); + $io = IO::Socket::SSL->start_SSL($io, %ssl_opt) if $TEST_TLS; + IMAPC->new($io); + + # one step through the event loop + # do a little work as we connect: + PublicInbox::DS::event_loop(); + + # try not to overflow the listen() backlog: + if (!($n % 128) && $DONE != $n) { + diag("nr: ($n) $DONE/$nfd"); + $PublicInbox::DS::loop_timeout = -1; + local @PublicInbox::DS::post_loop_do = (sub { $DONE != $n }); + + # clear the backlog: + PublicInbox::DS::event_loop(); + + # resume looping + $PublicInbox::DS::loop_timeout = 0; + } +} + +# run the event loop normally, now: +diag "done?: @".time." $DONE/$nfd"; +if ($DONE != $nfd) { + $PublicInbox::DS::loop_timeout = -1; + local @PublicInbox::DS::post_loop_do = (sub { $DONE != $nfd }); + PublicInbox::DS::event_loop(); +} +is($nfd, $DONE, "$nfd/$DONE done"); +my $lsof = which('lsof'); +if ($^O eq 'linux' && $lsof && open(my $f, '<', "/proc/$pid/status")) { + diag(grep(/RssAnon/, <$f>)); + diag " SELF lsof | wc -l ".`$lsof -p $$ |wc -l`; + diag "SERVER lsof | wc -l ".`$lsof -p $pid |wc -l`; +} +PublicInbox::DS->Reset; +$td->kill; +$td->join; +is($?, 0, 'no error in exited process'); +done_testing; + +package IMAPC; +use strict; +use parent qw(PublicInbox::DS); +# fields: step: state machine, zin: Zlib inflate context +use PublicInbox::Syscall qw(EPOLLOUT EPOLLONESHOT); +use Errno qw(EAGAIN); +# determines where we start event_step +use constant FIRST_STEP => ($ENV{TEST_COMPRESS} // 1) ? -2 : 0; + +# return true if complete, false if incomplete (or failure) +sub connect_tls_step { + my ($self) = @_; + my $sock = $self->{sock} or return; + return 1 if $sock->connect_SSL; + return $self->drop("$!") if $! != EAGAIN; + if (my $ev = PublicInbox::TLS::epollbit()) { + unshift @{$self->{wbuf}}, \&connect_tls_step; + PublicInbox::DS::epwait($sock, $ev | EPOLLONESHOT); + 0; + } else { + $self->drop('BUG? EAGAIN but '.PublicInbox::TLS::err()); + } +} + +sub event_step { + my ($self) = @_; + + # TLS negotiation happens in flush_write via {wbuf} + return unless $self->flush_write && $self->{sock}; + + if ($self->{step} == -2) { + $self->do_read(\(my $buf = ''), 128) or return; + $buf =~ /\A\* OK / or die 'no greeting'; + $self->{step} = -1; + $self->write(\"1 COMPRESS DEFLATE\r\n"); + } + if ($self->{step} == -1) { + $self->do_read(\(my $buf = ''), 128) or return; + $buf =~ /\A1 OK / or die "no compression $buf"; + IMAPCdeflate->enable($self); + $self->{step} = 1; + $self->write(\"2 EXAMINE inbox.test.0\r\n"); + } + if ($self->{step} == 0) { + $self->do_read(\(my $buf = ''), 128) or return; + $buf =~ /\A\* OK / or die 'no greeting'; + $self->{step} = 1; + $self->write(\"2 EXAMINE inbox.test.0\r\n"); + } + if ($self->{step} == 1) { + my $buf = ''; + until ($buf =~ /^2 OK \[READ-ONLY/ms) { + $self->do_read(\$buf, 4096, length($buf)) or return; + } + $self->{step} = 2; + $self->write(\"3 UID FETCH 1 (UID FLAGS)\r\n"); + } + if ($self->{step} == 2) { + my $buf = ''; + until ($buf =~ /^3 OK /ms) { + $self->do_read(\$buf, 4096, length($buf)) or return; + } + $self->{step} = 3; + $self->write(\"4 IDLE\r\n"); + } + if ($self->{step} == 3) { + $self->do_read(\(my $buf = ''), 128) or return; + no warnings 'once'; + $::DONE++; + $self->{step} = 5; # all done + } else { + warn "$self->{step} Should never get here $self"; + } +} + +sub new { + my ($class, $io) = @_; + my $self = bless { step => FIRST_STEP }, $class; + if ($io->can('connect_SSL')) { + $self->{wbuf} = [ \&connect_tls_step ]; + } + # wait for connect(), and maybe SSL_connect() + $self->SUPER::new($io, EPOLLOUT|EPOLLONESHOT); +} + +1; +package IMAPCdeflate; +use strict; +our @ISA; +use Compress::Raw::Zlib; +use PublicInbox::IMAP; +my %ZIN_OPT; +BEGIN { + @ISA = qw(IMAPC); + %ZIN_OPT = ( -WindowBits => -15, -AppendOutput => 1 ); + *write = \&PublicInbox::DSdeflate::write; + *do_read = \&PublicInbox::DSdeflate::do_read; +}; + +sub enable { + my ($class, $self) = @_; + my ($in, $err) = Compress::Raw::Zlib::Inflate->new(%ZIN_OPT); + die "Inflate->new failed: $err" if $err != Z_OK; + bless $self, $class; + $self->{zin} = $in; +} + +1; diff --git a/xt/mem-msgview.t b/xt/mem-msgview.t index bffb1768..dceb24b2 100644 --- a/xt/mem-msgview.t +++ b/xt/mem-msgview.t @@ -1,5 +1,5 @@ #!perl -w -# Copyright (C) 2020 all contributors <meta@public-inbox.org> +# Copyright (C) 2020-2021 all contributors <meta@public-inbox.org> # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt> # Note: this may be altered as-needed to demonstrate improvements. # See history in git for this file. @@ -13,6 +13,7 @@ my @mods = qw(DBD::SQLite BSD::Resource PublicInbox::WWW); require_mods(@mods); use_ok($_) for @mods; my $lines = $ENV{NR_LINES} // 50000; +diag "NR_LINES=$lines"; my ($tmpdir, $for_destroy) = tmpdir(); my $inboxname = 'big'; my $inboxdir = "$tmpdir/big"; diff --git a/xt/mem-nntpd-tls.t b/xt/mem-nntpd-tls.t new file mode 100644 index 00000000..ec639a8b --- /dev/null +++ b/xt/mem-nntpd-tls.t @@ -0,0 +1,254 @@ +#!perl -w +# Copyright (C) all contributors <meta@public-inbox.org> +# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt> +# Idle client memory usage test +use v5.12.1; +use PublicInbox::TestCommon; +use File::Temp qw(tempdir); +use Socket qw(SOCK_STREAM IPPROTO_TCP SOL_SOCKET); +require_mods(qw(-nntpd)); +require PublicInbox::InboxWritable; +require PublicInbox::SearchIdx; +use PublicInbox::Syscall; +use PublicInbox::DS; +my $version = 2; # v2 needs newer git +require_git('2.6') if $version >= 2; +use_ok 'IO::Socket::SSL'; +my ($cert, $key) = qw(certs/server-cert.pem certs/server-key.pem); +unless (-r $key && -r $cert) { + plan skip_all => + "certs/ missing for $0, run ./certs/create-certs.perl"; +} +use_ok 'PublicInbox::TLS'; +my ($tmpdir, $for_destroy) = tmpdir(); +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'; +local $SIG{PIPE} = 'IGNORE'; # for NNTPC (below) +my $nntps = tcp_server(); +my $ibx = PublicInbox::Inbox->new({ + inboxdir => $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 <<EOF +[publicinbox "nntpd-tls"] + mainrepo = $mainrepo + address = $addr + indexlevel = basic + newsgroup = $group +EOF + ; + close $fh or die "close: $!\n"; +} + +{ + my $im = $ibx->importer(0); + my $eml = eml_load('t/data/0001.patch'); + ok($im->add($eml), 'message added'); + $im->done; + if ($version == 1) { + my $s = PublicInbox::SearchIdx->new($ibx, 1); + $s->index_sync; + } +} + +my $nntps_addr = tcp_host_port($nntps); +my $env = { PI_CONFIG => $pi_config }; +my $tls = $ENV{TLS} // 1; +my $args = $tls ? ["--cert=$cert", "--key=$key", "-lnntps://$nntps_addr"] : []; +my $cmd = [ '-nntpd', '-W0', @$args, "--stdout=$out", "--stderr=$err" ]; + +# run_mode=0 ensures Test::More FDs don't get shared +my $td = start_script($cmd, $env, { 3 => $nntps, run_mode => 0 }); +my %ssl_opt = ( + SSL_hostname => 'server.local', + SSL_verifycn_name => 'server.local', + SSL_verify_mode => SSL_VERIFY_PEER(), + SSL_ca_file => 'certs/test-ca.pem', +); +my $ctx = IO::Socket::SSL::SSL_Context->new(%ssl_opt); + +# cf. https://rt.cpan.org/Ticket/Display.html?id=129463 +my $mode = eval { Net::SSLeay::MODE_RELEASE_BUFFERS() }; +if ($mode && $ctx->{context}) { + eval { Net::SSLeay::CTX_set_mode($ctx->{context}, $mode) }; + warn "W: $@ (setting SSL_MODE_RELEASE_BUFFERS)\n" if $@; +} + +$ssl_opt{SSL_reuse_ctx} = $ctx; +$ssl_opt{SSL_startHandshake} = 0; + +my %opt = ( + Proto => 'tcp', + PeerAddr => $nntps_addr, + Type => SOCK_STREAM, + Blocking => 0 +); +chomp(my $nfd = `/bin/sh -c 'ulimit -n'`); +$nfd -= 10; +ok($nfd > 0, 'positive FD count'); +my $MAX_FD = 10000; +$nfd = $MAX_FD if $nfd >= $MAX_FD; +our $DONE = 0; +sub once { 0 }; # stops event loop + +# setup the event loop so that it exits at every step +# while we're still doing connect(2) +$PublicInbox::DS::loop_timeout = 0; +local @PublicInbox::DS::post_loop_do = (\&once); + +foreach my $n (1..$nfd) { + my $io = tcp_connect($nntps, Blocking => 0); + $io = IO::Socket::SSL->start_SSL($io, %ssl_opt) if $tls; + NNTPC->new($io); + + # one step through the event loop + # do a little work as we connect: + PublicInbox::DS::event_loop(); + + # try not to overflow the listen() backlog: + if (!($n % 128) && $n != $DONE) { + diag("nr: ($n) $DONE/$nfd"); + $PublicInbox::DS::loop_timeout = -1; + @PublicInbox::DS::post_loop_do = (sub { $DONE != $n }); + + # clear the backlog: + PublicInbox::DS::event_loop(); + + # resume looping + $PublicInbox::DS::loop_timeout = 0; + @PublicInbox::DS::post_loop_do = (\&once); + } +} +my $pid = $td->{pid}; +my $dump_rss = sub { + return if $^O ne 'linux'; + open(my $f, '<', "/proc/$pid/status") or return; + diag(grep(/RssAnon/, <$f>)); +}; +$dump_rss->(); + +# run the event loop normally, now: +if ($DONE != $nfd) { + $PublicInbox::DS::loop_timeout = -1; + @PublicInbox::DS::post_loop_do = (sub { + diag "done: ".time." $DONE"; + $DONE != $nfd; + }); + PublicInbox::DS::event_loop(); +} + +is($nfd, $DONE, 'done'); +$dump_rss->(); +if ($^O eq 'linux') { + diag " SELF lsof | wc -l ".`lsof -p $$ |wc -l`; + diag "SERVER lsof | wc -l ".`lsof -p $pid |wc -l`; +} +PublicInbox::DS->Reset; +$td->kill; +$td->join; +is($?, 0, 'no error in exited process'); +done_testing(); + +package NNTPC; +use v5.12; +use parent qw(PublicInbox::DS); +use PublicInbox::Syscall qw(EPOLLOUT EPOLLONESHOT); +use Data::Dumper; + +# return true if complete, false if incomplete (or failure) +sub connect_tls_step ($) { + my ($self) = @_; + my $sock = $self->{sock} or return; + return 1 if $sock->connect_SSL; + return $self->drop("$!") unless $!{EAGAIN}; + if (my $ev = PublicInbox::TLS::epollbit()) { + unshift @{$self->{wbuf}}, \&connect_tls_step; + PublicInbox::DS::epwait($self->{sock}, $ev | EPOLLONESHOT); + 0; + } else { + $self->drop('BUG? EAGAIN but '.PublicInbox::TLS::err()); + } +} + +sub event_step ($) { + my ($self) = @_; + + # TLS negotiation happens in flush_write via {wbuf} + return unless $self->flush_write && $self->{sock}; + + if ($self->{step} == -2) { + $self->do_read(\(my $buf = ''), 128) or return; + $buf =~ /\A201 / or die "no greeting"; + $self->{step} = -1; + $self->write(\"COMPRESS DEFLATE\r\n"); + } + if ($self->{step} == -1) { + $self->do_read(\(my $buf = ''), 128) or return; + $buf =~ /\A20[0-9] / or die "no compression $buf"; + NNTPCdeflate->enable($self); + $self->{step} = 1; + $self->write(\"DATE\r\n"); + } + if ($self->{step} == 0) { + $self->do_read(\(my $buf = ''), 128) or return; + $buf =~ /\A201 / or die "no greeting"; + $self->{step} = 1; + $self->write(\"DATE\r\n"); + } + if ($self->{step} == 1) { + $self->do_read(\(my $buf = ''), 128) or return; + $buf =~ /\A111 / or die 'no date'; + no warnings 'once'; + $::DONE++; + $self->{step} = 2; # all done + } else { + die "$self->{step} Should never get here ". Dumper($self); + } +} + +sub new { + my ($class, $io) = @_; + my $self = bless {}, $class; + + # wait for connect(), and maybe SSL_connect() + $self->SUPER::new($io, EPOLLOUT|EPOLLONESHOT); + $self->{wbuf} = [ \&connect_tls_step ] if $io->can('connect_SSL'); + $self->{step} = -2; # determines where we start event_step + $self; +}; + +1; +package NNTPCdeflate; +use v5.12; +our @ISA = qw(NNTPC PublicInbox::DS); +use Compress::Raw::Zlib; +use PublicInbox::DSdeflate; +BEGIN { + *write = \&PublicInbox::DSdeflate::write; + *do_read = \&PublicInbox::DSdeflate::do_read; + *event_step = \&NNTPC::event_step; + *flush_write = \&PublicInbox::DS::flush_write; + *close = \&PublicInbox::DS::close; +} + +sub enable { + my ($class, $self) = @_; + my %ZIN_OPT = ( -WindowBits => -15, -AppendOutput => 1 ); + my ($in, $err) = Compress::Raw::Zlib::Inflate->new(%ZIN_OPT); + die "Inflate->new failed: $err" if $err != Z_OK; + bless $self, $class; + $self->{zin} = $in; +} + +1; diff --git a/xt/msgtime_cmp.t b/xt/msgtime_cmp.t index b77e57a6..c63f785e 100644 --- a/xt/msgtime_cmp.t +++ b/xt/msgtime_cmp.t @@ -1,10 +1,10 @@ #!perl -w -# Copyright (C) 2019-2020 all contributors <meta@public-inbox.org> +# Copyright (C) 2019-2021 all contributors <meta@public-inbox.org> # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt> use strict; use Test::More; use PublicInbox::TestCommon; -use PublicInbox::MIME; +use PublicInbox::Eml; use PublicInbox::Inbox; use PublicInbox::Git; use PublicInbox::MsgTime qw(msg_timestamp msg_datestamp); @@ -36,7 +36,7 @@ sub quiet_is_deeply ($$$$$) { ($old->[0] != $cur->[0]) || ($old->[1] != $cur->[1]))) { for ($cur, $old) { - $_->[2] = strftime('%Y-%m-%d %k:%M:%S', gmtime($_->[0])) + $_->[2] = strftime('%F %T', gmtime($_->[0])) } is_deeply($cur, $old, "$func $oid"); diag('got: ', explain($cur)); @@ -48,7 +48,7 @@ sub quiet_is_deeply ($$$$$) { sub compare { my ($bref, $oid, $type, $size) = @_; local $SIG{__WARN__} = sub { diag "$oid: ", @_ }; - my $mime = PublicInbox::MIME->new($$bref); + my $mime = PublicInbox::Eml->new($$bref); my $hdr = $mime->header_obj; my @cur = msg_datestamp($hdr); my @old = Old::msg_datestamp($hdr); @@ -59,13 +59,12 @@ sub compare { } my $fh = $git->popen(@cat); -$git->cat_async_begin; while (<$fh>) { my ($oid, $type) = split / /; next if $type ne 'blob'; - $git->cat_async($oid, *compare); + $git->cat_async($oid, \&compare); } -$git->cat_async_wait; +$git->async_wait_all; ok(1); done_testing; @@ -82,6 +81,13 @@ sub str2date_zone ($) { # off is the time zone offset in seconds from GMT my ($ss,$mm,$hh,$day,$month,$year,$off) = Date::Parse::strptime($date); + + # new behavior which wasn't in the original old version: + if ('commit d857e7dc0d816b635a7ead09c3273f8c2d2434be') { + # "msgtime: assume +0000 if TZ missing when using Date::Parse" + $off //= '+0000'; + } + return undef unless(defined $off); # Compute the time zone from offset @@ -109,7 +115,7 @@ sub time_response ($) { } sub msg_received_at ($) { - my ($hdr) = @_; # Email::MIME::Header + my ($hdr) = @_; # PublicInbox::Eml my @recvd = $hdr->header_raw('Received'); my ($ts); foreach my $r (@recvd) { @@ -124,7 +130,7 @@ sub msg_received_at ($) { } sub msg_date_only ($) { - my ($hdr) = @_; # Email::MIME::Header + my ($hdr) = @_; # PublicInbox::Eml my @date = $hdr->header_raw('Date'); my ($ts); foreach my $d (@date) { @@ -142,7 +148,7 @@ sub msg_date_only ($) { # Favors Received header for sorting globally sub msg_timestamp ($) { - my ($hdr) = @_; # Email::MIME::Header + my ($hdr) = @_; # PublicInbox::Eml my $ret; $ret = msg_received_at($hdr) and return time_response($ret); $ret = msg_date_only($hdr) and return time_response($ret); @@ -151,7 +157,7 @@ sub msg_timestamp ($) { # Favors the Date: header for display and sorting within a thread sub msg_datestamp ($) { - my ($hdr) = @_; # Email::MIME::Header + my ($hdr) = @_; # PublicInbox::Eml my $ret; $ret = msg_date_only($hdr) and return time_response($ret); $ret = msg_received_at($hdr) and return time_response($ret); diff --git a/xt/net_nntp_socks.t b/xt/net_nntp_socks.t new file mode 100644 index 00000000..41b60811 --- /dev/null +++ b/xt/net_nntp_socks.t @@ -0,0 +1,22 @@ +#!perl -w +# Copyright (C) 2021 all contributors <meta@public-inbox.org> +# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt> +use v5.12; +use PublicInbox::TestCommon; +use URI; +require_mods 'IO::Socket::Socks'; +use_ok 'PublicInbox::NetNNTPSocks'; +my $url = $ENV{TEST_NNTP_ONION_URL} // + 'nntp://ie5yzdi7fg72h7s4sdcztq5evakq23rdt33mfyfcddc5u3ndnw24ogqd.onion/inbox.comp.mail.public-inbox.meta'; +my $uri = URI->new($url); +my $on = PublicInbox::NetNNTPSocks->new_socks( + Port => $uri->port, + Host => $uri->host, + ProxyAddr => '127.0.0.1', # default Tor address + port + ProxyPort => 9050, +) or xbail('err = '.eval('$IO::Socket::Socks::SOCKS_ERROR')); +my ($nr, $min, $max, $grp) = $on->group($uri->group); +ok($nr > 0 && $min > 0 && $min < $max, 'nr, min, max make sense') or + diag explain([$nr, $min, $max, $grp]); +is($grp, $uri->group, 'group matches'); +done_testing; diff --git a/xt/net_writer-imap.t b/xt/net_writer-imap.t new file mode 100644 index 00000000..176502ba --- /dev/null +++ b/xt/net_writer-imap.t @@ -0,0 +1,274 @@ +#!perl -w +# Copyright (C) all contributors <meta@public-inbox.org> +# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt> +use strict; use v5.10.1; use PublicInbox::TestCommon; +use Sys::Hostname qw(hostname); +use POSIX qw(strftime); +use PublicInbox::OnDestroy; +use PublicInbox::URIimap; +use PublicInbox::Config; +use PublicInbox::DS; +use PublicInbox::InboxIdle; +use Fcntl qw(O_EXCL O_WRONLY O_CREAT); +my $imap_url = $ENV{TEST_IMAP_WRITE_URL} or + plan skip_all => 'TEST_IMAP_WRITE_URL unset'; +my $uri = PublicInbox::URIimap->new($imap_url); +defined($uri->path) and + plan skip_all => "$imap_url should not be a mailbox (just host:port)"; +require_mods('Mail::IMAPClient'); +require_ok 'PublicInbox::NetWriter'; +my $host = (split(/\./, hostname))[0]; +my ($base) = ($0 =~ m!\b([^/]+)\.[^\.]+\z!); +my $SEP = $ENV{IMAP_SEPARATOR} || '.'; +my $folder = "INBOX$SEP$base-$host-".strftime('%Y%m%d%H%M%S', gmtime(time)). + "-$$-".sprintf('%x', int(rand(0xffffffff))); +my $nwr = PublicInbox::NetWriter->new; +chop($imap_url) if substr($imap_url, -1) eq '/'; +my $folder_url = "$imap_url/$folder"; +my $folder_uri = PublicInbox::URIimap->new($folder_url); +is($folder_uri->mailbox, $folder, 'folder correct') or + BAIL_OUT "BUG: bad $$uri"; +$nwr->add_url($$folder_uri); +is($nwr->errors, undef, 'no errors'); +$nwr->{pi_cfg} = bless {}, 'PublicInbox::Config'; + +my $set_cred_helper = sub { + my ($f, $cred_set) = @_; + sysopen(my $fh, $f, O_CREAT|O_EXCL|O_WRONLY) or BAIL_OUT "open $f: $!"; + print $fh <<EOF or BAIL_OUT "print $f: $!"; +[credential] + helper = $cred_set +EOF + close $fh or BAIL_OUT "close $f: $!"; +}; + +# allow testers with git-credential-store configured to reuse +# stored credentials inside test_lei(sub {...}) when $ENV{HOME} +# is overridden and localized. +my ($cred_set, @cred_link, $tmpdir, $for_destroy); +chomp(my $cred_helper = `git config credential.helper 2>/dev/null`); +if ($cred_helper eq 'store') { + my $config = $ENV{XDG_CONFIG_HOME} // "$ENV{HOME}/.config"; + for my $f ("$ENV{HOME}/.git-credentials", "$config/git/credentials") { + next unless -f $f; + @cred_link = ($f, '/.git-credentials'); + last; + } + $cred_set = qq("$cred_helper"); +} elsif ($cred_helper =~ /\Acache(?:[ \t]|\z)/) { + my $cache = $ENV{XDG_CACHE_HOME} // "$ENV{HOME}/.cache"; + for my $d ("$ENV{HOME}/.git-credential-cache", + "$cache/git/credential") { + next unless -d $d; + @cred_link = ($d, '/.git-credential-cache'); + $cred_set = qq("$cred_helper"); + last; + } +} elsif (!$cred_helper) { # make the test less painful if no creds configured + ($tmpdir, $for_destroy) = tmpdir; + my $d = "$tmpdir/.git-credential-cache"; + mkdir($d, 0700) or BAIL_OUT $!; + $cred_set = "cache --timeout=60"; + @cred_link = ($d, '/.git-credential-cache'); +} else { + diag "credential.helper=$cred_helper will not be used for this test"; +} + +my $mics = do { + local $ENV{HOME} = $tmpdir // $ENV{HOME}; + if ($tmpdir && $cred_set) { + $set_cred_helper->("$ENV{HOME}/.gitconfig", $cred_set) + } + $nwr->imap_common_init; +}; +my $mic = (values %$mics)[0]; +my $cleanup = on_destroy sub { + if (defined($folder)) { + my $mic = $nwr->mic_get($uri); + $mic->delete($folder) or + fail "delete $folder <$folder_uri>: $@"; + } + if ($tmpdir && -f "$tmpdir/.gitconfig") { + local $ENV{HOME} = $tmpdir; + system(qw(git credential-cache exit)); + } +}; +my $imap_append = $nwr->can('imap_append'); +my $smsg = bless { kw => [ 'seen' ] }, 'PublicInbox::Smsg'; +$imap_append->($mic, $folder, undef, $smsg, eml_load('t/plack-qp.eml')); +$nwr->{quiet} = 1; +my $imap_slurp_all = sub { + my ($url, $uid, $kw, $eml, $res) = @_; + push @$res, [ $kw, $eml ]; +}; +$nwr->imap_each($folder_uri, $imap_slurp_all, my $res = []); +is(scalar(@$res), 1, 'got appended message'); +my $plack_qp_eml = eml_load('t/plack-qp.eml'); +is_deeply($res, [ [ [ 'seen' ], $plack_qp_eml ] ], + 'uploaded message read back'); +$res = $mic = $mics = undef; + +test_lei(sub { + my ($ro_home, $cfg_path) = setup_public_inboxes; + my $cfg = PublicInbox::Config->new($cfg_path); + $cfg->each_inbox(sub { + my ($ibx) = @_; + lei_ok qw(add-external -q), $ibx->{inboxdir} or BAIL_OUT; + }); + + # cred_link[0] may be on a different (hopefully encrypted) FS, + # we only symlink to it here, so we don't copy any sensitive data + # into the temporary directory + if (@cred_link && !symlink($cred_link[0], $ENV{HOME}.$cred_link[1])) { + diag "symlink @cred_link: $! (non-fatal)"; + $cred_set = undef; + } + $set_cred_helper->("$ENV{HOME}/.gitconfig", $cred_set) if $cred_set; + + # don't combine these two: + $ENV{TEST_IMAP_COMPRESS} and lei_ok qw(config imap.compress true); + $ENV{TEST_IMAP_DEBUG} and lei_ok qw(config imap.debug true); + my $proxy = $ENV{TEST_IMAP_PROXY}; + lei_ok(qw(config imap.proxy), $proxy) if $proxy; + + lei_ok qw(q f:qp@example.com -o), $folder_url; + $nwr->imap_each($folder_uri, $imap_slurp_all, my $res = []); + is(scalar(@$res), 1, 'got one deduped result') or diag explain($res); + is_deeply($res->[0]->[1], $plack_qp_eml, + 'lei q wrote expected result'); + + my $mdir = "$ENV{HOME}/t.mdir"; + lei_ok 'convert', $folder_url, '-o', $mdir; + my @mdfiles = glob("$mdir/*/*"); + is(scalar(@mdfiles), 1, '1 message from IMAP => Maildir conversion'); + is_deeply(eml_load($mdfiles[0]), $plack_qp_eml, + 'conversion from IMAP to Maildir'); + + lei_ok qw(q f:matz -a -o), $folder_url; + $nwr->imap_each($folder_uri, $imap_slurp_all, my $aug = []); + is(scalar(@$aug), 2, '2 results after augment') or diag explain($aug); + my $exp = $res->[0]->[1]->as_string; + is(scalar(grep { $_->[1]->as_string eq $exp } @$aug), 1, + 'original remains after augment'); + $exp = eml_load('t/iso-2202-jp.eml')->as_string; + is(scalar(grep { $_->[1]->as_string eq $exp } @$aug), 1, + 'new result shown after augment'); + + lei_ok qw(q s:thisbetternotgiveanyresult -o), $folder_url; + $nwr->imap_each($folder_uri, $imap_slurp_all, my $empty = []); + is(scalar(@$empty), 0, 'no results w/o augment'); + + my $f = 't/utf8.eml'; # <testmessage@example.com> + $exp = eml_load($f); + lei_ok qw(convert -F eml -o), $folder_url, $f; + my (@uid, @res); + $nwr->imap_each($folder_uri, sub { + my ($u, $uid, $kw, $eml) = @_; + push @uid, $uid; + push @res, [ $kw, $eml ]; + }); + is_deeply(\@res, [ [ [], $exp ] ], 'converted to IMAP destination'); + is(scalar(@uid), 1, 'got one UID back'); + lei_ok qw(q -o /dev/stdout m:testmessage@example.com --no-external); + is_deeply(json_utf8->decode($lei_out), [undef], + 'no results before import'); + + lei_ok qw(import -F eml), $f, \'import local copy w/o keywords'; + + lei_ok 'import', $folder_url; # populate mail_sync.sqlite3 + lei_ok qw(tag +kw:seen +kw:answered +kw:flagged), $f; + lei_ok 'ls-mail-sync'; + my @ls = split(/\n/, $lei_out); + is(scalar(@ls), 1, 'only one folder in ls-mail-sync') or xbail(\@ls); + for my $l (@ls) { + like($l, qr/;UIDVALIDITY=\d+\z/, 'UIDVALIDITY'); + } + lei_ok 'export-kw', $folder_url; + $mic = $nwr->mic_for_folder($folder_uri); + my $flags = $mic->flags($uid[0]); + is_deeply([sort @$flags], [ qw(\\Answered \\Flagged \\Seen) ], + 'IMAP flags set by export-kw') or diag explain($flags); + + # ensure this imap_set_kw clobbers + $nwr->imap_set_kw($mic, $uid[0], [ 'seen' ])->expunge or + BAIL_OUT "expunge $@"; + $mic = undef; + @res = (); + $nwr->imap_each($folder_uri, $imap_slurp_all, \@res); + is_deeply(\@res, [ [ ['seen'], $exp ] ], 'seen flag set') or + diag explain(\@res); + + lei_ok qw(q s:thisbetternotgiveanyresult -o), $folder_url, + \'clobber folder but import flag'; + $nwr->imap_each($folder_uri, $imap_slurp_all, $empty = []); + is_deeply($empty, [], 'clobbered folder'); + lei_ok qw(q -o /dev/stdout m:testmessage@example.com --no-external); + $res = json_utf8->decode($lei_out)->[0]; + is_deeply([@$res{qw(m kw)}], ['testmessage@example.com', ['seen']], + 'kw set'); + + # prepare messages for watch + $mic = $nwr->mic_for_folder($folder_uri); + for my $kw (qw(Deleted Seen Answered Draft forwarded)) { + my $buf = <<EOM; +From: x\@example.com +Message-ID: <$kw\@test.example.com> + +EOM + my $f = $kw eq 'forwarded' ? '$Forwarded' : "\\$kw"; + $mic->append_string($folder_uri->mailbox, $buf, $f) + or BAIL_OUT "append $kw $@"; + } + $mic->disconnect; + + my $inboxdir = "$ENV{HOME}/wtest"; + my @cmd = (qw(-init -Lbasic wtest), $inboxdir, + qw(https://example.com/wtest wtest@example.com)); + run_script(\@cmd) or BAIL_OUT "init wtest"; + xsys(qw(git config), "--file=$ENV{HOME}/.public-inbox/config", + 'publicinbox.wtest.watch', + $folder_url) == 0 or BAIL_OUT "git config $?"; + my $watcherr = "$ENV{HOME}/watch.err"; + open my $err_wr, '>>', $watcherr or BAIL_OUT $!; + my $pub_cfg = PublicInbox::Config->new; + PublicInbox::DS->Reset; + my $ii = PublicInbox::InboxIdle->new($pub_cfg); + my $cb = sub { @PublicInbox::DS::post_loop_do = (sub {}) }; + my $obj = bless \$cb, 'PublicInbox::TestCommon::InboxWakeup'; + $pub_cfg->each_inbox(sub { $_[0]->subscribe_unlock('ident', $obj) }); + my $w = start_script(['-watch'], undef, { 2 => $err_wr }); + diag 'waiting for initial fetch...'; + PublicInbox::DS::event_loop(); + my $ibx = $pub_cfg->lookup_name('wtest'); + my $mm = $ibx->mm; + ok(defined($mm->num_for('Seen@test.example.com')), + '-watch takes seen message'); + ok(defined($mm->num_for('Answered@test.example.com')), + '-watch takes answered message'); + ok(!defined($mm->num_for('Deleted@test.example.com')), + '-watch ignored \\Deleted'); + ok(!defined($mm->num_for('Draft@test.example.com')), + '-watch ignored \\Draft'); + ok(defined($mm->num_for('forwarded@test.example.com')), + '-watch takes forwarded message'); + undef $w; # done with watch + lei_ok qw(import), $folder_url; + lei_ok qw(q m:forwarded@test.example.com); + is_deeply(json_utf8->decode($lei_out)->[0]->{kw}, ['forwarded'], + 'forwarded kw imported from IMAP'); + + lei_ok qw(q m:testmessage --no-external -o), $folder_url; + lei_ok qw(up), $folder_url; + lei_ok qw(up --all=remote); + $mic = $nwr->mic_get($uri); + $mic->delete($folder) or fail "delete $folder <$folder_uri>: $@"; + $mic->expunge; + undef $mic; + undef $folder; + ok(!lei(qw(export-kw), $folder_url), + 'export-kw fails w/ non-existent folder'); + +}); + +undef $cleanup; # remove temporary folder +done_testing; diff --git a/xt/nntpd-validate.t b/xt/nntpd-validate.t index 322e6f62..a6f3980e 100644 --- a/xt/nntpd-validate.t +++ b/xt/nntpd-validate.t @@ -1,4 +1,4 @@ -# Copyright (C) 2019-2020 all contributors <meta@public-inbox.org> +# Copyright (C) all contributors <meta@public-inbox.org> # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt> # Integration test to validate compression. @@ -9,6 +9,7 @@ use Symbol qw(gensym); use Time::HiRes qw(clock_gettime CLOCK_MONOTONIC); use POSIX qw(_exit); use PublicInbox::TestCommon; +use PublicInbox::SHA; my $inbox_dir = $ENV{GIANT_INBOX_DIR}; plan skip_all => "GIANT_INBOX_DIR not defined for $0" unless $inbox_dir; my $mid = $ENV{TEST_MID}; @@ -55,7 +56,7 @@ sub do_get_all { my ($methods) = @_; my $desc = join(',', @$methods); my $t0 = clock_gettime(CLOCK_MONOTONIC); - my $dig = Digest::SHA->new(1); + my $dig = PublicInbox::SHA->new(1); my $digfh = gensym; my $tmpfh; if ($File::Temp::KEEP_ALL) { @@ -169,8 +170,7 @@ sub make_local_server { open my $fh, '>', $_ or die "truncate: $!"; } my $sock = tcp_server(); - ok($sock, 'sock created'); - $host_port = $sock->sockhost . ':' . $sock->sockport; + $host_port = tcp_host_port($sock); # not using multiple workers, here, since we want to increase # the chance of tripping concurrency bugs within PublicInbox/NNTP*.pm diff --git a/xt/over-fsck.perl b/xt/over-fsck.perl new file mode 100644 index 00000000..053204fe --- /dev/null +++ b/xt/over-fsck.perl @@ -0,0 +1,44 @@ +#!perl -w +# Copyright (C) all contributors <meta@public-inbox.org> +# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt> +# unstable dev script, chasing a bug which may be in LeiSavedSearch->is_dup +use v5.12; +use Data::Dumper; +use PublicInbox::OverIdx; +@ARGV == 1 or die "Usage: $0 /path/to/over.sqlite3\n"; +my $over = PublicInbox::OverIdx->new($ARGV[0]); +my $dbh = $over->dbh; +$dbh->do('PRAGMA mmap_size = '.(2 ** 48)); +my $num = 0; +my ($err, $none, $nr, $ids); +$Data::Dumper::Useqq = $Data::Dumper::Sortkeys = 1; +do { + $ids = $over->ids_after(\$num); + $nr += @$ids; + for my $n (@$ids) { + my $smsg = $over->get_art($n); + if (!$smsg) { + warn "#$n article missing\n"; + ++$err; + next; + } + my $exp = $smsg->{blob}; + if ($exp eq '') { + ++$none if $smsg->{bytes}; + next; + } + my $xr3 = $over->get_xref3($n, 1); + my $found; + for my $r (@$xr3) { + $r->[2] = unpack('H*', $r->[2]); + $found = 1 if $r->[2] eq $exp; + } + if (!$found) { + warn Dumper([$smsg, $xr3 ]); + ++$err; + } + } +} while (@$ids); +warn "$none/$nr had no blob (external?)\n" if $none; +warn "$err errors\n" if $err; +exit($err ? 1 : 0); diff --git a/xt/perf-msgview.t b/xt/perf-msgview.t index 3ea92ec6..ef261359 100644 --- a/xt/perf-msgview.t +++ b/xt/perf-msgview.t @@ -1,14 +1,18 @@ -# Copyright (C) 2019-2020 all contributors <meta@public-inbox.org> +#!perl -w +# Copyright (C) all contributors <meta@public-inbox.org> # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt> use strict; -use warnings; -use Test::More; +use v5.10.1; +use PublicInbox::TestCommon; use Benchmark qw(:all); use PublicInbox::Inbox; use PublicInbox::View; -use PublicInbox::TestCommon; +use PublicInbox::WwwStream; my $inboxdir = $ENV{GIANT_INBOX_DIR} // $ENV{GIANT_PI_DIR}; +my $blob = $ENV{TEST_BLOB}; +my $obfuscate = $ENV{PI_OBFUSCATE} ? 1 : 0; +diag "PI_OBFUSCATE=$obfuscate"; plan skip_all => "GIANT_INBOX_DIR not defined for $0" unless $inboxdir; my @cat = qw(cat-file --buffer --batch-check --batch-all-objects); @@ -19,35 +23,56 @@ if (require_git(2.19, 1)) { "git <2.19, cat-file lacks --unordered, locality suffers\n"; } require_mods qw(Plack::Util); -use_ok 'Plack::Util'; -my $ibx = PublicInbox::Inbox->new({ inboxdir => $inboxdir, name => 'name' }); +my $ibx = PublicInbox::Inbox->new({ inboxdir => $inboxdir, name => 'name', + obfuscate => $obfuscate}); my $git = $ibx->git; -my $fh = $git->popen(@cat); -my $vec = ''; -vec($vec, fileno($fh), 1) = 1; -select($vec, undef, undef, 60) or die "timed out waiting for --batch-check"; +my $fh = $blob ? undef : $git->popen(@cat); +if ($fh) { + my $vec = ''; + vec($vec, fileno($fh), 1) = 1; + select($vec, undef, undef, 60) or + die "timed out waiting for --batch-check"; +} -my $ctx = { +my $ctx = bless { env => { HTTP_HOST => 'example.com', 'psgi.url_scheme' => 'https' }, - -inbox => $ibx, + ibx => $ibx, www => Plack::Util::inline_object(style => sub {''}), -}; -my ($str, $mime, $res, $cmt, $type); + gz => PublicInbox::GzipFilter::gzip_or_die(), +}, 'PublicInbox::WwwStream'; +my ($eml, $res, $oid, $type); my $n = 0; +my $m = 0; +${$ctx->{obuf}} = ''; +$ctx->{mhref} = '../'; + +my $cb = sub { + $eml = PublicInbox::Eml->new(shift); + $eml->each_part(\&PublicInbox::View::add_text_body, $ctx, 1); + $ctx->zflush(grep defined, delete @$ctx{'obuf'}); # compat + ++$m; + delete $ctx->{zbuf}; + ${$ctx->{obuf}} = ''; # compat + $ctx->{gz} = PublicInbox::GzipFilter::gzip_or_die(); +}; + my $t = timeit(1, sub { - my $obuf = ''; - $ctx->{obuf} = \$obuf; - $ctx->{mhref} = '../'; - while (<$fh>) { - ($cmt, $type) = split / /; - next if $type ne 'blob'; - ++$n; - $str = $git->cat_file($cmt); - $mime = PublicInbox::MIME->new($str); - PublicInbox::View::multipart_text_as_html($mime, $ctx); - $obuf = ''; + if (defined $blob) { + my $nr = $ENV{NR} // 10000; + for (1..$nr) { + ++$n; + $git->cat_async($blob, $cb); + } + } else { + while (<$fh>) { + ($oid, $type) = split / /; + next if $type ne 'blob'; + ++$n; + $git->cat_async($oid, $cb); + } } + $git->async_wait_all; }); -diag 'multipart_text_as_html took '.timestr($t)." for $n messages"; -ok 1; +diag 'add_text_body took '.timestr($t)." for $n <=> $m messages"; +is($m, $n, 'rendered all messages'); done_testing(); diff --git a/xt/perf-nntpd.t b/xt/perf-nntpd.t index f73afacc..85db036c 100644 --- a/xt/perf-nntpd.t +++ b/xt/perf-nntpd.t @@ -1,4 +1,4 @@ -# Copyright (C) 2018-2020 all contributors <meta@public-inbox.org> +# Copyright (C) 2018-2021 all contributors <meta@public-inbox.org> # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt> use strict; use warnings; @@ -8,12 +8,15 @@ use PublicInbox::Inbox; use Net::NNTP; my $inboxdir = $ENV{GIANT_INBOX_DIR} // $ENV{GIANT_PI_DIR}; plan skip_all => "GIANT_INBOX_DIR not defined for $0" unless defined($inboxdir); -my ($host_port, $group, %opts, $s, $td, $tmp_obj); +my ($host_port, $group, $s, $td, $tmp_obj); use PublicInbox::TestCommon; if (($ENV{NNTP_TEST_URL} || '') =~ m!\Anntp://([^/]+)/([^/]+)\z!) { ($host_port, $group) = ($1, $2); $host_port .= ":119" unless index($host_port, ':') > 0; + my $six = substr($host_port, 0, 1) eq '[' ? '6' : ''; + my $cls = "IO::Socket::INET$six"; + $cls->new(Proto => 'tcp', Timeout => 1, PeerAddr => $host_port); } else { $group = 'inbox.test.perf.nntpd'; my $ibx = { inboxdir => $inboxdir, newsgroup => $group }; @@ -34,18 +37,11 @@ if (($ENV{NNTP_TEST_URL} || '') =~ m!\Anntp://([^/]+)/([^/]+)\z!) { } my $sock = tcp_server(); - ok($sock, 'sock created'); my $cmd = [ '-nntpd', '-W0' ]; $td = start_script($cmd, { PI_CONFIG => $pi_config }, { 3 => $sock }); - $host_port = $sock->sockhost . ':' . $sock->sockport; + $host_port = tcp_host_port($sock); + $s = tcp_connect($sock); } -%opts = ( - PeerAddr => $host_port, - Proto => 'tcp', - Timeout => 1, -); -$s = IO::Socket::INET->new(%opts); -$s->autoflush(1); my $buf = $s->getline; like($buf, qr/\A201 .* ready - post via email\r\n/s, 'got greeting'); diff --git a/xt/perf-threading.t b/xt/perf-threading.t index ae98a5ba..57e9db9b 100644 --- a/xt/perf-threading.t +++ b/xt/perf-threading.t @@ -1,4 +1,4 @@ -# Copyright (C) 2016-2020 all contributors <meta@public-inbox.org> +# Copyright (C) 2016-2021 all contributors <meta@public-inbox.org> # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt> # # real-world testing of search threading @@ -18,14 +18,14 @@ require PublicInbox::View; my $msgs; my $elapsed = timeit(1, sub { - $msgs = $srch->{over_ro}->recent({limit => 200000}); + $msgs = $ibx->over->recent({limit => 200000}); }); my $n = scalar(@$msgs); ok($n, 'got some messages'); diag "enquire: ".timestr($elapsed)." for $n"; $elapsed = timeit(1, sub { - PublicInbox::View::thread_results({-inbox => $ibx}, $msgs); + PublicInbox::View::thread_results({ibx => $ibx}, $msgs); }); diag "thread_results ".timestr($elapsed); diff --git a/xt/pop3d-mpop.t b/xt/pop3d-mpop.t new file mode 100644 index 00000000..ff8bb5dc --- /dev/null +++ b/xt/pop3d-mpop.t @@ -0,0 +1,76 @@ +#!perl -w +# Copyright (C) all contributors <meta@public-inbox.org> +# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt> +# ensure mpop compatibility +use v5.12; +use File::Path qw(make_path); +use PublicInbox::TestCommon; +use PublicInbox::Spawn qw(spawn); +my $inboxdir = $ENV{GIANT_INBOX_DIR}; +(defined($inboxdir) && -d $inboxdir) or + plan skip_all => "GIANT_INBOX_DIR not defined for $0"; +plan skip_all => "bad characters in $inboxdir" if $inboxdir =~ m![^\w\.\-/]!; +my $uuidgen = require_cmd('uuidgen'); +my $mpop = require_cmd('mpop'); +require_mods(qw(DBD::SQLite :fcntl_lock)); +require_git(v2.6); # for v2 + +my ($tmpdir, $for_destroy) = tmpdir(); +my $cfg = "$tmpdir/cfg"; +my $newsgroup = 'inbox.test'; +my %pids; +{ + open my $fh, '>', $cfg or xbail "open: $!"; + print $fh <<EOF or xbail "print: $!"; +[publicinbox] + pop3state = $tmpdir/p3s +[publicinbox "test"] + newsgroup = $newsgroup + address = mpop-test\@example.com + inboxdir = $inboxdir +EOF + close $fh or xbail "close: $!"; +} +my ($out, $err) = ("$tmpdir/stdout.log", "$tmpdir/stderr.log"); +my $sock = tcp_server(); +my $cmd = [ '-pop3d', '-W0', "--stdout=$out", "--stderr=$err" ]; +my $env = { PI_CONFIG => $cfg }; +my $td = start_script($cmd, $env, { 3 => $sock }) or xbail "-xbail $?"; +chomp(my $uuid = xqx([$uuidgen])); + +make_path("$tmpdir/home/.config/mpop", + map { "$tmpdir/md/$_" } qw(new cur tmp)); + +{ + open my $fh, '>', "$tmpdir/home/.config/mpop/config" + or xbail "open $!"; + chmod 0600, $fh; + print $fh <<EOM or xbail "print $!"; +defaults +tls off +delivery maildir $tmpdir/md +account default +host ${\$sock->sockhost} +port ${\$sock->sockport} +user $uuid\@$newsgroup?limit=10000 +auth user +password anonymous +received_header off +EOM + close $fh or xbail "close $!"; + delete local $ENV{XDG_CONFIG_HOME}; # mpop uses this + local $ENV{HOME} = "$tmpdir/home"; + my $cmd = [ $mpop, '-q' ]; + my $pid = spawn($cmd, undef, { 1 => 2 }); + $pids{$pid} = $cmd; +} +diag "mpop is writing to $tmpdir/md ..."; +while (scalar keys %pids) { + my $pid = waitpid(-1, 0) or next; + my $cmd = delete $pids{$pid} or next; + is($?, 0, join(' ', @$cmd, 'done')); +} +$td->kill; +$td->join; +is($?, 0, 'no error on -pop3d exit'); +done_testing; diff --git a/xt/solver.t b/xt/solver.t index d2206b28..372d003b 100644 --- a/xt/solver.t +++ b/xt/solver.t @@ -1,16 +1,16 @@ #!perl -w -# Copyright (C) 2020 all contributors <meta@public-inbox.org> +# Copyright (C) all contributors <meta@public-inbox.org> # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt> -use strict; -use Test::More; +use v5.12; use PublicInbox::TestCommon; use PublicInbox::Config; # this relies on PI_CONFIG // ~/.public-inbox/config my @psgi = qw(HTTP::Request::Common Plack::Test URI::Escape Plack::Builder); -require_mods(qw(DBD::SQLite Search::Xapian), @psgi); +require_mods(qw(DBD::SQLite Xapian), @psgi); use_ok($_) for @psgi; use_ok 'PublicInbox::WWW'; my $cfg = PublicInbox::Config->new; my $www = PublicInbox::WWW->new($cfg); +$www->preload; my $app = sub { my $env = shift; $env->{'psgi.errors'} = \*STDERR; @@ -30,30 +30,52 @@ my $todo = { '6aa8857a11/s/?b=protocol.c', '96f1c7f/s/', # TODO: b=contrib/completion/git-completion.bash 'b76f2c0/s/?b=po/zh_CN.po', + 'c2f3bf071ee90b01f2d629921bb04c4f798f02fa/s/', # tag + '7eb93c89651c47c8095d476251f2e4314656b292/s/', # non-UTF-8 ], + 'sox-devel' => [ + 'c38987e8d20505621b8d872863afa7d233ed1096/s/', # non-UTF-8 + ] }; -my ($ibx, $urls); +my @gone; my $client = sub { my ($cb) = @_; - for (@$urls) { - my $url = "/$ibx/$_"; - my $res = $cb->(GET($url)); - is($res->code, 200, $url); - next if $res->code == 200; - # diag $res->content; - diag "$url failed"; + for my $ibx_name (sort keys %$todo) { + diag "testing $ibx_name"; + my $urls = $todo->{$ibx_name}; + for my $u (@$urls) { + my $url = "/$ibx_name/$u"; + my $res = $cb->(GET($url)); + is($res->code, 200, $url); + next if $res->code == 200; + diag "$url failed"; + diag $res->content; + } } }; -while (($ibx, $urls) = each %$todo) { +my $nr = 0; +while (my ($ibx_name, $urls) = each %$todo) { SKIP: { - if (!$cfg->lookup_name($ibx)) { - skip("$ibx not configured", scalar(@$urls)); + my $ibx = $cfg->lookup_name($ibx_name); + if (!$ibx) { + push @gone, $ibx_name; + skip(qq{[publicinbox "$ibx_name"] not configured}, + scalar(@$urls)); + } + if (!defined($ibx->{-repo_objs})) { + push @gone, $ibx_name; + skip(qq{publicinbox.$ibx_name.coderepo not configured}, + scalar(@$urls)); } - test_psgi($app, $client); + $nr++; } } +delete @$todo{@gone}; +test_psgi($app, $client); +my $env = { PI_CONFIG => PublicInbox::Config->default_file }; +test_httpd($env, $client, $nr); + done_testing(); -1; diff --git a/xt/stress-sharedkv.t b/xt/stress-sharedkv.t new file mode 100644 index 00000000..1773d4bc --- /dev/null +++ b/xt/stress-sharedkv.t @@ -0,0 +1,50 @@ +# Copyright (C) 2021 all contributors <meta@public-inbox.org> +# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt> +use strict; +use v5.10.1; +use Test::More; +use Benchmark qw(:all); +use PublicInbox::TestCommon; +require_ok 'PublicInbox::SharedKV'; +my ($tmpdir, $for_destroy) = tmpdir(); +local $ENV{TMPDIR} = $tmpdir; +my $skv = PublicInbox::SharedKV->new; +my $ipc = bless {}, 'StressSharedKV'; +$ipc->wq_workers_start('stress-sharedkv', $ENV{TEST_NPROC}//4); +my $nr = $ENV{TEST_STRESS_NR} // 100_000; +my $ios = []; +my $t = timeit(1, sub { + for my $i (1..$nr) { + $ipc->wq_io_do('test_set_maybe', $ios, $skv, $i); + $ipc->wq_io_do('test_set_maybe', $ios, $skv, $i); + } +}); +diag "$nr sets done ".timestr($t); + +for my $w ($ipc->wq_workers) { + $ipc->wq_io_do('test_skv_done', $ios); +} +diag "done requested"; + +$ipc->wq_close; +done_testing; + +package StressSharedKV; +use strict; +use v5.10.1; +use parent qw(PublicInbox::IPC); +use Digest::SHA qw(sha1); + +sub test_set_maybe { + my ($self, $skv, $i) = @_; + my $wcb = $self->{wcb} //= do { + $skv->dbh; + sub { $skv->set_maybe(sha1($_[0]), '') }; + }; + $wcb->($i + time); +} + +sub test_skv_done { + my ($self) = @_; + delete $self->{wcb}; +} |