]> Sergey Matveev's repositories - public-inbox.git/blob - t/check-www-inbox.perl
doc: explain publicinbox.<name>.watchheader
[public-inbox.git] / t / check-www-inbox.perl
1 #!/usr/bin/perl -w
2 # Copyright (C) 2016-2019 all contributors <meta@public-inbox.org>
3 # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
4 # Parallel WWW checker
5 my $usage = "$0 [-j JOBS] [-s SLOW_THRESHOLD] URL_OF_INBOX\n";
6 use strict;
7 use warnings;
8 use File::Temp qw(tempfile);
9 use GDBM_File;
10 use Getopt::Long qw(:config gnu_getopt no_ignore_case auto_abbrev);
11 use IO::Socket;
12 use LWP::ConnCache;
13 use POSIX qw(:sys_wait_h);
14 use Time::HiRes qw(gettimeofday tv_interval);
15 use WWW::Mechanize;
16 use Data::Dumper;
17
18 # we want to use vfork+exec with spawn, WWW::Mechanize can use too much
19 # memory and fork(2) fails
20 use PublicInbox::Spawn qw(spawn which);
21 $ENV{PERL_INLINE_DIRECTORY} or warn "PERL_INLINE_DIRECTORY unset, may OOM\n";
22
23 our $tmp_owner = $$;
24 my $nproc = 4;
25 my $slow = 0.5;
26 my %opts = (
27         '-j|jobs=i' => \$nproc,
28         '-s|slow-threshold=f' => \$slow,
29 );
30 GetOptions(%opts) or die "bad command-line args\n$usage";
31 my $root_url = shift or die $usage;
32
33 chomp(my $xmlstarlet = which('xmlstarlet'));
34 my $atom_check = eval {
35         my $cmd = [ qw(xmlstarlet val -e -) ];
36         sub {
37                 my ($in, $out, $err) = @_;
38                 use autodie;
39                 open my $in_fh, '+>', undef;
40                 open my $out_fh, '+>', undef;
41                 open my $err_fh, '+>', undef;
42                 print $in_fh $$in;
43                 $in_fh->flush;
44                 sysseek($in_fh, 0, 0);
45                 my $rdr = {
46                         0 => fileno($in_fh),
47                         1 => fileno($out_fh),
48                         2 => fileno($err_fh),
49                 };
50                 my $pid = spawn($cmd, undef, $rdr);
51                 defined $pid or die "spawn failure: $!";
52                 while (waitpid($pid, 0) != $pid) {
53                         next if $!{EINTR};
54                         warn "waitpid(xmlstarlet, $pid) $!";
55                         return $!;
56                 }
57                 sysseek($out_fh, 0, 0);
58                 sysread($out_fh, $$out, -s $out_fh);
59                 sysseek($err_fh, 0, 0);
60                 sysread($err_fh, $$err, -s $err_fh);
61                 $?
62         }
63 } if $xmlstarlet;
64
65 my %workers;
66 $SIG{INT} = sub { exit 130 };
67 $SIG{TERM} = sub { exit 0 };
68 $SIG{CHLD} = sub {
69         while (1) {
70                 my $pid = waitpid(-1, WNOHANG);
71                 return if !defined $pid || $pid <= 0;
72                 my $p = delete $workers{$pid} || '(unknown)';
73                 warn("$pid [$p] exited with $?\n") if $?;
74         }
75 };
76
77 my @todo = IO::Socket->socketpair(AF_UNIX, SOCK_SEQPACKET, 0);
78 die "socketpair failed: $!" unless $todo[1];
79 my @done = IO::Socket->socketpair(AF_UNIX, SOCK_SEQPACKET, 0);
80 die "socketpair failed: $!" unless $done[1];
81 $| = 1;
82
83 foreach my $p (1..$nproc) {
84         my $pid = fork;
85         die "fork failed: $!\n" unless defined $pid;
86         if ($pid) {
87                 $workers{$pid} = $p;
88         } else {
89                 $todo[1]->close;
90                 $done[0]->close;
91                 worker_loop($todo[0], $done[1]);
92         }
93 }
94
95 my ($fh, $tmp) = tempfile('www-check-XXXXXXXX',
96                         SUFFIX => '.gdbm', UNLINK => 1, TMPDIR => 1);
97 my $gdbm = tie my %seen, 'GDBM_File', $tmp, &GDBM_WRCREAT, 0600;
98 defined $gdbm or die "gdbm open failed: $!\n";
99 $todo[0]->close;
100 $done[1]->close;
101
102 my ($rvec, $wvec);
103 $todo[1]->blocking(0);
104 $done[0]->blocking(0);
105 $seen{$root_url} = 1;
106 my $ndone = 0;
107 my $nsent = 1;
108 my @queue = ($root_url);
109 my $timeout = $slow * 4;
110 while (keys %workers) { # reacts to SIGCHLD
111         $wvec = $rvec = '';
112         my $u;
113         vec($rvec, fileno($done[0]), 1) = 1;
114         if (@queue) {
115                 vec($wvec, fileno($todo[1]), 1) = 1;
116         } elsif ($ndone == $nsent) {
117                 kill 'TERM', keys %workers;
118                 exit;
119         }
120         if (!select($rvec, $wvec, undef, $timeout)) {
121                 while (my ($k, $v) = each %seen) {
122                         next if $v == 2;
123                         print "WAIT ($ndone/$nsent) <$k>\n";
124                 }
125         }
126         while ($u = shift @queue) {
127                 my $s = $todo[1]->send($u, MSG_EOR);
128                 if ($!{EAGAIN}) {
129                         unshift @queue, $u;
130                         last;
131                 }
132         }
133         my $r;
134         do {
135                 $r = $done[0]->recv($u, 65535, 0);
136         } while (!defined $r && $!{EINTR});
137         next unless $u;
138         if ($u =~ s/\ADONE\t//) {
139                 $ndone++;
140                 $seen{$u} = 2;
141         } else {
142                 next if $seen{$u};
143                 $seen{$u} = 1;
144                 $nsent++;
145                 push @queue, $u;
146         }
147 }
148
149 sub worker_loop {
150         my ($todo_rd, $done_wr) = @_;
151         $SIG{CHLD} = 'DEFAULT';
152         my $m = WWW::Mechanize->new(autocheck => 0);
153         my $cc = LWP::ConnCache->new;
154         $m->stack_depth(0); # no history
155         $m->conn_cache($cc);
156         while (1) {
157                 $todo_rd->recv(my $u, 65535, 0);
158                 next unless $u;
159
160                 my $t = [ gettimeofday ];
161                 my $r = $m->get($u);
162                 $t = tv_interval($t);
163                 printf "SLOW %0.06f % 5d %s\n", $t, $$, $u if $t > $slow;
164                 my @links;
165                 if ($r->is_success) {
166                         my %links = map {
167                                 (split('#', $_->URI->abs->as_string))[0] => 1;
168                         } grep {
169                                 $_->tag && $_->url !~ /:/
170                         } $m->links;
171                         @links = keys %links;
172                 } elsif ($r->code != 300) {
173                         warn "W: ".$r->code . " $u\n"
174                 }
175
176                 my $s;
177                 # blocking
178                 foreach my $l (@links, "DONE\t$u") {
179                         next if $l eq '' || $l =~ /\.mbox(?:\.gz)\z/;
180                         do {
181                                 $s = $done_wr->send($l, MSG_EOR);
182                         } while (!defined $s && $!{EINTR});
183                         die "$$ send $!\n" unless defined $s;
184                         my $n = length($l);
185                         die "$$ send truncated $s < $n\n" if $s != $n;
186                 }
187
188                 # make sure the HTML source doesn't screw up terminals
189                 # when people curl the source (not remotely an expert
190                 # on languages or encodings, here).
191                 my $ct = $r->header('Content-Type') || '';
192                 warn "no Content-Type: $u\n" if $ct eq '';
193
194                 if ($atom_check && $ct =~ m!\bapplication/atom\+xml\b!) {
195                         my $raw = $r->decoded_content;
196                         my ($out, $err) = ('', '');
197                         my $fail = $atom_check->(\$raw, \$out, \$err);
198                         warn "Atom ($fail) - $u - <1:$out> <2:$err>\n" if $fail;
199                 }
200
201                 next if $ct !~ m!\btext/html\b!;
202                 my $dc = $r->decoded_content;
203                 if ($dc =~ /([\x00-\x08\x0d-\x1f\x7f-\x{99999999}]+)/s) {
204                         my $o = $1;
205                         my $c = Dumper($o);
206                         warn "bad: $u $c\n";
207                 }
208         }
209 }