#! /usr/bin/perl -w

# Copyright (c) 2003-2014 Henk Penning, all rights reserved.
# penning@uu.nl, http://www.staff.science.uu.nl/~penni101/
# Version 1.1 was donated to the Apache Software Foundation 2003 Jan 28.
#
# Permission is hereby granted, free of charge, to any person obtaining a
# copy of this software and associated documentation files (the "Software"),
# to deal in the Software without restriction, including without limitation
# the rights to use, copy, modify, merge, publish, distribute, sublicense,
# and/or sell copies of the Software, and to permit persons to whom the
# Software is furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
# THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
# DEALINGS IN THE SOFTWARE.
#
# Thanks to Klaus Heinz <heinz@NetBSD.org> for sugestions ao htm_head ;
# Peter Pöml for MirrorBrain support ; Jeremy Olexa, Karl Berry, Roland
# Pelzer for suggestions regarding rsync support.

use strict ;

our $PRG = 'mirmon' ;
our $VER = "2.10" ;

our $DEF_TIMEOUT = 300 ;
our $HIST        = 14 ;
our $TIM_PAT     = '^(\d+)([smhd])$' ;
our %APA_TYPES   = () ; $APA_TYPES { $_ } ++ for qw(backup ftp http rsync) ;
our %GET_OPTS    = () ; $GET_OPTS  { $_ } ++ for qw(all update url) ;
our $HIST_DELTA  = 24 * 60 * 60 ;
our $APRX_DELTA  = 300 ;
our $HOME        = 'http://www.staff.science.uu.nl/~penni101/mirmon/' ;

package Base ; #####################################################

use base 'Exporter' ;

our ( @ISA, @EXPORT ) ;
BEGIN
  { @ISA = qw(Exporter) ;
    @EXPORT =
      qw(aprx_eq aprx_ge aprx_le aprx_gt aprx_lt
         URL NAM SMA BLD NSS TAB BQ TR TH TD TDr RED GRN H1 H2 H3
         s4tim pr_interval pr_diff
        ) ;
  }

sub Version { "$PRG version $VER" ; }
sub version { "$PRG-$VER" ; }
sub DEF_TIMEOUT { $DEF_TIMEOUT ; }
sub is_get_opt  { my $opt = shift ; exists $GET_OPTS { $opt } ; }

sub getset
  { my $self = shift ;
    my $attr = shift ;
    if ( @_ ) { $self -> { $attr } = shift ; }
    die "no attr '$attr'" unless exists $self -> { $attr } ;
    $self -> { $attr } ;
  }

sub mk_method
  { my $self = shift ;
    my $attr = shift ;
    sprintf 'sub %s { my $self = shift ; $self -> getset ( "%s",  @_ ) ; }'
      , $attr, $attr ;
  }

sub mk_methods
  { my $self = shift ;
    join "\n", map { Base -> mk_method ( $_ ) ; } @_ ;
  }

sub aprx_eq { my ( $t1, $t2 ) = @_ ; abs ( $t1 - $t2 ) < $APRX_DELTA ; }
sub aprx_ge { my ( $t1, $t2 ) = @_ ; $t1 > $t2 or      aprx_eq $t1, $t2 ; }
sub aprx_le { my ( $t1, $t2 ) = @_ ; $t1 < $t2 or      aprx_eq $t1, $t2 ; }
sub aprx_gt { my ( $t1, $t2 ) = @_ ; $t1 > $t2 and not aprx_eq $t1, $t2 ; }
sub aprx_lt { my ( $t1, $t2 ) = @_ ; $t1 < $t2 and not aprx_eq $t1, $t2 ; }

sub URL { sprintf '<A HREF="%s">%s</A>', $_[0], $_[1] ; }
sub NAM { sprintf '<A NAME="%s">%s</A>', $_[0], $_[1] ; }
sub SMA { sprintf "<FONT SIZE=\"-1\">%s</FONT>", $_[0] ; }
sub BLD { sprintf "<B>%s</B>", $_[0] ; }
sub NSS { sprintf SMA('%s&nbsp;site%s'), $_[0], ( $_[0] == 1 ? '' : 's' ) ; }
sub TAB { sprintf "<TABLE BORDER=2 CELLPADDING=3>%s</TABLE>", $_[0] ; }
sub BQ  { sprintf "<BLOCKQUOTE>\n%s\n</BLOCKQUOTE>\n", $_[0] ; }
sub TR  { sprintf "<TR>%s</TR>\n", $_[0] ; }
sub TH  { sprintf "<TH>%s</TH>\n", $_[0] ; }
sub TD  { sprintf "<TD>%s</TD>\n", $_[0] ; }
sub H1  { sprintf "<H1>%s</H1>\n", $_[0] ; }
sub H2  { sprintf "<H2>%s</H2>\n", $_[0] ; }
sub H3  { sprintf "<H3>%s</H3>\n", $_[0] ; }
sub TDr { sprintf "<TD ALIGN=\"RIGHT\">%s</TD>\n", $_[0] ; }
sub RED { sprintf "<FONT COLOR=\"RED\">%s</FONT>", $_[0] ; }
sub GRN { sprintf '<FONT COLOR="GREEN">%s</FONT>', $_[0] ; }

sub s4tim
  { my $tim = shift ;
    my %tab = ( 's' => 1, 'm' => 60, 'h' => 60 * 60, 'd' => 60 * 60 * 24 ) ;
    die "wrong time '$tim'" unless $tim =~ /$TIM_PAT/o ;
    my $m = $1 ; my $u = $2 ;
    return $m * $tab { $u } ;
  }

sub pr_interval
  { my $s = shift ;
    my ( $magn, $unit ) ;
    my $mins  = $s / 60          ; my $m = int ( $mins + 0.5 ) ;
    my $hours = $s / ( 60 * 60 ) ; my $h = int ( $hours + 0.5 ) ;

    if ( $s < 50 )
      { $magn = $s ; $unit = 'second' ; }
    elsif ( $m < 50 )
      { $magn = $m ; $unit = 'minute' ; }
    elsif ( $h < 36 )
      { $magn = $h ; $unit = 'hour' ; }
    else
      { $magn = sprintf "%.1f", $hours / 24 ; $unit = 'day' ; }

    $unit .= 's' unless $magn == 1 ;

    return "$magn $unit" ;
  }

sub pr_diff
  { my $time = shift ;
    my $max  = shift ;
    my $res ;

    if ( $time == $^T )
      { $res = BLD 'renewed' ; }
    else
      { $res = pr_interval $^T - $time ;
        $res = BLD RED $res if aprx_lt $time, $max ;
      }
    return $res ;
  }

sub exp_date
  { my @day = qw(Sun Mon Tue Wed Thu Fri Sat) ;
    my @mon = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec) ;
    my @gmt = gmtime time + 3600 ;
    sprintf "%s, %02d %s %4d %02d:%02d:%02d GMT"
      , $day [ $gmt [ 6 ] ]
      , $gmt [ 3 ]
      , $mon [ $gmt [ 4 ] ]
      , $gmt [ 5 ] + 1900
      , @gmt [ 2, 1, 0 ]
      ;
  }

sub htmlquote
  { my $x = shift ;
    $x =~ s/&/&amp;/g ;
    $x =~ s/</&lt;/g ;
    $x =~ s/>/&gt;/g ;
    return $x ;
  }

package Mirmon ; ###################################################

BEGIN { use base 'Base' ; Base -> import () ; }

use IO::Select ;
use Net::hostent ;

  { my %opt = ( v => 0 , d => 0 , q => 0 ) ;
    sub _opt
      { my ( $key, $val ) = @_ ;
        my $res ;
        unless ( exists $opt { $key } )
          { warn "unknown Mirmon option '$key'\n" ; }
        else
          { $res = $opt { $key } ;
            $opt { $key } = $val if defined $val ;
          }
        $res ;
      }
  }

sub verbose { _opt ( 'v', shift ) ; }
sub quiet   { _opt ( 'q', shift ) ; }
sub debug   { _opt ( 'd', shift ) ; }

eval Base -> mk_methods ( qw(conf state regions) ) ;

sub config_list
  { my $self = shift ;
    my $home = ( getpwuid $< ) [ 7 ] or die "can get homedir '$<' ($!)" ;
    ( 'mirmon.conf', "$home/.mirmon.conf", '/etc/mirmon.conf' ) ;
  }

sub new
  { my $self = shift ;
    my $path = shift ;
    my $res  = bless {}, $self ;
    $res -> get_config ( $path ) ;
    $res -> get_state ;
    $res -> get_regions ;
    $res ;
  }

sub find_config
  { my $self = shift ;
    my $arg = shift ;
    my @LIST = $arg ? ( $arg ) : Mirmon -> config_list ;
    for my $conf ( @LIST ) { return $conf if -r $conf and ! -d $conf ; }
    die sprintf "can't find a config file :\n  %s\n" , join "\n  ", @LIST ;
  }

sub get_config
  { my $self = shift ;
    my $path = shift ;
    my $file = $self -> find_config ( $path ) ; # or die
    $self -> conf ( Mirmon::Conf -> new ( $file ) ) ;
  }

sub get_state
  { my $self = shift ;
    my $conf = $self -> conf ;
    my $name = $conf -> project_name ;
    my $state = $conf -> state ;
    my $res = {} ;
    open STATE, $state or die "can't open $state ($!)" ;
    for my $line ( <STATE> )
      { chop $line ;
        my $mirror = Mirmon::Mirror -> new ( $self, $line ) ;
        $res -> { $mirror -> url } = $mirror ;
      }
    close STATE ;

    my $mlist = $conf -> mirror_list ;
    my $style = $conf -> list_style ;
    my %in_list = () ;
    my $changes = '' ;
    open MLIST, $mlist or die "can't open $mlist ($!)" ;
    for my $line ( <MLIST> )
      { chop $line ;
        next if $line =~ /^#/ ;
        next if $line =~ /^\s*$/ ;
        my ( $reg, $url, $mail ) ;
        if ( $style eq 'plain' )
          { ( $reg, $url, $mail ) = split ' ', $line ; }
        elsif ( $style eq 'apache' )
          { my $apache_type ;
            ( $apache_type, $reg, $url, $mail ) = split ' ', $line ;
            unless (  defined $APA_TYPES { $apache_type } )
              { print "*** strange type in $url ($apache_type)\n"
                  unless Mirmon::quiet ;
                next ;
              }
          }

        if ( $conf -> add_slash and $url !~ m!/$! )
          { print "*** appended '/' to $url\n" unless Mirmon::quiet ;
            $url .= '/' ;
          }

        $in_list { $url } ++ ;

        unless ( exists $res -> { $url } )
          { $changes .= sprintf "added %s\n", $url unless Mirmon::quiet ;
            $res -> { $url } = Mirmon::Mirror -> init ( $self, $url ) ;
          }
        my $mirror = $res -> { $url } ;
        $mirror -> region ( $reg ) ;
        $mirror -> mail ( $mail || '' ) ;
      }
    close MLIST ;

    for my $url ( sort keys %$res )
      { # printf "%s\n", $res -> { $url } -> state ;
        unless ( exists $in_list { $url } )
          { $changes .= sprintf "removed %s\n", $url unless Mirmon::quiet ;
            delete $res -> { $url } ;
          }
      }
    printf "changes in mirror-list for '%s':\n%s", $name, $changes
      if $changes ;
    $self -> state ( $res ) ;
  }

