From 9513c275c8f3b482625bb8d38aecb57d65337987 Mon Sep 17 00:00:00 2001 From: Nigel Metheringham Date: Tue, 22 Jun 2010 21:05:09 +0100 Subject: [PATCH] Stupid idiot did not get prog update right --- mirmon/mirmon | 3421 ++++++++++++++++++++++++++++++++----------------- 1 file changed, 2242 insertions(+), 1179 deletions(-) diff --git a/mirmon/mirmon b/mirmon/mirmon index edaf65f..27175e3 100755 --- a/mirmon/mirmon +++ b/mirmon/mirmon @@ -1,9 +1,8 @@ -#!/usr/bin/perl -w -# +#! /usr/bin/perl -w + # Copyright (c) 2003 Henk Penning, all rights reserved. # penning@cs.uu.nl, http://www.cs.uu.nl/staff/henkp.html -# Version 1.1 was donated to the Apache Software Foundation 2003 Jan 28 -# $Id: mirmon,v 1.37 2006/12/04 15:16:11 henkp Exp henkp $ +# Version 1.1 was donated to the Apache Software Foundation 2003 Jan 28. # Permission is hereby granted, free of charge, to any person obtaining a # copy of this software and associated documentation files (the "Software"), # to deal in the Software without restriction, including without limitation @@ -22,830 +21,579 @@ # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER # DEALINGS IN THE SOFTWARE. # -# Thanks to Klaus Heinz for sugestions ao htm_head -my $PRG = 'mirmon'; -my $VER = '$Id: mirmon,v 1.37 2006/12/04 15:16:11 henkp Exp henkp $'; -use strict; -use IO::Pipe; -use IO::Select; -use Net::hostent; -my $DEF_CNF = "/etc/$PRG.conf"; -my %CNF = qw( timeout 300 - max_probes 25 - min_poll 1h - max_poll 4h - min_sync 1d - max_sync 2d - list_style plain - put_histo top - randomize 1 -); -my @REQ_KEYS = qw( web_page state countries mirror_list probe - project_name project_url icons -); -my @OPT_KEYS = - qw( project_logo min_poll min_sync max_sync list_style htm_top htm_foot - htm_head put_histo -); -my %CNF_KEYS; -for ( @REQ_KEYS, @OPT_KEYS, keys %CNF ) { $CNF_KEYS{$_}++; } -my $TIM_PAT = '^(\d+)([smhd])$'; -my @LIST_STYLE = qw(plain apache); -my @GET_OPTS = qw(all update); -my @PUT_HGRAM = qw(top bottom nowhere); -my $HIST = 14; -my %APA_TYPES = (); -for (qw(backup ftp http)) { $APA_TYPES{$_}++; } -my $prog = substr( $0, rindex( $0, '/' ) + 1 ); -my $Usage = <= 0; -my %WGT; -my $GET = IO::Select->new(); -my %URL; -my %RES; -my %OLD; -my %LST; -my %CCS; -my %HREF; -# -sub exp_date { - my @day = qw(Sun Mon Tue Wed Thu Fri Sat); - my @mon = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); - my @gmt = gmtime time + 3600; - sprintf "%s, %02d %s %4d %02d:%02d:%02d GMT", $day[ $gmt[6] ], $gmt[3], - $mon[ $gmt[4] ], $gmt[5] + 1900, @gmt[ 2, 1, 0 ]; -} -sub find_conf { - return $opt{c} if $opt{c}; - my $HOME = ( getpwuid $< )[7] or Error "can get homedir '$<' ($!)"; - my @LIST = ( "$PRG.conf", "$HOME/.$PRG.conf", $DEF_CNF ); - for my $conf (@LIST) { return $conf if -f $conf; } - Error sprintf "can't find a config file :\n %s", join "\n ", @LIST; -} -sub show_conf { - print "vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv\n"; - for my $key ( sort keys %CNF ) { - next if $key =~ m/^_/; - print "show_conf : $key = '$CNF{$key}'\n"; - } - for my $key ( sort keys %HREF ) { - printf "show_conf : for site '%s' use instead\n '%s'\n", $key, - $HREF{$key} - if $opt{v}; - } - printf "show_conf : included '%s'\n", join "', '", @{ $CNF{_include} }; - print "^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n"; -} -sub get_conf; -sub get_conf { - my $FILE = shift; - if ( grep $_ eq $FILE, @{ $CNF{_include} } ) { - Error "already included : '$FILE'"; - } - else { push @{ $CNF{_include} }, $FILE; } - open FILE, $FILE or Error "can't open '$FILE' ($!)"; - my $CONF = join "\n", grep /./, ; - close FILE; - $CONF =~ s/\t/ /g; # replace tabs - $CONF =~ s/^[+ ]+//; # delete leading space, plus - $CONF =~ s/\n\n\s+/ /g; # glue continuation lines - $CONF =~ s/\n\n\+\s+//g; # glue concatenation lines - $CONF =~ s/\n\n\./\n/g; # glue concatenation lines - chop $CONF; - print "--$CONF--\n" if $opt{d}; - for ( grep !/^#/, split /\n\n/, $CONF ) { - my ( $key, $val ) = split ' ', $_, 2; - $val = '' unless defined $val; - print "conf '$FILE' : key '$key', val '$val'\n" if $opt{d}; - if ( exists $CNF_KEYS{$key} ) { $CNF{$key} = $val; } - elsif ( $key eq 'site_url' ) { - my ( $site, $url ) = split ' ', $val; - $url .= '/' unless $url =~ m!/$!; - $HREF{ lc $site } = $url; - printf "config : for site '%s' use instead\n '%s'\n", $site, $url - if $opt{v}; - } - elsif ( $key eq 'env' ) { - my ( $x, $y ) = split ' ', $val; - $ENV{$x} = $y; - printf "config : setenv '%s'\n '%s'\n", $x, $y if $opt{v}; - } - elsif ( $key eq 'no_randomize' ) { $CNF{randomize} = 0; } - elsif ( $key eq 'include' ) { get_conf $val ; } - elsif ( $key eq 'show' ) { show_conf unless $opt{q}; } - elsif ( $key eq 'exit' ) { Error 'exit per config directive'; } - elsif ( $key eq 'max_age' ) { $CNF{max_sync} = $val; } - else { - show_conf; - Error "unknown keyword '$key' (value '$val')"; - } - } -} -sub get_conf_opt { - my $err = ''; - get_conf find_conf; - $CNF{timeout} = $opt{t} if $opt{t}; - for my $key (@REQ_KEYS) { - unless ( exists $CNF{$key} ) { - $err .= "$prog error: missing config for '$key'\n"; - } - } - for my $key (qw(min_poll max_poll max_sync min_sync)) { - my $max = $CNF{$key}; - unless ( $max =~ /$TIM_PAT/o ) { - $err .= "$prog error: $key ($max) doesn't match /$TIM_PAT/\n"; - } - } - unless ( grep $CNF{list_style} eq $_, @LIST_STYLE ) { - $err .= sprintf "%s : error: unknown 'list_style' '%s'\n", $prog, - $CNF{list_style}; - } - unless ( grep $CNF{put_histo} eq $_, @PUT_HGRAM ) { - $err .= sprintf "%s : error: unknown 'put_histo' '%s'\n", $prog, - $CNF{put_histo}; - } - if ( $opt{get} and not grep $opt{get} eq $_, @GET_OPTS ) { - $err .= sprintf "%s : error: unknown 'get option' '%s'\n", $prog, - $opt{get}; - } - Error $err if $err; - $opt{q} = 0 if $opt{v}; -} -sub tim_to_s { - my $tim = shift; - my %tab = ( 's' => 1, 'm' => 60, 'h' => 60 * 60, 'd' => 60 * 60 * 24 ); - Error "wrong time '$tim'" unless $tim =~ /$TIM_PAT/o; - my $m = $1; - my $u = $2; - return $m * $tab{$u}; -} -sub aprx_eq { my ( $t1, $t2 ) = @_; abs( $t1 - $t2 ) < 60; } -sub aprx_ge { my ( $t1, $t2 ) = @_; $t1 > $t2 or aprx_eq $t1, $t2; } -sub aprx_le { my ( $t1, $t2 ) = @_; $t1 < $t2 or aprx_eq $t1, $t2; } -sub aprx_gt { my ( $t1, $t2 ) = @_; $t1 > $t2 and not aprx_eq $t1, $t2; } -sub aprx_lt { my ( $t1, $t2 ) = @_; $t1 < $t2 and not aprx_eq $t1, $t2; } -sub pr_interval { - my $s = shift; - my ( $magn, $unit ); - my $mins = $s / 60; - my $m = int( $mins + 0.5 ); - my $hours = $s / ( 60 * 60 ); - my $h = int( $hours + 0.5 ); - if ( $s < 50 ) { $magn = $s; $unit = 'second'; } - elsif ( $m < 50 ) { $magn = $m; $unit = 'minute'; } - elsif ( $h < 36 ) { $magn = $h; $unit = 'hour'; } - else { $magn = sprintf "%.1f", $hours / 24; $unit = 'day'; } - $unit .= 's' unless $magn == 1; - return "$magn $unit"; -} -sub max_age1 { - ( tim_to_s $CNF {min_sync} ) + ( tim_to_s $CNF {max_poll} ); -} -sub max_age2 { - ( tim_to_s $CNF {max_sync} ) + ( tim_to_s $CNF {max_poll} ); -} -sub max_vrfy { - ( tim_to_s $CNF {min_poll} ) + ( tim_to_s $CNF {max_poll} ); -} -sub age_code { - my $time = shift; - return 'z' unless $time =~ /^\d+$/; - return ( - ( aprx_ge( $time, $^T - max_age1 ) ) - ? 's' - : ( aprx_ge( $time, $^T - max_age2 ) ? 'b' : 'f' ) - ); -} -sub err { - my $url = shift; - my $stat = shift; - printf "*** %-10s %s\n", $stat, $url unless $opt{q}; - my ( $time, $vrfy, $hstp, $hsts ); - if ( exists $OLD{$url} ) { - $time = $OLD{$url}[0]; - $vrfy = $OLD{$url}[2]; - $hstp = substr $OLD{$url}[3], 1 - $HIST; - $hsts = $OLD{$url}[4]; - } - else { - $time = 'undef'; - $vrfy = 'undef'; - $hstp = ''; - $hsts = ''; - } - $RES{$url} = [ $time, $stat, $vrfy, $hstp . 'f', $hsts, $^T ]; -} -sub res { - my $url = shift; - my $time = shift; - my $stat = shift; - my $hstp = ( - exists $OLD{$url} - ? substr( $OLD{$url}[3], 1 - $HIST ) - : '' - ); - my $hsts = ( exists $OLD{$url} ? $OLD{$url}[4] : '' ); - printf "result %d %s\n", $time, $url if $opt{v}; - $RES{$url} = [ $time, $stat, $^T, $hstp . 's', $hsts, $^T ]; -} -sub get_state { - my $STT = shift; - open STT, $STT or Error "can't open '$STT' ($!)"; - while () { - chop; - my ( $url, $time, $stat, $vrfy, $hstp, $hsts, $lprb ) = split ' '; - $stat =~ s/_/ /g; - $hstp = '' unless defined $hstp; - $hsts = '' unless defined $hsts; - $hsts = '' if $hsts eq 'undef'; - $lprb = 'undef' unless defined $lprb; - $OLD{$url} = [ $time, $stat, $vrfy, $hstp, $hsts, $lprb ]; - } - close STT; -} -sub check_hist { - my $time = shift; - my $hsts = shift; - printf "check_hist: last '$time' hsts '$hsts'\n" if $opt{d}; - my $res = $hsts; - my ( $stmp, $hist ); - if ( $hsts eq '' ) { $stmp = 0; $hist = ''; } - else { ( $stmp, $hist ) = split '-', $hsts; } - if ( aprx_le $stmp, $^T - tim_to_s '1d' ) { - $res = sprintf "%s-%s%s", $^T, substr( $hist, 1 - $HIST ), - age_code($time); - } - return $res; -} -sub put_state { - my $STT = shift; - my $TMP = "$STT.tmp"; - open TMP, ">$TMP" or Error "can't write '$TMP' ($!)"; - for my $url ( sort keys %RES ) { - $RES{$url}[4] = check_hist $RES {$url}[0], $RES{$url}[4]; - my @OUT = @{ $RES{$url} }; - $OUT[1] =~ s/\s/_/g; - printf TMP "%s %s\n", $url, join ' ', @OUT - or Error "can't print to $TMP ($!)"; - } - close TMP; - if ( -z $TMP ) { Warn "wrote empty state file; keeping previous version"; } - else { rename $TMP, $STT or Error "can't rename '$TMP', '$STT' ($!)"; } -} -sub get_ccs { - my $CCS = shift; - open CCS, $CCS or Error "can't open '$CCS' ($!)"; - while () { - chop; - next if /^#/; - my ( $code, $dash, $reg ) = split ' ', $_, 3; - $CCS{ lc $code } = lc $reg; - } - close CCS; -} -sub type_site { - my $url = shift; - my ( $type, $site, $home ); - if ( $url =~ m!^(ftp|http)://([^/:]+)(:\d+)?/! ) { - $type = $1; - $site = $2; - $home = $&; - } - return $type, $site, $home; -} -sub type { my ( $t, $s, $h ) = type_site $_[0]; $t; } -sub site { my ( $t, $s, $h ) = type_site $_[0]; $s; } -sub home { my ( $t, $s, $h ) = type_site $_[0]; $h; } -sub get_list { - my $LST = shift; - my ( $reg, $url ); - open LST, $LST or Error "can't open '$LST' ($!)"; - while () { - chop; - next if /^#/; - next if /^\s*$/; - if ( $CNF{list_style} eq 'plain' ) { - ( $reg, $url ) = split ' '; - unless ( $url =~ m!/$! ) { - print "*** mirmon appended '/' to $url\n" unless $opt{q}; - $url .= '/'; - } - } - elsif ( $CNF{list_style} eq 'apache' ) { - my $apache_type; - ( $apache_type, $reg, $url ) = split ' '; - unless ( defined $APA_TYPES{$apache_type} ) { - print "*** strange type : $apache_type\n" unless $opt{q}; - next; - } - unless ( $url =~ m!/$! ) { - print "*** missing '/' in $url\n" unless $opt{q}; - $url .= '/'; - } - } - my $site = site $url ; - my $type = type $url ; - unless ( defined $site ) { - print "*** strange url : '$url'\n" unless $opt{q}; - next; - } - $LST{$url} = [ $type, $site, $reg ]; - } -} -sub url { sprintf '%s', $_[0], $_[1]; } -sub nam { sprintf '%s', $_[0], $_[1]; } -sub SMA { sprintf "%s", $_[0]; } -sub BLD { sprintf "%s", $_[0]; } -sub NSS { sprintf SMA('%s site%s'), $_[0], ( $_[0] == 1 ? '' : 's' ); } -sub TAB { sprintf "%s
", $_[0]; } -sub TR { sprintf "%s\n", $_[0]; } -sub TH { sprintf "%s\n", $_[0]; } -sub TD { sprintf "%s\n", $_[0]; } -sub TDr { sprintf "%s\n", $_[0]; } -sub RED { sprintf "%s", $_[0]; } -sub GRN { sprintf '%s', $_[0]; } -sub htmlquote { - my $x = shift; - $x =~ s/&/&/g; - $x =~ s//>/g; - return $x; -} -sub diff { - my $time = shift; - my $max = shift; - my $res; - if ( $time == $^T ) { $res = BLD 'renewed'; } - else { - $res = pr_interval $^T - $time; - $res = BLD RED $res if aprx_lt $time, $max; - } - return $res; -} -sub img_sf_cnt { - sprintf '', $CNF{icons}, $_[0], - $_[1]; -} -sub img_sf { img_sf_cnt $_[0], 1; } -sub show_hist { - my $hst = shift; - return '' unless $hst =~ m/^[sbfz]+$/; - if ( length $hst == $HIST and $hst =~ /^(s*b)s*$/ ) { - return img_sf_cnt 'sb', length $1; - } - elsif ( length $hst == $HIST and $hst =~ /^(s*f)s*$/ ) { - return img_sf_cnt 'sf', length $1; - } - elsif ( length $hst == $HIST and $hst =~ /^(s*b)fs*$/ ) { - return img_sf_cnt 'sbf', length $1; - } - my $res = ''; - my $cnt = 1; - my $prf = substr $hst, 0, 1; - $hst = substr $hst, 1; - while ( $hst ne '' ) { - if ( substr( $prf, 0, 1 ) eq substr( $hst, 0, 1 ) ) { - $cnt++; - $hst = substr $hst, 1; - } - else { - $res .= img_sf_cnt $prf, $cnt; - $prf = substr $hst, 0, 1; - $hst = substr $hst, 1; - $cnt = 1; - } - } - $res .= img_sf_cnt $prf, $cnt if $cnt; - return $res; -} -sub show_hist_age { - my $hsts = shift; - my $time = shift; - return '' if $hsts eq ''; - my ( $t, $h ) = split '-', $hsts; - if ( aprx_lt $t, $^T ) { $h .= age_code $time ; } - return show_hist substr $h, -$HIST; -} -sub gen_histogram_probes { - my ( $time, $stat, $vrfy, $hstp, $hsts, $lprb ); - my %tab = (); - my %bad = (); - my $res = ''; - my $s_cnt = 0; - my $f_cnt = 0; - my $hr_min; - my $hr_max; - return '' unless scalar keys %RES; - for my $url ( keys %RES ) { - ( $time, $stat, $vrfy, $hstp, $hsts, $lprb ) = @{ $RES{$url} }; - my $hr = int( ( $^T - $lprb ) / 3600 + 0.5 ); - $hr_min = $hr if !defined $hr_min or $hr < $hr_min; - $hr_max = $hr if !defined $hr_max or $hr > $hr_max; - if ( $stat eq 'ok' ) { $tab{$hr}++; $s_cnt++; } - else { $bad{$hr}++; $f_cnt++; } - } - $res = TR( - TH('hours ago') - . TH('succ') - . TH('fail') - . TH sprintf( '%s %s, %s %s', - $s_cnt, GRN('successful'), $f_cnt, RED('failed') ) - ); - my $max = 0; - for my $x ( keys %tab ) { - my $tot = $tab{$x} + ( $bad{$x} || 0 ); - $max = $tot if $max < $tot; - } - return "
\nnothing yet\n
\n" unless $max; - for my $hr ( $hr_min .. $hr_max ) { - my $x = $tab{$hr} || 0; - my $y = $bad{$hr} || 0; - my $n = int( $x / $max * $HIST ); - my $b = int( $y / $max * $HIST ); - $res .= TR( - TDr($hr) - . TDr($x) - . TDr($y) - . TD( - ( $n ? img_sf_cnt( 's', $n ) : '' ) - . ( $b ? img_sf_cnt( 'f', $b ) : '' ) - . ( ( $n + $b ) ? '' : ' ' ) +# Thanks to Klaus Heinz for sugestions ao htm_head ; +# Peter Pöml for MirrorBrain support ; Jeremy Olexa, Karl Berry, Roland +# Pelzer for suggestions regarding rsync support. + +use strict ; + +our $PRG = 'mirmon' ; +our $VER = "2.3" ; + +our $DEF_TIMEOUT = 300 ; +our $HIST = 14 ; +our $TIM_PAT = '^(\d+)([smhd])$' ; +our %APA_TYPES = () ; for ( qw(backup ftp http) ) { $APA_TYPES { $_ } ++ ; } +our %GET_OPTS = () ; for ( qw(all update) ) { $GET_OPTS { $_ } ++ ; } +our $HIST_DELTA = 24 * 60 * 60 ; +our $APRX_DELTA = 60 ; +our $HOME = 'http://www.cs.uu.nl/people/henkp/mirmon/' ; + +package Base ; ##################################################### + +use base 'Exporter' ; + +our ( @ISA, @EXPORT ) ; +BEGIN + { @ISA = qw(Exporter) ; + @EXPORT = + qw(aprx_eq aprx_ge aprx_le aprx_gt aprx_lt + URL NAM SMA BLD NSS TAB BQ TR TH TD TDr RED GRN H1 H2 H3 + s4tim pr_interval pr_diff + ) ; + } + +sub Version { "$PRG version $VER" ; } +sub version { "$PRG-$VER" ; } +sub DEF_TIMEOUT { $DEF_TIMEOUT ; } +sub is_get_opt { my $opt = shift ; exists $GET_OPTS { $opt } ; } + +sub getset + { my $self = shift ; + my $attr = shift ; + if ( @_ ) { $self -> { $attr } = shift ; } + die "no attr '$attr'" unless exists $self -> { $attr } ; + $self -> { $attr } ; + } + +sub mk_method + { my $self = shift ; + my $attr = shift ; + sprintf 'sub %s { my $self = shift ; $self -> getset ( "%s", @_ ) ; }' + , $attr, $attr ; + } + +sub mk_methods + { my $self = shift ; + join "\n", map { Base -> mk_method ( $_ ) ; } @_ ; + } + +sub aprx_eq { my ( $t1, $t2 ) = @_ ; abs ( $t1 - $t2 ) < $APRX_DELTA ; } +sub aprx_ge { my ( $t1, $t2 ) = @_ ; $t1 > $t2 or aprx_eq $t1, $t2 ; } +sub aprx_le { my ( $t1, $t2 ) = @_ ; $t1 < $t2 or aprx_eq $t1, $t2 ; } +sub aprx_gt { my ( $t1, $t2 ) = @_ ; $t1 > $t2 and not aprx_eq $t1, $t2 ; } +sub aprx_lt { my ( $t1, $t2 ) = @_ ; $t1 < $t2 and not aprx_eq $t1, $t2 ; } + +sub URL { sprintf '%s', $_[0], $_[1] ; } +sub NAM { sprintf '%s', $_[0], $_[1] ; } +sub SMA { sprintf "%s", $_[0] ; } +sub BLD { sprintf "%s", $_[0] ; } +sub NSS { sprintf SMA('%s site%s'), $_[0], ( $_[0] == 1 ? '' : 's' ) ; } +sub TAB { sprintf "%s
", $_[0] ; } +sub BQ { sprintf "
\n%s\n
\n", $_[0] ; } +sub TR { sprintf "%s\n", $_[0] ; } +sub TH { sprintf "%s\n", $_[0] ; } +sub TD { sprintf "%s\n", $_[0] ; } +sub H1 { sprintf "

