-#!/usr/bin/perl -w
-#
+#! /usr/bin/perl -w
+
# Copyright (c) 2003 Henk Penning, all rights reserved.
# penning@cs.uu.nl, http://www.cs.uu.nl/staff/henkp.html
-# Version 1.1 was donated to the Apache Software Foundation 2003 Jan 28
-# $Id: mirmon,v 1.37 2006/12/04 15:16:11 henkp Exp henkp $
+# Version 1.1 was donated to the Apache Software Foundation 2003 Jan 28.
# Permission is hereby granted, free of charge, to any person obtaining a
# copy of this software and associated documentation files (the "Software"),
# to deal in the Software without restriction, including without limitation
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
# DEALINGS IN THE SOFTWARE.
#
-# Thanks to Klaus Heinz <heinz@NetBSD.org> for sugestions ao htm_head
-my $PRG = 'mirmon';
-my $VER = '$Id: mirmon,v 1.37 2006/12/04 15:16:11 henkp Exp henkp $';
-use strict;
-use IO::Pipe;
-use IO::Select;
-use Net::hostent;
-my $DEF_CNF = "/etc/$PRG.conf";
-my %CNF = qw( timeout 300
- max_probes 25
- min_poll 1h
- max_poll 4h
- min_sync 1d
- max_sync 2d
- list_style plain
- put_histo top
- randomize 1
-);
-my @REQ_KEYS = qw( web_page state countries mirror_list probe
- project_name project_url icons
-);
-my @OPT_KEYS =
- qw( project_logo min_poll min_sync max_sync list_style htm_top htm_foot
- htm_head put_histo
-);
-my %CNF_KEYS;
-for ( @REQ_KEYS, @OPT_KEYS, keys %CNF ) { $CNF_KEYS{$_}++; }
-my $TIM_PAT = '^(\d+)([smhd])$';
-my @LIST_STYLE = qw(plain apache);
-my @GET_OPTS = qw(all update);
-my @PUT_HGRAM = qw(top bottom nowhere);
-my $HIST = 14;
-my %APA_TYPES = ();
-for (qw(backup ftp http)) { $APA_TYPES{$_}++; }
-my $prog = substr( $0, rindex( $0, '/' ) + 1 );
-my $Usage = <<USAGE ;
-Usage: $prog [ -v ] [ -q ] [ -t timeout ] [ -get opt ] [ -c conf ]
-option v : be verbose
-option q : be quiet
-option t : set timeout [ default $CNF{timeout} ] ;
-option get : 'all' : probe all sites
- : 'update' : probe a selection of the sites (see doc)
-option c : configuration file [ default $DEF_CNF ]
--------------------------------------------------------------------
-Documentation : the program contains 'pod' style documentation.
-Extract the doc with 'pod2text $prog' or 'pod2html $prog OUT', etc.
--------------------------------------------------------------------
-USAGE
-sub Usage { die "$_[0]$Usage"; }
-sub Error { die "$prog: $_[0]\n"; }
-sub Warn { warn "$prog: $_[0]\n"; }
-# usage: &GetOptions(ARG,ARG,..) defines $opt_ID as 1 or user spec'ed value
-# usage: &GetOptions(\%opt,ARG,ARG,..) defines $opt{ID} as 1 or user value
-# ARG = 'ID' | 'ID=SPC' | 'ID:SPC' for no-arg, required-arg or optional-arg
-# ID = perl identifier
-# SPC = i|f|s for integer, fixedpoint real or string argument
-use Getopt::Long;
-Getopt::Long::config('no_ignore_case');
-# Usage() unless GetOptions() ;
-my %opt = ();
-Usage() unless GetOptions( \%opt, 'v', 'q', 't=i', 'get=s', 'c=s' );
-Usage("Arg count\n") unless @ARGV >= 0;
-my %WGT;
-my $GET = IO::Select->new();
-my %URL;
-my %RES;
-my %OLD;
-my %LST;
-my %CCS;
-my %HREF;
-# <META HTTP-EQUIV=Expires CONTENT="Tue, 04 Dec 1993 21:29:02 GMT">
-sub exp_date {
- my @day = qw(Sun Mon Tue Wed Thu Fri Sat);
- my @mon = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
- my @gmt = gmtime time + 3600;
- sprintf "%s, %02d %s %4d %02d:%02d:%02d GMT", $day[ $gmt[6] ], $gmt[3],
- $mon[ $gmt[4] ], $gmt[5] + 1900, @gmt[ 2, 1, 0 ];
-}
-sub find_conf {
- return $opt{c} if $opt{c};
- my $HOME = ( getpwuid $< )[7] or Error "can get homedir '$<' ($!)";
- my @LIST = ( "$PRG.conf", "$HOME/.$PRG.conf", $DEF_CNF );
- for my $conf (@LIST) { return $conf if -f $conf; }
- Error sprintf "can't find a config file :\n %s", join "\n ", @LIST;
-}
-sub show_conf {
- print "vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv\n";
- for my $key ( sort keys %CNF ) {
- next if $key =~ m/^_/;
- print "show_conf : $key = '$CNF{$key}'\n";
- }
- for my $key ( sort keys %HREF ) {
- printf "show_conf : for site '%s' use instead\n '%s'\n", $key,
- $HREF{$key}
- if $opt{v};
- }
- printf "show_conf : included '%s'\n", join "', '", @{ $CNF{_include} };
- print "^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n";
-}
-sub get_conf;
-sub get_conf {
- my $FILE = shift;
- if ( grep $_ eq $FILE, @{ $CNF{_include} } ) {
- Error "already included : '$FILE'";
- }
- else { push @{ $CNF{_include} }, $FILE; }
- open FILE, $FILE or Error "can't open '$FILE' ($!)";
- my $CONF = join "\n", grep /./, <FILE>;
- close FILE;
- $CONF =~ s/\t/ /g; # replace tabs
- $CONF =~ s/^[+ ]+//; # delete leading space, plus
- $CONF =~ s/\n\n\s+/ /g; # glue continuation lines
- $CONF =~ s/\n\n\+\s+//g; # glue concatenation lines
- $CONF =~ s/\n\n\./\n/g; # glue concatenation lines
- chop $CONF;
- print "--$CONF--\n" if $opt{d};
- for ( grep !/^#/, split /\n\n/, $CONF ) {
- my ( $key, $val ) = split ' ', $_, 2;
- $val = '' unless defined $val;
- print "conf '$FILE' : key '$key', val '$val'\n" if $opt{d};
- if ( exists $CNF_KEYS{$key} ) { $CNF{$key} = $val; }
- elsif ( $key eq 'site_url' ) {
- my ( $site, $url ) = split ' ', $val;
- $url .= '/' unless $url =~ m!/$!;
- $HREF{ lc $site } = $url;
- printf "config : for site '%s' use instead\n '%s'\n", $site, $url
- if $opt{v};
- }
- elsif ( $key eq 'env' ) {
- my ( $x, $y ) = split ' ', $val;
- $ENV{$x} = $y;
- printf "config : setenv '%s'\n '%s'\n", $x, $y if $opt{v};
- }
- elsif ( $key eq 'no_randomize' ) { $CNF{randomize} = 0; }
- elsif ( $key eq 'include' ) { get_conf $val ; }
- elsif ( $key eq 'show' ) { show_conf unless $opt{q}; }
- elsif ( $key eq 'exit' ) { Error 'exit per config directive'; }
- elsif ( $key eq 'max_age' ) { $CNF{max_sync} = $val; }
- else {
- show_conf;
- Error "unknown keyword '$key' (value '$val')";
- }
- }
-}
-sub get_conf_opt {
- my $err = '';
- get_conf find_conf;
- $CNF{timeout} = $opt{t} if $opt{t};
- for my $key (@REQ_KEYS) {
- unless ( exists $CNF{$key} ) {
- $err .= "$prog error: missing config for '$key'\n";
- }
- }
- for my $key (qw(min_poll max_poll max_sync min_sync)) {
- my $max = $CNF{$key};
- unless ( $max =~ /$TIM_PAT/o ) {
- $err .= "$prog error: $key ($max) doesn't match /$TIM_PAT/\n";
- }
- }
- unless ( grep $CNF{list_style} eq $_, @LIST_STYLE ) {
- $err .= sprintf "%s : error: unknown 'list_style' '%s'\n", $prog,
- $CNF{list_style};
- }
- unless ( grep $CNF{put_histo} eq $_, @PUT_HGRAM ) {
- $err .= sprintf "%s : error: unknown 'put_histo' '%s'\n", $prog,
- $CNF{put_histo};
- }
- if ( $opt{get} and not grep $opt{get} eq $_, @GET_OPTS ) {
- $err .= sprintf "%s : error: unknown 'get option' '%s'\n", $prog,
- $opt{get};
- }
- Error $err if $err;
- $opt{q} = 0 if $opt{v};
-}
-sub tim_to_s {
- my $tim = shift;
- my %tab = ( 's' => 1, 'm' => 60, 'h' => 60 * 60, 'd' => 60 * 60 * 24 );
- Error "wrong time '$tim'" unless $tim =~ /$TIM_PAT/o;
- my $m = $1;
- my $u = $2;
- return $m * $tab{$u};
-}
-sub aprx_eq { my ( $t1, $t2 ) = @_; abs( $t1 - $t2 ) < 60; }
-sub aprx_ge { my ( $t1, $t2 ) = @_; $t1 > $t2 or aprx_eq $t1, $t2; }
-sub aprx_le { my ( $t1, $t2 ) = @_; $t1 < $t2 or aprx_eq $t1, $t2; }
-sub aprx_gt { my ( $t1, $t2 ) = @_; $t1 > $t2 and not aprx_eq $t1, $t2; }
-sub aprx_lt { my ( $t1, $t2 ) = @_; $t1 < $t2 and not aprx_eq $t1, $t2; }
-sub pr_interval {
- my $s = shift;
- my ( $magn, $unit );
- my $mins = $s / 60;
- my $m = int( $mins + 0.5 );
- my $hours = $s / ( 60 * 60 );
- my $h = int( $hours + 0.5 );
- if ( $s < 50 ) { $magn = $s; $unit = 'second'; }
- elsif ( $m < 50 ) { $magn = $m; $unit = 'minute'; }
- elsif ( $h < 36 ) { $magn = $h; $unit = 'hour'; }
- else { $magn = sprintf "%.1f", $hours / 24; $unit = 'day'; }
- $unit .= 's' unless $magn == 1;
- return "$magn $unit";
-}
-sub max_age1 {
- ( tim_to_s $CNF {min_sync} ) + ( tim_to_s $CNF {max_poll} );
-}
-sub max_age2 {
- ( tim_to_s $CNF {max_sync} ) + ( tim_to_s $CNF {max_poll} );
-}
-sub max_vrfy {
- ( tim_to_s $CNF {min_poll} ) + ( tim_to_s $CNF {max_poll} );
-}
-sub age_code {
- my $time = shift;
- return 'z' unless $time =~ /^\d+$/;
- return (
- ( aprx_ge( $time, $^T - max_age1 ) )
- ? 's'
- : ( aprx_ge( $time, $^T - max_age2 ) ? 'b' : 'f' )
- );
-}
-sub err {
- my $url = shift;
- my $stat = shift;
- printf "*** %-10s %s\n", $stat, $url unless $opt{q};
- my ( $time, $vrfy, $hstp, $hsts );
- if ( exists $OLD{$url} ) {
- $time = $OLD{$url}[0];
- $vrfy = $OLD{$url}[2];
- $hstp = substr $OLD{$url}[3], 1 - $HIST;
- $hsts = $OLD{$url}[4];
- }
- else {
- $time = 'undef';
- $vrfy = 'undef';
- $hstp = '';
- $hsts = '';
- }
- $RES{$url} = [ $time, $stat, $vrfy, $hstp . 'f', $hsts, $^T ];
-}
-sub res {
- my $url = shift;
- my $time = shift;
- my $stat = shift;
- my $hstp = (
- exists $OLD{$url}
- ? substr( $OLD{$url}[3], 1 - $HIST )
- : ''
- );
- my $hsts = ( exists $OLD{$url} ? $OLD{$url}[4] : '' );
- printf "result %d %s\n", $time, $url if $opt{v};
- $RES{$url} = [ $time, $stat, $^T, $hstp . 's', $hsts, $^T ];
-}
-sub get_state {
- my $STT = shift;
- open STT, $STT or Error "can't open '$STT' ($!)";
- while (<STT>) {
- chop;
- my ( $url, $time, $stat, $vrfy, $hstp, $hsts, $lprb ) = split ' ';
- $stat =~ s/_/ /g;
- $hstp = '' unless defined $hstp;
- $hsts = '' unless defined $hsts;
- $hsts = '' if $hsts eq 'undef';
- $lprb = 'undef' unless defined $lprb;
- $OLD{$url} = [ $time, $stat, $vrfy, $hstp, $hsts, $lprb ];
- }
- close STT;
-}
-sub check_hist {
- my $time = shift;
- my $hsts = shift;
- printf "check_hist: last '$time' hsts '$hsts'\n" if $opt{d};
- my $res = $hsts;
- my ( $stmp, $hist );
- if ( $hsts eq '' ) { $stmp = 0; $hist = ''; }
- else { ( $stmp, $hist ) = split '-', $hsts; }
- if ( aprx_le $stmp, $^T - tim_to_s '1d' ) {
- $res = sprintf "%s-%s%s", $^T, substr( $hist, 1 - $HIST ),
- age_code($time);
- }
- return $res;
-}
-sub put_state {
- my $STT = shift;
- my $TMP = "$STT.tmp";
- open TMP, ">$TMP" or Error "can't write '$TMP' ($!)";
- for my $url ( sort keys %RES ) {
- $RES{$url}[4] = check_hist $RES {$url}[0], $RES{$url}[4];
- my @OUT = @{ $RES{$url} };
- $OUT[1] =~ s/\s/_/g;
- printf TMP "%s %s\n", $url, join ' ', @OUT
- or Error "can't print to $TMP ($!)";
- }
- close TMP;
- if ( -z $TMP ) { Warn "wrote empty state file; keeping previous version"; }
- else { rename $TMP, $STT or Error "can't rename '$TMP', '$STT' ($!)"; }
-}
-sub get_ccs {
- my $CCS = shift;
- open CCS, $CCS or Error "can't open '$CCS' ($!)";
- while (<CCS>) {
- chop;
- next if /^#/;
- my ( $code, $dash, $reg ) = split ' ', $_, 3;
- $CCS{ lc $code } = lc $reg;
- }
- close CCS;
-}
-sub type_site {
- my $url = shift;
- my ( $type, $site, $home );
- if ( $url =~ m!^(ftp|http)://([^/:]+)(:\d+)?/! ) {
- $type = $1;
- $site = $2;
- $home = $&;
- }
- return $type, $site, $home;
-}
-sub type { my ( $t, $s, $h ) = type_site $_[0]; $t; }
-sub site { my ( $t, $s, $h ) = type_site $_[0]; $s; }
-sub home { my ( $t, $s, $h ) = type_site $_[0]; $h; }
-sub get_list {
- my $LST = shift;
- my ( $reg, $url );
- open LST, $LST or Error "can't open '$LST' ($!)";
- while (<LST>) {
- chop;
- next if /^#/;
- next if /^\s*$/;
- if ( $CNF{list_style} eq 'plain' ) {
- ( $reg, $url ) = split ' ';
- unless ( $url =~ m!/$! ) {
- print "*** mirmon appended '/' to $url\n" unless $opt{q};
- $url .= '/';
- }
- }
- elsif ( $CNF{list_style} eq 'apache' ) {
- my $apache_type;
- ( $apache_type, $reg, $url ) = split ' ';
- unless ( defined $APA_TYPES{$apache_type} ) {
- print "*** strange type : $apache_type\n" unless $opt{q};
- next;
- }
- unless ( $url =~ m!/$! ) {
- print "*** missing '/' in $url\n" unless $opt{q};
- $url .= '/';
- }
- }
- my $site = site $url ;
- my $type = type $url ;
- unless ( defined $site ) {
- print "*** strange url : '$url'\n" unless $opt{q};
- next;
- }
- $LST{$url} = [ $type, $site, $reg ];
- }
-}
-sub url { sprintf '<A HREF="%s">%s</A>', $_[0], $_[1]; }
-sub nam { sprintf '<A NAME="%s">%s</A>', $_[0], $_[1]; }
-sub SMA { sprintf "<FONT SIZE=\"-1\">%s</FONT>", $_[0]; }
-sub BLD { sprintf "<B>%s</B>", $_[0]; }
-sub NSS { sprintf SMA('%s site%s'), $_[0], ( $_[0] == 1 ? '' : 's' ); }
-sub TAB { sprintf "<TABLE BORDER=2 CELLPADDING=3>%s</TABLE>", $_[0]; }
-sub TR { sprintf "<TR>%s</TR>\n", $_[0]; }
-sub TH { sprintf "<TH>%s</TH>\n", $_[0]; }
-sub TD { sprintf "<TD>%s</TD>\n", $_[0]; }
-sub TDr { sprintf "<TD ALIGN=\"RIGHT\">%s</TD>\n", $_[0]; }
-sub RED { sprintf "<FONT COLOR=\"RED\">%s</FONT>", $_[0]; }
-sub GRN { sprintf '<FONT COLOR="GREEN">%s</FONT>', $_[0]; }
-sub htmlquote {
- my $x = shift;
- $x =~ s/&/&/g;
- $x =~ s/</</g;
- $x =~ s/>/>/g;
- return $x;
-}
-sub diff {
- my $time = shift;
- my $max = shift;
- my $res;
- if ( $time == $^T ) { $res = BLD 'renewed'; }
- else {
- $res = pr_interval $^T - $time;
- $res = BLD RED $res if aprx_lt $time, $max;
- }
- return $res;
-}
-sub img_sf_cnt {
- sprintf '<IMG BORDER=1 SRC="%s/mm%s%02d.gif" ALT="">', $CNF{icons}, $_[0],
- $_[1];
-}
-sub img_sf { img_sf_cnt $_[0], 1; }
-sub show_hist {
- my $hst = shift;
- return '' unless $hst =~ m/^[sbfz]+$/;
- if ( length $hst == $HIST and $hst =~ /^(s*b)s*$/ ) {
- return img_sf_cnt 'sb', length $1;
- }
- elsif ( length $hst == $HIST and $hst =~ /^(s*f)s*$/ ) {
- return img_sf_cnt 'sf', length $1;
- }
- elsif ( length $hst == $HIST and $hst =~ /^(s*b)fs*$/ ) {
- return img_sf_cnt 'sbf', length $1;
- }
- my $res = '';
- my $cnt = 1;
- my $prf = substr $hst, 0, 1;
- $hst = substr $hst, 1;
- while ( $hst ne '' ) {
- if ( substr( $prf, 0, 1 ) eq substr( $hst, 0, 1 ) ) {
- $cnt++;
- $hst = substr $hst, 1;
- }
- else {
- $res .= img_sf_cnt $prf, $cnt;
- $prf = substr $hst, 0, 1;
- $hst = substr $hst, 1;
- $cnt = 1;
- }
- }
- $res .= img_sf_cnt $prf, $cnt if $cnt;
- return $res;
-}
-sub show_hist_age {
- my $hsts = shift;
- my $time = shift;
- return '' if $hsts eq '';
- my ( $t, $h ) = split '-', $hsts;
- if ( aprx_lt $t, $^T ) { $h .= age_code $time ; }
- return show_hist substr $h, -$HIST;
-}
-sub gen_histogram_probes {
- my ( $time, $stat, $vrfy, $hstp, $hsts, $lprb );
- my %tab = ();
- my %bad = ();
- my $res = '';
- my $s_cnt = 0;
- my $f_cnt = 0;
- my $hr_min;
- my $hr_max;
- return '' unless scalar keys %RES;
- for my $url ( keys %RES ) {
- ( $time, $stat, $vrfy, $hstp, $hsts, $lprb ) = @{ $RES{$url} };
- my $hr = int( ( $^T - $lprb ) / 3600 + 0.5 );
- $hr_min = $hr if !defined $hr_min or $hr < $hr_min;
- $hr_max = $hr if !defined $hr_max or $hr > $hr_max;
- if ( $stat eq 'ok' ) { $tab{$hr}++; $s_cnt++; }
- else { $bad{$hr}++; $f_cnt++; }
- }
- $res = TR(
- TH('hours ago')
- . TH('succ')
- . TH('fail')
- . TH sprintf( '%s %s, %s %s',
- $s_cnt, GRN('successful'), $f_cnt, RED('failed') )
- );
- my $max = 0;
- for my $x ( keys %tab ) {
- my $tot = $tab{$x} + ( $bad{$x} || 0 );
- $max = $tot if $max < $tot;
- }
- return "<BLOCKQUOTE>\nnothing yet\n</BLOCKQUOTE>\n" unless $max;
- for my $hr ( $hr_min .. $hr_max ) {
- my $x = $tab{$hr} || 0;
- my $y = $bad{$hr} || 0;
- my $n = int( $x / $max * $HIST );
- my $b = int( $y / $max * $HIST );
- $res .= TR(
- TDr($hr)
- . TDr($x)
- . TDr($y)
- . TD(
- ( $n ? img_sf_cnt( 's', $n ) : '' )
- . ( $b ? img_sf_cnt( 'f', $b ) : '' )
- . ( ( $n + $b ) ? '' : ' ' )
+# Thanks to Klaus Heinz <heinz@NetBSD.org> for sugestions ao htm_head ;
+# Peter Pöml for MirrorBrain support ; Jeremy Olexa, Karl Berry, Roland
+# Pelzer for suggestions regarding rsync support.
+
+use strict ;
+
+our $PRG = 'mirmon' ;
+our $VER = "2.3" ;
+
+our $DEF_TIMEOUT = 300 ;
+our $HIST = 14 ;
+our $TIM_PAT = '^(\d+)([smhd])$' ;
+our %APA_TYPES = () ; for ( qw(backup ftp http) ) { $APA_TYPES { $_ } ++ ; }
+our %GET_OPTS = () ; for ( qw(all update) ) { $GET_OPTS { $_ } ++ ; }
+our $HIST_DELTA = 24 * 60 * 60 ;
+our $APRX_DELTA = 60 ;
+our $HOME = 'http://www.cs.uu.nl/people/henkp/mirmon/' ;
+
+package Base ; #####################################################
+
+use base 'Exporter' ;
+
+our ( @ISA, @EXPORT ) ;
+BEGIN
+ { @ISA = qw(Exporter) ;
+ @EXPORT =
+ qw(aprx_eq aprx_ge aprx_le aprx_gt aprx_lt
+ URL NAM SMA BLD NSS TAB BQ TR TH TD TDr RED GRN H1 H2 H3
+ s4tim pr_interval pr_diff
+ ) ;
+ }
+
+sub Version { "$PRG version $VER" ; }
+sub version { "$PRG-$VER" ; }
+sub DEF_TIMEOUT { $DEF_TIMEOUT ; }
+sub is_get_opt { my $opt = shift ; exists $GET_OPTS { $opt } ; }
+
+sub getset
+ { my $self = shift ;
+ my $attr = shift ;
+ if ( @_ ) { $self -> { $attr } = shift ; }
+ die "no attr '$attr'" unless exists $self -> { $attr } ;
+ $self -> { $attr } ;
+ }
+
+sub mk_method
+ { my $self = shift ;
+ my $attr = shift ;
+ sprintf 'sub %s { my $self = shift ; $self -> getset ( "%s", @_ ) ; }'
+ , $attr, $attr ;
+ }
+
+sub mk_methods
+ { my $self = shift ;
+ join "\n", map { Base -> mk_method ( $_ ) ; } @_ ;
+ }
+
+sub aprx_eq { my ( $t1, $t2 ) = @_ ; abs ( $t1 - $t2 ) < $APRX_DELTA ; }
+sub aprx_ge { my ( $t1, $t2 ) = @_ ; $t1 > $t2 or aprx_eq $t1, $t2 ; }
+sub aprx_le { my ( $t1, $t2 ) = @_ ; $t1 < $t2 or aprx_eq $t1, $t2 ; }
+sub aprx_gt { my ( $t1, $t2 ) = @_ ; $t1 > $t2 and not aprx_eq $t1, $t2 ; }
+sub aprx_lt { my ( $t1, $t2 ) = @_ ; $t1 < $t2 and not aprx_eq $t1, $t2 ; }
+
+sub URL { sprintf '<A HREF="%s">%s</A>', $_[0], $_[1] ; }
+sub NAM { sprintf '<A NAME="%s">%s</A>', $_[0], $_[1] ; }
+sub SMA { sprintf "<FONT SIZE=\"-1\">%s</FONT>", $_[0] ; }
+sub BLD { sprintf "<B>%s</B>", $_[0] ; }
+sub NSS { sprintf SMA('%s site%s'), $_[0], ( $_[0] == 1 ? '' : 's' ) ; }
+sub TAB { sprintf "<TABLE BORDER=2 CELLPADDING=3>%s</TABLE>", $_[0] ; }
+sub BQ { sprintf "<BLOCKQUOTE>\n%s\n</BLOCKQUOTE>\n", $_[0] ; }
+sub TR { sprintf "<TR>%s</TR>\n", $_[0] ; }
+sub TH { sprintf "<TH>%s</TH>\n", $_[0] ; }
+sub TD { sprintf "<TD>%s</TD>\n", $_[0] ; }
+sub H1 { sprintf "<H1>%s</H1>\n", $_[0] ; }
+sub H2 { sprintf "<H2>%s</H2>\n", $_[0] ; }
+sub H3 { sprintf "<H3>%s</H3>\n", $_[0] ; }
+sub TDr { sprintf "<TD ALIGN=\"RIGHT\">%s</TD>\n", $_[0] ; }
+sub RED { sprintf "<FONT COLOR=\"RED\">%s</FONT>", $_[0] ; }
+sub GRN { sprintf '<FONT COLOR="GREEN">%s</FONT>', $_[0] ; }
+
+sub s4tim
+ { my $tim = shift ;
+ my %tab = ( 's' => 1, 'm' => 60, 'h' => 60 * 60, 'd' => 60 * 60 * 24 ) ;
+ die "wrong time '$tim'" unless $tim =~ /$TIM_PAT/o ;
+ my $m = $1 ; my $u = $2 ;
+ return $m * $tab { $u } ;
+ }
+
+sub pr_interval
+ { my $s = shift ;
+ my ( $magn, $unit ) ;
+ my $mins = $s / 60 ; my $m = int ( $mins + 0.5 ) ;
+ my $hours = $s / ( 60 * 60 ) ; my $h = int ( $hours + 0.5 ) ;
+
+ if ( $s < 50 )
+ { $magn = $s ; $unit = 'second' ; }
+ elsif ( $m < 50 )
+ { $magn = $m ; $unit = 'minute' ; }
+ elsif ( $h < 36 )
+ { $magn = $h ; $unit = 'hour' ; }
+ else
+ { $magn = sprintf "%.1f", $hours / 24 ; $unit = 'day' ; }
+
+ $unit .= 's' unless $magn == 1 ;
+
+ return "$magn $unit" ;
+ }
+
+sub pr_diff
+ { my $time = shift ;
+ my $max = shift ;
+ my $res ;
+
+ if ( $time == $^T )
+ { $res = BLD 'renewed' ; }
+ else
+ { $res = pr_interval $^T - $time ;
+ $res = BLD RED $res if aprx_lt $time, $max ;
+ }
+ return $res ;
+ }
+
+sub exp_date
+ { my @day = qw(Sun Mon Tue Wed Thu Fri Sat) ;
+ my @mon = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec) ;
+ my @gmt = gmtime time + 3600 ;
+ sprintf "%s, %02d %s %4d %02d:%02d:%02d GMT"
+ , $day [ $gmt [ 6 ] ]
+ , $gmt [ 3 ]
+ , $mon [ $gmt [ 4 ] ]
+ , $gmt [ 5 ] + 1900
+ , @gmt [ 2, 1, 0 ]
+ ;
+ }
+
+sub htmlquote
+ { my $x = shift ;
+ $x =~ s/&/&/g ;
+ $x =~ s/</</g ;
+ $x =~ s/>/>/g ;
+ return $x ;
+ }
+
+package Mirmon ; ###################################################
+
+BEGIN { use base 'Base' ; Base -> import () ; }
+
+use IO::Select ;
+use Net::hostent ;
+
+ { my %opt = ( v => 0 , d => 0 , q => 0 ) ;
+ sub _opt
+ { my ( $key, $val ) = @_ ;
+ my $res ;
+ unless ( exists $opt { $key } )
+ { warn "unknown Mirmon option '$key'\n" ; }
+ else
+ { $res = $opt { $key } ;
+ $opt { $key } = $val if defined $val ;
+ }
+ $res ;
+ }
+ }
+
+sub verbose { _opt ( 'v', shift ) ; }
+sub quiet { _opt ( 'q', shift ) ; }
+sub debug { _opt ( 'd', shift ) ; }
+
+eval Base -> mk_methods ( qw(conf state regions) ) ;
+
+sub config_list
+ { my $self = shift ;
+ my $home = ( getpwuid $< ) [ 7 ] or die "can get homedir '$<' ($!)" ;
+ ( 'mirmon.conf', "$home/.mirmon.conf", '/etc/mirmon.conf' ) ;
+ }
+
+sub new
+ { my $self = shift ;
+ my $path = shift ;
+ my $res = bless {}, $self ;
+ $res -> get_config ( $path ) ;
+ $res -> get_state ;
+ $res -> get_regions ;
+ $res ;
+ }
+
+sub find_config
+ { my $self = shift ;
+ my $arg = shift ;
+ my @LIST = $arg ? ( $arg ) : Mirmon -> config_list ;
+ for my $conf ( @LIST ) { return $conf if -f $conf ; }
+ die sprintf "can't find a config file :\n %s\n" , join "\n ", @LIST ;
+ }
+
+sub get_config
+ { my $self = shift ;
+ my $path = shift ;
+ my $file = $self -> find_config ( $path ) ; # or die
+ $self -> conf ( Mirmon::Conf -> new ( $file ) ) ;
+ }
+
+sub get_state
+ { my $self = shift ;
+ my $conf = $self -> conf ;
+ my $state = $conf -> state ;
+ my $res = {} ;
+ open STATE, $state or die "can't open $state ($!)" ;
+ for my $line ( <STATE> )
+ { chop $line ;
+ my $mirror = Mirmon::Mirror -> new ( $self, $line ) ;
+ $res -> { $mirror -> url } = $mirror ;
+ }
+ close STATE ;
+
+ my $mlist = $conf -> mirror_list ;
+ my $style = $conf -> list_style ;
+ my %in_list = () ;
+ open MLIST, $mlist or die "can't open $mlist ($!)" ;
+ for my $line ( <MLIST> )
+ { chop $line ;
+ next if $line =~ /^#/ ;
+ next if $line =~ /^\s*$/ ;
+ my ( $reg, $url, $mail ) ;
+ if ( $style eq 'plain' )
+ { ( $reg, $url, $mail ) = split ' ', $line ; }
+ elsif ( $style eq 'apache' )
+ { my $apache_type ;
+ ( $apache_type, $reg, $url, $mail ) = split ' ', $line ;
+ unless ( defined $APA_TYPES { $apache_type } )
+ { print "*** strange type in $url ($apache_type)\n"
+ unless Mirmon::quiet ;
+ next ;
+ }
+ }
+
+ if ( $conf -> add_slash and $url !~ m!/$! )
+ { print "*** appended '/' to $url\n" unless Mirmon::quiet ;
+ $url .= '/' ;
+ }
+
+ $in_list { $url } ++ ;
+
+ unless ( exists $res -> { $url } )
+ { printf "*** added to list %s\n", $url unless Mirmon::quiet ;
+ $res -> { $url } = Mirmon::Mirror -> init ( $self, $url ) ;
+ }
+ my $mirror = $res -> { $url } ;
+ $mirror -> region ( $reg ) ;
+ $mirror -> mail ( $mail || '' ) ;
+ }
+ close MLIST ;
+
+ for my $url ( sort keys %$res )
+ { # printf "%s\n", $res -> { $url } -> state ;
+ unless ( exists $in_list { $url } )
+ { printf "*** removed from list %s\n", $url unless Mirmon::quiet ;
+ delete $res -> { $url } ;
+ }
+ }
+ $self -> state ( $res ) ;
+ }
+
+sub put_state
+ { my $self = shift ;
+ my $state = $self -> state ;
+ my $file = $self -> conf -> state ;
+ my $TMP = "$file.tmp" ;
+ open TMP, ">$TMP" or die "can't write '$TMP' ($!)" ;
+ for my $url ( sort keys %$state )
+ { printf TMP "%s\n", $state -> { $url } -> state
+ or die "can't print $url to $TMP ($!)" ;
+ }
+ close TMP ;
+
+ if ( -z $TMP )
+ { warn "wrote empty state file; keeping previous version" ; }
+ else
+ { rename $TMP, $file or die "can't rename '$TMP', '$file' ($!)" ; }
+ }
+
+sub get_regions
+ { my $self = shift ;
+ my $file = $self -> conf -> countries ;
+ open REGS, $file or die "can't open countries '$file' ($!)" ;
+ while ( <REGS> )
+ { chop ;
+ next if /^#/ ;
+ my ( $code, $dash, $reg ) = split ' ', $_, 3 ;
+ $self -> { regions } { lc $code } = lc $reg ;
+ }
+ close REGS ;
+ }
+
+sub get_dates
+ { my $self = shift ;
+ my $get = shift ;
+ my $state = $self -> state ;
+ my $conf = $self -> conf ;
+ my $CMD = $conf -> probe ;
+ my $PAR = $conf -> max_probes ;
+ my %m4h = () ;
+ my @QUE = () ;
+ my @NOQ = () ;
+ my $GET = IO::Select -> new () ;
+
+ my $cnt = 0 ;
+ my $nok = 0 ;
+
+ for my $url ( sort keys %$state )
+ { my $mirror = $state -> { $url } ;
+ $cnt ++ if $mirror -> last_status eq 'ok' ;
+ if ( $get eq 'all' or $mirror -> last_probe eq 'undef' )
+ { push @QUE, $mirror ; }
+ elsif ( $get eq 'update' )
+ { my $stat = $mirror -> last_status ;
+ my $vrfy = $mirror -> last_ok_probe ;
+ my $lprb = $mirror -> last_probe ;
+ if ( aprx_le $lprb, $^T - s4tim $conf -> min_poll )
+ { if ( $stat ne 'ok' )
+ { push @QUE, $mirror ; $nok ++ ; }
+ elsif ( aprx_le $vrfy, $^T - s4tim $conf -> max_poll )
+ { push @QUE, $mirror ; }
+ else
+ { push @NOQ, $mirror ; }
+ }
+ }
+ else
+ { die "unknown opt_get '$get'" ; }
+ }
+
+ if ( Mirmon::verbose )
+ { my $que = scalar @QUE ; my $noq = scalar @NOQ ;
+ printf "ok mirrors %d, queued %d, not queued %d, ok %d, nok %d\n"
+ , $cnt, $que, $noq, $que - $nok, $nok
+ }
+
+ if ( $conf -> randomize )
+ { my $hrs = int ( ( s4tim $conf -> max_poll ) / 60 / 60 + 0.5 ) ;
+ my $avg = int ( $cnt / $hrs + 0.5 ) ;
+ my $prc = ( scalar keys %$state ) / 50 ;
+ my $flr = int $prc ;
+ my $extras = $flr + ( rand 1 < ( $prc - $flr ) ) ;
+ my $picked = 0 ;
+
+ while ( @QUE < $avg + $nok and @NOQ and $picked < $extras )
+ { my $idx = int rand @NOQ ;
+ push @QUE, $NOQ [ $idx ] ;
+ $NOQ [ $idx ] = $NOQ [ $#NOQ ] ;
+ pop @NOQ ;
+ $picked ++ ;
+ }
+
+ printf "avg mirrors/hr %d, max extras %d, picked %d ; queued %s\n"
+ , $avg, $extras, $picked, scalar @QUE if Mirmon::verbose ;
+ }
+
+ while ( @QUE )
+ { my $started = 0 ;
+ while ( $GET -> count () < $PAR and @QUE )
+ { my $mirror = shift @QUE ;
+ if ( gethost $mirror -> site )
+ { my $handle = $mirror -> start_probe ;
+ $m4h { $handle } = $mirror ;
+ $GET -> add ( $handle ) ;
+ $started ++ ;
+ }
+ else
+ { $mirror -> update ( 0, 'site_not_found', undef ) ; }
+ }
+
+ my @can_read = $GET -> can_read ( 0 ) ;
+
+ printf "queue %d, started %d, probes %d, can_read %d\n",
+ scalar @QUE, $started, $GET -> count (), scalar @can_read
+ if Mirmon::verbose ;
+
+ for my $handle ( @can_read )
+ { # order is important ; wget's hang if/when actions are reversed
+ $GET -> remove ( $handle ) ;
+ $m4h { $handle } -> finish_probe ( $handle ) ;
+ }
+
+ sleep 1 ;
+ }
+
+ my $stop = time + $conf -> timeout + 10 ;
+
+ while ( $GET -> count () and time < $stop )
+ { my @can_read = $GET -> can_read ( 0 ) ;
+
+ printf "wait %2d, probes %d, can_read %d\n",
+ $stop - scalar time, $GET -> count (), scalar @can_read
+ if Mirmon::verbose ;
+
+ for my $handle ( @can_read )
+ { $GET -> remove ( $handle ) ;
+ $m4h { $handle } -> finish_probe ( $handle ) ;
+ }
+
+ sleep 10 ;
+ }
+
+ for my $handle ( $GET -> handles () )
+ { $m4h { $handle } -> update ( 0, 'hangs', undef ) ; }
+ }
+
+sub img_sf_cnt
+ { my $self = shift ;
+ my $prf = shift ;
+ my $cnt = shift ;
+ my $res ;
+ if ( $prf eq 'x' )
+ { sprintf
+ ( '<IMG BORDER=1 SRC="%s/bar.gif" ALT="">'
+ , $self -> conf -> icons
+ ) x $cnt ;
+ }
+ else
+ { sprintf '<IMG BORDER=1 SRC="%s/mm%s%02d.gif" ALT="">'
+ , $self -> conf -> icons, $prf, $cnt ;
+ }
+ }
+
+sub img_sf { my $self = shift ; $self -> img_sf_cnt ( $_[0], 1 ) ; }
+
+sub show_hist
+ { my $self = shift ;
+ my $hst = shift ;
+ if ( $hst =~ /-(.*)$/ ) { $hst = $1 ; }
+ return '' unless $hst =~ m/^[sbfzx]+$/ ;
+ if ( length $hst == $HIST and $hst =~ /^(s*b)s*$/ )
+ { return $self -> img_sf_cnt ( 'sb', length $1 ) ; }
+ elsif ( length $hst == $HIST and $hst =~ /^(s*f)s*$/ )
+ { return $self -> img_sf_cnt ( 'sf', length $1 ) ; }
+ elsif ( length $hst == $HIST and $hst =~ /^(s*b)fs*$/ )
+ { return $self -> img_sf_cnt ( 'sbf', length $1 ) ; }
+ my $res = '' ;
+ my $cnt = 1 ;
+ my $prf = substr $hst, 0, 1 ;
+ $hst = substr $hst, 1 ;
+ while ( $hst ne '' )
+ { if ( substr ( $prf, 0, 1 ) eq substr ( $hst, 0, 1 ) )
+ { $cnt ++ ;
+ $hst = substr $hst, 1 ;
+ }
+ else
+ { $res .= $self -> img_sf_cnt ( $prf, $cnt ) ;
+ $prf = substr $hst, 0, 1 ;
+ $hst = substr $hst, 1 ;
+ $cnt = 1 ;
+ }
+ }
+ $res .= $self -> img_sf_cnt ( $prf, $cnt ) if $cnt ;
+ $res ;
+ }
+
+sub gen_histogram_probes
+ { my $self = shift ;
+ my $state = $self -> state ;
+ my %tab = () ;
+ my %bad = () ;
+ my $res = '' ;
+ my $s_cnt = 0 ;
+ my $f_cnt = 0 ;
+ my $hr_min ;
+ my $hr_max ;
+ for my $url ( keys %$state )
+ { my $mirror = $state -> { $url } ;
+ my $lprb = $mirror -> last_probe ;
+ my $stat = $mirror -> last_status ;
+ next if $lprb eq 'undef' ;
+ my $hr = int ( ( $^T - $lprb ) / 3600 + 0.5 ) ;
+ $hr_min = $hr if ! defined $hr_min or $hr < $hr_min ;
+ $hr_max = $hr if ! defined $hr_max or $hr > $hr_max ;
+ if ( $stat eq 'ok' )
+ { $tab { $hr } ++ ; $s_cnt ++ ; }
+ else
+ { $bad { $hr } ++ ; $f_cnt ++ ; }
+ }
+ return BQ 'nothing yet' unless scalar keys %tab ;
+
+ $res = TR
+ ( TH ( 'hours ago' )
+ . TH ( 'succ' )
+ . TH ( 'fail' )
+ . TH sprintf
+ ( '%s %s, %s %s'
+ , $s_cnt , GRN ( 'successful' )
+ , $f_cnt , RED ( 'failed' )
+ )
+ ) ;
+
+ my $max = 0 ;
+ for my $x ( keys %tab )
+ { my $tot = $tab { $x } + ( $bad { $x } || 0 ) ;
+ $max = $tot if $max < $tot ;
+ }
+
+ return BQ "nothing yet" unless $max ;
+
+ for my $hr ( $hr_min .. $hr_max )
+ { my $x = $tab { $hr } || 0 ;
+ my $y = $bad { $hr } || 0 ;
+ my $n = int ( $x / $max * $HIST ) ;
+ my $b = int ( $y / $max * $HIST ) ;
+ $res .= TR
+ ( TDr ( $hr )
+ . TDr ( $x )
+ . TDr ( $y )
+ . TD
+ ( ( $n ? $self -> img_sf_cnt ( 's', $n ) : '' )
+ . ( $b ? $self -> img_sf_cnt ( 'f', $b ) : '' )
+ . ( ( $n + $b ) ? '' : ' ' )
)
- );
- }
- return "<BLOCKQUOTE>\n" . TAB($res) . "</BLOCKQUOTE>\n";
-}
-sub gen_histogram {
- my $MAX_H = max_age1;
- my $MAX_h = 1 + (
- ( 20 * 3600 <= $MAX_H and $MAX_H <= 36 * 3600 )
- ? int( $MAX_H / 3600 )
- : 25
- );
- my $MAX_O = max_age2;
- my $MAX_o = int( $MAX_O / 3600 + 0.5 );
- my $H = 18;
- my %W = ( 'old' => 1, 'ded' => 1, 'bad' => 1 );
- my %Wmx = ( 'old' => 5, 'ded' => 3, 'bad' => 3 );
- my %tab;
- my %hst;
- my $res;
- for ( my $x = 0 ; $x < $MAX_h ; $x++ ) { $tab{$x} = 0; }
- $tab{old} = 0;
- $tab{ded} = 0;
- $tab{bad} = 0;
- for my $url ( keys %RES ) {
- my $time = $RES{$url}[0];
- if ( $time =~ /^\d+$/ ) {
- my $s = $^T - $time;
- my $hr = int( $s / $MAX_H * ( $MAX_h - 1 ) + 0.5 );
- if ( $s <= $MAX_H ) { $tab{$hr}++; }
- elsif ( $s <= $MAX_O ) { $tab{old}++; }
- else { $tab{ded}++; }
- }
- else { $tab{bad}++; }
- }
- my $max = 0;
- for ( grep !exists $Wmx{$_}, keys %tab ) {
- $max = $tab{$_} if $tab{$_} > $max;
- }
- my %bad;
- for my $aux ( keys %Wmx ) {
- $bad{$aux} = $tab{$aux};
- if ( $bad{$aux} > $max ) {
- $W{$aux} = $Wmx{$aux};
- my $d = int( $bad{$aux} / $W{$aux} );
- for ( my $i = 1 ; $i < $W{$aux} ; $i++ ) {
- $tab{ $aux . $i } = $d;
- if ( $bad{$aux} % $Wmx{$aux} > $i ) {
- $tab{ $aux . $i }++;
- $tab{$aux}--;
- }
- }
- $tab{$aux} -= ( $W{$aux} - 1 ) * $d;
- $max = $tab{$aux} if $max < $tab{$aux};
- }
- }
- # if ( $opt{v} )
- # { for my $hr ( keys %tab )
- # { printf "tab '%s' = '%s'\n", $hr, $tab { $hr } ; }
- # }
- return 'nothing yet' unless $max;
- $H = $max if 8 <= $max and $max <= 26;
- for ( keys %tab ) { $hst{$_} = int( $H * $tab{$_} / $max + 0.5 ); }
- my @keys = sort { $a <=> $b } grep /^\d+$/, keys %hst;
- my $tab_hr = 0;
- for my $hr (@keys) { $tab_hr += $tab{$hr}; }
- push @keys, grep ( m/^old/, sort keys %tab ),
- grep ( m/^ded/, sort keys %tab ), grep ( m/^bad/, sort keys %tab );
- for ( my $h = $H ; $h > 0 ; $h-- ) {
- $res .= "<TR>\n";
- $res .= sprintf "<TH ROWSPAN=3 VALIGN=\"TOP\">↑</TH>\n"
- if $h == $H;
- $res .= sprintf '<TD ROWSPAN=%d ALIGN="CENTER">%s</TD>' . "\n", $H - 6,
- NSS($max)
- if $h == $H - 3;
- $res .= sprintf "<TH ROWSPAN=3 VALIGN=\"BOTTOM\">↓</TH>\n"
- if $h == 3;
- for my $x (@keys) {
- $res .= sprintf "<TH>%s</TH>\n",
- (
- ( $hst{$x} >= $h )
- ? img_sf(
- $x =~ /^\d+$/
- ? 's'
- : ( $x =~ /^old/ ? 'b' : ( $x =~ /^ded/ ? 'f' : 'z' ) )
- )
- : (
- ( $h == 1 and $hst{$x} == 0 )
- ? sprintf( '<IMG SRC="%s/bar.gif" ALT="" BORDER=0>',
- $CNF{icons} )
- : ''
- )
- );
- }
- $res .= "</TR>\n";
- }
- my $HR = '<HR SIZE=2 WIDTH="95%%" NOSHADE>';
- $res .= "<TR>\n";
- $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", 1;
- $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", $MAX_h;
- $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", $W{old};
- $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", $W{ded};
- $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", $W{bad};
- $res .= "</TR>\n";
- $res .= "<TR>\n";
- $res .= '<TD ALIGN="CENTER"> <B>age</B> → </TD>';
- $res .= "<TH>|</TH>\n";
- $res .=
- sprintf( '<TD COLSPAN=%d ALIGN="CENTER">'
- . '← 0 ≤ <B>age</B> ≤ %s →'
- . "</TD>\n",
- $MAX_h - 2, pr_interval($MAX_H) );
- $res .= "<TH>|</TH>\n";
- $res .= sprintf(
- '<TD ALIGN="CENTER" COLSPAN=%d>'
- . ' %sh < %s ≤ %sh '
- . "</TD>\n",
- $W{old}, int( $MAX_H / 60 / 60 ),
- BLD('age'), $MAX_o
- );
- $res .= sprintf(
- '<TD ALIGN="CENTER" COLSPAN=%d>'
- . ' <FONT COLOR="RED">old</FONT> '
- . "</TD>\n",
- $W{ded}
- );
- $res .= sprintf(
- '<TD ALIGN="CENTER" COLSPAN=%d>'
- . ' <FONT COLOR="RED">bad</FONT> '
- . "</TD>\n",
- $W{bad}
- );
- $res .= "</TR>\n";
- my $FRMT = '<TD ALIGN="CENTER" COLSPAN=%d> %s </TD>';
- $res .= "<TR>\n";
- $res .= sprintf "$FRMT\n", 1, NSS scalar keys %RES;
- $res .= "<TH>|</TH>\n";
- $res .= sprintf "$FRMT\n", $MAX_h - 2, NSS $tab_hr ;
- $res .= "<TH>|</TH>\n";
- $res .= sprintf "$FRMT\n", $W{old}, NSS $bad {old};
- $res .= sprintf "$FRMT\n", $W{ded}, NSS $bad {ded};
- $res .= sprintf "$FRMT\n", $W{bad}, NSS $bad {bad};
- $res .= "</TR>\n";
- $res = "<TABLE CELLSPACING=0 CELLPADDING=1 BORDER=0>\n$res\n</TABLE>\n";
- $res = sprintf "<TABLE CELLPADDING=5 BORDER=4>%s</TABLE>\n",
- "<TR><TH>\n$res\n</TH></TR>";
- if ( $max == $H ) {
- $res .= sprintf "<BR>units %s %s %s %s represent one mirror site.\n",
- img_sf('s'), img_sf('f'), img_sf('b'), img_sf('z');
- }
- else {
- $res .=
- sprintf "<BR>each %s %s %s %s unit represents %s mirror sites.\n",
- img_sf('s'), img_sf('f'), img_sf('b'), img_sf('z'),
- sprintf( "%.1f", $max / $H );
- }
- return $res;
-}
-sub revdom { my $dom = shift; join '.', reverse split /\./, $dom; }
-sub by_type_site {
- my $a_type = $a->[0];
- my $b_type = $b->[0];
- my $a_site = $a->[2];
- my $b_site = $b->[2];
- ( revdom $a_site ) cmp( revdom $b_site )
- or $a_type cmp $b_type;
-}
-sub by_CCS { ( $CCS{$a} || $a ) cmp( $CCS{$b} || $b ); }
-sub legend;
-sub gen_page {
- my $PPP = shift;
- my $TMP = "$PPP.tmp";
- my %tab;
- my $refs;
- for my $url ( keys %LST ) {
- my ( $type, $site, $reg ) = @{ $LST{$url} };
- push @{ $tab{$reg} }, [ $type, $url, $site ];
- }
- my $bad = 0;
- my $old = 0;
- my $unr = 0;
- my %stats;
- my @stats;
- my $ok = 0;
- for my $url ( keys %RES ) {
- my ( $time, $stat, $vrfy ) = @{ $RES{$url} };
- if ( $stat eq 'ok' ) { $ok++; }
- else { $stats{$stat}++; }
- if ( $time eq 'undef' ) { $bad++; }
- elsif ( 'f' eq age_code $time ) { $old++; }
- if ( $vrfy eq 'undef' or aprx_lt $vrfy, $^T - max_vrfy ) { $unr++; }
- }
- my $STAT =
- sprintf "%d bad -- %d older than %s -- %s unreachable for more than %s",
- $bad, $old, pr_interval(max_age2), $unr, pr_interval(max_vrfy);
- my $PROB = 'last probes : ';
- push @stats, "$ok were ok" if $ok;
- for my $stat ( sort keys %stats ) {
- push @stats, sprintf "%s had %s", $stats{$stat}, RED $stat ;
- }
- $PROB .= join ', ', @stats;
- for my $reg ( sort keys %tab ) {
- $refs .= sprintf " %s \n", url "#$reg",
- "<FONT SIZE=\"+1\">$reg</FONT>";
- }
- my $COLS = 5;
- my $LOGO =
- $CNF{project_logo}
- ? url(
- $CNF{project_url},
- sprintf(
- '<IMG SRC="%s" ALT="%s" ALIGN="RIGHT" BORDER=0>',
- $CNF{project_logo}, $CNF{project_name}
- )
- )
- : '';
- my $HTOP = $CNF{htm_top} ? $CNF{htm_top} . "\n" : '';
- my $FOOT = $CNF{htm_foot} ? $CNF{htm_foot} . "\n" : '';
- my $HEAD = $CNF{htm_head} ? $CNF{htm_head} . "\n" : '';
- my $TITL = url $CNF{project_url}, $CNF{project_name};
- my $EXPD = exp_date;
- open PPP, ">$TMP" or Error "can't write $TMP ($!)";
- print PPP '<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01'
- . ' Transitional//EN"' . '>';
- print PPP "<HTML>\n";
- print PPP "<HEAD>\n";
- print PPP "<TITLE>the status of $CNF{project_name} mirrors</TITLE>\n";
- printf PPP "%s\n", '<meta HTTP-EQUIV="content-type" '
- . 'CONTENT="text/html; charset=ISO-8859-1">';
- print PPP "<META HTTP-EQUIV=\"refresh\" CONTENT=\"3600\">\n";
- print PPP "<META HTTP-EQUIV=\"Expires\" CONTENT=\"$EXPD\">\n";
- print PPP $HEAD if $HEAD;
- print PPP "</HEAD>\n";
- print PPP "<BODY BGCOLOR=\"#FFFFFF\">\n";
- print PPP $LOGO;
- print PPP "<H2>the status of $TITL mirrors</H2>\n";
- print PPP "<TABLE BORDER=0 CELLPADDING=2>\n";
- printf PPP "<TR><TD>date</TD><TD>:</TD><TD>%s (GMT)</TD></TR>\n",
- scalar gmtime $^T;
- printf PPP "<TR><TD>last check</TD><TD>:</TD><TD>%s (GMT)</TD></TR>\n",
- scalar gmtime( $opt{get} ? $^T : ( stat $CNF{state} )[9] );
- print PPP "</TABLE>\n";
- printf PPP "<P>%s</P>\n", $HTOP if $HTOP;
- if ( $CNF{put_histo} eq 'top' ) {
- print PPP "<H2>age histogram</H2>\n";
- print PPP "<BLOCKQUOTE>\n";
- print PPP gen_histogram;
- print PPP "</BLOCKQUOTE>\n";
- }
- print PPP "<H2>regions</H2>\n";
- print PPP "<BLOCKQUOTE>\n";
- print PPP "<CENTER>\n";
- printf PPP "%s\n", $refs;
- print PPP "</CENTER>\n";
- print PPP "</BLOCKQUOTE>\n";
- print PPP "<H2>report</H2>\n";
- my $attr1 = "COLSPAN=$COLS BGCOLOR=\"LIME\"";
- my $attr2 = 'BGCOLOR="AQUA"';
- print PPP "<BLOCKQUOTE>\n";
- print PPP "<TABLE BORDER=2 CELLPADDING=5>\n";
- printf PPP "<TR><TH $attr1>%d sites in %d regions</TH></TR>\n",
- scalar keys %LST, scalar keys %tab;
- printf PPP "<TR><TH $attr1>%s</TH></TR>\n", $STAT;
- printf PPP "<TR><TH $attr1>%s</TH></TR>\n", $PROB;
- print PPP "<TR>\n";
- printf PPP " <TH $attr2>%s site -- home</TH>\n", $CNF{project_name};
- printf PPP " <TH $attr2>%s</TH>\n", 'type';
- printf PPP " <TH $attr2>%s</TH>\n", 'mirror age,<BR>daily stats';
- printf PPP " <TH $attr2>%s</TH>\n", 'last probe,<BR>probe stats';
- printf PPP " <TH $attr2>%s</TH>\n", 'last stat';
- print PPP "</TR>\n";
- for my $reg ( sort by_CCS keys %tab ) {
- my $itms = $tab{$reg};
- my $ccs = exists $CCS{$reg} ? $CCS{$reg} : $reg;
- $ccs = nam $reg,
- (
- scalar @{$itms} > 6
- ? sprintf "%s - %d sites",
- $ccs,
- scalar @{$itms}
- : $ccs
- );
- my $attr3 = "COLSPAN=$COLS BGCOLOR=\"YELLOW\"";
- printf PPP "<TR><TH $attr3>$ccs</TH></TR>\n";
- for my $itm ( sort by_type_site @{$itms} ) {
- my ( $type, $url, $site ) = @{$itm};
- my ( $time, $stat, $hstp, $hsts, $vrfy );
- my ( $pr_time, $pr_last, $pr_hstp, $pr_hsts );
- print PPP "<TR>\n";
- printf PPP " <TD ALIGN=\"RIGHT\">%s %s</TD>\n"
- . " <TD>%s</TD>\n", url( $url, $site ), url( home($url), '@' ),
- $type;
- if ( exists $RES{$url} ) {
- ( $time, $stat, $vrfy, $hstp, $hsts ) = @{ $RES{$url} };
- $pr_time = $time =~ /^\d+$/
- ? diff $time, $^T - max_age2
- : ' ';
- $pr_last = $vrfy =~ /^\d+$/
- ? diff $vrfy, $^T - max_vrfy
- : ' ';
- $pr_hstp = show_hist $hstp ;
- $pr_hsts = show_hist_age $hsts, $time;
- }
- else {
- ( $pr_time, $pr_last, $pr_hstp, $pr_hsts, $stat ) =
- ( ' ', ' ', '', '', ' ' );
- }
- $stat = RED $stat if $stat ne 'ok';
- printf PPP " <TD ALIGN=\"RIGHT\">%s<BR>%s</TD>\n", $pr_time,
- $pr_hsts;
- printf PPP " <TD ALIGN=\"RIGHT\">%s<BR>%s</TD>\n", $pr_last,
- $pr_hstp;
- printf PPP " <TD>%s</TD>\n", $stat;
- print PPP "</TR>\n";
- }
- }
- print PPP "</TABLE>\n";
- print PPP "</BLOCKQUOTE>\n";
- if ( $CNF{put_histo} eq 'bottom' ) {
- print PPP "<H2>age histogram</H2>\n";
- print PPP "<BLOCKQUOTE>\n";
- print PPP gen_histogram;
- print PPP "</BLOCKQUOTE>\n";
- }
- print PPP legend;
- print PPP "<H3>probe results</H3>\n";
- print PPP gen_histogram_probes;
- print PPP "<H3>software</H3>\n";
- print PPP "<BLOCKQUOTE><TABLE><TR>\n";
- my $MIR_IMG = sprintf '<IMG BORDER=2 ALT="mirmon" SRC="%s/mirmon.gif">',
- $CNF{icons};
- print PPP sprintf "<TH><A HREF=\"%s\">%s</A></TH>\n",
- 'http://www.cs.uu.nl/people/henkp/mirmon/', $MIR_IMG;
- print PPP "<TD>$VER</TD>\n";
- print PPP "</TR></TABLE></BLOCKQUOTE>\n";
- print PPP $FOOT;
- print PPP "</BODY>\n";
- print PPP "</HTML>";
- if ( print PPP "\n" ) {
- close PPP;
- if ( -z $TMP ) {
- Warn "wrote empty html file; keeping previous version";
- }
- else { rename $TMP, $PPP or Error "can't rename $TMP, $PPP ($!)"; }
- }
- else { Error "can't print to $TMP ($!)"; }
-}
-sub legend {
+ ) ;
+ }
+ return BQ TAB $res ;
+ }
+
+sub age_avg
+ { my $self = shift ;
+ my $state = $self -> state ;
+ my @tab = () ;
+ for my $url ( keys %$state )
+ { my $time = $state -> { $url } -> age ;
+ push @tab, $^T - $time if $time =~ /^\d+$/ ;
+ }
+ my $cnt = @tab ;
+
+ return undef if $cnt == 0 ;
+
+ @tab = sort { $a <=> $b } @tab ;
+
+ my $tot = 0 ;
+ for my $age ( @tab ) { $tot += $age ; }
+ my $mean = $tot / $cnt ;
+
+ my $median ;
+ if ( $cnt == 1 )
+ { $median = $tab [ 0 ] ; }
+ elsif ( $cnt % 2 )
+ { my $mid = int ( $#tab / 2 ) ;
+ $median = ( $tab [ $mid ] + $tab [ $mid + 1 ] ) / 2 ;
+ }
+ else
+ { my $mid = int ( $#tab / 2 ) ;
+ $median = $tab [ $mid ] ;
+ }
+
+ if ( @tab < 2 )
+ { return $mean, $median, undef ; }
+
+ my $sum = 0 ;
+ for my $age ( @tab )
+ { $sum += ( $age - $mean ) ** 2 ; }
+ my $stddev = sqrt ( $sum / ( $cnt - 1 ) ) ;
+
+ return $mean, $median, $stddev ;
+ }
+
+sub legend
+ { my $self = shift ;
+ my $conf = $self -> conf ;
+ my $min_sync = $conf -> min_sync ;
+ my $max_sync = $conf -> max_sync ;
+ my $min_poll = $conf -> min_poll ;
+ my $max_poll = $conf -> max_poll ;
+
return <<LEGENDA ;
<H3>legend</H3>
+
<H4><I>project</I> site -- home</H4>
+
<BLOCKQUOTE>
<B><I>project</I> site</B> is an url.
The <B>href</B> is the href for the site in the list of mirrors,
useful if the <B><I>project</I> site</B> url is invalid,
possibly because the mirror site moved the archive.
</BLOCKQUOTE>
+
<H4>type</H4>
+
<BLOCKQUOTE>
Indicates the type (<B>ftp</B> or <B>http</B>) of
the <B><I>project</I> site</B> and <B>home</B> urls.
</BLOCKQUOTE>
+
<H4>mirror age, daily stats</H4>
+
<BLOCKQUOTE>
The <B>mirror age</B> is based upon the last successful probe.
<P>
<TH COLSPAN=4>age</TH>
</TR>
<TR>
- <TH COLSPAN=2 BGCOLOR="YELLOW">this project</TH>
- <TH COLSPAN=2 BGCOLOR="AQUA">in general</TH>
+ <TH COLSPAN=2 BGCOLOR=YELLOW>this project</TH>
+ <TH COLSPAN=2 BGCOLOR=AQUA>in general</TH>
</TR>
<TR>
- <TH BGCOLOR="YELLOW">min</TH>
- <TH BGCOLOR="YELLOW">max</TH>
- <TH BGCOLOR="AQUA">min</TH>
- <TH BGCOLOR="AQUA">max</TH>
+ <TH BGCOLOR=YELLOW>min</TH>
+ <TH BGCOLOR=YELLOW>max</TH>
+ <TH BGCOLOR=AQUA>min</TH>
+ <TH BGCOLOR=AQUA>max</TH>
</TR>
<TR>
- <TH><FONT COLOR="GREEN">fresh</FONT></TH>
- <TD BGCOLOR="YELLOW" ALIGN="CENTER">0</TD>
- <TD BGCOLOR="YELLOW" ALIGN="CENTER">
- @{[$CNF{min_sync}]} + @{[$CNF{max_poll}]}</TD>
- <TD BGCOLOR="AQUA" ALIGN="CENTER">0</TD>
- <TD BGCOLOR="AQUA" ALIGN="CENTER">min_sync + max_poll</TD>
+ <TH><FONT COLOR=GREEN>fresh</FONT></TH>
+ <TD BGCOLOR=YELLOW ALIGN=CENTER>0</TD>
+ <TD BGCOLOR=YELLOW ALIGN=CENTER>$min_sync + $max_poll</TD>
+ <TD BGCOLOR=AQUA ALIGN=CENTER>0</TD>
+ <TD BGCOLOR=AQUA ALIGN=CENTER>min_sync + max_poll</TD>
</TR>
<TR>
- <TH><FONT COLOR="BLUE">oldish</FONT></TH>
- <TD BGCOLOR="YELLOW" ALIGN="CENTER">
- @{[$CNF{min_sync}]} + @{[$CNF{max_poll}]}</TD>
- <TD BGCOLOR="YELLOW" ALIGN="CENTER">
- @{[$CNF{max_sync}]} + @{[$CNF{max_poll}]}</TD>
- <TD BGCOLOR="AQUA" ALIGN="CENTER">min_sync + max_poll</TD>
- <TD BGCOLOR="AQUA" ALIGN="CENTER">max_sync + max_poll</TD>
+ <TH><FONT COLOR=BLUE>oldish</FONT></TH>
+ <TD BGCOLOR=YELLOW ALIGN=CENTER>$min_sync + $max_poll</TD>
+ <TD BGCOLOR=YELLOW ALIGN=CENTER>$max_sync + $max_poll</TD>
+ <TD BGCOLOR=AQUA ALIGN=CENTER>min_sync + max_poll</TD>
+ <TD BGCOLOR=AQUA ALIGN=CENTER>max_sync + max_poll</TD>
</TR>
<TR>
<TH><FONT COLOR="RED">old</FONT></TH>
- <TD BGCOLOR="YELLOW" ALIGN="CENTER">
- @{[$CNF{max_sync}]} + @{[$CNF{max_poll}]}</TD>
- <TD BGCOLOR="YELLOW" ALIGN="CENTER">∞</TD>
- <TD BGCOLOR="AQUA" ALIGN="CENTER">max_sync + max_poll</TD>
- <TD BGCOLOR="AQUA" ALIGN="CENTER">∞</TD>
+ <TD BGCOLOR=YELLOW ALIGN=CENTER>$max_sync + $max_poll</TD>
+ <TD BGCOLOR=YELLOW ALIGN=CENTER>∞</TD>
+ <TD BGCOLOR=AQUA ALIGN=CENTER>max_sync + max_poll</TD>
+ <TD BGCOLOR=AQUA ALIGN=CENTER>∞</TD>
</TR>
<TR>
- <TH><FONT COLOR="BLACK">bad</FONT></TH>
- <TH COLSPAN=4 BGCOLOR="BLACK">
- <FONT COLOR="WHITE">the site or mirror tree was never found</FONT></TH>
+ <TH><FONT COLOR=BLACK>bad</FONT></TH>
+ <TH COLSPAN=4 BGCOLOR=BLACK>
+ <FONT COLOR=WHITE>the site or mirror tree was never found</FONT></TH>
</TR>
</TABLE>
</BLOCKQUOTE>
</BLOCKQUOTE>
+
<H4>last probe, probe stats</H4>
+
<BLOCKQUOTE>
<B>Last probe</B> indicates when the last successful probe was made.
<B>Probe stats</B> gives the probe history (<I>right</I> is <I>recent</I>).
A probe is either a
-<FONT COLOR="GREEN"><B>success</B></FONT> or a
-<FONT COLOR="RED"><B>failure</B></FONT>.
+<FONT COLOR=GREEN><B>success</B></FONT> or a
+<FONT COLOR=RED><B>failure</B></FONT>.
</BLOCKQUOTE>
+
<H4>last stat</H4>
+
<BLOCKQUOTE>
<B>Last stat</B> gives the status of the last probe.
</BLOCKQUOTE>
+
LEGENDA
-}
-sub start_date {
- my $url = shift;
- my $CMD = shift;
- my $TIMEOUT = $CNF{timeout};
- my $src = $HREF{ lc site $url } || $url;
- $CMD =~ s/%TIMEOUT%/$TIMEOUT/g;
- $CMD =~ s/%URL%/$src/g;
- printf "*** SUBSTITUTE site %s\n+ url %s\n+ %s\n", site($url),
- $HREF{ lc site $url }, $CMD
- if $HREF{ lc site $url } and $opt{v};
- my $WGT = new IO::Pipe;
- my $res = $WGT->reader( split ' ', $CMD );
- if ($res) {
- $WGT->blocking(0);
- $GET->add($WGT);
- $URL{$WGT} = $url;
- }
- else { err $url, 'no pipe'; }
-}
-sub get_date {
- my $WGT = shift;
- my $url = $URL{$WGT};
- my $time = undef;
- $WGT->blocking(1);
- unless ( $WGT->eof() ) { $time = $WGT->getline(); }
- $GET->remove($WGT);
- $WGT->flush;
- $WGT->close;
- return err $url, 'no time' unless defined $time;
- return err $url, "empty" if $time =~ /^\s*$/;
- $time = ( split ' ', $time )[0];
- if ( $time !~ /^\d+$/ ) {
- $time = htmlquote $time ;
- $time = substr( $time, 0, 15 ) . '..' if length $time > 15;
- err $url, "'$time'";
- }
- else { res $url, $time, 'ok'; }
-}
-sub get_dates {
- my $CMD = shift;
- my @QUE;
- my $PAR = $CNF{max_probes};
- my $cnt_LST = scalar keys %LST;
- for my $url ( sort keys %LST ) {
- if ( $opt{get} eq 'all' or !exists $OLD{$url} ) { push @QUE, $url; }
- elsif ( $opt{get} eq 'update' ) {
- my $stat = $OLD{$url}[1];
- my $vrfy = $OLD{$url}[2];
- my $lprb = $OLD{$url}[5];
- if (
- (
- $lprb eq 'undef'
- or aprx_le $lprb,
- $^T - tim_to_s $CNF {min_poll}
- )
- and (
- $stat ne 'ok' or aprx_le $vrfy,
- $^T - tim_to_s $CNF {max_poll}
+ }
+
+sub _ths
+ { return '' unless my $ths = shift ;
+ $ths == 1 ? TH '' : "<TH COLSPAN=$ths></TH>\n" ;
+ }
+
+sub gen_histogram
+ { my $self = shift ;
+ my $where = shift ;
+ my $conf = $self -> conf ;
+ my $state = $self -> state ;
+
+ return '' if $where ne $conf -> put_histo ;
+
+ my $MAX_H = $conf -> max_age1 ;
+ my $MAX_h = 1 +
+ ( ( 20 * 3600 <= $MAX_H and $MAX_H <= 36 * 3600 )
+ ? int ( $MAX_H / 3600 )
+ : 25
+ ) ;
+ my $MAX_O = $conf -> max_age2 ;
+ my $MAX_o = int ( $MAX_O / 3600 + 0.5 ) ;
+ my $H = 18 ;
+ my %W = ( 'old' => 1, 'ded' => 1, 'bad' => 1 ) ;
+ my %Wmx = ( 'old' => 5, 'ded' => 3, 'bad' => 3 ) ;
+ my %tab ;
+ my %hst ;
+ my $res ;
+ for ( my $x = 0 ; $x < $MAX_h ; $x ++ ) { $tab { $x } = 0 ; }
+ $tab { old } = 0 ; $tab { ded } = 0 ; $tab { bad } = 0 ;
+ for my $url ( keys %$state )
+ { my $time = $state -> { $url } -> age ;
+ if ( $time =~ /^\d+$/ )
+ { my $s = $^T - $time ;
+ my $hr = int ( $s / $MAX_H * ( $MAX_h - 1 ) + 0.5 ) ;
+ if ( $s <= $MAX_H ) { $tab { $hr } ++ ; }
+ elsif ( $s <= $MAX_O ) { $tab { old } ++ ; }
+ else { $tab { ded } ++ ; }
+ }
+ else
+ { $tab { bad } ++ ; }
+ }
+ my $max = 0 ;
+ for ( grep ! exists $Wmx { $_ }, keys %tab )
+ { $max = $tab { $_ } if $tab { $_ } > $max ; }
+
+ my %bad ;
+
+ for my $aux ( keys %Wmx )
+ { $bad { $aux } = $tab { $aux } ;
+ if ( $bad { $aux } > $max )
+ { $W { $aux } = $Wmx { $aux } ;
+ my $d = int ( $bad { $aux } / $W { $aux } ) ;
+ for ( my $i = 1 ; $i < $W { $aux } ; $i++ )
+ { $tab { $aux . $i } = $d ;
+ if ( $bad { $aux } % $Wmx { $aux } > $i )
+ { $tab { $aux . $i } ++ ;
+ $tab { $aux } -- ;
+ }
+ }
+ $tab { $aux } -= ( $W { $aux } - 1 ) * $d ;
+ $max = $tab { $aux } if $max < $tab { $aux } ;
+ }
+ }
+
+# if ( $opt{v} )
+# { for my $hr ( keys %tab )
+# { printf "tab '%s' = '%s'\n", $hr, $tab { $hr } ; }
+# }
+
+ return 'nothing yet' unless $max ;
+ $H = $max if 8 <= $max and $max <= 26 ;
+ for ( keys %tab )
+ { $hst { $_ } = int ( $H * $tab { $_ } / $max + 0.5 ) ; }
+ my @keys = sort { $a <=> $b } grep /^\d+$/, keys %hst ;
+ my $tab_hr = 0 ;
+ for my $hr ( @keys ) { $tab_hr += $tab { $hr } ; }
+ push @keys
+ , grep ( m/^old/, sort keys %tab )
+ , grep ( m/^ded/, sort keys %tab )
+ , grep ( m/^bad/, sort keys %tab )
+ ;
+ my $img_bar = sprintf '<IMG SRC="%s/bar.gif" ALT="" BORDER=0>'
+ , $conf -> icons ;
+ my %img = ( bar => $img_bar ) ;
+ for my $col ( qw(s b f z) ) { $img { $col } = $self -> img_sf ( $col ) ; }
+
+ for ( my $h = $H ; $h > 0 ; $h -- )
+ { $res .= "<TR>\n" ;
+ $res .= sprintf "<TH ROWSPAN=3 VALIGN=\"TOP\">↑</TH>\n"
+ if $h == $H ;
+ $res .= sprintf '<TD ROWSPAN=%d ALIGN="CENTER">%s</TD>' . "\n"
+ , $H-6, NSS ( $max ) if $h == $H - 3 ;
+ $res .= sprintf "<TH ROWSPAN=3 VALIGN=\"BOTTOM\">↓</TH>\n"
+ if $h == 3 ;
+ my $ths = 0 ;
+ for my $x ( @keys )
+ { my $col =
+ ( ( $hst { $x } >= $h )
+ ? ( $x =~ /^\d+$/
+ ? 's'
+ : ( $x =~ /^old/ ? 'b' : ( $x =~ /^ded/ ? 'f' : 'z' ) )
)
+ : ( ( $h == 1 and $hst { $x } == 0 ) ? 'bar' : '' )
+ ) ;
+ if ( $col )
+ { $res .= _ths $ths ; $ths = 0 ; $res .= TH $img { $col } ; }
+ else
+ { $ths ++ ; }
+ }
+ $res .= _ths ( $ths ) . "</TR>\n" ;
+ }
+
+ my $HR = '<HR SIZE=2 WIDTH="95%%" NOSHADE>' ;
+
+ $res .= "<TR>\n" ;
+ $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", 1 ;
+ $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", $MAX_h ;
+ $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", $W { old } ;
+ $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", $W { ded } ;
+ $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", $W { bad } ;
+ $res .= "</TR>\n" ;
+
+ $res .= "<TR>\n" ;
+ $res .= '<TD ALIGN="CENTER"> <B>age</B> → </TD>' ;
+
+ $res .= "<TH>|</TH>\n" ;
+ $res .= sprintf
+ ( '<TD COLSPAN=%d ALIGN="CENTER">'
+ . '← 0 ≤ <B>age</B> ≤ %s →'
+ . "</TD>\n"
+ , $MAX_h - 2, pr_interval ( $MAX_H )
+ )
+ ;
+ $res .= "<TH>|</TH>\n" ;
+ $res .= sprintf
+ ( '<TD ALIGN="CENTER" COLSPAN=%d>'
+ . ' %sh < %s ≤ %sh '
+ . "</TD>\n"
+ , $W { old }, int($MAX_H/60/60) , BLD ( 'age' ), $MAX_o
+ ) ;
+ $res .= sprintf
+ ( '<TD ALIGN="CENTER" COLSPAN=%d>'
+ . ' <FONT COLOR="RED">old</FONT> '
+ . "</TD>\n"
+ , $W { ded }
+ ) ;
+ $res .= sprintf
+ ( '<TD ALIGN="CENTER" COLSPAN=%d>'
+ . ' <FONT COLOR="RED">bad</FONT> '
+ . "</TD>\n"
+ , $W { bad }
+ ) ;
+ $res .= "</TR>\n" ;
+
+ my $FRMT = '<TD ALIGN="CENTER" COLSPAN=%d> %s </TD>' ;
+
+ $res .= "<TR>\n" ;
+ $res .= sprintf "$FRMT\n", 1, NSS scalar keys %$state ;
+ $res .= "<TH>|</TH>\n" ;
+ $res .= sprintf "$FRMT\n", $MAX_h - 2, NSS $tab_hr ;
+ $res .= "<TH>|</TH>\n" ;
+ $res .= sprintf "$FRMT\n", $W { old }, NSS $bad { old } ;
+ $res .= sprintf "$FRMT\n", $W { ded }, NSS $bad { ded } ;
+ $res .= sprintf "$FRMT\n", $W { bad }, NSS $bad { bad } ;
+ $res .= "</TR>\n" ;
+
+ $res = "<TABLE CELLSPACING=0 CELLPADDING=1 BORDER=0>\n$res\n</TABLE>\n" ;
+ $res = sprintf "<TABLE CELLPADDING=5 BORDER=4>%s</TABLE>\n"
+ , "<TR><TH>\n$res\n</TH></TR>" ;
+ my $units = join ' '
+ , $self -> img_sf ( 's' ) , $self -> img_sf ( 'b' )
+ , $self -> img_sf ( 'f' ) , $self -> img_sf ( 'z' )
+ ;
+ if ( $max == $H )
+ { $res .= sprintf "<BR>units %s represent one mirror site.\n"
+ , $units ;
+ }
+ else
+ { $res .= sprintf "<BR>each %s unit represents %s mirror sites.\n"
+ , $units, sprintf ( "%.1f", $max / $H ) ;
+ }
+ return H2 ( 'age histogram' ) . BQ $res ;
+ }
+
+sub gen_page
+ { my $self = shift ;
+ my $get = shift ;
+ my $VERSION = shift ;
+ my $conf = $self -> conf ;
+ my $PPP = $conf -> web_page ;
+ my $state = $self -> state ;
+ my $CCS = $self -> regions ;
+ my $TMP = "$PPP.tmp" ;
+ my %tab ;
+ my $refs ;
+
+ for my $url ( keys %$state )
+ { my $mirror = $state -> { $url } ;
+ my $reg = $mirror -> region ;
+ push @{ $tab { $reg } }, $mirror ;
+ }
+
+ my $bad = 0 ; my $old = 0 ; my $unr = 0 ;
+ my %stats ;
+ my @stats ;
+ my $ok = 0 ;
+
+ for my $url ( keys %$state )
+ { my $mirror = $state -> { $url } ;
+ my $time = $mirror -> age ;
+ my $stat = $mirror -> last_status ;
+ my $vrfy = $mirror -> last_ok_probe ;
+ if ( $stat eq 'ok' ) { $ok ++ ; } else { $stats { $stat } ++ ; }
+ if ( $time eq 'undef' )
+ { $bad ++ ; }
+ elsif ( 'f' eq $conf -> age_code ( $time ) )
+ { $old ++ ; }
+ if ( $vrfy eq 'undef' or aprx_lt $vrfy, $^T - $conf -> max_vrfy )
+ { $unr ++ ; }
+ }
+
+ my $STAT = sprintf
+ "%d bad -- %d older than %s -- %s unreachable for more than %s"
+ , $bad
+ , $old
+ , pr_interval ( $conf -> max_age2 )
+ , $unr
+ , pr_interval ( $conf -> max_vrfy )
+ ;
+
+ my $PROB = 'last probes : ' ;
+ push @stats, "$ok were ok" if $ok ;
+ for my $stat ( sort keys %stats )
+ { ( my $txt = $stat ) =~ s/_/ /g ;
+ push @stats, sprintf "%s had %s" , $stats { $stat } , RED $txt ;
+ }
+ $PROB .= join ', ', @stats ;
+
+ my ( $mean, $median, $stddev ) = $self -> age_avg ;
+ my $AVGS = "mean mirror age is " ;
+ unless ( defined $mean )
+ { $AVGS = "<I>undefined</I>" ; }
+ else
+ { $AVGS .= sprintf "%s", pr_interval $mean ;
+ if ( defined $stddev )
+ { $AVGS .= sprintf ", std_dev %s", pr_interval $stddev ; }
+ $AVGS .= sprintf ", median %s", pr_interval $median ;
+ }
+
+ for my $reg ( sort keys %tab )
+ { $refs .= sprintf " %s \n"
+ , URL "#$reg", "<FONT SIZE=\"+1\">$reg</FONT>"
+ ;
+ }
+
+ my $COLS = 5 ;
+ my $NAME = $conf -> project_name ;
+ my $LOGO = $conf -> project_logo
+ ? URL
+ ( $conf -> project_url
+ , sprintf
+ ( '<IMG SRC="%s" ALT="%s" ALIGN="RIGHT" BORDER=0>'
+ , $conf -> project_logo
+ , $conf -> project_name
)
- {
- push @QUE, $url;
- }
- elsif ( $CNF{randomize} and 0 == int rand $cnt_LST ) {
- push @QUE, $url;
- }
- else { $RES{$url} = $OLD{$url}; }
- }
- else { Error "unknown opt_get '$opt{get}'"; }
- }
- while (@QUE) {
- while ( $GET->count() < $PAR and @QUE ) {
- my $url = shift @QUE;
- if ( gethost site $url ) { start_date $url, $CMD; }
- else { err $url, 'site not found'; }
- }
- my @can_read = $GET->can_read(0);
- printf "que %d, get %d, can %d\n", scalar @QUE, $GET->count(),
- scalar @can_read
- if $opt{v};
- for my $can_read (@can_read) { get_date $can_read ; }
- sleep 1;
- }
- my $stop = time + $CNF{timeout} + 10;
- while ( $GET->count() and time < $stop ) {
- sleep 1;
- my @can_read = $GET->can_read(0);
- printf "wait %2d, get %d, can %d\n", $stop - scalar time, $GET->count(),
- scalar @can_read
- if $opt{v};
- for my $can_read (@can_read) { get_date $can_read ; }
- }
- for my $WGT ( $GET->handles() ) {
- my $url = $URL{$WGT};
- err $url, 'hangs';
+ )
+ : ''
+ ;
+ my $HEAD = $conf -> htm_head . "\n" ;
+ my $HTOP = $conf -> htm_top . "\n" ;
+ my $FOOT = $conf -> htm_foot . "\n" ;
+ my $TITL = URL $conf -> project_url, $NAME ;
+ my $EXPD = Base::exp_date ;
+ my $DATE = scalar gmtime $^T ;
+ my $LAST = scalar gmtime ( $get ? $^T : ( stat $conf -> state ) [9] ) ;
+
+ my $histo_top = $self -> gen_histogram ( 'top' ) ;
+ my $histo_bot = $self -> gen_histogram ( 'bottom' ) ;
+
+ open PPP, ">$TMP" or die "can't write $TMP ($!)" ;
+ my $prev_select = select PPP ;
+
+ my $attr1 = "COLSPAN=$COLS BGCOLOR=LIME" ;
+ my $attr2 = 'BGCOLOR=AQUA' ;
+ my $attr3 = "COLSPAN=$COLS BGCOLOR=YELLOW" ;
+
+ my $num_mirrors = scalar keys %$state ;
+ my $num_regions = scalar keys %tab ;
+
+ print <<HEAD ;
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<HTML>
+<HEAD>
+<TITLE>the status of $NAME mirrors</TITLE>
+<META HTTP-EQUIV="content-type" CONTENT="text/html; charset=utf-8">
+<META HTTP-EQUIV=refresh CONTENT=3600>
+<META HTTP-EQUIV=Expires CONTENT=\"$EXPD\">
+$HEAD
+</HEAD>
+<BODY BGCOLOR=\"#FFFFFF\">
+$LOGO
+<H2>the status of $TITL mirrors</H2>
+<TABLE BORDER=0 CELLPADDING=2>
+<TR><TD>date</TD><TD>:</TD><TD>$DATE (UTC)</TD></TR>
+<TR><TD>last check</TD>
+ <TD>:</TD>
+ <TD>$LAST (UTC)</TD>
+</TR>
+</TABLE>
+$HTOP
+$histo_top
+<H2>regions</H2>
+<BLOCKQUOTE><CENTER>\n$refs\n</CENTER></BLOCKQUOTE>
+<H2>report</H2>
+<BLOCKQUOTE>
+<TABLE BORDER=2 CELLPADDING=5>
+<TR><TH $attr1>$num_mirrors sites in $num_regions regions</TH></TR>
+<TR><TH $attr1>$STAT</TH></TR>
+<TR><TH $attr1>$PROB</TH></TR>
+<TR><TH $attr1>$AVGS</TH></TR>
+<TR>
+ <TH $attr2>$NAME site -- home</TH>
+ <TH $attr2>type</TH>
+ <TH $attr2>mirror age,<BR>daily stats</TH>
+ <TH $attr2>last probe,<BR>probe stats</TH>
+ <TH $attr2>last stat</TH>
+</TR>
+HEAD
+
+ for my $reg
+ ( sort
+ { ( $CCS -> { $a } || $a ) cmp ( $CCS -> { $b } || $b ) ; }
+ keys %tab
+ )
+ { my $mirrors = $tab { $reg } ;
+
+ my $ccs = exists $CCS -> { $reg } ? $CCS -> { $reg } : $reg ;
+ $ccs = NAM $reg,
+ ( scalar @{ $mirrors } > 6
+ ? sprintf "%s - %d sites"
+ , $ccs, scalar @{ $mirrors }
+ : $ccs
+ ) ;
+ printf "<TR><TH $attr3>$ccs</TH></TR>\n" ;
+
+ for my $mirror ( sort { $a -> cmp ( $b ) } @$mirrors )
+ { print "<TR>\n" ;
+ printf " <TD ALIGN=RIGHT>%s %s</TD>\n <TD>%s</TD>\n"
+ , $mirror -> site_url
+ , $mirror -> home_url
+ , $mirror -> type
+ ;
+
+ my ( $url, $time, $stat, $vrfy, $hstp, $hsts ) =
+ $mirror -> as_list ;
+ my $pr_time = $time =~ /^\d+$/
+ ? pr_diff $time, $^T - $conf -> max_age2 : ' ' ;
+ my $pr_last = $vrfy =~ /^\d+$/
+ ? pr_diff $vrfy, $^T - $conf -> max_vrfy : ' ' ;
+ my $pr_hstp = $self -> show_hist ( $hstp ) ;
+ my $pr_hsts = $self -> show_hist ( $hsts ) ;
+
+ if ( $stat ne 'ok' ) { $stat =~ s/_/ /g ; $stat = RED $stat ; }
+ printf " <TD ALIGN=RIGHT>%s<BR>%s</TD>\n" , $pr_time, $pr_hsts ;
+ printf " <TD ALIGN=RIGHT>%s<BR>%s</TD>\n" , $pr_last, $pr_hstp ;
+ printf " <TD>%s</TD>\n", $stat ;
+ print "</TR>\n" ;
+ }
+ }
+
+ my $legend = $self -> legend ;
+ my $probes = $self -> gen_histogram_probes ;
+ my $mir_img = sprintf
+ '<IMG BORDER=2 ALT=mirmon SRC="%s/mirmon.gif">' , $conf -> icons ;
+
+ print <<TAIL ;
+</TABLE>
+</BLOCKQUOTE>
+$histo_bot
+$legend
+<H3>probe results</H3>
+$probes
+<H3>software</H3>
+<BLOCKQUOTE>
+<TABLE>
+<TR>
+ <TH><A HREF=\"$HOME\">$mir_img</A></TH>
+ <TD>$VERSION</TD>
+</TR>
+</TABLE>
+</BLOCKQUOTE>
+$FOOT
+</BODY>
+</HTML>
+TAIL
+
+ select $prev_select ;
+
+ if ( print PPP "\n" )
+ { close PPP ;
+ if ( -z $TMP )
+ { warn "wrote empty html file; keeping previous version" ; }
+ else
+ { rename $TMP, $PPP or die "can't rename $TMP, $PPP ($!)" ; }
+ }
+ else
+ { die "can't print to $TMP ($!)" ; }
+ }
+
+package Mirmon::Conf ; #############################################
+
+BEGIN { use base 'Base' ; Base -> import () ; }
+
+our %CNF_defaults =
+ ( project_logo => ''
+ , timeout => $DEF_TIMEOUT
+ , max_probes => 25
+ , min_poll => '1h'
+ , max_poll => '4h'
+ , min_sync => '1d'
+ , max_sync => '2d'
+ , list_style => 'plain'
+ , put_histo => 'top'
+ , randomize => 1
+ , add_slash => 1
+ , htm_top => ''
+ , htm_foot => ''
+ , htm_head => ''
+ ) ;
+
+our @REQ_KEYS =
+ qw( web_page state countries mirror_list probe
+ project_name project_url icons
+ ) ;
+our %CNF_KEYS ;
+for ( @REQ_KEYS, keys %CNF_defaults ) { $CNF_KEYS { $_ } ++ ; }
+
+my @LIST_STYLE = qw(plain apache) ;
+my @PUT_HGRAM = qw(top bottom nowhere) ;
+
+eval Base -> mk_methods ( keys %CNF_KEYS, qw(root site_url) ) ;
+
+sub new
+ { my $self = shift ;
+ my $FILE = shift ;
+ my $res = bless { %CNF_defaults }, $self ;
+ $res -> root ( $FILE ) ;
+ $res -> site_url ( {} ) ;
+ $res -> get_conf () ;
+ }
+
+sub get_conf
+ { my $self = shift ;
+ my $FILE = ( @_ ? shift : $self -> root ) ;
+
+ if ( grep $_ eq $FILE, @{ $self -> {_include} } )
+ { die "already included : '$FILE'" ; }
+ else
+ { push @{ $self -> {_include} }, $FILE ; }
+
+ open FILE, $FILE or die "can't open '$FILE' ($!)" ;
+ my $CONF = join "\n", grep /./, <FILE> ;
+ close FILE ;
+
+ $CONF =~ s/\t/ /g ; # replace tabs
+ $CONF =~ s/^[+ ]+// ; # delete leading space, plus
+ $CONF =~ s/\n\n\s+/ /g ; # glue continuation lines
+ $CONF =~ s/\n\n\+\s+//g ; # glue concatenation lines
+ $CONF =~ s/\n\n\./\n/g ; # glue concatenation lines
+
+ chop $CONF ;
+ print "--$CONF--\n" if Mirmon::debug ;
+ for ( grep ! /^#/, split /\n\n/, $CONF )
+ { my ($key,$val) = split ' ', $_, 2 ;
+ $val = '' unless defined $val ;
+ print "conf '$FILE' : key '$key', val '$val'\n" if Mirmon::debug ;
+ if ( exists $CNF_KEYS { $key } )
+ { $self -> $key ( $val ) ; }
+ elsif ( $key eq 'site_url' )
+ { my ( $site, $url ) = split ' ' , $val ;
+ $url .= '/' if $self -> add_slash and $url !~ m!/$! ;
+ $self -> site_url -> { $site } = $url ;
+# printf "config : for site '%s' use instead\n '%s'\n",
+# $site, $url if Mirmon::verbose ;
+ }
+ elsif ( $key eq 'no_add_slash' )
+ { $self -> add_slash ( 0 ) ; }
+ elsif ( $key eq 'no_randomize' )
+ { $self -> randomize ( 0 ) ; }
+ elsif ( $key eq 'show' )
+ { $self -> show_conf if Mirmon::verbose ; }
+ elsif ( $key eq 'exit' )
+ { die 'exit per config directive' ; }
+ elsif ( $key eq 'include' )
+ { $self -> get_conf ( $val ) ; }
+ elsif ( $key eq 'env' )
+ { my ( $x, $y ) = split ' ' , $val ;
+ $ENV { $x } = $y ;
+ printf "config : setenv '%s'\n '%s'\n", $x, $y
+ if Mirmon::verbose ;
+ }
+ else
+ { $self -> show_conf ;
+ die "unknown keyword '$key' (value '$val')\n" ;
+ }
+ }
+ my $err = $self -> check ;
+ die $err if $err ;
+ $self ;
+ }
+
+sub check
+ { my $self = shift ;
+ my $err = '' ;
+ for my $key ( @REQ_KEYS )
+ { unless ( exists $self -> { $key } )
+ { $err .= "error: missing config for '$key'\n" ; }
+ }
+ for my $key ( qw(min_poll max_poll max_sync min_sync) )
+ { my $max = $self -> $key ;
+ unless ( $max =~ /$TIM_PAT/o )
+ { $err .= "error: bad timespec for $key ($max)\n" ; }
+ }
+ unless ( grep $self -> { list_style } eq $_, @LIST_STYLE )
+ { $err .= sprintf "error: unknown 'list_style' '%s'\n",
+ $self -> list_style ;
+ }
+ unless ( grep $self -> put_histo eq $_, @PUT_HGRAM )
+ { $err .= sprintf "%s : error: unknown 'put_histo' '%s'\n",
+ $self -> put_histo ;
+ }
+ $err ;
+ }
+
+sub show_conf
+ { my $self = shift ;
+ print "vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv\n" ;
+ for my $key ( sort keys %$self )
+ { next if $key =~ m/^_/ ;
+ my $val = $self -> { $key } ;
+ print "show_conf : $key = '$val'\n" ;
+ }
+ for my $key ( sort keys %{ $self -> site_url } )
+ { printf "show_conf : for site '%s' use instead\n '%s'\n"
+ , $key, $self -> site_url -> { $key } if Mirmon::verbose ;
+ }
+ printf "show_conf : included '%s'\n"
+ , join "', '", @{ $self -> {_include} } ;
+ print "^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n" ;
+ }
+
+sub max_age1
+ { my $self = shift ;
+ ( s4tim $self -> min_sync ) + ( s4tim $self -> max_poll ) ;
+ }
+
+sub max_age2
+ { my $self = shift ;
+ ( s4tim $self -> max_sync ) + ( s4tim $self -> max_poll ) ;
+ }
+
+sub max_vrfy
+ { my $self = shift ;
+ ( s4tim $self -> min_poll ) + ( s4tim $self -> max_poll ) ;
+ }
+
+sub age_code
+ { my $self = shift ;
+ my $time = shift ;
+ return 'z' unless $time =~ /^\d+$/ ;
+ return
+ ( ( aprx_ge ( $time, $^T - $self -> max_age1 ) )
+ ? 's'
+ : ( aprx_ge ( $time, $^T - $self -> max_age2 ) ? 'b' : 'f' )
+ ) ;
+ }
+
+package Mirmon::Mirror ; ###########################################
+
+BEGIN { use base 'Base' ; Base -> import () ; }
+
+use IO::Pipe ;
+
+my @FIELDS =
+ qw(url age last_status last_ok_probe probe_history state_history last_probe) ;
+
+eval Base -> mk_methods ( @FIELDS, qw(mirmon region mail) ) ;
+
+sub state_history_time
+ { my $self = shift ;
+ my $res = ( split /-/, $self -> state_history ) [ 0 ] ;
+ $res ;
+ }
+
+sub state_history_hist
+ { my $self = shift ;
+ my $res = ( split /-/, $self -> state_history ) [ 1 ] ;
+ $res ;
+ }
+
+sub _parse
+ { my $self = shift ;
+ my $url = $self -> url ;
+ my ( $type, $site, $home ) ;
+ if ( $url =~ m!^(ftp|https?|rsync)://([^/:]+)(:\d+)?/! )
+ { $type = $1 ; $site = $2 ; $home = $& ; }
+ return $type, $site, $home ;
+ }
+
+sub type { my $self = shift ; ( $self -> _parse ) [ 0 ] ; }
+sub site { my $self = shift ; ( $self -> _parse ) [ 1 ] ; }
+sub home { my $self = shift ; ( $self -> _parse ) [ 2 ] ; }
+
+sub age_in_days
+ { my $self = shift ;
+ my $res = 'undef' ;
+ my $age = $self -> age ;
+ if ( $age eq 'undef' )
+ { $res = length $self -> state_history_hist
+ if $self -> last_probe ne 'undef' ;
+ }
+ else
+ { $res = ( $^T - $age ) / 24 / 60 / 60 ; }
+ $res ;
+ }
+
+sub init
+ { my $self = shift ;
+ my $mirmon = shift ;
+ my $url = shift ;
+ my $res = bless { mirmon => $mirmon }, $self ;
+ @{ $res } { @FIELDS } = ( 'undef' ) x scalar @FIELDS ;
+ $res -> url ( $url ) ;
+ $res -> probe_history ( '' ) ;
+ $res -> state_history ( "$^T-z" ) ;
+ $res -> mail ( '' ) ;
+ $res ;
+ }
+
+sub new
+ { my $self = shift ;
+ my $mirmon = shift ;
+ my $line = shift ;
+ my $res = bless { mirmon => $mirmon }, $self ;
+ @{ $res } { @FIELDS } = split ' ', $line ;
+ $res -> mail ( '' ) ;
+ $res ;
+ }
+
+sub update
+ { my $self = shift ;
+ my $succ = shift ;
+ my $stat = shift ;
+ my $time = shift ;
+ my $probe_hist = $self -> probe_history ;
+ if ( $succ )
+ { $self -> age ( $time ) ;
+ $self -> last_ok_probe ( $^T ) ;
+ $probe_hist .= 's' ;
+ }
+ else
+ { $probe_hist .= 'f' ;
+ $time = $self -> age ;
+ }
+
+ my $h = $self -> state_history_hist ;
+ my $t = $self -> state_history_time ;
+
+ if ( aprx_ge ( $^T - $t, $HIST_DELTA ) )
+ { my $n = int ( ( $^T - $t ) / $HIST_DELTA ) ;
+ $h .= 'x' x ( $n - 1 ) ;
+ $t = ( $n == 1 ? $t + $HIST_DELTA : $^T ) ;
+ }
+ else
+ { chop $h ; }
+ $h .= $self -> mirmon -> conf -> age_code ( $time ) ;
+ $h = substr $h, - $HIST ;
+ $h =~ s/^x+// ;
+
+ $self -> last_status ( $stat ) ;
+ $self -> probe_history ( substr $probe_hist, - $HIST ) ;
+ $self -> last_probe ( $^T ) ;
+ $self -> state_history ( "$t-$h" ) ;
+ }
+
+sub as_list { my $self = shift ; @{ $self } { @FIELDS } ; }
+sub state { my $self = shift ; join ' ', $self -> as_list ; }
+
+sub start_probe
+ { my $self = shift ;
+ my $conf = $self -> mirmon -> conf ;
+ my $probe = $conf -> probe ;
+ my $timeout = $conf -> timeout ;
+ $probe =~ s/%TIMEOUT%/$timeout/g ;
+ my $url = $self -> url ;
+ my $new = $conf -> site_url -> { $self -> site } ;
+ if ( defined $new )
+ { printf "*** site_url : site %s\n -> url %s\n"
+ , $self -> site, $new if Mirmon::verbose ;
+ $url = $new ;
+ }
+ $probe =~ s/%URL%/$url/g ;
+ my $pipe = new IO::Pipe ;
+ my $handle = $pipe -> reader ( split ' ', $probe ) ;
+ if ( $handle )
+ { $pipe -> blocking ( 0 ) ; }
+ else
+ { die "start_probe : no pipe for $url" ; }
+ printf "start %s\n", $url if Mirmon::verbose ;
+ printf " %s\n", $probe if Mirmon::debug ;
+ $handle ;
+ }
+
+sub finish_probe
+ { my $self = shift ;
+ my $handle = shift ;
+ my $res ;
+ my $succ = 0 ;
+ my $stat ;
+ my $time ;
+
+ $handle -> blocking ( 1 ) ;
+ if ( $handle -> eof () )
+ { printf "finish eof %s\n", $self -> url if Mirmon::verbose ; }
+ else
+ { $res = $handle -> getline () ; }
+ $handle -> flush ;
+ $handle -> close ;
+
+ unless ( defined $res )
+ { $stat = 'no_time' ; }
+ elsif ( $res =~ /^\s*$/ )
+ { $stat = 'empty' ; }
+ else
+ { $res = ( split ' ', $res ) [ 0 ] ;
+
+ if ( $res !~ /^\d+$/ )
+ { $res =~ s/ /_/g ;
+ $res = Base::htmlquote $res ;
+ $res = substr ( $time, 0, 15 ) . '..' if length $res > 15 ;
+ $stat = "'$res'" ;
+ }
+ else
+ { $succ = 1 ; $stat = 'ok' ; $time = $res ; }
+ }
+
+ printf "finish %s\n succ(%s) stat(%s) time(%s)\n"
+ , $self -> url
+ , $succ
+ , $stat
+ , ( defined $time ? $time : 'undef' )
+ if Mirmon::verbose ;
+
+ $self -> update ( $succ, $stat, $time ) ;
+ }
+
+sub revdom { my $dom = shift ; join '.', reverse split /\./, $dom ; }
+
+sub cmp
+ { my $a = shift ;
+ my $b = shift ;
+ ( revdom $a -> site ) cmp ( revdom $b -> site )
+ or
+ ( $a -> type cmp $b -> type )
+ ;
+ }
+
+sub _url
+ { my $hrf = shift ;
+ my $txt = shift ;
+ $hrf =~ /^rsync/ ? $txt : URL $hrf, $txt ;
+ }
+
+sub site_url { my $self = shift ; _url $self -> url , $self -> site ; }
+sub home_url { my $self = shift ; _url $self -> home, '@' ; }
+
+=pod
+
+=head1 NAME
+
+Mirmon - OO interface for mirmon objects
+
+=head1 SYNOPSIS
+
+ use Mirmon ;
+
+ $m = Mirmon -> new ( [ $path-to-config ] )
+
+ $conf = $m -> conf ; # a Mirmon::Conf object
+ $state = $m -> state ; # the mirmon state
+
+ for my $url ( keys %$state )
+ { $mirror = $state -> { $url } ; # a Mirmon::Mirror object
+ $mail = $mirror -> mail ; # contact address
+ $mirror -> age ( time ) ; # set mirror age
}
-}
-get_conf_opt;
-get_ccs $CNF {countries};
-get_state $CNF {state};
-get_list $CNF {mirror_list};
-if ( $opt{get} ) {
- get_dates $CNF {probe};
- put_state $CNF {state};
-}
-else { %RES = %OLD }
-gen_page $CNF {web_page};
+
+Many class and object methods can be used to get or set attributes :
+
+ $object -> attribute # get an atttibute
+ $object -> attribute ( $attr ) # set an atttibute
+
+=head1 Mirmon class methods
+
+=over 4
+
+=item B<new ( [$path] )>
+
+Create a Mirmon object from a config file found in $path,
+or (by default) in the default list of possible config files.
+Related objects (config, state) are created and initialised.
+
+=item verbosity
+
+Mirmon always reports errors. Normally it only reports
+changes (inserts/deletes) found in the mirror_list ;
+in I<quiet> mode, it doesn't. In I<verbose> mode, it
+reports progress: the startup and finishing of probes.
+
+ Mirmon::verbose ( [ $bool ] ) # get/set verbose
+ Mirmon::quiet ( [ $bool ] ) # get/set quiet
+ Mirmon::debug ( [ $bool ] ) # get/set debug
+
+=back
+
+=head1 Mirmon object methods
+
+=over 4
+
+=item B<conf>
+
+Returns Mirmon's Mirmon::Conf object.
+
+=item B<state>
+
+Returns a hashref C<< { url => mirror, ... } >>,
+where I<url> is as specified in the mirror list
+and I<mirror> is a Mirmon::Mirror object.
+
+=item B<regions>
+
+Returns a hashref C<< { country_code =E<gt> country_name, ... } >>.
+
+=item B<config_list>
+
+Returns the list of default locations for config files.
+
+=item B<get_dates ( $get )>
+
+Probes all mirrors if $get is C<all> ; or a subset if $get is C<update>.
+
+=back
+
+=head1 Mirmon::Conf object methods
+
+A Mirmon::Conf object represents a mirmon conguration.
+It is normaly created by Mirmon::new().
+A specified (or default) config file is read and interpreted.
+
+=over 4
+
+=item attribute methods
+
+For every config file entry, there is an attribute method :
+B<web_page>, B<state>, B<countries>, B<mirror_list>, B<probe>,
+B<project_name>, B<project_url>, B<icons>, B<project_logo>,
+B<timeout>, B<max_probes>, B<min_poll>, B<max_poll>, B<min_sync>,
+B<max_sync>, B<list_style>, B<put_histo>, B<randomize>, B<add_slash>.
+
+=item B<root>
+
+Returns the file name of (the root of) the configuration file(s).
+
+=item B<site_url>
+
+Returns a hashref C<< { site => url, ... } >>,
+as specified in the mirmon config file.
+
+=back
+
+=head1 Mirmon::Mirror object methods
+
+A Mirmon::Mirror object represents the last known state of a mirror.
+It is normaly created by Mirmon::new() from the state file,
+as specified in the mirmon config file.
+Mirmon::Mirror objects can be used to probe mirrors.
+
+=head2 attribute methods
+
+=over 4
+
+=item B<url>
+
+The url as given in the mirror list.
+
+=item B<age>
+
+The mirror's timestamp found by the last succesful probe,
+or 'undef' if no probe was ever successful.
+
+=item B<last_status>
+
+The status of the last probe, or 'undef' if the mirror was never probed.
+
+=item B<last_ok_probe>
+
+The timestamp of the last succesful probe or 'undef'
+if the mirror was never successfully probed.
+
+=item B<probe_history>
+
+The probe history is a list of 's' (for success) and 'f' (for failure)
+characters indicating the result of the probe. New results are appended
+whenever the mirror is probed.
+
+=item B<state_history>
+
+The state history consists of a timestamp, a '-' char, and a list of
+chars indicating a past status: 's' (fresh), 'b' (oldish), 'f' (old),
+'z' (bad) or 'x' (skip).
+The timestamp indicates when the state history was last updated.
+The current status of the mirror is determined by the mirror's age and
+a few configuration parameters (min_sync, max_sync, max_poll).
+The state history is updated when the mirror is probed.
+If the last update of the history was less than 24 hours ago,
+the last status is replaced by the current status.
+If the last update of the history was more than 24 hours ago,
+the current status is appended to the history.
+One or more 'skip's are inserted, if the timestamp is two or more days old
+(when mirmon hasn't run for more than two days).
+
+=item B<last_probe>
+
+The timestamp of the last probe, or 'undef' if the mirror was never probed.
+
+=back
+
+=head2 object methods
+
+=over 4
+
+=item B<mirmon>
+
+Returns the parent Mirmon object.
+
+=item B<state_history_time>
+
+Returns the I<time> part of the state_history attribute.
+
+=item B<state_history_hist>
+
+Returns the I<history> part of the state_history attribute.
+
+=item B<type>, B<site>, B<home>
+
+For an url like I<ftp://www.some.org/path/to/home>,
+the B<type> is I<ftp>,
+the B<site> is I<www.some.org>,
+and B<home> is I<ftp://www.some.org/>.
+
+=item B<age_in_days>
+
+Returns the mirror's age (in fractional days), based on the mirror's
+timestamp as found by the last successful probe ; or based on the
+length of the state history if no probe was ever successful.
+Returns 'undef' if the mirror was never probed.
+
+=item B<mail>
+
+Returns the mirror's contact address as specified in the mirror list.
+
+=item B<region>
+
+Returns the mirror's country code as specified in the mirror list.
+
+=item B<start_probe>
+
+Start a probe for the mirror in non-blocking mode ;
+returns the associated (IO::Handle) file handle.
+The caller must maintain an association between
+the handles and the mirror objects.
+
+=item B<finish_probe ( $handle )>
+
+Sets the (IO::Handle) B<$handle> to blocking IO ;
+reads a result from the handle,
+and updates the state of the mirror.
+
+=back
+
+=head1 SEE ALSO
+
+=begin html
+
+<A HREF="mirmon.html">mirmon(1)</A>
+
+=end html
+
+=begin man
+
+mirmon(1)
+
+=end man
+
+=head1 AUTHOR
+
+=begin html
+
+ © 2003-2010
+ <A HREF="http://people.cs.uu.nl/henkp/">Henk P. Penning</A>,
+ <A HREF="http://www.cs.uu.nl/">Computer Science Department</A>,
+ <A HREF="http://www.uu.nl/">Utrecht University</A>
+ <BR>
+ mirmon-2.3 - Wed Mar 17 09:29:11 2010 ; henkp
+
+=end html
+
+=begin man
+
+ (c) 2003-2010 Henk P. Penning
+ Computer Science Department, Utrecht University
+ http://people.cs.uu.nl/henkp/ -- penning@cs.uu.nl
+ mirmon-2.3 - Wed Mar 17 09:29:11 2010 ; henkp
+
+=end man
+
+=begin text
+
+ (c) 2003-2010 Henk P. Penning
+ Computer Science Department, Utrecht University
+ http://people.cs.uu.nl/henkp/ -- penning@cs.uu.nl
+ mirmon-2.3 - Wed Mar 17 09:29:11 2010 ; henkp
+
+=end text
+
+=cut
+
+package main ; #####################################################
+
+use IO::Pipe ;
+use IO::Select ;
+use Net::hostent ;
+
+my $VERSION = Base::Version . ' - Wed Mar 17 09:29:11 2010 - henkp' ;
+my $DEF_CNF = join ', ', Mirmon -> config_list ;
+my $TIMEOUT = Base::DEF_TIMEOUT ;
+
+my $prog = substr $0, rindex ( $0, '/' ) + 1 ;
+my $Usage = <<USAGE ;
+Usage: $prog [ -v ] [ -q ] [ -t timeout ] [ -get opt ] [ -c conf ]
+option v : be verbose
+option q : be quiet
+option t : set timeout ; default $TIMEOUT
+option get : 'all' : probe all sites
+ : 'update' : probe a selection of the sites (see doc)
+option c : configuration file ; default search :
+ ( $DEF_CNF )
+-------------------------------------------------------------------
+Mirmon normally only reports errors and changes in the mirror list.
+This is $VERSION.
+-------------------------------------------------------------------
+USAGE
+sub Usage { die "$_[0]$Usage" ; }
+sub Error { die "$prog: $_[0]\n" ; }
+sub Warn { warn "$prog: $_[0]\n" ; }
+
+# usage: &GetOptions(ARG,ARG,..) defines $opt_ID as 1 or user spec'ed value
+# usage: &GetOptions(\%opt,ARG,ARG,..) defines $opt{ID} as 1 or user value
+# ARG = 'ID' | 'ID=SPC' | 'ID:SPC' for no-arg, required-arg or optional-arg
+# ID = perl identifier
+# SPC = i|f|s for integer, fixedpoint real or string argument
+
+use Getopt::Long ;
+Getopt::Long::config ( 'no_ignore_case' ) ;
+my %opt = () ;
+Usage '' unless GetOptions ( \%opt, qw(v q t=i get=s c=s version) ) ;
+Usage "Arg count\n" unless @ARGV == 0 ;
+
+if ( $opt{version} ) { printf "%s\n", Base::version () ; exit ; }
+
+$opt{v} ||= $opt{d} ;
+
+my $get = $opt{get} ;
+if ( $get and ! Base::is_get_opt ( $get ) )
+ { Error "unknown 'get option' '$get'" ; }
+
+Mirmon::verbose ( $opt{v} ) ;
+Mirmon::debug ( $opt{d} ) ;
+Mirmon::quiet ( $opt{q} ) ;
+
+my $M = Mirmon -> new ( $opt{c} ) ;
+$M -> conf -> timeout ( $opt{t} ) if $opt{t} ;
+if ( $get ) { $M -> get_dates ( $get ) ; $M -> put_state ; }
+$M -> gen_page ( $get, $VERSION ) ;
+
__END__
+
=pod
+
=head1 NAME
- mirmon - monitor the state of mirrors
+
+mirmon - monitor the state of mirrors
+
=head1 SYNOPSIS
+
mirmon [ -v ] [ -q ] [ -t timeout ] [ -get opt ] [ -c conf ]
+
=head1 OPTIONS
+
option v : be verbose
option q : be quiet
option t : set timeout [ default 300 ] ;
option c : configuration file ; default list :
./mirmon.conf $HOME/.mirmon.conf /etc/mirmon.conf
-------------------------------------------------------------------
- Documentation : the program contains 'pod' style documentation.
- Extract the doc with 'pod2text mirmon' or 'pod2html mirmon OUT', etc.
+ Mirmon normally only reports errors and changes in the mirror list.
-------------------------------------------------------------------
+
=head1 USAGE
- The program is intended to be run by cron every hour.
- 42 * * * * perl /path/to/mirmon -q -get update
- It quietly probes a subset of the sites in a given list,
- writes the results in the 'state' file and generates a web page
- with the results. The subset contains the sites that are new, bad
- and/or not probed for a specified time.
- When no 'get' option is specified, the program just generates a
- new web page from the last known state.
- The program checks the mirrors by running a (user specified)
- program on a pipe. A (user specified) number of probes is
- run in parallel using nonblocking IO. When something can be
- read from the pipe, it switches the pipe to blocking IO and
- reads one line from the pipe. Then it flushes and closes the
- pipe. No attempt is made to kill the probe.
- The probe should return something that looks like "1043625600\n",
- that is, a timestamp followed by a newline. The exit status of
- the probe is ignored.
+
+The program is intended to be run by cron every hour.
+
+ 42 * * * * perl /path/to/mirmon -get update
+
+It quietly probes a subset of the sites in a given list,
+writes the results in the 'state' file and generates a web page
+with the results. The subset contains the sites that are new, bad
+and/or not probed for a specified time.
+
+When no 'get' option is specified, the program just generates a
+new web page from the last known state.
+
+The program checks the mirrors by running a (user specified)
+program on a pipe. A (user specified) number of probes is
+run in parallel using nonblocking IO. When something can be
+read from the pipe, it switches the pipe to blocking IO and
+reads one line from the pipe. Then it flushes and closes the
+pipe. No attempt is made to kill the probe.
+
+The probe should return something that looks like
+
+ 1043625600 ...
+
+that is, a line of text starting with a timestamp. The exit status
+of the probe is ignored.
+
=head1 CONFIG FILE
+
=head2 location
- A config file can be specified with the -c option.
- If -c is not used, the program looks for a config file in
- -- ./mirmon.conf
- -- $HOME/.mirmon.conf
- -- /etc/mirmon.conf
+
+A config file can be specified with the -c option.
+If -c is not used, the program looks for a config file in
+
+=over
+
+=item * B<./mirmon.conf>
+
+=item * B<$HOME/.mirmon.conf>
+
+=item * B</etc/mirmon.conf>
+
+=back
+
=head2 syntax
- A config file looks like this :
- +--------------------------------------------------
- |# lines that start with '#' are comment
- |# blank lines are ignored too
- |# tabs are replaced by a space
- |
- |# the config entries are 'key' and 'value' pairs
- |# a 'key' begins in column 1
- |# the 'value' is the rest of the line
- |somekey A_val B_val ...
- |otherkey X_val Y_val ...
- |
- |# indented lines are glued
- |# the next three lines mean 'somekey part1 part2 part3'
- |somekey part1
- | part2
- | part3
- |
- |# lines starting with a '+' are concatenated
- |# the next three lines mean 'somekey part1part2part3'
- |somekey part1
- |+ part2
- |+ part3
- |
- |# lines starting with a '.' are glued too
- |# don't use a '.' on a line by itself
- |# 'somekey' gets the value "part1\n part2\n part3"
- |somekey part1
- |. part2
- |. part3
- +--------------------------------------------------
+
+A config file looks like this :
+
+ +--------------------------------------------------
+ |# lines that start with '#' are comment
+ |# blank lines are ignored too
+ |# tabs are replaced by a space
+ |
+ |# the config entries are 'key' and 'value' pairs
+ |# a 'key' begins in column 1
+ |# the 'value' is the rest of the line
+ |somekey A_val B_val ...
+ |otherkey X_val Y_val ...
+ |
+ |# indented lines are glued
+ |# the next three lines mean 'somekey part1 part2 part3'
+ |somekey part1
+ | part2
+ | part3
+ |
+ |# lines starting with a '+' are concatenated
+ |# the next three lines mean 'somekey part1part2part3'
+ |somekey part1
+ |+ part2
+ |+ part3
+ |
+ |# lines starting with a '.' are glued too
+ |# don't use a '.' on a line by itself
+ |# 'somekey' gets the value "part1\n part2\n part3"
+ |somekey part1
+ |. part2
+ |. part3
+ +--------------------------------------------------
+
=head1 CONFIG FILE : required entries
-=head2 project_name <name>
- Specify a short plaintext name for the project.
- project_name Apache
- project_name CTAN
-=head2 project_url <url>
- Specify an url pointing to the 'home' of the project.
- project_url http://www.apache.org/
-=head2 mirror_list <file name>
- Specify the file containing the mirrors to probe.
- Two formats are supported :
- -- plain : lines like
- us http://www.tux.org/
- nl http://apache.cs.uu.nl/dist/
- -- apache : lines like those in the apache mirrors.list
- ftp us ftp://ftp.tux.org/pub/net/apache/dist/ user@tux.org
- http nl http://apache.cs.uu.nl/dist/ user@cs.uu.nl
- Specify the required format with 'list_style' (see below).
- The default style is 'plain'.
- If the url part of a line doesn't end in a slash ('/'), mirmon
- adds a slash and issues a warning unless it is in quiet mode.
-=head2 web_page <file name>
- Specify where the html report page is written.
-=head2 icons <directory name>
- Specify the directory where the icons can be found.
-=head2 probe <program + arguments>
- Specify the program+args to probe the mirrors. Example:
- probe /sw/bin/wget -q -O - -T %TIMEOUT% -t 1 %URL%TIME
- Before the program is started, %TIMEOUT% and %URL% are
- substituted with the proper timeout and url values.
- Here it is assumed that each hour the root server writes
- a timestamp in /path/to/archive/TIME, for instance with
- a crontab entry like
- 42 * * * * perl -e 'printf "%s\n", time' > /path/to/archive/TIME
- Mirmon reads one line of output from the probe and interprets
- the first word on that line as a timestamp ; for example :
- 1043625600
- 1043625600 Mon Jan 27 00:00:00 2003
- 1043625600 www.apache.org Mon Jan 27 00:00:00 2003
-=head2 state <file name>
- Specify where the file containing the state is written.
- The program reads this file on startup and writes the
- file when mirrors are probed (-get is specified).
-=head2 countries <file name>
- Specify the file containing the country codes;
- The file should contain lines like
- us - united states
- nl - netherlands
- The mirmon package contains a recent ISO list.
+
+=head2 project_name I<name>
+
+Specify a short plaintext name for the project.
+
+ project_name Apache
+ project_name CTAN
+
+=head2 project_url I<url>
+
+Specify an url pointing to the 'home' of the project.
+
+ project_url http://www.apache.org/
+
+=head2 mirror_list I<file-name>
+
+Specify the file containing the mirrors to probe.
+
+ mirror_list /path/to/mirror-list
+
+If your mirror list is generated by a program, use
+
+ mirror_list /path/to/program arg1 ... |
+
+Two formats are supported :
+
+=over
+
+=item * plain : lines like
+
+ us http://www.tux.org/ [email] ...
+ nl http://apache.cs.uu.nl/dist/ [email] ...
+ nl rsync://archive.cs.uu.nl/apache-dist/ [email] ...
+
+=item * apache : lines like those in the apache mirrors.list
+
+ ftp us ftp://ftp.tux.org/pub/net/apache/dist/ user@tux.org ...
+ http nl http://apache.cs.uu.nl/dist/ user@cs.uu.nl ...
+
+=back
+
+Note that in style 'plain' the third item is reserved for an
+optional email address : the site's contact address.
+
+Specify the required format with 'list_style' (see below).
+The default style is 'plain'.
+
+=head2 web_page I<file-name>
+
+Specify where the html report page is written.
+
+=head2 icons I<directory-name>
+
+Specify the directory where the icons can be found,
+relative to the I<web_page>, or relative to the
+DOCUMENTROOT of the web server.
+
+If/when the I<web_page> lives in directory C<.../mirmon/> and
+the icons live in directory C<.../mirmon/icons/>,
+specify
+
+ icons icons
+
+If/when the icons live in C</path/to/DOCUMENTROOT/icons/mirmon/>, specify
+
+ icons /icons/mirmon
+
+=head2 probe I<program + arguments>
+
+Specify the program+args to probe the mirrors. Example:
+
+ probe /usr/bin/wget -q -O - -T %TIMEOUT% -t 1 %URL%TIME
+
+Before the program is started, %TIMEOUT% and %URL% are
+substituted with the proper timeout and url values.
+
+Here it is assumed that each hour the root server writes
+a timestamp in /path/to/archive/TIME, for instance with
+a crontab entry like
+
+ 42 * * * * perl -e 'printf "%s\n", time' > /path/to/archive/TIME
+
+Mirmon reads one line of output from the probe and interprets
+the first word on that line as a timestamp ; for example :
+
+ 1043625600
+ 1043625600 Mon Jan 27 00:00:00 2003
+ 1043625600 www.apache.org Mon Jan 27 00:00:00 2003
+
+Mirmon is distributed with a program C<probe> that handles
+ftp, http and rsync urls.
+
+=head2 state I<file-name>
+
+Specify where the file containing the state is written.
+
+The program reads this file on startup and writes the
+file when mirrors are probed (-get is specified).
+
+=head2 countries I<file-name>
+
+Specify the file containing the country codes;
+The file should contain lines like
+
+ us - united states
+ nl - netherlands
+
+The mirmon package contains a recent ISO list.
+
=head1 CONFIG FILE : optional entries
-=head2 max_probes <number>
- Optionally specify the number of parallel probes (default 25).
-=head2 timeout <seconds>
- Optionally specify the timeout for the probes (default 300).
- After the last probe is started, the program waits for
- <timeout> + 10 seconds, cleans up and exits.
-=head2 project_logo <logo>
- Optionally specify (the SRC of the IMG of) a logo to be placed
- top right on the page.
- project_logo /icons/apache.gif
- project_logo http://www.apache.org/icons/...
-=head2 htm_head <html>
- Optionally specify some HTML to be placed before </HEAD>.
- htm_head
- <link REL=StyleSheet HREF="/style.css" TYPE="text/css">
-=head2 htm_top <html>
- Optionally specify some HTML to be placed near the top of the page.
- The supplied text is placed between <P> and </P>.
- htm_top testing 1, 2, 3
-=head2 htm_foot <html>
- Optionally specify HTML to be placed near the bottom of the page.
- htm_foot
- <HR>
- <A HREF="..."><IMG SRC="..." BORDER=0></A>
- <HR>
+
+=head2 max_probes I<number>
+
+Optionally specify the number of parallel probes (default 25).
+
+=head2 timeout I<seconds>
+
+Optionally specify the timeout for the probes (default 300).
+
+After the last probe is started, the program waits for
+<timeout> + 10 seconds, cleans up and exits.
+
+=head2 project_logo I<logo>
+
+Optionally specify (the SRC of the IMG of) a logo to be placed
+top right on the page.
+
+ project_logo /icons/apache.gif
+ project_logo http://www.apache.org/icons/...
+
+=head2 htm_head I<html>
+
+Optionally specify some HTML to be placed before </HEAD>.
+
+ htm_head
+ <link REL=StyleSheet HREF="/style.css" TYPE="text/css">
+
+=head2 htm_top I<html>
+
+Optionally specify some HTML to be placed near the top of the page.
+
+ htm_top testing 1, 2, 3
+
+=head2 htm_foot I<html>
+
+Optionally specify HTML to be placed near the bottom of the page.
+
+ htm_foot
+ <HR>
+ <A HREF="..."><IMG SRC="..." BORDER=0></A>
+ <HR>
+
=head2 put_histo top|bottom|nowhere
- Optionally specify where the age histogram must be placed.
- The default is 'top'.
-=head2 min_poll <time spec>
- For 'min_poll' see next item. A <time spec> is a number followed by
- a unit 's' (seconds), or 'm' (minutes), or 'h' (hours), or 'd' (days).
- For example '3d' (three days) or '36h' (36 hours).
-=head2 max_poll <time spec>
- Optionally specify the maximum probe interval. When the program is
- called with option '-get update', all sites are probed which are :
- -- new : the site appears in the list, but there is no known state
- -- bad : the last probe of the site was unsuccessful
- -- old : the last probe was more than 'max_poll' ago.
- Sites are not probed if the last probe was less than 'min_poll' ago.
- So, if you specify
- min_poll 4h
- max_poll 12h
- the 'reachable' sites are probed twice daily and the 'unreachable'
- sites are probed at most six times a day.
- The default 'min_poll' is '1h' (1 hour).
- The default 'max_poll' is '4h' (4 hours).
-=head2 min_sync <time spec>
- Optionally specify how often the mirrors are required to
- make an update. The default 'min_sync' is '1d' (1 day).
-=head2 max_sync <time spec>
- Optionally specify the maximum allowable sync interval.
- Sites exceeding the limit will be considered 'old'.
- The default 'max_sync' is '2d' (2 days).
+
+Optionally specify where the age histogram must be placed.
+The default is 'top'.
+
+=head2 min_poll I<time-spec>
+
+For 'min_poll' see next item. A I<time-spec> is a number followed by
+a unit 's' (seconds), or 'm' (minutes), or 'h' (hours), or 'd' (days).
+For example '3d' (three days) or '36h' (36 hours).
+
+=head2 max_poll I<time-spec>
+
+Optionally specify the maximum probe interval. When the program is
+called with option '-get update', all sites are probed which are :
+
+=over 4
+
+=item * new
+
+the site appears in the list, but there is no known state
+
+=item * bad
+
+the last probe of the site was unsuccessful
+
+=item * old
+
+the last probe was more than 'max_poll' ago.
+
+=back
+
+Sites are not probed if the last probe was less than 'min_poll' ago.
+So, if you specify
+
+ min_poll 4h
+ max_poll 12h
+
+the 'reachable' sites are probed twice daily and the 'unreachable'
+sites are probed at most six times a day.
+
+The default 'min_poll' is '1h' (1 hour).
+The default 'max_poll' is '4h' (4 hours).
+
+=head2 min_sync I<time-spec>
+
+Optionally specify how often the mirrors are required to make an update.
+
+The default 'min_sync' is '1d' (1 day).
+
+=head2 max_sync I<time-spec>
+
+Optionally specify the maximum allowable sync interval.
+
+Sites exceeding the limit will be considered 'old'.
+The default 'max_sync' is '2d' (2 days).
+
=head2 no_randomize
- With a low probablility, mirmon probes mirrors that would
- otherwise not be probed. In the long run, this balances
- the number of mirror probes over the hourly mirmon runs.
- Specifically, if there are N mirrors in the list and some
- mirmon run would probe K sites, on average (N-K)/N extra
- sites will be probed.
- If you don't want this behaviour, use 'no_randomize'.
+
+To balance the probe load over the hourly mirmon runs,
+mirmon may probe a few extra randomly choosen mirrors :
+
+=over 4
+
+=item * only if the the number of mirrors to probe is below average,
+
+=item * at most 2% of the mirrors
+
+=back
+
+If you don't want this behaviour, use B<no_randomize>.
+
+=head2 no_add_slash
+
+If the url part of a line in the mirror_list doesn't end
+in a slash ('/'), mirmon adds a slash and issues a warning
+unless it is in quiet mode.
+
+If you don't want this behaviour, use B<no_add_slash>.
+
=head2 list_style plain|apache
- Optionally specify the format ('plain' or 'apache') of the
- mirror-list. See the description of 'mirror_list' above.
- The default list_style is 'plain'.
-=head2 site_url <site> <url>
- Optionally specify a substitute url for a site. When access to
- a site is restricted (in Australia, for instance), another
- (sometimes secret) url can be used to probe the site. The <site>
- of an url is the part between '://' and the first '/'.
-=head2 env <key> <value>
- Optionally specify an environment variable.
-=head2 include <file name>
- Optionally specify a file to include. The specified file is processed
- 'in situ'. After the specified file is read and processed, config
- processing is resumed in the file where the 'include' was encountered.
- The 'include' depth is unlimited. However, it is a fatal error to
- include a file twice under the same name.
+
+Optionally specify the format ('plain' or 'apache') of the mirror-list.
+
+See the description of 'mirror_list' above.
+The default list_style is 'plain'.
+
+=head2 site_url I<site> I<url>
+
+Optionally specify a substitute url for a site.
+
+When access to a site is restricted (in Australia, for instance),
+another (sometimes secret) url can be used to probe the site.
+The <site> of an url is the part between '://' and the first '/'.
+
+=head2 env I<key> I<value>
+
+Optionally specify an environment variable.
+
+=head2 include I<file-name>
+
+Optionally specify a file to include.
+
+The specified file is processed 'in situ'. After the specified file is
+read and processed, config processing is resumed in the file where the
+C<include> was encountered.
+The include depth is unlimited. However, it is a fatal error to
+include a file twice under the same name.
+
=head2 show
- When the config processor encounters the 'show' command, it
- dumps the content of the current config to standout, if option
- -v is specified. This is intented for debugging.
+
+When the config processor encounters the 'show' command, it
+dumps the content of the current config to standout, if option
+C<-v> is specified. This is intented for debugging.
+
=head2 exit
- When the config processor encounters the 'exit' command, it
- terminates the program. This is intented for debugging.
+
+When the config processor encounters the 'exit' command, it
+terminates the program. This is intented for debugging.
+
=head1 STATE FILE FORMAT
- The state file consists of lines; one line per site.
- Each line consists of white space separated fields.
- The seven fields are :
-=head2 field 1 : url
- The url as given in the mirror list.
-=head2 field 2 : age
- The age of the site, or 'undef' if no probe was ever successful.
-=head2 field 3 : status last probe
- The status of the last probe.
-=head2 field 4 : time last succesful probe
- The timestamp of the last succesful probe or 'undef'
- if the site was never successfully probed.
-=head2 field 5 : probe history
- The probe history is a list of 's' (for success) and 'f' (for failure)
- characters indicating the result of the probe. New results are appended
- whenever the site is probed.
-=head2 field 6 : state history
- The state history consists of a timestamp, a '-' char, and a list of
- chars indicating a past status: 's' (fresh), 'b' (oldish), 'f' (old)
- or 'z' (bad). The timestamp indicates when the state history was last
- updated. The state history is updated when the state file is updated
- and the last update of the history state was 24 (or more) hours ago.
- The status is determined by the site's age and a few configuration
- parameters. The details are explained in the legend of the report page.
-=head2 field 7 : last probe
- The timestamp of the last probe.
+
+The state file consists of lines; one line per site.
+Each line consists of white space separated fields.
+The seven fields are :
+
+=over 4
+
+=item * field 1 : url
+
+The url as given in the mirror list.
+
+=item * field 2 : age
+
+The mirror's timestamp found by the last succesful probe,
+or 'undef' if no probe was ever successful.
+
+=item * field 3 : status last probe
+
+The status of the last probe, or 'undef' if the mirror was never probed.
+
+=item * field 4 : time last succesful probe
+
+The timestamp of the last succesful probe or 'undef'
+if the mirror was never successfully probed.
+
+=item * field 5 : probe history
+
+The probe history is a list of 's' (for success) and 'f' (for failure)
+characters indicating the result of the probe. New results are appended
+whenever the mirror is probed.
+
+=item * field 6 : state history
+
+The state history consists of a timestamp, a '-' char, and a list of
+chars indicating a past status: 's' (fresh), 'b' (oldish), 'f' (old),
+'z' (bad) or 'x' (skip).
+The timestamp indicates when the state history was last updated.
+The current status of the mirror is determined by the mirror's age and
+a few configuration parameters (min_sync, max_sync, max_poll).
+The state history is updated when the mirror is probed.
+If the last update of the history was less than 24 hours ago,
+the last status is replaced by the current status.
+If the last update of the history was more than 24 hours ago,
+the current status is appended to the history.
+One or more 'skip's is inserted, if the timestamp is two or more days old
+(when mirmon hasn't run for more than two days).
+
+=item * field 7 : last probe
+
+The timestamp of the last probe, or 'undef' if the mirror was never probed.
+
+=back
+
=head1 INSTALLATION
-=over
-=item *
- The '#!' path for perl is probably wrong.
+
+=head2 general
+
+=over 4
+
+=item * Note: The (empty) state file must exist before mirmon runs.
+
+=item * The mirmon repository is here :
+
+ https://subversion.cs.uu.nl/repos/staff.henkp.mirmon/trunk/
+
+=item * The mirmon tarball is here :
+
+ http://people.cs.uu.nl/henkp/mirmon/mirmon.tar.gz
+
=back
+
+=head2 installation suggestions
+
+To install and configure mirmon, take the following steps :
+
+=over 2
+
+=item * First, make the webdir :
+
+ cd DOCUMENTROOT
+ mkdir mirmon
+
+For I<DOCUMENTROOT>, substitute the full pathname
+of the document root of your webserver.
+
+=item * Check out the mirmon repository :
+
+ cd /usr/local/src
+ svn checkout REPO mirmon
+
+where
+
+ REPO = https://subversion.cs.uu.nl/repos/staff.henkp.mirmon/trunk/
+
+or download the package and unpack it.
+
+=item * Chdir to directory mirmon :
+
+ cd mirmon
+
+=item * Create the (empty) state file :
+
+ touch state.txt
+
+=item * Install the icons in the webdir :
+
+ mkdir DOCUMENTROOT/mirmon/icons
+ cp icons/* DOCUMENTROOT/mirmon/icons
+
+=item * Create a mirror list C<mirror_list> ;
+
+Use your favorite editor, or genererate the list from an
+existing database.
+
+ nl http://archive.cs.uu.nl/your-project/ contact@cs.uu.nl
+ uk http://mirrors.this.org/your-project/ mirrors@this.org
+ us http://mirrors.that.org/your-project/ mirrors@that.org
+
+The email addresses are optional.
+
+=item * Create a mirmon config file C<mirmon.conf> with your favorite editor.
+
+ # lines must start in the first column ; no leading white space
+ project_name ....
+ project_url ....
+ mirror_list mirror_list
+ state state.txt
+ countries countries.list
+ web_page DOCUMENTROOT/mirmon/index.html
+ icons /mirmon/icons
+ probe /usr/bin/wget -q -O - -T %TIMEOUT% -t 1 %URL%TIME
+
+This assumes the project's timestamp is in file C<TIME>.
+
+=item * If you have rsync urls, change the probe line to :
+
+ probe perl /usr/local/src/mirmon/probe -t %TIMEOUT% %URL%TIME
+
+=item * Run mirmon :
+
+ perl mirmon -v -get all
+
+The mirmon report should now be in 'DOCUMENTROOT/mirmon/index.html'
+
+ http://www.your.project.org/mirmon/
+
+=item * If/when, at a later date, you want to upgrade mirmon :
+
+ cd /usr/local/src/mirmon
+ svn status -u
+ svn up
+
+=back
+
+=head1 SEE ALSO
+
+=begin html
+
+<A HREF="mirmon.pm.html">mirmon.pm(3)</A>
+
+=end html
+
+=begin man
+
+mirmon.pm(3)
+
+=end man
+
=head1 AUTHOR
+
=begin html
-<BLOCKQUOTE>
- © 2003
- <A HREF="http://www.cs.uu.nl/staff/henkp.html">Henk P. Penning</A>,
+
+ © 2003-2010
+ <A HREF="http://people.cs.uu.nl/henkp/">Henk P. Penning</A>,
<A HREF="http://www.cs.uu.nl/">Computer Science Department</A>,
<A HREF="http://www.uu.nl/">Utrecht University</A>
<BR>
- $Id: mirmon,v 1.37 2006/12/04 15:16:11 henkp Exp henkp $
-</BLOCKQUOTE>
+ mirmon-2.3 - Wed Mar 17 09:29:11 2010 ; henkp
+
=end html
+
+=begin man
+
+ (c) 2003-2010 Henk P. Penning
+ Computer Science Department, Utrecht University
+ http://people.cs.uu.nl/henkp/ -- penning@cs.uu.nl
+ mirmon-2.3 - Wed Mar 17 09:29:11 2010 ; henkp
+
+=end man
+
=begin text
- (c) 2003 Henk P. Penning, Computer Science Department, Utrecht University
- http://www.cs.uu.nl/staff/henkp.html -- penning@cs.uu.nl
+
+ (c) 2003-2010 Henk P. Penning
+ Computer Science Department, Utrecht University
+ http://people.cs.uu.nl/henkp/ -- penning@cs.uu.nl
+ mirmon-2.3 - Wed Mar 17 09:29:11 2010 ; henkp
+
=end text
-=cut
\ No newline at end of file
+
+=cut
git://git.exim.org / mirror-monitor.git / commitdiff