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