%s

\n", $_[0] ; } +sub H2 { sprintf "

%s

\n", $_[0] ; } +sub H3 { sprintf "

%s

\n", $_[0] ; } +sub TDr { sprintf "%s\n", $_[0] ; } +sub RED { sprintf "%s", $_[0] ; } +sub GRN { sprintf '%s', $_[0] ; } + +sub s4tim + { my $tim = shift ; + my %tab = ( 's' => 1, 'm' => 60, 'h' => 60 * 60, 'd' => 60 * 60 * 24 ) ; + die "wrong time '$tim'" unless $tim =~ /$TIM_PAT/o ; + my $m = $1 ; my $u = $2 ; + return $m * $tab { $u } ; + } + +sub pr_interval + { my $s = shift ; + my ( $magn, $unit ) ; + my $mins = $s / 60 ; my $m = int ( $mins + 0.5 ) ; + my $hours = $s / ( 60 * 60 ) ; my $h = int ( $hours + 0.5 ) ; + + if ( $s < 50 ) + { $magn = $s ; $unit = 'second' ; } + elsif ( $m < 50 ) + { $magn = $m ; $unit = 'minute' ; } + elsif ( $h < 36 ) + { $magn = $h ; $unit = 'hour' ; } + else + { $magn = sprintf "%.1f", $hours / 24 ; $unit = 'day' ; } + + $unit .= 's' unless $magn == 1 ; + + return "$magn $unit" ; + } + +sub pr_diff + { my $time = shift ; + my $max = shift ; + my $res ; + + if ( $time == $^T ) + { $res = BLD 'renewed' ; } + else + { $res = pr_interval $^T - $time ; + $res = BLD RED $res if aprx_lt $time, $max ; + } + return $res ; + } + +sub exp_date + { my @day = qw(Sun Mon Tue Wed Thu Fri Sat) ; + my @mon = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec) ; + my @gmt = gmtime time + 3600 ; + sprintf "%s, %02d %s %4d %02d:%02d:%02d GMT" + , $day [ $gmt [ 6 ] ] + , $gmt [ 3 ] + , $mon [ $gmt [ 4 ] ] + , $gmt [ 5 ] + 1900 + , @gmt [ 2, 1, 0 ] + ; + } + +sub htmlquote + { my $x = shift ; + $x =~ s/&/&/g ; + $x =~ s//>/g ; + return $x ; + } + +package Mirmon ; ################################################### + +BEGIN { use base 'Base' ; Base -> import () ; } + +use IO::Select ; +use Net::hostent ; + + { my %opt = ( v => 0 , d => 0 , q => 0 ) ; + sub _opt + { my ( $key, $val ) = @_ ; + my $res ; + unless ( exists $opt { $key } ) + { warn "unknown Mirmon option '$key'\n" ; } + else + { $res = $opt { $key } ; + $opt { $key } = $val if defined $val ; + } + $res ; + } + } + +sub verbose { _opt ( 'v', shift ) ; } +sub quiet { _opt ( 'q', shift ) ; } +sub debug { _opt ( 'd', shift ) ; } + +eval Base -> mk_methods ( qw(conf state regions) ) ; + +sub config_list + { my $self = shift ; + my $home = ( getpwuid $< ) [ 7 ] or die "can get homedir '$<' ($!)" ; + ( 'mirmon.conf', "$home/.mirmon.conf", '/etc/mirmon.conf' ) ; + } + +sub new + { my $self = shift ; + my $path = shift ; + my $res = bless {}, $self ; + $res -> get_config ( $path ) ; + $res -> get_state ; + $res -> get_regions ; + $res ; + } + +sub find_config + { my $self = shift ; + my $arg = shift ; + my @LIST = $arg ? ( $arg ) : Mirmon -> config_list ; + for my $conf ( @LIST ) { return $conf if -f $conf ; } + die sprintf "can't find a config file :\n %s\n" , join "\n ", @LIST ; + } + +sub get_config + { my $self = shift ; + my $path = shift ; + my $file = $self -> find_config ( $path ) ; # or die + $self -> conf ( Mirmon::Conf -> new ( $file ) ) ; + } + +sub get_state + { my $self = shift ; + my $conf = $self -> conf ; + my $state = $conf -> state ; + my $res = {} ; + open STATE, $state or die "can't open $state ($!)" ; + for my $line ( ) + { chop $line ; + my $mirror = Mirmon::Mirror -> new ( $self, $line ) ; + $res -> { $mirror -> url } = $mirror ; + } + close STATE ; + + my $mlist = $conf -> mirror_list ; + my $style = $conf -> list_style ; + my %in_list = () ; + open MLIST, $mlist or die "can't open $mlist ($!)" ; + for my $line ( ) + { chop $line ; + next if $line =~ /^#/ ; + next if $line =~ /^\s*$/ ; + my ( $reg, $url, $mail ) ; + if ( $style eq 'plain' ) + { ( $reg, $url, $mail ) = split ' ', $line ; } + elsif ( $style eq 'apache' ) + { my $apache_type ; + ( $apache_type, $reg, $url, $mail ) = split ' ', $line ; + unless ( defined $APA_TYPES { $apache_type } ) + { print "*** strange type in $url ($apache_type)\n" + unless Mirmon::quiet ; + next ; + } + } + + if ( $conf -> add_slash and $url !~ m!/$! ) + { print "*** appended '/' to $url\n" unless Mirmon::quiet ; + $url .= '/' ; + } + + $in_list { $url } ++ ; + + unless ( exists $res -> { $url } ) + { printf "*** added to list %s\n", $url unless Mirmon::quiet ; + $res -> { $url } = Mirmon::Mirror -> init ( $self, $url ) ; + } + my $mirror = $res -> { $url } ; + $mirror -> region ( $reg ) ; + $mirror -> mail ( $mail || '' ) ; + } + close MLIST ; + + for my $url ( sort keys %$res ) + { # printf "%s\n", $res -> { $url } -> state ; + unless ( exists $in_list { $url } ) + { printf "*** removed from list %s\n", $url unless Mirmon::quiet ; + delete $res -> { $url } ; + } + } + $self -> state ( $res ) ; + } + +sub put_state + { my $self = shift ; + my $state = $self -> state ; + my $file = $self -> conf -> state ; + my $TMP = "$file.tmp" ; + open TMP, ">$TMP" or die "can't write '$TMP' ($!)" ; + for my $url ( sort keys %$state ) + { printf TMP "%s\n", $state -> { $url } -> state + or die "can't print $url to $TMP ($!)" ; + } + close TMP ; + + if ( -z $TMP ) + { warn "wrote empty state file; keeping previous version" ; } + else + { rename $TMP, $file or die "can't rename '$TMP', '$file' ($!)" ; } + } + +sub get_regions + { my $self = shift ; + my $file = $self -> conf -> countries ; + open REGS, $file or die "can't open countries '$file' ($!)" ; + while ( ) + { chop ; + next if /^#/ ; + my ( $code, $dash, $reg ) = split ' ', $_, 3 ; + $self -> { regions } { lc $code } = lc $reg ; + } + close REGS ; + } + +sub get_dates + { my $self = shift ; + my $get = shift ; + my $state = $self -> state ; + my $conf = $self -> conf ; + my $CMD = $conf -> probe ; + my $PAR = $conf -> max_probes ; + my %m4h = () ; + my @QUE = () ; + my @NOQ = () ; + my $GET = IO::Select -> new () ; + + my $cnt = 0 ; + my $nok = 0 ; + + for my $url ( sort keys %$state ) + { my $mirror = $state -> { $url } ; + $cnt ++ if $mirror -> last_status eq 'ok' ; + if ( $get eq 'all' or $mirror -> last_probe eq 'undef' ) + { push @QUE, $mirror ; } + elsif ( $get eq 'update' ) + { my $stat = $mirror -> last_status ; + my $vrfy = $mirror -> last_ok_probe ; + my $lprb = $mirror -> last_probe ; + if ( aprx_le $lprb, $^T - s4tim $conf -> min_poll ) + { if ( $stat ne 'ok' ) + { push @QUE, $mirror ; $nok ++ ; } + elsif ( aprx_le $vrfy, $^T - s4tim $conf -> max_poll ) + { push @QUE, $mirror ; } + else + { push @NOQ, $mirror ; } + } + } + else + { die "unknown opt_get '$get'" ; } + } + + if ( Mirmon::verbose ) + { my $que = scalar @QUE ; my $noq = scalar @NOQ ; + printf "ok mirrors %d, queued %d, not queued %d, ok %d, nok %d\n" + , $cnt, $que, $noq, $que - $nok, $nok + } + + if ( $conf -> randomize ) + { my $hrs = int ( ( s4tim $conf -> max_poll ) / 60 / 60 + 0.5 ) ; + my $avg = int ( $cnt / $hrs + 0.5 ) ; + my $prc = ( scalar keys %$state ) / 50 ; + my $flr = int $prc ; + my $extras = $flr + ( rand 1 < ( $prc - $flr ) ) ; + my $picked = 0 ; + + while ( @QUE < $avg + $nok and @NOQ and $picked < $extras ) + { my $idx = int rand @NOQ ; + push @QUE, $NOQ [ $idx ] ; + $NOQ [ $idx ] = $NOQ [ $#NOQ ] ; + pop @NOQ ; + $picked ++ ; + } + + printf "avg mirrors/hr %d, max extras %d, picked %d ; queued %s\n" + , $avg, $extras, $picked, scalar @QUE if Mirmon::verbose ; + } + + while ( @QUE ) + { my $started = 0 ; + while ( $GET -> count () < $PAR and @QUE ) + { my $mirror = shift @QUE ; + if ( gethost $mirror -> site ) + { my $handle = $mirror -> start_probe ; + $m4h { $handle } = $mirror ; + $GET -> add ( $handle ) ; + $started ++ ; + } + else + { $mirror -> update ( 0, 'site_not_found', undef ) ; } + } + + my @can_read = $GET -> can_read ( 0 ) ; + + printf "queue %d, started %d, probes %d, can_read %d\n", + scalar @QUE, $started, $GET -> count (), scalar @can_read + if Mirmon::verbose ; + + for my $handle ( @can_read ) + { # order is important ; wget's hang if/when actions are reversed + $GET -> remove ( $handle ) ; + $m4h { $handle } -> finish_probe ( $handle ) ; + } + + sleep 1 ; + } + + my $stop = time + $conf -> timeout + 10 ; + + while ( $GET -> count () and time < $stop ) + { my @can_read = $GET -> can_read ( 0 ) ; + + printf "wait %2d, probes %d, can_read %d\n", + $stop - scalar time, $GET -> count (), scalar @can_read + if Mirmon::verbose ; + + for my $handle ( @can_read ) + { $GET -> remove ( $handle ) ; + $m4h { $handle } -> finish_probe ( $handle ) ; + } + + sleep 10 ; + } + + for my $handle ( $GET -> handles () ) + { $m4h { $handle } -> update ( 0, 'hangs', undef ) ; } + } + +sub img_sf_cnt + { my $self = shift ; + my $prf = shift ; + my $cnt = shift ; + my $res ; + if ( $prf eq 'x' ) + { sprintf + ( '' + , $self -> conf -> icons + ) x $cnt ; + } + else + { sprintf '' + , $self -> conf -> icons, $prf, $cnt ; + } + } + +sub img_sf { my $self = shift ; $self -> img_sf_cnt ( $_[0], 1 ) ; } + +sub show_hist + { my $self = shift ; + my $hst = shift ; + if ( $hst =~ /-(.*)$/ ) { $hst = $1 ; } + return '' unless $hst =~ m/^[sbfzx]+$/ ; + if ( length $hst == $HIST and $hst =~ /^(s*b)s*$/ ) + { return $self -> img_sf_cnt ( 'sb', length $1 ) ; } + elsif ( length $hst == $HIST and $hst =~ /^(s*f)s*$/ ) + { return $self -> img_sf_cnt ( 'sf', length $1 ) ; } + elsif ( length $hst == $HIST and $hst =~ /^(s*b)fs*$/ ) + { return $self -> img_sf_cnt ( 'sbf', length $1 ) ; } + my $res = '' ; + my $cnt = 1 ; + my $prf = substr $hst, 0, 1 ; + $hst = substr $hst, 1 ; + while ( $hst ne '' ) + { if ( substr ( $prf, 0, 1 ) eq substr ( $hst, 0, 1 ) ) + { $cnt ++ ; + $hst = substr $hst, 1 ; + } + else + { $res .= $self -> img_sf_cnt ( $prf, $cnt ) ; + $prf = substr $hst, 0, 1 ; + $hst = substr $hst, 1 ; + $cnt = 1 ; + } + } + $res .= $self -> img_sf_cnt ( $prf, $cnt ) if $cnt ; + $res ; + } + +sub gen_histogram_probes + { my $self = shift ; + my $state = $self -> state ; + my %tab = () ; + my %bad = () ; + my $res = '' ; + my $s_cnt = 0 ; + my $f_cnt = 0 ; + my $hr_min ; + my $hr_max ; + for my $url ( keys %$state ) + { my $mirror = $state -> { $url } ; + my $lprb = $mirror -> last_probe ; + my $stat = $mirror -> last_status ; + next if $lprb eq 'undef' ; + my $hr = int ( ( $^T - $lprb ) / 3600 + 0.5 ) ; + $hr_min = $hr if ! defined $hr_min or $hr < $hr_min ; + $hr_max = $hr if ! defined $hr_max or $hr > $hr_max ; + if ( $stat eq 'ok' ) + { $tab { $hr } ++ ; $s_cnt ++ ; } + else + { $bad { $hr } ++ ; $f_cnt ++ ; } + } + return BQ 'nothing yet' unless scalar keys %tab ; + + $res = TR + ( TH ( 'hours ago' ) + . TH ( 'succ' ) + . TH ( 'fail' ) + . TH sprintf + ( '%s %s, %s %s' + , $s_cnt , GRN ( 'successful' ) + , $f_cnt , RED ( 'failed' ) + ) + ) ; + + my $max = 0 ; + for my $x ( keys %tab ) + { my $tot = $tab { $x } + ( $bad { $x } || 0 ) ; + $max = $tot if $max < $tot ; + } + + return BQ "nothing yet" unless $max ; + + for my $hr ( $hr_min .. $hr_max ) + { my $x = $tab { $hr } || 0 ; + my $y = $bad { $hr } || 0 ; + my $n = int ( $x / $max * $HIST ) ; + my $b = int ( $y / $max * $HIST ) ; + $res .= TR + ( TDr ( $hr ) + . TDr ( $x ) + . TDr ( $y ) + . TD + ( ( $n ? $self -> img_sf_cnt ( 's', $n ) : '' ) + . ( $b ? $self -> img_sf_cnt ( 'f', $b ) : '' ) + . ( ( $n + $b ) ? '' : ' ' ) ) - ); - } - return "
\n" . TAB($res) . "
\n"; -} -sub gen_histogram { - my $MAX_H = max_age1; - my $MAX_h = 1 + ( - ( 20 * 3600 <= $MAX_H and $MAX_H <= 36 * 3600 ) - ? int( $MAX_H / 3600 ) - : 25 - ); - my $MAX_O = max_age2; - my $MAX_o = int( $MAX_O / 3600 + 0.5 ); - my $H = 18; - my %W = ( 'old' => 1, 'ded' => 1, 'bad' => 1 ); - my %Wmx = ( 'old' => 5, 'ded' => 3, 'bad' => 3 ); - my %tab; - my %hst; - my $res; - for ( my $x = 0 ; $x < $MAX_h ; $x++ ) { $tab{$x} = 0; } - $tab{old} = 0; - $tab{ded} = 0; - $tab{bad} = 0; - for my $url ( keys %RES ) { - my $time = $RES{$url}[0]; - if ( $time =~ /^\d+$/ ) { - my $s = $^T - $time; - my $hr = int( $s / $MAX_H * ( $MAX_h - 1 ) + 0.5 ); - if ( $s <= $MAX_H ) { $tab{$hr}++; } - elsif ( $s <= $MAX_O ) { $tab{old}++; } - else { $tab{ded}++; } - } - else { $tab{bad}++; } - } - my $max = 0; - for ( grep !exists $Wmx{$_}, keys %tab ) { - $max = $tab{$_} if $tab{$_} > $max; - } - my %bad; - for my $aux ( keys %Wmx ) { - $bad{$aux} = $tab{$aux}; - if ( $bad{$aux} > $max ) { - $W{$aux} = $Wmx{$aux}; - my $d = int( $bad{$aux} / $W{$aux} ); - for ( my $i = 1 ; $i < $W{$aux} ; $i++ ) { - $tab{ $aux . $i } = $d; - if ( $bad{$aux} % $Wmx{$aux} > $i ) { - $tab{ $aux . $i }++; - $tab{$aux}--; - } - } - $tab{$aux} -= ( $W{$aux} - 1 ) * $d; - $max = $tab{$aux} if $max < $tab{$aux}; - } - } - # if ( $opt{v} ) - # { for my $hr ( keys %tab ) - # { printf "tab '%s' = '%s'\n", $hr, $tab { $hr } ; } - # } - return 'nothing yet' unless $max; - $H = $max if 8 <= $max and $max <= 26; - for ( keys %tab ) { $hst{$_} = int( $H * $tab{$_} / $max + 0.5 ); } - my @keys = sort { $a <=> $b } grep /^\d+$/, keys %hst; - my $tab_hr = 0; - for my $hr (@keys) { $tab_hr += $tab{$hr}; } - push @keys, grep ( m/^old/, sort keys %tab ), - grep ( m/^ded/, sort keys %tab ), grep ( m/^bad/, sort keys %tab ); - for ( my $h = $H ; $h > 0 ; $h-- ) { - $res .= "\n"; - $res .= sprintf "↑\n" - if $h == $H; - $res .= sprintf '%s' . "\n", $H - 6, - NSS($max) - if $h == $H - 3; - $res .= sprintf "↓\n" - if $h == 3; - for my $x (@keys) { - $res .= sprintf "%s\n", - ( - ( $hst{$x} >= $h ) - ? img_sf( - $x =~ /^\d+$/ - ? 's' - : ( $x =~ /^old/ ? 'b' : ( $x =~ /^ded/ ? 'f' : 'z' ) ) - ) - : ( - ( $h == 1 and $hst{$x} == 0 ) - ? sprintf( '', - $CNF{icons} ) - : '' - ) - ); - } - $res .= "\n"; - } - my $HR = '
'; - $res .= "\n"; - $res .= sprintf "$HR\n", 1; - $res .= sprintf "$HR\n", $MAX_h; - $res .= sprintf "$HR\n", $W{old}; - $res .= sprintf "$HR\n", $W{ded}; - $res .= sprintf "$HR\n", $W{bad}; - $res .= "\n"; - $res .= "\n"; - $res .= ' age → '; - $res .= "|\n"; - $res .= - sprintf( '' - . '←  0 ≤ age ≤ %s  →' - . "\n", - $MAX_h - 2, pr_interval($MAX_H) ); - $res .= "|\n"; - $res .= sprintf( - '' - . ' %sh < %s ≤ %sh ' - . "\n", - $W{old}, int( $MAX_H / 60 / 60 ), - BLD('age'), $MAX_o - ); - $res .= sprintf( - '' - . ' old ' - . "\n", - $W{ded} - ); - $res .= sprintf( - '' - . ' bad ' - . "\n", - $W{bad} - ); - $res .= "\n"; - my $FRMT = ' %s '; - $res .= "\n"; - $res .= sprintf "$FRMT\n", 1, NSS scalar keys %RES; - $res .= "|\n"; - $res .= sprintf "$FRMT\n", $MAX_h - 2, NSS $tab_hr ; - $res .= "|\n"; - $res .= sprintf "$FRMT\n", $W{old}, NSS $bad {old}; - $res .= sprintf "$FRMT\n", $W{ded}, NSS $bad {ded}; - $res .= sprintf "$FRMT\n", $W{bad}, NSS $bad {bad}; - $res .= "\n"; - $res = "\n$res\n
\n"; - $res = sprintf "%s
\n", - "\n$res\n"; - if ( $max == $H ) { - $res .= sprintf "
units %s %s %s %s represent one mirror site.\n", - img_sf('s'), img_sf('f'), img_sf('b'), img_sf('z'); - } - else { - $res .= - sprintf "
each %s %s %s %s unit represents %s mirror sites.\n", - img_sf('s'), img_sf('f'), img_sf('b'), img_sf('z'), - sprintf( "%.1f", $max / $H ); - } - return $res; -} -sub revdom { my $dom = shift; join '.', reverse split /\./, $dom; } -sub by_type_site { - my $a_type = $a->[0]; - my $b_type = $b->[0]; - my $a_site = $a->[2]; - my $b_site = $b->[2]; - ( revdom $a_site ) cmp( revdom $b_site ) - or $a_type cmp $b_type; -} -sub by_CCS { ( $CCS{$a} || $a ) cmp( $CCS{$b} || $b ); } -sub legend; -sub gen_page { - my $PPP = shift; - my $TMP = "$PPP.tmp"; - my %tab; - my $refs; - for my $url ( keys %LST ) { - my ( $type, $site, $reg ) = @{ $LST{$url} }; - push @{ $tab{$reg} }, [ $type, $url, $site ]; - } - my $bad = 0; - my $old = 0; - my $unr = 0; - my %stats; - my @stats; - my $ok = 0; - for my $url ( keys %RES ) { - my ( $time, $stat, $vrfy ) = @{ $RES{$url} }; - if ( $stat eq 'ok' ) { $ok++; } - else { $stats{$stat}++; } - if ( $time eq 'undef' ) { $bad++; } - elsif ( 'f' eq age_code $time ) { $old++; } - if ( $vrfy eq 'undef' or aprx_lt $vrfy, $^T - max_vrfy ) { $unr++; } - } - my $STAT = - sprintf "%d bad -- %d older than %s -- %s unreachable for more than %s", - $bad, $old, pr_interval(max_age2), $unr, pr_interval(max_vrfy); - my $PROB = 'last probes : '; - push @stats, "$ok were ok" if $ok; - for my $stat ( sort keys %stats ) { - push @stats, sprintf "%s had %s", $stats{$stat}, RED $stat ; - } - $PROB .= join ', ', @stats; - for my $reg ( sort keys %tab ) { - $refs .= sprintf " %s \n", url "#$reg", - "$reg"; - } - my $COLS = 5; - my $LOGO = - $CNF{project_logo} - ? url( - $CNF{project_url}, - sprintf( - '%s', - $CNF{project_logo}, $CNF{project_name} - ) - ) - : ''; - my $HTOP = $CNF{htm_top} ? $CNF{htm_top} . "\n" : ''; - my $FOOT = $CNF{htm_foot} ? $CNF{htm_foot} . "\n" : ''; - my $HEAD = $CNF{htm_head} ? $CNF{htm_head} . "\n" : ''; - my $TITL = url $CNF{project_url}, $CNF{project_name}; - my $EXPD = exp_date; - open PPP, ">$TMP" or Error "can't write $TMP ($!)"; - print PPP ''; - print PPP "\n"; - print PPP "\n"; - print PPP "the status of $CNF{project_name} mirrors\n"; - printf PPP "%s\n", ''; - print PPP "\n"; - print PPP "\n"; - print PPP $HEAD if $HEAD; - print PPP "\n"; - print PPP "\n"; - print PPP $LOGO; - print PPP "

the status of $TITL mirrors

\n"; - print PPP "\n"; - printf PPP "\n", - scalar gmtime $^T; - printf PPP "\n", - scalar gmtime( $opt{get} ? $^T : ( stat $CNF{state} )[9] ); - print PPP "
date:%s (GMT)
last check:%s (GMT)
\n"; - printf PPP "

%s

\n", $HTOP if $HTOP; - if ( $CNF{put_histo} eq 'top' ) { - print PPP "

age histogram

\n"; - print PPP "
\n"; - print PPP gen_histogram; - print PPP "
\n"; - } - print PPP "

regions

\n"; - print PPP "
\n"; - print PPP "
\n"; - printf PPP "%s\n", $refs; - print PPP "
\n"; - print PPP "
\n"; - print PPP "

report

\n"; - my $attr1 = "COLSPAN=$COLS BGCOLOR=\"LIME\""; - my $attr2 = 'BGCOLOR="AQUA"'; - print PPP "
\n"; - print PPP "\n"; - printf PPP "\n", - scalar keys %LST, scalar keys %tab; - printf PPP "\n", $STAT; - printf PPP "\n", $PROB; - print PPP "\n"; - printf PPP " \n", $CNF{project_name}; - printf PPP " \n", 'type'; - printf PPP " \n", 'mirror age,
daily stats'; - printf PPP " \n", 'last probe,
probe stats'; - printf PPP " \n", 'last stat'; - print PPP "\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 "\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 "\n"; - printf PPP " \n" - . " \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 " \n", $pr_time, - $pr_hsts; - printf PPP " \n", $pr_last, - $pr_hstp; - printf PPP " \n", $stat; - print PPP "\n"; - } - } - print PPP "
%d sites in %d regions
%s
%s
%s site -- home%s%s%s%s
$ccs
%s  %s%s%s
%s
%s
%s
%s
\n"; - print PPP "
\n"; - if ( $CNF{put_histo} eq 'bottom' ) { - print PPP "

age histogram

\n"; - print PPP "
\n"; - print PPP gen_histogram; - print PPP "
\n"; - } - print PPP legend; - print PPP "

probe results

\n"; - print PPP gen_histogram_probes; - print PPP "

software

\n"; - print PPP "
\n"; - my $MIR_IMG = sprintf 'mirmon', - $CNF{icons}; - print PPP sprintf "\n", - 'http://www.cs.uu.nl/people/henkp/mirmon/', $MIR_IMG; - print PPP "\n"; - print PPP "
%s$VER
\n"; - print PPP $FOOT; - print PPP "\n"; - print PPP ""; - if ( print PPP "\n" ) { - close PPP; - if ( -z $TMP ) { - Warn "wrote empty html file; keeping previous version"; - } - else { rename $TMP, $PPP or Error "can't rename $TMP, $PPP ($!)"; } - } - else { Error "can't print to $TMP ($!)"; } -} -sub legend { + ) ; + } + return BQ TAB $res ; + } + +sub age_avg + { my $self = shift ; + my $state = $self -> state ; + my @tab = () ; + for my $url ( keys %$state ) + { my $time = $state -> { $url } -> age ; + push @tab, $^T - $time if $time =~ /^\d+$/ ; + } + my $cnt = @tab ; + + return undef if $cnt == 0 ; + + @tab = sort { $a <=> $b } @tab ; + + my $tot = 0 ; + for my $age ( @tab ) { $tot += $age ; } + my $mean = $tot / $cnt ; + + my $median ; + if ( $cnt == 1 ) + { $median = $tab [ 0 ] ; } + elsif ( $cnt % 2 ) + { my $mid = int ( $#tab / 2 ) ; + $median = ( $tab [ $mid ] + $tab [ $mid + 1 ] ) / 2 ; + } + else + { my $mid = int ( $#tab / 2 ) ; + $median = $tab [ $mid ] ; + } + + if ( @tab < 2 ) + { return $mean, $median, undef ; } + + my $sum = 0 ; + for my $age ( @tab ) + { $sum += ( $age - $mean ) ** 2 ; } + my $stddev = sqrt ( $sum / ( $cnt - 1 ) ) ; + + return $mean, $median, $stddev ; + } + +sub legend + { my $self = shift ; + my $conf = $self -> conf ; + my $min_sync = $conf -> min_sync ; + my $max_sync = $conf -> max_sync ; + my $min_poll = $conf -> min_poll ; + my $max_poll = $conf -> max_poll ; + return <legend +

project site -- home

+
project site is an url. The href is the href for the site in the list of mirrors, @@ -857,12 +605,16 @@ pointing to the document root of the site. This pointer is useful if the project site url is invalid, possibly because the mirror site moved the archive.
+

type

+
Indicates the type (ftp or http) of the project site and home urls.
+

mirror age, daily stats

+
The mirror age is based upon the last successful probe.

@@ -880,176 +632,1173 @@ configuration parameters : age - this project - in general + this project + in general - min - max - min - max + min + max + min + max - fresh - 0 - - @{[$CNF{min_sync}]} + @{[$CNF{max_poll}]} - 0 - min_sync + max_poll + fresh + 0 + $min_sync + $max_poll + 0 + min_sync + max_poll - oldish - - @{[$CNF{min_sync}]} + @{[$CNF{max_poll}]} - - @{[$CNF{max_sync}]} + @{[$CNF{max_poll}]} - min_sync + max_poll - max_sync + max_poll + oldish + $min_sync + $max_poll + $max_sync + $max_poll + min_sync + max_poll + max_sync + max_poll old - - @{[$CNF{max_sync}]} + @{[$CNF{max_poll}]} - ∞ - max_sync + max_poll - ∞ + $max_sync + $max_poll + ∞ + max_sync + max_poll + ∞ - bad - - the site or mirror tree was never found + bad + + the site or mirror tree was never found

+

last probe, probe stats

+
Last probe indicates when the last successful probe was made. Probe stats gives the probe history (right is recent). A probe is either a -success or a -failure. +success or a +failure.
+

last stat

+
Last stat gives the status of the last probe.
+ LEGENDA -} -sub start_date { - my $url = shift; - my $CMD = shift; - my $TIMEOUT = $CNF{timeout}; - my $src = $HREF{ lc site $url } || $url; - $CMD =~ s/%TIMEOUT%/$TIMEOUT/g; - $CMD =~ s/%URL%/$src/g; - printf "*** SUBSTITUTE site %s\n+ url %s\n+ %s\n", site($url), - $HREF{ lc site $url }, $CMD - if $HREF{ lc site $url } and $opt{v}; - my $WGT = new IO::Pipe; - my $res = $WGT->reader( split ' ', $CMD ); - if ($res) { - $WGT->blocking(0); - $GET->add($WGT); - $URL{$WGT} = $url; - } - else { err $url, 'no pipe'; } -} -sub get_date { - my $WGT = shift; - my $url = $URL{$WGT}; - my $time = undef; - $WGT->blocking(1); - unless ( $WGT->eof() ) { $time = $WGT->getline(); } - $GET->remove($WGT); - $WGT->flush; - $WGT->close; - return err $url, 'no time' unless defined $time; - return err $url, "empty" if $time =~ /^\s*$/; - $time = ( split ' ', $time )[0]; - if ( $time !~ /^\d+$/ ) { - $time = htmlquote $time ; - $time = substr( $time, 0, 15 ) . '..' if length $time > 15; - err $url, "'$time'"; - } - else { res $url, $time, 'ok'; } -} -sub get_dates { - my $CMD = shift; - my @QUE; - my $PAR = $CNF{max_probes}; - my $cnt_LST = scalar keys %LST; - for my $url ( sort keys %LST ) { - if ( $opt{get} eq 'all' or !exists $OLD{$url} ) { push @QUE, $url; } - elsif ( $opt{get} eq 'update' ) { - my $stat = $OLD{$url}[1]; - my $vrfy = $OLD{$url}[2]; - my $lprb = $OLD{$url}[5]; - if ( - ( - $lprb eq 'undef' - or aprx_le $lprb, - $^T - tim_to_s $CNF {min_poll} - ) - and ( - $stat ne 'ok' or aprx_le $vrfy, - $^T - tim_to_s $CNF {max_poll} + } + +sub _ths + { return '' unless my $ths = shift ; + $ths == 1 ? TH '' : "\n" ; + } + +sub gen_histogram + { my $self = shift ; + my $where = shift ; + my $conf = $self -> conf ; + my $state = $self -> state ; + + return '' if $where ne $conf -> put_histo ; + + my $MAX_H = $conf -> max_age1 ; + my $MAX_h = 1 + + ( ( 20 * 3600 <= $MAX_H and $MAX_H <= 36 * 3600 ) + ? int ( $MAX_H / 3600 ) + : 25 + ) ; + my $MAX_O = $conf -> max_age2 ; + my $MAX_o = int ( $MAX_O / 3600 + 0.5 ) ; + my $H = 18 ; + my %W = ( 'old' => 1, 'ded' => 1, 'bad' => 1 ) ; + my %Wmx = ( 'old' => 5, 'ded' => 3, 'bad' => 3 ) ; + my %tab ; + my %hst ; + my $res ; + for ( my $x = 0 ; $x < $MAX_h ; $x ++ ) { $tab { $x } = 0 ; } + $tab { old } = 0 ; $tab { ded } = 0 ; $tab { bad } = 0 ; + for my $url ( keys %$state ) + { my $time = $state -> { $url } -> age ; + if ( $time =~ /^\d+$/ ) + { my $s = $^T - $time ; + my $hr = int ( $s / $MAX_H * ( $MAX_h - 1 ) + 0.5 ) ; + if ( $s <= $MAX_H ) { $tab { $hr } ++ ; } + elsif ( $s <= $MAX_O ) { $tab { old } ++ ; } + else { $tab { ded } ++ ; } + } + else + { $tab { bad } ++ ; } + } + my $max = 0 ; + for ( grep ! exists $Wmx { $_ }, keys %tab ) + { $max = $tab { $_ } if $tab { $_ } > $max ; } + + my %bad ; + + for my $aux ( keys %Wmx ) + { $bad { $aux } = $tab { $aux } ; + if ( $bad { $aux } > $max ) + { $W { $aux } = $Wmx { $aux } ; + my $d = int ( $bad { $aux } / $W { $aux } ) ; + for ( my $i = 1 ; $i < $W { $aux } ; $i++ ) + { $tab { $aux . $i } = $d ; + if ( $bad { $aux } % $Wmx { $aux } > $i ) + { $tab { $aux . $i } ++ ; + $tab { $aux } -- ; + } + } + $tab { $aux } -= ( $W { $aux } - 1 ) * $d ; + $max = $tab { $aux } if $max < $tab { $aux } ; + } + } + +# if ( $opt{v} ) +# { for my $hr ( keys %tab ) +# { printf "tab '%s' = '%s'\n", $hr, $tab { $hr } ; } +# } + + return 'nothing yet' unless $max ; + $H = $max if 8 <= $max and $max <= 26 ; + for ( keys %tab ) + { $hst { $_ } = int ( $H * $tab { $_ } / $max + 0.5 ) ; } + my @keys = sort { $a <=> $b } grep /^\d+$/, keys %hst ; + my $tab_hr = 0 ; + for my $hr ( @keys ) { $tab_hr += $tab { $hr } ; } + push @keys + , grep ( m/^old/, sort keys %tab ) + , grep ( m/^ded/, sort keys %tab ) + , grep ( m/^bad/, sort keys %tab ) + ; + my $img_bar = sprintf '' + , $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 .= "\n" ; + $res .= sprintf "↑\n" + if $h == $H ; + $res .= sprintf '%s' . "\n" + , $H-6, NSS ( $max ) if $h == $H - 3 ; + $res .= sprintf "↓\n" + if $h == 3 ; + my $ths = 0 ; + for my $x ( @keys ) + { my $col = + ( ( $hst { $x } >= $h ) + ? ( $x =~ /^\d+$/ + ? 's' + : ( $x =~ /^old/ ? 'b' : ( $x =~ /^ded/ ? 'f' : 'z' ) ) ) + : ( ( $h == 1 and $hst { $x } == 0 ) ? 'bar' : '' ) + ) ; + if ( $col ) + { $res .= _ths $ths ; $ths = 0 ; $res .= TH $img { $col } ; } + else + { $ths ++ ; } + } + $res .= _ths ( $ths ) . "\n" ; + } + + my $HR = '
' ; + + $res .= "\n" ; + $res .= sprintf "$HR\n", 1 ; + $res .= sprintf "$HR\n", $MAX_h ; + $res .= sprintf "$HR\n", $W { old } ; + $res .= sprintf "$HR\n", $W { ded } ; + $res .= sprintf "$HR\n", $W { bad } ; + $res .= "\n" ; + + $res .= "\n" ; + $res .= ' age → ' ; + + $res .= "|\n" ; + $res .= sprintf + ( '' + . '←  0 ≤ age ≤ %s  →' + . "\n" + , $MAX_h - 2, pr_interval ( $MAX_H ) + ) + ; + $res .= "|\n" ; + $res .= sprintf + ( '' + . ' %sh < %s ≤ %sh ' + . "\n" + , $W { old }, int($MAX_H/60/60) , BLD ( 'age' ), $MAX_o + ) ; + $res .= sprintf + ( '' + . ' old ' + . "\n" + , $W { ded } + ) ; + $res .= sprintf + ( '' + . ' bad ' + . "\n" + , $W { bad } + ) ; + $res .= "\n" ; + + my $FRMT = ' %s ' ; + + $res .= "\n" ; + $res .= sprintf "$FRMT\n", 1, NSS scalar keys %$state ; + $res .= "|\n" ; + $res .= sprintf "$FRMT\n", $MAX_h - 2, NSS $tab_hr ; + $res .= "|\n" ; + $res .= sprintf "$FRMT\n", $W { old }, NSS $bad { old } ; + $res .= sprintf "$FRMT\n", $W { ded }, NSS $bad { ded } ; + $res .= sprintf "$FRMT\n", $W { bad }, NSS $bad { bad } ; + $res .= "\n" ; + + $res = "\n$res\n
\n" ; + $res = sprintf "%s
\n" + , "\n$res\n" ; + my $units = join ' ' + , $self -> img_sf ( 's' ) , $self -> img_sf ( 'b' ) + , $self -> img_sf ( 'f' ) , $self -> img_sf ( 'z' ) + ; + if ( $max == $H ) + { $res .= sprintf "
units %s represent one mirror site.\n" + , $units ; + } + else + { $res .= sprintf "
each %s unit represents %s mirror sites.\n" + , $units, sprintf ( "%.1f", $max / $H ) ; + } + return H2 ( 'age histogram' ) . BQ $res ; + } + +sub gen_page + { my $self = shift ; + my $get = shift ; + my $VERSION = shift ; + my $conf = $self -> conf ; + my $PPP = $conf -> web_page ; + my $state = $self -> state ; + my $CCS = $self -> regions ; + my $TMP = "$PPP.tmp" ; + my %tab ; + my $refs ; + + for my $url ( keys %$state ) + { my $mirror = $state -> { $url } ; + my $reg = $mirror -> region ; + push @{ $tab { $reg } }, $mirror ; + } + + my $bad = 0 ; my $old = 0 ; my $unr = 0 ; + my %stats ; + my @stats ; + my $ok = 0 ; + + for my $url ( keys %$state ) + { my $mirror = $state -> { $url } ; + my $time = $mirror -> age ; + my $stat = $mirror -> last_status ; + my $vrfy = $mirror -> last_ok_probe ; + if ( $stat eq 'ok' ) { $ok ++ ; } else { $stats { $stat } ++ ; } + if ( $time eq 'undef' ) + { $bad ++ ; } + elsif ( 'f' eq $conf -> age_code ( $time ) ) + { $old ++ ; } + if ( $vrfy eq 'undef' or aprx_lt $vrfy, $^T - $conf -> max_vrfy ) + { $unr ++ ; } + } + + my $STAT = sprintf + "%d bad -- %d older than %s -- %s unreachable for more than %s" + , $bad + , $old + , pr_interval ( $conf -> max_age2 ) + , $unr + , pr_interval ( $conf -> max_vrfy ) + ; + + my $PROB = 'last probes : ' ; + push @stats, "$ok were ok" if $ok ; + for my $stat ( sort keys %stats ) + { ( my $txt = $stat ) =~ s/_/ /g ; + push @stats, sprintf "%s had %s" , $stats { $stat } , RED $txt ; + } + $PROB .= join ', ', @stats ; + + my ( $mean, $median, $stddev ) = $self -> age_avg ; + my $AVGS = "mean mirror age is " ; + unless ( defined $mean ) + { $AVGS = "undefined" ; } + 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", "$reg" + ; + } + + my $COLS = 5 ; + my $NAME = $conf -> project_name ; + my $LOGO = $conf -> project_logo + ? URL + ( $conf -> project_url + , sprintf + ( '%s' + , $conf -> project_logo + , $conf -> project_name ) - { - push @QUE, $url; - } - elsif ( $CNF{randomize} and 0 == int rand $cnt_LST ) { - push @QUE, $url; - } - else { $RES{$url} = $OLD{$url}; } - } - else { Error "unknown opt_get '$opt{get}'"; } - } - while (@QUE) { - while ( $GET->count() < $PAR and @QUE ) { - my $url = shift @QUE; - if ( gethost site $url ) { start_date $url, $CMD; } - else { err $url, 'site not found'; } - } - my @can_read = $GET->can_read(0); - printf "que %d, get %d, can %d\n", scalar @QUE, $GET->count(), - scalar @can_read - if $opt{v}; - for my $can_read (@can_read) { get_date $can_read ; } - sleep 1; - } - my $stop = time + $CNF{timeout} + 10; - while ( $GET->count() and time < $stop ) { - sleep 1; - my @can_read = $GET->can_read(0); - printf "wait %2d, get %d, can %d\n", $stop - scalar time, $GET->count(), - scalar @can_read - if $opt{v}; - for my $can_read (@can_read) { get_date $can_read ; } - } - for my $WGT ( $GET->handles() ) { - my $url = $URL{$WGT}; - err $url, 'hangs'; + ) + : '' + ; + my $HEAD = $conf -> htm_head . "\n" ; + my $HTOP = $conf -> htm_top . "\n" ; + my $FOOT = $conf -> htm_foot . "\n" ; + my $TITL = URL $conf -> project_url, $NAME ; + my $EXPD = Base::exp_date ; + my $DATE = scalar gmtime $^T ; + my $LAST = scalar gmtime ( $get ? $^T : ( stat $conf -> state ) [9] ) ; + + my $histo_top = $self -> gen_histogram ( 'top' ) ; + my $histo_bot = $self -> gen_histogram ( 'bottom' ) ; + + open PPP, ">$TMP" or die "can't write $TMP ($!)" ; + my $prev_select = select PPP ; + + my $attr1 = "COLSPAN=$COLS BGCOLOR=LIME" ; + my $attr2 = 'BGCOLOR=AQUA' ; + my $attr3 = "COLSPAN=$COLS BGCOLOR=YELLOW" ; + + my $num_mirrors = scalar keys %$state ; + my $num_regions = scalar keys %tab ; + + print < + + +the status of $NAME mirrors + + + +$HEAD + + +$LOGO +

the status of $TITL mirrors

+ + + + + + +
date:$DATE (UTC)
last check:$LAST (UTC)
+$HTOP +$histo_top +

regions

+
\n$refs\n
+

report

+
+ + + + + + + + + + + + +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 "\n" ; + + for my $mirror ( sort { $a -> cmp ( $b ) } @$mirrors ) + { print "\n" ; + printf " \n \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 " \n" , $pr_time, $pr_hsts ; + printf " \n" , $pr_last, $pr_hstp ; + printf " \n", $stat ; + print "\n" ; + } + } + + my $legend = $self -> legend ; + my $probes = $self -> gen_histogram_probes ; + my $mir_img = sprintf + 'mirmon' , $conf -> icons ; + + print < + +$histo_bot +$legend +

probe results

+$probes +

software

+
+
$num_mirrors sites in $num_regions regions
$STAT
$PROB
$AVGS
$NAME site -- hometypemirror age,
daily stats
last probe,
probe stats
last stat
$ccs
%s  %s%s%s
%s
%s
%s
%s
+ + + + +
$mir_img$VERSION
+
+$FOOT + + +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 /./, ; + close FILE ; + + $CONF =~ s/\t/ /g ; # replace tabs + $CONF =~ s/^[+ ]+// ; # delete leading space, plus + $CONF =~ s/\n\n\s+/ /g ; # glue continuation lines + $CONF =~ s/\n\n\+\s+//g ; # glue concatenation lines + $CONF =~ s/\n\n\./\n/g ; # glue concatenation lines + + chop $CONF ; + print "--$CONF--\n" if Mirmon::debug ; + for ( grep ! /^#/, split /\n\n/, $CONF ) + { my ($key,$val) = split ' ', $_, 2 ; + $val = '' unless defined $val ; + print "conf '$FILE' : key '$key', val '$val'\n" if Mirmon::debug ; + if ( exists $CNF_KEYS { $key } ) + { $self -> $key ( $val ) ; } + elsif ( $key eq 'site_url' ) + { my ( $site, $url ) = split ' ' , $val ; + $url .= '/' if $self -> add_slash and $url !~ m!/$! ; + $self -> site_url -> { $site } = $url ; +# printf "config : for site '%s' use instead\n '%s'\n", +# $site, $url if Mirmon::verbose ; + } + elsif ( $key eq 'no_add_slash' ) + { $self -> add_slash ( 0 ) ; } + elsif ( $key eq 'no_randomize' ) + { $self -> randomize ( 0 ) ; } + elsif ( $key eq 'show' ) + { $self -> show_conf if Mirmon::verbose ; } + elsif ( $key eq 'exit' ) + { die 'exit per config directive' ; } + elsif ( $key eq 'include' ) + { $self -> get_conf ( $val ) ; } + elsif ( $key eq 'env' ) + { my ( $x, $y ) = split ' ' , $val ; + $ENV { $x } = $y ; + printf "config : setenv '%s'\n '%s'\n", $x, $y + if Mirmon::verbose ; + } + else + { $self -> show_conf ; + die "unknown keyword '$key' (value '$val')\n" ; + } + } + my $err = $self -> check ; + die $err if $err ; + $self ; + } + +sub check + { my $self = shift ; + my $err = '' ; + for my $key ( @REQ_KEYS ) + { unless ( exists $self -> { $key } ) + { $err .= "error: missing config for '$key'\n" ; } + } + for my $key ( qw(min_poll max_poll max_sync min_sync) ) + { my $max = $self -> $key ; + unless ( $max =~ /$TIM_PAT/o ) + { $err .= "error: bad timespec for $key ($max)\n" ; } + } + unless ( grep $self -> { list_style } eq $_, @LIST_STYLE ) + { $err .= sprintf "error: unknown 'list_style' '%s'\n", + $self -> list_style ; + } + unless ( grep $self -> put_histo eq $_, @PUT_HGRAM ) + { $err .= sprintf "%s : error: unknown 'put_histo' '%s'\n", + $self -> put_histo ; + } + $err ; + } + +sub show_conf + { my $self = shift ; + print "vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv\n" ; + for my $key ( sort keys %$self ) + { next if $key =~ m/^_/ ; + my $val = $self -> { $key } ; + print "show_conf : $key = '$val'\n" ; + } + for my $key ( sort keys %{ $self -> site_url } ) + { printf "show_conf : for site '%s' use instead\n '%s'\n" + , $key, $self -> site_url -> { $key } if Mirmon::verbose ; + } + printf "show_conf : included '%s'\n" + , join "', '", @{ $self -> {_include} } ; + print "^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n" ; + } + +sub max_age1 + { my $self = shift ; + ( s4tim $self -> min_sync ) + ( s4tim $self -> max_poll ) ; + } + +sub max_age2 + { my $self = shift ; + ( s4tim $self -> max_sync ) + ( s4tim $self -> max_poll ) ; + } + +sub max_vrfy + { my $self = shift ; + ( s4tim $self -> min_poll ) + ( s4tim $self -> max_poll ) ; + } + +sub age_code + { my $self = shift ; + my $time = shift ; + return 'z' unless $time =~ /^\d+$/ ; + return + ( ( aprx_ge ( $time, $^T - $self -> max_age1 ) ) + ? 's' + : ( aprx_ge ( $time, $^T - $self -> max_age2 ) ? 'b' : 'f' ) + ) ; + } + +package Mirmon::Mirror ; ########################################### + +BEGIN { use base 'Base' ; Base -> import () ; } + +use IO::Pipe ; + +my @FIELDS = + qw(url age last_status last_ok_probe probe_history state_history last_probe) ; + +eval Base -> mk_methods ( @FIELDS, qw(mirmon region mail) ) ; + +sub state_history_time + { my $self = shift ; + my $res = ( split /-/, $self -> state_history ) [ 0 ] ; + $res ; + } + +sub state_history_hist + { my $self = shift ; + my $res = ( split /-/, $self -> state_history ) [ 1 ] ; + $res ; + } + +sub _parse + { my $self = shift ; + my $url = $self -> url ; + my ( $type, $site, $home ) ; + if ( $url =~ m!^(ftp|https?|rsync)://([^/:]+)(:\d+)?/! ) + { $type = $1 ; $site = $2 ; $home = $& ; } + return $type, $site, $home ; + } + +sub type { my $self = shift ; ( $self -> _parse ) [ 0 ] ; } +sub site { my $self = shift ; ( $self -> _parse ) [ 1 ] ; } +sub home { my $self = shift ; ( $self -> _parse ) [ 2 ] ; } + +sub age_in_days + { my $self = shift ; + my $res = 'undef' ; + my $age = $self -> age ; + if ( $age eq 'undef' ) + { $res = length $self -> state_history_hist + if $self -> last_probe ne 'undef' ; + } + else + { $res = ( $^T - $age ) / 24 / 60 / 60 ; } + $res ; + } + +sub init + { my $self = shift ; + my $mirmon = shift ; + my $url = shift ; + my $res = bless { mirmon => $mirmon }, $self ; + @{ $res } { @FIELDS } = ( 'undef' ) x scalar @FIELDS ; + $res -> url ( $url ) ; + $res -> probe_history ( '' ) ; + $res -> state_history ( "$^T-z" ) ; + $res -> mail ( '' ) ; + $res ; + } + +sub new + { my $self = shift ; + my $mirmon = shift ; + my $line = shift ; + my $res = bless { mirmon => $mirmon }, $self ; + @{ $res } { @FIELDS } = split ' ', $line ; + $res -> mail ( '' ) ; + $res ; + } + +sub update + { my $self = shift ; + my $succ = shift ; + my $stat = shift ; + my $time = shift ; + my $probe_hist = $self -> probe_history ; + if ( $succ ) + { $self -> age ( $time ) ; + $self -> last_ok_probe ( $^T ) ; + $probe_hist .= 's' ; + } + else + { $probe_hist .= 'f' ; + $time = $self -> age ; + } + + my $h = $self -> state_history_hist ; + my $t = $self -> state_history_time ; + + if ( aprx_ge ( $^T - $t, $HIST_DELTA ) ) + { my $n = int ( ( $^T - $t ) / $HIST_DELTA ) ; + $h .= 'x' x ( $n - 1 ) ; + $t = ( $n == 1 ? $t + $HIST_DELTA : $^T ) ; + } + else + { chop $h ; } + $h .= $self -> mirmon -> conf -> age_code ( $time ) ; + $h = substr $h, - $HIST ; + $h =~ s/^x+// ; + + $self -> last_status ( $stat ) ; + $self -> probe_history ( substr $probe_hist, - $HIST ) ; + $self -> last_probe ( $^T ) ; + $self -> state_history ( "$t-$h" ) ; + } + +sub as_list { my $self = shift ; @{ $self } { @FIELDS } ; } +sub state { my $self = shift ; join ' ', $self -> as_list ; } + +sub start_probe + { my $self = shift ; + my $conf = $self -> mirmon -> conf ; + my $probe = $conf -> probe ; + my $timeout = $conf -> timeout ; + $probe =~ s/%TIMEOUT%/$timeout/g ; + my $url = $self -> url ; + my $new = $conf -> site_url -> { $self -> site } ; + if ( defined $new ) + { printf "*** site_url : site %s\n -> url %s\n" + , $self -> site, $new if Mirmon::verbose ; + $url = $new ; + } + $probe =~ s/%URL%/$url/g ; + my $pipe = new IO::Pipe ; + my $handle = $pipe -> reader ( split ' ', $probe ) ; + if ( $handle ) + { $pipe -> blocking ( 0 ) ; } + else + { die "start_probe : no pipe for $url" ; } + printf "start %s\n", $url if Mirmon::verbose ; + printf " %s\n", $probe if Mirmon::debug ; + $handle ; + } + +sub finish_probe + { my $self = shift ; + my $handle = shift ; + my $res ; + my $succ = 0 ; + my $stat ; + my $time ; + + $handle -> blocking ( 1 ) ; + if ( $handle -> eof () ) + { printf "finish eof %s\n", $self -> url if Mirmon::verbose ; } + else + { $res = $handle -> getline () ; } + $handle -> flush ; + $handle -> close ; + + unless ( defined $res ) + { $stat = 'no_time' ; } + elsif ( $res =~ /^\s*$/ ) + { $stat = 'empty' ; } + else + { $res = ( split ' ', $res ) [ 0 ] ; + + if ( $res !~ /^\d+$/ ) + { $res =~ s/ /_/g ; + $res = Base::htmlquote $res ; + $res = substr ( $time, 0, 15 ) . '..' if length $res > 15 ; + $stat = "'$res'" ; + } + else + { $succ = 1 ; $stat = 'ok' ; $time = $res ; } + } + + printf "finish %s\n succ(%s) stat(%s) time(%s)\n" + , $self -> url + , $succ + , $stat + , ( defined $time ? $time : 'undef' ) + if Mirmon::verbose ; + + $self -> update ( $succ, $stat, $time ) ; + } + +sub revdom { my $dom = shift ; join '.', reverse split /\./, $dom ; } + +sub cmp + { my $a = shift ; + my $b = shift ; + ( revdom $a -> site ) cmp ( revdom $b -> site ) + or + ( $a -> type cmp $b -> type ) + ; + } + +sub _url + { my $hrf = shift ; + my $txt = shift ; + $hrf =~ /^rsync/ ? $txt : URL $hrf, $txt ; + } + +sub site_url { my $self = shift ; _url $self -> url , $self -> site ; } +sub home_url { my $self = shift ; _url $self -> home, '@' ; } + +=pod + +=head1 NAME + +Mirmon - OO interface for mirmon objects + +=head1 SYNOPSIS + + use Mirmon ; + + $m = Mirmon -> new ( [ $path-to-config ] ) + + $conf = $m -> conf ; # a Mirmon::Conf object + $state = $m -> state ; # the mirmon state + + for my $url ( keys %$state ) + { $mirror = $state -> { $url } ; # a Mirmon::Mirror object + $mail = $mirror -> mail ; # contact address + $mirror -> age ( time ) ; # set mirror age } -} -get_conf_opt; -get_ccs $CNF {countries}; -get_state $CNF {state}; -get_list $CNF {mirror_list}; -if ( $opt{get} ) { - get_dates $CNF {probe}; - put_state $CNF {state}; -} -else { %RES = %OLD } -gen_page $CNF {web_page}; + +Many class and object methods can be used to get or set attributes : + + $object -> attribute # get an atttibute + $object -> attribute ( $attr ) # set an atttibute + +=head1 Mirmon class methods + +=over 4 + +=item B + +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 mode, it doesn't. In I 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 + +Returns Mirmon's Mirmon::Conf object. + +=item B + +Returns a hashref C<< { url => mirror, ... } >>, +where I is as specified in the mirror list +and I is a Mirmon::Mirror object. + +=item B + +Returns a hashref C<< { country_code =E country_name, ... } >>. + +=item B + +Returns the list of default locations for config files. + +=item B + +Probes all mirrors if $get is C ; or a subset if $get is C. + +=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, B, B, B, B, +B, B, B, B, +B, B, B, B, B, +B, B, B, B, B. + +=item B + +Returns the file name of (the root of) the configuration file(s). + +=item B + +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 + +The url as given in the mirror list. + +=item B + +The mirror's timestamp found by the last succesful probe, +or 'undef' if no probe was ever successful. + +=item B + +The status of the last probe, or 'undef' if the mirror was never probed. + +=item B + +The timestamp of the last succesful probe or 'undef' +if the mirror was never successfully probed. + +=item B + +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 + +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 + +The timestamp of the last probe, or 'undef' if the mirror was never probed. + +=back + +=head2 object methods + +=over 4 + +=item B + +Returns the parent Mirmon object. + +=item B + +Returns the I