1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
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;
|