sub put_state
  { my $self  = shift ;
    my $state = $self -> state ;
    my $file  = $self -> conf -> state ;
    my $TMP = "$file.tmp" ;
    open TMP, ">$TMP" or die "can't write '$TMP' ($!)" ;
    for my $url ( sort keys %$state )
      { printf TMP "%s\n", $state -> { $url } -> state
          or die "can't print $url to $TMP ($!)" ;
      }
    close TMP ;

    if ( -z $TMP )
      { warn "wrote empty state file; keeping previous version" ; }
    else
      { rename $TMP, $file or die "can't rename '$TMP', '$file' ($!)" ; }
  }

sub get_regions
  { my $self = shift ;
    my $file =  $self -> conf -> countries ;
    open REGS, $file or die "can't open countries '$file' ($!)" ;
    while ( <REGS> )
      { chop ;
        next if /^#/ ;
        my ( $code, $dash, $reg ) = split ' ', $_, 3 ;
        $self -> { regions } { lc $code } = $reg ;
      }
    close REGS ;
  }

sub _cmp_ccs
  { my $ccs = shift ;
    my $x  = shift ;
    my $y  = shift ;
    my $xx = $ccs -> { $x } ;
    my $yy = $ccs -> { $y } ;
    if ( ! defined $xx and ! defined $yy )
      { $x cmp $y ; }
    elsif ( ! defined $xx )
      { -1 ; }
    elsif ( ! defined $yy )
      { +1 ; }
    else
      { $xx cmp $yy ; }
  }

sub _pr_round
  { my $x = shift ;
    my $i = int $x ;
    my $f = $x - $i ;
    $i + ( rand 1 < $f ? 1 : 0 ) ;
  }

sub _diag_qs
  { my $qs = shift ;
    join ', ', map { sprintf "%s %s" , $_, scalar @{ $qs -> { $_ } } ; }
      sort keys %$qs ;
  }

