t/nntpd-validate.t

   1 # Copyright (C) 2019 all contributors <meta@public-inbox.org>
   2 # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
   3
   4 # Integration test to validate compression.
   5 use strict;
   6 use warnings;
   7 use File::Temp qw(tempdir);
   8 use Test::More;
   9 use Symbol qw(gensym);
  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 my $mid = $ENV{TEST_MID};
  14
  15 # This test is also an excuse for me to experiment with Perl threads :P
  16 unless (eval 'use threads; 1') {
  17         plan skip_all => "$0 requires a threaded perl" if $@;
  18 }
  19
  20 # Net::NNTP is part of the standard library, but distros may split it off...
  21 foreach my $mod (qw(DBD::SQLite Net::NNTP Compress::Raw::Zlib)) {
  22         eval "require $mod";
  23         plan skip_all => "$mod missing for $0" if $@;
  24 }
  25
  26 my $test_compress = Net::NNTP->can('compress');
  27 if (!$test_compress) {
  28         diag 'Your Net::NNTP does not yet support compression';
  29         diag 'See: https://rt.cpan.org/Ticket/Display.html?id=129967';
  30 }
  31 my $test_tls = $ENV{TEST_SKIP_TLS} ? 0 : eval { require IO::Socket::SSL };
  32 my $cert = 'certs/server-cert.pem';
  33 my $key = 'certs/server-key.pem';
  34 if ($test_tls && !-r $key || !-r $cert) {
  35         plan skip_all => "certs/ missing for $0, run ./certs/create-certs.perl";
  36 }
  37 require './t/common.perl';
  38 my $keep_tmp = !!$ENV{TEST_KEEP_TMP};
  39 my $tmpdir = tempdir('nntpd-validate-XXXXXX',TMPDIR => 1,CLEANUP => $keep_tmp);
  40 my (%OPT, $pid, $tail_pid, $host_port, $group);
  41 my $batch = 1000;
  42 END {
  43         foreach ($pid, $tail_pid) {
  44                 kill 'TERM', $_ if defined $_;
  45         }
  46 };
  47 if (($ENV{NNTP_TEST_URL} // '') =~ m!\Anntp://([^/]+)/([^/]+)\z!) {
  48         ($host_port, $group) = ($1, $2);
  49         $host_port .= ":119" unless index($host_port, ':') > 0;
  50 } else {
  51         make_local_server();
  52 }
  53 my $test_article = $ENV{TEST_ARTICLE} // 0;
  54 my $test_xover = $ENV{TEST_XOVER} // 1;
  55
  56 if ($test_tls) {
  57         my $nntp = Net::NNTP->new($host_port, %OPT);
  58         ok($nntp->starttls, 'STARTTLS works');
  59         ok($nntp->compress, 'COMPRESS works') if $test_compress;
  60         ok($nntp->quit, 'QUIT after starttls OK');
  61 }
  62 if ($test_compress) {
  63         my $nntp = Net::NNTP->new($host_port, %OPT);
  64         ok($nntp->compress, 'COMPRESS works');
  65         ok($nntp->quit, 'QUIT after compress OK');
  66 }
  67
  68 sub do_get_all {
  69         my ($methods) = @_;
  70         my $desc = join(',', @$methods);
  71         my $t0 = clock_gettime(CLOCK_MONOTONIC);
  72         my $dig = Digest::SHA->new(1);
  73         my $digfh = gensym;
  74         my $tmpfh;
  75         if ($keep_tmp) {
  76                 open $tmpfh, '>', "$tmpdir/$desc.raw" or die $!;
  77         }
  78         my $tmp = { dig => $dig, tmpfh => $tmpfh };
  79         tie *$digfh, 'DigestPipe', $tmp;
  80         my $nntp = Net::NNTP->new($host_port, %OPT);
  81         $nntp->article("<$mid>", $digfh) if $mid;
  82         foreach my $m (@$methods) {
  83                 my $res = $nntp->$m;
  84                 print STDERR "# $m got $res ($desc)\n" if !$res;
  85         }
  86         $nntp->article("<$mid>", $digfh) if $mid;
  87         my ($num, $first, $last) = $nntp->group($group);
  88         unless (defined $num && defined $first && defined $last) {
  89                 warn "Invalid group\n";
  90                 return undef;
  91         }
  92         my $i;
  93         for ($i = $first; $i < $last; $i += $batch) {
  94                 my $j = $i + $batch - 1;
  95                 $j = $last if $j > $last;
  96                 if ($test_xover) {
  97                         my $xover = $nntp->xover("$i-$j");
  98                         for my $n (sort { $a <=> $b } keys %$xover) {
  99                                 my $line = join("\t", @{$xover->{$n}});
 100                                 $line =~ tr/\r//d;
 101                                 $dig->add("$n\t".$line);
 102                         }
 103                 }
 104                 if ($test_article) {
 105                         for my $n ($i..$j) {
 106                                 $nntp->article($n, $digfh) and next;
 107                                 next if $nntp->code == 423;
 108                                 my $res = $nntp->code.' '.  $nntp->message;
 109
 110                                 $res =~ tr/\r\n//d;
 111                                 print STDERR "# Article $n ($desc): $res\n";
 112                         }
 113                 }
 114         }
 115         my $q = $nntp->quit;
 116         print STDERR "# quit failed: ".$nntp->code."\n" if !$q;
 117         my $elapsed = sprintf('%0.3f', clock_gettime(CLOCK_MONOTONIC) - $t0);
 118         my $res = $dig->hexdigest;
 119         print STDERR "# $desc - $res (${elapsed}s)\n";
 120         $res;
 121 }
 122 my @tests = ([]);
 123 push @tests, [ 'compress' ] if $test_compress;
 124 push @tests, [ 'starttls' ] if $test_tls;
 125 push @tests, [ 'starttls', 'compress' ] if $test_tls && $test_compress;
 126 my (@keys, %thr, %res);
 127 for my $m (@tests) {
 128         my $key = join(',', @$m);
 129         push @keys, $key;
 130         diag "$key start";
 131         $thr{$key} = threads->create(\&do_get_all, $m);
 132 }
 133
 134 $res{$_} = $thr{$_}->join for @keys;
 135 my $plain = $res{''};
 136 ok($plain, "plain got $plain");
 137 is($res{$_}, $plain, "$_ matches '' result") for @keys;
 138
 139 done_testing();
 140
 141 sub make_local_server {
 142         require PublicInbox::Inbox;
 143         $group = 'inbox.test.perf.nntpd';
 144         my $ibx = { mainrepo => $inbox_dir, newsgroup => $group };
 145         $ibx = PublicInbox::Inbox->new($ibx);
 146         my $nntpd = 'blib/script/public-inbox-nntpd';
 147         my $pi_config = "$tmpdir/config";
 148         {
 149                 open my $fh, '>', $pi_config or die "open($pi_config): $!";
 150                 print $fh <<"" or die "print $pi_config: $!";
 151 [publicinbox "test"]
 152         newsgroup = $group
 153         mainrepo = $inbox_dir
 154         address = test\@example.com
 155
 156                 close $fh or die "close($pi_config): $!";
 157         }
 158         my ($out, $err) = ("$tmpdir/out", "$tmpdir/err");
 159         for ($out, $err) {
 160                 open my $fh, '>', $_ or die "truncate: $!";
 161         }
 162         if (my $tail_cmd = $ENV{TAIL}) { # don't assume GNU tail
 163                 $tail_pid = fork;
 164                 if (defined $tail_pid && $tail_pid == 0) {
 165                         open STDOUT, '>&STDERR' or die ">&2 failed: $!";
 166                         exec(split(' ', $tail_cmd), $out, $err);
 167                 }
 168         }
 169         my $sock = tcp_server();
 170         ok($sock, 'sock created');
 171         $host_port = $sock->sockhost . ':' . $sock->sockport;
 172
 173         # not using multiple workers, here, since we want to increase
 174         # the chance of tripping concurrency bugs within PublicInbox/NNTP*.pm
 175         my $cmd = [ $nntpd, "--stdout=$out", "--stderr=$err", '-W0' ];
 176         push @$cmd, "-lnntp://$host_port";
 177         if ($test_tls) {
 178                 push @$cmd, "--cert=$cert", "--key=$key";
 179                 %OPT = (
 180                         SSL_hostname => 'server.local',
 181                         SSL_verifycn_name => 'server.local',
 182                         SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_PEER(),
 183                         SSL_ca_file => 'certs/test-ca.pem',
 184                 );
 185         }
 186         print STDERR "# CMD ". join(' ', @$cmd). "\n";
 187         $pid = spawn_listener({ PI_CONFIG => $pi_config }, $cmd, [$sock]);
 188 }
 189
 190 package DigestPipe;
 191 use strict;
 192 use warnings;
 193
 194 sub TIEHANDLE {
 195         my ($class, $self) = @_;
 196         bless $self, $class;
 197 }
 198
 199 sub PRINT {
 200         my $self = shift;
 201         my $data = join('', @_);
 202         # Net::NNTP emit different line-endings depending on TLS or not...:
 203         $data =~ tr/\r//d;
 204         $self->{dig}->add($data);
 205         if (my $tmpfh = $self->{tmpfh}) {
 206                 print $tmpfh $data;
 207         }
 208         1;
 209 }
 210 1;