]> Sergey Matveev's repositories - public-inbox.git/blob - t/check-www-inbox.perl
msgmap: mid_insert ignores duplicates instead of die-ing
[public-inbox.git] / t / check-www-inbox.perl
1 #!/usr/bin/perl -w
2 # Copyright (C) 2016 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 my $nproc = 4;
18 my $slow = 0.5;
19 my %opts = (
20         '-j|jobs=i' => \$nproc,
21         '-s|slow-threshold=f' => \$slow,
22 );
23 GetOptions(%opts) or die "bad command-line args\n$usage";
24 my $root_url = shift or die $usage;
25
26 my %workers;
27 $SIG{TERM} = sub { exit 0 };
28 $SIG{CHLD} = sub {
29         while (1) {
30                 my $pid = waitpid(-1, WNOHANG);
31                 return if !defined $pid || $pid <= 0;
32                 my $p = delete $workers{$pid} || '(unknown)';
33                 warn("$pid [$p] exited with $?\n") if $?;
34         }
35 };
36
37 my @todo = IO::Socket->socketpair(AF_UNIX, SOCK_SEQPACKET, 0);
38 die "socketpair failed: $!" unless $todo[1];
39 my @done = IO::Socket->socketpair(AF_UNIX, SOCK_SEQPACKET, 0);
40 die "socketpair failed: $!" unless $done[1];
41 $| = 1;
42
43 foreach my $p (1..$nproc) {
44         my $pid = fork;
45         die "fork failed: $!\n" unless defined $pid;
46         if ($pid) {
47                 $workers{$pid} = $p;
48         } else {
49                 $todo[1]->close;
50                 $done[0]->close;
51                 worker_loop($todo[0], $done[1]);
52         }
53 }
54
55 my ($fh, $tmp) = tempfile('www-check-XXXXXXXX',
56                         SUFFIX => '.gdbm', UNLINK => 1, TMPDIR => 1);
57 my $gdbm = tie my %seen, 'GDBM_File', $tmp, &GDBM_WRCREAT, 0600;
58 defined $gdbm or die "gdbm open failed: $!\n";
59 $todo[0]->close;
60 $done[1]->close;
61
62 my ($rvec, $wvec);
63 $todo[1]->blocking(0);
64 $done[0]->blocking(0);
65 $seen{$root_url} = 1;
66 my $ndone = 0;
67 my $nsent = 1;
68 my @queue = ($root_url);
69 my $timeout = $slow * 4;
70 while (keys %workers) { # reacts to SIGCHLD
71         $wvec = $rvec = '';
72         my $u;
73         vec($rvec, fileno($done[0]), 1) = 1;
74         if (@queue) {
75                 vec($wvec, fileno($todo[1]), 1) = 1;
76         } elsif ($ndone == $nsent) {
77                 kill 'TERM', keys %workers;
78                 exit;
79         }
80         if (!select($rvec, $wvec, undef, $timeout)) {
81                 while (my ($k, $v) = each %seen) {
82                         next if $v == 2;
83                         print "WAIT ($ndone/$nsent) <$k>\n";
84                 }
85         }
86         while ($u = shift @queue) {
87                 my $s = $todo[1]->send($u, MSG_EOR);
88                 if ($!{EAGAIN}) {
89                         unshift @queue, $u;
90                         last;
91                 }
92         }
93         my $r;
94         do {
95                 $r = $done[0]->recv($u, 65535, 0);
96         } while (!defined $r && $!{EINTR});
97         next unless $u;
98         if ($u =~ s/\ADONE\t//) {
99                 $ndone++;
100                 $seen{$u} = 2;
101         } else {
102                 next if $seen{$u};
103                 $seen{$u} = 1;
104                 $nsent++;
105                 push @queue, $u;
106         }
107 }
108
109 sub worker_loop {
110         my ($todo_rd, $done_wr) = @_;
111         my $m = WWW::Mechanize->new(autocheck => 0);
112         my $cc = LWP::ConnCache->new;
113         $m->conn_cache($cc);
114         while (1) {
115                 $todo_rd->recv(my $u, 65535, 0);
116                 next unless $u;
117
118                 my $t = [ gettimeofday ];
119                 my $r = $m->get($u);
120                 $t = tv_interval($t);
121                 printf "SLOW %0.06f % 5d %s\n", $t, $$, $u if $t > $slow;
122                 my @links;
123                 if ($r->is_success) {
124                         my %links = map {
125                                 (split('#', $_->URI->abs->as_string))[0] => 1;
126                         } grep {
127                                 $_->tag && $_->url !~ /:/
128                         } $m->links;
129                         @links = keys %links;
130                 } elsif ($r->code != 300) {
131                         warn "W: ".$r->code . " $u\n"
132                 }
133
134                 my $s;
135                 # blocking
136                 foreach my $l (@links, "DONE\t$u") {
137                         next if $l eq '';
138                         do {
139                                 $s = $done_wr->send($l, MSG_EOR);
140                         } while (!defined $s && $!{EINTR});
141                         die "$$ send $!\n" unless defined $s;
142                         my $n = length($l);
143                         die "$$ send truncated $s < $n\n" if $s != $n;
144                 }
145
146                 # make sure the HTML source doesn't screw up terminals
147                 # when people curl the source (not remotely an expert
148                 # on languages or encodings, here).
149                 next if $r->header('Content-Type') !~ m!\btext/html\b!;
150                 my $dc = $r->decoded_content;
151                 if ($dc =~ /([\x00-\x08\x0d-\x1f\x7f-\x{99999999}]+)/s) {
152                         my $o = $1;
153                         my $c = Dumper($o);
154                         warn "bad: $u $c\n";
155                 }
156         }
157 }