mirmon/mirmon

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