# 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.36 2004/12/28 17:54:10 henkp Exp $
+# Version 1.1 was donated to the Apache Software Foundation 2003 Jan 28.
# Permission is hereby granted, free of charge, to any person obtaining a
# copy of this software and associated documentation files (the "Software"),
# to deal in the Software without restriction, including without limitation
# the rights to use, copy, modify, merge, publish, distribute, sublicense,
# and/or sell copies of the Software, and to permit persons to whom the
# Software is furnished to do so, subject to the following conditions:
-#
+#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
-#
+#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
# DEALINGS IN THE SOFTWARE.
-
-my $PRG = 'mirmon' ;
-my $VER = '$Id: mirmon,v 1.36 2004/12/28 17:54:10 henkp Exp $' ;
+#
+# 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
- 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.3" ;
+
+our $DEF_TIMEOUT = 300 ;
+our $HIST = 14 ;
+our $TIM_PAT = '^(\d+)([smhd])$' ;
+our %APA_TYPES = () ; for ( qw(backup ftp http) ) { $APA_TYPES { $_ } ++ ; }
+our %GET_OPTS = () ; for ( qw(all update) ) { $GET_OPTS { $_ } ++ ; }
+our $HIST_DELTA = 24 * 60 * 60 ;
+our $APRX_DELTA = 60 ;
+our $HOME = 'http://www.cs.uu.nl/people/henkp/mirmon/' ;
+
+package Base ; #####################################################
+
+use base 'Exporter' ;
+
+our ( @ISA, @EXPORT ) ;
+BEGIN
+ { @ISA = qw(Exporter) ;
+ @EXPORT =
+ qw(aprx_eq aprx_ge aprx_le aprx_gt aprx_lt
+ URL NAM SMA BLD NSS TAB BQ TR TH TD TDr RED GRN H1 H2 H3
+ s4tim pr_interval pr_diff
+ ) ;
}
-sub 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 -f $conf ; }
+ die sprintf "can't find a config file :\n %s\n" , join "\n ", @LIST ;
+ }
+
+sub get_config
+ { my $self = shift ;
+ my $path = shift ;
+ my $file = $self -> find_config ( $path ) ; # or die
+ $self -> conf ( Mirmon::Conf -> new ( $file ) ) ;
}
sub get_state
- { my $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 $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 = () ;
+ 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 ; }
-
- if ( aprx_le $stmp, $^T - tim_to_s '1d' )
- { $res = sprintf "%s-%s%s"
- , $^T
- , substr ( $hist, 1 - $HIST )
- , age_code ( $time )
- ;
+ unless ( exists $res -> { $url } )
+ { printf "*** added to list %s\n", $url unless Mirmon::quiet ;
+ $res -> { $url } = Mirmon::Mirror -> init ( $self, $url ) ;
+ }
+ my $mirror = $res -> { $url } ;
+ $mirror -> region ( $reg ) ;
+ $mirror -> mail ( $mail || '' ) ;
}
- return $res ;
+ close MLIST ;
+
+ for my $url ( sort keys %$res )
+ { # printf "%s\n", $res -> { $url } -> state ;
+ unless ( exists $in_list { $url } )
+ { printf "*** removed from list %s\n", $url unless Mirmon::quiet ;
+ delete $res -> { $url } ;
+ }
+ }
+ $self -> state ( $res ) ;
}
sub put_state
- { my $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 } = lc $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 get_dates
+ { my $self = shift ;
+ my $get = shift ;
+ my $state = $self -> state ;
+ my $conf = $self -> conf ;
+ my $CMD = $conf -> probe ;
+ my $PAR = $conf -> max_probes ;
+ my %m4h = () ;
+ my @QUE = () ;
+ my @NOQ = () ;
+ my $GET = IO::Select -> new () ;
+
+ my $cnt = 0 ;
+ my $nok = 0 ;
+
+ for my $url ( sort keys %$state )
+ { my $mirror = $state -> { $url } ;
+ $cnt ++ if $mirror -> last_status eq 'ok' ;
+ if ( $get eq 'all' or $mirror -> last_probe eq 'undef' )
+ { push @QUE, $mirror ; }
+ elsif ( $get eq 'update' )
+ { my $stat = $mirror -> last_status ;
+ my $vrfy = $mirror -> last_ok_probe ;
+ my $lprb = $mirror -> last_probe ;
+ if ( aprx_le $lprb, $^T - s4tim $conf -> min_poll )
+ { if ( $stat ne 'ok' )
+ { push @QUE, $mirror ; $nok ++ ; }
+ elsif ( aprx_le $vrfy, $^T - s4tim $conf -> max_poll )
+ { push @QUE, $mirror ; }
+ else
+ { push @NOQ, $mirror ; }
+ }
+ }
+ else
+ { die "unknown opt_get '$get'" ; }
+ }
-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 ; }
+ if ( Mirmon::verbose )
+ { my $que = scalar @QUE ; my $noq = scalar @NOQ ;
+ printf "ok mirrors %d, queued %d, not queued %d, ok %d, nok %d\n"
+ , $cnt, $que, $noq, $que - $nok, $nok
+ }
-sub get_list
- { my $LST = shift ;
- my ( $reg, $url ) ;
- open LST, $LST or Error "can't open '$LST' ($!)" ;
- while ( <LST> )
- { chop ;
- next if /^#/ ;
- next if /^\s*$/ ;
- if ( $CNF { list_style } eq 'plain' )
- { ( $reg, $url ) = split ' ' ;
- unless ( $url =~ m!/$! )
- { print "*** mirmon appended '/' to $url\n" unless $opt{q} ;
- $url .= '/' ;
- }
- }
- elsif ( $CNF { list_style } eq 'apache' )
- { my $apache_type ;
- ( $apache_type, $reg, $url ) = split ' ' ;
- unless ( defined $APA_TYPES { $apache_type } )
- { print "*** strange type : $apache_type\n" unless $opt{q} ;
- next ;
- }
- unless ( $url =~ m!/$! )
- { print "*** missing '/' in $url\n" unless $opt{q} ;
- $url .= '/' ;
- }
- }
-
- my $site = site $url ;
- my $type = type $url ;
-
- unless ( defined $site )
- { print "*** strange url : '$url'\n" unless $opt{q} ; next ; }
-
- $LST { $url } = [ $type , $site, $reg ] ;
+ if ( $conf -> randomize )
+ { my $hrs = int ( ( s4tim $conf -> max_poll ) / 60 / 60 + 0.5 ) ;
+ my $avg = int ( $cnt / $hrs + 0.5 ) ;
+ my $prc = ( scalar keys %$state ) / 50 ;
+ my $flr = int $prc ;
+ my $extras = $flr + ( rand 1 < ( $prc - $flr ) ) ;
+ my $picked = 0 ;
+
+ while ( @QUE < $avg + $nok and @NOQ and $picked < $extras )
+ { my $idx = int rand @NOQ ;
+ push @QUE, $NOQ [ $idx ] ;
+ $NOQ [ $idx ] = $NOQ [ $#NOQ ] ;
+ pop @NOQ ;
+ $picked ++ ;
+ }
+
+ printf "avg mirrors/hr %d, max extras %d, picked %d ; queued %s\n"
+ , $avg, $extras, $picked, scalar @QUE if Mirmon::verbose ;
}
- }
-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] ; }
+ 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 ) ; }
+ }
-sub htmlquote
- { my $x = shift ;
- $x =~ s/&/&/g ;
- $x =~ s/</</g ;
- $x =~ s/>/>/g ;
- return $x ;
- }
+ my @can_read = $GET -> can_read ( 0 ) ;
-sub diff
- { my $time = shift ;
- my $max = shift ;
- my $res ;
+ printf "queue %d, started %d, probes %d, can_read %d\n",
+ scalar @QUE, $started, $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 )
+ { # order is important ; wget's hang if/when actions are reversed
+ $GET -> remove ( $handle ) ;
+ $m4h { $handle } -> finish_probe ( $handle ) ;
+ }
+
+ sleep 1 ;
}
- return $res ;
+
+ my $stop = time + $conf -> timeout + 10 ;
+
+ while ( $GET -> count () and time < $stop )
+ { my @can_read = $GET -> can_read ( 0 ) ;
+
+ printf "wait %2d, probes %d, can_read %d\n",
+ $stop - scalar time, $GET -> count (), scalar @can_read
+ if Mirmon::verbose ;
+
+ for my $handle ( @can_read )
+ { $GET -> remove ( $handle ) ;
+ $m4h { $handle } -> finish_probe ( $handle ) ;
+ }
+
+ sleep 10 ;
+ }
+
+ for my $handle ( $GET -> handles () )
+ { $m4h { $handle } -> update ( 0, 'hangs', undef ) ; }
}
sub img_sf_cnt
- { 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 "<BLOCKQUOTE>\n" . TAB ( $res ) . "</BLOCKQUOTE>\n" ;
+ return BQ TAB $res ;
}
-sub gen_histogram
- { my $MAX_H = max_age1 ;
- my $MAX_h = 1 +
- ( ( 20 * 3600 <= $MAX_H and $MAX_H <= 36 * 3600 )
- ? int ( $MAX_H / 3600 )
- : 25
- ) ;
- my $MAX_O = max_age2 ;
- my $MAX_o = int ( $MAX_O / 3600 + 0.5 ) ;
- my $H = 18 ;
- my %W = ( 'old' => 1, 'ded' => 1, 'bad' => 1 ) ;
- my %Wmx = ( 'old' => 5, 'ded' => 3, 'bad' => 3 ) ;
- my %tab ;
- my %hst ;
- my $res ;
- for ( my $x = 0 ; $x < $MAX_h ; $x ++ ) { $tab { $x } = 0 ; }
- $tab { old } = 0 ; $tab { ded } = 0 ; $tab { bad } = 0 ;
- for my $url ( keys %RES )
- { my $time = $RES { $url } [ 0 ] ;
+sub age_avg
+ { my $self = shift ;
+ my $state = $self -> state ;
+ my @tab = () ;
+ for my $url ( keys %$state )
+ { my $time = $state -> { $url } -> age ;
+ push @tab, $^T - $time if $time =~ /^\d+$/ ;
+ }
+ my $cnt = @tab ;
+
+ return undef if $cnt == 0 ;
+
+ @tab = sort { $a <=> $b } @tab ;
+
+ my $tot = 0 ;
+ for my $age ( @tab ) { $tot += $age ; }
+ my $mean = $tot / $cnt ;
+
+ my $median ;
+ if ( $cnt == 1 )
+ { $median = $tab [ 0 ] ; }
+ elsif ( $cnt % 2 )
+ { my $mid = int ( $#tab / 2 ) ;
+ $median = ( $tab [ $mid ] + $tab [ $mid + 1 ] ) / 2 ;
+ }
+ else
+ { my $mid = int ( $#tab / 2 ) ;
+ $median = $tab [ $mid ] ;
+ }
+
+ if ( @tab < 2 )
+ { return $mean, $median, undef ; }
+
+ my $sum = 0 ;
+ for my $age ( @tab )
+ { $sum += ( $age - $mean ) ** 2 ; }
+ my $stddev = sqrt ( $sum / ( $cnt - 1 ) ) ;
+
+ return $mean, $median, $stddev ;
+ }
+
+sub legend
+ { my $self = shift ;
+ my $conf = $self -> conf ;
+ my $min_sync = $conf -> min_sync ;
+ my $max_sync = $conf -> max_sync ;
+ my $min_poll = $conf -> min_poll ;
+ my $max_poll = $conf -> max_poll ;
+
+ return <<LEGENDA ;
+<H3>legend</H3>
+
+<H4><I>project</I> site -- home</H4>
+
+<BLOCKQUOTE>
+<B><I>project</I> site</B> is an url.
+The <B>href</B> is the href for the site in the list of mirrors,
+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 $self = shift ;
+ my $where = shift ;
+ my $conf = $self -> conf ;
+ my $state = $self -> state ;
+
+ return '' if $where ne $conf -> put_histo ;
+
+ my $MAX_H = $conf -> max_age1 ;
+ my $MAX_h = 1 +
+ ( ( 20 * 3600 <= $MAX_H and $MAX_H <= 36 * 3600 )
+ ? int ( $MAX_H / 3600 )
+ : 25
+ ) ;
+ my $MAX_O = $conf -> max_age2 ;
+ my $MAX_o = int ( $MAX_O / 3600 + 0.5 ) ;
+ my $H = 18 ;
+ my %W = ( 'old' => 1, 'ded' => 1, 'bad' => 1 ) ;
+ my %Wmx = ( 'old' => 5, 'ded' => 3, 'bad' => 3 ) ;
+ my %tab ;
+ my %hst ;
+ my $res ;
+ for ( my $x = 0 ; $x < $MAX_h ; $x ++ ) { $tab { $x } = 0 ; }
+ $tab { old } = 0 ; $tab { ded } = 0 ; $tab { bad } = 0 ;
+ for my $url ( keys %$state )
+ { my $time = $state -> { $url } -> age ;
if ( $time =~ /^\d+$/ )
- { my $s = $^T - $time ;
- my $hr = int ( $s / $MAX_H * ( $MAX_h - 1 ) + 0.5 ) ;
- if ( $s <= $MAX_H ) { $tab { $hr } ++ ; }
- elsif ( $s <= $MAX_O ) { $tab { old } ++ ; }
- else { $tab { ded } ++ ; }
- }
- else
- { $tab { bad } ++ ; }
+ { my $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 } ;
}
}
, 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 ;
+ $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 )
- { $res .= sprintf "<TH>%s</TH>\n"
- , ( ( $hst { $x } >= $h )
- ? img_sf
- ( $x =~ /^\d+$/
- ? 's'
- : ( $x =~ /^old/ ? 'b' : ( $x =~ /^ded/ ? 'f' : 'z' ) )
- )
- : ( ( $h == 1 and $hst { $x } == 0 )
- ? sprintf
- ( '<IMG SRC="%s/bar.gif" ALT="" BORDER=0>'
- , $CNF { icons }
- )
- : ''
- )
- ) ;
- }
- $res .= "</TR>\n" ;
+ { my $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" ;
my $FRMT = '<TD ALIGN="CENTER" COLSPAN=%d> %s </TD>' ;
-
+
$res .= "<TR>\n" ;
- $res .= sprintf "$FRMT\n", 1, NSS scalar keys %RES ;
+ $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 = "<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 %s %s %s represent one mirror site.\n"
- , img_sf ( 's' ), img_sf ( 'f' ), img_sf ( 'b' ), img_sf ( 'z' ) ;
+ { $res .= sprintf "<BR>units %s represent one mirror site.\n"
+ , $units ;
}
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 )
+ { $res .= sprintf "<BR>each %s unit represents %s mirror sites.\n"
+ , $units, sprintf ( "%.1f", $max / $H ) ;
}
- return $res ;
+ return H2 ( 'age histogram' ) . BQ $res ;
+ }
+
+sub gen_page
+ { my $self = shift ;
+ my $get = shift ;
+ my $VERSION = shift ;
+ my $conf = $self -> conf ;
+ my $PPP = $conf -> web_page ;
+ my $state = $self -> state ;
+ my $CCS = $self -> regions ;
+ my $TMP = "$PPP.tmp" ;
+ my %tab ;
+ my $refs ;
+
+ for my $url ( keys %$state )
+ { my $mirror = $state -> { $url } ;
+ my $reg = $mirror -> region ;
+ push @{ $tab { $reg } }, $mirror ;
+ }
+
+ my $bad = 0 ; my $old = 0 ; my $unr = 0 ;
+ my %stats ;
+ my @stats ;
+ my $ok = 0 ;
+
+ for my $url ( keys %$state )
+ { my $mirror = $state -> { $url } ;
+ my $time = $mirror -> age ;
+ my $stat = $mirror -> last_status ;
+ my $vrfy = $mirror -> last_ok_probe ;
+ if ( $stat eq 'ok' ) { $ok ++ ; } else { $stats { $stat } ++ ; }
+ if ( $time eq 'undef' )
+ { $bad ++ ; }
+ elsif ( 'f' eq $conf -> age_code ( $time ) )
+ { $old ++ ; }
+ if ( $vrfy eq 'undef' or aprx_lt $vrfy, $^T - $conf -> max_vrfy )
+ { $unr ++ ; }
+ }
+
+ my $STAT = sprintf
+ "%d bad -- %d older than %s -- %s unreachable for more than %s"
+ , $bad
+ , $old
+ , pr_interval ( $conf -> max_age2 )
+ , $unr
+ , pr_interval ( $conf -> max_vrfy )
+ ;
+
+ my $PROB = 'last probes : ' ;
+ push @stats, "$ok were ok" if $ok ;
+ for my $stat ( sort keys %stats )
+ { ( my $txt = $stat ) =~ s/_/ /g ;
+ push @stats, sprintf "%s had %s" , $stats { $stat } , RED $txt ;
+ }
+ $PROB .= join ', ', @stats ;
+
+ my ( $mean, $median, $stddev ) = $self -> age_avg ;
+ my $AVGS = "mean mirror age is " ;
+ unless ( defined $mean )
+ { $AVGS = "<I>undefined</I>" ; }
+ else
+ { $AVGS .= sprintf "%s", pr_interval $mean ;
+ if ( defined $stddev )
+ { $AVGS .= sprintf ", std_dev %s", pr_interval $stddev ; }
+ $AVGS .= sprintf ", median %s", pr_interval $median ;
+ }
+
+ for my $reg ( sort keys %tab )
+ { $refs .= sprintf " %s \n"
+ , URL "#$reg", "<FONT SIZE=\"+1\">$reg</FONT>"
+ ;
+ }
+
+ my $COLS = 5 ;
+ my $NAME = $conf -> project_name ;
+ my $LOGO = $conf -> project_logo
+ ? URL
+ ( $conf -> project_url
+ , sprintf
+ ( '<IMG SRC="%s" ALT="%s" ALIGN="RIGHT" BORDER=0>'
+ , $conf -> project_logo
+ , $conf -> project_name
+ )
+ )
+ : ''
+ ;
+ my $HEAD = $conf -> htm_head . "\n" ;
+ my $HTOP = $conf -> htm_top . "\n" ;
+ my $FOOT = $conf -> htm_foot . "\n" ;
+ my $TITL = URL $conf -> project_url, $NAME ;
+ my $EXPD = Base::exp_date ;
+ my $DATE = scalar gmtime $^T ;
+ my $LAST = scalar gmtime ( $get ? $^T : ( stat $conf -> state ) [9] ) ;
+
+ my $histo_top = $self -> gen_histogram ( 'top' ) ;
+ my $histo_bot = $self -> gen_histogram ( 'bottom' ) ;
+
+ open PPP, ">$TMP" or die "can't write $TMP ($!)" ;
+ my $prev_select = select PPP ;
+
+ my $attr1 = "COLSPAN=$COLS BGCOLOR=LIME" ;
+ my $attr2 = 'BGCOLOR=AQUA' ;
+ my $attr3 = "COLSPAN=$COLS BGCOLOR=YELLOW" ;
+
+ my $num_mirrors = scalar keys %$state ;
+ my $num_regions = scalar keys %tab ;
+
+ print <<HEAD ;
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<HTML>
+<HEAD>
+<TITLE>the status of $NAME mirrors</TITLE>
+<META HTTP-EQUIV="content-type" CONTENT="text/html; charset=utf-8">
+<META HTTP-EQUIV=refresh CONTENT=3600>
+<META HTTP-EQUIV=Expires CONTENT=\"$EXPD\">
+$HEAD
+</HEAD>
+<BODY BGCOLOR=\"#FFFFFF\">
+$LOGO
+<H2>the status of $TITL mirrors</H2>
+<TABLE BORDER=0 CELLPADDING=2>
+<TR><TD>date</TD><TD>:</TD><TD>$DATE (UTC)</TD></TR>
+<TR><TD>last check</TD>
+ <TD>:</TD>
+ <TD>$LAST (UTC)</TD>
+</TR>
+</TABLE>
+$HTOP
+$histo_top
+<H2>regions</H2>
+<BLOCKQUOTE><CENTER>\n$refs\n</CENTER></BLOCKQUOTE>
+<H2>report</H2>
+<BLOCKQUOTE>
+<TABLE BORDER=2 CELLPADDING=5>
+<TR><TH $attr1>$num_mirrors sites in $num_regions regions</TH></TR>
+<TR><TH $attr1>$STAT</TH></TR>
+<TR><TH $attr1>$PROB</TH></TR>
+<TR><TH $attr1>$AVGS</TH></TR>
+<TR>
+ <TH $attr2>$NAME site -- home</TH>
+ <TH $attr2>type</TH>
+ <TH $attr2>mirror age,<BR>daily stats</TH>
+ <TH $attr2>last probe,<BR>probe stats</TH>
+ <TH $attr2>last stat</TH>
+</TR>
+HEAD
+
+ for my $reg
+ ( sort
+ { ( $CCS -> { $a } || $a ) cmp ( $CCS -> { $b } || $b ) ; }
+ keys %tab
+ )
+ { my $mirrors = $tab { $reg } ;
+
+ my $ccs = exists $CCS -> { $reg } ? $CCS -> { $reg } : $reg ;
+ $ccs = NAM $reg,
+ ( scalar @{ $mirrors } > 6
+ ? sprintf "%s - %d sites"
+ , $ccs, scalar @{ $mirrors }
+ : $ccs
+ ) ;
+ printf "<TR><TH $attr3>$ccs</TH></TR>\n" ;
+
+ for my $mirror ( sort { $a -> cmp ( $b ) } @$mirrors )
+ { print "<TR>\n" ;
+ printf " <TD ALIGN=RIGHT>%s %s</TD>\n <TD>%s</TD>\n"
+ , $mirror -> site_url
+ , $mirror -> home_url
+ , $mirror -> type
+ ;
+
+ my ( $url, $time, $stat, $vrfy, $hstp, $hsts ) =
+ $mirror -> as_list ;
+ my $pr_time = $time =~ /^\d+$/
+ ? pr_diff $time, $^T - $conf -> max_age2 : ' ' ;
+ my $pr_last = $vrfy =~ /^\d+$/
+ ? pr_diff $vrfy, $^T - $conf -> max_vrfy : ' ' ;
+ my $pr_hstp = $self -> show_hist ( $hstp ) ;
+ my $pr_hsts = $self -> show_hist ( $hsts ) ;
+
+ if ( $stat ne 'ok' ) { $stat =~ s/_/ /g ; $stat = RED $stat ; }
+ printf " <TD ALIGN=RIGHT>%s<BR>%s</TD>\n" , $pr_time, $pr_hsts ;
+ printf " <TD ALIGN=RIGHT>%s<BR>%s</TD>\n" , $pr_last, $pr_hstp ;
+ printf " <TD>%s</TD>\n", $stat ;
+ print "</TR>\n" ;
+ }
+ }
+
+ my $legend = $self -> legend ;
+ my $probes = $self -> gen_histogram_probes ;
+ my $mir_img = sprintf
+ '<IMG BORDER=2 ALT=mirmon SRC="%s/mirmon.gif">' , $conf -> icons ;
+
+ print <<TAIL ;
+</TABLE>
+</BLOCKQUOTE>
+$histo_bot
+$legend
+<H3>probe results</H3>
+$probes
+<H3>software</H3>
+<BLOCKQUOTE>
+<TABLE>
+<TR>
+ <TH><A HREF=\"$HOME\">$mir_img</A></TH>
+ <TD>$VERSION</TD>
+</TR>
+</TABLE>
+</BLOCKQUOTE>
+$FOOT
+</BODY>
+</HTML>
+TAIL
+
+ select $prev_select ;
+
+ if ( print PPP "\n" )
+ { close PPP ;
+ if ( -z $TMP )
+ { warn "wrote empty html file; keeping previous version" ; }
+ else
+ { rename $TMP, $PPP or die "can't rename $TMP, $PPP ($!)" ; }
+ }
+ else
+ { die "can't print to $TMP ($!)" ; }
+ }
+
+package Mirmon::Conf ; #############################################
+
+BEGIN { use base 'Base' ; Base -> import () ; }
+
+our %CNF_defaults =
+ ( project_logo => ''
+ , timeout => $DEF_TIMEOUT
+ , max_probes => 25
+ , min_poll => '1h'
+ , max_poll => '4h'
+ , min_sync => '1d'
+ , max_sync => '2d'
+ , list_style => 'plain'
+ , put_histo => 'top'
+ , randomize => 1
+ , add_slash => 1
+ , htm_top => ''
+ , htm_foot => ''
+ , htm_head => ''
+ ) ;
+
+our @REQ_KEYS =
+ qw( web_page state countries mirror_list probe
+ project_name project_url icons
+ ) ;
+our %CNF_KEYS ;
+for ( @REQ_KEYS, keys %CNF_defaults ) { $CNF_KEYS { $_ } ++ ; }
+
+my @LIST_STYLE = qw(plain apache) ;
+my @PUT_HGRAM = qw(top bottom nowhere) ;
+
+eval Base -> mk_methods ( keys %CNF_KEYS, qw(root site_url) ) ;
+
+sub new
+ { my $self = shift ;
+ my $FILE = shift ;
+ my $res = bless { %CNF_defaults }, $self ;
+ $res -> root ( $FILE ) ;
+ $res -> site_url ( {} ) ;
+ $res -> get_conf () ;
+ }
+
+sub get_conf
+ { my $self = shift ;
+ my $FILE = ( @_ ? shift : $self -> root ) ;
+
+ if ( grep $_ eq $FILE, @{ $self -> {_include} } )
+ { die "already included : '$FILE'" ; }
+ else
+ { push @{ $self -> {_include} }, $FILE ; }
+
+ open FILE, $FILE or die "can't open '$FILE' ($!)" ;
+ my $CONF = join "\n", grep /./, <FILE> ;
+ close FILE ;
+
+ $CONF =~ s/\t/ /g ; # replace tabs
+ $CONF =~ s/^[+ ]+// ; # delete leading space, plus
+ $CONF =~ s/\n\n\s+/ /g ; # glue continuation lines
+ $CONF =~ s/\n\n\+\s+//g ; # glue concatenation lines
+ $CONF =~ s/\n\n\./\n/g ; # glue concatenation lines
+
+ chop $CONF ;
+ print "--$CONF--\n" if Mirmon::debug ;
+ for ( grep ! /^#/, split /\n\n/, $CONF )
+ { my ($key,$val) = split ' ', $_, 2 ;
+ $val = '' unless defined $val ;
+ print "conf '$FILE' : key '$key', val '$val'\n" if Mirmon::debug ;
+ if ( exists $CNF_KEYS { $key } )
+ { $self -> $key ( $val ) ; }
+ elsif ( $key eq 'site_url' )
+ { my ( $site, $url ) = split ' ' , $val ;
+ $url .= '/' if $self -> add_slash and $url !~ m!/$! ;
+ $self -> site_url -> { $site } = $url ;
+# printf "config : for site '%s' use instead\n '%s'\n",
+# $site, $url if Mirmon::verbose ;
+ }
+ elsif ( $key eq 'no_add_slash' )
+ { $self -> add_slash ( 0 ) ; }
+ elsif ( $key eq 'no_randomize' )
+ { $self -> randomize ( 0 ) ; }
+ elsif ( $key eq 'show' )
+ { $self -> show_conf if Mirmon::verbose ; }
+ elsif ( $key eq 'exit' )
+ { die 'exit per config directive' ; }
+ elsif ( $key eq 'include' )
+ { $self -> get_conf ( $val ) ; }
+ elsif ( $key eq 'env' )
+ { my ( $x, $y ) = split ' ' , $val ;
+ $ENV { $x } = $y ;
+ printf "config : setenv '%s'\n '%s'\n", $x, $y
+ if Mirmon::verbose ;
+ }
+ else
+ { $self -> show_conf ;
+ die "unknown keyword '$key' (value '$val')\n" ;
+ }
+ }
+ my $err = $self -> check ;
+ die $err if $err ;
+ $self ;
+ }
+
+sub check
+ { my $self = shift ;
+ my $err = '' ;
+ for my $key ( @REQ_KEYS )
+ { unless ( exists $self -> { $key } )
+ { $err .= "error: missing config for '$key'\n" ; }
+ }
+ for my $key ( qw(min_poll max_poll max_sync min_sync) )
+ { my $max = $self -> $key ;
+ unless ( $max =~ /$TIM_PAT/o )
+ { $err .= "error: bad timespec for $key ($max)\n" ; }
+ }
+ unless ( grep $self -> { list_style } eq $_, @LIST_STYLE )
+ { $err .= sprintf "error: unknown 'list_style' '%s'\n",
+ $self -> list_style ;
+ }
+ unless ( grep $self -> put_histo eq $_, @PUT_HGRAM )
+ { $err .= sprintf "%s : error: unknown 'put_histo' '%s'\n",
+ $self -> put_histo ;
+ }
+ $err ;
+ }
+
+sub show_conf
+ { my $self = shift ;
+ print "vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv\n" ;
+ for my $key ( sort keys %$self )
+ { next if $key =~ m/^_/ ;
+ my $val = $self -> { $key } ;
+ print "show_conf : $key = '$val'\n" ;
+ }
+ for my $key ( sort keys %{ $self -> site_url } )
+ { printf "show_conf : for site '%s' use instead\n '%s'\n"
+ , $key, $self -> site_url -> { $key } if Mirmon::verbose ;
+ }
+ printf "show_conf : included '%s'\n"
+ , join "', '", @{ $self -> {_include} } ;
+ print "^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n" ;
+ }
+
+sub max_age1
+ { my $self = shift ;
+ ( s4tim $self -> min_sync ) + ( s4tim $self -> max_poll ) ;
+ }
+
+sub max_age2
+ { my $self = shift ;
+ ( s4tim $self -> max_sync ) + ( s4tim $self -> max_poll ) ;
+ }
+
+sub max_vrfy
+ { my $self = shift ;
+ ( s4tim $self -> min_poll ) + ( s4tim $self -> max_poll ) ;
+ }
+
+sub age_code
+ { my $self = shift ;
+ my $time = shift ;
+ return 'z' unless $time =~ /^\d+$/ ;
+ return
+ ( ( aprx_ge ( $time, $^T - $self -> max_age1 ) )
+ ? 's'
+ : ( aprx_ge ( $time, $^T - $self -> max_age2 ) ? 'b' : 'f' )
+ ) ;
+ }
+
+package Mirmon::Mirror ; ###########################################
+
+BEGIN { use base 'Base' ; Base -> import () ; }
+
+use IO::Pipe ;
+
+my @FIELDS =
+ qw(url age last_status last_ok_probe probe_history state_history last_probe) ;
+
+eval Base -> mk_methods ( @FIELDS, qw(mirmon region mail) ) ;
+
+sub state_history_time
+ { my $self = shift ;
+ my $res = ( split /-/, $self -> state_history ) [ 0 ] ;
+ $res ;
+ }
+
+sub state_history_hist
+ { my $self = shift ;
+ my $res = ( split /-/, $self -> state_history ) [ 1 ] ;
+ $res ;
+ }
+
+sub _parse
+ { my $self = shift ;
+ my $url = $self -> url ;
+ my ( $type, $site, $home ) ;
+ if ( $url =~ m!^(ftp|https?|rsync)://([^/:]+)(:\d+)?/! )
+ { $type = $1 ; $site = $2 ; $home = $& ; }
+ return $type, $site, $home ;
+ }
+
+sub type { my $self = shift ; ( $self -> _parse ) [ 0 ] ; }
+sub site { my $self = shift ; ( $self -> _parse ) [ 1 ] ; }
+sub home { my $self = shift ; ( $self -> _parse ) [ 2 ] ; }
+
+sub age_in_days
+ { my $self = shift ;
+ my $res = 'undef' ;
+ my $age = $self -> age ;
+ if ( $age eq 'undef' )
+ { $res = length $self -> state_history_hist
+ if $self -> last_probe ne 'undef' ;
+ }
+ else
+ { $res = ( $^T - $age ) / 24 / 60 / 60 ; }
+ $res ;
+ }
+
+sub init
+ { my $self = shift ;
+ my $mirmon = shift ;
+ my $url = shift ;
+ my $res = bless { mirmon => $mirmon }, $self ;
+ @{ $res } { @FIELDS } = ( 'undef' ) x scalar @FIELDS ;
+ $res -> url ( $url ) ;
+ $res -> probe_history ( '' ) ;
+ $res -> state_history ( "$^T-z" ) ;
+ $res -> mail ( '' ) ;
+ $res ;
+ }
+
+sub new
+ { my $self = shift ;
+ my $mirmon = shift ;
+ my $line = shift ;
+ my $res = bless { mirmon => $mirmon }, $self ;
+ @{ $res } { @FIELDS } = split ' ', $line ;
+ $res -> mail ( '' ) ;
+ $res ;
+ }
+
+sub update
+ { my $self = shift ;
+ my $succ = shift ;
+ my $stat = shift ;
+ my $time = shift ;
+ my $probe_hist = $self -> probe_history ;
+ if ( $succ )
+ { $self -> age ( $time ) ;
+ $self -> last_ok_probe ( $^T ) ;
+ $probe_hist .= 's' ;
+ }
+ else
+ { $probe_hist .= 'f' ;
+ $time = $self -> age ;
+ }
+
+ my $h = $self -> state_history_hist ;
+ my $t = $self -> state_history_time ;
+
+ if ( aprx_ge ( $^T - $t, $HIST_DELTA ) )
+ { my $n = int ( ( $^T - $t ) / $HIST_DELTA ) ;
+ $h .= 'x' x ( $n - 1 ) ;
+ $t = ( $n == 1 ? $t + $HIST_DELTA : $^T ) ;
+ }
+ else
+ { chop $h ; }
+ $h .= $self -> mirmon -> conf -> age_code ( $time ) ;
+ $h = substr $h, - $HIST ;
+ $h =~ s/^x+// ;
+
+ $self -> last_status ( $stat ) ;
+ $self -> probe_history ( substr $probe_hist, - $HIST ) ;
+ $self -> last_probe ( $^T ) ;
+ $self -> state_history ( "$t-$h" ) ;
+ }
+
+sub as_list { my $self = shift ; @{ $self } { @FIELDS } ; }
+sub state { my $self = shift ; join ' ', $self -> as_list ; }
+
+sub start_probe
+ { my $self = shift ;
+ my $conf = $self -> mirmon -> conf ;
+ my $probe = $conf -> probe ;
+ my $timeout = $conf -> timeout ;
+ $probe =~ s/%TIMEOUT%/$timeout/g ;
+ my $url = $self -> url ;
+ my $new = $conf -> site_url -> { $self -> site } ;
+ if ( defined $new )
+ { printf "*** site_url : site %s\n -> url %s\n"
+ , $self -> site, $new if Mirmon::verbose ;
+ $url = $new ;
+ }
+ $probe =~ s/%URL%/$url/g ;
+ my $pipe = new IO::Pipe ;
+ my $handle = $pipe -> reader ( split ' ', $probe ) ;
+ if ( $handle )
+ { $pipe -> blocking ( 0 ) ; }
+ else
+ { die "start_probe : no pipe for $url" ; }
+ printf "start %s\n", $url if Mirmon::verbose ;
+ printf " %s\n", $probe if Mirmon::debug ;
+ $handle ;
+ }
+
+sub finish_probe
+ { my $self = shift ;
+ my $handle = shift ;
+ my $res ;
+ my $succ = 0 ;
+ my $stat ;
+ my $time ;
+
+ $handle -> blocking ( 1 ) ;
+ if ( $handle -> eof () )
+ { printf "finish eof %s\n", $self -> url if Mirmon::verbose ; }
+ else
+ { $res = $handle -> getline () ; }
+ $handle -> flush ;
+ $handle -> close ;
+
+ unless ( defined $res )
+ { $stat = 'no_time' ; }
+ elsif ( $res =~ /^\s*$/ )
+ { $stat = 'empty' ; }
+ else
+ { $res = ( split ' ', $res ) [ 0 ] ;
+
+ if ( $res !~ /^\d+$/ )
+ { $res =~ s/ /_/g ;
+ $res = Base::htmlquote $res ;
+ $res = substr ( $time, 0, 15 ) . '..' if length $res > 15 ;
+ $stat = "'$res'" ;
+ }
+ else
+ { $succ = 1 ; $stat = 'ok' ; $time = $res ; }
+ }
+
+ printf "finish %s\n succ(%s) stat(%s) time(%s)\n"
+ , $self -> url
+ , $succ
+ , $stat
+ , ( defined $time ? $time : 'undef' )
+ if Mirmon::verbose ;
+
+ $self -> update ( $succ, $stat, $time ) ;
}
sub revdom { my $dom = shift ; join '.', reverse split /\./, $dom ; }
-sub 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 )
+sub cmp
+ { my $a = shift ;
+ my $b = shift ;
+ ( revdom $a -> site ) cmp ( revdom $b -> site )
or
- $a_type cmp $b_type
+ ( $a -> type cmp $b -> type )
;
}
-sub by_CCS { ( $CCS { $a } || $a ) cmp ( $CCS { $b } || $b ) ; }
+sub _url
+ { my $hrf = shift ;
+ my $txt = shift ;
+ $hrf =~ /^rsync/ ? $txt : URL $hrf, $txt ;
+ }
-sub legend ;
+sub site_url { my $self = shift ; _url $self -> url , $self -> site ; }
+sub home_url { my $self = shift ; _url $self -> home, '@' ; }
-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 ] ;
- }
+=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 )>
+
+Probes all mirrors if $get is C<all> ; or a subset if $get is C<update>.
+
+=back
+
+=head1 Mirmon::Conf object methods
+
+A Mirmon::Conf object represents a mirmon conguration.
+It is normaly created by Mirmon::new().
+A specified (or default) config file is read and interpreted.
+
+=over 4
+
+=item attribute methods
+
+For every config file entry, there is an attribute method :
+B<web_page>, B<state>, B<countries>, B<mirror_list>, B<probe>,
+B<project_name>, B<project_url>, B<icons>, B<project_logo>,
+B<timeout>, B<max_probes>, B<min_poll>, B<max_poll>, B<min_sync>,
+B<max_sync>, B<list_style>, B<put_histo>, B<randomize>, B<add_slash>.
+
+=item B<root>
+
+Returns the file name of (the root of) the configuration file(s).
+
+=item B<site_url>
+
+Returns a hashref C<< { site => url, ... } >>,
+as specified in the mirmon config file.
+
+=back
+
+=head1 Mirmon::Mirror object methods
+
+A Mirmon::Mirror object represents the last known state of a mirror.
+It is normaly created by Mirmon::new() from the state file,
+as specified in the mirmon config file.
+Mirmon::Mirror objects can be used to probe mirrors.
+
+=head2 attribute methods
+
+=over 4
+
+=item B<url>
+
+The url as given in the mirror list.
+
+=item B<age>
+
+The mirror's timestamp found by the last succesful probe,
+or 'undef' if no probe was ever successful.
+
+=item B<last_status>
+
+The status of the last probe, or 'undef' if the mirror was never probed.
+
+=item B<last_ok_probe>
+
+The timestamp of the last succesful probe or 'undef'
+if the mirror was never successfully probed.
+
+=item B<probe_history>
+
+The probe history is a list of 's' (for success) and 'f' (for failure)
+characters indicating the result of the probe. New results are appended
+whenever the mirror is probed.
+
+=item B<state_history>
+
+The state history consists of a timestamp, a '-' char, and a list of
+chars indicating a past status: 's' (fresh), 'b' (oldish), 'f' (old),
+'z' (bad) or 'x' (skip).
+The timestamp indicates when the state history was last updated.
+The current status of the mirror is determined by the mirror's age and
+a few configuration parameters (min_sync, max_sync, max_poll).
+The state history is updated when the mirror is probed.
+If the last update of the history was less than 24 hours ago,
+the last status is replaced by the current status.
+If the last update of the history was more than 24 hours ago,
+the current status is appended to the history.
+One or more 'skip's are inserted, if the timestamp is two or more days old
+(when mirmon hasn't run for more than two days).
+
+=item B<last_probe>
+
+The timestamp of the last probe, or 'undef' if the mirror was never probed.
+
+=back
- my $bad = 0 ; my $old = 0 ; my $unr = 0 ;
- my %stats ;
- my @stats ;
- my $ok = 0 ;
+=head2 object methods
- 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 ++ ; }
- }
+=over 4
- 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 )
- ;
+=item B<mirmon>
- 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 ;
+Returns the parent Mirmon object.
- for my $reg ( sort keys %tab )
- { $refs .= sprintf " %s \n"
- , url "#$reg"
- , "<FONT SIZE=\"+1\">$reg</FONT>"
- ;
- }
+=item B<state_history_time>
- 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 $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"'
-# . ' "http://www.w3.org/TR/html4/loose.dtd"'
- . '>' ;
- 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>\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" ;
- }
+Returns the I<time> part of the state_history attribute.
- print PPP "<H2>regions</H2>\n" ;
+=item B<state_history_hist>
- print PPP "<BLOCKQUOTE>\n" ;
- print PPP "<CENTER>\n" ;
- printf PPP "%s\n", $refs ;
- print PPP "</CENTER>\n" ;
- print PPP "</BLOCKQUOTE>\n" ;
+Returns the I<history> part of the state_history attribute.
- print PPP "<H2>report</H2>\n" ;
+=item B<type>, B<site>, B<home>
- my $attr1 = "COLSPAN=$COLS BGCOLOR=\"LIME\"" ;
- my $attr2 = 'BGCOLOR="AQUA"' ;
+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/>.
- print PPP "<BLOCKQUOTE>\n" ;
- print PPP "<TABLE BORDER=2 CELLPADDING=5>\n" ;
- printf PPP "<TR><TH $attr1>%d sites in %d regions</TH></TR>\n"
- , scalar keys %LST
- , scalar keys %tab
- ;
- printf PPP "<TR><TH $attr1>%s</TH></TR>\n", $STAT ;
- printf PPP "<TR><TH $attr1>%s</TH></TR>\n", $PROB ;
- print PPP "<TR>\n" ;
- printf PPP " <TH $attr2>%s site -- home</TH>\n"
- , $CNF { project_name } ;
- printf PPP " <TH $attr2>%s</TH>\n", 'type' ;
- printf PPP " <TH $attr2>%s</TH>\n", 'mirror age,<BR>daily stats' ;
- printf PPP " <TH $attr2>%s</TH>\n", 'last probe,<BR>probe stats' ;
- printf PPP " <TH $attr2>%s</TH>\n", 'last stat' ;
- print PPP "</TR>\n" ;
- for my $reg ( sort by_CCS keys %tab )
- { my $itms = $tab { $reg } ;
-
- my $ccs = exists $CCS { $reg } ? $CCS { $reg } : $reg ;
- $ccs = nam $reg,
- ( scalar @{ $itms } > 6
- ? sprintf "%s - %d sites"
- , $ccs, scalar @{ $itms }
- : $ccs
- ) ;
-
- my $attr3 = "COLSPAN=$COLS BGCOLOR=\"YELLOW\"" ;
- printf PPP "<TR><TH $attr3>$ccs</TH></TR>\n" ;
-
- for my $itm ( sort by_type_site @{ $itms } )
- { my ( $type, $url, $site ) = @{ $itm } ;
- my ( $time, $stat, $hstp, $hsts, $vrfy ) ;
- my ( $pr_time, $pr_last, $pr_hstp, $pr_hsts ) ;
-
- print PPP "<TR>\n" ;
- printf PPP
- " <TD ALIGN=\"RIGHT\">%s %s</TD>\n"
- . " <TD>%s</TD>\n"
- , url ( $url , $site )
- , url ( home ( $url ), '@' )
- , $type
- ;
-
- if ( exists $RES { $url } )
- { ( $time, $stat, $vrfy, $hstp, $hsts ) = @{ $RES { $url } } ;
- $pr_time = $time =~ /^\d+$/
- ? diff $time, $^T - max_age2 : ' ' ;
- $pr_last = $vrfy =~ /^\d+$/
- ? diff $vrfy, $^T - max_vrfy : ' ' ;
- $pr_hstp = show_hist $hstp ;
- $pr_hsts = show_hist_age $hsts, $time ;
-
- }
- else
- { ( $pr_time, $pr_last, $pr_hstp, $pr_hsts, $stat ) =
- ( ' ', ' ', '', '', ' ' ) ;
- }
-
- $stat = RED $stat if $stat ne 'ok' ;
- printf PPP " <TD ALIGN=\"RIGHT\">%s<BR>%s</TD>\n"
- , $pr_time, $pr_hsts ;
- printf PPP " <TD ALIGN=\"RIGHT\">%s<BR>%s</TD>\n"
- , $pr_last, $pr_hstp ;
- printf PPP " <TD>%s</TD>\n", $stat ;
- print PPP "</TR>\n" ;
- }
- }
- print PPP "</TABLE>\n" ;
- print PPP "</BLOCKQUOTE>\n" ;
+=item B<age_in_days>
- if ( $CNF { put_histo } eq 'bottom' )
- { print PPP "<H2>age histogram</H2>\n" ;
+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.
- print PPP "<BLOCKQUOTE>\n" ;
- print PPP gen_histogram ;
- print PPP "</BLOCKQUOTE>\n" ;
- }
+=item B<mail>
- print PPP legend ;
+Returns the mirror's contact address as specified in the mirror list.
- print PPP "<H3>probe results</H3>\n" ;
- print PPP gen_histogram_probes ;
+=item B<region>
- print PPP "<H3>software</H3>\n" ;
+Returns the mirror's country code as specified in the mirror list.
- 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>" ;
+=item B<start_probe>
- 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 ($!)" ; }
- }
+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.
-sub legend
- { return <<LEGENDA ;
-<H3>legend</H3>
+=item B<finish_probe ( $handle )>
-<H4><I>project</I> site -- home</H4>
+Sets the (IO::Handle) B<$handle> to blocking IO ;
+reads a result from the handle,
+and updates the state of the mirror.
-<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>
+=back
-<H4>type</H4>
+=head1 SEE ALSO
-<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>
+=begin html
-<H4>mirror age, daily stats</H4>
+<A HREF="mirmon.html">mirmon(1)</A>
-<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>
+=end html
- <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>
+=begin man
- <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>
+mirmon(1)
-<H4>last probe, probe stats</H4>
+=end man
-<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>
+=head1 AUTHOR
-<H4>last stat</H4>
+=begin html
-<BLOCKQUOTE>
-<B>Last stat</B> gives the status of the last probe.
-</BLOCKQUOTE>
+ © 2003-2010
+ <A HREF="http://people.cs.uu.nl/henkp/">Henk P. Penning</A>,
+ <A HREF="http://www.cs.uu.nl/">Computer Science Department</A>,
+ <A HREF="http://www.uu.nl/">Utrecht University</A>
+ <BR>
+ mirmon-2.3 - Wed Mar 17 09:29:11 2010 ; henkp
-LEGENDA
- }
+=end html
-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' ; }
- }
+=begin man
-sub get_date
- { my $WGT = shift ;
- my $url = $URL { $WGT } ;
- my $time = undef ;
+ (c) 2003-2010 Henk P. Penning
+ Computer Science Department, Utrecht University
+ http://people.cs.uu.nl/henkp/ -- penning@cs.uu.nl
+ mirmon-2.3 - Wed Mar 17 09:29:11 2010 ; henkp
- $WGT -> blocking ( 1 ) ;
- unless ( $WGT -> eof () ) { $time = $WGT -> getline () ; }
- $GET -> remove ( $WGT ) ;
- $WGT -> flush ;
- $WGT -> close ;
+=end man
- unless ( defined $time ) { return err $url, 'no time' ; }
+=begin text
- $time = ( split ' ', $time ) [ 0 ] ;
+ (c) 2003-2010 Henk P. Penning
+ Computer Science Department, Utrecht University
+ http://people.cs.uu.nl/henkp/ -- penning@cs.uu.nl
+ mirmon-2.3 - Wed Mar 17 09:29:11 2010 ; henkp
- if ( $time eq '' )
- { err $url, "empty" ; }
- elsif ( $time !~ /^\d+$/ )
- { $time = htmlquote $time ;
- $time = substr ( $time, 0, 15 ) . '..' if length $time > 15 ;
- err $url, "'$time'" ;
- }
- else
- { res $url, $time, 'ok' ; }
- }
+=end text
-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}'" ; }
- }
+=cut
- 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' ; }
- }
+package main ; #####################################################
- my @can_read = $GET -> can_read ( 0 ) ;
+use IO::Pipe ;
+use IO::Select ;
+use Net::hostent ;
- printf "que %d, get %d, can %d\n",
- scalar @QUE, $GET -> count (), scalar @can_read
- if $opt{v} ;
-
- for my $can_read ( @can_read )
- { get_date $can_read ; }
+my $VERSION = Base::Version . ' - Wed Mar 17 09:29:11 2010 - henkp' ;
+my $DEF_CNF = join ', ', Mirmon -> config_list ;
+my $TIMEOUT = Base::DEF_TIMEOUT ;
- sleep 1 ;
- }
+my $prog = substr $0, rindex ( $0, '/' ) + 1 ;
+my $Usage = <<USAGE ;
+Usage: $prog [ -v ] [ -q ] [ -t timeout ] [ -get opt ] [ -c conf ]
+option v : be verbose
+option q : be quiet
+option t : set timeout ; default $TIMEOUT
+option get : 'all' : probe all sites
+ : 'update' : probe a selection of the sites (see doc)
+option c : configuration file ; default search :
+ ( $DEF_CNF )
+-------------------------------------------------------------------
+Mirmon normally only reports errors and changes in the mirror list.
+This is $VERSION.
+-------------------------------------------------------------------
+USAGE
+sub Usage { die "$_[0]$Usage" ; }
+sub Error { die "$prog: $_[0]\n" ; }
+sub Warn { warn "$prog: $_[0]\n" ; }
- my $stop = time + $CNF { timeout } + 10 ;
-
- while ( $GET -> count () and time < $stop )
- { sleep 1 ;
+# 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
- my @can_read = $GET -> can_read ( 0 ) ;
+use Getopt::Long ;
+Getopt::Long::config ( 'no_ignore_case' ) ;
+my %opt = () ;
+Usage '' unless GetOptions ( \%opt, qw(v q t=i get=s c=s version) ) ;
+Usage "Arg count\n" unless @ARGV == 0 ;
- printf "wait %2d, get %d, can %d\n",
- $stop - scalar time, $GET -> count (), scalar @can_read
- if $opt{v} ;
-
- for my $can_read ( @can_read )
- { get_date $can_read ; }
- }
+if ( $opt{version} ) { printf "%s\n", Base::version () ; exit ; }
- for my $WGT ( $GET -> handles () )
- { my $url = $URL { $WGT } ;
- err $url, 'hangs' ;
- }
- }
+$opt{v} ||= $opt{d} ;
-get_conf_opt ;
-get_ccs $CNF { countries } ;
-get_state $CNF { state } ;
-get_list $CNF { mirror_list } ;
+my $get = $opt{get} ;
+if ( $get and ! Base::is_get_opt ( $get ) )
+ { Error "unknown 'get option' '$get'" ; }
-if ( $opt{get} )
- { get_dates $CNF { probe } ;
- put_state $CNF { state } ;
- }
-else
- { %RES = %OLD }
+Mirmon::verbose ( $opt{v} ) ;
+Mirmon::debug ( $opt{d} ) ;
+Mirmon::quiet ( $opt{q} ) ;
-gen_page $CNF { web_page } ;
+my $M = Mirmon -> new ( $opt{c} ) ;
+$M -> conf -> timeout ( $opt{t} ) if $opt{t} ;
+if ( $get ) { $M -> get_dates ( $get ) ; $M -> put_state ; }
+$M -> gen_page ( $get, $VERSION ) ;
__END__
=head1 NAME
- mirmon - monitor the state of mirrors
+mirmon - monitor the state of mirrors
=head1 SYNOPSIS
option c : configuration file ; default list :
./mirmon.conf $HOME/.mirmon.conf /etc/mirmon.conf
-------------------------------------------------------------------
- Documentation : the program contains 'pod' style documentation.
- Extract the doc with 'pod2text mirmon' or 'pod2html mirmon OUT', etc.
+ Mirmon normally only reports errors and changes in the mirror list.
-------------------------------------------------------------------
=head1 USAGE
- The program is intended to be run by cron every hour.
+The program is intended to be run by cron every hour.
+
+ 42 * * * * perl /path/to/mirmon -get update
- 42 * * * * perl /path/to/mirmon -q -get update
+It quietly probes a subset of the sites in a given list,
+writes the results in the 'state' file and generates a web page
+with the results. The subset contains the sites that are new, bad
+and/or not probed for a specified time.
- 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.
- 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 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
- 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.
+ 1043625600 ...
+
+that is, a line of text starting with a timestamp. The exit status
+of the probe is ignored.
=head1 CONFIG FILE
=head2 location
- A config file can be specified with the -c option.
- If -c is not used, the program looks for a config file in
- -- ./mirmon.conf
- -- $HOME/.mirmon.conf
- -- /etc/mirmon.conf
+A config file can be specified with the -c option.
+If -c is not used, the program looks for a config file in
+
+=over
+
+=item * B<./mirmon.conf>
+
+=item * B<$HOME/.mirmon.conf>
+
+=item * B</etc/mirmon.conf>
+
+=back
=head2 syntax
- A config file looks like this :
-
- +--------------------------------------------------
- |# lines that start with '#' are comment
- |# blank lines are ignored too
- |# tabs are replaced by a space
- |
- |# the config entries are 'key' and 'value' pairs
- |# a 'key' begins in column 1
- |# the 'value' is the rest of the line
- |somekey A_val B_val ...
- |otherkey X_val Y_val ...
- |
- |# indented lines are glued
- |# the next three lines mean 'somekey part1 part2 part3'
- |somekey part1
- | part2
- | part3
- |
- |# lines starting with a '+' are concatenated
- |# the next three lines mean 'somekey part1part2part3'
- |somekey part1
- |+ part2
- |+ part3
- |
- |# lines starting with a '.' are glued too
- |# don't use a '.' on a line by itself
- |# 'somekey' gets the value "part1\n part2\n part3"
- |somekey part1
- |. part2
- |. part3
- +--------------------------------------------------
+A config file looks like this :
+
+ +--------------------------------------------------
+ |# lines that start with '#' are comment
+ |# blank lines are ignored too
+ |# tabs are replaced by a space
+ |
+ |# the config entries are 'key' and 'value' pairs
+ |# a 'key' begins in column 1
+ |# the 'value' is the rest of the line
+ |somekey A_val B_val ...
+ |otherkey X_val Y_val ...
+ |
+ |# indented lines are glued
+ |# the next three lines mean 'somekey part1 part2 part3'
+ |somekey part1
+ | part2
+ | part3
+ |
+ |# lines starting with a '+' are concatenated
+ |# the next three lines mean 'somekey part1part2part3'
+ |somekey part1
+ |+ part2
+ |+ part3
+ |
+ |# lines starting with a '.' are glued too
+ |# don't use a '.' on a line by itself
+ |# 'somekey' gets the value "part1\n part2\n part3"
+ |somekey part1
+ |. part2
+ |. part3
+ +--------------------------------------------------
=head1 CONFIG FILE : required entries
-=head2 project_name <name>
+=head2 project_name I<name>
+
+Specify a short plaintext name for the project.
+
+ project_name Apache
+ project_name CTAN
- Specify a short plaintext name for the project.
+=head2 project_url I<url>
- project_name Apache
- project_name CTAN
+Specify an url pointing to the 'home' of the project.
-=head2 project_url <url>
+ project_url http://www.apache.org/
- Specify an url pointing to the 'home' of the project.
+=head2 mirror_list I<file-name>
- project_url http://www.apache.org/
+Specify the file containing the mirrors to probe.
-=head2 mirror_list <file name>
+ mirror_list /path/to/mirror-list
- Specify the file containing the mirrors to probe.
- Two formats are supported :
+If your mirror list is generated by a program, use
- -- plain : lines like
+ mirror_list /path/to/program arg1 ... |
- us http://www.tux.org/
- nl http://apache.cs.uu.nl/dist/
+Two formats are supported :
- -- apache : lines like those in the apache mirrors.list
+=over
+
+=item * plain : lines like
+
+ us http://www.tux.org/ [email] ...
+ nl http://apache.cs.uu.nl/dist/ [email] ...
+ nl rsync://archive.cs.uu.nl/apache-dist/ [email] ...
+
+=item * apache : lines like those in the apache mirrors.list
+
+ ftp us ftp://ftp.tux.org/pub/net/apache/dist/ user@tux.org ...
+ http nl http://apache.cs.uu.nl/dist/ user@cs.uu.nl ...
+
+=back
+
+Note that in style 'plain' the third item is reserved for an
+optional email address : the site's contact address.
- ftp us ftp://ftp.tux.org/pub/net/apache/dist/ user@tux.org
- http nl http://apache.cs.uu.nl/dist/ user@cs.uu.nl
+Specify the required format with 'list_style' (see below).
+The default style is 'plain'.
- Specify the required format with 'list_style' (see below).
- The default style is 'plain'.
+=head2 web_page I<file-name>
- 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.
+Specify where the html report page is written.
-=head2 web_page <file name>
+=head2 icons I<directory-name>
- Specify where the html report page is written.
+Specify the directory where the icons can be found,
+relative to the I<web_page>, or relative to the
+DOCUMENTROOT of the web server.
-=head2 icons <directory name>
+If/when the I<web_page> lives in directory C<.../mirmon/> and
+the icons live in directory C<.../mirmon/icons/>,
+specify
- Specify the directory where the icons can be found.
+ icons icons
-=head2 probe <program + arguments>
+If/when the icons live in C</path/to/DOCUMENTROOT/icons/mirmon/>, specify
- Specify the program+args to probe the mirrors. Example:
+ icons /icons/mirmon
- probe /sw/bin/wget -q -O - -T %TIMEOUT% -t 1 %URL%TIME
+=head2 probe I<program + arguments>
- Before the program is started, %TIMEOUT% and %URL% are
- substituted with the proper timeout and url values.
+Specify the program+args to probe the mirrors. Example:
- Here it is assumed that each hour the root server writes
- a timestamp in /path/to/archive/TIME, for instance with
- a crontab entry like
-
- 42 * * * * perl -e 'printf "%s\n", time' > /path/to/archive/TIME
+ probe /usr/bin/wget -q -O - -T %TIMEOUT% -t 1 %URL%TIME
- Mirmon reads one line of output from the probe and interprets
- the first word on that line as a timestamp ; for example :
+Before the program is started, %TIMEOUT% and %URL% are
+substituted with the proper timeout and url values.
- 1043625600
- 1043625600 Mon Jan 27 00:00:00 2003
- 1043625600 www.apache.org Mon Jan 27 00:00:00 2003
+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
-=head2 state <file name>
+ 42 * * * * perl -e 'printf "%s\n", time' > /path/to/archive/TIME
- 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).
+Mirmon reads one line of output from the probe and interprets
+the first word on that line as a timestamp ; for example :
-=head2 countries <file name>
+ 1043625600
+ 1043625600 Mon Jan 27 00:00:00 2003
+ 1043625600 www.apache.org Mon Jan 27 00:00:00 2003
- Specify the file containing the country codes;
- The file should contain lines like
+Mirmon is distributed with a program C<probe> that handles
+ftp, http and rsync urls.
- us - united states
- nl - netherlands
+=head2 state I<file-name>
- The mirmon package contains a recent ISO list.
+Specify where the file containing the state is written.
+
+The program reads this file on startup and writes the
+file when mirrors are probed (-get is specified).
+
+=head2 countries I<file-name>
+
+Specify the file containing the country codes;
+The file should contain lines like
+
+ us - united states
+ nl - netherlands
+
+The mirmon package contains a recent ISO list.
=head1 CONFIG FILE : optional entries
-=head2 max_probes <number>
+=head2 max_probes I<number>
+
+Optionally specify the number of parallel probes (default 25).
+
+=head2 timeout I<seconds>
+
+Optionally specify the timeout for the probes (default 300).
- Optionally specify the number of parallel probes (default 25).
+After the last probe is started, the program waits for
+<timeout> + 10 seconds, cleans up and exits.
-=head2 timeout <seconds>
+=head2 project_logo I<logo>
- 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.
+Optionally specify (the SRC of the IMG of) a logo to be placed
+top right on the page.
-=head2 project_logo <logo>
+ project_logo /icons/apache.gif
+ project_logo http://www.apache.org/icons/...
- Optionally specify (the SRC of the IMG of) a logo to be placed
- top right on the page.
+=head2 htm_head I<html>
- project_logo /icons/apache.gif
- project_logo http://www.apache.org/icons/...
+Optionally specify some HTML to be placed before </HEAD>.
-=head2 htm_foot <html>
+ htm_head
+ <link REL=StyleSheet HREF="/style.css" TYPE="text/css">
- Optionally specify HTML to be placed near the bottom of the page.
+=head2 htm_top I<html>
- htm_foot
- <HR>
- <A HREF="..."><IMG SRC="..." BORDER=0></A>
- <HR>
+Optionally specify some HTML to be placed near the top of the page.
-=head2 htm_top <html>
+ htm_top testing 1, 2, 3
- Optionally specify some HTML to be placed near the top of the page.
- The supplied text is placed between <P> and </P>.
+=head2 htm_foot I<html>
- htm_top testing 1, 2, 3
+Optionally specify HTML to be placed near the bottom of the page.
+
+ htm_foot
+ <HR>
+ <A HREF="..."><IMG SRC="..." BORDER=0></A>
+ <HR>
=head2 put_histo top|bottom|nowhere
- Optionally specify where the age histogram must be placed.
- The default is 'top'.
+Optionally specify where the age histogram must be placed.
+The default is 'top'.
+
+=head2 min_poll I<time-spec>
+
+For 'min_poll' see next item. A I<time-spec> is a number followed by
+a unit 's' (seconds), or 'm' (minutes), or 'h' (hours), or 'd' (days).
+For example '3d' (three days) or '36h' (36 hours).
+
+=head2 max_poll I<time-spec>
+
+Optionally specify the maximum probe interval. When the program is
+called with option '-get update', all sites are probed which are :
+
+=over 4
+
+=item * new
+
+the site appears in the list, but there is no known state
-=head2 min_poll <time spec>
+=item * bad
- 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).
+the last probe of the site was unsuccessful
-=head2 max_poll <time spec>
+=item * old
- 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.
+the last probe was more than 'max_poll' ago.
- So, if you specify
+=back
+
+Sites are not probed if the last probe was less than 'min_poll' ago.
+So, if you specify
+
+ min_poll 4h
+ max_poll 12h
+
+the 'reachable' sites are probed twice daily and the 'unreachable'
+sites are probed at most six times a day.
- min_poll 4h
- max_poll 12h
+The default 'min_poll' is '1h' (1 hour).
+The default 'max_poll' is '4h' (4 hours).
- the 'reachable' sites are probed twice daily and the 'unreachable'
- sites are probed at most six times a day.
+=head2 min_sync I<time-spec>
- The default 'min_poll' is '1h' (1 hour).
- The default 'max_poll' is '4h' (4 hours).
+Optionally specify how often the mirrors are required to make an update.
-=head2 min_sync <time spec>
+The default 'min_sync' is '1d' (1 day).
- Optionally specify how often the mirrors are required to
- make an update. The default 'min_sync' is '1d' (1 day).
+=head2 max_sync I<time-spec>
-=head2 max_sync <time spec>
+Optionally specify the maximum allowable sync interval.
- Optionally specify the maximum allowable sync interval.
- Sites exceeding the limit will be considered 'old'.
- The default 'max_sync' is '2d' (2 days).
+Sites exceeding the limit will be considered 'old'.
+The default 'max_sync' is '2d' (2 days).
=head2 no_randomize
- With a low probablility, mirmon probes mirrors that would
- otherwise not be probed. In the long run, this balances
- the number of mirror probes over the hourly mirmon runs.
- Specifically, if there are N mirrors in the list and some
- mirmon run would probe K sites, on average (N-K)/N extra
- sites will be probed.
+To balance the probe load over the hourly mirmon runs,
+mirmon may probe a few extra randomly choosen mirrors :
+
+=over 4
+
+=item * only if the the number of mirrors to probe is below average,
+
+=item * at most 2% of the mirrors
+
+=back
+
+If you don't want this behaviour, use B<no_randomize>.
+
+=head2 no_add_slash
+
+If the url part of a line in the mirror_list doesn't end
+in a slash ('/'), mirmon adds a slash and issues a warning
+unless it is in quiet mode.
- If you don't want this behaviour, use 'no_randomize'.
+If you don't want this behaviour, use B<no_add_slash>.
=head2 list_style plain|apache
- Optionally specify the format ('plain' or 'apache') of the
- mirror-list. See the description of 'mirror_list' above.
- The default list_style is 'plain'.
+Optionally specify the format ('plain' or 'apache') of the mirror-list.
-=head2 site_url <site> <url>
+See the description of 'mirror_list' above.
+The default list_style is 'plain'.
- Optionally specify a substitute url for a site. When access to
- a site is restricted (in Australia, for instance), another
- (sometimes secret) url can be used to probe the site. The <site>
- of an url is the part between '://' and the first '/'.
+=head2 site_url I<site> I<url>
-=head2 env <key> <value>
+Optionally specify a substitute url for a site.
- Optionally specify an environment variable.
+When access to a site is restricted (in Australia, for instance),
+another (sometimes secret) url can be used to probe the site.
+The <site> of an url is the part between '://' and the first '/'.
-=head2 include <file name>
+=head2 env I<key> I<value>
- Optionally specify a file to include. The specified file is processed
- 'in situ'. After the specified file is read and processed, config
- processing is resumed in the file where the 'include' was encountered.
- The 'include' depth is unlimited. However, it is a fatal error to
- include a file twice under the same name.
+Optionally specify an environment variable.
+
+=head2 include I<file-name>
+
+Optionally specify a file to include.
+
+The specified file is processed 'in situ'. After the specified file is
+read and processed, config processing is resumed in the file where the
+C<include> was encountered.
+The include depth is unlimited. However, it is a fatal error to
+include a file twice under the same name.
=head2 show
- When the config processor encounters the 'show' command, it
- dumps the content of the current config to standout, if option
- -v is specified. This is intented for debugging.
+When the config processor encounters the 'show' command, it
+dumps the content of the current config to standout, if option
+C<-v> is specified. This is intented for debugging.
=head2 exit
- When the config processor encounters the 'exit' command, it
- terminates the program. This is intented for debugging.
+When the config processor encounters the 'exit' command, it
+terminates the program. This is intented for debugging.
=head1 STATE FILE FORMAT
- The state file consists of lines; one line per site.
- Each line consists of white space separated fields.
- The seven fields are :
+The state file consists of lines; one line per site.
+Each line consists of white space separated fields.
+The seven fields are :
+
+=over 4
-=head2 field 1 : url
+=item * field 1 : url
- The url as given in the mirror list.
+The url as given in the mirror list.
-=head2 field 2 : age
+=item * field 2 : age
- The age of the site, or 'undef' if no probe was ever successful.
+The mirror's timestamp found by the last succesful probe,
+or 'undef' if no probe was ever successful.
-=head2 field 3 : status last probe
+=item * field 3 : status last probe
- The status of the last probe.
+The status of the last probe, or 'undef' if the mirror was never probed.
-=head2 field 4 : time last succesful probe
+=item * field 4 : time last succesful probe
- The timestamp of the last succesful probe or 'undef'
- if the site was never successfully probed.
+The timestamp of the last succesful probe or 'undef'
+if the mirror was never successfully probed.
-=head2 field 5 : probe history
+=item * field 5 : probe history
- The probe history is a list of 's' (for success) and 'f' (for failure)
- characters indicating the result of the probe. New results are appended
- whenever the site is probed.
+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.
-=head2 field 6 : state history
+=item * field 6 : state history
- The state history consists of a timestamp, a '-' char, and a list of
- chars indicating a past status: 's' (fresh), 'b' (oldish), 'f' (old)
- 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.
+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).
-=head2 field 7 : last probe
+=item * field 7 : last probe
- The timestamp of the last probe.
+The timestamp of the last probe, or 'undef' if the mirror was never probed.
+
+=back
=head1 INSTALLATION
-=over
+=head2 general
+
+=over 4
+
+=item * Note: The (empty) state file must exist before mirmon runs.
+
+=item * The mirmon repository is here :
+
+ https://subversion.cs.uu.nl/repos/staff.henkp.mirmon/trunk/
+
+=item * The mirmon tarball is here :
+
+ http://people.cs.uu.nl/henkp/mirmon/mirmon.tar.gz
+
+=back
+
+=head2 installation suggestions
+
+To install and configure mirmon, take the following steps :
+
+=over 2
+
+=item * First, make the webdir :
+
+ cd DOCUMENTROOT
+ mkdir mirmon
+
+For I<DOCUMENTROOT>, substitute the full pathname
+of the document root of your webserver.
+
+=item * Check out the mirmon repository :
+
+ cd /usr/local/src
+ svn checkout REPO mirmon
+
+where
+
+ REPO = https://subversion.cs.uu.nl/repos/staff.henkp.mirmon/trunk/
+
+or download the package and unpack it.
+
+=item * Chdir to directory mirmon :
+
+ cd mirmon
-=item *
+=item * Create the (empty) state file :
- The '#!' path for perl is probably wrong.
+ touch state.txt
+
+=item * Install the icons in the webdir :
+
+ mkdir DOCUMENTROOT/mirmon/icons
+ cp icons/* DOCUMENTROOT/mirmon/icons
+
+=item * Create a mirror list C<mirror_list> ;
+
+Use your favorite editor, or genererate the list from an
+existing database.
+
+ nl http://archive.cs.uu.nl/your-project/ contact@cs.uu.nl
+ uk http://mirrors.this.org/your-project/ mirrors@this.org
+ us http://mirrors.that.org/your-project/ mirrors@that.org
+
+The email addresses are optional.
+
+=item * Create a mirmon config file C<mirmon.conf> with your favorite editor.
+
+ # lines must start in the first column ; no leading white space
+ project_name ....
+ project_url ....
+ mirror_list mirror_list
+ state state.txt
+ countries countries.list
+ web_page DOCUMENTROOT/mirmon/index.html
+ icons /mirmon/icons
+ probe /usr/bin/wget -q -O - -T %TIMEOUT% -t 1 %URL%TIME
+
+This assumes the project's timestamp is in file C<TIME>.
+
+=item * If you have rsync urls, change the probe line to :
+
+ probe perl /usr/local/src/mirmon/probe -t %TIMEOUT% %URL%TIME
+
+=item * Run mirmon :
+
+ perl mirmon -v -get all
+
+The mirmon report should now be in 'DOCUMENTROOT/mirmon/index.html'
+
+ http://www.your.project.org/mirmon/
+
+=item * If/when, at a later date, you want to upgrade mirmon :
+
+ cd /usr/local/src/mirmon
+ svn status -u
+ svn up
=back
+=head1 SEE ALSO
+
+=begin html
+
+<A HREF="mirmon.pm.html">mirmon.pm(3)</A>
+
+=end html
+
+=begin man
+
+mirmon.pm(3)
+
+=end man
+
=head1 AUTHOR
=begin html
-<BLOCKQUOTE>
- © 2003
- <A HREF="http://www.cs.uu.nl/staff/henkp.html">Henk P. Penning</A>,
+ © 2003-2010
+ <A HREF="http://people.cs.uu.nl/henkp/">Henk P. Penning</A>,
<A HREF="http://www.cs.uu.nl/">Computer Science Department</A>,
<A HREF="http://www.uu.nl/">Utrecht University</A>
<BR>
- $Id: mirmon,v 1.36 2004/12/28 17:54:10 henkp Exp $
-</BLOCKQUOTE>
+ mirmon-2.3 - Wed Mar 17 09:29:11 2010 ; henkp
=end html
+=begin man
+
+ (c) 2003-2010 Henk P. Penning
+ Computer Science Department, Utrecht University
+ http://people.cs.uu.nl/henkp/ -- penning@cs.uu.nl
+ mirmon-2.3 - Wed Mar 17 09:29:11 2010 ; henkp
+
+=end man
+
=begin text
- (c) 2003 Henk P. Penning, Computer Science Department, Utrecht University
- http://www.cs.uu.nl/staff/henkp.html -- penning@cs.uu.nl
+ (c) 2003-2010 Henk P. Penning
+ Computer Science Department, Utrecht University
+ http://people.cs.uu.nl/henkp/ -- penning@cs.uu.nl
+ mirmon-2.3 - Wed Mar 17 09:29:11 2010 ; henkp
=end text
=cut
-
git://git.exim.org / mirror-monitor.git / blobdiff