-# Thanks to Klaus Heinz <heinz@NetBSD.org> for sugestions ao htm_head
-my $PRG = 'mirmon';
-my $VER = '$Id: mirmon,v 1.37 2006/12/04 15:16:11 henkp Exp henkp $';
-use strict;
-use IO::Pipe;
-use IO::Select;
-use Net::hostent;
-my $DEF_CNF = "/etc/$PRG.conf";
-my %CNF = qw( timeout 300
- max_probes 25
- min_poll 1h
- max_poll 4h
- min_sync 1d
- max_sync 2d
- list_style plain
- put_histo top
- randomize 1
-);
-my @REQ_KEYS = qw( web_page state countries mirror_list probe
- project_name project_url icons
-);
-my @OPT_KEYS =
- qw( project_logo min_poll min_sync max_sync list_style htm_top htm_foot
- htm_head put_histo
-);
-my %CNF_KEYS;
-for ( @REQ_KEYS, @OPT_KEYS, keys %CNF ) { $CNF_KEYS{$_}++; }
-my $TIM_PAT = '^(\d+)([smhd])$';
-my @LIST_STYLE = qw(plain apache);
-my @GET_OPTS = qw(all update);
-my @PUT_HGRAM = qw(top bottom nowhere);
-my $HIST = 14;
-my %APA_TYPES = ();
-for (qw(backup ftp http)) { $APA_TYPES{$_}++; }
-my $prog = substr( $0, rindex( $0, '/' ) + 1 );
-my $Usage = <<USAGE ;
-Usage: $prog [ -v ] [ -q ] [ -t timeout ] [ -get opt ] [ -c conf ]
-option v : be verbose
-option q : be quiet
-option t : set timeout [ default $CNF{timeout} ] ;
-option get : 'all' : probe all sites
- : 'update' : probe a selection of the sites (see doc)
-option c : configuration file [ default $DEF_CNF ]
--------------------------------------------------------------------
-Documentation : the program contains 'pod' style documentation.
-Extract the doc with 'pod2text $prog' or 'pod2html $prog OUT', etc.
--------------------------------------------------------------------
-USAGE
-sub Usage { die "$_[0]$Usage"; }
-sub Error { die "$prog: $_[0]\n"; }
-sub Warn { warn "$prog: $_[0]\n"; }
-# usage: &GetOptions(ARG,ARG,..) defines $opt_ID as 1 or user spec'ed value
-# usage: &GetOptions(\%opt,ARG,ARG,..) defines $opt{ID} as 1 or user value
-# ARG = 'ID' | 'ID=SPC' | 'ID:SPC' for no-arg, required-arg or optional-arg
-# ID = perl identifier
-# SPC = i|f|s for integer, fixedpoint real or string argument
-use Getopt::Long;
-Getopt::Long::config('no_ignore_case');
-# Usage() unless GetOptions() ;
-my %opt = ();
-Usage() unless GetOptions( \%opt, 'v', 'q', 't=i', 'get=s', 'c=s' );
-Usage("Arg count\n") unless @ARGV >= 0;
-my %WGT;
-my $GET = IO::Select->new();
-my %URL;
-my %RES;
-my %OLD;
-my %LST;
-my %CCS;
-my %HREF;
-# <META HTTP-EQUIV=Expires CONTENT="Tue, 04 Dec 1993 21:29:02 GMT">
-sub exp_date {
- my @day = qw(Sun Mon Tue Wed Thu Fri Sat);
- my @mon = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
- my @gmt = gmtime time + 3600;
- sprintf "%s, %02d %s %4d %02d:%02d:%02d GMT", $day[ $gmt[6] ], $gmt[3],
- $mon[ $gmt[4] ], $gmt[5] + 1900, @gmt[ 2, 1, 0 ];
-}
-sub find_conf {
- return $opt{c} if $opt{c};
- my $HOME = ( getpwuid $< )[7] or Error "can get homedir '$<' ($!)";
- my @LIST = ( "$PRG.conf", "$HOME/.$PRG.conf", $DEF_CNF );
- for my $conf (@LIST) { return $conf if -f $conf; }
- Error sprintf "can't find a config file :\n %s", join "\n ", @LIST;
-}
-sub show_conf {
- print "vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv\n";
- for my $key ( sort keys %CNF ) {
- next if $key =~ m/^_/;
- print "show_conf : $key = '$CNF{$key}'\n";
- }
- for my $key ( sort keys %HREF ) {
- printf "show_conf : for site '%s' use instead\n '%s'\n", $key,
- $HREF{$key}
- if $opt{v};
- }
- printf "show_conf : included '%s'\n", join "', '", @{ $CNF{_include} };
- print "^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n";
-}
-sub get_conf;
-sub get_conf {
- my $FILE = shift;
- if ( grep $_ eq $FILE, @{ $CNF{_include} } ) {
- Error "already included : '$FILE'";
- }
- else { push @{ $CNF{_include} }, $FILE; }
- open FILE, $FILE or Error "can't open '$FILE' ($!)";
- my $CONF = join "\n", grep /./, <FILE>;
- close FILE;
- $CONF =~ s/\t/ /g; # replace tabs
- $CONF =~ s/^[+ ]+//; # delete leading space, plus
- $CONF =~ s/\n\n\s+/ /g; # glue continuation lines
- $CONF =~ s/\n\n\+\s+//g; # glue concatenation lines
- $CONF =~ s/\n\n\./\n/g; # glue concatenation lines
- chop $CONF;
- print "--$CONF--\n" if $opt{d};
- for ( grep !/^#/, split /\n\n/, $CONF ) {
- my ( $key, $val ) = split ' ', $_, 2;
- $val = '' unless defined $val;
- print "conf '$FILE' : key '$key', val '$val'\n" if $opt{d};
- if ( exists $CNF_KEYS{$key} ) { $CNF{$key} = $val; }
- elsif ( $key eq 'site_url' ) {
- my ( $site, $url ) = split ' ', $val;
- $url .= '/' unless $url =~ m!/$!;
- $HREF{ lc $site } = $url;
- printf "config : for site '%s' use instead\n '%s'\n", $site, $url
- if $opt{v};
- }
- elsif ( $key eq 'env' ) {
- my ( $x, $y ) = split ' ', $val;
- $ENV{$x} = $y;
- printf "config : setenv '%s'\n '%s'\n", $x, $y if $opt{v};
- }
- elsif ( $key eq 'no_randomize' ) { $CNF{randomize} = 0; }
- elsif ( $key eq 'include' ) { get_conf $val ; }
- elsif ( $key eq 'show' ) { show_conf unless $opt{q}; }
- elsif ( $key eq 'exit' ) { Error 'exit per config directive'; }
- elsif ( $key eq 'max_age' ) { $CNF{max_sync} = $val; }
- else {
- show_conf;
- Error "unknown keyword '$key' (value '$val')";
- }
- }
-}
-sub get_conf_opt {
- my $err = '';
- get_conf find_conf;
- $CNF{timeout} = $opt{t} if $opt{t};
- for my $key (@REQ_KEYS) {
- unless ( exists $CNF{$key} ) {
- $err .= "$prog error: missing config for '$key'\n";
- }
- }
- for my $key (qw(min_poll max_poll max_sync min_sync)) {
- my $max = $CNF{$key};
- unless ( $max =~ /$TIM_PAT/o ) {
- $err .= "$prog error: $key ($max) doesn't match /$TIM_PAT/\n";
- }
- }
- unless ( grep $CNF{list_style} eq $_, @LIST_STYLE ) {
- $err .= sprintf "%s : error: unknown 'list_style' '%s'\n", $prog,
- $CNF{list_style};
- }
- unless ( grep $CNF{put_histo} eq $_, @PUT_HGRAM ) {
- $err .= sprintf "%s : error: unknown 'put_histo' '%s'\n", $prog,
- $CNF{put_histo};
- }
- if ( $opt{get} and not grep $opt{get} eq $_, @GET_OPTS ) {
- $err .= sprintf "%s : error: unknown 'get option' '%s'\n", $prog,
- $opt{get};
- }
- Error $err if $err;
- $opt{q} = 0 if $opt{v};
-}
-sub tim_to_s {
- my $tim = shift;
- my %tab = ( 's' => 1, 'm' => 60, 'h' => 60 * 60, 'd' => 60 * 60 * 24 );
- Error "wrong time '$tim'" unless $tim =~ /$TIM_PAT/o;
- my $m = $1;
- my $u = $2;
- return $m * $tab{$u};
-}
-sub aprx_eq { my ( $t1, $t2 ) = @_; abs( $t1 - $t2 ) < 60; }
-sub aprx_ge { my ( $t1, $t2 ) = @_; $t1 > $t2 or aprx_eq $t1, $t2; }
-sub aprx_le { my ( $t1, $t2 ) = @_; $t1 < $t2 or aprx_eq $t1, $t2; }
-sub aprx_gt { my ( $t1, $t2 ) = @_; $t1 > $t2 and not aprx_eq $t1, $t2; }
-sub aprx_lt { my ( $t1, $t2 ) = @_; $t1 < $t2 and not aprx_eq $t1, $t2; }
-sub pr_interval {
- my $s = shift;
- my ( $magn, $unit );
- my $mins = $s / 60;
- my $m = int( $mins + 0.5 );
- my $hours = $s / ( 60 * 60 );
- my $h = int( $hours + 0.5 );
- if ( $s < 50 ) { $magn = $s; $unit = 'second'; }
- elsif ( $m < 50 ) { $magn = $m; $unit = 'minute'; }
- elsif ( $h < 36 ) { $magn = $h; $unit = 'hour'; }
- else { $magn = sprintf "%.1f", $hours / 24; $unit = 'day'; }
- $unit .= 's' unless $magn == 1;
- return "$magn $unit";
-}
-sub max_age1 {
- ( tim_to_s $CNF {min_sync} ) + ( tim_to_s $CNF {max_poll} );
-}
-sub max_age2 {
- ( tim_to_s $CNF {max_sync} ) + ( tim_to_s $CNF {max_poll} );
-}
-sub max_vrfy {
- ( tim_to_s $CNF {min_poll} ) + ( tim_to_s $CNF {max_poll} );
-}
-sub age_code {
- my $time = shift;
- return 'z' unless $time =~ /^\d+$/;
- return (
- ( aprx_ge( $time, $^T - max_age1 ) )
- ? 's'
- : ( aprx_ge( $time, $^T - max_age2 ) ? 'b' : 'f' )
- );
-}
-sub err {
- my $url = shift;
- my $stat = shift;
- printf "*** %-10s %s\n", $stat, $url unless $opt{q};
- my ( $time, $vrfy, $hstp, $hsts );
- if ( exists $OLD{$url} ) {
- $time = $OLD{$url}[0];
- $vrfy = $OLD{$url}[2];
- $hstp = substr $OLD{$url}[3], 1 - $HIST;
- $hsts = $OLD{$url}[4];
- }
- else {
- $time = 'undef';
- $vrfy = 'undef';
- $hstp = '';
- $hsts = '';
- }
- $RES{$url} = [ $time, $stat, $vrfy, $hstp . 'f', $hsts, $^T ];
-}
-sub res {
- my $url = shift;
- my $time = shift;
- my $stat = shift;
- my $hstp = (
- exists $OLD{$url}
- ? substr( $OLD{$url}[3], 1 - $HIST )
- : ''
- );
- my $hsts = ( exists $OLD{$url} ? $OLD{$url}[4] : '' );
- printf "result %d %s\n", $time, $url if $opt{v};
- $RES{$url} = [ $time, $stat, $^T, $hstp . 's', $hsts, $^T ];
-}
-sub get_state {
- my $STT = shift;
- open STT, $STT or Error "can't open '$STT' ($!)";
- while (<STT>) {
- chop;
- my ( $url, $time, $stat, $vrfy, $hstp, $hsts, $lprb ) = split ' ';
- $stat =~ s/_/ /g;
- $hstp = '' unless defined $hstp;
- $hsts = '' unless defined $hsts;
- $hsts = '' if $hsts eq 'undef';
- $lprb = 'undef' unless defined $lprb;
- $OLD{$url} = [ $time, $stat, $vrfy, $hstp, $hsts, $lprb ];
- }
- close STT;
-}
-sub check_hist {
- my $time = shift;
- my $hsts = shift;
- printf "check_hist: last '$time' hsts '$hsts'\n" if $opt{d};
- my $res = $hsts;
- my ( $stmp, $hist );
- if ( $hsts eq '' ) { $stmp = 0; $hist = ''; }
- else { ( $stmp, $hist ) = split '-', $hsts; }
- if ( aprx_le $stmp, $^T - tim_to_s '1d' ) {
- $res = sprintf "%s-%s%s", $^T, substr( $hist, 1 - $HIST ),
- age_code($time);
- }
- return $res;
-}
-sub put_state {
- my $STT = shift;
- my $TMP = "$STT.tmp";
- open TMP, ">$TMP" or Error "can't write '$TMP' ($!)";
- for my $url ( sort keys %RES ) {
- $RES{$url}[4] = check_hist $RES {$url}[0], $RES{$url}[4];
- my @OUT = @{ $RES{$url} };
- $OUT[1] =~ s/\s/_/g;
- printf TMP "%s %s\n", $url, join ' ', @OUT
- or Error "can't print to $TMP ($!)";
- }
- close TMP;
- if ( -z $TMP ) { Warn "wrote empty state file; keeping previous version"; }
- else { rename $TMP, $STT or Error "can't rename '$TMP', '$STT' ($!)"; }
-}
-sub get_ccs {
- my $CCS = shift;
- open CCS, $CCS or Error "can't open '$CCS' ($!)";
- while (<CCS>) {
- chop;
- next if /^#/;
- my ( $code, $dash, $reg ) = split ' ', $_, 3;
- $CCS{ lc $code } = lc $reg;
- }
- close CCS;
-}
-sub type_site {
- my $url = shift;
- my ( $type, $site, $home );
- if ( $url =~ m!^(ftp|http)://([^/:]+)(:\d+)?/! ) {
- $type = $1;
- $site = $2;
- $home = $&;
- }
- return $type, $site, $home;
-}
-sub type { my ( $t, $s, $h ) = type_site $_[0]; $t; }
-sub site { my ( $t, $s, $h ) = type_site $_[0]; $s; }
-sub home { my ( $t, $s, $h ) = type_site $_[0]; $h; }
-sub get_list {
- my $LST = shift;
- my ( $reg, $url );
- open LST, $LST or Error "can't open '$LST' ($!)";
- while (<LST>) {
- chop;
- next if /^#/;
- next if /^\s*$/;
- if ( $CNF{list_style} eq 'plain' ) {
- ( $reg, $url ) = split ' ';
- unless ( $url =~ m!/$! ) {
- print "*** mirmon appended '/' to $url\n" unless $opt{q};
- $url .= '/';
- }
- }
- elsif ( $CNF{list_style} eq 'apache' ) {
- my $apache_type;
- ( $apache_type, $reg, $url ) = split ' ';
- unless ( defined $APA_TYPES{$apache_type} ) {
- print "*** strange type : $apache_type\n" unless $opt{q};
- next;
- }
- unless ( $url =~ m!/$! ) {
- print "*** missing '/' in $url\n" unless $opt{q};
- $url .= '/';
- }
- }
- my $site = site $url ;
- my $type = type $url ;
- unless ( defined $site ) {
- print "*** strange url : '$url'\n" unless $opt{q};
- next;
- }
- $LST{$url} = [ $type, $site, $reg ];
- }
-}
-sub url { sprintf '<A HREF="%s">%s</A>', $_[0], $_[1]; }
-sub nam { sprintf '<A NAME="%s">%s</A>', $_[0], $_[1]; }
-sub SMA { sprintf "<FONT SIZE=\"-1\">%s</FONT>", $_[0]; }
-sub BLD { sprintf "<B>%s</B>", $_[0]; }
-sub NSS { sprintf SMA('%s site%s'), $_[0], ( $_[0] == 1 ? '' : 's' ); }
-sub TAB { sprintf "<TABLE BORDER=2 CELLPADDING=3>%s</TABLE>", $_[0]; }
-sub TR { sprintf "<TR>%s</TR>\n", $_[0]; }
-sub TH { sprintf "<TH>%s</TH>\n", $_[0]; }
-sub TD { sprintf "<TD>%s</TD>\n", $_[0]; }
-sub TDr { sprintf "<TD ALIGN=\"RIGHT\">%s</TD>\n", $_[0]; }
-sub RED { sprintf "<FONT COLOR=\"RED\">%s</FONT>", $_[0]; }
-sub GRN { sprintf '<FONT COLOR="GREEN">%s</FONT>', $_[0]; }
-sub htmlquote {
- my $x = shift;
- $x =~ s/&/&/g;
- $x =~ s/</</g;
- $x =~ s/>/>/g;
- return $x;
-}
-sub diff {
- my $time = shift;
- my $max = shift;
- my $res;
- if ( $time == $^T ) { $res = BLD 'renewed'; }
- else {
- $res = pr_interval $^T - $time;
- $res = BLD RED $res if aprx_lt $time, $max;
- }
- return $res;
-}
-sub img_sf_cnt {
- sprintf '<IMG BORDER=1 SRC="%s/mm%s%02d.gif" ALT="">', $CNF{icons}, $_[0],
- $_[1];
-}
-sub img_sf { img_sf_cnt $_[0], 1; }
-sub show_hist {
- my $hst = shift;
- return '' unless $hst =~ m/^[sbfz]+$/;
- if ( length $hst == $HIST and $hst =~ /^(s*b)s*$/ ) {
- return img_sf_cnt 'sb', length $1;
- }
- elsif ( length $hst == $HIST and $hst =~ /^(s*f)s*$/ ) {
- return img_sf_cnt 'sf', length $1;
- }
- elsif ( length $hst == $HIST and $hst =~ /^(s*b)fs*$/ ) {
- return img_sf_cnt 'sbf', length $1;
- }
- my $res = '';
- my $cnt = 1;
- my $prf = substr $hst, 0, 1;
- $hst = substr $hst, 1;
- while ( $hst ne '' ) {
- if ( substr( $prf, 0, 1 ) eq substr( $hst, 0, 1 ) ) {
- $cnt++;
- $hst = substr $hst, 1;
- }
- else {
- $res .= img_sf_cnt $prf, $cnt;
- $prf = substr $hst, 0, 1;
- $hst = substr $hst, 1;
- $cnt = 1;
- }
- }
- $res .= img_sf_cnt $prf, $cnt if $cnt;
- return $res;
-}
-sub show_hist_age {
- my $hsts = shift;
- my $time = shift;
- return '' if $hsts eq '';
- my ( $t, $h ) = split '-', $hsts;
- if ( aprx_lt $t, $^T ) { $h .= age_code $time ; }
- return show_hist substr $h, -$HIST;
-}
-sub gen_histogram_probes {
- my ( $time, $stat, $vrfy, $hstp, $hsts, $lprb );
- my %tab = ();
- my %bad = ();
- my $res = '';
- my $s_cnt = 0;
- my $f_cnt = 0;
- my $hr_min;
- my $hr_max;
- return '' unless scalar keys %RES;
- for my $url ( keys %RES ) {
- ( $time, $stat, $vrfy, $hstp, $hsts, $lprb ) = @{ $RES{$url} };
- my $hr = int( ( $^T - $lprb ) / 3600 + 0.5 );
- $hr_min = $hr if !defined $hr_min or $hr < $hr_min;
- $hr_max = $hr if !defined $hr_max or $hr > $hr_max;
- if ( $stat eq 'ok' ) { $tab{$hr}++; $s_cnt++; }
- else { $bad{$hr}++; $f_cnt++; }
- }
- $res = TR(
- TH('hours ago')
- . TH('succ')
- . TH('fail')
- . TH sprintf( '%s %s, %s %s',
- $s_cnt, GRN('successful'), $f_cnt, RED('failed') )
- );
- my $max = 0;
- for my $x ( keys %tab ) {
- my $tot = $tab{$x} + ( $bad{$x} || 0 );
- $max = $tot if $max < $tot;
- }
- return "<BLOCKQUOTE>\nnothing yet\n</BLOCKQUOTE>\n" unless $max;
- for my $hr ( $hr_min .. $hr_max ) {
- my $x = $tab{$hr} || 0;
- my $y = $bad{$hr} || 0;
- my $n = int( $x / $max * $HIST );
- my $b = int( $y / $max * $HIST );
- $res .= TR(
- TDr($hr)
- . TDr($x)
- . TDr($y)
- . TD(
- ( $n ? img_sf_cnt( 's', $n ) : '' )
- . ( $b ? img_sf_cnt( 'f', $b ) : '' )
- . ( ( $n + $b ) ? '' : ' ' )
+# Thanks to Klaus Heinz <heinz@NetBSD.org> for sugestions ao htm_head ;
+# Peter Pöml for MirrorBrain support ; Jeremy Olexa, Karl Berry, Roland
+# Pelzer for suggestions regarding rsync support.
+
+use strict ;
+
+our $PRG = 'mirmon' ;
+our $VER = "2.3" ;
+
+our $DEF_TIMEOUT = 300 ;
+our $HIST = 14 ;
+our $TIM_PAT = '^(\d+)([smhd])$' ;
+our %APA_TYPES = () ; for ( qw(backup ftp http) ) { $APA_TYPES { $_ } ++ ; }
+our %GET_OPTS = () ; for ( qw(all update) ) { $GET_OPTS { $_ } ++ ; }
+our $HIST_DELTA = 24 * 60 * 60 ;
+our $APRX_DELTA = 60 ;
+our $HOME = 'http://www.cs.uu.nl/people/henkp/mirmon/' ;
+
+package Base ; #####################################################
+
+use base 'Exporter' ;
+
+our ( @ISA, @EXPORT ) ;
+BEGIN
+ { @ISA = qw(Exporter) ;
+ @EXPORT =
+ qw(aprx_eq aprx_ge aprx_le aprx_gt aprx_lt
+ URL NAM SMA BLD NSS TAB BQ TR TH TD TDr RED GRN H1 H2 H3
+ s4tim pr_interval pr_diff
+ ) ;
+ }
+
+sub Version { "$PRG version $VER" ; }
+sub version { "$PRG-$VER" ; }
+sub DEF_TIMEOUT { $DEF_TIMEOUT ; }
+sub is_get_opt { my $opt = shift ; exists $GET_OPTS { $opt } ; }
+
+sub getset
+ { my $self = shift ;
+ my $attr = shift ;
+ if ( @_ ) { $self -> { $attr } = shift ; }
+ die "no attr '$attr'" unless exists $self -> { $attr } ;
+ $self -> { $attr } ;
+ }
+
+sub mk_method
+ { my $self = shift ;
+ my $attr = shift ;
+ sprintf 'sub %s { my $self = shift ; $self -> getset ( "%s", @_ ) ; }'
+ , $attr, $attr ;
+ }
+
+sub mk_methods
+ { my $self = shift ;
+ join "\n", map { Base -> mk_method ( $_ ) ; } @_ ;
+ }
+
+sub aprx_eq { my ( $t1, $t2 ) = @_ ; abs ( $t1 - $t2 ) < $APRX_DELTA ; }
+sub aprx_ge { my ( $t1, $t2 ) = @_ ; $t1 > $t2 or aprx_eq $t1, $t2 ; }
+sub aprx_le { my ( $t1, $t2 ) = @_ ; $t1 < $t2 or aprx_eq $t1, $t2 ; }
+sub aprx_gt { my ( $t1, $t2 ) = @_ ; $t1 > $t2 and not aprx_eq $t1, $t2 ; }
+sub aprx_lt { my ( $t1, $t2 ) = @_ ; $t1 < $t2 and not aprx_eq $t1, $t2 ; }
+
+sub URL { sprintf '<A HREF="%s">%s</A>', $_[0], $_[1] ; }
+sub NAM { sprintf '<A NAME="%s">%s</A>', $_[0], $_[1] ; }
+sub SMA { sprintf "<FONT SIZE=\"-1\">%s</FONT>", $_[0] ; }
+sub BLD { sprintf "<B>%s</B>", $_[0] ; }
+sub NSS { sprintf SMA('%s site%s'), $_[0], ( $_[0] == 1 ? '' : 's' ) ; }
+sub TAB { sprintf "<TABLE BORDER=2 CELLPADDING=3>%s</TABLE>", $_[0] ; }
+sub BQ { sprintf "<BLOCKQUOTE>\n%s\n</BLOCKQUOTE>\n", $_[0] ; }
+sub TR { sprintf "<TR>%s</TR>\n", $_[0] ; }
+sub TH { sprintf "<TH>%s</TH>\n", $_[0] ; }
+sub TD { sprintf "<TD>%s</TD>\n", $_[0] ; }
+sub H1 { sprintf "<H1>%s</H1>\n", $_[0] ; }
+sub H2 { sprintf "<H2>%s</H2>\n", $_[0] ; }
+sub H3 { sprintf "<H3>%s</H3>\n", $_[0] ; }
+sub TDr { sprintf "<TD ALIGN=\"RIGHT\">%s</TD>\n", $_[0] ; }
+sub RED { sprintf "<FONT COLOR=\"RED\">%s</FONT>", $_[0] ; }
+sub GRN { sprintf '<FONT COLOR="GREEN">%s</FONT>', $_[0] ; }
+
+sub s4tim
+ { my $tim = shift ;
+ my %tab = ( 's' => 1, 'm' => 60, 'h' => 60 * 60, 'd' => 60 * 60 * 24 ) ;
+ die "wrong time '$tim'" unless $tim =~ /$TIM_PAT/o ;
+ my $m = $1 ; my $u = $2 ;
+ return $m * $tab { $u } ;
+ }
+
+sub pr_interval
+ { my $s = shift ;
+ my ( $magn, $unit ) ;
+ my $mins = $s / 60 ; my $m = int ( $mins + 0.5 ) ;
+ my $hours = $s / ( 60 * 60 ) ; my $h = int ( $hours + 0.5 ) ;
+
+ if ( $s < 50 )
+ { $magn = $s ; $unit = 'second' ; }
+ elsif ( $m < 50 )
+ { $magn = $m ; $unit = 'minute' ; }
+ elsif ( $h < 36 )
+ { $magn = $h ; $unit = 'hour' ; }
+ else
+ { $magn = sprintf "%.1f", $hours / 24 ; $unit = 'day' ; }
+
+ $unit .= 's' unless $magn == 1 ;
+
+ return "$magn $unit" ;
+ }
+
+sub pr_diff
+ { my $time = shift ;
+ my $max = shift ;
+ my $res ;
+
+ if ( $time == $^T )
+ { $res = BLD 'renewed' ; }
+ else
+ { $res = pr_interval $^T - $time ;
+ $res = BLD RED $res if aprx_lt $time, $max ;
+ }
+ return $res ;
+ }
+
+sub exp_date
+ { my @day = qw(Sun Mon Tue Wed Thu Fri Sat) ;
+ my @mon = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec) ;
+ my @gmt = gmtime time + 3600 ;
+ sprintf "%s, %02d %s %4d %02d:%02d:%02d GMT"
+ , $day [ $gmt [ 6 ] ]
+ , $gmt [ 3 ]
+ , $mon [ $gmt [ 4 ] ]
+ , $gmt [ 5 ] + 1900
+ , @gmt [ 2, 1, 0 ]
+ ;
+ }
+
+sub htmlquote
+ { my $x = shift ;
+ $x =~ s/&/&/g ;
+ $x =~ s/</</g ;
+ $x =~ s/>/>/g ;
+ return $x ;
+ }
+
+package Mirmon ; ###################################################
+
+BEGIN { use base 'Base' ; Base -> import () ; }
+
+use IO::Select ;
+use Net::hostent ;
+
+ { my %opt = ( v => 0 , d => 0 , q => 0 ) ;
+ sub _opt
+ { my ( $key, $val ) = @_ ;
+ my $res ;
+ unless ( exists $opt { $key } )
+ { warn "unknown Mirmon option '$key'\n" ; }
+ else
+ { $res = $opt { $key } ;
+ $opt { $key } = $val if defined $val ;
+ }
+ $res ;
+ }
+ }
+
+sub verbose { _opt ( 'v', shift ) ; }
+sub quiet { _opt ( 'q', shift ) ; }
+sub debug { _opt ( 'd', shift ) ; }
+
+eval Base -> mk_methods ( qw(conf state regions) ) ;
+
+sub config_list
+ { my $self = shift ;
+ my $home = ( getpwuid $< ) [ 7 ] or die "can get homedir '$<' ($!)" ;
+ ( 'mirmon.conf', "$home/.mirmon.conf", '/etc/mirmon.conf' ) ;
+ }
+
+sub new
+ { my $self = shift ;
+ my $path = shift ;
+ my $res = bless {}, $self ;
+ $res -> get_config ( $path ) ;
+ $res -> get_state ;
+ $res -> get_regions ;
+ $res ;
+ }
+
+sub find_config
+ { my $self = shift ;
+ my $arg = shift ;
+ my @LIST = $arg ? ( $arg ) : Mirmon -> config_list ;
+ for my $conf ( @LIST ) { return $conf if -f $conf ; }
+ die sprintf "can't find a config file :\n %s\n" , join "\n ", @LIST ;
+ }
+
+sub get_config
+ { my $self = shift ;
+ my $path = shift ;
+ my $file = $self -> find_config ( $path ) ; # or die
+ $self -> conf ( Mirmon::Conf -> new ( $file ) ) ;
+ }
+
+sub get_state
+ { my $self = shift ;
+ my $conf = $self -> conf ;
+ my $state = $conf -> state ;
+ my $res = {} ;
+ open STATE, $state or die "can't open $state ($!)" ;
+ for my $line ( <STATE> )
+ { chop $line ;
+ my $mirror = Mirmon::Mirror -> new ( $self, $line ) ;
+ $res -> { $mirror -> url } = $mirror ;
+ }
+ close STATE ;
+
+ my $mlist = $conf -> mirror_list ;
+ my $style = $conf -> list_style ;
+ my %in_list = () ;
+ open MLIST, $mlist or die "can't open $mlist ($!)" ;
+ for my $line ( <MLIST> )
+ { chop $line ;
+ next if $line =~ /^#/ ;
+ next if $line =~ /^\s*$/ ;
+ my ( $reg, $url, $mail ) ;
+ if ( $style eq 'plain' )
+ { ( $reg, $url, $mail ) = split ' ', $line ; }
+ elsif ( $style eq 'apache' )
+ { my $apache_type ;
+ ( $apache_type, $reg, $url, $mail ) = split ' ', $line ;
+ unless ( defined $APA_TYPES { $apache_type } )
+ { print "*** strange type in $url ($apache_type)\n"
+ unless Mirmon::quiet ;
+ next ;
+ }
+ }
+
+ if ( $conf -> add_slash and $url !~ m!/$! )
+ { print "*** appended '/' to $url\n" unless Mirmon::quiet ;
+ $url .= '/' ;
+ }
+
+ $in_list { $url } ++ ;
+
+ unless ( exists $res -> { $url } )
+ { printf "*** added to list %s\n", $url unless Mirmon::quiet ;
+ $res -> { $url } = Mirmon::Mirror -> init ( $self, $url ) ;
+ }
+ my $mirror = $res -> { $url } ;
+ $mirror -> region ( $reg ) ;
+ $mirror -> mail ( $mail || '' ) ;
+ }
+ close MLIST ;
+
+ for my $url ( sort keys %$res )
+ { # printf "%s\n", $res -> { $url } -> state ;
+ unless ( exists $in_list { $url } )
+ { printf "*** removed from list %s\n", $url unless Mirmon::quiet ;
+ delete $res -> { $url } ;
+ }
+ }
+ $self -> state ( $res ) ;
+ }
+
+sub put_state
+ { my $self = shift ;
+ my $state = $self -> state ;
+ my $file = $self -> conf -> state ;
+ my $TMP = "$file.tmp" ;
+ open TMP, ">$TMP" or die "can't write '$TMP' ($!)" ;
+ for my $url ( sort keys %$state )
+ { printf TMP "%s\n", $state -> { $url } -> state
+ or die "can't print $url to $TMP ($!)" ;
+ }
+ close TMP ;
+
+ if ( -z $TMP )
+ { warn "wrote empty state file; keeping previous version" ; }
+ else
+ { rename $TMP, $file or die "can't rename '$TMP', '$file' ($!)" ; }
+ }
+
+sub get_regions
+ { my $self = shift ;
+ my $file = $self -> conf -> countries ;
+ open REGS, $file or die "can't open countries '$file' ($!)" ;
+ while ( <REGS> )
+ { chop ;
+ next if /^#/ ;
+ my ( $code, $dash, $reg ) = split ' ', $_, 3 ;
+ $self -> { regions } { lc $code } = lc $reg ;
+ }
+ close REGS ;
+ }
+
+sub get_dates
+ { my $self = shift ;
+ my $get = shift ;
+ my $state = $self -> state ;
+ my $conf = $self -> conf ;
+ my $CMD = $conf -> probe ;
+ my $PAR = $conf -> max_probes ;
+ my %m4h = () ;
+ my @QUE = () ;
+ my @NOQ = () ;
+ my $GET = IO::Select -> new () ;
+
+ my $cnt = 0 ;
+ my $nok = 0 ;
+
+ for my $url ( sort keys %$state )
+ { my $mirror = $state -> { $url } ;
+ $cnt ++ if $mirror -> last_status eq 'ok' ;
+ if ( $get eq 'all' or $mirror -> last_probe eq 'undef' )
+ { push @QUE, $mirror ; }
+ elsif ( $get eq 'update' )
+ { my $stat = $mirror -> last_status ;
+ my $vrfy = $mirror -> last_ok_probe ;
+ my $lprb = $mirror -> last_probe ;
+ if ( aprx_le $lprb, $^T - s4tim $conf -> min_poll )
+ { if ( $stat ne 'ok' )
+ { push @QUE, $mirror ; $nok ++ ; }
+ elsif ( aprx_le $vrfy, $^T - s4tim $conf -> max_poll )
+ { push @QUE, $mirror ; }
+ else
+ { push @NOQ, $mirror ; }
+ }
+ }
+ else
+ { die "unknown opt_get '$get'" ; }
+ }
+
+ if ( Mirmon::verbose )
+ { my $que = scalar @QUE ; my $noq = scalar @NOQ ;
+ printf "ok mirrors %d, queued %d, not queued %d, ok %d, nok %d\n"
+ , $cnt, $que, $noq, $que - $nok, $nok
+ }
+
+ if ( $conf -> randomize )
+ { my $hrs = int ( ( s4tim $conf -> max_poll ) / 60 / 60 + 0.5 ) ;
+ my $avg = int ( $cnt / $hrs + 0.5 ) ;
+ my $prc = ( scalar keys %$state ) / 50 ;
+ my $flr = int $prc ;
+ my $extras = $flr + ( rand 1 < ( $prc - $flr ) ) ;
+ my $picked = 0 ;
+
+ while ( @QUE < $avg + $nok and @NOQ and $picked < $extras )
+ { my $idx = int rand @NOQ ;
+ push @QUE, $NOQ [ $idx ] ;
+ $NOQ [ $idx ] = $NOQ [ $#NOQ ] ;
+ pop @NOQ ;
+ $picked ++ ;
+ }
+
+ printf "avg mirrors/hr %d, max extras %d, picked %d ; queued %s\n"
+ , $avg, $extras, $picked, scalar @QUE if Mirmon::verbose ;
+ }
+
+ while ( @QUE )
+ { my $started = 0 ;
+ while ( $GET -> count () < $PAR and @QUE )
+ { my $mirror = shift @QUE ;
+ if ( gethost $mirror -> site )
+ { my $handle = $mirror -> start_probe ;
+ $m4h { $handle } = $mirror ;
+ $GET -> add ( $handle ) ;
+ $started ++ ;
+ }
+ else
+ { $mirror -> update ( 0, 'site_not_found', undef ) ; }
+ }
+
+ my @can_read = $GET -> can_read ( 0 ) ;
+
+ printf "queue %d, started %d, probes %d, can_read %d\n",
+ scalar @QUE, $started, $GET -> count (), scalar @can_read
+ if Mirmon::verbose ;
+
+ for my $handle ( @can_read )
+ { # order is important ; wget's hang if/when actions are reversed
+ $GET -> remove ( $handle ) ;
+ $m4h { $handle } -> finish_probe ( $handle ) ;
+ }
+
+ sleep 1 ;
+ }
+
+ my $stop = time + $conf -> timeout + 10 ;
+
+ while ( $GET -> count () and time < $stop )
+ { my @can_read = $GET -> can_read ( 0 ) ;
+
+ printf "wait %2d, probes %d, can_read %d\n",
+ $stop - scalar time, $GET -> count (), scalar @can_read
+ if Mirmon::verbose ;
+
+ for my $handle ( @can_read )
+ { $GET -> remove ( $handle ) ;
+ $m4h { $handle } -> finish_probe ( $handle ) ;
+ }
+
+ sleep 10 ;
+ }
+
+ for my $handle ( $GET -> handles () )
+ { $m4h { $handle } -> update ( 0, 'hangs', undef ) ; }
+ }
+
+sub img_sf_cnt
+ { my $self = shift ;
+ my $prf = shift ;
+ my $cnt = shift ;
+ my $res ;
+ if ( $prf eq 'x' )
+ { sprintf
+ ( '<IMG BORDER=1 SRC="%s/bar.gif" ALT="">'
+ , $self -> conf -> icons
+ ) x $cnt ;
+ }
+ else
+ { sprintf '<IMG BORDER=1 SRC="%s/mm%s%02d.gif" ALT="">'
+ , $self -> conf -> icons, $prf, $cnt ;
+ }
+ }
+
+sub img_sf { my $self = shift ; $self -> img_sf_cnt ( $_[0], 1 ) ; }
+
+sub show_hist
+ { my $self = shift ;
+ my $hst = shift ;
+ if ( $hst =~ /-(.*)$/ ) { $hst = $1 ; }
+ return '' unless $hst =~ m/^[sbfzx]+$/ ;
+ if ( length $hst == $HIST and $hst =~ /^(s*b)s*$/ )
+ { return $self -> img_sf_cnt ( 'sb', length $1 ) ; }
+ elsif ( length $hst == $HIST and $hst =~ /^(s*f)s*$/ )
+ { return $self -> img_sf_cnt ( 'sf', length $1 ) ; }
+ elsif ( length $hst == $HIST and $hst =~ /^(s*b)fs*$/ )
+ { return $self -> img_sf_cnt ( 'sbf', length $1 ) ; }
+ my $res = '' ;
+ my $cnt = 1 ;
+ my $prf = substr $hst, 0, 1 ;
+ $hst = substr $hst, 1 ;
+ while ( $hst ne '' )
+ { if ( substr ( $prf, 0, 1 ) eq substr ( $hst, 0, 1 ) )
+ { $cnt ++ ;
+ $hst = substr $hst, 1 ;
+ }
+ else
+ { $res .= $self -> img_sf_cnt ( $prf, $cnt ) ;
+ $prf = substr $hst, 0, 1 ;
+ $hst = substr $hst, 1 ;
+ $cnt = 1 ;
+ }
+ }
+ $res .= $self -> img_sf_cnt ( $prf, $cnt ) if $cnt ;
+ $res ;
+ }
+
+sub gen_histogram_probes
+ { my $self = shift ;
+ my $state = $self -> state ;
+ my %tab = () ;
+ my %bad = () ;
+ my $res = '' ;
+ my $s_cnt = 0 ;
+ my $f_cnt = 0 ;
+ my $hr_min ;
+ my $hr_max ;
+ for my $url ( keys %$state )
+ { my $mirror = $state -> { $url } ;
+ my $lprb = $mirror -> last_probe ;
+ my $stat = $mirror -> last_status ;
+ next if $lprb eq 'undef' ;
+ my $hr = int ( ( $^T - $lprb ) / 3600 + 0.5 ) ;
+ $hr_min = $hr if ! defined $hr_min or $hr < $hr_min ;
+ $hr_max = $hr if ! defined $hr_max or $hr > $hr_max ;
+ if ( $stat eq 'ok' )
+ { $tab { $hr } ++ ; $s_cnt ++ ; }
+ else
+ { $bad { $hr } ++ ; $f_cnt ++ ; }
+ }
+ return BQ 'nothing yet' unless scalar keys %tab ;
+
+ $res = TR
+ ( TH ( 'hours ago' )
+ . TH ( 'succ' )
+ . TH ( 'fail' )
+ . TH sprintf
+ ( '%s %s, %s %s'
+ , $s_cnt , GRN ( 'successful' )
+ , $f_cnt , RED ( 'failed' )
+ )
+ ) ;
+
+ my $max = 0 ;
+ for my $x ( keys %tab )
+ { my $tot = $tab { $x } + ( $bad { $x } || 0 ) ;
+ $max = $tot if $max < $tot ;
+ }
+
+ return BQ "nothing yet" unless $max ;
+
+ for my $hr ( $hr_min .. $hr_max )
+ { my $x = $tab { $hr } || 0 ;
+ my $y = $bad { $hr } || 0 ;
+ my $n = int ( $x / $max * $HIST ) ;
+ my $b = int ( $y / $max * $HIST ) ;
+ $res .= TR
+ ( TDr ( $hr )
+ . TDr ( $x )
+ . TDr ( $y )
+ . TD
+ ( ( $n ? $self -> img_sf_cnt ( 's', $n ) : '' )
+ . ( $b ? $self -> img_sf_cnt ( 'f', $b ) : '' )
+ . ( ( $n + $b ) ? '' : ' ' )
git://git.exim.org / mirror-monitor.git / commitdiff