1372 lines
38 KiB
Perl
Executable File
1372 lines
38 KiB
Perl
Executable File
#! /usr/bin/perl -w
|
|
|
|
# this copy forked off the original fork by Joy
|
|
# just to get the two archive thingies monitored, quick'n'dirty
|
|
# 2007-10-14
|
|
|
|
# Copyright (C) 2001-2002 Adam Lackorzynski
|
|
#
|
|
# This file contains free software, you can redistribute it and/or modify
|
|
# it under the terms of the GNU General Public License, Version 2 as
|
|
# published by the Free Software Foundation (see the file COPYING).
|
|
#
|
|
# This program is distributed in the hope that it will be useful,
|
|
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
# GNU General Public License for more details.
|
|
#
|
|
# Adam Lackorzynski <adam@os.inf.tu-dresden.de>
|
|
|
|
# todo
|
|
# - time of query (maybe, will consume too much space)
|
|
# - maybe some bars marking time all the servers are behind the
|
|
# the most recent server
|
|
# - rewrite and do it better this time...
|
|
|
|
use strict;
|
|
use LWP::UserAgent;
|
|
use Data::Dumper;
|
|
use Getopt::Long;
|
|
use File::Listing;
|
|
use Carp ();
|
|
|
|
#local $SIG{__WARN__} = \&Carp::confess; #cluck;
|
|
#local $SIG{__DIE__} = \&Carp::confess;
|
|
#$SIG{INT} = \&Carp::confess;
|
|
|
|
my $hostpattern =
|
|
#'([wp]\.de\.debian\.org$|den\.de$|erlangen|(se|uk|fi)\.debian)';
|
|
#'(\.debian\.org$|\.de$)';
|
|
#'([pw]\.de\.debian\.|dresden|claus)';
|
|
#'dresden';
|
|
#'(claus)';
|
|
#'((www|ftp).de.debian.org$)';
|
|
#'www\..+\.debian.org';
|
|
#'(\.de$)';
|
|
#'(ftp|www)\.(se|de|at|es|fr|uk|it|pl|nl|tr).debian.org$|\.de$';
|
|
#'ftp.wa.au';
|
|
#'www.mirror.ac.uk|dresden|claus|\.de.debian.org|erlan|berlin';
|
|
#'www.mirror.ac.uk';
|
|
#'www2';
|
|
#'ftp.(at|si).debian.org';
|
|
#'ftp.si.debian.org';
|
|
'.';
|
|
#'.debian.org';
|
|
|
|
my $tracedir_std_main = "project/trace";
|
|
my $masterfile_stdmain = "ftp-master.debian.org";
|
|
my $tracedir_std_cd = "project/trace";
|
|
my $masterfile_stdcd = "cdimage.debian.org";
|
|
my $tracedir_std_www = "mirror/timestamps";
|
|
my $masterfile_stdwww = "www-master.debian.org";
|
|
|
|
my $tracedir_std_old = "project/trace";
|
|
my $masterfile_stdold = "saens.debian.org"; # FIXME :)
|
|
my $tracedir_std_nonus = "project/trace";
|
|
my $masterfile_stdnonus = "non-us.debian.org";
|
|
|
|
my $archivUpdatePattern = "Archive-Update-in-Progress-";
|
|
|
|
my $masterlistURL = 'http://cvs.debian.org/*checkout*/webwml/english/mirror/Mirrors.masterlist?cvsroot=webwml';
|
|
|
|
my @sections = qw/old nonus/;
|
|
|
|
# order of protocols is important -> ftp is easier to parse for the upstream
|
|
# mirror list, so do this one first...
|
|
my %protocols =
|
|
(
|
|
old => [qw/ftp http rsync/],
|
|
nonus => [qw/ftp http rsync/],
|
|
);
|
|
|
|
my %addrs =
|
|
(
|
|
# 'debian.inf.tu-dresden.de' =>
|
|
# {
|
|
# main =>
|
|
# { path => '/debian',
|
|
# tracedir => $tracedir_std_main, mastertracefile => $masterfile_stdmain, },
|
|
# cd =>
|
|
# { path_http => '/debian-cd', path_ftp => '/debian-cd', patch_rsync => 'debian-cd', },
|
|
# },
|
|
# 'os.inf.tu-dresden.de' =>
|
|
# {
|
|
# main =>
|
|
# { path => '/debian',
|
|
# tracedir => $tracedir_std_main, mastertracefile => $masterfile_stdmain, },
|
|
# checkProtocol => [ 'http', ],
|
|
# cd =>
|
|
# { path_http => '/debian-cd'},
|
|
# },
|
|
);
|
|
|
|
my $debug = 1;
|
|
my $DisplayNonCheckedHosts = 0;
|
|
|
|
my $HtmlDir = "../www/archive";
|
|
my $HtmlFile = "status.html";
|
|
my $MasterFile = "master.list";
|
|
my $DataFile = "mirror.data";
|
|
my $DataFileIP = "mirror.data.ip";
|
|
|
|
my @arg_options = ("masterfile|m=s", \$MasterFile,
|
|
"datafile|d=s", \$DataFile,
|
|
"datafileip|i=s", \$DataFileIP,
|
|
"htmlfile|o=s", \$HtmlFile,
|
|
"displaynonchecked!", \$DisplayNonCheckedHosts,
|
|
);
|
|
|
|
# some mirrors have authenticated rsync access only although they're in
|
|
# the mirror list...
|
|
# do not let rsync pop up with a password prompt
|
|
$ENV{'RSYNC_PASSWORD'} = '';
|
|
|
|
umask 022;
|
|
my $MasterListRefreshTime = 24*3600; # 1 day
|
|
my $IPListRefreshTime = 2*24*2600; # 2 days
|
|
my $OutOfDateTime = 3600*24*2; # 2 days
|
|
my $connectionTimeout = 10; # secs
|
|
my $prog_rsync = "rsync --timeout=$connectionTimeout";
|
|
my %timestamps =
|
|
(
|
|
data_capture_start => 0,
|
|
data_capture_end => 0,
|
|
);
|
|
my $IPDataCaptureTime = 0;
|
|
|
|
my $ERRORMSGCUTBYTES = 200;
|
|
|
|
my %data;
|
|
my %IPs;
|
|
my (@errors_full, @errors_filt);
|
|
my %openedfile = ();
|
|
|
|
sub DBG {
|
|
print join("", @_) if $debug;
|
|
}
|
|
|
|
sub getTempFile {
|
|
$_ = `/bin/mktemp /tmp/mirstat.temp.XXXXXX`;
|
|
chomp;
|
|
$_;
|
|
}
|
|
|
|
sub getHtmlFullErrorFileName {
|
|
my $r;
|
|
if ($HtmlFile =~ /\.html$/) {
|
|
($r = $HtmlFile) =~ s/html$/full-errors.$&/i;
|
|
} else {
|
|
$r = $HtmlFile."full-errors.html";
|
|
}
|
|
$r;
|
|
}
|
|
|
|
sub rsyncErrorFilter {
|
|
my ($text) = @_;
|
|
# In rsync error messages normally only the last line is significant
|
|
(reverse split(/\n/, $text))[0];
|
|
}
|
|
|
|
sub getErrorNrFull {
|
|
my ($text) = @_;
|
|
my $i = 0;
|
|
for (; $i <= $#errors_full; $i++) {
|
|
return $i if ($errors_full[$i] eq $text);
|
|
}
|
|
$errors_full[$i] = $text;
|
|
$i;
|
|
}
|
|
|
|
sub getErrorNr {
|
|
my ($text, $protocol) = @_;
|
|
my $i = getErrorNrFull($text);
|
|
if ($protocol =~ /rsync/) {
|
|
$text = rsyncErrorFilter($text);
|
|
}
|
|
# trim text also in case it's too long
|
|
$errors_filt[$i] = substr($text, 0, $ERRORMSGCUTBYTES);
|
|
$i;
|
|
}
|
|
|
|
sub parseMasterData {
|
|
my ($host, $key, $val) = @_;
|
|
|
|
# print "$host $key $val\n";
|
|
$val =~ s,(.)/$,$1,;
|
|
|
|
if ($key =~ /Archive-/) {
|
|
$addrs{$host}{main}{mastertracefile} = $masterfile_stdmain;
|
|
$addrs{$host}{main}{tracedir} = $tracedir_std_main;
|
|
} elsif ($key =~ /CDImage-/) {
|
|
$addrs{$host}{cd}{mastertracefile} = $masterfile_stdcd;
|
|
$addrs{$host}{cd}{tracedir} = $tracedir_std_cd;
|
|
} elsif ($key =~ /WWW-/) {
|
|
$addrs{$host}{www}{mastertracefile} = $masterfile_stdwww;
|
|
$addrs{$host}{www}{tracedir} = $tracedir_std_www;
|
|
} elsif ($key =~ /Old-/) {
|
|
$addrs{$host}{old}{mastertracefile} = $masterfile_stdold;
|
|
$addrs{$host}{old}{tracedir} = $tracedir_std_old;
|
|
} elsif ($key =~ /NonUS-/) {
|
|
$addrs{$host}{nonus}{mastertracefile} = $masterfile_stdnonus;
|
|
$addrs{$host}{nonus}{tracedir} = $tracedir_std_nonus;
|
|
}
|
|
|
|
if ($key =~ /Archive-http/i) {
|
|
$addrs{$host}{main}{path_http} = $val;
|
|
} elsif ($key =~ /Archive-ftp/i) {
|
|
$addrs{$host}{main}{path_ftp} = $val;
|
|
} elsif ($key =~ /Archive-rsync/i) {
|
|
$addrs{$host}{main}{path_rsync} = $val;
|
|
} elsif ($key =~ /CDImage-http/i) {
|
|
$addrs{$host}{cd}{path_http} = $val;
|
|
} elsif ($key =~ /CDImage-ftp/i) {
|
|
$addrs{$host}{cd}{path_ftp} = $val;
|
|
} elsif ($key =~ /CDImage-rsync/i) {
|
|
$addrs{$host}{cd}{path_rsync} = $val;
|
|
} elsif ($key =~ /WWW-http/i) {
|
|
$addrs{$host}{www}{path_http} = $val;
|
|
} elsif ($key =~ /Old-http/i) {
|
|
$addrs{$host}{old}{path_http} = $val;
|
|
} elsif ($key =~ /Old-ftp/i) {
|
|
$addrs{$host}{old}{path_ftp} = $val;
|
|
} elsif ($key =~ /Old-rsync/i) {
|
|
$addrs{$host}{old}{path_rsync} = $val;
|
|
} elsif ($key =~ /NonUS-http/i) {
|
|
$addrs{$host}{nonus}{path_http} = $val;
|
|
} elsif ($key =~ /NonUS-ftp/i) {
|
|
$addrs{$host}{nonus}{path_ftp} = $val;
|
|
} elsif ($key =~ /NonUS-rsync/i) {
|
|
$addrs{$host}{nonus}{path_rsync} = $val;
|
|
}
|
|
# save all other info
|
|
$addrs{$host}{info}{$key} = $val;
|
|
}
|
|
|
|
sub parseMirrorsMasterList {
|
|
my $ctime = 0;
|
|
$ctime = (stat($MasterFile))[9] if -f $MasterFile;
|
|
if ($ctime + $MasterListRefreshTime < time) {
|
|
DBG("Getting new master mirror list\n");
|
|
open(F, "wget -q -O - '$masterlistURL' | tee $MasterFile |") or die $!;
|
|
} else {
|
|
open(F, $MasterFile) or die $!;
|
|
}
|
|
my $s = 0;
|
|
my ($host, $entryval, $entrykey) = (undef, undef, undef);
|
|
while (defined ($_=<F>)) {
|
|
chomp;
|
|
s/\s*$//;
|
|
if ($s == 0) { # looking for site
|
|
next if /^$/;
|
|
next if /^X-/;
|
|
next if /^\s\S/;
|
|
die "format error ($_)" unless /^Site:\s*(\S+)/;
|
|
$host = $1;
|
|
$s = 1;
|
|
} else {
|
|
if (/^$/) { # end of description
|
|
$s = 0;
|
|
parseMasterData($host, $entrykey, $entryval)
|
|
if (defined $entrykey);
|
|
$entrykey = undef;
|
|
} else {
|
|
if (/^\s+/) { # continued line (starting with \s's)
|
|
s/^\s*/ /;
|
|
$entryval .= $_;
|
|
} else {
|
|
parseMasterData($host, $entrykey, $entryval)
|
|
if (defined $entrykey);
|
|
|
|
($entrykey, $entryval) = split(/: */, $_, 2);
|
|
die "format error($_)" unless $entrykey && $entryval;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
close F;
|
|
}
|
|
|
|
sub getSecondsOfDatestring {
|
|
my ($datestring) = @_;
|
|
$datestring = (split(/\n/, $datestring))[0];
|
|
$_ = `date -d "$datestring" +%s 2>&1`;
|
|
chomp;
|
|
return "ERROR: $_" if $?;
|
|
$_;
|
|
}
|
|
|
|
# get output from http/ftp request
|
|
sub getData_ftp_http {
|
|
my ($url) = @_;
|
|
my $ua = LWP::UserAgent->new;
|
|
$ua->agent(" ");
|
|
$ua->timeout($connectionTimeout);
|
|
my $res = $ua->request(HTTP::Request->new(GET => $url));
|
|
return 'ERROR: ' . $res->status_line if $res->is_error;
|
|
my $d = $res->content;
|
|
chomp $d;
|
|
return $d;
|
|
}
|
|
|
|
# get file via rsync
|
|
sub getData_rsync_file {
|
|
my ($url) = @_;
|
|
my $tmpf = getTempFile();
|
|
my $d = `$prog_rsync $url $tmpf 2>&1`;
|
|
|
|
# check for error messages - yes, can return with $?==0 although
|
|
# we've got an error (@ERROR: access denied...)
|
|
if ($d =~ /^\@ERROR: /m) {
|
|
$d = 'ERROR: '.$d;
|
|
} elsif (!$?) {
|
|
# request succesful
|
|
$d = '';
|
|
open(D, $tmpf) || die $!;
|
|
while (defined ($_=<D>)) {
|
|
chomp;
|
|
$d .= $_;
|
|
}
|
|
close D;
|
|
} # fall through otherwise...
|
|
|
|
unlink $tmpf;
|
|
$d;
|
|
}
|
|
|
|
# get output from rsync request
|
|
sub getData_rsync_output {
|
|
my ($url) = @_;
|
|
my $d = `$prog_rsync '$url' 2>&1`;
|
|
$d = 'ERROR: '.$d if $?;
|
|
$d;
|
|
}
|
|
|
|
sub getFile {
|
|
my ($url) = @_;
|
|
if ($url =~ /^(ht|f)tp:/) {
|
|
return getData_ftp_http($url);
|
|
} elsif ($url =~ /^rsync:/) {
|
|
return getData_rsync_file($url);
|
|
} else {
|
|
die "INTERNAL ERROR: unknown protocol type!";
|
|
}
|
|
}
|
|
|
|
sub getDirListing {
|
|
my ($url) = @_;
|
|
if ($url =~ /^rsync:/) {
|
|
$url .= '/*' if ($url =~ /[^*]$/);
|
|
return getData_rsync_output($url);
|
|
} else {
|
|
$url .= '/' if $url !~ /\/$/;
|
|
return getData_ftp_http($url);
|
|
}
|
|
}
|
|
|
|
sub removeHTMLTags {
|
|
$_ = shift;
|
|
s/<.*?>//sg;
|
|
$_;
|
|
}
|
|
|
|
sub getPathForProtocol {
|
|
my ($host, $section, $protocol) = @_;
|
|
my $path = (defined $addrs{$host}{$section}{"path_$protocol"})?
|
|
$addrs{$host}{$section}{"path_$protocol"}:
|
|
$addrs{$host}{$section}{path};
|
|
$path = '/'.$path if (defined $path && $path !~ m,^/,);
|
|
$path;
|
|
}
|
|
|
|
sub checkUpdateInProgress {
|
|
my ($section) = @_;
|
|
($section eq 'www')?0:1;
|
|
}
|
|
|
|
sub checkIfUpdateIsInProgress {
|
|
my ($protocol, $host, $path, $section) = @_;
|
|
|
|
# we check if an archiv update is in progress
|
|
# (by simply getting the directory listing of the topmost dir)
|
|
my $r = getDirListing("$protocol://$host$path");
|
|
DBG($r, "\n");
|
|
$data{$host}{$section}{updateInProgess} =
|
|
($r =~ /$archivUpdatePattern/im)?1:0;
|
|
$data{$host}{$section}{$protocol} =
|
|
($r !~ /^ERROR: /m)?-1:getErrorNr($r, $protocol);
|
|
}
|
|
|
|
sub extractFileLinksFromDirHTMLListing {
|
|
my ($listing) = @_;
|
|
|
|
my @files;
|
|
while ($listing =~ s/href\s*=\s*"?(.*?)[^\/\w.\d-](.*)/$2/i) {
|
|
my $a = $1;
|
|
#$a = (reverse split(/\//, $a))[0] if $a =~ /\//;
|
|
next if $a =~ m,/,; # don't take directories
|
|
next if (!defined $a || $a eq '' || $a =~ /^(http|ftp|mailto|trace)$/i);
|
|
if ($a !~ /\/$/) {
|
|
push @files, $a
|
|
if ($a !~ /^\.$/ && $a !~ /^\.\.$/ && $a !~ /^\./ && $a !~ /\.$/);
|
|
}
|
|
}
|
|
@files;
|
|
}
|
|
|
|
sub extractFileLinksFromDirRsyncListing {
|
|
my ($listing) = @_;
|
|
my @files;
|
|
|
|
for my $l (split(/\n/, $listing)) {
|
|
next unless ($l =~ /^.[rwxsSXt-]{9}\s/);
|
|
(my $name = $l) =~ s/.*\s([^\s]+)$/$1/;
|
|
push @files, $name;
|
|
}
|
|
|
|
@files;
|
|
}
|
|
|
|
sub extractFileLinksFromDirFTPListing {
|
|
my ($listing) = @_;
|
|
my @files;
|
|
|
|
for (parse_dir($listing)) {
|
|
my ($name) = @$_;
|
|
push @files, $name;
|
|
}
|
|
@files;
|
|
}
|
|
|
|
sub getLinkFilesOutOfListing {
|
|
my ($protocol, $listing) = @_;
|
|
my @files;
|
|
if ($protocol eq 'rsync') {
|
|
return extractFileLinksFromDirRsyncListing($listing);
|
|
} elsif ($protocol eq 'http') {
|
|
return extractFileLinksFromDirHTMLListing($listing);
|
|
} elsif ($protocol eq 'ftp') {
|
|
return extractFileLinksFromDirFTPListing($listing);
|
|
} else {
|
|
print STDERR "not impl\n";
|
|
}
|
|
return ();
|
|
}
|
|
|
|
sub cleanOutNonMirrorTraceFiles {
|
|
my (@list) = @_;
|
|
|
|
my @nl;
|
|
for (@list) {
|
|
next if (/\.(html?|css)$/);
|
|
push @nl, $_;
|
|
}
|
|
@nl;
|
|
}
|
|
|
|
sub uniqueList {
|
|
my (@list) = @_;
|
|
|
|
my @nl;
|
|
my $d = '';
|
|
for (sort @list) {
|
|
push @nl, $_ if $d ne $_;
|
|
$d = $_;
|
|
}
|
|
@nl;
|
|
}
|
|
|
|
sub masterSet__ {
|
|
my ($t, $failret, $host, $section, $val) = @_;
|
|
return $failret unless defined $addrs{$host}{$section}{mastertracefile};
|
|
$data{$host}{$section}{$t}{$addrs{$host}{$section}{mastertracefile}}
|
|
= $val if defined $val;
|
|
$data{$host}{$section}{$t}{$addrs{$host}{$section}{mastertracefile}};
|
|
}
|
|
sub masterTimeString { return masterSet__('timestamps_str', '', @_); }
|
|
sub masterSeconds { return masterSet__('timestamps_sec', 0, @_); }
|
|
|
|
sub getUndefinedTimestampFile {
|
|
my ($host, $section) = @_;
|
|
foreach my $m (keys %{$data{$host}{$section}{timestamps_str}}) {
|
|
return $m unless defined $data{$host}{$section}{timestamps_str}{$m};
|
|
}
|
|
undef;
|
|
}
|
|
|
|
sub getWorkingProtocol {
|
|
my ($host, $section) = @_;
|
|
|
|
foreach my $p (@{$protocols{$section}}) {
|
|
next unless defined $data{$host}{$section}{$p};
|
|
return $p;
|
|
}
|
|
undef;
|
|
}
|
|
|
|
sub isProtocolHTTPWorking {
|
|
my ($host, $section) = @_;
|
|
|
|
return defined $data{$host}{$section}{'http'};
|
|
}
|
|
|
|
sub getHostInfo {
|
|
my ($hostname) = @_;
|
|
|
|
return 0 if defined $IPs{$hostname};
|
|
|
|
$? = 0; # huh, why is that needed?
|
|
my ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($hostname);
|
|
|
|
#print "HUUUU: $hostname $?\n";
|
|
return 0 if ($?);
|
|
|
|
foreach my $h ($hostname, $name, split(/\s+/, $aliases)) {
|
|
next if $h eq '' || defined $IPs{$h};
|
|
$IPs{$h} = [map { join(".", unpack('C4', $_)) } @addrs];
|
|
print "IP: $h: ", join(", ", map { join(".", unpack('C4', $_)) } @addrs), "\n";
|
|
}
|
|
1;
|
|
}
|
|
|
|
sub areHostsEqual {
|
|
my ($host1, $host2) = @_;
|
|
|
|
return 0 unless defined $IPs{$host1} && defined $IPs{$host2};
|
|
my @h1 = @{$IPs{$host1}};
|
|
my @h2 = @{$IPs{$host2}};
|
|
for (my $i = 0; $i <= $#h1; $i++) {
|
|
for (my $j = 0; $j <= $#h2; $j++) {
|
|
return 1 if $h1[$i] eq $h2[$j];
|
|
}
|
|
}
|
|
0;
|
|
}
|
|
|
|
sub getOfficialHostname {
|
|
my ($h, $section) = @_;
|
|
|
|
return $h if (grep(/^$h$/, keys %addrs));
|
|
return $h unless defined $IPs{$h};
|
|
for my $a (keys %addrs) {
|
|
next unless defined $IPs{$a};
|
|
foreach my $i (@{$IPs{$a}}) {
|
|
return $a if (grep(/^$i$/, @{$IPs{$h}}) &&
|
|
@{$IPs{$a}} == 1 && # NO DNS round robin entries...
|
|
defined $addrs{$a}{$section}{tracedir});
|
|
}
|
|
}
|
|
return $h;
|
|
}
|
|
|
|
sub doStep {
|
|
my ($host, $section, $protocol) = @_;
|
|
|
|
# get path since we can have protocol specific paths
|
|
my $path = getPathForProtocol($host, $section, $protocol);
|
|
return unless defined $path;
|
|
|
|
DBG(">>>> $host - $section - $protocol - $path\n");
|
|
|
|
unless (defined $data{$host}{$section}{timestamps_sec}) {
|
|
next unless (defined $addrs{$host}{$section}{tracedir});
|
|
my $pa = $path;
|
|
$pa .= '/' if ($pa !~ /\/$/);
|
|
$pa .= $addrs{$host}{$section}{tracedir};
|
|
my $listing = getDirListing("$protocol://$host$pa");
|
|
if ($listing !~ /^ERROR: /m) {
|
|
my @files = getLinkFilesOutOfListing($protocol, $listing);
|
|
@files = cleanOutNonMirrorTraceFiles(uniqueList(@files));
|
|
DBG("Got upstream mirrors (via $protocol): ".join(", ", @files), "\n");
|
|
|
|
#print STDERR "TODO: check for ", scalar @files, " == 1 --> client failure!\n";
|
|
|
|
# some badly configured servers return HTTP 200 codes even
|
|
# if they should return 404...
|
|
next unless (defined $addrs{$host}{$section}{mastertracefile});
|
|
if (grep(/^$addrs{$host}{$section}{mastertracefile}$/, @files)) {
|
|
$data{$host}{$section}{$protocol} = -1;
|
|
foreach my $h (@files) {
|
|
$data{$host}{$section}{timestamps_str}{$h} = undef;
|
|
$data{$host}{$section}{timestamps_sec}{$h} = undef;
|
|
}
|
|
} else {
|
|
# warn "Missing master file $addrs{$host}{$section}{mastertracefile} on $host\n";
|
|
if ($listing =~ /<html>/i) {
|
|
$listing = "ERROR: ".$listing if ($listing !~ /^ERROR: /);
|
|
$listing = removeHTMLTags($listing);
|
|
}
|
|
$data{$host}{$section}{$protocol} = getErrorNr($listing, $protocol);
|
|
}
|
|
|
|
} else {
|
|
$data{$host}{$section}{$protocol} = getErrorNr($listing, $protocol);
|
|
}
|
|
|
|
} elsif ((my $file = getUndefinedTimestampFile($host, $section)) &&
|
|
(!defined $data{$host}{$section}{$protocol} ||
|
|
$data{$host}{$section}{$protocol} == -1)) {
|
|
my $pa = $path;
|
|
$pa .= '/' if ($pa !~ /\/$/);
|
|
$pa .= $addrs{$host}{$section}{tracedir}.'/'.$file;
|
|
DBG("getting tracefile via $protocol://$host$pa\n");
|
|
my $d = getFile("$protocol://$host$pa");
|
|
DBG("output: $d\n");
|
|
|
|
# some badly configured servers return a HTTP code 200 even
|
|
# if they could not find a file and present a nicely formated
|
|
# error message
|
|
if (length($d) > 60) {
|
|
$d = "ERROR: ".$d if ($d !~ /^ERROR: /);
|
|
$d = removeHTMLTags($d);
|
|
}
|
|
if ($d !~ /^ERROR: /m) {
|
|
$data{$host}{$section}{$protocol} = -1;
|
|
$data{$host}{$section}{timestamps_str}{$file} = $d;
|
|
$data{$host}{$section}{timestamps_sec}{$file} = getSecondsOfDatestring($d);
|
|
if ($data{$host}{$section}{timestamps_sec}{$file} =~ /^ERROR: /) {
|
|
$data{$host}{$section}{timestamps_sec}{$file} = 0;
|
|
}
|
|
} else {
|
|
$data{$host}{$section}{$protocol} = getErrorNr($d, $protocol);
|
|
}
|
|
|
|
} elsif (!defined $data{$host}{$section}{updateInProgess} &&
|
|
checkUpdateInProgress($section)) {
|
|
DBG("Checking if update in progress\n");
|
|
checkIfUpdateIsInProgress($protocol, $host, $path, $section);
|
|
|
|
} else {
|
|
# done
|
|
DBG("done\n");
|
|
return 0;
|
|
}
|
|
1;
|
|
}
|
|
|
|
|
|
######################################################################
|
|
|
|
Getopt::Long::config("pass_through");
|
|
my $optret = GetOptions(@arg_options);
|
|
|
|
if (defined $ARGV[0] && $ARGV[0] eq 'get') {
|
|
|
|
parseMirrorsMasterList();
|
|
|
|
$timestamps{data_capture_start} = time();
|
|
|
|
foreach my $host (keys %addrs) {
|
|
next if ($host !~ /$hostpattern/);
|
|
|
|
foreach my $section (@sections) {
|
|
|
|
foreach my $protocol (@{$protocols{$section}}) {
|
|
next if (defined $addrs{$host}{checkProtocol} &&
|
|
!grep(/^$protocol$/, @{$addrs{$host}{checkProtocol}}));
|
|
|
|
# following steps:
|
|
# - get directory listing
|
|
# - if master-files not in dir-listing -> error
|
|
# - get all timestamp files from dir-listing
|
|
# - check if update in progress...
|
|
|
|
doStep($host, $section, $protocol);
|
|
|
|
|
|
} # foreach protocol
|
|
|
|
if (defined $data{$host}{$section}{timestamps_sec}) {
|
|
# ok, we've got at least one protocol that works
|
|
my $protocol = undef;
|
|
# find it
|
|
foreach (@{$protocols{$section}}) {
|
|
$protocol = $_, last
|
|
if (defined $data{$host}{$section}{$_} &&
|
|
$data{$host}{$section}{$_} == -1);
|
|
}
|
|
if (defined $protocol) {
|
|
while (doStep($host, $section, $protocol)) {}
|
|
} else {
|
|
print STDERR "BIG INTERNAL ERROR!\n";
|
|
}
|
|
}
|
|
|
|
} # foreach section (main, cd, www)
|
|
|
|
} # foreach host
|
|
|
|
# get the IPs of all hostnames to find hosts with more than one name
|
|
# (e.g. real name and debian.org alias)
|
|
|
|
|
|
if (open(I, $DataFileIP)) {
|
|
my $dat;
|
|
while (<I>) {
|
|
$dat .= $_;
|
|
}
|
|
close I;
|
|
eval $dat;
|
|
}
|
|
|
|
print "$IPDataCaptureTime + $IPListRefreshTime\n";
|
|
if ($IPDataCaptureTime + $IPListRefreshTime < time) {
|
|
print "IPs:\n";
|
|
foreach my $host (keys %addrs) {
|
|
print "$host\n";
|
|
getHostInfo($host);
|
|
}
|
|
foreach my $host (keys %data) {
|
|
print "$host\n";
|
|
getHostInfo($host);
|
|
foreach my $section (keys %{$data{$host}}) {
|
|
print " $section\n";
|
|
if (defined $data{$host}{$section}{timestamps_str}) {
|
|
foreach my $tsh (keys %{$data{$host}{$section}{timestamps_str}}) {
|
|
print " $tsh\n";
|
|
getHostInfo($tsh);
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
open(I, ">$DataFileIP") || die $!;
|
|
$Data::Dumper::Indent = 1;
|
|
$IPDataCaptureTime = time;
|
|
print I Data::Dumper->Dump
|
|
([$IPDataCaptureTime, \%IPs], [qw/IPDataCaptureTime *IPs/]);
|
|
close I;
|
|
}
|
|
|
|
open(A, ">$DataFile") || die $!;
|
|
$Data::Dumper::Indent = 1;
|
|
$timestamps{data_capture_end} = time();
|
|
print A Data::Dumper->Dump
|
|
([\%timestamps, \%addrs, \%data, \@errors_filt, \@errors_full],
|
|
[qw/*timestamps *addrs *data *errors_filt *errors_full/]);
|
|
close A;
|
|
|
|
} else {
|
|
|
|
open(A, "$DataFile") || die $!;
|
|
my $dat;
|
|
while (<A>) {
|
|
$dat .= $_;
|
|
}
|
|
close A;
|
|
eval $dat;
|
|
|
|
open(I, $DataFileIP) || die $!;
|
|
$dat = '';
|
|
while (<I>) {
|
|
$dat .= $_;
|
|
}
|
|
close I;
|
|
eval $dat;
|
|
|
|
DBG("Using data created between ",
|
|
scalar localtime $timestamps{data_capture_start}, " and ",
|
|
scalar localtime $timestamps{data_capture_end}, "\n");
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
####### create HTML file out of the generated data... ######
|
|
|
|
DBG("Creating HTML files ($HtmlDir/$HtmlFile)\n\n");
|
|
|
|
open(H, ">$HtmlDir/$HtmlFile") || die $!;
|
|
|
|
my $dts_s = (scalar gmtime $timestamps{data_capture_start})." UTC";
|
|
my $dts_e = (scalar gmtime $timestamps{data_capture_end})." UTC";
|
|
my $now_utc = (scalar gmtime time)." UTC";
|
|
print H <<EOF;
|
|
<html><head><title>Debian Mirror Checker</title></head>
|
|
<style type="text/css">
|
|
<!--
|
|
.inv
|
|
{
|
|
text-decoration: none;
|
|
color: black;
|
|
}
|
|
.inv:hover
|
|
{
|
|
text-decoration: underline;
|
|
color: blue;
|
|
}
|
|
.mastertime
|
|
{
|
|
text-decoration: none;
|
|
color: black;
|
|
}
|
|
.outofdate
|
|
{
|
|
color: brown;
|
|
text-decoration: none;
|
|
}
|
|
.misplaced
|
|
{
|
|
color: red;
|
|
text-decoration: none;
|
|
}
|
|
.misplaced:hover
|
|
{
|
|
text-decoration: underline;
|
|
}
|
|
-->
|
|
</style>
|
|
<body bgcolor="white">
|
|
<TABLE border="0" width="100%" cellpadding="3" cellspacing="0" align="center" summary="">
|
|
<TR>
|
|
<TD>
|
|
<A HREF="http://www.debian.org/logos/">
|
|
<IMG src="http://www.debian.org/Pics/logo-50.jpg" border="0" hspace="0" vspace="0" alt="" width="50" height="61"></A>
|
|
<IMG src="http://www.debian.org/Pics/debian.jpg" border="0" hspace="0" vspace="0" alt="Debian Project" width="179" height="61">
|
|
</TD>
|
|
<td align="right" style="font-size: 75%">
|
|
Data capturing time window:<br>$dts_s<br> - $dts_e<br>
|
|
HTML-file creation time: $now_utc
|
|
</td>
|
|
</TR>
|
|
</TABLE>
|
|
<h2 align="center">Debian Mirror Checker</h2>
|
|
EOF
|
|
|
|
sub validSection {
|
|
my ($host, $sect) = @_;
|
|
return 1 if (defined $addrs{$host}{$sect}{path});
|
|
foreach (@{$protocols{$sect}}) {
|
|
return 1 if (defined $addrs{$host}{$sect}{"path_$_"});
|
|
}
|
|
0;
|
|
}
|
|
|
|
use constant TRACE_NO_MASTERFILE => 1;
|
|
use constant TRACE_TIMESTAMPS_BEFORE_MASTER => 2;
|
|
use constant TRACE_INVALID_DATES => 3;
|
|
use constant TRACE_NOT_DOWNLOADABLE => 4;
|
|
use constant TRACE_NO_PRIMARY => 5;
|
|
use constant TRACE_NO_SECONDARY => 6;
|
|
use constant TRACE_NO_TRACEFILE_FOR_OWN_MIRROR => 7;
|
|
use constant TRACE_NO_TRACEFILES_AT_ALL => 8;
|
|
|
|
my %TraceTypeText =
|
|
(
|
|
&TRACE_NO_MASTERFILE =>
|
|
'No master file found',
|
|
&TRACE_TIMESTAMPS_BEFORE_MASTER =>
|
|
'Older (non-valid) timestamp files found',
|
|
&TRACE_INVALID_DATES =>
|
|
'Timestamp files contain invalid dates',
|
|
&TRACE_NOT_DOWNLOADABLE =>
|
|
'Trace files are not downloadable',
|
|
&TRACE_NO_PRIMARY =>
|
|
'Mirror lacks trace files from their upstream, it is not a primary',
|
|
&TRACE_NO_SECONDARY =>
|
|
'Mirror lacks trace files from their upstream, it is not a secondary',
|
|
&TRACE_NO_TRACEFILE_FOR_OWN_MIRROR =>
|
|
'The local trace file is missing',
|
|
&TRACE_NO_TRACEFILES_AT_ALL =>
|
|
'There are no trace files at all',
|
|
);
|
|
|
|
use constant MIRROR_PRIMARY => 1;
|
|
use constant MIRROR_SECONDARY => 2;
|
|
use constant MIRROR_LEAF => 3;
|
|
use constant MIRROR_UNKNOWN => 4;
|
|
|
|
my %mirrorHTMLIDs =
|
|
(
|
|
&MIRROR_PRIMARY => '<b>P</b>',
|
|
&MIRROR_SECONDARY => '<b>S</b>',
|
|
&MIRROR_LEAF => 'L',
|
|
&MIRROR_UNKNOWN => '?',
|
|
);
|
|
my %mirrorTypes =
|
|
(
|
|
'Push-Primary' => MIRROR_PRIMARY,
|
|
'Push-Secondary' => MIRROR_SECONDARY,
|
|
'leaf' => MIRROR_LEAF,
|
|
);
|
|
|
|
sub getMirrorType {
|
|
my ($host) = @_;
|
|
return $mirrorTypes{$addrs{$host}{info}{Type}}
|
|
if defined $addrs{$host}{info}{Type} and
|
|
defined $mirrorTypes{$addrs{$host}{info}{Type}};
|
|
# return $addrs{$host}{info}{Type}
|
|
# if defined $addrs{$host}{info}{Type};
|
|
return MIRROR_UNKNOWN;
|
|
}
|
|
|
|
sub getMirrorHTMLIDs {
|
|
my ($host) = @_;
|
|
return $mirrorHTMLIDs{getMirrorType($host)};
|
|
}
|
|
|
|
|
|
sub addTraceEntry {
|
|
my ($host, $section, $entry) = @_;
|
|
push @{$data{$host}{$section}{tracestat}}, $entry;
|
|
}
|
|
|
|
sub getTraceEntries {
|
|
my ($host, $section) = @_;
|
|
return () unless defined $data{$host}{$section}{tracestat};
|
|
@{$data{$host}{$section}{tracestat}};
|
|
}
|
|
|
|
sub isTraceEntry {
|
|
my ($host, $section, $nr) = @_;
|
|
|
|
return 0 unless defined $data{$host}{$section}{tracestat};
|
|
foreach my $t (@{$data{$host}{$section}{tracestat}}) {
|
|
return 1 if $nr == $t;
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
sub computeTraceStates {
|
|
|
|
foreach my $section (@sections) {
|
|
foreach my $host (keys %data) {
|
|
next unless defined $data{$host}{$section};
|
|
|
|
# TRACE_NO_TRACEFILES_AT_ALL
|
|
addTraceEntry($host, $section, TRACE_NO_TRACEFILES_AT_ALL)
|
|
unless defined $data{$host}{$section}{timestamps_str};
|
|
|
|
# TRACE_NO_MASTERFILE
|
|
# TRACE_TIMESTAMPS_BEFORE_MASTER
|
|
my $ms = masterSeconds($host, $section);
|
|
if (!defined $ms || $ms == 0) {
|
|
addTraceEntry($host, $section, TRACE_NO_MASTERFILE);
|
|
} else {
|
|
foreach my $k (keys %{$data{$host}{$section}{timestamps_sec}}) {
|
|
if (defined $data{$host}{$section}{timestamps_sec}{$k} &&
|
|
$data{$host}{$section}{timestamps_sec}{$k} != 0 &&
|
|
$data{$host}{$section}{timestamps_sec}{$k} < $ms) {
|
|
addTraceEntry($host, $section, TRACE_TIMESTAMPS_BEFORE_MASTER);
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
|
|
# TRACE_INVALID_DATES
|
|
foreach my $k (keys %{$data{$host}{$section}{timestamps_sec}}) {
|
|
if (defined $data{$host}{$section}{timestamps_sec}{$k} &&
|
|
$data{$host}{$section}{timestamps_sec}{$k} == 0) {
|
|
addTraceEntry($host, $section, TRACE_INVALID_DATES);
|
|
last;
|
|
}
|
|
}
|
|
|
|
# TRACE_NOT_DOWNLOADABLE
|
|
# not implemented yet...
|
|
|
|
my $mirror_type = getMirrorType($host);
|
|
my $credit;
|
|
# TRACE_NO_PRIMARY
|
|
if ($mirror_type != MIRROR_PRIMARY) {
|
|
$credit = 1;
|
|
$credit++ if (defined $ms && $ms != 0);
|
|
$credit++
|
|
if (defined $data{$host}{$section}{timestamps_str}{$host});
|
|
addTraceEntry($host, $section, TRACE_NO_PRIMARY)
|
|
if (scalar keys %{$data{$host}{$section}{timestamps_str}} <
|
|
$credit);
|
|
}
|
|
|
|
|
|
# TRACE_NO_SECONDARY
|
|
if ($mirror_type == MIRROR_SECONDARY) {
|
|
$credit = 1;
|
|
$credit++ if (defined $ms && $ms != 0);
|
|
$credit++
|
|
if (defined $data{$host}{$section}{timestamps_str}{$host});
|
|
addTraceEntry($host, $section, TRACE_NO_SECONDARY)
|
|
if (scalar keys %{$data{$host}{$section}{timestamps_str}} <
|
|
$credit);
|
|
}
|
|
|
|
# TRACE_NO_TRACEFILE_FOR_OWN_MIRROR
|
|
my $bo = defined $data{$host}{$section}{timestamps_str}{$host};
|
|
foreach my $h (keys %{$data{$host}{$section}{timestamps_str}}) {
|
|
last if $bo;
|
|
$bo = 1 if getOfficialHostname($h, $section) eq $host;
|
|
}
|
|
addTraceEntry($host, $section, TRACE_NO_TRACEFILE_FOR_OWN_MIRROR)
|
|
unless $bo;
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
sub printSectionInfo {
|
|
my $sect = shift;
|
|
my $i = 1;
|
|
my $master_type = ($sect eq 'www')?'www':'ftp';
|
|
|
|
print H "<h2><a name=\"sect_$sect\">Archive: $sect</h2>\n\n<ul>\n";
|
|
|
|
my $oldtime = undef;
|
|
for my $host (sort {my ($aa, $bb) =
|
|
(masterSeconds($a, $sect), masterSeconds($b, $sect));
|
|
((defined $bb)?$bb:0) <=> ((defined $aa)?$aa:0)} keys %data) {
|
|
next unless (defined $data{$host}{$sect});
|
|
next unless validSection($host, $sect);
|
|
|
|
if ($openedfile{$host}++ < 2) { # hasn't been opened before
|
|
if (-f "$HtmlDir/$host.html") {
|
|
unlink "$HtmlDir/$host.html" or die "can't remove $HtmlDir/$host.html: $!";
|
|
}
|
|
}
|
|
open M, ">>$HtmlDir/$host.html" or die "can't write to $HtmlDir/$host.html: $!";
|
|
if ($openedfile{$host}++ < 2) { # hasn't been opened before
|
|
print M "<html>\n<head><title>Debian Mirror Checker: $host</title></head>\n<body>\n\n";
|
|
print M "<h1 align=center>Debian mirror $host</h1>\n";
|
|
}
|
|
|
|
print M "<h2><a name=\"sect_$sect\">Archive: $sect</h2>\n\n";
|
|
|
|
my $ms = masterSeconds($host, $sect);
|
|
if (defined $ms) {
|
|
$i++
|
|
if (defined $oldtime && $oldtime > $ms);
|
|
$oldtime = $ms;
|
|
}
|
|
|
|
print H "<li>$i...<a href=\"$host.html#sect_$sect\">$host</a> ";
|
|
|
|
print M "<p>Level of freshness: $i</p>\n";
|
|
|
|
print H " [".getMirrorHTMLIDs($host)."] ";
|
|
|
|
die "can't find Type for $host!" unless defined $addrs{$host}{info}{Type};
|
|
print M "<p>Type: ".$addrs{$host}{info}{Type}."</p>\n";
|
|
|
|
# master time
|
|
my $timestr = masterTimeString($host, $sect);
|
|
print M "<p>Master time stamp: ";
|
|
unless (defined $timestr) {
|
|
print H ' [<span class="outofdate">master time stamp N/A</span>] ';
|
|
print M '<div class="outofdate">N/A</div>';
|
|
} elsif ($timestr eq '') {
|
|
print H ' [<span class="outofdate">master time stamp missing!</span>] ';
|
|
print M '<div class="outofdate">No master file!</div>';
|
|
} else {
|
|
my $outofdateclass =
|
|
($ms < $timestamps{data_capture_start} - $OutOfDateTime)?
|
|
'class="outofdate"':'class="mastertime"';
|
|
if (defined (my $p = getWorkingProtocol($host, $sect))) {
|
|
my $path = getPathForProtocol($host, $sect, $p);
|
|
$timestr = "<a $outofdateclass ".
|
|
"href=\"$p://$host$path/$addrs{$host}{$sect}{tracedir}/".
|
|
"$addrs{$host}{$sect}{mastertracefile}\">$timestr</a>";
|
|
}
|
|
print M "$timestr";
|
|
}
|
|
|
|
# trace status
|
|
my @ts = getTraceEntries($host, $sect);
|
|
if (@ts and defined $ms) {
|
|
print H " [<a href=\"#tracelegend\">trace</a>: ".join(',', @ts)."] ";
|
|
print M "<p>Trace status:\n<ul>";
|
|
foreach my $traceerror (@ts) {
|
|
print M "<li>$traceerror: $TraceTypeText{$traceerror}\n";
|
|
}
|
|
print M "</ul>\n";
|
|
}
|
|
|
|
# Update in progress
|
|
if (checkUpdateInProgress($sect)) {
|
|
if ((defined $data{$host}{$sect}{updateInProgess} &&
|
|
$data{$host}{$sect}{updateInProgess} == 1)) {
|
|
print H " [UIP!] ";
|
|
print M "<p>Checked while update was in progress!\n";
|
|
}
|
|
}
|
|
print M "<p>Protocols:</p>\n<ul>\n";
|
|
foreach my $p (@{$protocols{$sect}}) {
|
|
my $pt; my $pth;
|
|
if (defined $data{$host}{$sect}{$p}) {
|
|
my $err = $data{$host}{$sect}{$p};
|
|
my $path = getPathForProtocol($host, $sect, $p);
|
|
my $link = "$p://$host$path";
|
|
$link .= '/' if $link !~ /\/$/;
|
|
if ($err == -1) {
|
|
$pt = "<li>$p: <a class=\"inv\" href=\"$link\">ok</a>";
|
|
$pth = "";
|
|
} else {
|
|
$err++;
|
|
$pt = "<li>$p: <b><a class=\"inv\" href=\"$link\">bad</a></b>:\n";
|
|
$pth = " <b>[$p bad]</b> ";
|
|
my $s = $errors_full[$err-1];
|
|
if (defined $s and $s ne "") {
|
|
$s =~ s/\n/<br>$&/gs;
|
|
$pt .= "<p>$s</p>\n";
|
|
} else {
|
|
$pt .= "<p>No error text!</p>\n";
|
|
}
|
|
}
|
|
} else {
|
|
$pt = "";
|
|
$pth = "";
|
|
}
|
|
print M "$pt";
|
|
print H "$pth";
|
|
}
|
|
print H "</li>\n";
|
|
print M "</ul>\n";
|
|
if ($sect eq $sections[-1]) { # last section
|
|
print M "</body>\n</html>\n";
|
|
}
|
|
close M;
|
|
}
|
|
|
|
# ok, now the non-checked ones
|
|
if (0 && $DisplayNonCheckedHosts) {
|
|
for my $host (sort keys %addrs) {
|
|
next if (defined $data{$host} && defined $data{$host}{$sect});
|
|
next unless validSection($host, $sect);
|
|
|
|
print H "<tr><td> </td><td>$host</td><td>".getMirrorHTMLIDs($host)."</td>\n";
|
|
print H "<td> -- not checked -- </td>";
|
|
print H "<td> </td>" if checkUpdateInProgress($sect);
|
|
foreach my $p (@{$protocols{$sect}}) {
|
|
if (defined $addrs{$host}{$sect}{"path_".$p}) {
|
|
my $url = "$p://$host".$addrs{$host}{$sect}{"path_$p"};
|
|
$url .= '/' if $url !~ /\/$/;
|
|
print H "<td><a class=\"inv\" href=\"$url\">A</a></td>";
|
|
} else {
|
|
print H "<td> </td>";
|
|
}
|
|
}
|
|
print H "</tr>\n";
|
|
}
|
|
}
|
|
print H "</ul>\n";
|
|
}
|
|
|
|
sub printHierarchyList {
|
|
my ($section, $pad, $z) = @_;
|
|
|
|
print H " "x$pad, "<ul>\n";
|
|
foreach (keys %$z) {
|
|
next if $_ eq '__count__';
|
|
my $rs = '';
|
|
$rs .= " class=\"misplaced\""
|
|
if (isTraceEntry($_, $section, TRACE_NO_PRIMARY) ||
|
|
isTraceEntry($_, $section, TRACE_NO_SECONDARY));
|
|
print H " "x($pad+1), "<li$rs>$_",
|
|
($$z{$_}{__count__} > 1)?" ($$z{$_}{__count__})":'', "</li>\n";
|
|
|
|
printHierarchyList($section, $pad+1, $$z{$_}) if keys %{$$z{$_}} > 1;
|
|
}
|
|
print H " "x$pad, "</ul>\n";
|
|
}
|
|
|
|
sub constructMatrix {
|
|
my ($y, $x, $matrix, $hosts, %z) = @_;
|
|
my $ysum=0;
|
|
foreach my $z (keys %z) {
|
|
next if $z eq '__count__';
|
|
#print "II (",$y+$ysum,", $x): ", " "x$x, $z{$z}{'__count__'}, " $z\n";
|
|
$matrix->[$y+$ysum][$x] = { "__count__" => $z{$z}{'__count__'}, host => $z};
|
|
$hosts->[$y+$ysum] = $z;
|
|
my $i = 1;
|
|
for ($i = 1; $i < $z{$z}{'__count__'}; $i++) {
|
|
$matrix->[$y+$ysum+$i][$x] = { "__count__" => 0};
|
|
}
|
|
my $childsum = constructMatrix($y+$ysum, $x+1, $matrix, $hosts, %{$z{$z}});
|
|
|
|
if ($childsum) {
|
|
foreach my $pad (($childsum)..($z{$z}{'__count__'}-1)) {
|
|
unless (defined $matrix->[$y+$ysum+$pad][$x+1]) {
|
|
$matrix->[$y+$ysum+$pad][$x+1] = { "__count__" => 0, host => '' };
|
|
#print "PP (",$y+$ysum+$pad,", ", $x+1, "): ", " "x$x, $z{$z}{'__count__'}, "\n";
|
|
$hosts->[$y+$ysum+$pad] = $z;
|
|
}
|
|
}
|
|
}
|
|
$ysum += $z{$z}{__count__};
|
|
}
|
|
#print "SUM: $ysum\n";
|
|
$ysum;
|
|
}
|
|
|
|
sub printHierarchies {
|
|
my ($section) = @_;
|
|
|
|
my %a;
|
|
my $longest = 0;
|
|
my $pa;
|
|
foreach my $host (keys %data) {
|
|
my $mts = masterTimeString($host, $section);
|
|
next if !defined $mts || $mts eq '';
|
|
if (defined $data{$host}{$section}{timestamps_sec} ) {
|
|
my @tmp =
|
|
sort { ($data{$host}{$section}{timestamps_sec}{$a} || 0xffffffff)
|
|
<=> ($data{$host}{$section}{timestamps_sec}{$b} || 0xffffffff) }
|
|
keys %{$data{$host}{$section}{timestamps_sec}};
|
|
my $ms = masterSeconds($host, $section);
|
|
$ms = 0 unless defined $ms;
|
|
|
|
#print STDERR "Unoff: ", join(", ", @tmp), "\n";
|
|
my @tmpoff = map { getOfficialHostname($_, $section) } @tmp;
|
|
#print STDERR "Off: ", join(", ", @tmpoff), "\n";
|
|
$longest = @tmp if $longest < @tmp;
|
|
$pa = \%a;
|
|
push @tmp, $host;
|
|
push @tmpoff, $host;
|
|
for (my $t = 0; $t <= $#tmp; $t++) {
|
|
next
|
|
if (defined $data{$host}{$section}{timestamps_sec}{$tmp[$t]} &&
|
|
$data{$host}{$section}{timestamps_sec}{$tmp[$t]} < $ms);
|
|
next if ($t < $#tmp && areHostsEqual($tmp[$t], $tmp[$t+1]));
|
|
|
|
#print "$tmpoff[$t] ";
|
|
$pa->{$tmpoff[$t]} = {} unless defined $pa->{$tmpoff[$t]};
|
|
$pa->{$tmpoff[$t]}{__count__}++;
|
|
$pa = $pa->{$tmpoff[$t]};
|
|
}
|
|
#print "\n";
|
|
}
|
|
}
|
|
|
|
#$Data::Dumper::Indent = 1;
|
|
#print Data::Dumper->Dump([\%a], ['*a']), "\n";
|
|
|
|
my @matrix = ();
|
|
my @hosts = ();
|
|
constructMatrix(0, 0, \@matrix, \@hosts, %a);
|
|
|
|
#$Data::Dumper::Indent = 1;
|
|
#print Data::Dumper->Dump([\@matrix], ['*matrix']), "\n";
|
|
|
|
#print join("_", map { (defined)?$_:'U' }@hosts), "\n";
|
|
|
|
my $maxwidth = 0;
|
|
for (my $y=0; $y <= $#matrix; $y++ ) {
|
|
$maxwidth = @{$matrix[$y]} if @{$matrix[$y]} > $maxwidth;
|
|
}
|
|
print H "<table style=\"font-size: 60%\" align=\"center\" border=\"1\">\n";
|
|
print H "<tr>";
|
|
my @headertitles = qw(Host Master Primary Secondary/Leaf Leaf...);
|
|
$maxwidth = @headertitles-1 if @headertitles <= $maxwidth;
|
|
for (0..$maxwidth) {
|
|
print H "<th>$headertitles[$_]</th>";
|
|
}
|
|
print H "</tr>\n";
|
|
|
|
for (my $y=0; $y <= $#matrix; $y++ ){
|
|
# we prefer HTTP for links
|
|
my $p = 'http';
|
|
$p = getWorkingProtocol($hosts[$y], $section)
|
|
if (!isProtocolHTTPWorking($hosts[$y], $section));
|
|
next unless defined $p;
|
|
|
|
print H " <tr>\n <td><i>";
|
|
my $url = "$p://".$hosts[$y].getPathForProtocol($hosts[$y], $section, $p);
|
|
$url .= '/' if $url !~ /\/$/;
|
|
print H "<a class=\"inv\" href=\"$url\">",
|
|
((defined $hosts[$y])?$hosts[$y]:' '), "</a>";
|
|
print H "</i></td>\n";
|
|
|
|
for (my $x=0; $x < @{$matrix[$y]}; $x++) {
|
|
if (defined $matrix[$y][$x]) {
|
|
if ($matrix[$y][$x]{__count__}) {
|
|
my $host = $matrix[$y][$x]{host};
|
|
my $count = $matrix[$y][$x]{__count__};
|
|
my $td;
|
|
if (defined ($p = getWorkingProtocol($host, $section))) {
|
|
$p = 'http' if isProtocolHTTPWorking($host, $section);
|
|
$td = $addrs{$host}{$section}{tracedir};
|
|
$url = "$p://".$host.getPathForProtocol($host, $section, $p).'/'.$td;
|
|
$url .= '/' if $url !~ /\/$/;
|
|
}
|
|
my $rs = '';
|
|
my $as = '';
|
|
$rs .= " rowspan=\"$count\"" if $count > 1;
|
|
if (isTraceEntry($host, $section, TRACE_NO_PRIMARY) ||
|
|
isTraceEntry($host, $section, TRACE_NO_SECONDARY)) {
|
|
$as = ' class="misplaced"';
|
|
$rs .= $as if !defined $td;
|
|
} else {
|
|
$as .= ' class="inv"';
|
|
}
|
|
print H
|
|
" <td$rs>", (defined $td)?"<a$as href=\"$url\">":'',
|
|
($count > 1)?($count.'-'):'', $host,
|
|
(defined $td)?'</a>':'', "</td>\n"
|
|
|
|
} elsif (defined $matrix[$y][$x]{host}) {
|
|
print H " <td> <----- </td>\n";
|
|
}
|
|
}
|
|
}
|
|
print H " </tr>\n";
|
|
}
|
|
print H "</table>\n";
|
|
|
|
print H "<p> </p>\n";
|
|
print H "<div style=\"font-size: 90%\">\n";
|
|
printHierarchyList($section, 0, \%a);
|
|
print H "</div>\n";
|
|
}
|
|
|
|
## ####### ####### ###### # #####
|
|
|
|
print H "<p align=\"center\">".join(", ", map {"<a href=\"#sect_$_\">$_</a>" } @sections);
|
|
|
|
computeTraceStates();
|
|
|
|
foreach my $sect (@sections) {
|
|
print H "<p align=\"center\"><a href=\"#legend\">see legend</a></p>";
|
|
printSectionInfo($sect);
|
|
print H '<p> </p>';
|
|
# printHierarchies($sect);
|
|
}
|
|
|
|
# legend
|
|
print H <<EOF;
|
|
<h3><a name="legend">Legend</a></h3>
|
|
<table border="0">
|
|
<tr>
|
|
<td valign="top">UIP!</td>
|
|
<td>Archive_update_in_progress file found</td>
|
|
</tr>
|
|
<tr>
|
|
<td valign="top">T</td>
|
|
<td>Type:
|
|
<ul>
|
|
<li>P: Push-Primary
|
|
<li>S: Push-Secondary
|
|
<li>L: Leaf
|
|
<li>?: not in DB (will be leaf, of course)
|
|
</ul>
|
|
</td>
|
|
</tr>
|
|
</table>
|
|
EOF
|
|
|
|
print H "<p><a name=\"tracelegend\">Trace errors</a>:\n<table>\n";
|
|
foreach my $k (keys %TraceTypeText) {
|
|
print H "<tr><td>$k: </td><td>$TraceTypeText{$k}</td></tr>\n";
|
|
}
|
|
print H "</table></p>\n";
|
|
|
|
print H <<EOF;
|
|
<hr noshade size="1">
|
|
HostPattern: $hostpattern
|
|
|
|
</body>
|
|
</html>
|
|
EOF
|
|
close H;
|