mirmon/mirmon

   1 #! /usr/bin/perl -w
   2 #    $Cambridge$
   3 #
   4 # Copyright (c) 2003 Henk Penning, all rights reserved.
   5 # penning@cs.uu.nl, http://www.cs.uu.nl/staff/henkp.html
   6 # Version 1.1 was donated to the Apache Software Foundation 2003 Jan 28
   7 # $Id: mirmon,v 1.37 2006/12/04 15:16:11 henkp Exp henkp $
   8 # Permission is hereby granted, free of charge, to any person obtaining a
   9 # copy of this software and associated documentation files (the "Software"),
  10 # to deal in the Software without restriction, including without limitation
  11 # the rights to use, copy, modify, merge, publish, distribute, sublicense,
  12 # and/or sell copies of the Software, and to permit persons to whom the
  13 # Software is furnished to do so, subject to the following conditions:
  14 #
  15 # The above copyright notice and this permission notice shall be included in
  16 # all copies or substantial portions of the Software.
  17 #
  18 # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  19 # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  20 # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
  21 # THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  22 # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  23 # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  24 # DEALINGS IN THE SOFTWARE.
  25 #
  26 # Thanks to Klaus Heinz <heinz@NetBSD.org> for sugestions ao htm_head
  27
  28 my $PRG = 'mirmon' ;
  29 my $VER = '$Id: mirmon,v 1.37 2006/12/04 15:16:11 henkp Exp henkp $' ;
  30
  31 use strict ;
  32 use IO::Pipe ;
  33 use IO::Select ;
  34 use Net::hostent ;
  35
  36 my $DEF_CNF = "/etc/$PRG.conf" ;
  37
  38 my %CNF =
  39   qw( timeout    300
  40       max_probes 25
  41       min_poll   1h
  42       max_poll   4h
  43       min_sync   1d
  44       max_sync   2d
  45       list_style plain
  46       put_histo  top
  47       randomize  1
  48     ) ;
  49
  50 my @REQ_KEYS =
  51   qw( web_page state countries mirror_list probe
  52       project_name project_url icons
  53     ) ;
  54 my @OPT_KEYS =
  55   qw( project_logo min_poll min_sync max_sync list_style htm_top htm_foot
  56       htm_head put_histo
  57     ) ;
  58 my %CNF_KEYS ; for ( @REQ_KEYS, @OPT_KEYS, keys %CNF )
  59   { $CNF_KEYS { $_ } ++ ; }
  60
  61 my $TIM_PAT = '^(\d+)([smhd])$' ;
  62 my @LIST_STYLE = qw(plain apache) ;
  63 my @GET_OPTS   = qw(all update) ;
  64 my @PUT_HGRAM  = qw(top bottom nowhere) ;
  65 my $HIST       = 14 ;
  66 my %APA_TYPES  = () ; for ( qw(backup ftp http) ) { $APA_TYPES { $_ } ++ ; }
  67
  68 my $prog = substr($0,rindex($0,'/')+1) ;
  69 my $Usage = <<USAGE ;
  70 Usage: $prog [ -v ] [ -q ] [ -t timeout ] [ -get opt ] [ -c conf ]
  71 option v   : be verbose
  72 option q   : be quiet
  73 option t   : set timeout [ default $CNF{timeout} ] ;
  74 option get : 'all'    : probe all sites
  75            : 'update' : probe a selection of the sites (see doc)
  76 option c   : configuration file [ default $DEF_CNF ]
  77 -------------------------------------------------------------------
  78 Documentation : the program contains 'pod' style documentation.
  79 Extract the doc with 'pod2text $prog' or 'pod2html $prog OUT', etc.
  80 -------------------------------------------------------------------
  81 USAGE
  82 sub Usage { die "$_[0]$Usage" ; }
  83 sub Error { die "$prog: $_[0]\n" ; }
  84 sub Warn  { warn "$prog: $_[0]\n" ; }
  85
  86 # usage: &GetOptions(ARG,ARG,..) defines $opt_ID as 1 or user spec'ed value
  87 # usage: &GetOptions(\%opt,ARG,ARG,..) defines $opt{ID} as 1 or user value
  88 # ARG = 'ID' | 'ID=SPC' | 'ID:SPC' for no-arg, required-arg or optional-arg
  89 # ID  = perl identifier
  90 # SPC = i|f|s for integer, fixedpoint real or string argument
  91
  92 use Getopt::Long ;
  93 Getopt::Long::config('no_ignore_case') ;
  94 # Usage() unless GetOptions() ;
  95 my %opt = () ; Usage() unless GetOptions (\%opt,'v','q','t=i','get=s','c=s') ;
  96 Usage("Arg count\n") unless @ARGV >= 0 ;
  97
  98 my %WGT ;
  99 my $GET = IO::Select -> new () ;
 100 my %URL ;
 101 my %RES ;
 102 my %OLD ;
 103 my %LST ;
 104 my %CCS ;
 105 my %HREF ;
 106
 107 # <META HTTP-EQUIV=Expires CONTENT="Tue, 04 Dec 1993 21:29:02 GMT">
 108 sub exp_date
 109   { my @day = qw(Sun Mon Tue Wed Thu Fri Sat) ;
 110     my @mon = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec) ;
 111     my @gmt = gmtime time + 3600 ;
 112     sprintf "%s, %02d %s %4d %02d:%02d:%02d GMT"
 113       , $day [ $gmt [ 6 ] ]
 114       , $gmt [ 3 ]
 115       , $mon [ $gmt [ 4 ] ]
 116       , $gmt [ 5 ] + 1900
 117       , @gmt [ 2, 1, 0 ]
 118       ;
 119   }
 120
 121 sub find_conf
 122   { return $opt{c} if $opt{c} ;
 123     my $HOME = ( getpwuid $< ) [ 7 ] or Error "can get homedir '$<' ($!)" ;
 124     my @LIST = ( "$PRG.conf" , "$HOME/.$PRG.conf" , $DEF_CNF ) ;
 125     for my $conf ( @LIST ) { return $conf if -f $conf ; }
 126     Error sprintf "can't find a config file :\n  %s" , join "\n  ", @LIST ;
 127   }
 128
 129 sub show_conf
 130   { print "vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv\n" ;
 131     for my $key ( sort keys %CNF )
 132       { next if $key =~ m/^_/ ;
 133         print "show_conf : $key = '$CNF{$key}'\n" ;
 134       }
 135     for my $key ( sort keys %HREF )
 136       { printf "show_conf : for site '%s' use instead\n   '%s'\n",
 137           $key, $HREF { $key } if $opt{v} ;
 138       }
 139     printf "show_conf : included '%s'\n", join "', '", @{ $CNF{_include} } ;
 140     print "^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n" ;
 141   }
 142
 143 sub get_conf ;
 144
 145 sub get_conf
 146   { my $FILE = shift ;
 147
 148     if ( grep $_ eq $FILE,  @{ $CNF {_include} } )
 149       { Error "already included : '$FILE'" ; }
 150     else
 151       { push @{ $CNF {_include} }, $FILE ; }
 152
 153     open FILE, $FILE or Error "can't open '$FILE' ($!)" ;
 154     my $CONF = join "\n", grep /./, <FILE> ;
 155     close FILE ;
 156
 157     $CONF =~ s/\t/ /g ;           # replace tabs
 158     $CONF =~ s/^[+ ]+// ;         # delete leading space, plus
 159     $CONF =~ s/\n\n\s+/ /g ;      # glue continuation lines
 160     $CONF =~ s/\n\n\+\s+//g ;     # glue concatenation lines
 161     $CONF =~ s/\n\n\./\n/g ;      # glue concatenation lines
 162
 163     chop $CONF ;
 164     print "--$CONF--\n" if  $opt{d} ;
 165     for ( grep ! /^#/, split /\n\n/, $CONF )
 166       { my ($key,$val) = split ' ', $_, 2 ;
 167         $val = '' unless defined $val ;
 168         print "conf '$FILE' : key '$key', val '$val'\n" if $opt{d} ;
 169     if ( exists $CNF_KEYS { $key } )
 170       { $CNF { $key } = $val ; }
 171     elsif ( $key eq 'site_url' )
 172       { my ( $site, $url ) = split ' ' , $val ;
 173         $url .= '/' unless $url =~ m!/$! ;
 174         $HREF { lc $site } = $url ;
 175         printf "config : for site '%s' use instead\n   '%s'\n",
 176           $site, $url if $opt{v} ;
 177       }
 178     elsif ( $key eq 'env' )
 179       { my ( $x, $y ) = split ' ' , $val ;
 180         $ENV { $x } = $y ;
 181         printf "config : setenv '%s'\n   '%s'\n", $x, $y if $opt{v} ;
 182       }
 183     elsif ( $key eq 'no_randomize' )
 184       { $CNF { randomize } = 0 ; }
 185     elsif ( $key eq 'include' )
 186       { get_conf $val ; }
 187     elsif ( $key eq 'show' )
 188       { show_conf unless $opt{q} ; }
 189     elsif ( $key eq 'exit' )
 190       { Error 'exit per config directive' ; }
 191     elsif ( $key eq 'max_age' )
 192       { $CNF { max_sync } = $val ; }
 193     else
 194       { show_conf ;
 195         Error "unknown keyword '$key' (value '$val')" ;
 196       }
 197       }
 198   }
 199
 200 sub get_conf_opt
 201   { my $err = '' ;
 202     get_conf find_conf ;
 203     $CNF { timeout } = $opt{t} if $opt{t} ;
 204     for my $key ( @REQ_KEYS )
 205       { unless ( exists $CNF { $key } )
 206           { $err .= "$prog error: missing config for '$key'\n" ; }
 207       }
 208     for my $key ( qw(min_poll max_poll max_sync min_sync) )
 209       { my $max = $CNF { $key } ;
 210         unless ( $max =~ /$TIM_PAT/o )
 211           { $err .= "$prog error: $key ($max) doesn't match /$TIM_PAT/\n" ; }
 212       }
 213     unless ( grep $CNF { list_style } eq $_, @LIST_STYLE )
 214       { $err .= sprintf "%s : error: unknown 'list_style' '%s'\n",
 215           $prog, $CNF { list_style } ;
 216       }
 217     unless ( grep $CNF { put_histo } eq $_, @PUT_HGRAM )
 218       { $err .= sprintf "%s : error: unknown 'put_histo' '%s'\n",
 219           $prog, $CNF { put_histo } ;
 220       }
 221     if ( $opt { get } and not grep $opt { get } eq $_, @GET_OPTS )
 222       { $err .= sprintf "%s : error: unknown 'get option' '%s'\n",
 223           $prog, $opt { get } ;
 224       }
 225     Error $err if $err ;
 226     $opt{q} = 0 if $opt{v} ;
 227   }
 228
 229 sub tim_to_s
 230   { my $tim = shift ;
 231     my %tab = ( 's' => 1, 'm' => 60, 'h' => 60 * 60, 'd' => 60 * 60 * 24 ) ;
 232     Error "wrong time '$tim'" unless $tim =~ /$TIM_PAT/o ;
 233     my $m = $1 ; my $u = $2 ;
 234     return $m * $tab { $u } ;
 235   }
 236
 237 sub aprx_eq { my ( $t1, $t2 ) = @_ ; abs ( $t1 - $t2 ) < 60 ; }
 238 sub aprx_ge { my ( $t1, $t2 ) = @_ ; $t1 > $t2 or      aprx_eq $t1, $t2 ; }
 239 sub aprx_le { my ( $t1, $t2 ) = @_ ; $t1 < $t2 or      aprx_eq $t1, $t2 ; }
 240 sub aprx_gt { my ( $t1, $t2 ) = @_ ; $t1 > $t2 and not aprx_eq $t1, $t2 ; }
 241 sub aprx_lt { my ( $t1, $t2 ) = @_ ; $t1 < $t2 and not aprx_eq $t1, $t2 ; }
 242
 243 sub pr_interval
 244   { my $s  = shift ;
 245     my ( $magn, $unit ) ;
 246     my $mins  = $s / 60          ; my $m = int ( $mins + 0.5 ) ;
 247     my $hours = $s / ( 60 * 60 ) ; my $h = int ( $hours + 0.5 ) ;
 248
 249     if ( $s < 50 )
 250       { $magn = $s ; $unit = 'second' ; }
 251     elsif ( $m < 50 )
 252       { $magn = $m ; $unit = 'minute' ; }
 253     elsif ( $h < 36 )
 254       { $magn = $h ; $unit = 'hour' ; }
 255     else
 256       { $magn = sprintf "%.1f", $hours / 24 ; $unit = 'day' ; }
 257
 258     $unit .= 's' unless $magn == 1 ;
 259
 260     return "$magn $unit" ;
 261   }
 262
 263 sub max_age1
 264   { ( tim_to_s $CNF { min_sync } ) + ( tim_to_s $CNF { max_poll } ) ; }
 265 sub max_age2
 266   { ( tim_to_s $CNF { max_sync } ) + ( tim_to_s $CNF { max_poll } ) ; }
 267
 268 sub max_vrfy
 269   { ( tim_to_s $CNF { min_poll } ) + ( tim_to_s $CNF { max_poll } ) ; }
 270
 271 sub age_code
 272   { my $time = shift ;
 273     return 'z' unless $time =~ /^\d+$/ ;
 274     return
 275       ( ( aprx_ge ( $time, $^T - max_age1 ) )
 276       ? 's'
 277       : ( aprx_ge ( $time, $^T - max_age2 ) ? 'b' : 'f' )
 278       ) ;
 279   }
 280
 281 sub err
 282   { my $url = shift ;
 283     my $stat = shift ;
 284     printf "*** %-10s %s\n", $stat, $url unless $opt{q} ;
 285     my ( $time, $vrfy, $hstp, $hsts ) ;
 286     if ( exists $OLD { $url } )
 287       { $time = $OLD { $url } [ 0 ] ;
 288         $vrfy = $OLD { $url } [ 2 ] ;
 289     $hstp = substr $OLD { $url } [ 3 ], 1 - $HIST ;
 290         $hsts = $OLD { $url } [ 4 ] ;
 291       }
 292     else
 293       { $time = 'undef' ;
 294         $vrfy = 'undef' ;
 295     $hstp = '' ;
 296         $hsts = '' ;
 297       }
 298     $RES { $url } = [ $time, $stat, $vrfy, $hstp . 'f', $hsts, $^T ] ;
 299   }
 300
 301 sub res
 302   { my $url  = shift ;
 303     my $time = shift ;
 304     my $stat = shift ;
 305     my $hstp =
 306       ( exists $OLD { $url }
 307       ? substr ( $OLD { $url } [ 3 ], 1 - $HIST )
 308       : ''
 309       ) ;
 310     my $hsts = ( exists $OLD { $url } ? $OLD { $url } [ 4 ] : '') ;
 311     printf "result %d %s\n", $time, $url if $opt{v} ;
 312     $RES { $url } = [ $time, $stat, $^T, $hstp . 's', $hsts, $^T ] ;
 313   }
 314
 315 sub get_state
 316   { my $STT = shift ;
 317     open STT, $STT or Error "can't open '$STT' ($!)" ;
 318     while ( <STT> )
 319       { chop ;
 320         my ( $url, $time, $stat, $vrfy, $hstp, $hsts, $lprb ) = split ' ' ;
 321     $stat =~ s/_/ /g ;
 322     $hstp = '' unless defined $hstp ;
 323     $hsts = '' unless defined $hsts ;
 324     $hsts = '' if $hsts eq 'undef' ;
 325     $lprb = 'undef' unless defined $lprb ;
 326     $OLD { $url } = [ $time, $stat, $vrfy, $hstp, $hsts, $lprb ] ;
 327       }
 328     close STT ;
 329   }
 330
 331 sub check_hist
 332   { my $time = shift ;
 333     my $hsts = shift ;
 334     printf "check_hist: last '$time' hsts '$hsts'\n" if $opt{d} ;
 335
 336     my $res = $hsts ;
 337     my ( $stmp, $hist ) ;
 338
 339     if ( $hsts eq '' )
 340       { $stmp = 0 ; $hist = '' ; }
 341     else
 342       { ( $stmp, $hist ) = split '-', $hsts ; }
 343
 344     if ( aprx_le $stmp, $^T - tim_to_s '1d' )
 345       { $res = sprintf "%s-%s%s"
 346       , $^T
 347       , substr ( $hist, 1 - $HIST )
 348       , age_code ( $time )
 349       ;
 350       }
 351     return $res ;
 352   }
 353
 354 sub put_state
 355   { my $STT = shift ;
 356     my $TMP = "$STT.tmp" ;
 357     open TMP, ">$TMP" or Error "can't write '$TMP' ($!)" ;
 358     for my $url ( sort keys %RES )
 359       { $RES { $url } [ 4 ]
 360           = check_hist $RES { $url } [ 0 ], $RES { $url } [ 4 ] ;
 361         my @OUT = @{ $RES { $url } } ;
 362         $OUT [ 1 ] =~ s/\s/_/g ;
 363         printf TMP "%s %s\n", $url, join ' ', @OUT
 364       or Error "can't print to $TMP ($!)" ;
 365       }
 366     close TMP ;
 367     if ( -z $TMP )
 368       { Warn "wrote empty state file; keeping previous version" ; }
 369     else
 370       { rename $TMP, $STT or Error "can't rename '$TMP', '$STT' ($!)" ; }
 371   }
 372
 373 sub get_ccs
 374   { my $CCS = shift ;
 375     open CCS, $CCS or Error "can't open '$CCS' ($!)" ;
 376     while ( <CCS> )
 377       { chop ;
 378         next if /^#/ ;
 379         my ( $code, $dash, $reg ) = split ' ', $_, 3 ;
 380     $CCS { lc $code } = lc $reg ;
 381       }
 382     close CCS ;
 383   }
 384
 385 sub type_site
 386   { my $url = shift ;
 387     my ( $type, $site, $home ) ;
 388     if ( $url =~ m!^(ftp|http)://([^/:]+)(:\d+)?/! )
 389       { $type = $1 ; $site = $2 ; $home = $& ; }
 390     return $type, $site, $home ;
 391   }
 392
 393 sub type { my ( $t, $s, $h) = type_site $_[0] ; $t ; }
 394 sub site { my ( $t, $s, $h) = type_site $_[0] ; $s ; }
 395 sub home { my ( $t, $s, $h) = type_site $_[0] ; $h ; }
 396
 397 sub get_list
 398   { my $LST = shift ;
 399     my ( $reg, $url ) ;
 400     open LST, $LST or Error "can't open '$LST' ($!)" ;
 401     while ( <LST> )
 402       { chop ;
 403         next if /^#/ ;
 404     next if /^\s*$/ ;
 405         if ( $CNF { list_style } eq 'plain' )
 406       { ( $reg, $url ) = split ' ' ;
 407         unless ( $url =~ m!/$! )
 408           { print "*** mirmon appended '/' to $url\n" unless $opt{q} ;
 409             $url .= '/' ;
 410           }
 411       }
 412     elsif ( $CNF { list_style } eq 'apache' )
 413       { my $apache_type ;
 414         ( $apache_type, $reg, $url ) = split ' ' ;
 415         unless (  defined $APA_TYPES { $apache_type } )
 416           { print "*** strange type : $apache_type\n" unless $opt{q} ;
 417             next ;
 418           }
 419         unless ( $url =~ m!/$! )
 420           { print "*** missing '/' in $url\n" unless $opt{q} ;
 421             $url .= '/' ;
 422           }
 423       }
 424
 425     my $site = site $url ;
 426     my $type = type $url ;
 427
 428     unless ( defined $site )
 429       { print "*** strange url : '$url'\n" unless $opt{q} ; next ; }
 430
 431         $LST { $url } = [ $type , $site, $reg ] ;
 432       }
 433   }
 434
 435 sub url { sprintf '<A HREF="%s">%s</A>', $_[0], $_[1] ; }
 436 sub nam { sprintf '<A NAME="%s">%s</A>', $_[0], $_[1] ; }
 437 sub SMA { sprintf "<FONT SIZE=\"-1\">%s</FONT>", $_[0] ; }
 438 sub BLD { sprintf "<B>%s</B>", $_[0] ; }
 439 sub NSS { sprintf SMA('%s&nbsp;site%s'), $_[0], ( $_[0] == 1 ? '' : 's' ) ; }
 440 sub TAB { sprintf "<TABLE BORDER=2 CELLPADDING=3>%s</TABLE>", $_[0] ; }
 441 sub TR  { sprintf "<TR>%s</TR>\n", $_[0] ; }
 442 sub TH  { sprintf "<TH>%s</TH>\n", $_[0] ; }
 443 sub TD  { sprintf "<TD>%s</TD>\n", $_[0] ; }
 444 sub TDr { sprintf "<TD ALIGN=\"RIGHT\">%s</TD>\n", $_[0] ; }
 445 sub RED { sprintf "<FONT COLOR=\"RED\">%s</FONT>", $_[0] ; }
 446 sub GRN { sprintf '<FONT COLOR="GREEN">%s</FONT>', $_[0] ; }
 447
 448 sub htmlquote
 449   { my $x = shift ;
 450     $x =~ s/&/&amp;/g ;
 451     $x =~ s/</&lt;/g ;
 452     $x =~ s/>/&gt;/g ;
 453     return $x ;
 454   }
 455
 456 sub diff
 457   { my $time = shift ;
 458     my $max  = shift ;
 459     my $res ;
 460
 461     if ( $time == $^T )
 462       { $res = BLD 'renewed' ; }
 463     else
 464       { $res = pr_interval $^T - $time ;
 465         $res = BLD RED $res if aprx_lt $time, $max ;
 466       }
 467     return $res ;
 468   }
 469
 470 sub img_sf_cnt
 471   { sprintf '<IMG BORDER=1 SRC="%s/mm%s%02d.gif" ALT="">'
 472       , $CNF { icons }, $_[0], $_[1] ;
 473   }
 474
 475 sub img_sf { img_sf_cnt $_[0], 1 ; }
 476
 477 sub show_hist
 478   { my $hst = shift ;
 479     return '' unless $hst =~ m/^[sbfz]+$/ ;
 480     if ( length $hst == $HIST and $hst =~ /^(s*b)s*$/ )
 481       { return img_sf_cnt 'sb',  length $1 ; }
 482     elsif ( length $hst == $HIST and $hst =~ /^(s*f)s*$/ )
 483       { return img_sf_cnt 'sf',  length $1 ; }
 484     elsif ( length $hst == $HIST and $hst =~ /^(s*b)fs*$/ )
 485       { return img_sf_cnt 'sbf', length $1 ; }
 486     my $res = '' ;
 487     my $cnt = 1 ;
 488     my $prf = substr $hst, 0, 1 ;
 489     $hst = substr $hst, 1 ;
 490     while ( $hst ne '' )
 491       { if ( substr ( $prf, 0, 1 ) eq substr ( $hst, 0, 1 ) )
 492           { $cnt ++ ;
 493         $hst = substr $hst, 1 ;
 494       }
 495         else
 496       { $res .= img_sf_cnt $prf, $cnt ;
 497         $prf = substr $hst, 0, 1 ;
 498         $hst = substr $hst, 1 ;
 499         $cnt = 1 ;
 500       }
 501       }
 502     $res .= img_sf_cnt $prf, $cnt if $cnt ;
 503     return $res ;
 504   }
 505
 506 sub show_hist_age
 507   { my $hsts = shift ;
 508     my $time = shift ;
 509     return '' if $hsts eq '' ;
 510     my ( $t, $h ) = split '-', $hsts ;
 511     if ( aprx_lt $t, $^T ) { $h .= age_code $time ; }
 512     return show_hist substr $h, - $HIST ;
 513   }
 514
 515 sub gen_histogram_probes
 516   { my ( $time, $stat, $vrfy, $hstp, $hsts, $lprb ) ;
 517     my %tab = () ;
 518     my %bad = () ;
 519     my $res = '' ;
 520     my $s_cnt = 0 ;
 521     my $f_cnt = 0 ;
 522     my $hr_min ;
 523     my $hr_max ;
 524     return '' unless scalar keys %RES ;
 525     for my $url ( keys %RES )
 526       { ( $time, $stat, $vrfy, $hstp, $hsts, $lprb ) = @{ $RES { $url } } ;
 527         my $hr = int ( ( $^T - $lprb ) / 3600 + 0.5 ) ;
 528     $hr_min = $hr if ! defined $hr_min or $hr < $hr_min ;
 529     $hr_max = $hr if ! defined $hr_max or $hr > $hr_max ;
 530         if ( $stat eq 'ok' )
 531       { $tab { $hr } ++ ; $s_cnt ++ ; }
 532     else
 533       { $bad { $hr } ++ ; $f_cnt ++ ; }
 534       }
 535     $res = TR
 536       ( TH ( 'hours ago' )
 537       . TH ( 'succ' )
 538       . TH ( 'fail' )
 539       . TH sprintf
 540           ( '%s %s, %s %s'
 541           , $s_cnt , GRN ( 'successful' )
 542       , $f_cnt , RED ( 'failed' )
 543           )
 544       ) ;
 545
 546     my $max = 0 ;
 547     for my $x ( keys %tab )
 548       { my $tot = $tab { $x } + ( $bad { $x } || 0 ) ;
 549         $max = $tot if $max < $tot ;
 550       } ;
 551
 552     return "<BLOCKQUOTE>\nnothing yet\n</BLOCKQUOTE>\n" unless $max ;
 553
 554     for my $hr ( $hr_min .. $hr_max )
 555       { my $x = $tab { $hr } || 0 ;
 556         my $y = $bad { $hr } || 0 ;
 557         my $n = int ( $x / $max * $HIST ) ;
 558         my $b = int ( $y / $max * $HIST ) ;
 559     $res .= TR
 560       ( TDr ( $hr )
 561       . TDr ( $x )
 562       . TDr ( $y )
 563       . TD
 564           ( ( $n ? img_sf_cnt ( 's', $n ) : '' )
 565           . ( $b ? img_sf_cnt ( 'f', $b ) : '' )
 566           . ( ( $n + $b ) ? '' : '&nbsp;' )
 567           )
 568       ) ;
 569       }
 570     return "<BLOCKQUOTE>\n" . TAB ( $res ) . "</BLOCKQUOTE>\n" ;
 571   }
 572
 573 sub gen_histogram
 574   { my $MAX_H = max_age1 ;
 575     my $MAX_h = 1 +
 576       ( ( 20 * 3600 <= $MAX_H and $MAX_H <= 36 * 3600 )
 577       ? int ( $MAX_H / 3600 )
 578       : 25
 579       ) ;
 580     my $MAX_O = max_age2 ;
 581     my $MAX_o = int ( $MAX_O / 3600 + 0.5 ) ;
 582     my $H = 18 ;
 583     my %W   = ( 'old' => 1, 'ded' => 1, 'bad' => 1 ) ;
 584     my %Wmx = ( 'old' => 5, 'ded' => 3, 'bad' => 3 ) ;
 585     my %tab ;
 586     my %hst ;
 587     my $res ;
 588     for ( my $x = 0 ; $x < $MAX_h ; $x ++ ) { $tab { $x } = 0 ; }
 589     $tab { old } = 0 ; $tab { ded } = 0 ; $tab { bad } = 0 ;
 590     for my $url ( keys %RES )
 591       { my $time = $RES { $url } [ 0 ] ;
 592         if ( $time =~ /^\d+$/ )
 593       { my $s  = $^T - $time ;
 594         my $hr = int ( $s / $MAX_H * ( $MAX_h - 1 ) + 0.5 ) ;
 595         if    ( $s <= $MAX_H ) { $tab { $hr  } ++ ; }
 596         elsif ( $s <= $MAX_O ) { $tab { old } ++ ; }
 597         else                   { $tab { ded } ++ ; }
 598       }
 599     else
 600       { $tab { bad } ++ ; }
 601       }
 602     my $max = 0 ;
 603     for ( grep ! exists $Wmx { $_ }, keys %tab )
 604       { $max = $tab { $_ } if $tab { $_ } > $max ; }
 605
 606     my %bad ;
 607
 608     for my $aux ( keys %Wmx )
 609       { $bad { $aux } = $tab { $aux } ;
 610         if ( $bad { $aux } > $max )
 611           { $W { $aux } = $Wmx { $aux } ;
 612             my $d = int ( $bad { $aux } / $W { $aux } ) ;
 613             for ( my $i = 1 ; $i < $W { $aux } ; $i++ )
 614               { $tab { $aux . $i } = $d ;
 615         if ( $bad { $aux } % $Wmx { $aux } > $i )
 616           { $tab { $aux . $i } ++ ;
 617             $tab { $aux } -- ;
 618               }
 619           }
 620             $tab { $aux } -= ( $W { $aux } - 1 ) * $d ;
 621         $max = $tab { $aux } if $max < $tab { $aux } ;
 622           }
 623       }
 624
 625 #   if ( $opt{v} )
 626 #     { for my $hr ( keys %tab )
 627 #         { printf "tab '%s' = '%s'\n", $hr, $tab { $hr } ; }
 628 #     }
 629
 630     return 'nothing yet' unless $max ;
 631     $H = $max if 8 <= $max and $max <= 26 ;
 632     for ( keys %tab )
 633       { $hst { $_ } = int ( $H * $tab { $_ } / $max + 0.5 ) ; }
 634     my @keys = sort { $a <=> $b } grep /^\d+$/, keys %hst ;
 635     my $tab_hr = 0 ;
 636     for my $hr ( @keys ) { $tab_hr += $tab { $hr } ; }
 637     push @keys
 638       , grep ( m/^old/, sort keys %tab )
 639       , grep ( m/^ded/, sort keys %tab )
 640       , grep ( m/^bad/, sort keys %tab )
 641       ;
 642     for ( my $h = $H ; $h > 0 ; $h -- )
 643       { $res .= "<TR>\n" ;
 644     $res .= sprintf "<TH ROWSPAN=3 VALIGN=\"TOP\">&uarr;</TH>\n"
 645       if $h == $H ;
 646     $res .= sprintf '<TD ROWSPAN=%d ALIGN="CENTER">%s</TD>' . "\n"
 647       , $H-6, NSS ( $max ) if $h == $H - 3 ;
 648     $res .= sprintf "<TH ROWSPAN=3 VALIGN=\"BOTTOM\">&darr;</TH>\n"
 649       if $h == 3 ;
 650         for my $x ( @keys )
 651       { $res .=  sprintf "<TH>%s</TH>\n"
 652           , ( ( $hst { $x } >= $h )
 653             ? img_sf
 654             ( $x =~ /^\d+$/
 655             ? 's'
 656             : ( $x =~ /^old/ ? 'b' : ( $x =~ /^ded/ ? 'f' : 'z' ) )
 657             )
 658         : ( ( $h == 1 and $hst { $x } == 0 )
 659           ? sprintf
 660               ( '<IMG SRC="%s/bar.gif" ALT="" BORDER=0>'
 661               , $CNF { icons }
 662               )
 663           : ''
 664           )
 665         ) ;
 666       }
 667         $res .= "</TR>\n" ;
 668       }
 669
 670     my $HR = '<HR SIZE=2 WIDTH="95%%" NOSHADE>' ;
 671
 672     $res .= "<TR>\n" ;
 673     $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", 1 ;
 674     $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", $MAX_h ;
 675     $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", $W { old } ;
 676     $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", $W { ded } ;
 677     $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", $W { bad } ;
 678     $res .= "</TR>\n" ;
 679
 680     $res .= "<TR>\n" ;
 681     $res .= '<TD ALIGN="CENTER">&nbsp;<B>age</B>&nbsp;&rarr;&nbsp;</TD>' ;
 682
 683     $res .= "<TH>|</TH>\n" ;
 684     $res .= sprintf
 685       ( '<TD COLSPAN=%d ALIGN="CENTER">'
 686       . '&larr;&nbsp; 0 &le; <B>age</B> &le; %s &nbsp;&rarr;'
 687       . "</TD>\n"
 688       , $MAX_h - 2, pr_interval ( $MAX_H )
 689       )
 690       ;
 691     $res .= "<TH>|</TH>\n" ;
 692     $res .= sprintf
 693       ( '<TD ALIGN="CENTER" COLSPAN=%d>'
 694       . '&nbsp;%sh&nbsp;&lt;&nbsp;%s&nbsp;&le;&nbsp;%sh&nbsp;'
 695       . "</TD>\n"
 696       , $W { old }, int($MAX_H/60/60) , BLD ( 'age' ), $MAX_o
 697       ) ;
 698     $res .= sprintf
 699       ( '<TD ALIGN="CENTER" COLSPAN=%d>'
 700       . '&nbsp;<FONT COLOR="RED">old</FONT>&nbsp;'
 701       . "</TD>\n"
 702       , $W { ded }
 703       ) ;
 704     $res .= sprintf
 705       ( '<TD ALIGN="CENTER" COLSPAN=%d>'
 706       . '&nbsp;<FONT COLOR="RED">bad</FONT>&nbsp;'
 707       . "</TD>\n"
 708       , $W { bad }
 709       ) ;
 710     $res .= "</TR>\n" ;
 711
 712     my $FRMT = '<TD ALIGN="CENTER" COLSPAN=%d>&nbsp;%s&nbsp;</TD>' ;
 713
 714     $res .= "<TR>\n" ;
 715     $res .= sprintf "$FRMT\n", 1,  NSS scalar keys %RES ;
 716     $res .= "<TH>|</TH>\n" ;
 717     $res .= sprintf "$FRMT\n", $MAX_h - 2, NSS $tab_hr ;
 718     $res .= "<TH>|</TH>\n" ;
 719     $res .= sprintf "$FRMT\n", $W { old }, NSS $bad { old } ;
 720     $res .= sprintf "$FRMT\n", $W { ded }, NSS $bad { ded } ;
 721     $res .= sprintf "$FRMT\n", $W { bad }, NSS $bad { bad } ;
 722     $res .= "</TR>\n" ;
 723
 724     $res = "<TABLE CELLSPACING=0 CELLPADDING=1 BORDER=0>\n$res\n</TABLE>\n" ;
 725     $res = sprintf "<TABLE CELLPADDING=5 BORDER=4>%s</TABLE>\n"
 726        , "<TR><TH>\n$res\n</TH></TR>" ;
 727     if ( $max == $H )
 728       { $res .= sprintf "<BR>units %s %s %s %s represent one mirror site.\n"
 729           , img_sf ( 's' ), img_sf ( 'f' ), img_sf ( 'b' ), img_sf ( 'z' ) ;
 730       }
 731     else
 732       { $res .= sprintf
 733           "<BR>each %s %s %s %s unit represents %s mirror sites.\n"
 734           , img_sf ( 's' ) , img_sf ( 'f' ), img_sf ( 'b' ) , img_sf ( 'z' )
 735       , sprintf ( "%.1f", $max / $H )
 736       }
 737     return $res ;
 738   }
 739
 740 sub revdom { my $dom = shift ; join '.', reverse split /\./, $dom ; }
 741
 742 sub by_type_site
 743   { my $a_type = $a -> [ 0 ] ;
 744     my $b_type = $b -> [ 0 ] ;
 745     my $a_site = $a -> [ 2 ] ;
 746     my $b_site = $b -> [ 2 ] ;
 747     ( revdom $a_site ) cmp ( revdom $b_site )
 748     or
 749     $a_type cmp $b_type
 750     ;
 751   }
 752
 753 sub by_CCS { ( $CCS { $a } || $a ) cmp ( $CCS { $b } || $b ) ; }
 754
 755 sub legend ;
 756
 757 sub gen_page
 758   { my $PPP = shift ;
 759     my $TMP = "$PPP.tmp" ;
 760     my %tab ;
 761     my $refs ;
 762     for my $url ( keys %LST )
 763       { my ( $type , $site, $reg ) = @{ $LST { $url } } ;
 764         push @{ $tab { $reg } }, [ $type, $url, $site ] ;
 765       }
 766
 767     my $bad = 0 ; my $old = 0 ; my $unr = 0 ;
 768     my %stats ;
 769     my @stats ;
 770     my $ok = 0 ;
 771
 772     for my $url ( keys %RES )
 773       { my ( $time, $stat, $vrfy ) = @{ $RES { $url } } ;
 774         if ( $stat eq 'ok' ) { $ok ++ ; } else { $stats { $stat } ++ ; }
 775         if ( $time eq 'undef' )
 776       { $bad ++ ; }
 777     elsif ( 'f' eq age_code $time )
 778       { $old ++ ; }
 779     if ( $vrfy eq 'undef' or aprx_lt $vrfy, $^T - max_vrfy )
 780       { $unr ++ ; }
 781       }
 782
 783     my $STAT = sprintf
 784         "%d bad -- %d older than %s -- %s unreachable for more than %s"
 785       , $bad
 786       , $old
 787       , pr_interval ( max_age2 )
 788       , $unr
 789       , pr_interval ( max_vrfy )
 790       ;
 791
 792     my $PROB = 'last probes : ' ;
 793     push @stats, "$ok were ok" if $ok ;
 794     for my $stat ( sort keys %stats )
 795       { push @stats, sprintf "%s had %s", $stats { $stat }, RED  $stat ; }
 796     $PROB .= join ', ', @stats ;
 797
 798     for my $reg ( sort keys %tab )
 799       { $refs .= sprintf "&nbsp;%s&nbsp;\n"
 800           , url "#$reg"
 801       , "<FONT SIZE=\"+1\">$reg</FONT>"
 802       ;
 803       }
 804
 805     my $COLS = 5 ;
 806     my $LOGO = $CNF { project_logo }
 807       ? url
 808           ( $CNF { project_url }
 809       , sprintf
 810               ( '<IMG SRC="%s" ALT="%s" ALIGN="RIGHT" BORDER=0>'
 811           , $CNF { project_logo }
 812           , $CNF { project_name }
 813           )
 814           )
 815       : ''
 816       ;
 817     my $HTOP = $CNF{htm_top}  ? $CNF{htm_top}  . "\n" : '' ;
 818     my $FOOT = $CNF{htm_foot} ? $CNF{htm_foot} . "\n" : '' ;
 819     my $HEAD = $CNF{htm_head} ? $CNF{htm_head} . "\n" : '' ;
 820     my $TITL = url $CNF{project_url}, $CNF{project_name} ;
 821     my $EXPD = exp_date ;
 822
 823     open PPP, ">$TMP" or Error "can't write $TMP ($!)" ;
 824     print PPP '<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01'
 825       . ' Transitional//EN"'
 826       . '>' ;
 827     print PPP "<HTML>\n" ;
 828     print PPP "<HEAD>\n" ;
 829     print PPP "<TITLE>the status of $CNF{project_name} mirrors</TITLE>\n" ;
 830     printf PPP "%s\n", '<meta HTTP-EQUIV="content-type" '
 831       . 'CONTENT="text/html; charset=ISO-8859-1">' ;
 832     print PPP "<META HTTP-EQUIV=\"refresh\" CONTENT=\"3600\">\n" ;
 833     print PPP "<META HTTP-EQUIV=\"Expires\" CONTENT=\"$EXPD\">\n" ;
 834     print PPP $HEAD if $HEAD ;
 835     print PPP "</HEAD>\n" ;
 836     print PPP "<BODY BGCOLOR=\"#FFFFFF\">\n" ;
 837     print PPP $LOGO ;
 838
 839     print PPP "<H2>the status of $TITL mirrors</H2>\n" ;
 840
 841     print PPP "<TABLE BORDER=0 CELLPADDING=2>\n" ;
 842     printf PPP "<TR><TD>date</TD><TD>:</TD><TD>%s (GMT)</TD></TR>\n"
 843       , scalar gmtime $^T ;
 844     printf PPP "<TR><TD>last&nbsp;check</TD><TD>:</TD><TD>%s (GMT)</TD></TR>\n"
 845       , scalar gmtime ( $opt{get} ? $^T : ( stat $CNF { state } ) [9] ) ;
 846     print PPP "</TABLE>\n" ;
 847
 848     printf PPP "<P>%s</P>\n", $HTOP if $HTOP ;
 849
 850     if ( $CNF { put_histo } eq 'top' )
 851       { print PPP "<H2>age histogram</H2>\n" ;
 852
 853         print PPP "<BLOCKQUOTE>\n" ;
 854         print PPP gen_histogram ;
 855         print PPP "</BLOCKQUOTE>\n" ;
 856       }
 857
 858     print PPP "<H2>regions</H2>\n" ;
 859
 860     print PPP "<BLOCKQUOTE>\n" ;
 861     print PPP "<CENTER>\n" ;
 862     printf PPP "%s\n", $refs ;
 863     print PPP "</CENTER>\n" ;
 864     print PPP "</BLOCKQUOTE>\n" ;
 865
 866     print PPP "<H2>report</H2>\n" ;
 867
 868     my $attr1 = "COLSPAN=$COLS BGCOLOR=\"LIME\"" ;
 869     my $attr2 = 'BGCOLOR="AQUA"' ;
 870
 871     print PPP "<BLOCKQUOTE>\n" ;
 872     print PPP "<TABLE BORDER=2 CELLPADDING=5>\n" ;
 873     printf PPP "<TR><TH $attr1>%d sites in %d regions</TH></TR>\n"
 874       , scalar keys %LST
 875       , scalar keys %tab
 876       ;
 877     printf PPP "<TR><TH $attr1>%s</TH></TR>\n", $STAT ;
 878     printf PPP "<TR><TH $attr1>%s</TH></TR>\n", $PROB ;
 879     print PPP "<TR>\n" ;
 880     printf PPP "  <TH $attr2>%s site -- home</TH>\n"
 881       , $CNF { project_name } ;
 882     printf PPP "  <TH $attr2>%s</TH>\n", 'type' ;
 883     printf PPP "  <TH $attr2>%s</TH>\n", 'mirror age,<BR>daily stats' ;
 884     printf PPP "  <TH $attr2>%s</TH>\n", 'last probe,<BR>probe stats' ;
 885     printf PPP "  <TH $attr2>%s</TH>\n", 'last stat' ;
 886     print PPP "</TR>\n" ;
 887     for my $reg ( sort by_CCS keys %tab )
 888       { my $itms = $tab { $reg } ;
 889
 890         my $ccs = exists $CCS { $reg } ? $CCS { $reg } : $reg ;
 891         $ccs = nam $reg,
 892       ( scalar @{ $itms } > 6
 893       ? sprintf "%s&nbsp;&nbsp;-&nbsp;&nbsp;%d sites"
 894           , $ccs, scalar @{ $itms }
 895       : $ccs
 896       ) ;
 897
 898     my $attr3 = "COLSPAN=$COLS BGCOLOR=\"YELLOW\"" ;
 899         printf PPP "<TR><TH $attr3>$ccs</TH></TR>\n" ;
 900
 901     for my $itm ( sort by_type_site @{ $itms } )
 902       { my ( $type, $url, $site ) = @{ $itm } ;
 903         my ( $time, $stat, $hstp, $hsts, $vrfy ) ;
 904         my ( $pr_time, $pr_last, $pr_hstp, $pr_hsts ) ;
 905
 906         print PPP "<TR>\n" ;
 907         printf PPP
 908              "  <TD ALIGN=\"RIGHT\">%s&nbsp;&nbsp;%s</TD>\n"
 909           .  "  <TD>%s</TD>\n"
 910           , url ( $url , $site )
 911           , url ( home ( $url ), '@' )
 912           , $type
 913           ;
 914
 915         if ( exists $RES { $url } )
 916           { ( $time, $stat, $vrfy, $hstp, $hsts ) = @{ $RES { $url } } ;
 917             $pr_time = $time =~ /^\d+$/
 918               ? diff $time, $^T - max_age2 : '&nbsp;' ;
 919             $pr_last = $vrfy =~ /^\d+$/
 920               ? diff $vrfy, $^T - max_vrfy : '&nbsp;' ;
 921                 $pr_hstp = show_hist $hstp ;
 922                 $pr_hsts = show_hist_age $hsts, $time ;
 923
 924           }
 925         else
 926           { ( $pr_time, $pr_last, $pr_hstp, $pr_hsts, $stat ) =
 927               ( '&nbsp;', '&nbsp;', '', '', '&nbsp;' ) ;
 928           }
 929
 930         $stat = RED $stat if $stat ne 'ok' ;
 931         printf PPP "  <TD ALIGN=\"RIGHT\">%s<BR>%s</TD>\n"
 932           , $pr_time, $pr_hsts ;
 933         printf PPP "  <TD ALIGN=\"RIGHT\">%s<BR>%s</TD>\n"
 934           , $pr_last, $pr_hstp ;
 935         printf PPP "  <TD>%s</TD>\n", $stat ;
 936         print PPP "</TR>\n" ;
 937       }
 938       }
 939     print PPP "</TABLE>\n" ;
 940     print PPP "</BLOCKQUOTE>\n" ;
 941
 942     if ( $CNF { put_histo } eq 'bottom' )
 943       { print PPP "<H2>age histogram</H2>\n" ;
 944
 945         print PPP "<BLOCKQUOTE>\n" ;
 946         print PPP gen_histogram ;
 947         print PPP "</BLOCKQUOTE>\n" ;
 948       }
 949
 950     print PPP legend ;
 951
 952     print PPP "<H3>probe results</H3>\n" ;
 953     print PPP gen_histogram_probes ;
 954
 955     print PPP "<H3>software</H3>\n" ;
 956
 957     print PPP "<BLOCKQUOTE><TABLE><TR>\n" ;
 958     my $MIR_IMG = sprintf
 959       '<IMG BORDER=2 ALT="mirmon" SRC="%s/mirmon.gif">' , $CNF { icons } ;
 960     print PPP sprintf "<TH><A HREF=\"%s\">%s</A></TH>\n"
 961       , 'http://www.cs.uu.nl/people/henkp/mirmon/', $MIR_IMG ;
 962     print PPP "<TD>$VER</TD>\n" ;
 963     print PPP "</TR></TABLE></BLOCKQUOTE>\n" ;
 964     print PPP $FOOT ;
 965     print PPP "</BODY>\n" ;
 966     print PPP "</HTML>" ;
 967
 968     if ( print PPP "\n" )
 969       { close PPP ;
 970         if ( -z $TMP )
 971           { Warn "wrote empty html file; keeping previous version" ; }
 972         else
 973           { rename $TMP, $PPP or Error "can't rename $TMP, $PPP ($!)" ; }
 974       }
 975     else
 976       { Error "can't print to $TMP ($!)" ; }
 977   }
 978
 979 sub legend
 980   { return <<LEGENDA ;
 981 <H3>legend</H3>
 982
 983 <H4><I>project</I> site -- home</H4>
 984
 985 <BLOCKQUOTE>
 986 <B><I>project</I> site</B> is an url.
 987 The <B>href</B> is the href for the site in the list of mirrors,
 988 usually the root of the mirrored file tree.
 989 The <B>text</B> is the <I>site</I> of that url.
 990 <P>
 991 <B>home</B> (represented by the <B>@</B>-symbol) is an url
 992 pointing to the document root of the site. This pointer is
 993 useful if the <B><I>project</I> site</B> url is invalid,
 994 possibly because the mirror site moved the archive.
 995 </BLOCKQUOTE>
 996
 997 <H4>type</H4>
 998
 999 <BLOCKQUOTE>
1000 Indicates the type (<B>ftp</B> or <B>http</B>) of
1001 the <B><I>project</I> site</B> and <B>home</B> urls.
1002 </BLOCKQUOTE>
1003
1004 <H4>mirror age, daily stats</H4>
1005
1006 <BLOCKQUOTE>
1007 The <B>mirror age</B> is based upon the last successful probe.
1008 <P>
1009 Once a day the status of a mirror site is determined.
1010 The status (represented by a colored block) is appended
1011 to the <B>right</B> of the status history (<I>right</I>
1012 is <I>recent</I>). More precise, the status block is appended
1013 if the last status block was appended 24 (or more) hours ago.
1014 <P>The status of a mirror depends on its age and a few
1015 configuration parameters :
1016 <BLOCKQUOTE>
1017 <TABLE BORDER=1 CELLPADDING=5>
1018 <TR>
1019   <TH ROWSPAN=3>status</TH>
1020   <TH COLSPAN=4>age</TH>
1021 </TR>
1022 <TR>
1023   <TH COLSPAN=2 BGCOLOR="YELLOW">this project</TH>
1024   <TH COLSPAN=2 BGCOLOR="AQUA">in general</TH>
1025 </TR>
1026 <TR>
1027   <TH BGCOLOR="YELLOW">min</TH>
1028   <TH BGCOLOR="YELLOW">max</TH>
1029   <TH BGCOLOR="AQUA">min</TH>
1030   <TH BGCOLOR="AQUA">max</TH>
1031 </TR>
1032 <TR>
1033   <TH><FONT COLOR="GREEN">fresh</FONT></TH>
1034
1035   <TD BGCOLOR="YELLOW" ALIGN="CENTER">0</TD>
1036   <TD BGCOLOR="YELLOW" ALIGN="CENTER">
1037     @{[$CNF{min_sync}]} + @{[$CNF{max_poll}]}</TD>
1038   <TD BGCOLOR="AQUA"   ALIGN="CENTER">0</TD>
1039   <TD BGCOLOR="AQUA"   ALIGN="CENTER">min_sync + max_poll</TD>
1040 </TR>
1041 <TR>
1042   <TH><FONT COLOR="BLUE">oldish</FONT></TH>
1043
1044   <TD BGCOLOR="YELLOW" ALIGN="CENTER">
1045     @{[$CNF{min_sync}]} + @{[$CNF{max_poll}]}</TD>
1046   <TD BGCOLOR="YELLOW" ALIGN="CENTER">
1047     @{[$CNF{max_sync}]} + @{[$CNF{max_poll}]}</TD>
1048   <TD BGCOLOR="AQUA"   ALIGN="CENTER">min_sync + max_poll</TD>
1049   <TD BGCOLOR="AQUA"   ALIGN="CENTER">max_sync + max_poll</TD>
1050 </TR>
1051 <TR>
1052   <TH><FONT COLOR="RED">old</FONT></TH>
1053
1054   <TD BGCOLOR="YELLOW" ALIGN="CENTER">
1055     @{[$CNF{max_sync}]} + @{[$CNF{max_poll}]}</TD>
1056   <TD BGCOLOR="YELLOW" ALIGN="CENTER">&infin;</TD>
1057   <TD BGCOLOR="AQUA"   ALIGN="CENTER">max_sync + max_poll</TD>
1058   <TD BGCOLOR="AQUA"   ALIGN="CENTER">&infin;</TD>
1059 </TR>
1060 <TR>
1061   <TH><FONT COLOR="BLACK">bad</FONT></TH>
1062   <TH COLSPAN=4 BGCOLOR="BLACK">
1063     <FONT COLOR="WHITE">the site or mirror tree was never found</FONT></TH>
1064 </TR>
1065 </TABLE>
1066 </BLOCKQUOTE>
1067 </BLOCKQUOTE>
1068
1069 <H4>last probe, probe stats</H4>
1070
1071 <BLOCKQUOTE>
1072 <B>Last probe</B> indicates when the last successful probe was made.
1073 <B>Probe stats</B> gives the probe history (<I>right</I> is <I>recent</I>).
1074 A probe is either a
1075 <FONT COLOR="GREEN"><B>success</B></FONT> or a
1076 <FONT COLOR="RED"><B>failure</B></FONT>.
1077 </BLOCKQUOTE>
1078
1079 <H4>last stat</H4>
1080
1081 <BLOCKQUOTE>
1082 <B>Last stat</B> gives the status of the last probe.
1083 </BLOCKQUOTE>
1084
1085 LEGENDA
1086   }
1087
1088 sub start_date
1089   { my $url = shift ;
1090     my $CMD = shift ;
1091     my $TIMEOUT = $CNF { timeout } ;
1092     my $src = $HREF { lc site $url } || $url ;
1093     $CMD =~ s/%TIMEOUT%/$TIMEOUT/g ;
1094     $CMD =~ s/%URL%/$src/g ;
1095     printf "*** SUBSTITUTE site %s\n+  url %s\n+  %s\n",
1096       site($url), $HREF { lc site $url }, $CMD
1097         if $HREF { lc site $url } and $opt{v} ;
1098     my $WGT = new IO::Pipe ;
1099     my $res = $WGT -> reader ( split ' ', $CMD ) ;
1100     if ( $res )
1101       { $WGT -> blocking ( 0 ) ;
1102         $GET -> add ( $WGT ) ;
1103     $URL { $WGT } = $url ;
1104       }
1105     else
1106       { err $url, 'no pipe' ; }
1107   }
1108
1109 sub get_date
1110   { my $WGT = shift ;
1111     my $url = $URL { $WGT } ;
1112     my $time = undef ;
1113
1114     $WGT -> blocking ( 1 ) ;
1115     unless ( $WGT -> eof () ) { $time = $WGT -> getline () ; }
1116     $GET -> remove ( $WGT ) ;
1117     $WGT -> flush ;
1118     $WGT -> close ;
1119
1120     return err $url, 'no time' unless defined $time ;
1121     return err $url, "empty"   if $time =~ /^\s*$/  ;
1122
1123     $time = ( split ' ', $time ) [ 0 ] ;
1124
1125     if ( $time !~ /^\d+$/ )
1126       { $time = htmlquote $time ;
1127         $time = substr ( $time, 0, 15 ) . '..' if length $time > 15 ;
1128         err $url, "'$time'" ;
1129       }
1130     else
1131       { res $url, $time, 'ok' ; }
1132   }
1133
1134 sub get_dates
1135   { my $CMD = shift ;
1136     my @QUE ;
1137     my $PAR = $CNF { max_probes } ;
1138     my $cnt_LST = scalar keys %LST ;
1139     for my $url ( sort keys %LST )
1140       { if ( $opt{get} eq 'all' or ! exists $OLD { $url } )
1141           { push @QUE, $url ; }
1142     elsif ( $opt{get} eq 'update' )
1143       { my $stat = $OLD { $url } [ 1 ] ;
1144         my $vrfy = $OLD { $url } [ 2 ] ;
1145         my $lprb = $OLD { $url } [ 5 ] ;
1146         if ( ( $lprb eq 'undef'
1147             or aprx_le $lprb, $^T - tim_to_s $CNF { min_poll }
1148              )
1149          and ( $stat ne 'ok'
1150             or aprx_le $vrfy, $^T - tim_to_s $CNF { max_poll }
1151              )
1152            )
1153           { push @QUE, $url ; }
1154         elsif ( $CNF { randomize } and 0 == int rand $cnt_LST )
1155           { push @QUE, $url ; }
1156         else
1157           { $RES { $url } = $OLD { $url } ; }
1158       }
1159     else
1160       { Error "unknown opt_get '$opt{get}'" ; }
1161       }
1162
1163     while ( @QUE )
1164       { while ( $GET -> count () < $PAR and @QUE )
1165           { my $url = shift @QUE ;
1166             if ( gethost site $url )
1167           { start_date $url, $CMD ; }
1168         else
1169           { err $url, 'site not found' ; }
1170           }
1171
1172     my @can_read = $GET -> can_read ( 0 ) ;
1173
1174     printf "que %d, get %d, can %d\n",
1175       scalar @QUE, $GET -> count (), scalar @can_read
1176         if $opt{v} ;
1177
1178         for my $can_read ( @can_read )
1179       { get_date $can_read ; }
1180
1181         sleep 1 ;
1182       }
1183
1184     my $stop = time + $CNF { timeout } + 10 ;
1185
1186     while ( $GET -> count () and time < $stop )
1187       { sleep 1 ;
1188
1189         my @can_read = $GET -> can_read ( 0 ) ;
1190
1191     printf "wait %2d, get %d, can %d\n",
1192       $stop - scalar time, $GET -> count (), scalar @can_read
1193         if $opt{v} ;
1194
1195         for my $can_read ( @can_read )
1196       { get_date $can_read ; }
1197       }
1198
1199     for my $WGT ( $GET -> handles () )
1200       { my $url = $URL { $WGT } ;
1201         err $url, 'hangs' ;
1202       }
1203   }
1204
1205 get_conf_opt ;
1206 get_ccs   $CNF { countries } ;
1207 get_state $CNF { state } ;
1208 get_list  $CNF { mirror_list } ;
1209
1210 if ( $opt{get} )
1211   { get_dates $CNF { probe } ;
1212     put_state $CNF { state } ;
1213   }
1214 else
1215   { %RES = %OLD }
1216
1217 gen_page $CNF { web_page } ;
1218
1219 __END__
1220
1221 =pod
1222
1223 =head1 NAME
1224
1225   mirmon - monitor the state of mirrors
1226
1227 =head1 SYNOPSIS
1228
1229   mirmon [ -v ] [ -q ] [ -t timeout ] [ -get opt ] [ -c conf ]
1230
1231 =head1 OPTIONS
1232
1233   option v   : be verbose
1234   option q   : be quiet
1235   option t   : set timeout [ default 300 ] ;
1236   option get : 'all'    : probe all sites
1237              : 'update' : probe a selection of the sites (see doc)
1238   option c   : configuration file ; default list :
1239                ./mirmon.conf $HOME/.mirmon.conf /etc/mirmon.conf
1240   -------------------------------------------------------------------
1241   Documentation : the program contains 'pod' style documentation.
1242   Extract the doc with 'pod2text mirmon' or 'pod2html mirmon OUT', etc.
1243   -------------------------------------------------------------------
1244
1245 =head1 USAGE
1246
1247   The program is intended to be run by cron every hour.
1248
1249     42 * * * * perl /path/to/mirmon -q -get update
1250
1251   It quietly probes a subset of the sites in a given list,
1252   writes the results in the 'state' file and generates a web page
1253   with the results. The subset contains the sites that are new, bad
1254   and/or not probed for a specified time.
1255
1256   When no 'get' option is specified, the program just generates a
1257   new web page from the last known state.
1258
1259   The program checks the mirrors by running a (user specified)
1260   program on a pipe. A (user specified) number of probes is
1261   run in parallel using nonblocking IO. When something can be
1262   read from the pipe, it switches the pipe to blocking IO and
1263   reads one line from the pipe. Then it flushes and closes the
1264   pipe. No attempt is made to kill the probe.
1265
1266   The probe should return something that looks like "1043625600\n",
1267   that is, a timestamp followed by a newline. The exit status of
1268   the probe is ignored.
1269
1270 =head1 CONFIG FILE
1271
1272 =head2 location
1273
1274   A config file can be specified with the -c option.
1275   If -c is not used, the program looks for a config file in
1276   -- ./mirmon.conf
1277   -- $HOME/.mirmon.conf
1278   -- /etc/mirmon.conf
1279
1280 =head2 syntax
1281
1282   A config file looks like this :
1283
1284     +--------------------------------------------------
1285     |# lines that start with '#' are comment
1286     |# blank lines are ignored too
1287     |# tabs are replaced by a space
1288     |
1289     |# the config entries are 'key' and 'value' pairs
1290     |# a 'key' begins in column 1
1291     |# the 'value' is the rest of the line
1292     |somekey  A_val B_val ...
1293     |otherkey X_val Y_val ...
1294     |
1295     |# indented lines are glued
1296     |# the next three lines mean 'somekey part1 part2 part3'
1297     |somekey part1
1298     |  part2
1299     |  part3
1300     |
1301     |# lines starting with a '+' are concatenated
1302     |# the next three lines mean 'somekey part1part2part3'
1303     |somekey part1
1304     |+ part2
1305     |+ part3
1306     |
1307     |# lines starting with a '.' are glued too
1308     |# don't use a '.' on a line by itself
1309     |# 'somekey' gets the value "part1\n part2\n part3"
1310     |somekey part1
1311     |. part2
1312     |. part3
1313     +--------------------------------------------------
1314
1315 =head1 CONFIG FILE : required entries
1316
1317 =head2 project_name <name>
1318
1319   Specify a short plaintext name for the project.
1320
1321     project_name Apache
1322     project_name CTAN
1323
1324 =head2 project_url <url>
1325
1326   Specify an url pointing to the 'home' of the project.
1327
1328     project_url http://www.apache.org/
1329
1330 =head2 mirror_list <file name>
1331
1332   Specify the file containing the mirrors to probe.
1333   Two formats are supported :
1334
1335   -- plain : lines like
1336
1337        us http://www.tux.org/
1338        nl http://apache.cs.uu.nl/dist/
1339
1340   -- apache : lines like those in the apache mirrors.list
1341
1342        ftp  us ftp://ftp.tux.org/pub/net/apache/dist/ user@tux.org
1343        http nl http://apache.cs.uu.nl/dist/ user@cs.uu.nl
1344
1345   Specify the required format with 'list_style' (see below).
1346   The default style is 'plain'.
1347
1348   If the url part of a line doesn't end in a slash ('/'), mirmon
1349   adds a slash and issues a warning unless it is in quiet mode.
1350
1351 =head2 web_page <file name>
1352
1353   Specify where the html report page is written.
1354
1355 =head2 icons <directory name>
1356
1357   Specify the directory where the icons can be found.
1358
1359 =head2 probe <program + arguments>
1360
1361   Specify the program+args to probe the mirrors. Example:
1362
1363     probe /sw/bin/wget -q -O - -T %TIMEOUT% -t 1 %URL%TIME
1364
1365   Before the program is started, %TIMEOUT% and %URL% are
1366   substituted with the proper timeout and url values.
1367
1368   Here it is assumed that each hour the root server writes
1369   a timestamp in /path/to/archive/TIME, for instance with
1370   a crontab entry like
1371
1372     42 * * * * perl -e 'printf "%s\n", time' > /path/to/archive/TIME
1373
1374   Mirmon reads one line of output from the probe and interprets
1375   the first word on that line as a timestamp ; for example :
1376
1377     1043625600
1378     1043625600 Mon Jan 27 00:00:00 2003
1379     1043625600 www.apache.org Mon Jan 27 00:00:00 2003
1380
1381 =head2 state <file name>
1382
1383   Specify where the file containing the state is written.
1384   The program reads this file on startup and writes the
1385   file when mirrors are probed (-get is specified).
1386
1387 =head2 countries <file name>
1388
1389   Specify the file containing the country codes;
1390   The file should contain lines like
1391
1392     us - united states
1393     nl - netherlands
1394
1395   The mirmon package contains a recent ISO list.
1396
1397 =head1 CONFIG FILE : optional entries
1398
1399 =head2 max_probes <number>
1400
1401   Optionally specify the number of parallel probes (default 25).
1402
1403 =head2 timeout <seconds>
1404
1405   Optionally specify the timeout for the probes (default 300).
1406   After the last probe is started, the program waits for
1407   <timeout> + 10 seconds, cleans up and exits.
1408
1409 =head2 project_logo <logo>
1410
1411   Optionally specify (the SRC of the IMG of) a logo to be placed
1412   top right on the page.
1413
1414     project_logo /icons/apache.gif
1415     project_logo http://www.apache.org/icons/...
1416
1417 =head2 htm_head <html>
1418
1419   Optionally specify some HTML to be placed before </HEAD>.
1420
1421     htm_head
1422       <link REL=StyleSheet HREF="/style.css" TYPE="text/css">
1423
1424 =head2 htm_top <html>
1425
1426   Optionally specify some HTML to be placed near the top of the page.
1427   The supplied text is placed between <P> and </P>.
1428
1429     htm_top testing 1, 2, 3
1430
1431 =head2 htm_foot <html>
1432
1433   Optionally specify HTML to be placed near the bottom of the page.
1434
1435     htm_foot
1436       <HR>
1437       <A HREF="..."><IMG SRC="..." BORDER=0></A>
1438       <HR>
1439
1440 =head2 put_histo top|bottom|nowhere
1441
1442   Optionally specify where the age histogram must be placed.
1443   The default is 'top'.
1444
1445 =head2 min_poll <time spec>
1446
1447   For 'min_poll' see next item. A <time spec> is a number followed by
1448   a unit 's' (seconds), or 'm' (minutes), or 'h' (hours), or 'd' (days).
1449   For example '3d' (three days) or '36h' (36 hours).
1450
1451 =head2 max_poll <time spec>
1452
1453   Optionally specify the maximum probe interval. When the program is
1454   called with option '-get update', all sites are probed which are :
1455   -- new : the site appears in the list, but there is no known state
1456   -- bad : the last probe of the site was unsuccessful
1457   -- old : the last probe was more than 'max_poll' ago.
1458   Sites are not probed if the last probe was less than 'min_poll' ago.
1459
1460   So, if you specify
1461
1462     min_poll 4h
1463     max_poll 12h
1464
1465   the 'reachable' sites are probed twice daily and the 'unreachable'
1466   sites are probed at most six times a day.
1467
1468   The default 'min_poll' is '1h' (1 hour).
1469   The default 'max_poll' is '4h' (4 hours).
1470
1471 =head2 min_sync <time spec>
1472
1473   Optionally specify how often the mirrors are required to
1474   make an update. The default 'min_sync' is '1d' (1 day).
1475
1476 =head2 max_sync <time spec>
1477
1478   Optionally specify the maximum allowable sync interval.
1479   Sites exceeding the limit will be considered 'old'.
1480   The default 'max_sync' is '2d' (2 days).
1481
1482 =head2 no_randomize
1483
1484   With a low probablility, mirmon probes mirrors that would
1485   otherwise not be probed. In the long run, this balances
1486   the number of mirror probes over the hourly mirmon runs.
1487   Specifically, if there are N mirrors in the list and some
1488   mirmon run would probe K sites, on average (N-K)/N extra
1489   sites will be probed.
1490
1491   If you don't want this behaviour, use 'no_randomize'.
1492
1493 =head2 list_style plain|apache
1494
1495   Optionally specify the format ('plain' or 'apache') of the
1496   mirror-list. See the description of 'mirror_list' above.
1497   The default list_style is 'plain'.
1498
1499 =head2 site_url <site> <url>
1500
1501   Optionally specify a substitute url for a site. When access to
1502   a site is restricted (in Australia, for instance), another
1503   (sometimes secret) url can be used to probe the site. The <site>
1504   of an url is the part between '://' and the first '/'.
1505
1506 =head2 env <key> <value>
1507
1508   Optionally specify an environment variable.
1509
1510 =head2 include <file name>
1511
1512   Optionally specify a file to include. The specified file is processed
1513   'in situ'. After the specified file is read and processed, config
1514   processing is resumed in the file where the 'include' was encountered.
1515   The 'include' depth is unlimited. However, it is a fatal error to
1516   include a file twice under the same name.
1517
1518 =head2 show
1519
1520   When the config processor encounters the 'show' command, it
1521   dumps the content of the current config to standout, if option
1522   -v is specified. This is intented for debugging.
1523
1524 =head2 exit
1525
1526   When the config processor encounters the 'exit' command, it
1527   terminates the program. This is intented for debugging.
1528
1529 =head1 STATE FILE FORMAT
1530
1531   The state file consists of lines; one line per site.
1532   Each line consists of white space separated fields.
1533   The seven fields are :
1534
1535 =head2 field 1 : url
1536
1537   The url as given in the mirror list.
1538
1539 =head2 field 2 : age
1540
1541   The age of the site, or 'undef' if no probe was ever successful.
1542
1543 =head2 field 3 : status last probe
1544
1545   The status of the last probe.
1546
1547 =head2 field 4 : time last succesful probe
1548
1549   The timestamp of the last succesful probe or 'undef'
1550   if the site was never successfully probed.
1551
1552 =head2 field 5 : probe history
1553
1554   The probe history is a list of 's' (for success) and 'f' (for failure)
1555   characters indicating the result of the probe. New results are appended
1556   whenever the site is probed.
1557
1558 =head2 field 6 : state history
1559
1560   The state history consists of a timestamp, a '-' char, and a list of
1561   chars indicating a past status: 's' (fresh), 'b' (oldish), 'f' (old)
1562   or 'z' (bad). The timestamp indicates when the state history was last
1563   updated. The state history is updated when the state file is updated
1564   and the last update of the history state was 24 (or more) hours ago.
1565   The status is determined by the site's age and a few configuration
1566   parameters. The details are explained in the legend of the report page.
1567
1568 =head2 field 7 : last probe
1569
1570   The timestamp of the last probe.
1571
1572 =head1 INSTALLATION
1573
1574 =over
1575
1576 =item *
1577
1578   The '#!' path for perl is probably wrong.
1579
1580 =back
1581
1582 =head1 AUTHOR
1583
1584 =begin html
1585
1586 <BLOCKQUOTE>
1587   &copy; 2003
1588   <A HREF="http://www.cs.uu.nl/staff/henkp.html">Henk P. Penning</A>,
1589   <A HREF="http://www.cs.uu.nl/">Computer Science Department</A>,
1590   <A HREF="http://www.uu.nl/">Utrecht University</A>
1591   <BR>
1592   $Id: mirmon,v 1.37 2006/12/04 15:16:11 henkp Exp henkp $
1593 </BLOCKQUOTE>
1594
1595 =end html
1596
1597 =begin text
1598
1599   (c) 2003 Henk P. Penning, Computer Science Department, Utrecht University
1600   http://www.cs.uu.nl/staff/henkp.html -- penning@cs.uu.nl
1601
1602 =end text
1603
1604 =cut
1605