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