#! /usr/bin/perl -w
-# $Cambridge$
+
+# Copyright (c) 2003-2014 Henk Penning, all rights reserved.
+# penning@uu.nl, http://www.staff.science.uu.nl/~penni101/
+# Version 1.1 was donated to the Apache Software Foundation 2003 Jan 28.
#
-# 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 $
# 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 $' ;
+# 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 ;
-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 ]
- ;
+our $PRG = 'mirmon' ;
+our $VER = "2.10" ;
+
+our $DEF_TIMEOUT = 300 ;
+our $HIST = 14 ;
+our $TIM_PAT = '^(\d+)([smhd])$' ;
+our %APA_TYPES = () ; $APA_TYPES { $_ } ++ for qw(backup ftp http rsync) ;
+our %GET_OPTS = () ; $GET_OPTS { $_ } ++ for qw(all update url) ;
+our $HIST_DELTA = 24 * 60 * 60 ;
+our $APRX_DELTA = 300 ;
+our $HOME = 'http://www.staff.science.uu.nl/~penni101/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 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 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 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 mk_method
+ { my $self = shift ;
+ my $attr = shift ;
+ sprintf 'sub %s { my $self = shift ; $self -> getset ( "%s", @_ ) ; }'
+ , $attr, $attr ;
}
-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 mk_methods
+ { my $self = shift ;
+ join "\n", map { Base -> mk_method ( $_ ) ; } @_ ;
}
-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 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 tim_to_s
+sub s4tim
{ 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 ;
+ die "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 $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 ) ;
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 pr_diff
+ { my $time = shift ;
+ my $max = shift ;
+ my $res ;
-sub max_vrfy
- { ( tim_to_s $CNF { min_poll } ) + ( tim_to_s $CNF { max_poll } ) ; }
+ if ( $time == $^T )
+ { $res = BLD 'renewed' ; }
+ else
+ { $res = pr_interval $^T - $time ;
+ $res = BLD RED $res if aprx_lt $time, $max ;
+ }
+ return $res ;
+ }
-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 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 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 = '' ;
+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 ;
}
- $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 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 -r $conf and ! -d $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 $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 ] ;
+ { my $self = shift ;
+ my $conf = $self -> conf ;
+ my $name = $conf -> project_name ;
+ 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 STT ;
- }
+ close STATE ;
+
+ my $mlist = $conf -> mirror_list ;
+ my $style = $conf -> list_style ;
+ my %in_list = () ;
+ my $changes = '' ;
+ 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 ;
+ }
+ }
-sub check_hist
- { my $time = shift ;
- my $hsts = shift ;
- printf "check_hist: last '$time' hsts '$hsts'\n" if $opt{d} ;
+ if ( $conf -> add_slash and $url !~ m!/$! )
+ { print "*** appended '/' to $url\n" unless Mirmon::quiet ;
+ $url .= '/' ;
+ }
- my $res = $hsts ;
- my ( $stmp, $hist ) ;
+ $in_list { $url } ++ ;
- if ( $hsts eq '' )
- { $stmp = 0 ; $hist = '' ; }
- else
- { ( $stmp, $hist ) = split '-', $hsts ; }
+ unless ( exists $res -> { $url } )
+ { $changes .= sprintf "added %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 ;
- if ( aprx_le $stmp, $^T - tim_to_s '1d' )
- { $res = sprintf "%s-%s%s"
- , $^T
- , substr ( $hist, 1 - $HIST )
- , age_code ( $time )
- ;
+ for my $url ( sort keys %$res )
+ { # printf "%s\n", $res -> { $url } -> state ;
+ unless ( exists $in_list { $url } )
+ { $changes .= sprintf "removed %s\n", $url unless Mirmon::quiet ;
+ delete $res -> { $url } ;
+ }
}
- return $res ;
+ printf "changes in mirror-list for '%s':\n%s", $name, $changes
+ if $changes ;
+ $self -> state ( $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 ($!)" ;
+ { 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" ; }
+ { warn "wrote empty state file; keeping previous version" ; }
else
- { rename $TMP, $STT or Error "can't rename '$TMP', '$STT' ($!)" ; }
+ { rename $TMP, $file or die "can't rename '$TMP', '$file' ($!)" ; }
}
-sub get_ccs
- { my $CCS = shift ;
- open CCS, $CCS or Error "can't open '$CCS' ($!)" ;
- while ( <CCS> )
+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 ;
- $CCS { lc $code } = lc $reg ;
+ $self -> { regions } { lc $code } = $reg ;
}
- close CCS ;
+ close REGS ;
}
-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 _cmp_ccs
+ { my $ccs = shift ;
+ my $x = shift ;
+ my $y = shift ;
+ my $xx = $ccs -> { $x } ;
+ my $yy = $ccs -> { $y } ;
+ if ( ! defined $xx and ! defined $yy )
+ { $x cmp $y ; }
+ elsif ( ! defined $xx )
+ { -1 ; }
+ elsif ( ! defined $yy )
+ { +1 ; }
+ else
+ { $xx cmp $yy ; }
}
-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 _pr_round
+ { my $x = shift ;
+ my $i = int $x ;
+ my $f = $x - $i ;
+ $i + ( rand 1 < $f ? 1 : 0 ) ;
+ }
-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 .= '/' ;
- }
+sub _diag_qs
+ { my $qs = shift ;
+ join ', ', map { sprintf "%s %s" , $_, scalar @{ $qs -> { $_ } } ; }
+ sort keys %$qs ;
+ }
+
+sub _rpick
+ { my $row = shift ;
+ die "_rpick : row empty" unless @$row ;
+ my $idx = int rand @$row ;
+ my $res = $row -> [ $idx ] ;
+ $row -> [ $idx ] = $row -> [ $#{$row} ] ;
+ pop @$row ;
+ $res ;
+ }
+
+sub _buck_split
+ { my $que = shift ;
+ my $tmp = [] ;
+ for my $mirr ( @$que )
+ { my $lp = $mirr -> last_probe ;
+ my $hr = int ( ( $^T - $lp ) / 60 / 60 + 0.5 ) ;
+ push @{ $tmp -> [ $hr ] }, $mirr ;
+ }
+ [ grep defined $_, @$tmp ] ;
+ }
+
+sub _buck_join
+ { my $bucks = shift ;
+ my $res = [] ;
+ push @$res, @$_ for @$bucks ;
+ $res ;
+ }
+
+sub _buck_pick
+ { my $bucks = shift ;
+ die "buck_pick : bucks empty" unless @$bucks ;
+ my $buck = ( sort { @$b <=> @$a } @$bucks ) [ 0 ] ;
+ _rpick $buck ;
+ }
+
+sub _randomize
+ { my $ques = shift ;
+ my $poll = shift ;
+ my $hrs = int ( $poll / 60 / 60 + 0.5 ) ;
+
+ my $diag1 = _diag_qs $ques ;
+
+ my $todos = $ques -> { todo } ;
+ my $dones = $ques -> { done } ;
+ my $cnt = @$todos + @$dones ;
+ my $avg = $hrs ? $cnt / $hrs : 0 ;
+ my $iavg = _pr_round $avg ;
+ my $pick = 0 ;
+ my $bucks = _buck_split $dones ;
+
+ while ( @$todos < $iavg and $pick < @$dones )
+ { push @$todos, _buck_pick $bucks ;
+ $pick ++ ;
}
- 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 ;
+
+ $ques -> { done } = _buck_join $bucks ;
+
+ sprintf ''
+ . " hrs %s, %s\n"
+ . " avg %.2f -> %d , picked %d ; queued %s\n"
+ . " hrs %s, %s\n"
+ , $hrs, $diag1
+ , $avg, $iavg, $pick, scalar @$todos
+ , $hrs, _diag_qs ( $ques )
+ ;
+ }
+
+sub get_dates
+ { my $self = shift ;
+ my $get = shift ;
+ my $URL = shift ;
+ my $state = $self -> state ;
+ my $conf = $self -> conf ;
+ my $CMD = $conf -> probe ;
+ my $PAR = $conf -> max_probes ;
+ my %m4h = () ;
+ my @QUE = () ;
+ my $GET = IO::Select -> new () ;
+ my $ques = {} ;
+ for my $col ( qw(new red grn xtr) )
+ { $ques -> { $col } { $_ } = [] for qw(done todo) ; }
+ my $max_poll = s4tim $conf -> max_poll ;
+ my $min_poll = s4tim $conf -> min_poll ;
+
+ if ( Mirmon::verbose ) { printf "mirrors %d\n", scalar keys %$state ; }
+
+ if ( $get eq 'all' )
+ { @QUE = sort { $a -> url cmp $b -> url } values %$state ; }
+ elsif ( $get eq 'url' )
+ { @QUE = ( $state -> { $URL } ) ; }
+ elsif ( $get eq 'update' )
+ { my $maxp = $^T - $max_poll ;
+ my $minp = $^T - $min_poll ;
+
+if ( Mirmon::verbose )
+ { printf "max_poll %s\n", scalar localtime $maxp ;
+ printf "min_poll %s\n", scalar localtime $minp ;
+ }
+ for my $url ( sort keys %$state )
+ { my $mirror = $state -> { $url } ;
+ my $stat = $mirror -> last_status ;
+ my $vrfy = $mirror -> last_ok_probe ;
+ my $lprb = $mirror -> last_probe ;
+ my $col ;
+ my $que ;
+ if ( $stat eq 'undef' ) # never probed ; new mirror ; todo
+ { $col = 'new' ; $que = 'todo' ; }
+ elsif ( $conf -> get_xtr ( $mirror -> region ) )
+ { $col = 'xtr' ; $que = 'todo' ; }
+ else
+ { my $poll = $stat eq 'ok' ? $maxp : $minp ;
+ $col = $stat eq 'ok' ? 'grn' : 'red' ;
+ $que = ( aprx_le $lprb, $poll ) ? 'todo' : 'done' ;
+ }
+ push @{ $ques -> { $col } { $que } }, $mirror ;
}
- unless ( $url =~ m!/$! )
- { print "*** missing '/' in $url\n" unless $opt{q} ;
- $url .= '/' ;
+
+ if ( $conf -> randomize )
+ { my $msg = "randomize green\n" ;
+ $msg .= _randomize $ques -> { grn }, $max_poll ;
+ $msg .= "randomize red\n" ;
+ $msg .= _randomize $ques -> { red }, $min_poll ;
+ print $msg if Mirmon::verbose ;
}
+ @QUE =
+ ( @{ $ques -> { new } { todo } }
+ , @{ $ques -> { red } { todo } }
+ , @{ $ques -> { grn } { todo } }
+ , @{ $ques -> { xtr } { todo } }
+ ) ;
}
+ else
+ { die "unknown opt_get '$get'" ; }
+
+ if ( Mirmon::verbose ) { printf "queued %d\n\n", scalar @QUE ; }
+
+ 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 ) ;
- my $site = site $url ;
- my $type = type $url ;
+ printf "queue %d, started %d, probes %d, can_read %d\n",
+ scalar @QUE, $started, $GET -> count (), scalar @can_read
+ if Mirmon::verbose ;
- unless ( defined $site )
- { print "*** strange url : '$url'\n" unless $opt{q} ; next ; }
+ for my $handle ( @can_read )
+ { # order is important ; wget's hang if/when actions are reversed
+ $GET -> remove ( $handle ) ;
+ $m4h { $handle } -> finish_probe ( $handle ) ;
+ }
- $LST { $url } = [ $type , $site, $reg ] ;
+ sleep 1 ;
}
- }
-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] ; }
+ my $stop = time + $conf -> timeout + 10 ;
-sub htmlquote
- { my $x = shift ;
- $x =~ s/&/&/g ;
- $x =~ s/</</g ;
- $x =~ s/>/>/g ;
- return $x ;
- }
+ while ( $GET -> count () and time < $stop )
+ { my @can_read = $GET -> can_read ( 0 ) ;
-sub diff
- { my $time = shift ;
- my $max = shift ;
- my $res ;
+ printf "wait %2d, probes %d, can_read %d\n",
+ $stop - scalar time, $GET -> count (), scalar @can_read
+ if Mirmon::verbose ;
- if ( $time == $^T )
- { $res = BLD 'renewed' ; }
- else
- { $res = pr_interval $^T - $time ;
- $res = BLD RED $res if aprx_lt $time, $max ;
+ for my $handle ( @can_read )
+ { $GET -> remove ( $handle ) ;
+ $m4h { $handle } -> finish_probe ( $handle ) ;
+ }
+
+ sleep 10 ;
}
- return $res ;
+
+ for my $handle ( $GET -> handles () )
+ { $m4h { $handle } -> update ( 0, 'hangs', undef ) ; }
}
sub img_sf_cnt
- { sprintf '<IMG BORDER=1 SRC="%s/mm%s%02d.gif" ALT="">'
- , $CNF { icons }, $_[0], $_[1] ;
+ { 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 { img_sf_cnt $_[0], 1 ; }
+sub img_sf { my $self = shift ; $self -> img_sf_cnt ( $_[0], 1 ) ; }
sub show_hist
- { my $hst = shift ;
- return '' unless $hst =~ m/^[sbfz]+$/ ;
+ { 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 img_sf_cnt 'sb', length $1 ; }
+ { return $self -> img_sf_cnt ( 'sb', length $1 ) ; }
elsif ( length $hst == $HIST and $hst =~ /^(s*f)s*$/ )
- { return img_sf_cnt 'sf', length $1 ; }
+ { return $self -> img_sf_cnt ( 'sf', length $1 ) ; }
elsif ( length $hst == $HIST and $hst =~ /^(s*b)fs*$/ )
- { return img_sf_cnt 'sbf', length $1 ; }
+ { return $self -> img_sf_cnt ( 'sbf', length $1 ) ; }
my $res = '' ;
my $cnt = 1 ;
my $prf = substr $hst, 0, 1 ;
while ( $hst ne '' )
{ if ( substr ( $prf, 0, 1 ) eq substr ( $hst, 0, 1 ) )
{ $cnt ++ ;
- $hst = substr $hst, 1 ;
- }
+ $hst = substr $hst, 1 ;
+ }
else
- { $res .= img_sf_cnt $prf, $cnt ;
- $prf = substr $hst, 0, 1 ;
- $hst = substr $hst, 1 ;
- $cnt = 1 ;
- }
+ { $res .= $self -> 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 ;
+ $res .= $self -> img_sf_cnt ( $prf, $cnt ) if $cnt ;
+ $res ;
}
sub gen_histogram_probes
- { my ( $time, $stat, $vrfy, $hstp, $hsts, $lprb ) ;
+ { my $self = shift ;
+ my $state = $self -> state ;
my %tab = () ;
my %bad = () ;
my $res = '' ;
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 } } ;
+ 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 ;
+ $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 ++ ; }
+ { $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 sprintf
( '%s %s, %s %s'
, $s_cnt , GRN ( 'successful' )
- , $f_cnt , RED ( 'failed' )
+ , $f_cnt , RED ( 'failed' )
)
) ;
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 ;
+ 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 ? img_sf_cnt ( 's', $n ) : '' )
- . ( $b ? img_sf_cnt ( 'f', $b ) : '' )
- . ( ( $n + $b ) ? '' : ' ' )
- )
- ) ;
+ $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 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 ] ;
}
- return "<BLOCKQUOTE>\n" . TAB ( $res ) . "</BLOCKQUOTE>\n" ;
+
+ 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,
+usually the root of the mirrored file tree.
+The <B>text</B> is the <I>site</I> of that url.
+<P>
+<B>home</B> (represented by the <B>@</B>-symbol) is an url
+pointing to the document root of the site. This pointer is
+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>
+Once a day the status of a mirror site is determined.
+The status (represented by a colored block) is appended
+to the <B>right</B> of the status history (<I>right</I>
+is <I>recent</I>). More precise, the status block is appended
+if the last status block was appended 24 (or more) hours ago.
+<P>The status of a mirror depends on its age and a few
+configuration parameters :
+<BLOCKQUOTE>
+<TABLE BORDER=1 CELLPADDING=5>
+<TR>
+ <TH ROWSPAN=3>status</TH>
+ <TH COLSPAN=4>age</TH>
+</TR>
+<TR>
+ <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>
+</TR>
+<TR>
+ <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>$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>$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>
+</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>.
+</BLOCKQUOTE>
+
+<H4>last stat</H4>
+
+<BLOCKQUOTE>
+<B>Last stat</B> gives the status of the last probe.
+</BLOCKQUOTE>
+
+LEGENDA
+ }
+
+sub _ths
+ { return '' unless my $ths = shift ;
+ $ths == 1 ? TH '' : "<TH COLSPAN=$ths></TH>\n" ;
}
sub gen_histogram
- { my $MAX_H = max_age1 ;
+ { 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 = max_age2 ;
+ 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 $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 ] ;
+ 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 $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 )
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 } -- ;
+ if ( $bad { $aux } % $Wmx { $aux } > $i )
+ { $tab { $aux . $i } ++ ;
+ $tab { $aux } -- ;
+ }
}
- }
$tab { $aux } -= ( $W { $aux } - 1 ) * $d ;
- $max = $tab { $aux } if $max < $tab { $aux } ;
+ $max = $tab { $aux } if $max < $tab { $aux } ;
}
}
# { 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" ;
- }
+ 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 ( NAM 'age-histogram', '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
+ )
+ )
+ : ''
+ ;
+ 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 { _cmp_ccs $CCS, $a, $b } keys %tab )
+# { ( $CCS -> { $a } ? lc ( $CCS -> { $a } ) : $a )
+# cmp ( $CCS -> { $b } ? lc ( $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 -> url_site
+ , $mirror -> url_home
+ , $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 => ''
+ , always_get => ''
+ ) ;
+
+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 get_xtr
+ { my $self = shift ;
+ my $reg = shift ;
+ scalar grep { $_ eq $reg } split ' ', $self -> always_get ;
+ }
+
+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, $path ) ;
+ if ( $url =~ m!^(ftp|https?|rsync)://([^/:]+)(:\d+)?/! )
+ { $type = $1 ; $site = $2 ; $home = $& ; $path = $' ; }
+ else
+ { warn "can't parse url ($url)" ; }
+ return $type, $site, $home, $path ;
+ }
+
+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 path { my $self = shift ; ( $self -> _parse ) [ 3 ] ; }
+
+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 ( $res, 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 url_site
+ { my $self = shift ;
+ my $type = $self -> type ;
+ if ( $type eq 'rsync' )
+ { my $path = $self -> path ;
+ chop $path if $path =~ m!/$! ;
+ sprintf '%s::%s', $self -> site , $path ;
+ }
+ else
+ { URL $self -> url , $self -> site ; }
+ }
+
+sub url_home
+ { my $self = shift ;
+ my $type = $self -> type ;
+ if ( $type eq 'rsync' )
+ { '@' ; }
+ else
+ { 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
+ }
+
+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 [, $URL] )>
+
+Probes all mirrors if $get is C<all> ; or a subset if $get is C<update> ;
+or only I<$URL> if $get is C<url>.
+
+=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 successful 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 successful 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
+
+<p>
+<a href="mirmon.html">mirmon(1)</a>
+</p>
+
+=end html
+
+=begin man
+
+mirmon(1)
+
+=end man
+
+=head1 AUTHOR
+
+=begin html
+
+ <p>
+ © 2003-2014
+ <a href="http://www.staff.science.uu.nl/~penni101/">Henk P. Penning</a>,
+ <a href="http://www.uu.nl/faculty/science/EN/">Faculty of Science</a>,
+ <a href="http://www.uu.nl/">Utrecht University</a>
+ <br />
+ mirmon-2.10 - Fri Aug 15 12:26:55 2014 ; henkp ;
+ <a href="http://validator.w3.org/check?uri=referer">verify html</a>
+ </p>
+
+=end html
+
+=begin man
+
+ (c) 2003-2014 Henk P. Penning
+ Faculty of Science, Utrecht University
+ http://www.staff.science.uu.nl/~penni101/ -- penning@uu.nl
+ mirmon-2.10 - Fri Aug 15 12:26:55 2014 ; henkp
+
+=end man
+
+=begin text
+
+ (c) 2003-2014 Henk P. Penning
+ Faculty of Science, Utrecht University
+ http://www.staff.science.uu.nl/~penni101/ -- penning@uu.nl
+ mirmon-2.10 - Fri Aug 15 12:26:55 2014 ; henkp
+
+=end text
+
+=cut
+
+package main ; #####################################################
+
+use IO::Pipe ;
+use IO::Select ;
+use Net::hostent ;
+
+my $VERSION = Base::Version . ' - Fri Aug 15 12:26:55 2014 - 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] [-c conf] [-get all|update|url <url>]
+option v : be verbose
+option q : be quiet
+option t : set timeout ; default $TIMEOUT
+option get : get all : probe all sites
+ : get update : probe a selection of the sites (see doc)
+ : get url <url> : probe some <url> (in the mirror-list).
+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" if @ARGV > 1 ;
+Usage "Arg count\n" if $opt{get} and $opt{get} eq 'url' and ! @ARGV ;
+
+if ( $opt{version} ) { printf "%s\n", Base::version () ; exit ; }
+
+$opt{v} ||= $opt{d} ;
+
+my $URL = shift ;
+
+my $M = Mirmon -> new ( $opt{c} ) ;
+$M -> conf -> timeout ( $opt{t} ) if $opt{t} ;
+
+my $get = $opt{get} ;
+if ( $get )
+ { Error "url $URL not in list"
+ if $get eq 'url' and ! $M -> state -> { $URL } ;
+ Error "unknown 'get option' '$get'" unless Base::is_get_opt ( $get ) ;
+ }
+
+Mirmon::verbose ( $opt{v} ) ;
+Mirmon::debug ( $opt{d} ) ;
+Mirmon::quiet ( $opt{q} ) ;
+
+if ( $get ) { $M -> get_dates ( $get, $URL ) ; $M -> put_state ; }
+$M -> gen_page ( $get, $VERSION ) ;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+mirmon - monitor the state of mirrors
+
+=head1 SYNOPSIS
+
+ mirmon [-v] [-q] [-t timeout] [-c conf] [-get all|update|url url]
+
+=head1 OPTIONS
+
+=over 4
+
+=item B<-v>
+
+Be verbose ; B<mirmon> normally only reports
+errors and changes in the mirror list.
+
+=item B<-q>
+
+Be quiet.
+
+=item B<-t> I<timeout>
+
+Set the timeout ; the default is I<300>.
+
+=item B<-get> all | update | url <url>
+
+With B<all>, probe all sites.
+With B<update>, probe a selection of the sites ; see option C<max_poll> below.
+With B<url>, probe only the given I<url>, which must appear in the mirror-list.
+
+=item B<-c> I<name>
+
+Use config file I<name>. The default list is
+
+ ./mirmon.conf $HOME/.mirmon.conf /etc/mirmon.conf
+
+=back
+
+=head1 USAGE
+
+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
- my $HR = '<HR SIZE=2 WIDTH="95%%" NOSHADE>' ;
+ 1043625600 ...
- $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" ;
+that is, a line of text starting with a timestamp. The exit status
+of the probe is ignored.
- $res .= "<TR>\n" ;
- $res .= '<TD ALIGN="CENTER"> <B>age</B> → </TD>' ;
+=head1 CONFIG FILE
- $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" ;
+=head2 location
- my $FRMT = '<TD ALIGN="CENTER" COLSPAN=%d> %s </TD>' ;
+A config file can be specified with the -c option.
+If -c is not used, the program looks for a config file in
- $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" ;
+=over
- $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 ;
- }
+=item * B<./mirmon.conf>
-sub revdom { my $dom = shift ; join '.', reverse split /\./, $dom ; }
+=item * B<$HOME/.mirmon.conf>
-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
- ;
- }
+=item * B</etc/mirmon.conf>
-sub by_CCS { ( $CCS { $a } || $a ) cmp ( $CCS { $b } || $b ) ; }
+=back
-sub legend ;
+=head2 syntax
-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 ] ;
- }
+A config file looks like this :
- my $bad = 0 ; my $old = 0 ; my $unr = 0 ;
- my %stats ;
- my @stats ;
- my $ok = 0 ;
+ +--------------------------------------------------
+ |# 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
+ +--------------------------------------------------
- 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 ++ ; }
- }
+=head2 required entries
- 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 )
- ;
+=over 4
- 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 ;
+=item project_name I<name>
- for my $reg ( sort keys %tab )
- { $refs .= sprintf " %s \n"
- , url "#$reg"
- , "<FONT SIZE=\"+1\">$reg</FONT>"
- ;
- }
+Specify a short plaintext name for the project.
- 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" ;
- }
+ project_name Apache
+ project_name CTAN
- print PPP "<H2>regions</H2>\n" ;
+=item project_url I<url>
- print PPP "<BLOCKQUOTE>\n" ;
- print PPP "<CENTER>\n" ;
- printf PPP "%s\n", $refs ;
- print PPP "</CENTER>\n" ;
- print PPP "</BLOCKQUOTE>\n" ;
+Specify an url pointing to the 'home' of the project.
- print PPP "<H2>report</H2>\n" ;
+ project_url http://www.apache.org/
- my $attr1 = "COLSPAN=$COLS BGCOLOR=\"LIME\"" ;
- my $attr2 = 'BGCOLOR="AQUA"' ;
+=item mirror_list I<file-name>
- 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
- ) ;
+Specify the file containing the mirrors to probe.
- 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
- ;
+ mirror_list /path/to/mirror-list
- 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 ;
+If your mirror list is generated by a program, use
- }
- else
- { ( $pr_time, $pr_last, $pr_hstp, $pr_hsts, $stat ) =
- ( ' ', ' ', '', '', ' ' ) ;
- }
+ mirror_list /path/to/program arg1 ... |
- $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" ;
+Two formats are supported :
- if ( $CNF { put_histo } eq 'bottom' )
- { print PPP "<H2>age histogram</H2>\n" ;
+=over
- print PPP "<BLOCKQUOTE>\n" ;
- print PPP gen_histogram ;
- print PPP "</BLOCKQUOTE>\n" ;
- }
+=item * plain : lines like
- print PPP legend ;
+ us http://www.tux.org/ [email] ...
+ nl http://apache.cs.uu.nl/dist/ [email] ...
+ nl rsync://archive.cs.uu.nl/apache-dist/ [email] ...
- print PPP "<H3>probe results</H3>\n" ;
- print PPP gen_histogram_probes ;
+=item * apache : lines like those in the apache mirrors.list
- print PPP "<H3>software</H3>\n" ;
+ 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 ...
- 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>" ;
+=back
- 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 ($!)" ; }
- }
+Note that in style 'plain' the third item is reserved for an
+optional email address : the site's contact address.
-sub legend
- { return <<LEGENDA ;
-<H3>legend</H3>
+Specify the required format with option C<list_style> (see below).
+The default style is 'plain'.
-<H4><I>project</I> site -- home</H4>
+=item web_page I<file-name>
-<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,
-usually the root of the mirrored file tree.
-The <B>text</B> is the <I>site</I> of that url.
-<P>
-<B>home</B> (represented by the <B>@</B>-symbol) is an url
-pointing to the document root of the site. This pointer is
-useful if the <B><I>project</I> site</B> url is invalid,
-possibly because the mirror site moved the archive.
-</BLOCKQUOTE>
+Specify where the html report page is written.
-<H4>type</H4>
+=item icons I<directory-name>
-<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>
+Specify the directory where the icons can be found,
+relative to the I<web_page>, or relative to the
+DOCUMENTROOT of the web server.
-<H4>mirror age, daily stats</H4>
+If/when the I<web_page> lives in directory C<.../mirmon/> and
+the icons live in directory C<.../mirmon/icons/>,
+specify
-<BLOCKQUOTE>
-The <B>mirror age</B> is based upon the last successful probe.
-<P>
-Once a day the status of a mirror site is determined.
-The status (represented by a colored block) is appended
-to the <B>right</B> of the status history (<I>right</I>
-is <I>recent</I>). More precise, the status block is appended
-if the last status block was appended 24 (or more) hours ago.
-<P>The status of a mirror depends on its age and a few
-configuration parameters :
-<BLOCKQUOTE>
-<TABLE BORDER=1 CELLPADDING=5>
-<TR>
- <TH ROWSPAN=3>status</TH>
- <TH COLSPAN=4>age</TH>
-</TR>
-<TR>
- <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>
-</TR>
-<TR>
- <TH><FONT COLOR="GREEN">fresh</FONT></TH>
+ icons icons
- <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>
-</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>
-</TR>
-<TR>
- <TH><FONT COLOR="RED">old</FONT></TH>
+If/when the icons live in C</path/to/DOCUMENTROOT/icons/mirmon/>, specify
- <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>
-</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>
-</TR>
-</TABLE>
-</BLOCKQUOTE>
-</BLOCKQUOTE>
+ icons /icons/mirmon
-<H4>last probe, probe stats</H4>
+=item probe I<program + arguments>
-<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>.
-</BLOCKQUOTE>
+Specify the program+args to probe the mirrors. Example:
-<H4>last stat</H4>
+ probe /usr/bin/wget -q -O - -T %TIMEOUT% -t 1 %URL%TIME.txt
-<BLOCKQUOTE>
-<B>Last stat</B> gives the status of the last probe.
-</BLOCKQUOTE>
+Before the program is started, %TIMEOUT% and %URL% are
+substituted with the proper timeout and url values.
-LEGENDA
- }
+Here it is assumed that each hour the root server writes
+a timestamp in /path/to/archive/TIME.txt, for instance with
+a crontab entry like
-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' ; }
- }
+ 42 * * * * perl -e 'print time, "\n"' > /path/to/archive/TIME.txt
-sub get_date
- { my $WGT = shift ;
- my $url = $URL { $WGT } ;
- my $time = undef ;
+Mirmon reads one line of output from the probe and interprets
+the first word on that line as a timestamp ; for example :
- $WGT -> blocking ( 1 ) ;
- unless ( $WGT -> eof () ) { $time = $WGT -> getline () ; }
- $GET -> remove ( $WGT ) ;
- $WGT -> flush ;
- $WGT -> close ;
+ 1043625600
+ 1043625600 Mon Jan 27 00:00:00 2003
+ 1043625600 www.apache.org Mon Jan 27 00:00:00 2003
- return err $url, 'no time' unless defined $time ;
- return err $url, "empty" if $time =~ /^\s*$/ ;
+Mirmon is distributed with a program C<probe> that handles
+ftp, http and rsync urls.
- $time = ( split ' ', $time ) [ 0 ] ;
+=item state I<file-name>
- if ( $time !~ /^\d+$/ )
- { $time = htmlquote $time ;
- $time = substr ( $time, 0, 15 ) . '..' if length $time > 15 ;
- err $url, "'$time'" ;
- }
- else
- { res $url, $time, 'ok' ; }
- }
+Specify where the file containing the state is written.
-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 }
- )
- )
- { 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}'" ; }
- }
+The program reads this file on startup and writes the
+file when mirrors are probed (-get is specified).
- 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' ; }
- }
+=item countries I<file-name>
- my @can_read = $GET -> can_read ( 0 ) ;
+Specify the file containing the country codes;
+The file should contain lines like
- printf "que %d, get %d, can %d\n",
- scalar @QUE, $GET -> count (), scalar @can_read
- if $opt{v} ;
+ us - United States
+ nl - Netherlands
- for my $can_read ( @can_read )
- { get_date $can_read ; }
+The mirmon package contains a recent ISO list.
- sleep 1 ;
- }
+I<Fake> domains like I<Backup>, I<Master> are allowed,
+and are listed first in the report ; lowercase-first
+fake domains (like I<backup>) are listed last.
- my $stop = time + $CNF { timeout } + 10 ;
+=back
- while ( $GET -> count () and time < $stop )
- { sleep 1 ;
+=head2 optional entries
- my @can_read = $GET -> can_read ( 0 ) ;
+=over 4
- printf "wait %2d, get %d, can %d\n",
- $stop - scalar time, $GET -> count (), scalar @can_read
- if $opt{v} ;
+=item max_probes I<number>
- for my $can_read ( @can_read )
- { get_date $can_read ; }
- }
+Optionally specify the number of parallel probes (default 25).
- for my $WGT ( $GET -> handles () )
- { my $url = $URL { $WGT } ;
- err $url, 'hangs' ;
- }
- }
+=item timeout I<seconds>
-get_conf_opt ;
-get_ccs $CNF { countries } ;
-get_state $CNF { state } ;
-get_list $CNF { mirror_list } ;
+Optionally specify the timeout for the probes (default 300).
-if ( $opt{get} )
- { get_dates $CNF { probe } ;
- put_state $CNF { state } ;
- }
-else
- { %RES = %OLD }
+After the last probe is started, the program waits for
+<timeout> + 10 seconds, cleans up and exits.
-gen_page $CNF { web_page } ;
+=item project_logo I<logo>
-__END__
+Optionally specify (the SRC of the IMG of) a logo to be placed
+top right on the page.
-=pod
+ project_logo /icons/apache.gif
+ project_logo http://www.apache.org/icons/...
-=head1 NAME
+=item htm_head I<html>
- mirmon - monitor the state of mirrors
+Optionally specify some HTML to be placed before </HEAD>.
-=head1 SYNOPSIS
+ htm_head
+ <link REL=StyleSheet HREF="/style.css" TYPE="text/css">
- mirmon [ -v ] [ -q ] [ -t timeout ] [ -get opt ] [ -c conf ]
+=item htm_top I<html>
-=head1 OPTIONS
+Optionally specify some HTML to be placed near the top of the page.
- option v : be verbose
- option q : be quiet
- option t : set timeout [ default 300 ] ;
- option get : 'all' : probe all sites
- : 'update' : probe a selection of the sites (see doc)
- 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.
- -------------------------------------------------------------------
+ htm_top testing 1, 2, 3
-=head1 USAGE
+=item htm_foot I<html>
- The program is intended to be run by cron every hour.
+Optionally specify HTML to be placed near the bottom of the page.
- 42 * * * * perl /path/to/mirmon -q -get update
+ htm_foot
+ <HR>
+ <A HREF="..."><IMG SRC="..." BORDER=0></A>
+ <HR>
- 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.
+=item put_histo top|bottom|nowhere
- When no 'get' option is specified, the program just generates a
- new web page from the last known state.
+Optionally specify where the age histogram must be placed.
+The default is 'top'.
- 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.
+=item min_poll I<time-spec>
- 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.
+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).
-=head1 CONFIG FILE
+=item max_poll I<time-spec>
-=head2 location
+Optionally specify the maximum probe interval. When the program is
+called with option '-get update', all sites are probed which are :
- 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
+=over 4
-=head2 syntax
+=item * new
- A config file looks like this :
+the site appears in the list, but there is no known state
- +--------------------------------------------------
- |# 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
- +--------------------------------------------------
+=item * bad
-=head1 CONFIG FILE : required entries
+the last probe of the site was unsuccessful
-=head2 project_name <name>
+=item * old
- Specify a short plaintext name for the project.
+the last probe was more than 'max_poll' ago.
- project_name Apache
- project_name CTAN
+=back
-=head2 project_url <url>
+Sites are not probed if the last probe was less than 'min_poll' ago.
+So, if you specify
- Specify an url pointing to the 'home' of the project.
+ min_poll 4h
+ max_poll 12h
- project_url http://www.apache.org/
+the 'reachable' sites are probed twice daily and the 'unreachable'
+sites are probed at most six times a day.
-=head2 mirror_list <file name>
+The default 'min_poll' is '1h' (1 hour).
+The default 'max_poll' is '4h' (4 hours).
- Specify the file containing the mirrors to probe.
- Two formats are supported :
+=item min_sync I<time-spec>
- -- plain : lines like
+Optionally specify how often the mirrors are required to make an update.
- us http://www.tux.org/
- nl http://apache.cs.uu.nl/dist/
+The default 'min_sync' is '1d' (1 day).
- -- apache : lines like those in the apache mirrors.list
+=item max_sync I<time-spec>
- 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
+Optionally specify the maximum allowable sync interval.
- Specify the required format with 'list_style' (see below).
- The default style is 'plain'.
+Sites exceeding the limit will be considered 'old'.
+The default 'max_sync' is '2d' (2 days).
- 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.
+=item always_get I<region ...>
-=head2 web_page <file name>
+Optionally specify a list of regions that must be probed always.
- Specify where the html report page is written.
+ always_get Master Tier1
-=head2 icons <directory name>
+This is intended for I<fake regions> like I<Master> etc.
- Specify the directory where the icons can be found.
+=item no_randomize
-=head2 probe <program + arguments>
+Mirmon tries to balance the probe load over the hourly mirmon runs.
+If the current run has a below average number of mirrors to probe,
+mirmon probes a few extra, randomly chosen mirrors, picked from the
+runs that have the highest load.
- Specify the program+args to probe the mirrors. Example:
+If you don't want this behaviour, use B<no_randomize>.
- probe /sw/bin/wget -q -O - -T %TIMEOUT% -t 1 %URL%TIME
+=item no_add_slash
- Before the program is started, %TIMEOUT% and %URL% are
- substituted with the proper timeout and url values.
+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.
- 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
+If you don't want this behaviour, use B<no_add_slash>.
- 42 * * * * perl -e 'printf "%s\n", time' > /path/to/archive/TIME
+=item list_style plain|apache
- Mirmon reads one line of output from the probe and interprets
- the first word on that line as a timestamp ; for example :
+Optionally specify the format ('plain' or 'apache') of the mirror-list.
- 1043625600
- 1043625600 Mon Jan 27 00:00:00 2003
- 1043625600 www.apache.org Mon Jan 27 00:00:00 2003
+See the description of 'mirror_list' above.
+The default list_style is 'plain'.
-=head2 state <file name>
+=item site_url I<site> I<url>
- 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).
+Optionally specify a substitute url for a site.
-=head2 countries <file name>
+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 '/'.
- Specify the file containing the country codes;
- The file should contain lines like
+=item env I<key> I<value>
- us - united states
- nl - netherlands
+Optionally specify an environment variable.
- The mirmon package contains a recent ISO list.
+=item include I<file-name>
-=head1 CONFIG FILE : optional entries
+Optionally specify a file to include.
-=head2 max_probes <number>
+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.
- Optionally specify the number of parallel probes (default 25).
+=item show
-=head2 timeout <seconds>
+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.
- 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.
+=item exit
-=head2 project_logo <logo>
+When the config processor encounters the 'exit' command, it
+terminates the program. This is intented for debugging.
- Optionally specify (the SRC of the IMG of) a logo to be placed
- top right on the page.
+=back
- project_logo /icons/apache.gif
- project_logo http://www.apache.org/icons/...
+=head1 STATE FILE FORMAT
-=head2 htm_head <html>
+The state file consists of lines; one line per site.
+Each line consists of white space separated fields.
+The seven fields are :
- Optionally specify some HTML to be placed before </HEAD>.
+=over 4
- htm_head
- <link REL=StyleSheet HREF="/style.css" TYPE="text/css">
+=item * field 1 : url
-=head2 htm_top <html>
+The url as given in the mirror list.
- Optionally specify some HTML to be placed near the top of the page.
- The supplied text is placed between <P> and </P>.
+=item * field 2 : age
- htm_top testing 1, 2, 3
+The mirror's timestamp found by the last successful probe,
+or 'undef' if no probe was ever successful.
-=head2 htm_foot <html>
+=item * field 3 : status last probe
- Optionally specify HTML to be placed near the bottom of the page.
+The status of the last probe, or 'undef' if the mirror was never probed.
- htm_foot
- <HR>
- <A HREF="..."><IMG SRC="..." BORDER=0></A>
- <HR>
+=item * field 4 : time last successful probe
-=head2 put_histo top|bottom|nowhere
+The timestamp of the last successful probe or 'undef'
+if the mirror was never successfully probed.
- Optionally specify where the age histogram must be placed.
- The default is 'top'.
+=item * field 5 : probe history
-=head2 min_poll <time spec>
+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.
- 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).
+=item * field 6 : state history
-=head2 max_poll <time spec>
+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).
- 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.
+=item * field 7 : last probe
- So, if you specify
+The timestamp of the last probe, or 'undef' if the mirror was never probed.
- min_poll 4h
- max_poll 12h
+=back
- the 'reachable' sites are probed twice daily and the 'unreachable'
- sites are probed at most six times a day.
+=head1 INSTALLATION
- The default 'min_poll' is '1h' (1 hour).
- The default 'max_poll' is '4h' (4 hours).
+=head2 general
-=head2 min_sync <time spec>
+=over 4
- Optionally specify how often the mirrors are required to
- make an update. The default 'min_sync' is '1d' (1 day).
+=item * Note: The (empty) state file must exist before mirmon runs.
-=head2 max_sync <time spec>
+=item * The mirmon repository is here :
- Optionally specify the maximum allowable sync interval.
- Sites exceeding the limit will be considered 'old'.
- The default 'max_sync' is '2d' (2 days).
+ https://svn.science.uu.nl/repos/project.mirmon/trunk/
-=head2 no_randomize
+=item * The mirmon tarball is here :
- 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.
+ http://www.staff.science.uu.nl/~penni101/mirmon/mirmon.tar.gz
- If you don't want this behaviour, use 'no_randomize'.
+=back
-=head2 list_style plain|apache
+=head2 installation suggestions
- Optionally specify the format ('plain' or 'apache') of the
- mirror-list. See the description of 'mirror_list' above.
- The default list_style is 'plain'.
+To install and configure mirmon, take the following steps :
-=head2 site_url <site> <url>
+=over 2
- 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 '/'.
+=item * First, make the webdir :
-=head2 env <key> <value>
+ cd DOCUMENTROOT
+ mkdir mirmon
- Optionally specify an environment variable.
+For I<DOCUMENTROOT>, substitute the full pathname
+of the document root of your webserver.
-=head2 include <file name>
+=item * Check out the mirmon repository :
- 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.
+ cd /usr/local/src
+ svn checkout REPO mirmon
-=head2 show
+where
- 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.
+ REPO = https://svn.science.uu.nl/repos/project.mirmon/trunk/
-=head2 exit
+or download the package and unpack it.
- When the config processor encounters the 'exit' command, it
- terminates the program. This is intented for debugging.
+=item * Chdir to directory mirmon :
-=head1 STATE FILE FORMAT
+ cd mirmon
- The state file consists of lines; one line per site.
- Each line consists of white space separated fields.
- The seven fields are :
+=item * Create the (empty) state file :
-=head2 field 1 : url
+ touch state.txt
- The url as given in the mirror list.
+=item * Install the icons in the webdir :
-=head2 field 2 : age
+ mkdir DOCUMENTROOT/mirmon/icons
+ cp icons/* DOCUMENTROOT/mirmon/icons
- The age of the site, or 'undef' if no probe was ever successful.
+=item * Create a mirror list C<mirror_list> ;
-=head2 field 3 : status last probe
+Use your favorite editor, or genererate the list from an
+existing database.
- The status of the last probe.
+ 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
-=head2 field 4 : time last succesful probe
+The email addresses are optional.
- The timestamp of the last succesful probe or 'undef'
- if the site was never successfully probed.
+=item * Create a mirmon config file C<mirmon.conf> with your favorite editor.
-=head2 field 5 : probe history
+ # 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.txt
- 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.
+This assumes the project's timestamp is in file C<TIME.txt>.
-=head2 field 6 : state history
+=item * If you have rsync urls, change the probe line to :
- 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.
+ probe perl /usr/local/src/mirmon/probe -t %TIMEOUT% %URL%TIME.txt
-=head2 field 7 : last probe
+=item * Run mirmon :
- The timestamp of the last probe.
+ perl mirmon -v -get all
-=head1 INSTALLATION
+The mirmon report should now be in 'DOCUMENTROOT/mirmon/index.html'
-=over
+ http://www.your.project.org/mirmon/
-=item *
+=item * If/when, at a later date, you want to upgrade mirmon :
- The '#!' path for perl is probably wrong.
+ cd /usr/local/src/mirmon
+ svn status -u
+ svn up
=back
+=head1 SEE ALSO
+
+=begin html
+
+<p>
+<a href="mirmon.pm.html">mirmon.pm(3)</a>
+</p>
+
+=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>,
- <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>
+ <p>
+ © 2003-2014
+ <a href="http://www.staff.science.uu.nl/~penni101/">Henk P. Penning</a>,
+ <a href="http://www.uu.nl/faculty/science/EN/">Faculty of Science</a>,
+ <a href="http://www.uu.nl/">Utrecht University</a>
+ <br />
+ mirmon-2.10 - Fri Aug 15 12:26:55 2014 ; henkp ;
+ <a href="http://validator.w3.org/check?uri=referer">verify html</a>
+ </p>
=end html
+=begin man
+
+ (c) 2003-2014 Henk P. Penning
+ Faculty of Science, Utrecht University
+ http://www.staff.science.uu.nl/~penni101/ -- penning@uu.nl
+ mirmon-2.10 - Fri Aug 15 12:26:55 2014 ; 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-2014 Henk P. Penning
+ Faculty of Science, Utrecht University
+ http://www.staff.science.uu.nl/~penni101/ -- penning@uu.nl
+ mirmon-2.10 - Fri Aug 15 12:26:55 2014 ; henkp
=end text
=cut
-
git://git.exim.org / mirror-monitor.git / blobdiff