1 # Copyright (C) 2019 all contributors <meta@public-inbox.org>
2 # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
4 # Integration test to validate compression.
7 use File::Temp qw(tempdir);
10 use Time::HiRes qw(clock_gettime CLOCK_MONOTONIC);
11 my $inbox_dir = $ENV{GIANT_INBOX_DIR};
12 plan skip_all => "GIANT_INBOX_DIR not defined for $0" unless $inbox_dir;
13 if (my $m = $ENV{TEST_RUN_MODE}) {
14 plan skip_all => "threads conflict w/ TEST_RUN_MODE=$m";
16 my $mid = $ENV{TEST_MID};
18 # This test is also an excuse for me to experiment with Perl threads :P
19 # TODO: get rid of threads, I was reading an old threads(3perl) manpage
20 # and missed the WARNING in the newer ones about it being "discouraged"
22 unless (eval 'use threads; 1') {
23 plan skip_all => "$0 requires a threaded perl" if $@;
26 # Net::NNTP is part of the standard library, but distros may split it off...
27 foreach my $mod (qw(DBD::SQLite Net::NNTP Compress::Raw::Zlib)) {
29 plan skip_all => "$mod missing for $0" if $@;
32 my $test_compress = Net::NNTP->can('compress');
33 if (!$test_compress) {
34 diag 'Your Net::NNTP does not yet support compression';
35 diag 'See: https://rt.cpan.org/Ticket/Display.html?id=129967';
37 my $test_tls = $ENV{TEST_SKIP_TLS} ? 0 : eval { require IO::Socket::SSL };
38 my $cert = 'certs/server-cert.pem';
39 my $key = 'certs/server-key.pem';
40 if ($test_tls && !-r $key || !-r $cert) {
41 plan skip_all => "certs/ missing for $0, run $^X ./certs/create-certs.perl";
43 require './t/common.perl';
44 my $keep_tmp = !!$ENV{TEST_KEEP_TMP};
45 my $tmpdir = tempdir('nntpd-validate-XXXXXX',TMPDIR => 1,CLEANUP => $keep_tmp);
46 my (%OPT, $td, $host_port, $group);
48 if (($ENV{NNTP_TEST_URL} // '') =~ m!\Anntp://([^/]+)/([^/]+)\z!) {
49 ($host_port, $group) = ($1, $2);
50 $host_port .= ":119" unless index($host_port, ':') > 0;
54 my $test_article = $ENV{TEST_ARTICLE} // 0;
55 my $test_xover = $ENV{TEST_XOVER} // 1;
58 my $nntp = Net::NNTP->new($host_port, %OPT);
59 ok($nntp->starttls, 'STARTTLS works');
60 ok($nntp->compress, 'COMPRESS works') if $test_compress;
61 ok($nntp->quit, 'QUIT after starttls OK');
64 my $nntp = Net::NNTP->new($host_port, %OPT);
65 ok($nntp->compress, 'COMPRESS works');
66 ok($nntp->quit, 'QUIT after compress OK');
71 my $desc = join(',', @$methods);
72 my $t0 = clock_gettime(CLOCK_MONOTONIC);
73 my $dig = Digest::SHA->new(1);
77 open $tmpfh, '>', "$tmpdir/$desc.raw" or die $!;
79 my $tmp = { dig => $dig, tmpfh => $tmpfh };
80 tie *$digfh, 'DigestPipe', $tmp;
81 my $nntp = Net::NNTP->new($host_port, %OPT);
82 $nntp->article("<$mid>", $digfh) if $mid;
83 foreach my $m (@$methods) {
85 print STDERR "# $m got $res ($desc)\n" if !$res;
87 $nntp->article("<$mid>", $digfh) if $mid;
88 my ($num, $first, $last) = $nntp->group($group);
89 unless (defined $num && defined $first && defined $last) {
90 warn "Invalid group\n";
94 for ($i = $first; $i < $last; $i += $batch) {
95 my $j = $i + $batch - 1;
96 $j = $last if $j > $last;
98 my $xover = $nntp->xover("$i-$j");
99 for my $n (sort { $a <=> $b } keys %$xover) {
100 my $line = join("\t", @{$xover->{$n}});
102 $dig->add("$n\t".$line);
107 $nntp->article($n, $digfh) and next;
108 next if $nntp->code == 423;
109 my $res = $nntp->code.' '. $nntp->message;
112 print STDERR "# Article $n ($desc): $res\n";
117 # hacky bytes_read thing added to Net::NNTP for testing:
119 if ($nntp->can('bytes_read')) {
120 $bytes_read .= ' '.$nntp->bytes_read.'b';
123 print STDERR "# quit failed: ".$nntp->code."\n" if !$q;
124 my $elapsed = sprintf('%0.3f', clock_gettime(CLOCK_MONOTONIC) - $t0);
125 my $res = $dig->hexdigest;
126 print STDERR "# $desc - $res (${elapsed}s)$bytes_read\n";
130 push @tests, [ 'compress' ] if $test_compress;
131 push @tests, [ 'starttls' ] if $test_tls;
132 push @tests, [ 'starttls', 'compress' ] if $test_tls && $test_compress;
133 my (@keys, %thr, %res);
135 my $key = join(',', @$m);
138 $thr{$key} = threads->create(\&do_get_all, $m);
141 $res{$_} = $thr{$_}->join for @keys;
142 my $plain = $res{''};
143 ok($plain, "plain got $plain");
144 is($res{$_}, $plain, "$_ matches '' result") for @keys;
148 sub make_local_server {
149 require PublicInbox::Inbox;
150 $group = 'inbox.test.perf.nntpd';
151 my $ibx = { inboxdir => $inbox_dir, newsgroup => $group };
152 $ibx = PublicInbox::Inbox->new($ibx);
153 my $pi_config = "$tmpdir/config";
155 open my $fh, '>', $pi_config or die "open($pi_config): $!";
156 print $fh <<"" or die "print $pi_config: $!";
159 inboxdir = $inbox_dir
160 address = test\@example.com
162 close $fh or die "close($pi_config): $!";
164 my ($out, $err) = ("$tmpdir/out", "$tmpdir/err");
166 open my $fh, '>', $_ or die "truncate: $!";
168 my $sock = tcp_server();
169 ok($sock, 'sock created');
170 $host_port = $sock->sockhost . ':' . $sock->sockport;
172 # not using multiple workers, here, since we want to increase
173 # the chance of tripping concurrency bugs within PublicInbox/NNTP*.pm
174 my $cmd = [ '-nntpd', "--stdout=$out", "--stderr=$err", '-W0' ];
175 push @$cmd, "-lnntp://$host_port";
177 push @$cmd, "--cert=$cert", "--key=$key";
179 SSL_hostname => 'server.local',
180 SSL_verifycn_name => 'server.local',
181 SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_PEER(),
182 SSL_ca_file => 'certs/test-ca.pem',
185 print STDERR "# CMD ". join(' ', @$cmd). "\n";
186 my $env = { PI_CONFIG => $pi_config };
187 # perl threads and run_mode != 0 don't get along
188 $td = start_script($cmd, $env, { run_mode => 0, 3 => $sock });
196 my ($class, $self) = @_;
202 my $data = join('', @_);
203 # Net::NNTP emit different line-endings depending on TLS or not...:
205 $self->{dig}->add($data);
206 if (my $tmpfh = $self->{tmpfh}) {