sub _rpick
  { my $row = shift ;
    die "_rpick : row empty" unless @$row ;
    my $idx = int rand @$row ;
    my $res = $row -> [ $idx ] ;
    $row -> [ $idx ] = $row -> [ $#{$row} ] ;
    pop @$row ;
    $res ;
  }

sub _buck_split
  { my $que = shift ;
    my $tmp = [] ;
    for my $mirr ( @$que )
      { my $lp = $mirr -> last_probe ;
        my $hr = int ( ( $^T - $lp ) / 60 / 60 + 0.5 ) ;
        push @{ $tmp -> [ $hr ] }, $mirr ;
      }
    [ grep defined $_, @$tmp ] ;
  }

sub _buck_join
  { my $bucks = shift ;
    my $res = [] ;
    push @$res, @$_ for @$bucks ;
    $res ;
  }

sub _buck_pick
  { my $bucks = shift ;
    die "buck_pick : bucks empty" unless @$bucks ;
    my $buck = ( sort { @$b <=> @$a } @$bucks ) [ 0 ] ;
    _rpick $buck ;
  }

sub _randomize
  { my $ques = shift ;
    my $poll = shift ;
    my $hrs  = int ( $poll / 60 / 60 + 0.5 ) ;

    my $diag1 = _diag_qs $ques ;

    my $todos = $ques -> { todo } ;
    my $dones = $ques -> { done } ;
    my $cnt   = @$todos + @$dones ;
    my $avg   = $hrs ? $cnt / $hrs : 0 ;
    my $iavg  = _pr_round $avg ;
    my $pick  = 0 ;
    my $bucks = _buck_split $dones ;

    while ( @$todos < $iavg and $pick < @$dones )
      { push @$todos, _buck_pick $bucks ;
        $pick ++ ;
      }

    $ques -> { done } = _buck_join $bucks ;

    sprintf ''
      . "  hrs %s, %s\n"
      . "  avg %.2f -> %d , picked %d ; queued %s\n"
      . "  hrs %s, %s\n"
      , $hrs, $diag1
      , $avg, $iavg, $pick, scalar @$todos
      , $hrs, _diag_qs ( $ques )
      ;
  }

sub get_dates
  { my $self  = shift ;
    my $get   = shift ;
    my $URL   = shift ;
    my $state = $self -> state ;
    my $conf  = $self -> conf ;
    my $CMD   = $conf -> probe ;
    my $PAR   = $conf -> max_probes ;
    my %m4h   = () ;
    my @QUE   = () ;
    my $GET   = IO::Select -> new () ;
    my $ques  = {} ;
    for my $col ( qw(new red grn xtr) )
      { $ques -> { $col } { $_ } = [] for qw(done todo) ; }
    my $max_poll = s4tim $conf -> max_poll ;
    my $min_poll = s4tim $conf -> min_poll ;

    if ( Mirmon::verbose ) { printf "mirrors %d\n", scalar keys %$state ; }

    if ( $get eq 'all' )
      { @QUE = sort { $a -> url cmp $b -> url } values %$state ; }
    elsif ( $get eq 'url' )
      { @QUE = ( $state -> { $URL } ) ; }
    elsif ( $get eq 'update' )
      { my $maxp = $^T - $max_poll ;
        my $minp = $^T - $min_poll ;

if ( Mirmon::verbose )
  { printf "max_poll %s\n", scalar localtime $maxp ;
    printf "min_poll %s\n", scalar localtime $minp ;
  }
        for my $url ( sort keys %$state )
          { my $mirror = $state -> { $url } ;
            my $stat = $mirror -> last_status ;
            my $vrfy = $mirror -> last_ok_probe ;
            my $lprb = $mirror -> last_probe ;
            my $col ;
            my $que ;
            if ( $stat eq 'undef' ) # never probed ; new mirror ; todo
              { $col = 'new' ; $que = 'todo' ; }
            elsif ( $conf -> get_xtr ( $mirror -> region ) )
              { $col = 'xtr' ; $que = 'todo' ; }
            else
              { my $poll = $stat eq 'ok' ? $maxp : $minp ;
                $col     = $stat eq 'ok' ? 'grn' : 'red' ;
                $que     = ( aprx_le $lprb, $poll ) ? 'todo' : 'done' ;
              }
            push @{ $ques -> { $col } { $que } }, $mirror ;
          }

        if ( $conf -> randomize )
          { my $msg = "randomize green\n" ;
            $msg .= _randomize $ques -> { grn }, $max_poll ;
            $msg .= "randomize red\n" ;
            $msg .= _randomize $ques -> { red }, $min_poll ;
            print $msg if Mirmon::verbose ;
          }
        @QUE =
          ( @{ $ques -> { new } { todo } }
          , @{ $ques -> { red } { todo } }
          , @{ $ques -> { grn } { todo } }
          , @{ $ques -> { xtr } { todo } }
          ) ;
      }
    else
      { die "unknown opt_get '$get'" ; }

    if ( Mirmon::verbose ) { printf "queued %d\n\n", scalar @QUE ; }

    while ( @QUE )
      { my $started = 0 ;
        while ( $GET -> count () < $PAR and @QUE )
          { my $mirror = shift @QUE ;
            if ( gethost $mirror -> site )
              { my $handle = $mirror -> start_probe ;
                $m4h { $handle } = $mirror ;
                $GET -> add ( $handle ) ;
                $started ++ ;
              }
            else
              { $mirror -> update ( 0, 'site_not_found', undef ) ; }
          }

        my @can_read = $GET -> can_read ( 0 ) ;

        printf "queue %d, started %d, probes %d, can_read %d\n",
          scalar @QUE, $started, $GET -> count (), scalar @can_read
            if Mirmon::verbose ;

        for my $handle ( @can_read )
          { # order is important ; wget's hang if/when actions are reversed
            $GET -> remove ( $handle ) ;
            $m4h { $handle } -> finish_probe ( $handle ) ;
          }

        sleep 1 ;
      }

    my $stop = time + $conf -> timeout + 10 ;

    while ( $GET -> count () and time < $stop )
      { my @can_read = $GET -> can_read ( 0 ) ;

        printf "wait %2d, probes %d, can_read %d\n",
          $stop - scalar time, $GET -> count (), scalar @can_read
            if Mirmon::verbose ;

        for my $handle ( @can_read )
          { $GET -> remove ( $handle ) ;
            $m4h { $handle } -> finish_probe ( $handle ) ;
          }

        sleep 10 ;
      }

    for my $handle ( $GET -> handles () )
      { $m4h { $handle } -> update ( 0, 'hangs', undef ) ; }
  }

sub img_sf_cnt
  { my $self = shift ;
    my $prf  = shift ;
    my $cnt  = shift ;
    my $res ;
    if ( $prf eq 'x' )
      { sprintf
          ( '<IMG BORDER=1 SRC="%s/bar.gif" ALT="">'
          , $self -> conf -> icons
          ) x $cnt ;
      }
    else
     { sprintf '<IMG BORDER=1 SRC="%s/mm%s%02d.gif" ALT="">'
         , $self -> conf -> icons, $prf, $cnt ;
     }
  }

sub img_sf { my $self = shift ; $self -> img_sf_cnt ( $_[0], 1 ) ; }

sub show_hist
  { my $self = shift ;
    my $hst = shift ;
    if ( $hst =~ /-(.*)$/ ) { $hst = $1 ; }
    return '' unless $hst =~ m/^[sbfzx]+$/ ;
    if ( length $hst == $HIST and $hst =~ /^(s*b)s*$/ )
      { return $self -> img_sf_cnt ( 'sb',  length $1 ) ; }
    elsif ( length $hst == $HIST and $hst =~ /^(s*f)s*$/ )
      { return $self -> img_sf_cnt ( 'sf',  length $1 ) ; }
    elsif ( length $hst == $HIST and $hst =~ /^(s*b)fs*$/ )
      { return $self -> img_sf_cnt ( 'sbf', length $1 ) ; }
    my $res = '' ;
    my $cnt = 1 ;
    my $prf = substr $hst, 0, 1 ;
    $hst = substr $hst, 1 ;
    while ( $hst ne '' )
      { if ( substr ( $prf, 0, 1 ) eq substr ( $hst, 0, 1 ) )
          { $cnt ++ ;
            $hst = substr $hst, 1 ;
          }
        else
          { $res .= $self -> img_sf_cnt ( $prf, $cnt ) ;
            $prf = substr $hst, 0, 1 ;
            $hst = substr $hst, 1 ;
            $cnt = 1 ;
          }
      }
    $res .= $self -> img_sf_cnt ( $prf, $cnt ) if $cnt ;
    $res ;
  }

sub gen_histogram_probes
  { my $self = shift ;
    my $state = $self -> state ;
    my %tab = () ;
    my %bad = () ;
    my $res = '' ;
    my $s_cnt = 0 ;
    my $f_cnt = 0 ;
    my $hr_min ;
    my $hr_max ;
    for my $url ( keys %$state )
      { my $mirror = $state -> { $url } ;
        my $lprb = $mirror -> last_probe ;
        my $stat = $mirror -> last_status ;
        next if $lprb eq 'undef' ;
        my $hr = int ( ( $^T - $lprb ) / 3600 + 0.5 ) ;
        $hr_min = $hr if ! defined $hr_min or $hr < $hr_min ;
        $hr_max = $hr if ! defined $hr_max or $hr > $hr_max ;
        if ( $stat eq 'ok' )
          { $tab { $hr } ++ ; $s_cnt ++ ; }
        else
          { $bad { $hr } ++ ; $f_cnt ++ ; }
      }
    return BQ 'nothing yet' unless scalar keys %tab ;

    $res = TR
      ( TH ( 'hours ago' )
      . TH ( 'succ' )
      . TH ( 'fail' )
      . TH sprintf
          ( '%s %s, %s %s'
          , $s_cnt , GRN ( 'successful' )
          , $f_cnt , RED ( 'failed' )
          )
      ) ;

    my $max = 0 ;
    for my $x ( keys %tab )
      { my $tot = $tab { $x } + ( $bad { $x } || 0 ) ;
        $max = $tot if $max < $tot ;
      }

    return BQ "nothing yet" unless $max ;

    for my $hr ( $hr_min .. $hr_max )
      { my $x = $tab { $hr } || 0 ;
        my $y = $bad { $hr } || 0 ;
        my $n = int ( $x / $max * $HIST ) ;
        my $b = int ( $y / $max * $HIST ) ;
        $res .= TR
          ( TDr ( $hr )
          . TDr ( $x )
          . TDr ( $y )
          . TD
              ( ( $n ? $self -> img_sf_cnt ( 's', $n ) : '' )
              . ( $b ? $self -> img_sf_cnt ( 'f', $b ) : '' )
              . ( ( $n + $b ) ? '' : '&nbsp;' )
              )
          ) ;
      }
    return BQ TAB $res ;
  }

sub age_avg
  { my $self = shift ;
    my $state = $self -> state ;
    my @tab = () ;
    for my $url ( keys %$state )
      { my $time = $state -> { $url } -> age ;
        push @tab, $^T - $time if $time =~ /^\d+$/ ;
      }
    my $cnt = @tab ;

    return undef if $cnt == 0 ;

    @tab = sort { $a <=> $b } @tab ;

    my $tot = 0 ;
    for my $age ( @tab ) { $tot += $age ; }
    my $mean = $tot / $cnt ;

    my $median ;
    if ( $cnt == 1 )
      { $median = $tab [ 0 ] ; }
    elsif ( $cnt % 2 )
      { my $mid = int ( $#tab / 2 ) ;
        $median = ( $tab [ $mid ] + $tab [ $mid + 1 ] ) / 2 ;
      }
    else
      { my $mid = int ( $#tab / 2 ) ;
        $median = $tab [ $mid ] ;
      }

    if ( @tab < 2 )
      { return $mean, $median, undef ; }

    my $sum = 0 ;
    for my $age ( @tab )
      { $sum += ( $age - $mean ) ** 2 ; }
    my $stddev = sqrt ( $sum / ( $cnt - 1 ) ) ;

    return $mean, $median, $stddev ;
  }

sub legend
  { my $self = shift ;
    my $conf = $self -> conf ;
    my $min_sync = $conf -> min_sync ;
    my $max_sync = $conf -> max_sync ;
    my $min_poll = $conf -> min_poll ;
    my $max_poll = $conf -> max_poll ;

    return <<LEGENDA ;
<H3>legend</H3>

<H4><I>project</I> site -- home</H4>

<BLOCKQUOTE>
<B><I>project</I> site</B> is an url.
The <B>href</B> is the href for the site in the list of mirrors,
usually the root of the mirrored file tree.
The <B>text</B> is the <I>site</I> of that url.
<P>
<B>home</B> (represented by the <B>@</B>-symbol) is an url
pointing to the document root of the site. This pointer is
useful if the <B><I>project</I> site</B> url is invalid,
possibly because the mirror site moved the archive.
</BLOCKQUOTE>

<H4>type</H4>

<BLOCKQUOTE>
Indicates the type (<B>ftp</B> or <B>http</B>) of
the <B><I>project</I> site</B> and <B>home</B> urls.
</BLOCKQUOTE>

<H4>mirror age, daily stats</H4>

<BLOCKQUOTE>
The <B>mirror age</B> is based upon the last successful probe.
<P>
Once a day the status of a mirror site is determined.
The status (represented by a colored block) is appended
to the <B>right</B> of the status history (<I>right</I>
is <I>recent</I>). More precise, the status block is appended
if the last status block was appended 24 (or more) hours ago.
<P>The status of a mirror depends on its age and a few
configuration parameters :
<BLOCKQUOTE>
<TABLE BORDER=1 CELLPADDING=5>
<TR>
  <TH ROWSPAN=3>status</TH>
  <TH COLSPAN=4>age</TH>
</TR>
<TR>
  <TH COLSPAN=2 BGCOLOR=YELLOW>this project</TH>
  <TH COLSPAN=2 BGCOLOR=AQUA>in general</TH>
</TR>
<TR>
  <TH BGCOLOR=YELLOW>min</TH>
  <TH BGCOLOR=YELLOW>max</TH>
  <TH BGCOLOR=AQUA>min</TH>
  <TH BGCOLOR=AQUA>max</TH>
</TR>
<TR>
  <TH><FONT COLOR=GREEN>fresh</FONT></TH>
  <TD BGCOLOR=YELLOW ALIGN=CENTER>0</TD>
  <TD BGCOLOR=YELLOW ALIGN=CENTER>$min_sync + $max_poll</TD>
  <TD BGCOLOR=AQUA   ALIGN=CENTER>0</TD>
  <TD BGCOLOR=AQUA   ALIGN=CENTER>min_sync + max_poll</TD>
</TR>
<TR>
  <TH><FONT COLOR=BLUE>oldish</FONT></TH>
  <TD BGCOLOR=YELLOW ALIGN=CENTER>$min_sync + $max_poll</TD>
  <TD BGCOLOR=YELLOW ALIGN=CENTER>$max_sync + $max_poll</TD>
  <TD BGCOLOR=AQUA   ALIGN=CENTER>min_sync + max_poll</TD>
  <TD BGCOLOR=AQUA   ALIGN=CENTER>max_sync + max_poll</TD>
</TR>
<TR>
  <TH><FONT COLOR="RED">old</FONT></TH>
  <TD BGCOLOR=YELLOW ALIGN=CENTER>$max_sync + $max_poll</TD>
  <TD BGCOLOR=YELLOW ALIGN=CENTER>&infin;</TD>
  <TD BGCOLOR=AQUA   ALIGN=CENTER>max_sync + max_poll</TD>
  <TD BGCOLOR=AQUA   ALIGN=CENTER>&infin;</TD>
</TR>
<TR>
  <TH><FONT COLOR=BLACK>bad</FONT></TH>
  <TH COLSPAN=4 BGCOLOR=BLACK>
    <FONT COLOR=WHITE>the site or mirror tree was never found</FONT></TH>
</TR>
</TABLE>
</BLOCKQUOTE>
</BLOCKQUOTE>

<H4>last probe, probe stats</H4>

<BLOCKQUOTE>
<B>Last probe</B> indicates when the last successful probe was made.
<B>Probe stats</B> gives the probe history (<I>right</I> is <I>recent</I>).
A probe is either a
<FONT COLOR=GREEN><B>success</B></FONT> or a
<FONT COLOR=RED><B>failure</B></FONT>.
</BLOCKQUOTE>

<H4>last stat</H4>

<BLOCKQUOTE>
<B>Last stat</B> gives the status of the last probe.
</BLOCKQUOTE>

LEGENDA
  }

sub _ths
  { return '' unless my $ths = shift ;
    $ths == 1 ? TH '' : "<TH COLSPAN=$ths></TH>\n" ;
  }

sub gen_histogram
  { my $self  = shift ;
    my $where = shift ;
    my $conf  = $self -> conf ;
    my $state = $self -> state ;

    return '' if $where ne $conf -> put_histo ;

    my $MAX_H = $conf -> max_age1 ;
    my $MAX_h = 1 +
      ( ( 20 * 3600 <= $MAX_H and $MAX_H <= 36 * 3600 )
      ? int ( $MAX_H / 3600 )
      : 25
      ) ;
    my $MAX_O = $conf -> max_age2 ;
    my $MAX_o = int ( $MAX_O / 3600 + 0.5 ) ;
    my $H = 18 ;
    my %W   = ( 'old' => 1, 'ded' => 1, 'bad' => 1 ) ;
    my %Wmx = ( 'old' => 5, 'ded' => 3, 'bad' => 3 ) ;
    my %tab ;
    my %hst ;
    my $res ;
    for ( my $x = 0 ; $x < $MAX_h ; $x ++ ) { $tab { $x } = 0 ; }
    $tab { old } = 0 ; $tab { ded } = 0 ; $tab { bad } = 0 ;
    for my $url ( keys %$state )
      { my $time = $state -> { $url } -> age ;
        if ( $time =~ /^\d+$/ )
          { my $s  = $^T - $time ;
            my $hr = int ( $s / $MAX_H * ( $MAX_h - 1 ) + 0.5 ) ;
            if    ( $s <= $MAX_H ) { $tab { $hr  } ++ ; }
            elsif ( $s <= $MAX_O ) { $tab { old } ++ ; }
            else                   { $tab { ded } ++ ; }
          }
        else
          { $tab { bad } ++ ; }
      }
    my $max = 0 ;
    for ( grep ! exists $Wmx { $_ }, keys %tab )
      { $max = $tab { $_ } if $tab { $_ } > $max ; }

    my %bad ;

    for my $aux ( keys %Wmx )
      { $bad { $aux } = $tab { $aux } ;
        if ( $bad { $aux } > $max )
          { $W { $aux } = $Wmx { $aux } ;
            my $d = int ( $bad { $aux } / $W { $aux } ) ;
            for ( my $i = 1 ; $i < $W { $aux } ; $i++ )
              { $tab { $aux . $i } = $d ;
                if ( $bad { $aux } % $Wmx { $aux } > $i )
                  { $tab { $aux . $i } ++ ;
                    $tab { $aux } -- ;
                  }
              }
            $tab { $aux } -= ( $W { $aux } - 1 ) * $d ;
            $max = $tab { $aux } if $max < $tab { $aux } ;
          }
      }

#   if ( $opt{v} )
#     { for my $hr ( keys %tab )
#         { printf "tab '%s' = '%s'\n", $hr, $tab { $hr } ; }
#     }

    return 'nothing yet' unless $max ;
    $H = $max if 8 <= $max and $max <= 26 ;
    for ( keys %tab )
      { $hst { $_ } = int ( $H * $tab { $_ } / $max + 0.5 ) ; }
    my @keys = sort { $a <=> $b } grep /^\d+$/, keys %hst ;
    my $tab_hr = 0 ;
    for my $hr ( @keys ) { $tab_hr += $tab { $hr } ; }
    push @keys
      , grep ( m/^old/, sort keys %tab )
      , grep ( m/^ded/, sort keys %tab )
      , grep ( m/^bad/, sort keys %tab )
      ;
    my $img_bar = sprintf '<IMG SRC="%s/bar.gif" ALT="" BORDER=0>'
      , $conf -> icons ;
    my %img = ( bar => $img_bar ) ;
    for my $col ( qw(s b f z) ) { $img { $col } = $self -> img_sf ( $col ) ; }

    for ( my $h = $H ; $h > 0 ; $h -- )
      { $res .= "<TR>\n" ;
        $res .= sprintf "<TH ROWSPAN=3 VALIGN=\"TOP\">&uarr;</TH>\n"
          if $h == $H ;
        $res .= sprintf '<TD ROWSPAN=%d ALIGN="CENTER">%s</TD>' . "\n"
          , $H-6, NSS ( $max ) if $h == $H - 3 ;
        $res .= sprintf "<TH ROWSPAN=3 VALIGN=\"BOTTOM\">&darr;</TH>\n"
          if $h == 3 ;
        my $ths = 0 ;
        for my $x ( @keys )
          { my $col =
              ( ( $hst { $x } >= $h )
              ? ( $x =~ /^\d+$/
                ? 's'
                : ( $x =~ /^old/ ? 'b' : ( $x =~ /^ded/ ? 'f' : 'z' ) )
                )
              : ( ( $h == 1 and $hst { $x } == 0 ) ? 'bar' : '' )
              ) ;
            if ( $col )
              { $res .= _ths $ths ; $ths = 0 ; $res .= TH $img { $col } ; }
            else
              { $ths ++ ; }
          }
        $res .= _ths ( $ths ) . "</TR>\n" ;
      }

    my $HR = '<HR SIZE=2 WIDTH="95%%" NOSHADE>' ;

    $res .= "<TR>\n" ;
    $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", 1 ;
    $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", $MAX_h ;
    $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", $W { old } ;
    $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", $W { ded } ;
    $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", $W { bad } ;
    $res .= "</TR>\n" ;

    $res .= "<TR>\n" ;
    $res .= '<TD ALIGN="CENTER">&nbsp;<B>age</B>&nbsp;&rarr;&nbsp;</TD>' ;

    $res .= "<TH>|</TH>\n" ;
    $res .= sprintf
      ( '<TD COLSPAN=%d ALIGN="CENTER">'
      . '&larr;&nbsp; 0 &le; <B>age</B> &le; %s &nbsp;&rarr;'
      . "</TD>\n"
      , $MAX_h - 2, pr_interval ( $MAX_H )
      )
      ;
    $res .= "<TH>|</TH>\n" ;
    $res .= sprintf
      ( '<TD ALIGN="CENTER" COLSPAN=%d>'
      . '&nbsp;%sh&nbsp;&lt;&nbsp;%s&nbsp;&le;&nbsp;%sh&nbsp;'
      . "</TD>\n"
      , $W { old }, int($MAX_H/60/60) , BLD ( 'age' ), $MAX_o
      ) ;
    $res .= sprintf
      ( '<TD ALIGN="CENTER" COLSPAN=%d>'
      . '&nbsp;<FONT COLOR="RED">old</FONT>&nbsp;'
      . "</TD>\n"
      , $W { ded }
      ) ;
    $res .= sprintf
      ( '<TD ALIGN="CENTER" COLSPAN=%d>'
      . '&nbsp;<FONT COLOR="RED">bad</FONT>&nbsp;'
      . "</TD>\n"
      , $W { bad }
      ) ;
    $res .= "</TR>\n" ;

    my $FRMT = '<TD ALIGN="CENTER" COLSPAN=%d>&nbsp;%s&nbsp;</TD>' ;

    $res .= "<TR>\n" ;
    $res .= sprintf "$FRMT\n", 1,  NSS scalar keys %$state ;
    $res .= "<TH>|</TH>\n" ;
    $res .= sprintf "$FRMT\n", $MAX_h - 2, NSS $tab_hr ;
    $res .= "<TH>|</TH>\n" ;
    $res .= sprintf "$FRMT\n", $W { old }, NSS $bad { old } ;
    $res .= sprintf "$FRMT\n", $W { ded }, NSS $bad { ded } ;
    $res .= sprintf "$FRMT\n", $W { bad }, NSS $bad { bad } ;
    $res .= "</TR>\n" ;

    $res = "<TABLE CELLSPACING=0 CELLPADDING=1 BORDER=0>\n$res\n</TABLE>\n" ;
    $res = sprintf "<TABLE CELLPADDING=5 BORDER=4>%s</TABLE>\n"
       , "<TR><TH>\n$res\n</TH></TR>" ;
    my $units = join ' '
      , $self -> img_sf ( 's' ) , $self -> img_sf ( 'b' )
      , $self -> img_sf ( 'f' ) , $self -> img_sf ( 'z' )
      ;
    if ( $max == $H )
      { $res .= sprintf "<BR>units %s represent one mirror site.\n"
          , $units ;
      }
    else
      { $res .= sprintf "<BR>each %s unit represents %s mirror sites.\n"
          , $units, sprintf ( "%.1f", $max / $H ) ;
      }
    return H2 ( NAM 'age-histogram', 'age histogram' )
      . BQ $res ;
  }

sub gen_page
  { my $self    = shift ;
    my $get     = shift ;
    my $VERSION = shift ;
    my $conf  = $self -> conf ;
    my $PPP   = $conf -> web_page ;
    my $state = $self -> state ;
    my $CCS   = $self -> regions ;
    my $TMP = "$PPP.tmp" ;
    my %tab ;
    my $refs ;

    for my $url ( keys %$state )
      { my $mirror = $state -> { $url } ;
        my $reg = $mirror -> region ;
        push @{ $tab { $reg } }, $mirror ;
      }

    my $bad = 0 ; my $old = 0 ; my $unr = 0 ;
    my %stats ;
    my @stats ;
    my $ok = 0 ;

    for my $url ( keys %$state )
      { my $mirror = $state -> { $url } ;
        my $time = $mirror -> age ;
        my $stat = $mirror -> last_status ;
        my $vrfy = $mirror -> last_ok_probe ;
        if ( $stat eq 'ok' ) { $ok ++ ; } else { $stats { $stat } ++ ; }
        if ( $time eq 'undef' )
          { $bad ++ ; }
        elsif ( 'f' eq $conf -> age_code ( $time ) )
          { $old ++ ; }
        if ( $vrfy eq 'undef' or aprx_lt $vrfy, $^T - $conf -> max_vrfy )
          { $unr ++ ; }
      }

    my $STAT = sprintf
        "%d bad -- %d older than %s -- %s unreachable for more than %s"
      , $bad
      , $old
      , pr_interval ( $conf -> max_age2 )
      , $unr
      , pr_interval ( $conf -> max_vrfy )
      ;

    my $PROB = 'last probes : ' ;
    push @stats, "$ok were ok" if $ok ;
    for my $stat ( sort keys %stats )
      { ( my $txt = $stat ) =~ s/_/ /g ;
        push @stats, sprintf "%s had %s" , $stats { $stat } , RED $txt ;
      }
    $PROB .= join ', ', @stats ;

    my ( $mean, $median, $stddev ) = $self -> age_avg ;
    my $AVGS = "mean mirror age is " ;
    unless ( defined $mean )
       { $AVGS = "<I>undefined</I>" ; }
    else
       { $AVGS .= sprintf "%s", pr_interval $mean ;
         if ( defined $stddev )
           { $AVGS .= sprintf ", std_dev %s", pr_interval $stddev ; }
         $AVGS .= sprintf ", median %s", pr_interval $median ;
       }

    for my $reg ( sort keys %tab )
      { $refs .= sprintf "&nbsp;%s&nbsp;\n"
          , URL "#$reg", "<FONT SIZE=\"+1\">$reg</FONT>"
          ;
      }

    my $COLS = 5 ;
    my $NAME = $conf -> project_name ;
    my $LOGO = $conf -> project_logo
      ? URL
          ( $conf -> project_url
          , sprintf
              ( '<IMG SRC="%s" ALT="%s" ALIGN="RIGHT" BORDER=0>'
              , $conf -> project_logo
              , $conf -> project_name
              )
          )
      : ''
      ;
    my $HEAD = $conf -> htm_head . "\n" ;
    my $HTOP = $conf -> htm_top  . "\n" ;
    my $FOOT = $conf -> htm_foot . "\n" ;
    my $TITL = URL $conf -> project_url, $NAME ;
    my $EXPD = Base::exp_date ;
    my $DATE = scalar gmtime $^T ;
    my $LAST = scalar gmtime ( $get ? $^T : ( stat $conf -> state ) [9] ) ;

    my $histo_top = $self -> gen_histogram ( 'top' ) ;
    my $histo_bot = $self -> gen_histogram ( 'bottom' ) ;

    open PPP, ">$TMP" or die "can't write $TMP ($!)" ;
    my $prev_select = select PPP ;

    my $attr1 = "COLSPAN=$COLS BGCOLOR=LIME" ;
    my $attr2 = 'BGCOLOR=AQUA' ;
    my $attr3 = "COLSPAN=$COLS BGCOLOR=YELLOW" ;

    my $num_mirrors = scalar keys %$state ;
    my $num_regions = scalar keys %tab ;

    print <<HEAD ;
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
<HTML>
<HEAD>
<TITLE>the status of $NAME mirrors</TITLE>
<META HTTP-EQUIV="content-type" CONTENT="text/html; charset=utf-8">
<META HTTP-EQUIV=refresh CONTENT=3600>
<META HTTP-EQUIV=Expires CONTENT=\"$EXPD\">
$HEAD
</HEAD>
<BODY BGCOLOR=\"#FFFFFF\">
$LOGO
<H2>the status of $TITL mirrors</H2>
<TABLE BORDER=0 CELLPADDING=2>
<TR><TD>date</TD><TD>:</TD><TD>$DATE (UTC)</TD></TR>
<TR><TD>last&nbsp;check</TD>
  <TD>:</TD>
  <TD>$LAST (UTC)</TD>
</TR>
</TABLE>
$HTOP
$histo_top
<H2>regions</H2>
<BLOCKQUOTE><CENTER>\n$refs\n</CENTER></BLOCKQUOTE>
<H2>report</H2>
<BLOCKQUOTE>
<TABLE BORDER=2 CELLPADDING=5>
<TR><TH $attr1>$num_mirrors sites in $num_regions regions</TH></TR>
<TR><TH $attr1>$STAT</TH></TR>
<TR><TH $attr1>$PROB</TH></TR>
<TR><TH $attr1>$AVGS</TH></TR>
<TR>
  <TH $attr2>$NAME site -- home</TH>
  <TH $attr2>type</TH>
  <TH $attr2>mirror age,<BR>daily stats</TH>
  <TH $attr2>last probe,<BR>probe stats</TH>
  <TH $attr2>last stat</TH>
</TR>
HEAD

    for my $reg
      ( sort { _cmp_ccs $CCS, $a, $b } keys %tab )
#      { ( $CCS -> { $a } ? lc ( $CCS -> { $a } ) : $a )
#    cmp ( $CCS -> { $b } ? lc ( $CCS -> { $b } ) : $b )
#      } keys %tab
#     )
      { my $mirrors = $tab { $reg } ;

        my $ccs = exists $CCS -> { $reg } ? $CCS -> { $reg } : $reg ;
        $ccs = NAM $reg,
          ( scalar @{ $mirrors } > 6
          ? sprintf "%s&nbsp;&nbsp;-&nbsp;&nbsp;%d sites"
              , $ccs, scalar @{ $mirrors }
          : $ccs
          ) ;
        printf "<TR><TH $attr3>$ccs</TH></TR>\n" ;

        for my $mirror ( sort { $a -> cmp ( $b ) } @$mirrors )
          { print "<TR>\n" ;
            printf "  <TD ALIGN=RIGHT>%s&nbsp;&nbsp;%s</TD>\n  <TD>%s</TD>\n"
              , $mirror -> url_site
              , $mirror -> url_home
              , $mirror -> type
              ;

            my ( $url, $time, $stat, $vrfy, $hstp, $hsts ) =
              $mirror -> as_list ;
            my $pr_time = $time =~ /^\d+$/
              ? pr_diff $time, $^T - $conf -> max_age2 : '&nbsp;' ;
            my $pr_last = $vrfy =~ /^\d+$/
              ? pr_diff $vrfy, $^T - $conf -> max_vrfy : '&nbsp;' ;
            my $pr_hstp = $self -> show_hist ( $hstp ) ;
            my $pr_hsts = $self -> show_hist ( $hsts ) ;

            if ( $stat ne 'ok' ) { $stat =~ s/_/ /g ; $stat = RED $stat ; }
            printf "  <TD ALIGN=RIGHT>%s<BR>%s</TD>\n" , $pr_time, $pr_hsts ;
            printf "  <TD ALIGN=RIGHT>%s<BR>%s</TD>\n" , $pr_last, $pr_hstp ;
            printf "  <TD>%s</TD>\n", $stat ;
            print "</TR>\n" ;
          }
      }

    my $legend = $self -> legend ;
    my $probes = $self -> gen_histogram_probes ;
    my $mir_img = sprintf
      '<IMG BORDER=2 ALT=mirmon SRC="%s/mirmon.gif">' , $conf -> icons ;

    print <<TAIL ;
</TABLE>
</BLOCKQUOTE>
$histo_bot
$legend
<H3>probe results</H3>
$probes
<H3>software</H3>
<BLOCKQUOTE>
<TABLE>
<TR>
  <TH><A HREF=\"$HOME\">$mir_img</A></TH>
  <TD>$VERSION</TD>
</TR>
</TABLE>
</BLOCKQUOTE>
$FOOT
</BODY>
</HTML>
TAIL

    select $prev_select ;

    if ( print PPP "\n" )
      { close PPP ;
        if ( -z $TMP )
          { warn "wrote empty html file; keeping previous version" ; }
        else
          { rename $TMP, $PPP or die "can't rename $TMP, $PPP ($!)" ; }
      }
    else
      { die "can't print to $TMP ($!)" ; }
  }

package Mirmon::Conf ; #############################################

BEGIN { use base 'Base' ; Base -> import () ; }

our %CNF_defaults =
  ( project_logo => ''
  , timeout      => $DEF_TIMEOUT
  , max_probes   => 25
  , min_poll     => '1h'
  , max_poll     => '4h'
  , min_sync     => '1d'
  , max_sync     => '2d'
  , list_style   => 'plain'
  , put_histo    => 'top'
  , randomize    => 1
  , add_slash    => 1
  , htm_top      => ''
  , htm_foot     => ''
  , htm_head     => ''
  , always_get   => ''
  ) ;

our @REQ_KEYS =
  qw( web_page state countries mirror_list probe
      project_name project_url icons
    ) ;
our %CNF_KEYS ;
for ( @REQ_KEYS, keys %CNF_defaults ) { $CNF_KEYS { $_ } ++ ; }

my @LIST_STYLE = qw(plain apache) ;
my @PUT_HGRAM  = qw(top bottom nowhere) ;

eval Base -> mk_methods ( keys %CNF_KEYS, qw(root site_url) ) ;

sub get_xtr
  { my $self = shift ;
    my $reg  = shift ;
    scalar grep { $_ eq $reg } split ' ', $self -> always_get ;
  }

sub new
  { my $self = shift ;
    my $FILE = shift ;
    my $res = bless { %CNF_defaults }, $self ;
    $res -> root ( $FILE ) ;
    $res -> site_url ( {} ) ;
    $res -> get_conf () ;
  }

sub get_conf
  { my $self = shift ;
    my $FILE = ( @_ ? shift : $self -> root ) ;

    if ( grep $_ eq $FILE,  @{ $self -> {_include} } )
      { die "already included : '$FILE'" ; }
    else
      { push @{ $self -> {_include} }, $FILE ; }

    open FILE, $FILE or die "can't open '$FILE' ($!)" ;
    my $CONF = join "\n", grep /./, <FILE> ;
    close FILE ;

    $CONF =~ s/\t/ /g ;           # replace tabs
    $CONF =~ s/^[+ ]+// ;         # delete leading space, plus
    $CONF =~ s/\n\n\s+/ /g ;      # glue continuation lines
    $CONF =~ s/\n\n\+\s+//g ;     # glue concatenation lines
    $CONF =~ s/\n\n\./\n/g ;      # glue concatenation lines

    chop $CONF ;
    print "--$CONF--\n" if Mirmon::debug ;
    for ( grep ! /^#/, split /\n\n/, $CONF )
      { my ($key,$val) = split ' ', $_, 2 ;
        $val = '' unless defined $val ;
        print "conf '$FILE' : key '$key', val '$val'\n" if Mirmon::debug ;
        if ( exists $CNF_KEYS { $key } )
          { $self -> $key ( $val ) ; }
        elsif ( $key eq 'site_url' )
          { my ( $site, $url ) = split ' ' , $val ;
            $url .= '/' if $self -> add_slash and $url !~ m!/$! ;
            $self -> site_url -> { $site } = $url ;
#           printf "config : for site '%s' use instead\n   '%s'\n",
#             $site, $url if Mirmon::verbose ;
          }
        elsif ( $key eq 'no_add_slash' )
          { $self -> add_slash ( 0 ) ; }
        elsif ( $key eq 'no_randomize' )
          { $self -> randomize ( 0 ) ; }
        elsif ( $key eq 'show' )
          { $self -> show_conf if Mirmon::verbose ; }
        elsif ( $key eq 'exit' )
          { die 'exit per config directive' ; }
        elsif ( $key eq 'include' )
          { $self -> get_conf ( $val ) ; }
        elsif ( $key eq 'env' )
          { my ( $x, $y ) = split ' ' , $val ;
            $ENV { $x } = $y ;
            printf "config : setenv '%s'\n   '%s'\n", $x, $y
              if Mirmon::verbose ;
          }
        else
          { $self -> show_conf ;
            die "unknown keyword '$key' (value '$val')\n" ;
          }
      }
    my $err = $self -> check ;
    die $err if $err ;
    $self ;
  }

sub check
  { my $self = shift ;
    my $err = '' ;
    for my $key ( @REQ_KEYS )
      { unless ( exists $self -> { $key } )
          { $err .= "error: missing config for '$key'\n" ; }
      }
    for my $key ( qw(min_poll max_poll max_sync min_sync) )
      { my $max = $self -> $key ;
        unless ( $max =~ /$TIM_PAT/o )
          { $err .= "error: bad timespec for $key ($max)\n" ; }
      }
    unless ( grep $self -> { list_style } eq $_, @LIST_STYLE )
      { $err .= sprintf "error: unknown 'list_style' '%s'\n",
          $self -> list_style ;
      }
    unless ( grep $self -> put_histo eq $_, @PUT_HGRAM )
      { $err .= sprintf "%s : error: unknown 'put_histo' '%s'\n",
          $self -> put_histo ;
      }
    $err ;
  }

sub show_conf
  { my $self = shift ;
    print "vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv\n" ;
    for my $key ( sort keys %$self )
      { next if $key =~ m/^_/ ;
        my $val = $self -> { $key } ;
        print "show_conf : $key = '$val'\n" ;
      }
    for my $key ( sort keys %{ $self -> site_url } )
      { printf "show_conf : for site '%s' use instead\n   '%s'\n"
          , $key, $self -> site_url -> { $key } if Mirmon::verbose ;
      }
    printf "show_conf : included '%s'\n"
      , join "', '", @{ $self -> {_include} } ;
    print "^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n" ;
  }

sub max_age1
  { my $self = shift ;
    ( s4tim $self -> min_sync ) + ( s4tim $self -> max_poll ) ;
  }

sub max_age2
  { my $self = shift ;
    ( s4tim $self -> max_sync ) + ( s4tim $self -> max_poll ) ;
  }

sub max_vrfy
  { my $self = shift ;
    ( s4tim $self -> min_poll ) + ( s4tim $self -> max_poll ) ;
  }

sub age_code
  { my $self = shift ;
    my $time = shift ;
    return 'z' unless $time =~ /^\d+$/ ;
    return
      ( ( aprx_ge ( $time, $^T - $self -> max_age1 ) )
      ? 's'
      : ( aprx_ge ( $time, $^T - $self -> max_age2 ) ? 'b' : 'f' )
      ) ;
  }

package Mirmon::Mirror ; ###########################################

BEGIN { use base 'Base' ; Base -> import () ; }

use IO::Pipe ;

my @FIELDS =
  qw(url age last_status last_ok_probe probe_history state_history last_probe) ;

eval Base -> mk_methods ( @FIELDS, qw(mirmon region mail) ) ;

sub state_history_time
  { my $self = shift ;
    my $res = ( split /-/, $self -> state_history ) [ 0 ] ;
    $res ;
  }

sub state_history_hist
  { my $self = shift ;
    my $res = ( split /-/, $self -> state_history ) [ 1 ] ;
    $res ;
  }

sub _parse
  { my $self = shift ;
    my $url  = $self -> url ;
    my ( $type, $site, $home, $path ) ;
    if ( $url =~ m!^(ftp|https?|rsync)://([^/:]+)(:\d+)?/! )
      { $type = $1 ; $site = $2 ; $home = $& ; $path = $' ; }
    else
      { warn "can't parse url ($url)" ; }
    return $type, $site, $home, $path ;
  }

sub type { my $self = shift ; ( $self -> _parse ) [ 0 ] ; }
sub site { my $self = shift ; ( $self -> _parse ) [ 1 ] ; }
sub home { my $self = shift ; ( $self -> _parse ) [ 2 ] ; }
sub path { my $self = shift ; ( $self -> _parse ) [ 3 ] ; }

sub age_in_days
  { my $self = shift ;
    my $res = 'undef' ;
    my $age = $self -> age ;
    if ( $age eq 'undef' )
      { $res = length $self -> state_history_hist
          if $self -> last_probe ne 'undef' ;
      }
    else
      { $res = ( $^T - $age ) / 24 / 60 / 60 ; }
    $res ;
  }

sub init
  { my $self   = shift ;
    my $mirmon = shift ;
    my $url    = shift ;
    my $res = bless { mirmon => $mirmon }, $self ;
    @{ $res } { @FIELDS } = ( 'undef' ) x scalar @FIELDS ;
    $res -> url ( $url ) ;
    $res -> probe_history ( '' ) ;
    $res -> state_history ( "$^T-z" ) ;
    $res -> mail ( '' ) ;
    $res ;
  }

sub new
  { my $self   = shift ;
    my $mirmon = shift ;
    my $line   = shift ;
    my $res = bless { mirmon => $mirmon }, $self ;
    @{ $res } { @FIELDS } = split ' ', $line ;
    $res -> mail ( '' ) ;
    $res ;
  }

sub update
  { my $self = shift ;
    my $succ = shift ;
    my $stat = shift ;
    my $time = shift ;
    my $probe_hist = $self -> probe_history ;
    if ( $succ )
      { $self -> age ( $time ) ;
        $self -> last_ok_probe ( $^T ) ;
        $probe_hist .= 's' ;
      }
    else
      { $probe_hist .= 'f' ;
        $time = $self -> age ;
      }

    my $h = $self -> state_history_hist ;
    my $t = $self -> state_history_time ;

    if ( aprx_ge ( $^T - $t, $HIST_DELTA ) )
      { my $n = int ( ( $^T - $t ) / $HIST_DELTA ) ;
        $h .= 'x' x ( $n - 1 ) ;
        $t = ( $n == 1 ? $t + $HIST_DELTA : $^T ) ;
      }
    else
      { chop $h ; }
    $h .= $self -> mirmon -> conf -> age_code ( $time ) ;
    $h = substr $h, - $HIST ;
    $h =~ s/^x+// ;

    $self -> last_status ( $stat ) ;
    $self -> probe_history ( substr $probe_hist, - $HIST ) ;
    $self -> last_probe ( $^T ) ;
    $self -> state_history ( "$t-$h" ) ;
  }

sub as_list { my $self = shift ; @{ $self } { @FIELDS } ; }
sub state { my $self = shift ; join ' ', $self -> as_list ; }

sub start_probe
  { my $self = shift ;
    my $conf = $self -> mirmon -> conf ;
    my $probe = $conf -> probe ;
    my $timeout = $conf -> timeout ;
    $probe =~ s/%TIMEOUT%/$timeout/g ;
    my $url = $self -> url ;
    my $new = $conf -> site_url -> { $self -> site } ;
    if ( defined $new )
      { printf "*** site_url : site %s\n  -> url %s\n"
          , $self -> site, $new if Mirmon::verbose ;
        $url = $new ;
      }
    $probe =~ s/%URL%/$url/g ;
    my $pipe = new IO::Pipe ;
    my $handle = $pipe -> reader ( split ' ', $probe ) ;
    if ( $handle )
      { $pipe -> blocking ( 0 ) ; }
    else
      { die "start_probe : no pipe for $url" ; }
    printf "start %s\n", $url if Mirmon::verbose ;
    printf "  %s\n", $probe if Mirmon::debug ;
    $handle ;
  }

sub finish_probe
  { my $self   = shift ;
    my $handle = shift ;
    my $res ;
    my $succ = 0 ;
    my $stat ;
    my $time ;

    $handle -> blocking ( 1 ) ;
    if ( $handle -> eof () )
      { printf "finish eof %s\n", $self -> url if Mirmon::verbose ; }
    else
      { $res = $handle -> getline () ; }
    $handle -> flush ;
    $handle -> close ;

    unless ( defined $res )
      { $stat = 'no_time' ; }
    elsif ( $res =~ /^\s*$/ )
      { $stat = 'empty' ; }
    else
      { $res = ( split ' ', $res ) [ 0 ] ;

        if ( $res !~ /^\d+$/ )
          { $res =~ s/ /_/g ;
            $res = Base::htmlquote $res ;
            $res = substr ( $res, 0, 15 ) . '..' if length $res > 15 ;
            $stat = "'$res'" ;
          }
        else
          { $succ = 1 ; $stat = 'ok' ; $time = $res ; }
      }

    printf "finish %s\n  succ(%s) stat(%s) time(%s)\n"
      , $self -> url
      , $succ
      , $stat
      , ( defined $time ? $time : 'undef' )
        if Mirmon::verbose ;

    $self -> update ( $succ, $stat, $time ) ;
  }

sub revdom { my $dom = shift ; join '.', reverse split /\./, $dom ; }

sub cmp
  { my $a = shift ;
    my $b = shift ;
    ( revdom $a -> site ) cmp ( revdom $b -> site )
    or
    ( $a -> type cmp $b -> type )
    ;
  }

sub _url
  { my $hrf = shift ;
    my $txt = shift ;
    $hrf =~ /^rsync/ ? $txt : URL $hrf, $txt ;
  }

sub url_site
  { my $self = shift ;
    my $type = $self -> type ;
    if ( $type eq 'rsync' )
      { my $path = $self -> path ;
        chop $path if $path =~ m!/$! ;
        sprintf '%s::%s', $self -> site , $path ;
      }
    else
      { URL $self -> url , $self -> site ; }
  }

sub url_home
  { my $self = shift ;
    my $type = $self -> type ;
    if ( $type eq 'rsync' )
      { '@' ; }
    else
      { URL $self -> home, '@' ; }
  }

=pod

=head1 NAME

Mirmon - OO interface for mirmon objects

=head1 SYNOPSIS

  use Mirmon ;

  $m = Mirmon -> new ( [ $path-to-config ] )

  $conf  = $m -> conf  ; # a Mirmon::Conf object
  $state = $m -> state ; # the mirmon state

  for my $url ( keys %$state )
    { $mirror = $state -> { $url } ; # a Mirmon::Mirror object
      $mail = $mirror -> mail ;      # contact address
      $mirror -> age ( time ) ;      # set mirror age
    }

Many class and object methods can be used to get or set attributes :

  $object -> attribute           # get an atttibute
  $object -> attribute ( $attr ) # set an atttibute

=head1 Mirmon class methods

=over 4

=item B<new ( [$path] )>

Create a Mirmon object from a config file found in $path,
or (by default) in the default list of possible config files.
Related objects (config, state) are created and initialised.

=item verbosity

Mirmon always reports errors. Normally it only reports
changes (inserts/deletes) found in the mirror_list ;
in I<quiet> mode, it doesn't. In I<verbose> mode, it
reports progress: the startup and finishing of probes.

  Mirmon::verbose ( [ $bool ] ) # get/set verbose
  Mirmon::quiet   ( [ $bool ] ) # get/set quiet
  Mirmon::debug   ( [ $bool ] ) # get/set debug

=back

=head1 Mirmon object methods

=over 4

=item B<conf>

Returns Mirmon's Mirmon::Conf object.

=item B<state>

Returns a hashref C<< { url => mirror, ... } >>,
where I<url> is as specified in the mirror list
and I<mirror> is a Mirmon::Mirror object.

=item B<regions>

Returns a hashref C<< { country_code =E<gt> country_name, ... } >>.

=item B<config_list>

Returns the list of default locations for config files.

=item B<get_dates ( $get [, $URL] )>

Probes all mirrors if $get is C<all> ; or a subset if $get is C<update> ;
or only I<$URL> if $get is C<url>.

=back

=head1 Mirmon::Conf object methods

A Mirmon::Conf object represents a mirmon conguration.
It is normaly created by Mirmon::new().
A specified (or default) config file is read and interpreted.

=over 4

=item attribute methods

For every config file entry, there is an attribute method :
B<web_page>, B<state>, B<countries>, B<mirror_list>, B<probe>,
B<project_name>, B<project_url>, B<icons>, B<project_logo>,
B<timeout>, B<max_probes>, B<min_poll>, B<max_poll>, B<min_sync>,
B<max_sync>, B<list_style>, B<put_histo>, B<randomize>, B<add_slash>.

=item B<root>

Returns the file name of (the root of) the configuration file(s).

=item B<site_url>

Returns a hashref C<< { site => url, ... } >>,
as specified in the mirmon config file.

=back

=head1 Mirmon::Mirror object methods

A Mirmon::Mirror object represents the last known state of a mirror.
It is normaly created by Mirmon::new() from the state file,
as specified in the mirmon config file.
Mirmon::Mirror objects can be used to probe mirrors.

=head2 attribute methods

=over 4

=item B<url>

The url as given in the mirror list.

=item B<age>

The mirror's timestamp found by the last successful probe,
or 'undef' if no probe was ever successful.

=item B<last_status>

The status of the last probe, or 'undef' if the mirror was never probed.

=item B<last_ok_probe>

The timestamp of the last successful probe or 'undef'
if the mirror was never successfully probed.

=item B<probe_history>

The probe history is a list of 's' (for success) and 'f' (for failure)
characters indicating the result of the probe. New results are appended
whenever the mirror is probed.

=item B<state_history>

The state history consists of a timestamp, a '-' char, and a list of
chars indicating a past status: 's' (fresh), 'b' (oldish), 'f' (old),
'z' (bad) or 'x' (skip).
The timestamp indicates when the state history was last updated.
The current status of the mirror is determined by the mirror's age and
a few configuration parameters (min_sync, max_sync, max_poll).
The state history is updated when the mirror is probed.
If the last update of the history was less than 24 hours ago,
the last status is replaced by the current status.
If the last update of the history was more than 24 hours ago,
the current status is appended to the history.
One or more 'skip's are inserted, if the timestamp is two or more days old
(when mirmon hasn't run for more than two days).

=item B<last_probe>

The timestamp of the last probe, or 'undef' if the mirror was never probed.

=back

=head2 object methods

=over 4

=item B<mirmon>

Returns the parent Mirmon object.

=item B<state_history_time>

Returns the I<time> part of the state_history attribute.

=item B<state_history_hist>

Returns the I<history> part of the state_history attribute.

=item B<type>, B<site>, B<home>

For an url like I<ftp://www.some.org/path/to/home>,
the B<type> is I<ftp>,
the B<site> is I<www.some.org>,
and B<home> is I<ftp://www.some.org/>.

=item B<age_in_days>

Returns the mirror's age (in fractional days), based on the mirror's
timestamp as found by the last successful probe ; or based on the
length of the state history if no probe was ever successful.
Returns 'undef' if the mirror was never probed.

=item B<mail>

Returns the mirror's contact address as specified in the mirror list.

=item B<region>

Returns the mirror's country code as specified in the mirror list.

=item B<start_probe>

Start a probe for the mirror in non-blocking mode ;
returns the associated (IO::Handle) file handle.
The caller must maintain an association between
the handles and the mirror objects.

=item B<finish_probe ( $handle )>

Sets the (IO::Handle) B<$handle> to blocking IO ;
reads a result from the handle,
and updates the state of the mirror.

=back

=head1 SEE ALSO

=begin html

<p>
<a href="mirmon.html">mirmon(1)</a>
</p>

=end html

=begin man

mirmon(1)

=end man

=head1 AUTHOR

=begin html

  <p>
  &copy; 2003-2014
  <a href="http://www.staff.science.uu.nl/~penni101/">Henk P. Penning</a>,
  <a href="http://www.uu.nl/faculty/science/EN/">Faculty of Science</a>,
  <a href="http://www.uu.nl/">Utrecht University</a>
  <br />
  mirmon-2.10 - Fri Aug 15 12:26:55 2014 ; henkp ;
  <a href="http://validator.w3.org/check?uri=referer">verify html</a>
  </p>

=end html

=begin man

  (c) 2003-2014 Henk P. Penning
  Faculty of Science, Utrecht University
  http://www.staff.science.uu.nl/~penni101/ -- penning@uu.nl
  mirmon-2.10 - Fri Aug 15 12:26:55 2014 ; henkp

=end man

=begin text

  (c) 2003-2014 Henk P. Penning
  Faculty of Science, Utrecht University
  http://www.staff.science.uu.nl/~penni101/ -- penning@uu.nl
  mirmon-2.10 - Fri Aug 15 12:26:55 2014 ; henkp

=end text

=cut

package main ; #####################################################

use IO::Pipe ;
use IO::Select ;
use Net::hostent ;

my $VERSION = Base::Version . ' - Fri Aug 15 12:26:55 2014 - henkp' ;
my $DEF_CNF = join ', ', Mirmon -> config_list ;
my $TIMEOUT = Base::DEF_TIMEOUT ;

my $prog = substr $0, rindex ( $0, '/' ) + 1 ;
my $Usage = <<USAGE ;
Usage: $prog [-v] [-q] [-t timeout] [-c conf] [-get all|update|url <url>]
option v   : be verbose
option q   : be quiet
option t   : set timeout ; default $TIMEOUT
option get : get all       : probe all sites
           : get update    : probe a selection of the sites (see doc)
           : get url <url> : probe some <url> (in the mirror-list).
option c   : configuration file ; default search :
             ( $DEF_CNF )
-------------------------------------------------------------------
Mirmon normally only reports errors and changes in the mirror list.
This is $VERSION.
-------------------------------------------------------------------
USAGE
sub Usage { die "$_[0]$Usage" ; }
sub Error { die "$prog: $_[0]\n" ; }
sub Warn  { warn "$prog: $_[0]\n" ; }

# usage: &GetOptions(ARG,ARG,..) defines $opt_ID as 1 or user spec'ed value
# usage: &GetOptions(\%opt,ARG,ARG,..) defines $opt{ID} as 1 or user value
# ARG = 'ID' | 'ID=SPC' | 'ID:SPC' for no-arg, required-arg or optional-arg
# ID  = perl identifier
# SPC = i|f|s for integer, fixedpoint real or string argument

use Getopt::Long ;
Getopt::Long::config ( 'no_ignore_case' ) ;
my %opt = () ;
Usage '' unless GetOptions ( \%opt, qw(v q t=i get=s c=s version) ) ;
Usage "Arg count\n" if @ARGV > 1 ;
Usage "Arg count\n" if $opt{get} and $opt{get} eq 'url' and ! @ARGV ;

if ( $opt{version} ) { printf "%s\n", Base::version () ; exit ; }

$opt{v} ||= $opt{d} ;

my $URL = shift ;

my $M = Mirmon -> new ( $opt{c} ) ;
$M -> conf -> timeout ( $opt{t} ) if $opt{t} ;

my $get = $opt{get} ;
if ( $get )
  { Error "url $URL not in list"
      if $get eq 'url' and ! $M -> state -> { $URL } ;
    Error "unknown 'get option' '$get'" unless Base::is_get_opt ( $get ) ;
  }

Mirmon::verbose ( $opt{v} ) ;
Mirmon::debug   ( $opt{d} ) ;
Mirmon::quiet   ( $opt{q} ) ;

if ( $get ) { $M -> get_dates ( $get, $URL ) ; $M -> put_state ; }
$M -> gen_page ( $get, $VERSION ) ;

__END__

=pod

=head1 NAME

mirmon - monitor the state of mirrors

=head1 SYNOPSIS

  mirmon [-v] [-q] [-t timeout] [-c conf] [-get all|update|url url]

=head1 OPTIONS

=over 4

=item B<-v>

Be verbose ; B<mirmon> normally only reports
errors and changes in the mirror list.

=item B<-q>

Be quiet.

=item B<-t> I<timeout>

Set the timeout ; the default is I<300>.

=item B<-get> all | update | url <url>

With B<all>, probe all sites.
With B<update>, probe a selection of the sites ; see option C<max_poll> below.
With B<url>, probe only the given I<url>, which must appear in the mirror-list.

=item B<-c> I<name>

Use config file I<name>. The default list is

  ./mirmon.conf $HOME/.mirmon.conf /etc/mirmon.conf

=back

=head1 USAGE

The program is intended to be run by cron every hour.

  42 * * * * perl /path/to/mirmon -get update

It quietly probes a subset of the sites in a given list,
writes the results in the 'state' file and generates a web page
with the results. The subset contains the sites that are new, bad
and/or not probed for a specified time.

When no 'get' option is specified, the program just generates a
new web page from the last known state.

The program checks the mirrors by running a (user specified)
program on a pipe. A (user specified) number of probes is
run in parallel using nonblocking IO. When something can be
read from the pipe, it switches the pipe to blocking IO and
reads one line from the pipe. Then it flushes and closes the
pipe. No attempt is made to kill the probe.

The probe should return something that looks like

  1043625600 ...

that is, a line of text starting with a timestamp. The exit status
of the probe is ignored.

=head1 CONFIG FILE

=head2 location

A config file can be specified with the -c option.
If -c is not used, the program looks for a config file in

=over

=item * B<./mirmon.conf>

=item * B<$HOME/.mirmon.conf>

=item * B</etc/mirmon.conf>

=back

=head2 syntax

A config file looks like this :

  +--------------------------------------------------
  |# lines that start with '#' are comment
  |# blank lines are ignored too
  |# tabs are replaced by a space
  |
  |# the config entries are 'key' and 'value' pairs
  |# a 'key' begins in column 1
  |# the 'value' is the rest of the line
  |somekey  A_val B_val ...
  |otherkey X_val Y_val ...
  |
  |# indented lines are glued
  |# the next three lines mean 'somekey part1 part2 part3'
  |somekey part1
  |  part2
  |  part3
  |
  |# lines starting with a '+' are concatenated
  |# the next three lines mean 'somekey part1part2part3'
  |somekey part1
  |+ part2
  |+ part3
  |
  |# lines starting with a '.' are glued too
  |# don't use a '.' on a line by itself
  |# 'somekey' gets the value "part1\n part2\n part3"
  |somekey part1
  |. part2
  |. part3
  +--------------------------------------------------

=head2 required entries

=over 4

=item project_name I<name>

Specify a short plaintext name for the project.

  project_name Apache
  project_name CTAN

=item project_url I<url>

Specify an url pointing to the 'home' of the project.

  project_url http://www.apache.org/

=item mirror_list I<file-name>

Specify the file containing the mirrors to probe.

  mirror_list /path/to/mirror-list

If your mirror list is generated by a program, use

  mirror_list /path/to/program arg1 ... |

Two formats are supported :

=over

=item * plain : lines like

  us http://www.tux.org/ [email] ...
  nl http://apache.cs.uu.nl/dist/ [email] ...
  nl rsync://archive.cs.uu.nl/apache-dist/ [email] ...

=item * apache : lines like those in the apache mirrors.list

  ftp  us ftp://ftp.tux.org/pub/net/apache/dist/ user@tux.org ...
  http nl http://apache.cs.uu.nl/dist/ user@cs.uu.nl ...

=back

Note that in style 'plain' the third item is reserved for an
optional email address : the site's contact address.

Specify the required format with option C<list_style> (see below).
The default style is 'plain'.

=item web_page I<file-name>

Specify where the html report page is written.

=item icons I<directory-name>

Specify the directory where the icons can be found,
relative to the I<web_page>, or relative to the
DOCUMENTROOT of the web server.

If/when the I<web_page> lives in directory C<.../mirmon/> and
the icons live in directory C<.../mirmon/icons/>,
specify

  icons icons

If/when the icons live in C</path/to/DOCUMENTROOT/icons/mirmon/>, specify

  icons /icons/mirmon

=item probe I<program + arguments>

Specify the program+args to probe the mirrors. Example:

  probe /usr/bin/wget -q -O - -T %TIMEOUT% -t 1 %URL%TIME.txt

Before the program is started, %TIMEOUT% and %URL% are
substituted with the proper timeout and url values.

Here it is assumed that each hour the root server writes
a timestamp in /path/to/archive/TIME.txt, for instance with
a crontab entry like

  42 * * * * perl -e 'print time, "\n"' > /path/to/archive/TIME.txt

Mirmon reads one line of output from the probe and interprets
the first word on that line as a timestamp ; for example :

  1043625600
  1043625600 Mon Jan 27 00:00:00 2003
  1043625600 www.apache.org Mon Jan 27 00:00:00 2003

Mirmon is distributed with a program C<probe> that handles
ftp, http and rsync urls.

=item state I<file-name>

Specify where the file containing the state is written.

The program reads this file on startup and writes the
file when mirrors are probed (-get is specified).

=item countries I<file-name>

Specify the file containing the country codes;
The file should contain lines like

  us - United States
  nl - Netherlands

The mirmon package contains a recent ISO list.

I<Fake> domains like I<Backup>, I<Master> are allowed,
and are listed first in the report ; lowercase-first
fake domains (like I<backup>) are listed last.

=back

=head2 optional entries

=over 4

=item max_probes I<number>

Optionally specify the number of parallel probes (default 25).

=item timeout I<seconds>

Optionally specify the timeout for the probes (default 300).

After the last probe is started, the program waits for
<timeout> + 10 seconds, cleans up and exits.

=item project_logo I<logo>

Optionally specify (the SRC of the IMG of) a logo to be placed
top right on the page.

  project_logo /icons/apache.gif
  project_logo http://www.apache.org/icons/...

=item htm_head I<html>

Optionally specify some HTML to be placed before </HEAD>.

  htm_head
    <link REL=StyleSheet HREF="/style.css" TYPE="text/css">

=item htm_top I<html>

Optionally specify some HTML to be placed near the top of the page.

  htm_top testing 1, 2, 3

=item htm_foot I<html>

Optionally specify HTML to be placed near the bottom of the page.

  htm_foot
    <HR>
    <A HREF="..."><IMG SRC="..." BORDER=0></A>
    <HR>

=item put_histo top|bottom|nowhere

Optionally specify where the age histogram must be placed.
The default is 'top'.

=item min_poll I<time-spec>

For 'min_poll' see next item. A I<time-spec> is a number followed by
a unit 's' (seconds), or 'm' (minutes), or 'h' (hours), or 'd' (days).
For example '3d' (three days) or '36h' (36 hours).

=item max_poll I<time-spec>

Optionally specify the maximum probe interval. When the program is
called with option '-get update', all sites are probed which are :

=over 4

=item * new

the site appears in the list, but there is no known state

=item * bad

the last probe of the site was unsuccessful

=item * old

the last probe was more than 'max_poll' ago.

=back

Sites are not probed if the last probe was less than 'min_poll' ago.
So, if you specify

  min_poll 4h
  max_poll 12h

the 'reachable' sites are probed twice daily and the 'unreachable'
sites are probed at most six times a day.

The default 'min_poll' is '1h' (1 hour).
The default 'max_poll' is '4h' (4 hours).

=item min_sync I<time-spec>

Optionally specify how often the mirrors are required to make an update.

The default 'min_sync' is '1d' (1 day).

=item max_sync I<time-spec>

Optionally specify the maximum allowable sync interval.

Sites exceeding the limit will be considered 'old'.
The default 'max_sync' is '2d' (2 days).

=item always_get I<region ...>

Optionally specify a list of regions that must be probed always.

  always_get Master Tier1

This is intended for I<fake regions> like I<Master> etc.

=item no_randomize

Mirmon tries to balance the probe load over the hourly mirmon runs.
If the current run has a below average number of mirrors to probe,
mirmon probes a few extra, randomly chosen mirrors, picked from the
runs that have the highest load.

If you don't want this behaviour, use B<no_randomize>.

=item no_add_slash

If the url part of a line in the mirror_list doesn't end
in a slash ('/'), mirmon adds a slash and issues a warning
unless it is in quiet mode.

If you don't want this behaviour, use B<no_add_slash>.

=item list_style plain|apache

Optionally specify the format ('plain' or 'apache') of the mirror-list.

See the description of 'mirror_list' above.
The default list_style is 'plain'.

=item site_url I<site> I<url>

Optionally specify a substitute url for a site.

When access to a site is restricted (in Australia, for instance),
another (sometimes secret) url can be used to probe the site.
The <site> of an url is the part between '://' and the first '/'.

=item env I<key> I<value>

Optionally specify an environment variable.

=item include I<file-name>

Optionally specify a file to include.

The specified file is processed 'in situ'. After the specified file is
read and processed, config processing is resumed in the file where the
C<include> was encountered.
The include depth is unlimited. However, it is a fatal error to
include a file twice under the same name.

=item show

When the config processor encounters the 'show' command, it
dumps the content of the current config to standout, if option
C<-v> is specified. This is intented for debugging.

=item exit

When the config processor encounters the 'exit' command, it
terminates the program. This is intented for debugging.

=back

=head1 STATE FILE FORMAT

The state file consists of lines; one line per site.
Each line consists of white space separated fields.
The seven fields are :

=over 4

=item * field 1 : url

The url as given in the mirror list.

=item * field 2 : age

The mirror's timestamp found by the last successful probe,
or 'undef' if no probe was ever successful.

=item * field 3 : status last probe

The status of the last probe, or 'undef' if the mirror was never probed.

=item * field 4 : time last successful probe

The timestamp of the last successful probe or 'undef'
if the mirror was never successfully probed.

=item * field 5 : probe history

The probe history is a list of 's' (for success) and 'f' (for failure)
characters indicating the result of the probe. New results are appended
whenever the mirror is probed.

=item * field 6 : state history

The state history consists of a timestamp, a '-' char, and a list of
chars indicating a past status: 's' (fresh), 'b' (oldish), 'f' (old),
'z' (bad) or 'x' (skip).
The timestamp indicates when the state history was last updated.
The current status of the mirror is determined by the mirror's age and
a few configuration parameters (min_sync, max_sync, max_poll).
The state history is updated when the mirror is probed.
If the last update of the history was less than 24 hours ago,
the last status is replaced by the current status.
If the last update of the history was more than 24 hours ago,
the current status is appended to the history.
One or more 'skip's is inserted, if the timestamp is two or more days old
(when mirmon hasn't run for more than two days).

=item * field 7 : last probe

The timestamp of the last probe, or 'undef' if the mirror was never probed.

=back

=head1 INSTALLATION

=head2 general

=over 4

=item * Note: The (empty) state file must exist before mirmon runs.

=item * The mirmon repository is here :

  https://svn.science.uu.nl/repos/project.mirmon/trunk/

=item * The mirmon tarball is here :

  http://www.staff.science.uu.nl/~penni101/mirmon/mirmon.tar.gz

=back

=head2 installation suggestions

To install and configure mirmon, take the following steps :

=over 2

=item * First, make the webdir :

  cd DOCUMENTROOT
  mkdir mirmon

For I<DOCUMENTROOT>, substitute the full pathname
of the document root of your webserver.

=item * Check out the mirmon repository :

  cd /usr/local/src
  svn checkout REPO mirmon

where

  REPO = https://svn.science.uu.nl/repos/project.mirmon/trunk/

or download the package and unpack it.

=item * Chdir to directory mirmon :

  cd mirmon

=item * Create the (empty) state file :

  touch state.txt

=item * Install the icons in the webdir :

  mkdir DOCUMENTROOT/mirmon/icons
  cp icons/* DOCUMENTROOT/mirmon/icons

=item * Create a mirror list C<mirror_list> ;

Use your favorite editor, or genererate the list from an
existing database.

  nl http://archive.cs.uu.nl/your-project/ contact@cs.uu.nl
  uk http://mirrors.this.org/your-project/ mirrors@this.org
  us http://mirrors.that.org/your-project/ mirrors@that.org

The email addresses are optional.

=item * Create a mirmon config file C<mirmon.conf> with your favorite editor.

  # lines must start in the first column ; no leading white space
  project_name ....
  project_url  ....
  mirror_list mirror_list
  state state.txt
  countries countries.list
  web_page DOCUMENTROOT/mirmon/index.html
  icons /mirmon/icons
  probe /usr/bin/wget -q -O - -T %TIMEOUT% -t 1 %URL%TIME.txt

This assumes the project's timestamp is in file C<TIME.txt>.

=item * If you have rsync urls, change the probe line to :

  probe perl /usr/local/src/mirmon/probe -t %TIMEOUT% %URL%TIME.txt

=item * Run mirmon :

  perl mirmon -v -get all

The mirmon report should now be in 'DOCUMENTROOT/mirmon/index.html'

  http://www.your.project.org/mirmon/

=item * If/when, at a later date, you want to upgrade mirmon :

  cd /usr/local/src/mirmon
  svn status -u
  svn up

=back

=head1 SEE ALSO

=begin html

<p>
<a href="mirmon.pm.html">mirmon.pm(3)</a>
</p>

=end html

=begin man

mirmon.pm(3)

=end man

=head1 AUTHOR

=begin html

  <p>
  &copy; 2003-2014
  <a href="http://www.staff.science.uu.nl/~penni101/">Henk P. Penning</a>,
  <a href="http://www.uu.nl/faculty/science/EN/">Faculty of Science</a>,
  <a href="http://www.uu.nl/">Utrecht University</a>
  <br />
  mirmon-2.10 - Fri Aug 15 12:26:55 2014 ; henkp ;
  <a href="http://validator.w3.org/check?uri=referer">verify html</a>
  </p>

=end html

=begin man

  (c) 2003-2014 Henk P. Penning
  Faculty of Science, Utrecht University
  http://www.staff.science.uu.nl/~penni101/ -- penning@uu.nl
  mirmon-2.10 - Fri Aug 15 12:26:55 2014 ; henkp

=end man

=begin text

  (c) 2003-2014 Henk P. Penning
  Faculty of Science, Utrecht University
  http://www.staff.science.uu.nl/~penni101/ -- penning@uu.nl
  mirmon-2.10 - Fri Aug 15 12:26:55 2014 ; henkp

=end text

=cut