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 # Permission is hereby granted, free of charge, to any person obtaining a
   7 # copy of this software and associated documentation files (the "Software"),
   8 # to deal in the Software without restriction, including without limitation
   9 # the rights to use, copy, modify, merge, publish, distribute, sublicense,
  10 # and/or sell copies of the Software, and to permit persons to whom the
  11 # Software is furnished to do so, subject to the following conditions:
  12 #
  13 # The above copyright notice and this permission notice shall be included in
  14 # all copies or substantial portions of the Software.
  15 #
  16 # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  17 # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  18 # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
  19 # THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  20 # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  21 # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  22 # DEALINGS IN THE SOFTWARE.
  23 #
  24 # Thanks to Klaus Heinz <heinz@NetBSD.org> for sugestions ao htm_head ;
  25 # Peter Pöml for MirrorBrain support ; Jeremy Olexa, Karl Berry, Roland
  26 # Pelzer for suggestions regarding rsync support.
  27
  28 use strict ;
  29
  30 our $PRG = 'mirmon' ;
  31 our $VER = "2.3" ;
  32
  33 our $DEF_TIMEOUT = 300 ;
  34 our $HIST        = 14 ;
  35 our $TIM_PAT     = '^(\d+)([smhd])$' ;
  36 our %APA_TYPES   = () ; for ( qw(backup ftp http) ) { $APA_TYPES { $_ } ++ ; }
  37 our %GET_OPTS    = () ; for ( qw(all update) )      { $GET_OPTS  { $_ } ++ ; }
  38 our $HIST_DELTA  = 24 * 60 * 60 ;
  39 our $APRX_DELTA  = 60 ;
  40 our $HOME        = 'http://www.cs.uu.nl/people/henkp/mirmon/' ;
  41
  42 package Base ; #####################################################
  43
  44 use base 'Exporter' ;
  45
  46 our ( @ISA, @EXPORT ) ;
  47 BEGIN
  48   { @ISA = qw(Exporter) ;
  49     @EXPORT =
  50       qw(aprx_eq aprx_ge aprx_le aprx_gt aprx_lt
  51          URL NAM SMA BLD NSS TAB BQ TR TH TD TDr RED GRN H1 H2 H3
  52          s4tim pr_interval pr_diff
  53         ) ;
  54   }
  55
  56 sub Version { "$PRG version $VER" ; }
  57 sub version { "$PRG-$VER" ; }
  58 sub DEF_TIMEOUT { $DEF_TIMEOUT ; }
  59 sub is_get_opt  { my $opt = shift ; exists $GET_OPTS { $opt } ; }
  60
  61 sub getset
  62   { my $self = shift ;
  63     my $attr = shift ;
  64     if ( @_ ) { $self -> { $attr } = shift ; }
  65     die "no attr '$attr'" unless exists $self -> { $attr } ;
  66     $self -> { $attr } ;
  67   }
  68
  69 sub mk_method
  70   { my $self = shift ;
  71     my $attr = shift ;
  72     sprintf 'sub %s { my $self = shift ; $self -> getset ( "%s",  @_ ) ; }'
  73       , $attr, $attr ;
  74   }
  75
  76 sub mk_methods
  77   { my $self = shift ;
  78     join "\n", map { Base -> mk_method ( $_ ) ; } @_ ;
  79   }
  80
  81 sub aprx_eq { my ( $t1, $t2 ) = @_ ; abs ( $t1 - $t2 ) < $APRX_DELTA ; }
  82 sub aprx_ge { my ( $t1, $t2 ) = @_ ; $t1 > $t2 or      aprx_eq $t1, $t2 ; }
  83 sub aprx_le { my ( $t1, $t2 ) = @_ ; $t1 < $t2 or      aprx_eq $t1, $t2 ; }
  84 sub aprx_gt { my ( $t1, $t2 ) = @_ ; $t1 > $t2 and not aprx_eq $t1, $t2 ; }
  85 sub aprx_lt { my ( $t1, $t2 ) = @_ ; $t1 < $t2 and not aprx_eq $t1, $t2 ; }
  86
  87 sub URL { sprintf '<A HREF="%s">%s</A>', $_[0], $_[1] ; }
  88 sub NAM { sprintf '<A NAME="%s">%s</A>', $_[0], $_[1] ; }
  89 sub SMA { sprintf "<FONT SIZE=\"-1\">%s</FONT>", $_[0] ; }
  90 sub BLD { sprintf "<B>%s</B>", $_[0] ; }
  91 sub NSS { sprintf SMA('%s&nbsp;site%s'), $_[0], ( $_[0] == 1 ? '' : 's' ) ; }
  92 sub TAB { sprintf "<TABLE BORDER=2 CELLPADDING=3>%s</TABLE>", $_[0] ; }
  93 sub BQ  { sprintf "<BLOCKQUOTE>\n%s\n</BLOCKQUOTE>\n", $_[0] ; }
  94 sub TR  { sprintf "<TR>%s</TR>\n", $_[0] ; }
  95 sub TH  { sprintf "<TH>%s</TH>\n", $_[0] ; }
  96 sub TD  { sprintf "<TD>%s</TD>\n", $_[0] ; }
  97 sub H1  { sprintf "<H1>%s</H1>\n", $_[0] ; }
  98 sub H2  { sprintf "<H2>%s</H2>\n", $_[0] ; }
  99 sub H3  { sprintf "<H3>%s</H3>\n", $_[0] ; }
 100 sub TDr { sprintf "<TD ALIGN=\"RIGHT\">%s</TD>\n", $_[0] ; }
 101 sub RED { sprintf "<FONT COLOR=\"RED\">%s</FONT>", $_[0] ; }
 102 sub GRN { sprintf '<FONT COLOR="GREEN">%s</FONT>', $_[0] ; }
 103
 104 sub s4tim
 105   { my $tim = shift ;
 106     my %tab = ( 's' => 1, 'm' => 60, 'h' => 60 * 60, 'd' => 60 * 60 * 24 ) ;
 107     die "wrong time '$tim'" unless $tim =~ /$TIM_PAT/o ;
 108     my $m = $1 ; my $u = $2 ;
 109     return $m * $tab { $u } ;
 110   }
 111
 112 sub pr_interval
 113   { my $s = shift ;
 114     my ( $magn, $unit ) ;
 115     my $mins  = $s / 60          ; my $m = int ( $mins + 0.5 ) ;
 116     my $hours = $s / ( 60 * 60 ) ; my $h = int ( $hours + 0.5 ) ;
 117
 118     if ( $s < 50 )
 119       { $magn = $s ; $unit = 'second' ; }
 120     elsif ( $m < 50 )
 121       { $magn = $m ; $unit = 'minute' ; }
 122     elsif ( $h < 36 )
 123       { $magn = $h ; $unit = 'hour' ; }
 124     else
 125       { $magn = sprintf "%.1f", $hours / 24 ; $unit = 'day' ; }
 126
 127     $unit .= 's' unless $magn == 1 ;
 128
 129     return "$magn $unit" ;
 130   }
 131
 132 sub pr_diff
 133   { my $time = shift ;
 134     my $max  = shift ;
 135     my $res ;
 136
 137     if ( $time == $^T )
 138       { $res = BLD 'renewed' ; }
 139     else
 140       { $res = pr_interval $^T - $time ;
 141         $res = BLD RED $res if aprx_lt $time, $max ;
 142       }
 143     return $res ;
 144   }
 145
 146 sub exp_date
 147   { my @day = qw(Sun Mon Tue Wed Thu Fri Sat) ;
 148     my @mon = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec) ;
 149     my @gmt = gmtime time + 3600 ;
 150     sprintf "%s, %02d %s %4d %02d:%02d:%02d GMT"
 151       , $day [ $gmt [ 6 ] ]
 152       , $gmt [ 3 ]
 153       , $mon [ $gmt [ 4 ] ]
 154       , $gmt [ 5 ] + 1900
 155       , @gmt [ 2, 1, 0 ]
 156       ;
 157   }
 158
 159 sub htmlquote
 160   { my $x = shift ;
 161     $x =~ s/&/&amp;/g ;
 162     $x =~ s/</&lt;/g ;
 163     $x =~ s/>/&gt;/g ;
 164     return $x ;
 165   }
 166
 167 package Mirmon ; ###################################################
 168
 169 BEGIN { use base 'Base' ; Base -> import () ; }
 170
 171 use IO::Select ;
 172 use Net::hostent ;
 173
 174   { my %opt = ( v => 0 , d => 0 , q => 0 ) ;
 175     sub _opt
 176       { my ( $key, $val ) = @_ ;
 177         my $res ;
 178         unless ( exists $opt { $key } )
 179           { warn "unknown Mirmon option '$key'\n" ; }
 180         else
 181           { $res = $opt { $key } ;
 182             $opt { $key } = $val if defined $val ;
 183           }
 184         $res ;
 185       }
 186   }
 187
 188 sub verbose { _opt ( 'v', shift ) ; }
 189 sub quiet   { _opt ( 'q', shift ) ; }
 190 sub debug   { _opt ( 'd', shift ) ; }
 191
 192 eval Base -> mk_methods ( qw(conf state regions) ) ;
 193
 194 sub config_list
 195   { my $self = shift ;
 196     my $home = ( getpwuid $< ) [ 7 ] or die "can get homedir '$<' ($!)" ;
 197     ( 'mirmon.conf', "$home/.mirmon.conf", '/etc/mirmon.conf' ) ;
 198   }
 199
 200 sub new
 201   { my $self = shift ;
 202     my $path = shift ;
 203     my $res  = bless {}, $self ;
 204     $res -> get_config ( $path ) ;
 205     $res -> get_state ;
 206     $res -> get_regions ;
 207     $res ;
 208   }
 209
 210 sub find_config
 211   { my $self = shift ;
 212     my $arg = shift ;
 213     my @LIST = $arg ? ( $arg ) : Mirmon -> config_list ;
 214     for my $conf ( @LIST ) { return $conf if -f $conf ; }
 215     die sprintf "can't find a config file :\n  %s\n" , join "\n  ", @LIST ;
 216   }
 217
 218 sub get_config
 219   { my $self = shift ;
 220     my $path = shift ;
 221     my $file = $self -> find_config ( $path ) ; # or die
 222     $self -> conf ( Mirmon::Conf -> new ( $file ) ) ;
 223   }
 224
 225 sub get_state
 226   { my $self = shift ;
 227     my $conf = $self -> conf ;
 228     my $state = $conf -> state ;
 229     my $res = {} ;
 230     open STATE, $state or die "can't open $state ($!)" ;
 231     for my $line ( <STATE> )
 232       { chop $line ;
 233         my $mirror = Mirmon::Mirror -> new ( $self, $line ) ;
 234         $res -> { $mirror -> url } = $mirror ;
 235       }
 236     close STATE ;
 237
 238     my $mlist = $conf -> mirror_list ;
 239     my $style = $conf -> list_style ;
 240     my %in_list = () ;
 241     open MLIST, $mlist or die "can't open $mlist ($!)" ;
 242     for my $line ( <MLIST> )
 243       { chop $line ;
 244         next if $line =~ /^#/ ;
 245         next if $line =~ /^\s*$/ ;
 246         my ( $reg, $url, $mail ) ;
 247         if ( $style eq 'plain' )
 248           { ( $reg, $url, $mail ) = split ' ', $line ; }
 249         elsif ( $style eq 'apache' )
 250           { my $apache_type ;
 251             ( $apache_type, $reg, $url, $mail ) = split ' ', $line ;
 252             unless (  defined $APA_TYPES { $apache_type } )
 253               { print "*** strange type in $url ($apache_type)\n"
 254                   unless Mirmon::quiet ;
 255                 next ;
 256               }
 257           }
 258
 259         if ( $conf -> add_slash and $url !~ m!/$! )
 260           { print "*** appended '/' to $url\n" unless Mirmon::quiet ;
 261             $url .= '/' ;
 262           }
 263
 264         $in_list { $url } ++ ;
 265
 266         unless ( exists $res -> { $url } )
 267           { printf "*** added to list %s\n", $url unless Mirmon::quiet ;
 268             $res -> { $url } = Mirmon::Mirror -> init ( $self, $url ) ;
 269           }
 270         my $mirror = $res -> { $url } ;
 271         $mirror -> region ( $reg ) ;
 272         $mirror -> mail ( $mail || '' ) ;
 273       }
 274     close MLIST ;
 275
 276     for my $url ( sort keys %$res )
 277       { # printf "%s\n", $res -> { $url } -> state ;
 278         unless ( exists $in_list { $url } )
 279           { printf "*** removed from list %s\n", $url unless Mirmon::quiet ;
 280             delete $res -> { $url } ;
 281           }
 282       }
 283     $self -> state ( $res ) ;
 284   }
 285
 286 sub put_state
 287   { my $self  = shift ;
 288     my $state = $self -> state ;
 289     my $file  = $self -> conf -> state ;
 290     my $TMP = "$file.tmp" ;
 291     open TMP, ">$TMP" or die "can't write '$TMP' ($!)" ;
 292     for my $url ( sort keys %$state )
 293       { printf TMP "%s\n", $state -> { $url } -> state
 294           or die "can't print $url to $TMP ($!)" ;
 295       }
 296     close TMP ;
 297
 298     if ( -z $TMP )
 299       { warn "wrote empty state file; keeping previous version" ; }
 300     else
 301       { rename $TMP, $file or die "can't rename '$TMP', '$file' ($!)" ; }
 302   }
 303
 304 sub get_regions
 305   { my $self = shift ;
 306     my $file =  $self -> conf -> countries ;
 307     open REGS, $file or die "can't open countries '$file' ($!)" ;
 308     while ( <REGS> )
 309       { chop ;
 310         next if /^#/ ;
 311         my ( $code, $dash, $reg ) = split ' ', $_, 3 ;
 312         $self -> { regions } { lc $code } = lc $reg ;
 313       }
 314     close REGS ;
 315   }
 316
 317 sub get_dates
 318   { my $self  = shift ;
 319     my $get   = shift ;
 320     my $state = $self -> state ;
 321     my $conf = $self -> conf ;
 322     my $CMD  = $conf -> probe ;
 323     my $PAR  = $conf -> max_probes ;
 324     my %m4h  = () ;
 325     my @QUE  = () ;
 326     my @NOQ  = () ;
 327     my $GET = IO::Select -> new () ;
 328
 329     my $cnt = 0 ;
 330     my $nok = 0 ;
 331
 332     for my $url ( sort keys %$state )
 333       { my $mirror = $state -> { $url } ;
 334         $cnt ++ if $mirror -> last_status eq 'ok' ;
 335         if ( $get eq 'all' or $mirror -> last_probe eq 'undef' )
 336           { push @QUE, $mirror ; }
 337         elsif ( $get eq 'update' )
 338           { my $stat = $mirror -> last_status ;
 339             my $vrfy = $mirror -> last_ok_probe ;
 340             my $lprb = $mirror -> last_probe ;
 341             if ( aprx_le $lprb, $^T - s4tim $conf -> min_poll )
 342               { if ( $stat ne 'ok' )
 343                   { push @QUE, $mirror ; $nok ++ ; }
 344                 elsif ( aprx_le $vrfy, $^T - s4tim $conf -> max_poll )
 345                   { push @QUE, $mirror ; }
 346                 else
 347                   { push @NOQ, $mirror ; }
 348               }
 349           }
 350         else
 351           { die "unknown opt_get '$get'" ; }
 352       }
 353
 354     if ( Mirmon::verbose )
 355       { my $que = scalar @QUE ; my $noq = scalar @NOQ ;
 356         printf "ok mirrors %d, queued %d, not queued %d, ok %d, nok %d\n"
 357           , $cnt, $que, $noq, $que - $nok, $nok
 358       }
 359
 360     if ( $conf -> randomize )
 361       { my $hrs  = int ( ( s4tim $conf -> max_poll ) / 60 / 60 + 0.5 ) ;
 362         my $avg  = int ( $cnt / $hrs + 0.5 ) ;
 363         my $prc  = ( scalar keys %$state ) / 50 ;
 364         my $flr  = int $prc ;
 365         my $extras = $flr + ( rand 1 < ( $prc - $flr ) ) ;
 366         my $picked = 0 ;
 367
 368         while ( @QUE < $avg + $nok and @NOQ and $picked < $extras )
 369           { my $idx = int rand @NOQ ;
 370             push @QUE, $NOQ [ $idx ] ;
 371             $NOQ [ $idx ] = $NOQ [ $#NOQ ] ;
 372             pop @NOQ ;
 373             $picked ++ ;
 374           }
 375
 376         printf "avg mirrors/hr %d, max extras %d, picked %d ; queued %s\n"
 377           , $avg, $extras, $picked, scalar @QUE if Mirmon::verbose ;
 378       }
 379
 380     while ( @QUE )
 381       { my $started = 0 ;
 382         while ( $GET -> count () < $PAR and @QUE )
 383           { my $mirror = shift @QUE ;
 384             if ( gethost $mirror -> site )
 385               { my $handle = $mirror -> start_probe ;
 386                 $m4h { $handle } = $mirror ;
 387                 $GET -> add ( $handle ) ;
 388                 $started ++ ;
 389               }
 390             else
 391               { $mirror -> update ( 0, 'site_not_found', undef ) ; }
 392           }
 393
 394         my @can_read = $GET -> can_read ( 0 ) ;
 395
 396         printf "queue %d, started %d, probes %d, can_read %d\n",
 397           scalar @QUE, $started, $GET -> count (), scalar @can_read
 398             if Mirmon::verbose ;
 399
 400         for my $handle ( @can_read )
 401           { # order is important ; wget's hang if/when actions are reversed
 402             $GET -> remove ( $handle ) ;
 403             $m4h { $handle } -> finish_probe ( $handle ) ;
 404           }
 405
 406         sleep 1 ;
 407       }
 408
 409     my $stop = time + $conf -> timeout + 10 ;
 410
 411     while ( $GET -> count () and time < $stop )
 412       { my @can_read = $GET -> can_read ( 0 ) ;
 413
 414         printf "wait %2d, probes %d, can_read %d\n",
 415           $stop - scalar time, $GET -> count (), scalar @can_read
 416             if Mirmon::verbose ;
 417
 418         for my $handle ( @can_read )
 419           { $GET -> remove ( $handle ) ;
 420             $m4h { $handle } -> finish_probe ( $handle ) ;
 421           }
 422
 423         sleep 10 ;
 424       }
 425
 426     for my $handle ( $GET -> handles () )
 427       { $m4h { $handle } -> update ( 0, 'hangs', undef ) ; }
 428   }
 429
 430 sub img_sf_cnt
 431   { my $self = shift ;
 432     my $prf  = shift ;
 433     my $cnt  = shift ;
 434     my $res ;
 435     if ( $prf eq 'x' )
 436       { sprintf
 437           ( '<IMG BORDER=1 SRC="%s/bar.gif" ALT="">'
 438           , $self -> conf -> icons
 439           ) x $cnt ;
 440       }
 441     else
 442      { sprintf '<IMG BORDER=1 SRC="%s/mm%s%02d.gif" ALT="">'
 443          , $self -> conf -> icons, $prf, $cnt ;
 444      }
 445   }
 446
 447 sub img_sf { my $self = shift ; $self -> img_sf_cnt ( $_[0], 1 ) ; }
 448
 449 sub show_hist
 450   { my $self = shift ;
 451     my $hst = shift ;
 452     if ( $hst =~ /-(.*)$/ ) { $hst = $1 ; }
 453     return '' unless $hst =~ m/^[sbfzx]+$/ ;
 454     if ( length $hst == $HIST and $hst =~ /^(s*b)s*$/ )
 455       { return $self -> img_sf_cnt ( 'sb',  length $1 ) ; }
 456     elsif ( length $hst == $HIST and $hst =~ /^(s*f)s*$/ )
 457       { return $self -> img_sf_cnt ( 'sf',  length $1 ) ; }
 458     elsif ( length $hst == $HIST and $hst =~ /^(s*b)fs*$/ )
 459       { return $self -> img_sf_cnt ( 'sbf', length $1 ) ; }
 460     my $res = '' ;
 461     my $cnt = 1 ;
 462     my $prf = substr $hst, 0, 1 ;
 463     $hst = substr $hst, 1 ;
 464     while ( $hst ne '' )
 465       { if ( substr ( $prf, 0, 1 ) eq substr ( $hst, 0, 1 ) )
 466           { $cnt ++ ;
 467             $hst = substr $hst, 1 ;
 468           }
 469         else
 470           { $res .= $self -> img_sf_cnt ( $prf, $cnt ) ;
 471             $prf = substr $hst, 0, 1 ;
 472             $hst = substr $hst, 1 ;
 473             $cnt = 1 ;
 474           }
 475       }
 476     $res .= $self -> img_sf_cnt ( $prf, $cnt ) if $cnt ;
 477     $res ;
 478   }
 479
 480 sub gen_histogram_probes
 481   { my $self = shift ;
 482     my $state = $self -> state ;
 483     my %tab = () ;
 484     my %bad = () ;
 485     my $res = '' ;
 486     my $s_cnt = 0 ;
 487     my $f_cnt = 0 ;
 488     my $hr_min ;
 489     my $hr_max ;
 490     for my $url ( keys %$state )
 491       { my $mirror = $state -> { $url } ;
 492         my $lprb = $mirror -> last_probe ;
 493         my $stat = $mirror -> last_status ;
 494         next if $lprb eq 'undef' ;
 495         my $hr = int ( ( $^T - $lprb ) / 3600 + 0.5 ) ;
 496         $hr_min = $hr if ! defined $hr_min or $hr < $hr_min ;
 497         $hr_max = $hr if ! defined $hr_max or $hr > $hr_max ;
 498         if ( $stat eq 'ok' )
 499           { $tab { $hr } ++ ; $s_cnt ++ ; }
 500         else
 501           { $bad { $hr } ++ ; $f_cnt ++ ; }
 502       }
 503     return BQ 'nothing yet' unless scalar keys %tab ;
 504
 505     $res = TR
 506       ( TH ( 'hours ago' )
 507       . TH ( 'succ' )
 508       . TH ( 'fail' )
 509       . TH sprintf
 510           ( '%s %s, %s %s'
 511           , $s_cnt , GRN ( 'successful' )
 512           , $f_cnt , RED ( 'failed' )
 513           )
 514       ) ;
 515
 516     my $max = 0 ;
 517     for my $x ( keys %tab )
 518       { my $tot = $tab { $x } + ( $bad { $x } || 0 ) ;
 519         $max = $tot if $max < $tot ;
 520       }
 521
 522     return BQ "nothing yet" unless $max ;
 523
 524     for my $hr ( $hr_min .. $hr_max )
 525       { my $x = $tab { $hr } || 0 ;
 526         my $y = $bad { $hr } || 0 ;
 527         my $n = int ( $x / $max * $HIST ) ;
 528         my $b = int ( $y / $max * $HIST ) ;
 529         $res .= TR
 530           ( TDr ( $hr )
 531           . TDr ( $x )
 532           . TDr ( $y )
 533           . TD
 534               ( ( $n ? $self -> img_sf_cnt ( 's', $n ) : '' )
 535               . ( $b ? $self -> img_sf_cnt ( 'f', $b ) : '' )
 536               . ( ( $n + $b ) ? '' : '&nbsp;' )
 537               )
 538           ) ;
 539       }
 540     return BQ TAB $res ;
 541   }
 542
 543 sub age_avg
 544   { my $self = shift ;
 545     my $state = $self -> state ;
 546     my @tab = () ;
 547     for my $url ( keys %$state )
 548       { my $time = $state -> { $url } -> age ;
 549         push @tab, $^T - $time if $time =~ /^\d+$/ ;
 550       }
 551     my $cnt = @tab ;
 552
 553     return undef if $cnt == 0 ;
 554
 555     @tab = sort { $a <=> $b } @tab ;
 556
 557     my $tot = 0 ;
 558     for my $age ( @tab ) { $tot += $age ; }
 559     my $mean = $tot / $cnt ;
 560
 561     my $median ;
 562     if ( $cnt == 1 )
 563       { $median = $tab [ 0 ] ; }
 564     elsif ( $cnt % 2 )
 565       { my $mid = int ( $#tab / 2 ) ;
 566         $median = ( $tab [ $mid ] + $tab [ $mid + 1 ] ) / 2 ;
 567       }
 568     else
 569       { my $mid = int ( $#tab / 2 ) ;
 570         $median = $tab [ $mid ] ;
 571       }
 572
 573     if ( @tab < 2 )
 574       { return $mean, $median, undef ; }
 575
 576     my $sum = 0 ;
 577     for my $age ( @tab )
 578       { $sum += ( $age - $mean ) ** 2 ; }
 579     my $stddev = sqrt ( $sum / ( $cnt - 1 ) ) ;
 580
 581     return $mean, $median, $stddev ;
 582   }
 583
 584 sub legend
 585   { my $self = shift ;
 586     my $conf = $self -> conf ;
 587     my $min_sync = $conf -> min_sync ;
 588     my $max_sync = $conf -> max_sync ;
 589     my $min_poll = $conf -> min_poll ;
 590     my $max_poll = $conf -> max_poll ;
 591
 592     return <<LEGENDA ;
 593 <H3>legend</H3>
 594
 595 <H4><I>project</I> site -- home</H4>
 596
 597 <BLOCKQUOTE>
 598 <B><I>project</I> site</B> is an url.
 599 The <B>href</B> is the href for the site in the list of mirrors,
 600 usually the root of the mirrored file tree.
 601 The <B>text</B> is the <I>site</I> of that url.
 602 <P>
 603 <B>home</B> (represented by the <B>@</B>-symbol) is an url
 604 pointing to the document root of the site. This pointer is
 605 useful if the <B><I>project</I> site</B> url is invalid,
 606 possibly because the mirror site moved the archive.
 607 </BLOCKQUOTE>
 608
 609 <H4>type</H4>
 610
 611 <BLOCKQUOTE>
 612 Indicates the type (<B>ftp</B> or <B>http</B>) of
 613 the <B><I>project</I> site</B> and <B>home</B> urls.
 614 </BLOCKQUOTE>
 615
 616 <H4>mirror age, daily stats</H4>
 617
 618 <BLOCKQUOTE>
 619 The <B>mirror age</B> is based upon the last successful probe.
 620 <P>
 621 Once a day the status of a mirror site is determined.
 622 The status (represented by a colored block) is appended
 623 to the <B>right</B> of the status history (<I>right</I>
 624 is <I>recent</I>). More precise, the status block is appended
 625 if the last status block was appended 24 (or more) hours ago.
 626 <P>The status of a mirror depends on its age and a few
 627 configuration parameters :
 628 <BLOCKQUOTE>
 629 <TABLE BORDER=1 CELLPADDING=5>
 630 <TR>
 631   <TH ROWSPAN=3>status</TH>
 632   <TH COLSPAN=4>age</TH>
 633 </TR>
 634 <TR>
 635   <TH COLSPAN=2 BGCOLOR=YELLOW>this project</TH>
 636   <TH COLSPAN=2 BGCOLOR=AQUA>in general</TH>
 637 </TR>
 638 <TR>
 639   <TH BGCOLOR=YELLOW>min</TH>
 640   <TH BGCOLOR=YELLOW>max</TH>
 641   <TH BGCOLOR=AQUA>min</TH>
 642   <TH BGCOLOR=AQUA>max</TH>
 643 </TR>
 644 <TR>
 645   <TH><FONT COLOR=GREEN>fresh</FONT></TH>
 646   <TD BGCOLOR=YELLOW ALIGN=CENTER>0</TD>
 647   <TD BGCOLOR=YELLOW ALIGN=CENTER>$min_sync + $max_poll</TD>
 648   <TD BGCOLOR=AQUA   ALIGN=CENTER>0</TD>
 649   <TD BGCOLOR=AQUA   ALIGN=CENTER>min_sync + max_poll</TD>
 650 </TR>
 651 <TR>
 652   <TH><FONT COLOR=BLUE>oldish</FONT></TH>
 653   <TD BGCOLOR=YELLOW ALIGN=CENTER>$min_sync + $max_poll</TD>
 654   <TD BGCOLOR=YELLOW ALIGN=CENTER>$max_sync + $max_poll</TD>
 655   <TD BGCOLOR=AQUA   ALIGN=CENTER>min_sync + max_poll</TD>
 656   <TD BGCOLOR=AQUA   ALIGN=CENTER>max_sync + max_poll</TD>
 657 </TR>
 658 <TR>
 659   <TH><FONT COLOR="RED">old</FONT></TH>
 660   <TD BGCOLOR=YELLOW ALIGN=CENTER>$max_sync + $max_poll</TD>
 661   <TD BGCOLOR=YELLOW ALIGN=CENTER>&infin;</TD>
 662   <TD BGCOLOR=AQUA   ALIGN=CENTER>max_sync + max_poll</TD>
 663   <TD BGCOLOR=AQUA   ALIGN=CENTER>&infin;</TD>
 664 </TR>
 665 <TR>
 666   <TH><FONT COLOR=BLACK>bad</FONT></TH>
 667   <TH COLSPAN=4 BGCOLOR=BLACK>
 668     <FONT COLOR=WHITE>the site or mirror tree was never found</FONT></TH>
 669 </TR>
 670 </TABLE>
 671 </BLOCKQUOTE>
 672 </BLOCKQUOTE>
 673
 674 <H4>last probe, probe stats</H4>
 675
 676 <BLOCKQUOTE>
 677 <B>Last probe</B> indicates when the last successful probe was made.
 678 <B>Probe stats</B> gives the probe history (<I>right</I> is <I>recent</I>).
 679 A probe is either a
 680 <FONT COLOR=GREEN><B>success</B></FONT> or a
 681 <FONT COLOR=RED><B>failure</B></FONT>.
 682 </BLOCKQUOTE>
 683
 684 <H4>last stat</H4>
 685
 686 <BLOCKQUOTE>
 687 <B>Last stat</B> gives the status of the last probe.
 688 </BLOCKQUOTE>
 689
 690 LEGENDA
 691   }
 692
 693 sub _ths
 694   { return '' unless my $ths = shift ;
 695     $ths == 1 ? TH '' : "<TH COLSPAN=$ths></TH>\n" ;
 696   }
 697
 698 sub gen_histogram
 699   { my $self  = shift ;
 700     my $where = shift ;
 701     my $conf  = $self -> conf ;
 702     my $state = $self -> state ;
 703
 704     return '' if $where ne $conf -> put_histo ;
 705
 706     my $MAX_H = $conf -> max_age1 ;
 707     my $MAX_h = 1 +
 708       ( ( 20 * 3600 <= $MAX_H and $MAX_H <= 36 * 3600 )
 709       ? int ( $MAX_H / 3600 )
 710       : 25
 711       ) ;
 712     my $MAX_O = $conf -> max_age2 ;
 713     my $MAX_o = int ( $MAX_O / 3600 + 0.5 ) ;
 714     my $H = 18 ;
 715     my %W   = ( 'old' => 1, 'ded' => 1, 'bad' => 1 ) ;
 716     my %Wmx = ( 'old' => 5, 'ded' => 3, 'bad' => 3 ) ;
 717     my %tab ;
 718     my %hst ;
 719     my $res ;
 720     for ( my $x = 0 ; $x < $MAX_h ; $x ++ ) { $tab { $x } = 0 ; }
 721     $tab { old } = 0 ; $tab { ded } = 0 ; $tab { bad } = 0 ;
 722     for my $url ( keys %$state )
 723       { my $time = $state -> { $url } -> age ;
 724         if ( $time =~ /^\d+$/ )
 725           { my $s  = $^T - $time ;
 726             my $hr = int ( $s / $MAX_H * ( $MAX_h - 1 ) + 0.5 ) ;
 727             if    ( $s <= $MAX_H ) { $tab { $hr  } ++ ; }
 728             elsif ( $s <= $MAX_O ) { $tab { old } ++ ; }
 729             else                   { $tab { ded } ++ ; }
 730           }
 731         else
 732           { $tab { bad } ++ ; }
 733       }
 734     my $max = 0 ;
 735     for ( grep ! exists $Wmx { $_ }, keys %tab )
 736       { $max = $tab { $_ } if $tab { $_ } > $max ; }
 737
 738     my %bad ;
 739
 740     for my $aux ( keys %Wmx )
 741       { $bad { $aux } = $tab { $aux } ;
 742         if ( $bad { $aux } > $max )
 743           { $W { $aux } = $Wmx { $aux } ;
 744             my $d = int ( $bad { $aux } / $W { $aux } ) ;
 745             for ( my $i = 1 ; $i < $W { $aux } ; $i++ )
 746               { $tab { $aux . $i } = $d ;
 747                 if ( $bad { $aux } % $Wmx { $aux } > $i )
 748                   { $tab { $aux . $i } ++ ;
 749                     $tab { $aux } -- ;
 750                   }
 751               }
 752             $tab { $aux } -= ( $W { $aux } - 1 ) * $d ;
 753             $max = $tab { $aux } if $max < $tab { $aux } ;
 754           }
 755       }
 756
 757 #   if ( $opt{v} )
 758 #     { for my $hr ( keys %tab )
 759 #         { printf "tab '%s' = '%s'\n", $hr, $tab { $hr } ; }
 760 #     }
 761
 762     return 'nothing yet' unless $max ;
 763     $H = $max if 8 <= $max and $max <= 26 ;
 764     for ( keys %tab )
 765       { $hst { $_ } = int ( $H * $tab { $_ } / $max + 0.5 ) ; }
 766     my @keys = sort { $a <=> $b } grep /^\d+$/, keys %hst ;
 767     my $tab_hr = 0 ;
 768     for my $hr ( @keys ) { $tab_hr += $tab { $hr } ; }
 769     push @keys
 770       , grep ( m/^old/, sort keys %tab )
 771       , grep ( m/^ded/, sort keys %tab )
 772       , grep ( m/^bad/, sort keys %tab )
 773       ;
 774     my $img_bar = sprintf '<IMG SRC="%s/bar.gif" ALT="" BORDER=0>'
 775       , $conf -> icons ;
 776     my %img = ( bar => $img_bar ) ;
 777     for my $col ( qw(s b f z) ) { $img { $col } = $self -> img_sf ( $col ) ; }
 778
 779     for ( my $h = $H ; $h > 0 ; $h -- )
 780       { $res .= "<TR>\n" ;
 781         $res .= sprintf "<TH ROWSPAN=3 VALIGN=\"TOP\">&uarr;</TH>\n"
 782           if $h == $H ;
 783         $res .= sprintf '<TD ROWSPAN=%d ALIGN="CENTER">%s</TD>' . "\n"
 784           , $H-6, NSS ( $max ) if $h == $H - 3 ;
 785         $res .= sprintf "<TH ROWSPAN=3 VALIGN=\"BOTTOM\">&darr;</TH>\n"
 786           if $h == 3 ;
 787         my $ths = 0 ;
 788         for my $x ( @keys )
 789           { my $col =
 790               ( ( $hst { $x } >= $h )
 791               ? ( $x =~ /^\d+$/
 792                 ? 's'
 793                 : ( $x =~ /^old/ ? 'b' : ( $x =~ /^ded/ ? 'f' : 'z' ) )
 794                 )
 795               : ( ( $h == 1 and $hst { $x } == 0 ) ? 'bar' : '' )
 796               ) ;
 797             if ( $col )
 798               { $res .= _ths $ths ; $ths = 0 ; $res .= TH $img { $col } ; }
 799             else
 800               { $ths ++ ; }
 801           }
 802         $res .= _ths ( $ths ) . "</TR>\n" ;
 803       }
 804
 805     my $HR = '<HR SIZE=2 WIDTH="95%%" NOSHADE>' ;
 806
 807     $res .= "<TR>\n" ;
 808     $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", 1 ;
 809     $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", $MAX_h ;
 810     $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", $W { old } ;
 811     $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", $W { ded } ;
 812     $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", $W { bad } ;
 813     $res .= "</TR>\n" ;
 814
 815     $res .= "<TR>\n" ;
 816     $res .= '<TD ALIGN="CENTER">&nbsp;<B>age</B>&nbsp;&rarr;&nbsp;</TD>' ;
 817
 818     $res .= "<TH>|</TH>\n" ;
 819     $res .= sprintf
 820       ( '<TD COLSPAN=%d ALIGN="CENTER">'
 821       . '&larr;&nbsp; 0 &le; <B>age</B> &le; %s &nbsp;&rarr;'
 822       . "</TD>\n"
 823       , $MAX_h - 2, pr_interval ( $MAX_H )
 824       )
 825       ;
 826     $res .= "<TH>|</TH>\n" ;
 827     $res .= sprintf
 828       ( '<TD ALIGN="CENTER" COLSPAN=%d>'
 829       . '&nbsp;%sh&nbsp;&lt;&nbsp;%s&nbsp;&le;&nbsp;%sh&nbsp;'
 830       . "</TD>\n"
 831       , $W { old }, int($MAX_H/60/60) , BLD ( 'age' ), $MAX_o
 832       ) ;
 833     $res .= sprintf
 834       ( '<TD ALIGN="CENTER" COLSPAN=%d>'
 835       . '&nbsp;<FONT COLOR="RED">old</FONT>&nbsp;'
 836       . "</TD>\n"
 837       , $W { ded }
 838       ) ;
 839     $res .= sprintf
 840       ( '<TD ALIGN="CENTER" COLSPAN=%d>'
 841       . '&nbsp;<FONT COLOR="RED">bad</FONT>&nbsp;'
 842       . "</TD>\n"
 843       , $W { bad }
 844       ) ;
 845     $res .= "</TR>\n" ;
 846
 847     my $FRMT = '<TD ALIGN="CENTER" COLSPAN=%d>&nbsp;%s&nbsp;</TD>' ;
 848
 849     $res .= "<TR>\n" ;
 850     $res .= sprintf "$FRMT\n", 1,  NSS scalar keys %$state ;
 851     $res .= "<TH>|</TH>\n" ;
 852     $res .= sprintf "$FRMT\n", $MAX_h - 2, NSS $tab_hr ;
 853     $res .= "<TH>|</TH>\n" ;
 854     $res .= sprintf "$FRMT\n", $W { old }, NSS $bad { old } ;
 855     $res .= sprintf "$FRMT\n", $W { ded }, NSS $bad { ded } ;
 856     $res .= sprintf "$FRMT\n", $W { bad }, NSS $bad { bad } ;
 857     $res .= "</TR>\n" ;
 858
 859     $res = "<TABLE CELLSPACING=0 CELLPADDING=1 BORDER=0>\n$res\n</TABLE>\n" ;
 860     $res = sprintf "<TABLE CELLPADDING=5 BORDER=4>%s</TABLE>\n"
 861        , "<TR><TH>\n$res\n</TH></TR>" ;
 862     my $units = join ' '
 863       , $self -> img_sf ( 's' ) , $self -> img_sf ( 'b' )
 864       , $self -> img_sf ( 'f' ) , $self -> img_sf ( 'z' )
 865       ;
 866     if ( $max == $H )
 867       { $res .= sprintf "<BR>units %s represent one mirror site.\n"
 868           , $units ;
 869       }
 870     else
 871       { $res .= sprintf "<BR>each %s unit represents %s mirror sites.\n"
 872           , $units, sprintf ( "%.1f", $max / $H ) ;
 873       }
 874     return H2 ( 'age histogram' ) . BQ $res ;
 875   }
 876
 877 sub gen_page
 878   { my $self    = shift ;
 879     my $get     = shift ;
 880     my $VERSION = shift ;
 881     my $conf  = $self -> conf ;
 882     my $PPP   = $conf -> web_page ;
 883     my $state = $self -> state ;
 884     my $CCS   = $self -> regions ;
 885     my $TMP = "$PPP.tmp" ;
 886     my %tab ;
 887     my $refs ;
 888
 889     for my $url ( keys %$state )
 890       { my $mirror = $state -> { $url } ;
 891         my $reg = $mirror -> region ;
 892         push @{ $tab { $reg } }, $mirror ;
 893       }
 894
 895     my $bad = 0 ; my $old = 0 ; my $unr = 0 ;
 896     my %stats ;
 897     my @stats ;
 898     my $ok = 0 ;
 899
 900     for my $url ( keys %$state )
 901       { my $mirror = $state -> { $url } ;
 902         my $time = $mirror -> age ;
 903         my $stat = $mirror -> last_status ;
 904         my $vrfy = $mirror -> last_ok_probe ;
 905         if ( $stat eq 'ok' ) { $ok ++ ; } else { $stats { $stat } ++ ; }
 906         if ( $time eq 'undef' )
 907           { $bad ++ ; }
 908         elsif ( 'f' eq $conf -> age_code ( $time ) )
 909           { $old ++ ; }
 910         if ( $vrfy eq 'undef' or aprx_lt $vrfy, $^T - $conf -> max_vrfy )
 911           { $unr ++ ; }
 912       }
 913
 914     my $STAT = sprintf
 915         "%d bad -- %d older than %s -- %s unreachable for more than %s"
 916       , $bad
 917       , $old
 918       , pr_interval ( $conf -> max_age2 )
 919       , $unr
 920       , pr_interval ( $conf -> max_vrfy )
 921       ;
 922
 923     my $PROB = 'last probes : ' ;
 924     push @stats, "$ok were ok" if $ok ;
 925     for my $stat ( sort keys %stats )
 926       { ( my $txt = $stat ) =~ s/_/ /g ;
 927         push @stats, sprintf "%s had %s" , $stats { $stat } , RED $txt ;
 928       }
 929     $PROB .= join ', ', @stats ;
 930
 931     my ( $mean, $median, $stddev ) = $self -> age_avg ;
 932     my $AVGS = "mean mirror age is " ;
 933     unless ( defined $mean )
 934        { $AVGS = "<I>undefined</I>" ; }
 935     else
 936        { $AVGS .= sprintf "%s", pr_interval $mean ;
 937          if ( defined $stddev )
 938            { $AVGS .= sprintf ", std_dev %s", pr_interval $stddev ; }
 939          $AVGS .= sprintf ", median %s", pr_interval $median ;
 940        }
 941
 942     for my $reg ( sort keys %tab )
 943       { $refs .= sprintf "&nbsp;%s&nbsp;\n"
 944           , URL "#$reg", "<FONT SIZE=\"+1\">$reg</FONT>"
 945           ;
 946       }
 947
 948     my $COLS = 5 ;
 949     my $NAME = $conf -> project_name ;
 950     my $LOGO = $conf -> project_logo
 951       ? URL
 952           ( $conf -> project_url
 953           , sprintf
 954               ( '<IMG SRC="%s" ALT="%s" ALIGN="RIGHT" BORDER=0>'
 955               , $conf -> project_logo
 956               , $conf -> project_name
 957               )
 958           )
 959       : ''
 960       ;
 961     my $HEAD = $conf -> htm_head . "\n" ;
 962     my $HTOP = $conf -> htm_top  . "\n" ;
 963     my $FOOT = $conf -> htm_foot . "\n" ;
 964     my $TITL = URL $conf -> project_url, $NAME ;
 965     my $EXPD = Base::exp_date ;
 966     my $DATE = scalar gmtime $^T ;
 967     my $LAST = scalar gmtime ( $get ? $^T : ( stat $conf -> state ) [9] ) ;
 968
 969     my $histo_top = $self -> gen_histogram ( 'top' ) ;
 970     my $histo_bot = $self -> gen_histogram ( 'bottom' ) ;
 971
 972     open PPP, ">$TMP" or die "can't write $TMP ($!)" ;
 973     my $prev_select = select PPP ;
 974
 975     my $attr1 = "COLSPAN=$COLS BGCOLOR=LIME" ;
 976     my $attr2 = 'BGCOLOR=AQUA' ;
 977     my $attr3 = "COLSPAN=$COLS BGCOLOR=YELLOW" ;
 978
 979     my $num_mirrors = scalar keys %$state ;
 980     my $num_regions = scalar keys %tab ;
 981
 982     print <<HEAD ;
 983 <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
 984 <HTML>
 985 <HEAD>
 986 <TITLE>the status of $NAME mirrors</TITLE>
 987 <META HTTP-EQUIV="content-type" CONTENT="text/html; charset=utf-8">
 988 <META HTTP-EQUIV=refresh CONTENT=3600>
 989 <META HTTP-EQUIV=Expires CONTENT=\"$EXPD\">
 990 $HEAD
 991 </HEAD>
 992 <BODY BGCOLOR=\"#FFFFFF\">
 993 $LOGO
 994 <H2>the status of $TITL mirrors</H2>
 995 <TABLE BORDER=0 CELLPADDING=2>
 996 <TR><TD>date</TD><TD>:</TD><TD>$DATE (UTC)</TD></TR>
 997 <TR><TD>last&nbsp;check</TD>
 998   <TD>:</TD>
 999   <TD>$LAST (UTC)</TD>
1000 </TR>
1001 </TABLE>
1002 $HTOP
1003 $histo_top
1004 <H2>regions</H2>
1005 <BLOCKQUOTE><CENTER>\n$refs\n</CENTER></BLOCKQUOTE>
1006 <H2>report</H2>
1007 <BLOCKQUOTE>
1008 <TABLE BORDER=2 CELLPADDING=5>
1009 <TR><TH $attr1>$num_mirrors sites in $num_regions regions</TH></TR>
1010 <TR><TH $attr1>$STAT</TH></TR>
1011 <TR><TH $attr1>$PROB</TH></TR>
1012 <TR><TH $attr1>$AVGS</TH></TR>
1013 <TR>
1014   <TH $attr2>$NAME site -- home</TH>
1015   <TH $attr2>type</TH>
1016   <TH $attr2>mirror age,<BR>daily stats</TH>
1017   <TH $attr2>last probe,<BR>probe stats</TH>
1018   <TH $attr2>last stat</TH>
1019 </TR>
1020 HEAD
1021
1022     for my $reg
1023       ( sort
1024        { ( $CCS -> { $a } || $a ) cmp ( $CCS -> { $b } || $b ) ; }
1025        keys %tab
1026       )
1027       { my $mirrors = $tab { $reg } ;
1028
1029         my $ccs = exists $CCS -> { $reg } ? $CCS -> { $reg } : $reg ;
1030         $ccs = NAM $reg,
1031           ( scalar @{ $mirrors } > 6
1032           ? sprintf "%s&nbsp;&nbsp;-&nbsp;&nbsp;%d sites"
1033               , $ccs, scalar @{ $mirrors }
1034           : $ccs
1035           ) ;
1036         printf "<TR><TH $attr3>$ccs</TH></TR>\n" ;
1037
1038         for my $mirror ( sort { $a -> cmp ( $b ) } @$mirrors )
1039           { print "<TR>\n" ;
1040             printf "  <TD ALIGN=RIGHT>%s&nbsp;&nbsp;%s</TD>\n  <TD>%s</TD>\n"
1041               , $mirror -> site_url
1042               , $mirror -> home_url
1043               , $mirror -> type
1044               ;
1045
1046             my ( $url, $time, $stat, $vrfy, $hstp, $hsts ) =
1047               $mirror -> as_list ;
1048             my $pr_time = $time =~ /^\d+$/
1049               ? pr_diff $time, $^T - $conf -> max_age2 : '&nbsp;' ;
1050             my $pr_last = $vrfy =~ /^\d+$/
1051               ? pr_diff $vrfy, $^T - $conf -> max_vrfy : '&nbsp;' ;
1052             my $pr_hstp = $self -> show_hist ( $hstp ) ;
1053             my $pr_hsts = $self -> show_hist ( $hsts ) ;
1054
1055             if ( $stat ne 'ok' ) { $stat =~ s/_/ /g ; $stat = RED $stat ; }
1056             printf "  <TD ALIGN=RIGHT>%s<BR>%s</TD>\n" , $pr_time, $pr_hsts ;
1057             printf "  <TD ALIGN=RIGHT>%s<BR>%s</TD>\n" , $pr_last, $pr_hstp ;
1058             printf "  <TD>%s</TD>\n", $stat ;
1059             print "</TR>\n" ;
1060           }
1061       }
1062
1063     my $legend = $self -> legend ;
1064     my $probes = $self -> gen_histogram_probes ;
1065     my $mir_img = sprintf
1066       '<IMG BORDER=2 ALT=mirmon SRC="%s/mirmon.gif">' , $conf -> icons ;
1067
1068     print <<TAIL ;
1069 </TABLE>
1070 </BLOCKQUOTE>
1071 $histo_bot
1072 $legend
1073 <H3>probe results</H3>
1074 $probes
1075 <H3>software</H3>
1076 <BLOCKQUOTE>
1077 <TABLE>
1078 <TR>
1079   <TH><A HREF=\"$HOME\">$mir_img</A></TH>
1080   <TD>$VERSION</TD>
1081 </TR>
1082 </TABLE>
1083 </BLOCKQUOTE>
1084 $FOOT
1085 </BODY>
1086 </HTML>
1087 TAIL
1088
1089     select $prev_select ;
1090
1091     if ( print PPP "\n" )
1092       { close PPP ;
1093         if ( -z $TMP )
1094           { warn "wrote empty html file; keeping previous version" ; }
1095         else
1096           { rename $TMP, $PPP or die "can't rename $TMP, $PPP ($!)" ; }
1097       }
1098     else
1099       { die "can't print to $TMP ($!)" ; }
1100   }
1101
1102 package Mirmon::Conf ; #############################################
1103
1104 BEGIN { use base 'Base' ; Base -> import () ; }
1105
1106 our %CNF_defaults =
1107   ( project_logo => ''
1108   , timeout      => $DEF_TIMEOUT
1109   , max_probes   => 25
1110   , min_poll     => '1h'
1111   , max_poll     => '4h'
1112   , min_sync     => '1d'
1113   , max_sync     => '2d'
1114   , list_style   => 'plain'
1115   , put_histo    => 'top'
1116   , randomize    => 1
1117   , add_slash    => 1
1118   , htm_top      => ''
1119   , htm_foot     => ''
1120   , htm_head     => ''
1121   ) ;
1122
1123 our @REQ_KEYS =
1124   qw( web_page state countries mirror_list probe
1125       project_name project_url icons
1126     ) ;
1127 our %CNF_KEYS ;
1128 for ( @REQ_KEYS, keys %CNF_defaults ) { $CNF_KEYS { $_ } ++ ; }
1129
1130 my @LIST_STYLE = qw(plain apache) ;
1131 my @PUT_HGRAM  = qw(top bottom nowhere) ;
1132
1133 eval Base -> mk_methods ( keys %CNF_KEYS, qw(root site_url) ) ;
1134
1135 sub new
1136   { my $self = shift ;
1137     my $FILE = shift ;
1138     my $res = bless { %CNF_defaults }, $self ;
1139     $res -> root ( $FILE ) ;
1140     $res -> site_url ( {} ) ;
1141     $res -> get_conf () ;
1142   }
1143
1144 sub get_conf
1145   { my $self = shift ;
1146     my $FILE = ( @_ ? shift : $self -> root ) ;
1147
1148     if ( grep $_ eq $FILE,  @{ $self -> {_include} } )
1149       { die "already included : '$FILE'" ; }
1150     else
1151       { push @{ $self -> {_include} }, $FILE ; }
1152
1153     open FILE, $FILE or die "can't open '$FILE' ($!)" ;
1154     my $CONF = join "\n", grep /./, <FILE> ;
1155     close FILE ;
1156
1157     $CONF =~ s/\t/ /g ;           # replace tabs
1158     $CONF =~ s/^[+ ]+// ;         # delete leading space, plus
1159     $CONF =~ s/\n\n\s+/ /g ;      # glue continuation lines
1160     $CONF =~ s/\n\n\+\s+//g ;     # glue concatenation lines
1161     $CONF =~ s/\n\n\./\n/g ;      # glue concatenation lines
1162
1163     chop $CONF ;
1164     print "--$CONF--\n" if Mirmon::debug ;
1165     for ( grep ! /^#/, split /\n\n/, $CONF )
1166       { my ($key,$val) = split ' ', $_, 2 ;
1167         $val = '' unless defined $val ;
1168         print "conf '$FILE' : key '$key', val '$val'\n" if Mirmon::debug ;
1169         if ( exists $CNF_KEYS { $key } )
1170           { $self -> $key ( $val ) ; }
1171         elsif ( $key eq 'site_url' )
1172           { my ( $site, $url ) = split ' ' , $val ;
1173             $url .= '/' if $self -> add_slash and $url !~ m!/$! ;
1174             $self -> site_url -> { $site } = $url ;
1175 #           printf "config : for site '%s' use instead\n   '%s'\n",
1176 #             $site, $url if Mirmon::verbose ;
1177           }
1178         elsif ( $key eq 'no_add_slash' )
1179           { $self -> add_slash ( 0 ) ; }
1180         elsif ( $key eq 'no_randomize' )
1181           { $self -> randomize ( 0 ) ; }
1182         elsif ( $key eq 'show' )
1183           { $self -> show_conf if Mirmon::verbose ; }
1184         elsif ( $key eq 'exit' )
1185           { die 'exit per config directive' ; }
1186         elsif ( $key eq 'include' )
1187           { $self -> get_conf ( $val ) ; }
1188         elsif ( $key eq 'env' )
1189           { my ( $x, $y ) = split ' ' , $val ;
1190             $ENV { $x } = $y ;
1191             printf "config : setenv '%s'\n   '%s'\n", $x, $y
1192               if Mirmon::verbose ;
1193           }
1194         else
1195           { $self -> show_conf ;
1196             die "unknown keyword '$key' (value '$val')\n" ;
1197           }
1198       }
1199     my $err = $self -> check ;
1200     die $err if $err ;
1201     $self ;
1202   }
1203
1204 sub check
1205   { my $self = shift ;
1206     my $err = '' ;
1207     for my $key ( @REQ_KEYS )
1208       { unless ( exists $self -> { $key } )
1209           { $err .= "error: missing config for '$key'\n" ; }
1210       }
1211     for my $key ( qw(min_poll max_poll max_sync min_sync) )
1212       { my $max = $self -> $key ;
1213         unless ( $max =~ /$TIM_PAT/o )
1214           { $err .= "error: bad timespec for $key ($max)\n" ; }
1215       }
1216     unless ( grep $self -> { list_style } eq $_, @LIST_STYLE )
1217       { $err .= sprintf "error: unknown 'list_style' '%s'\n",
1218           $self -> list_style ;
1219       }
1220     unless ( grep $self -> put_histo eq $_, @PUT_HGRAM )
1221       { $err .= sprintf "%s : error: unknown 'put_histo' '%s'\n",
1222           $self -> put_histo ;
1223       }
1224     $err ;
1225   }
1226
1227 sub show_conf
1228   { my $self = shift ;
1229     print "vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv\n" ;
1230     for my $key ( sort keys %$self )
1231       { next if $key =~ m/^_/ ;
1232         my $val = $self -> { $key } ;
1233         print "show_conf : $key = '$val'\n" ;
1234       }
1235     for my $key ( sort keys %{ $self -> site_url } )
1236       { printf "show_conf : for site '%s' use instead\n   '%s'\n"
1237           , $key, $self -> site_url -> { $key } if Mirmon::verbose ;
1238       }
1239     printf "show_conf : included '%s'\n"
1240       , join "', '", @{ $self -> {_include} } ;
1241     print "^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n" ;
1242   }
1243
1244 sub max_age1
1245   { my $self = shift ;
1246     ( s4tim $self -> min_sync ) + ( s4tim $self -> max_poll ) ;
1247   }
1248
1249 sub max_age2
1250   { my $self = shift ;
1251     ( s4tim $self -> max_sync ) + ( s4tim $self -> max_poll ) ;
1252   }
1253
1254 sub max_vrfy
1255   { my $self = shift ;
1256     ( s4tim $self -> min_poll ) + ( s4tim $self -> max_poll ) ;
1257   }
1258
1259 sub age_code
1260   { my $self = shift ;
1261     my $time = shift ;
1262     return 'z' unless $time =~ /^\d+$/ ;
1263     return
1264       ( ( aprx_ge ( $time, $^T - $self -> max_age1 ) )
1265       ? 's'
1266       : ( aprx_ge ( $time, $^T - $self -> max_age2 ) ? 'b' : 'f' )
1267       ) ;
1268   }
1269
1270 package Mirmon::Mirror ; ###########################################
1271
1272 BEGIN { use base 'Base' ; Base -> import () ; }
1273
1274 use IO::Pipe ;
1275
1276 my @FIELDS =
1277   qw(url age last_status last_ok_probe probe_history state_history last_probe) ;
1278
1279 eval Base -> mk_methods ( @FIELDS, qw(mirmon region mail) ) ;
1280
1281 sub state_history_time
1282   { my $self = shift ;
1283     my $res = ( split /-/, $self -> state_history ) [ 0 ] ;
1284     $res ;
1285   }
1286
1287 sub state_history_hist
1288   { my $self = shift ;
1289     my $res = ( split /-/, $self -> state_history ) [ 1 ] ;
1290     $res ;
1291   }
1292
1293 sub _parse
1294   { my $self = shift ;
1295     my $url  = $self -> url ;
1296     my ( $type, $site, $home ) ;
1297     if ( $url =~ m!^(ftp|https?|rsync)://([^/:]+)(:\d+)?/! )
1298       { $type = $1 ; $site = $2 ; $home = $& ; }
1299     return $type, $site, $home ;
1300   }
1301
1302 sub type { my $self = shift ; ( $self -> _parse ) [ 0 ] ; }
1303 sub site { my $self = shift ; ( $self -> _parse ) [ 1 ] ; }
1304 sub home { my $self = shift ; ( $self -> _parse ) [ 2 ] ; }
1305
1306 sub age_in_days
1307   { my $self = shift ;
1308     my $res = 'undef' ;
1309     my $age = $self -> age ;
1310     if ( $age eq 'undef' )
1311       { $res = length $self -> state_history_hist
1312           if $self -> last_probe ne 'undef' ;
1313       }
1314     else
1315       { $res = ( $^T - $age ) / 24 / 60 / 60 ; }
1316     $res ;
1317   }
1318
1319 sub init
1320   { my $self   = shift ;
1321     my $mirmon = shift ;
1322     my $url    = shift ;
1323     my $res = bless { mirmon => $mirmon }, $self ;
1324     @{ $res } { @FIELDS } = ( 'undef' ) x scalar @FIELDS ;
1325     $res -> url ( $url ) ;
1326     $res -> probe_history ( '' ) ;
1327     $res -> state_history ( "$^T-z" ) ;
1328     $res -> mail ( '' ) ;
1329     $res ;
1330   }
1331
1332 sub new
1333   { my $self   = shift ;
1334     my $mirmon = shift ;
1335     my $line   = shift ;
1336     my $res = bless { mirmon => $mirmon }, $self ;
1337     @{ $res } { @FIELDS } = split ' ', $line ;
1338     $res -> mail ( '' ) ;
1339     $res ;
1340   }
1341
1342 sub update
1343   { my $self = shift ;
1344     my $succ = shift ;
1345     my $stat = shift ;
1346     my $time = shift ;
1347     my $probe_hist = $self -> probe_history ;
1348     if ( $succ )
1349       { $self -> age ( $time ) ;
1350         $self -> last_ok_probe ( $^T ) ;
1351         $probe_hist .= 's' ;
1352       }
1353     else
1354       { $probe_hist .= 'f' ;
1355         $time = $self -> age ;
1356       }
1357
1358     my $h = $self -> state_history_hist ;
1359     my $t = $self -> state_history_time ;
1360
1361     if ( aprx_ge ( $^T - $t, $HIST_DELTA ) )
1362       { my $n = int ( ( $^T - $t ) / $HIST_DELTA ) ;
1363         $h .= 'x' x ( $n - 1 ) ;
1364         $t = ( $n == 1 ? $t + $HIST_DELTA : $^T ) ;
1365       }
1366     else
1367       { chop $h ; }
1368     $h .= $self -> mirmon -> conf -> age_code ( $time ) ;
1369     $h = substr $h, - $HIST ;
1370     $h =~ s/^x+// ;
1371
1372     $self -> last_status ( $stat ) ;
1373     $self -> probe_history ( substr $probe_hist, - $HIST ) ;
1374     $self -> last_probe ( $^T ) ;
1375     $self -> state_history ( "$t-$h" ) ;
1376   }
1377
1378 sub as_list { my $self = shift ; @{ $self } { @FIELDS } ; }
1379 sub state { my $self = shift ; join ' ', $self -> as_list ; }
1380
1381 sub start_probe
1382   { my $self = shift ;
1383     my $conf = $self -> mirmon -> conf ;
1384     my $probe = $conf -> probe ;
1385     my $timeout = $conf -> timeout ;
1386     $probe =~ s/%TIMEOUT%/$timeout/g ;
1387     my $url = $self -> url ;
1388     my $new = $conf -> site_url -> { $self -> site } ;
1389     if ( defined $new )
1390       { printf "*** site_url : site %s\n  -> url %s\n"
1391           , $self -> site, $new if Mirmon::verbose ;
1392         $url = $new ;
1393       }
1394     $probe =~ s/%URL%/$url/g ;
1395     my $pipe = new IO::Pipe ;
1396     my $handle = $pipe -> reader ( split ' ', $probe ) ;
1397     if ( $handle )
1398       { $pipe -> blocking ( 0 ) ; }
1399     else
1400       { die "start_probe : no pipe for $url" ; }
1401     printf "start %s\n", $url if Mirmon::verbose ;
1402     printf "  %s\n", $probe if Mirmon::debug ;
1403     $handle ;
1404   }
1405
1406 sub finish_probe
1407   { my $self   = shift ;
1408     my $handle = shift ;
1409     my $res ;
1410     my $succ = 0 ;
1411     my $stat ;
1412     my $time ;
1413
1414     $handle -> blocking ( 1 ) ;
1415     if ( $handle -> eof () )
1416       { printf "finish eof %s\n", $self -> url if Mirmon::verbose ; }
1417     else
1418       { $res = $handle -> getline () ; }
1419     $handle -> flush ;
1420     $handle -> close ;
1421
1422     unless ( defined $res )
1423       { $stat = 'no_time' ; }
1424     elsif ( $res =~ /^\s*$/ )
1425       { $stat = 'empty' ; }
1426     else
1427       { $res = ( split ' ', $res ) [ 0 ] ;
1428
1429         if ( $res !~ /^\d+$/ )
1430           { $res =~ s/ /_/g ;
1431             $res = Base::htmlquote $res ;
1432             $res = substr ( $time, 0, 15 ) . '..' if length $res > 15 ;
1433             $stat = "'$res'" ;
1434           }
1435         else
1436           { $succ = 1 ; $stat = 'ok' ; $time = $res ; }
1437       }
1438
1439     printf "finish %s\n  succ(%s) stat(%s) time(%s)\n"
1440       , $self -> url
1441       , $succ
1442       , $stat
1443       , ( defined $time ? $time : 'undef' )
1444         if Mirmon::verbose ;
1445
1446     $self -> update ( $succ, $stat, $time ) ;
1447   }
1448
1449 sub revdom { my $dom = shift ; join '.', reverse split /\./, $dom ; }
1450
1451 sub cmp
1452   { my $a = shift ;
1453     my $b = shift ;
1454     ( revdom $a -> site ) cmp ( revdom $b -> site )
1455     or
1456     ( $a -> type cmp $b -> type )
1457     ;
1458   }
1459
1460 sub _url
1461   { my $hrf = shift ;
1462     my $txt = shift ;
1463     $hrf =~ /^rsync/ ? $txt : URL $hrf, $txt ;
1464   }
1465
1466 sub site_url { my $self = shift ; _url $self -> url , $self -> site ; }
1467 sub home_url { my $self = shift ; _url $self -> home, '@' ; }
1468
1469 =pod
1470
1471 =head1 NAME
1472
1473 Mirmon - OO interface for mirmon objects
1474
1475 =head1 SYNOPSIS
1476
1477   use Mirmon ;
1478
1479   $m = Mirmon -> new ( [ $path-to-config ] )
1480
1481   $conf  = $m -> conf  ; # a Mirmon::Conf object
1482   $state = $m -> state ; # the mirmon state
1483
1484   for my $url ( keys %$state )
1485     { $mirror = $state -> { $url } ; # a Mirmon::Mirror object
1486       $mail = $mirror -> mail ;      # contact address
1487       $mirror -> age ( time ) ;      # set mirror age
1488     }
1489
1490 Many class and object methods can be used to get or set attributes :
1491
1492   $object -> attribute           # get an atttibute
1493   $object -> attribute ( $attr ) # set an atttibute
1494
1495 =head1 Mirmon class methods
1496
1497 =over 4
1498
1499 =item B<new ( [$path] )>
1500
1501 Create a Mirmon object from a config file found in $path,
1502 or (by default) in the default list of possible config files.
1503 Related objects (config, state) are created and initialised.
1504
1505 =item verbosity
1506
1507 Mirmon always reports errors. Normally it only reports
1508 changes (inserts/deletes) found in the mirror_list ;
1509 in I<quiet> mode, it doesn't. In I<verbose> mode, it
1510 reports progress: the startup and finishing of probes.
1511
1512   Mirmon::verbose ( [ $bool ] ) # get/set verbose
1513   Mirmon::quiet   ( [ $bool ] ) # get/set quiet
1514   Mirmon::debug   ( [ $bool ] ) # get/set debug
1515
1516 =back
1517
1518 =head1 Mirmon object methods
1519
1520 =over 4
1521
1522 =item B<conf>
1523
1524 Returns Mirmon's Mirmon::Conf object.
1525
1526 =item B<state>
1527
1528 Returns a hashref C<< { url => mirror, ... } >>,
1529 where I<url> is as specified in the mirror list
1530 and I<mirror> is a Mirmon::Mirror object.
1531
1532 =item B<regions>
1533
1534 Returns a hashref C<< { country_code =E<gt> country_name, ... } >>.
1535
1536 =item B<config_list>
1537
1538 Returns the list of default locations for config files.
1539
1540 =item B<get_dates ( $get )>
1541
1542 Probes all mirrors if $get is C<all> ; or a subset if $get is C<update>.
1543
1544 =back
1545
1546 =head1 Mirmon::Conf object methods
1547
1548 A Mirmon::Conf object represents a mirmon conguration.
1549 It is normaly created by Mirmon::new().
1550 A specified (or default) config file is read and interpreted.
1551
1552 =over 4
1553
1554 =item attribute methods
1555
1556 For every config file entry, there is an attribute method :
1557 B<web_page>, B<state>, B<countries>, B<mirror_list>, B<probe>,
1558 B<project_name>, B<project_url>, B<icons>, B<project_logo>,
1559 B<timeout>, B<max_probes>, B<min_poll>, B<max_poll>, B<min_sync>,
1560 B<max_sync>, B<list_style>, B<put_histo>, B<randomize>, B<add_slash>.
1561
1562 =item B<root>
1563
1564 Returns the file name of (the root of) the configuration file(s).
1565
1566 =item B<site_url>
1567
1568 Returns a hashref C<< { site => url, ... } >>,
1569 as specified in the mirmon config file.
1570
1571 =back
1572
1573 =head1 Mirmon::Mirror object methods
1574
1575 A Mirmon::Mirror object represents the last known state of a mirror.
1576 It is normaly created by Mirmon::new() from the state file,
1577 as specified in the mirmon config file.
1578 Mirmon::Mirror objects can be used to probe mirrors.
1579
1580 =head2 attribute methods
1581
1582 =over 4
1583
1584 =item B<url>
1585
1586 The url as given in the mirror list.
1587
1588 =item B<age>
1589
1590 The mirror's timestamp found by the last succesful probe,
1591 or 'undef' if no probe was ever successful.
1592
1593 =item B<last_status>
1594
1595 The status of the last probe, or 'undef' if the mirror was never probed.
1596
1597 =item B<last_ok_probe>
1598
1599 The timestamp of the last succesful probe or 'undef'
1600 if the mirror was never successfully probed.
1601
1602 =item B<probe_history>
1603
1604 The probe history is a list of 's' (for success) and 'f' (for failure)
1605 characters indicating the result of the probe. New results are appended
1606 whenever the mirror is probed.
1607
1608 =item B<state_history>
1609
1610 The state history consists of a timestamp, a '-' char, and a list of
1611 chars indicating a past status: 's' (fresh), 'b' (oldish), 'f' (old),
1612 'z' (bad) or 'x' (skip).
1613 The timestamp indicates when the state history was last updated.
1614 The current status of the mirror is determined by the mirror's age and
1615 a few configuration parameters (min_sync, max_sync, max_poll).
1616 The state history is updated when the mirror is probed.
1617 If the last update of the history was less than 24 hours ago,
1618 the last status is replaced by the current status.
1619 If the last update of the history was more than 24 hours ago,
1620 the current status is appended to the history.
1621 One or more 'skip's are inserted, if the timestamp is two or more days old
1622 (when mirmon hasn't run for more than two days).
1623
1624 =item B<last_probe>
1625
1626 The timestamp of the last probe, or 'undef' if the mirror was never probed.
1627
1628 =back
1629
1630 =head2 object methods
1631
1632 =over 4
1633
1634 =item B<mirmon>
1635
1636 Returns the parent Mirmon object.
1637
1638 =item B<state_history_time>
1639
1640 Returns the I<time> part of the state_history attribute.
1641
1642 =item B<state_history_hist>
1643
1644 Returns the I<history> part of the state_history attribute.
1645
1646 =item B<type>, B<site>, B<home>
1647
1648 For an url like I<ftp://www.some.org/path/to/home>,
1649 the B<type> is I<ftp>,
1650 the B<site> is I<www.some.org>,
1651 and B<home> is I<ftp://www.some.org/>.
1652
1653 =item B<age_in_days>
1654
1655 Returns the mirror's age (in fractional days), based on the mirror's
1656 timestamp as found by the last successful probe ; or based on the
1657 length of the state history if no probe was ever successful.
1658 Returns 'undef' if the mirror was never probed.
1659
1660 =item B<mail>
1661
1662 Returns the mirror's contact address as specified in the mirror list.
1663
1664 =item B<region>
1665
1666 Returns the mirror's country code as specified in the mirror list.
1667
1668 =item B<start_probe>
1669
1670 Start a probe for the mirror in non-blocking mode ;
1671 returns the associated (IO::Handle) file handle.
1672 The caller must maintain an association between
1673 the handles and the mirror objects.
1674
1675 =item B<finish_probe ( $handle )>
1676
1677 Sets the (IO::Handle) B<$handle> to blocking IO ;
1678 reads a result from the handle,
1679 and updates the state of the mirror.
1680
1681 =back
1682
1683 =head1 SEE ALSO
1684
1685 =begin html
1686
1687 <A HREF="mirmon.html">mirmon(1)</A>
1688
1689 =end html
1690
1691 =begin man
1692
1693 mirmon(1)
1694
1695 =end man
1696
1697 =head1 AUTHOR
1698
1699 =begin html
1700
1701   &copy; 2003-2010
1702   <A HREF="http://people.cs.uu.nl/henkp/">Henk P. Penning</A>,
1703   <A HREF="http://www.cs.uu.nl/">Computer Science Department</A>,
1704   <A HREF="http://www.uu.nl/">Utrecht University</A>
1705   <BR>
1706   mirmon-2.3 - Wed Mar 17 09:29:11 2010 ; henkp
1707
1708 =end html
1709
1710 =begin man
1711
1712   (c) 2003-2010 Henk P. Penning
1713   Computer Science Department, Utrecht University
1714   http://people.cs.uu.nl/henkp/ -- penning@cs.uu.nl
1715   mirmon-2.3 - Wed Mar 17 09:29:11 2010 ; henkp
1716
1717 =end man
1718
1719 =begin text
1720
1721   (c) 2003-2010 Henk P. Penning
1722   Computer Science Department, Utrecht University
1723   http://people.cs.uu.nl/henkp/ -- penning@cs.uu.nl
1724   mirmon-2.3 - Wed Mar 17 09:29:11 2010 ; henkp
1725
1726 =end text
1727
1728 =cut
1729
1730 package main ; #####################################################
1731
1732 use IO::Pipe ;
1733 use IO::Select ;
1734 use Net::hostent ;
1735
1736 my $VERSION = Base::Version . ' - Wed Mar 17 09:29:11 2010 - henkp' ;
1737 my $DEF_CNF = join ', ', Mirmon -> config_list ;
1738 my $TIMEOUT = Base::DEF_TIMEOUT ;
1739
1740 my $prog = substr $0, rindex ( $0, '/' ) + 1 ;
1741 my $Usage = <<USAGE ;
1742 Usage: $prog [ -v ] [ -q ] [ -t timeout ] [ -get opt ] [ -c conf ]
1743 option v   : be verbose
1744 option q   : be quiet
1745 option t   : set timeout ; default $TIMEOUT
1746 option get : 'all'    : probe all sites
1747            : 'update' : probe a selection of the sites (see doc)
1748 option c   : configuration file ; default search :
1749              ( $DEF_CNF )
1750 -------------------------------------------------------------------
1751 Mirmon normally only reports errors and changes in the mirror list.
1752 This is $VERSION.
1753 -------------------------------------------------------------------
1754 USAGE
1755 sub Usage { die "$_[0]$Usage" ; }
1756 sub Error { die "$prog: $_[0]\n" ; }
1757 sub Warn  { warn "$prog: $_[0]\n" ; }
1758
1759 # usage: &GetOptions(ARG,ARG,..) defines $opt_ID as 1 or user spec'ed value
1760 # usage: &GetOptions(\%opt,ARG,ARG,..) defines $opt{ID} as 1 or user value
1761 # ARG = 'ID' | 'ID=SPC' | 'ID:SPC' for no-arg, required-arg or optional-arg
1762 # ID  = perl identifier
1763 # SPC = i|f|s for integer, fixedpoint real or string argument
1764
1765 use Getopt::Long ;
1766 Getopt::Long::config ( 'no_ignore_case' ) ;
1767 my %opt = () ;
1768 Usage '' unless GetOptions ( \%opt, qw(v q t=i get=s c=s version) ) ;
1769 Usage "Arg count\n" unless @ARGV == 0 ;
1770
1771 if ( $opt{version} ) { printf "%s\n", Base::version () ; exit ; }
1772
1773 $opt{v} ||= $opt{d} ;
1774
1775 my $get = $opt{get} ;
1776 if ( $get and ! Base::is_get_opt ( $get ) )
1777   { Error "unknown 'get option' '$get'" ; }
1778
1779 Mirmon::verbose ( $opt{v} ) ;
1780 Mirmon::debug   ( $opt{d} ) ;
1781 Mirmon::quiet   ( $opt{q} ) ;
1782
1783 my $M = Mirmon -> new ( $opt{c} ) ;
1784 $M -> conf -> timeout ( $opt{t} ) if $opt{t} ;
1785 if ( $get ) { $M -> get_dates ( $get ) ; $M -> put_state ; }
1786 $M -> gen_page ( $get, $VERSION ) ;
1787
1788 __END__
1789
1790 =pod
1791
1792 =head1 NAME
1793
1794 mirmon - monitor the state of mirrors
1795
1796 =head1 SYNOPSIS
1797
1798   mirmon [ -v ] [ -q ] [ -t timeout ] [ -get opt ] [ -c conf ]
1799
1800 =head1 OPTIONS
1801
1802   option v   : be verbose
1803   option q   : be quiet
1804   option t   : set timeout [ default 300 ] ;
1805   option get : 'all'    : probe all sites
1806              : 'update' : probe a selection of the sites (see doc)
1807   option c   : configuration file ; default list :
1808                ./mirmon.conf $HOME/.mirmon.conf /etc/mirmon.conf
1809   -------------------------------------------------------------------
1810   Mirmon normally only reports errors and changes in the mirror list.
1811   -------------------------------------------------------------------
1812
1813 =head1 USAGE
1814
1815 The program is intended to be run by cron every hour.
1816
1817   42 * * * * perl /path/to/mirmon -get update
1818
1819 It quietly probes a subset of the sites in a given list,
1820 writes the results in the 'state' file and generates a web page
1821 with the results. The subset contains the sites that are new, bad
1822 and/or not probed for a specified time.
1823
1824 When no 'get' option is specified, the program just generates a
1825 new web page from the last known state.
1826
1827 The program checks the mirrors by running a (user specified)
1828 program on a pipe. A (user specified) number of probes is
1829 run in parallel using nonblocking IO. When something can be
1830 read from the pipe, it switches the pipe to blocking IO and
1831 reads one line from the pipe. Then it flushes and closes the
1832 pipe. No attempt is made to kill the probe.
1833
1834 The probe should return something that looks like
1835
1836   1043625600 ...
1837
1838 that is, a line of text starting with a timestamp. The exit status
1839 of the probe is ignored.
1840
1841 =head1 CONFIG FILE
1842
1843 =head2 location
1844
1845 A config file can be specified with the -c option.
1846 If -c is not used, the program looks for a config file in
1847
1848 =over
1849
1850 =item * B<./mirmon.conf>
1851
1852 =item * B<$HOME/.mirmon.conf>
1853
1854 =item * B</etc/mirmon.conf>
1855
1856 =back
1857
1858 =head2 syntax
1859
1860 A config file looks like this :
1861
1862   +--------------------------------------------------
1863   |# lines that start with '#' are comment
1864   |# blank lines are ignored too
1865   |# tabs are replaced by a space
1866   |
1867   |# the config entries are 'key' and 'value' pairs
1868   |# a 'key' begins in column 1
1869   |# the 'value' is the rest of the line
1870   |somekey  A_val B_val ...
1871   |otherkey X_val Y_val ...
1872   |
1873   |# indented lines are glued
1874   |# the next three lines mean 'somekey part1 part2 part3'
1875   |somekey part1
1876   |  part2
1877   |  part3
1878   |
1879   |# lines starting with a '+' are concatenated
1880   |# the next three lines mean 'somekey part1part2part3'
1881   |somekey part1
1882   |+ part2
1883   |+ part3
1884   |
1885   |# lines starting with a '.' are glued too
1886   |# don't use a '.' on a line by itself
1887   |# 'somekey' gets the value "part1\n part2\n part3"
1888   |somekey part1
1889   |. part2
1890   |. part3
1891   +--------------------------------------------------
1892
1893 =head1 CONFIG FILE : required entries
1894
1895 =head2 project_name I<name>
1896
1897 Specify a short plaintext name for the project.
1898
1899   project_name Apache
1900   project_name CTAN
1901
1902 =head2 project_url I<url>
1903
1904 Specify an url pointing to the 'home' of the project.
1905
1906   project_url http://www.apache.org/
1907
1908 =head2 mirror_list I<file-name>
1909
1910 Specify the file containing the mirrors to probe.
1911
1912   mirror_list /path/to/mirror-list
1913
1914 If your mirror list is generated by a program, use
1915
1916   mirror_list /path/to/program arg1 ... |
1917
1918 Two formats are supported :
1919
1920 =over
1921
1922 =item * plain : lines like
1923
1924   us http://www.tux.org/ [email] ...
1925   nl http://apache.cs.uu.nl/dist/ [email] ...
1926   nl rsync://archive.cs.uu.nl/apache-dist/ [email] ...
1927
1928 =item * apache : lines like those in the apache mirrors.list
1929
1930   ftp  us ftp://ftp.tux.org/pub/net/apache/dist/ user@tux.org ...
1931   http nl http://apache.cs.uu.nl/dist/ user@cs.uu.nl ...
1932
1933 =back
1934
1935 Note that in style 'plain' the third item is reserved for an
1936 optional email address : the site's contact address.
1937
1938 Specify the required format with 'list_style' (see below).
1939 The default style is 'plain'.
1940
1941 =head2 web_page I<file-name>
1942
1943 Specify where the html report page is written.
1944
1945 =head2 icons I<directory-name>
1946
1947 Specify the directory where the icons can be found,
1948 relative to the I<web_page>, or relative to the
1949 DOCUMENTROOT of the web server.
1950
1951 If/when the I<web_page> lives in directory C<.../mirmon/> and
1952 the icons live in directory C<.../mirmon/icons/>,
1953 specify
1954
1955   icons icons
1956
1957 If/when the icons live in C</path/to/DOCUMENTROOT/icons/mirmon/>, specify
1958
1959   icons /icons/mirmon
1960
1961 =head2 probe I<program + arguments>
1962
1963 Specify the program+args to probe the mirrors. Example:
1964
1965   probe /usr/bin/wget -q -O - -T %TIMEOUT% -t 1 %URL%TIME
1966
1967 Before the program is started, %TIMEOUT% and %URL% are
1968 substituted with the proper timeout and url values.
1969
1970 Here it is assumed that each hour the root server writes
1971 a timestamp in /path/to/archive/TIME, for instance with
1972 a crontab entry like
1973
1974   42 * * * * perl -e 'printf "%s\n", time' > /path/to/archive/TIME
1975
1976 Mirmon reads one line of output from the probe and interprets
1977 the first word on that line as a timestamp ; for example :
1978
1979   1043625600
1980   1043625600 Mon Jan 27 00:00:00 2003
1981   1043625600 www.apache.org Mon Jan 27 00:00:00 2003
1982
1983 Mirmon is distributed with a program C<probe> that handles
1984 ftp, http and rsync urls.
1985
1986 =head2 state I<file-name>
1987
1988 Specify where the file containing the state is written.
1989
1990 The program reads this file on startup and writes the
1991 file when mirrors are probed (-get is specified).
1992
1993 =head2 countries I<file-name>
1994
1995 Specify the file containing the country codes;
1996 The file should contain lines like
1997
1998   us - united states
1999   nl - netherlands
2000
2001 The mirmon package contains a recent ISO list.
2002
2003 =head1 CONFIG FILE : optional entries
2004
2005 =head2 max_probes I<number>
2006
2007 Optionally specify the number of parallel probes (default 25).
2008
2009 =head2 timeout I<seconds>
2010
2011 Optionally specify the timeout for the probes (default 300).
2012
2013 After the last probe is started, the program waits for
2014 <timeout> + 10 seconds, cleans up and exits.
2015
2016 =head2 project_logo I<logo>
2017
2018 Optionally specify (the SRC of the IMG of) a logo to be placed
2019 top right on the page.
2020
2021   project_logo /icons/apache.gif
2022   project_logo http://www.apache.org/icons/...
2023
2024 =head2 htm_head I<html>
2025
2026 Optionally specify some HTML to be placed before </HEAD>.
2027
2028   htm_head
2029     <link REL=StyleSheet HREF="/style.css" TYPE="text/css">
2030
2031 =head2 htm_top I<html>
2032
2033 Optionally specify some HTML to be placed near the top of the page.
2034
2035   htm_top testing 1, 2, 3
2036
2037 =head2 htm_foot I<html>
2038
2039 Optionally specify HTML to be placed near the bottom of the page.
2040
2041   htm_foot
2042     <HR>
2043     <A HREF="..."><IMG SRC="..." BORDER=0></A>
2044     <HR>
2045
2046 =head2 put_histo top|bottom|nowhere
2047
2048 Optionally specify where the age histogram must be placed.
2049 The default is 'top'.
2050
2051 =head2 min_poll I<time-spec>
2052
2053 For 'min_poll' see next item. A I<time-spec> is a number followed by
2054 a unit 's' (seconds), or 'm' (minutes), or 'h' (hours), or 'd' (days).
2055 For example '3d' (three days) or '36h' (36 hours).
2056
2057 =head2 max_poll I<time-spec>
2058
2059 Optionally specify the maximum probe interval. When the program is
2060 called with option '-get update', all sites are probed which are :
2061
2062 =over 4
2063
2064 =item * new
2065
2066 the site appears in the list, but there is no known state
2067
2068 =item * bad
2069
2070 the last probe of the site was unsuccessful
2071
2072 =item * old
2073
2074 the last probe was more than 'max_poll' ago.
2075
2076 =back
2077
2078 Sites are not probed if the last probe was less than 'min_poll' ago.
2079 So, if you specify
2080
2081   min_poll 4h
2082   max_poll 12h
2083
2084 the 'reachable' sites are probed twice daily and the 'unreachable'
2085 sites are probed at most six times a day.
2086
2087 The default 'min_poll' is '1h' (1 hour).
2088 The default 'max_poll' is '4h' (4 hours).
2089
2090 =head2 min_sync I<time-spec>
2091
2092 Optionally specify how often the mirrors are required to make an update.
2093
2094 The default 'min_sync' is '1d' (1 day).
2095
2096 =head2 max_sync I<time-spec>
2097
2098 Optionally specify the maximum allowable sync interval.
2099
2100 Sites exceeding the limit will be considered 'old'.
2101 The default 'max_sync' is '2d' (2 days).
2102
2103 =head2 no_randomize
2104
2105 To balance the probe load over the hourly mirmon runs,
2106 mirmon may probe a few extra randomly choosen mirrors :
2107
2108 =over 4
2109
2110 =item * only if the the number of mirrors to probe is below average,
2111
2112 =item * at most 2% of the mirrors
2113
2114 =back
2115
2116 If you don't want this behaviour, use B<no_randomize>.
2117
2118 =head2 no_add_slash
2119
2120 If the url part of a line in the mirror_list doesn't end
2121 in a slash ('/'), mirmon adds a slash and issues a warning
2122 unless it is in quiet mode.
2123
2124 If you don't want this behaviour, use B<no_add_slash>.
2125
2126 =head2 list_style plain|apache
2127
2128 Optionally specify the format ('plain' or 'apache') of the mirror-list.
2129
2130 See the description of 'mirror_list' above.
2131 The default list_style is 'plain'.
2132
2133 =head2 site_url I<site> I<url>
2134
2135 Optionally specify a substitute url for a site.
2136
2137 When access to a site is restricted (in Australia, for instance),
2138 another (sometimes secret) url can be used to probe the site.
2139 The <site> of an url is the part between '://' and the first '/'.
2140
2141 =head2 env I<key> I<value>
2142
2143 Optionally specify an environment variable.
2144
2145 =head2 include I<file-name>
2146
2147 Optionally specify a file to include.
2148
2149 The specified file is processed 'in situ'. After the specified file is
2150 read and processed, config processing is resumed in the file where the
2151 C<include> was encountered.
2152 The include depth is unlimited. However, it is a fatal error to
2153 include a file twice under the same name.
2154
2155 =head2 show
2156
2157 When the config processor encounters the 'show' command, it
2158 dumps the content of the current config to standout, if option
2159 C<-v> is specified. This is intented for debugging.
2160
2161 =head2 exit
2162
2163 When the config processor encounters the 'exit' command, it
2164 terminates the program. This is intented for debugging.
2165
2166 =head1 STATE FILE FORMAT
2167
2168 The state file consists of lines; one line per site.
2169 Each line consists of white space separated fields.
2170 The seven fields are :
2171
2172 =over 4
2173
2174 =item * field 1 : url
2175
2176 The url as given in the mirror list.
2177
2178 =item * field 2 : age
2179
2180 The mirror's timestamp found by the last succesful probe,
2181 or 'undef' if no probe was ever successful.
2182
2183 =item * field 3 : status last probe
2184
2185 The status of the last probe, or 'undef' if the mirror was never probed.
2186
2187 =item * field 4 : time last succesful probe
2188
2189 The timestamp of the last succesful probe or 'undef'
2190 if the mirror was never successfully probed.
2191
2192 =item * field 5 : probe history
2193
2194 The probe history is a list of 's' (for success) and 'f' (for failure)
2195 characters indicating the result of the probe. New results are appended
2196 whenever the mirror is probed.
2197
2198 =item * field 6 : state history
2199
2200 The state history consists of a timestamp, a '-' char, and a list of
2201 chars indicating a past status: 's' (fresh), 'b' (oldish), 'f' (old),
2202 'z' (bad) or 'x' (skip).
2203 The timestamp indicates when the state history was last updated.
2204 The current status of the mirror is determined by the mirror's age and
2205 a few configuration parameters (min_sync, max_sync, max_poll).
2206 The state history is updated when the mirror is probed.
2207 If the last update of the history was less than 24 hours ago,
2208 the last status is replaced by the current status.
2209 If the last update of the history was more than 24 hours ago,
2210 the current status is appended to the history.
2211 One or more 'skip's is inserted, if the timestamp is two or more days old
2212 (when mirmon hasn't run for more than two days).
2213
2214 =item * field 7 : last probe
2215
2216 The timestamp of the last probe, or 'undef' if the mirror was never probed.
2217
2218 =back
2219
2220 =head1 INSTALLATION
2221
2222 =head2 general
2223
2224 =over 4
2225
2226 =item * Note: The (empty) state file must exist before mirmon runs.
2227
2228 =item * The mirmon repository is here :
2229
2230   https://subversion.cs.uu.nl/repos/staff.henkp.mirmon/trunk/
2231
2232 =item * The mirmon tarball is here :
2233
2234   http://people.cs.uu.nl/henkp/mirmon/mirmon.tar.gz
2235
2236 =back
2237
2238 =head2 installation suggestions
2239
2240 To install and configure mirmon, take the following steps :
2241
2242 =over 2
2243
2244 =item * First, make the webdir :
2245
2246   cd DOCUMENTROOT
2247   mkdir mirmon
2248
2249 For I<DOCUMENTROOT>, substitute the full pathname
2250 of the document root of your webserver.
2251
2252 =item * Check out the mirmon repository :
2253
2254   cd /usr/local/src
2255   svn checkout REPO mirmon
2256
2257 where
2258
2259   REPO = https://subversion.cs.uu.nl/repos/staff.henkp.mirmon/trunk/
2260
2261 or download the package and unpack it.
2262
2263 =item * Chdir to directory mirmon :
2264
2265   cd mirmon
2266
2267 =item * Create the (empty) state file :
2268
2269   touch state.txt
2270
2271 =item * Install the icons in the webdir :
2272
2273   mkdir DOCUMENTROOT/mirmon/icons
2274   cp icons/* DOCUMENTROOT/mirmon/icons
2275
2276 =item * Create a mirror list C<mirror_list> ;
2277
2278 Use your favorite editor, or genererate the list from an
2279 existing database.
2280
2281   nl http://archive.cs.uu.nl/your-project/ contact@cs.uu.nl
2282   uk http://mirrors.this.org/your-project/ mirrors@this.org
2283   us http://mirrors.that.org/your-project/ mirrors@that.org
2284
2285 The email addresses are optional.
2286
2287 =item * Create a mirmon config file C<mirmon.conf> with your favorite editor.
2288
2289   # lines must start in the first column ; no leading white space
2290   project_name ....
2291   project_url  ....
2292   mirror_list mirror_list
2293   state state.txt
2294   countries countries.list
2295   web_page DOCUMENTROOT/mirmon/index.html
2296   icons /mirmon/icons
2297   probe /usr/bin/wget -q -O - -T %TIMEOUT% -t 1 %URL%TIME
2298
2299 This assumes the project's timestamp is in file C<TIME>.
2300
2301 =item * If you have rsync urls, change the probe line to :
2302
2303   probe perl /usr/local/src/mirmon/probe -t %TIMEOUT% %URL%TIME
2304
2305 =item * Run mirmon :
2306
2307   perl mirmon -v -get all
2308
2309 The mirmon report should now be in 'DOCUMENTROOT/mirmon/index.html'
2310
2311   http://www.your.project.org/mirmon/
2312
2313 =item * If/when, at a later date, you want to upgrade mirmon :
2314
2315   cd /usr/local/src/mirmon
2316   svn status -u
2317   svn up
2318
2319 =back
2320
2321 =head1 SEE ALSO
2322
2323 =begin html
2324
2325 <A HREF="mirmon.pm.html">mirmon.pm(3)</A>
2326
2327 =end html
2328
2329 =begin man
2330
2331 mirmon.pm(3)
2332
2333 =end man
2334
2335 =head1 AUTHOR
2336
2337 =begin html
2338
2339   &copy; 2003-2010
2340   <A HREF="http://people.cs.uu.nl/henkp/">Henk P. Penning</A>,
2341   <A HREF="http://www.cs.uu.nl/">Computer Science Department</A>,
2342   <A HREF="http://www.uu.nl/">Utrecht University</A>
2343   <BR>
2344   mirmon-2.3 - Wed Mar 17 09:29:11 2010 ; henkp
2345
2346 =end html
2347
2348 =begin man
2349
2350   (c) 2003-2010 Henk P. Penning
2351   Computer Science Department, Utrecht University
2352   http://people.cs.uu.nl/henkp/ -- penning@cs.uu.nl
2353   mirmon-2.3 - Wed Mar 17 09:29:11 2010 ; henkp
2354
2355 =end man
2356
2357 =begin text
2358
2359   (c) 2003-2010 Henk P. Penning
2360   Computer Science Department, Utrecht University
2361   http://people.cs.uu.nl/henkp/ -- penning@cs.uu.nl
2362   mirmon-2.3 - Wed Mar 17 09:29:11 2010 ; henkp
2363
2364 =end text
2365
2366 =cut