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