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