#! /usr/bin/perl

use strict ;
use warnings ;

use CGI qw/:standard/ ;
use CGI::Carp 'fatalsToBrowser';
use Net::LDAP ;
use Dmon ;

use constant
  { LEFT => 'left'
  , RGHT => 'right'
  , MENU => 'urly'
  , ERRY => 'erry'
  , LOGO => '/images/dmon.png'
  , NO_RECV => 'not received'
  , ACKStab => 'acks'
  , USERtab => 'usrs'
  , COOKIE  => 'dmon_login'
  } ;

my $DARR  = '⇓'  ; # double down arrow
my $HARR  = '↪' ; # hooked down arrow
my $GONE  = '×' ;
my $USER  = '' ;
my $UPRF  = {} ;
my $VNAME = $ENV{SERVER_NAME} || 'no_server_name' ;
my $SCRPT = $ENV{SCRIPT_NAME} || 'no_script' ;
my $HTTPS = $ENV{HTTPS} ;

my $STYLE = <<STYLE ;
BODY
  { background-color: white ;
    font-family  : Verdana, sans-serif ;
    color: #000066 ;
  }

PRE { font-size : smaller ; }
HR  { border-style : solid ; }

A.urly:link    { text-decoration : none ; color: blue ; }
A.urly:visited { text-decoration : none ; color: blue ; }

A.erry:link    { color: red ; }
A.erry:visited { color: red ; }

div.menubox
  { border : 2px ;
    background-color: #FFFFCC ;
    border-style : solid ;
    border-color : #990066 ;
    font-family  : Verdana, sans-serif ;
    font-size    : larger ;
  }

div.menubox TH { background-color : #FFFFCC ; }
div.menubox A:link    { text-decoration : none ; color : blue }
div.menubox A:visited { text-decoration : none ; color : blue ; }
div.menubox A:hover   { text-decoration : underline ; }

div.motd
  { border : 2px ;
    background-color: #FFFFCC ;
    border-style : solid ;
    border-color : #990066 ;
    font-family  : Verdana, sans-serif ;
    margin-top   : 5px
  }
div.motd A:link    { text-decoration : none ; color : blue }
div.motd A:visited { text-decoration : none ; color : blue ; }

div.left0 { float : left ; }
div.left1 { float : left ; margin-left : 2em ; margin-right : 0em }

span.red { color : red ; }
span.big { font-size : larger ; }
span.brb { color : red ; font-weight : bold ; }
span.grn { color : green ; font-weight : bold ; }

th.left  { text-align : left ; }
th.right { text-align : right ; }
td.right { text-align : right ; }

tr.head    { background-color : #CCCCFF ; }
tr.subhead { background-color : #FFFFCC ; }
th.head    { background-color : #CCCCFF ; }
td.head    { background-color : #CCCCFF ; }
th.subhead { background-color : #FFFFCC ; }
td.subhead { background-color : #FFFFCC ; }

img.logo   { float : right ; }
STYLE

my @nl_open = qw(blockquote div table tr ul ) ;
my @nl_clos = qw(blockquote div table tr ul h1 h2 h3 h4) ;
my %nl_open = () ; for ( @nl_open ) { $nl_open { $_ } ++ ; }
my %nl_clos = () ; for ( @nl_clos ) { $nl_clos { $_ } ++ ; }

sub nlo { my $t = shift ; exists $nl_open { $t } ? "\n" : '' ; }
sub nlc { my $t = shift ; exists $nl_clos { $t } ? "\n" : '' ; }
sub DEF ($) { my $x = shift ; defined $x ? $x : '' ; }

sub _TAGa
  { my ( $t, $c ) = @_ ;
    my $nlo = nlo $t ;
    if ( @_ == 2 )
      { sprintf "<%s class=\"%s\">$nlo", $t, $c ; }
    else
      { sprintf '<%s>', $t ; }
  }

sub _TAGz { my ( $t ) = @_ ; sprintf '</%s>', $t ; }

sub _TAG1
  { my ( $t, $x, $c ) = @_ ;
    my $nlo = nlo $t ;
    my @args =
      ( ( @_ == 3 )
      ? ( "<%s class=\"%s\">$nlo%s</%s>", $t, $c, DEF $x, $t )
      : ( "<%s>$nlo%s</%s>", $t, DEF $x, $t )
      ) ;
    my $fmt = shift @args ;
    sprintf ( $fmt, @args ) . nlc $t ;
  }

sub _TAG2
  { my ( $t, $a, $x, $c ) = @_ ;
    my $nlo = nlo $t ;
    my @args =
      ( ( @_ == 4 )
      ? ( "<%s %s class=\"%s\">$nlo%s</%s>", $t, $a, $c, DEF $x, $t )
      : ( "<%s %s>$nlo%s</%s>", $t, $a, DEF $x, $t )
      ) ;
    my $fmt = shift @args ;
    sprintf ( $fmt, @args ) . nlc $t ;
  }

sub TABA { my @a = @_ ; _TAG2 'table', @a ; }
sub TAB
  { my @a = @_ ; TABA 'border="2" cellpadding="3" cellspacing="1"', @a ; }
sub TRx  { my @a = @_ ; _TAG1 'tr', @a ; }
sub TH   { my @a = @_ ; _TAG1 'th', @a ; }
sub THA  { my @a = @_ ; _TAG2 'th', @a ; }
sub THr  { my @a = @_ ; THA 'align="right"', @a ; }
sub THl  { my @a = @_ ; THA 'align="left"', @a ; }
sub TH2  { my @a = @_ ; THA 'colspan="2"', @a ; }
sub TH3  { my @a = @_ ; THA 'colspan="3"', @a ; }
sub TH4  { my @a = @_ ; THA 'colspan="4"', @a ; }
sub TH5  { my @a = @_ ; THA 'colspan="5"', @a ; }
sub TH6  { my @a = @_ ; THA 'colspan="6"', @a ; }
sub TD   { my @a = @_ ; _TAG1 'td', @a ; }
sub TDA  { my @a = @_ ; _TAG2 'td', @a ; }
sub TDl  { my @a = @_ ; _TAG1 'td', @a ; }
sub TDr  { my @a = @_ ; _TAG2 'td', 'align="right"' , @a ; }
sub TDc  { my @a = @_ ; _TAG2 'td', 'align="center"', @a ; }
sub DIV  { my @a = @_ ; _TAG1 'div', @a ; }
sub DIVa { my @a = @_ ; _TAGa 'div', @a ; }
sub DIVz { my @a = @_ ; _TAGz 'div', @a ; }
sub BQ   { my @a = @_ ; _TAG1 'blockquote', @a ; }
sub UL   { my @a = @_ ; _TAG1 'ul', @a ; }
sub LI   { my @a = @_ ; _TAG1 'li', @a ; }
sub CODE { my @a = @_ ; _TAG1 'code', @a ; }
sub SPAN { my @a = @_ ; _TAG1 'span', @a ; }
sub H1   { my @a = @_ ; _TAG1 'h1', @a ; }
sub H1A  { my @a = @_ ; _TAG2 'h1', @a ; }
sub H2   { my @a = @_ ; _TAG1 'h2', @a ; }
sub H2A  { my @a = @_ ; _TAG2 'h2', @a ; }
sub H3   { my @a = @_ ; _TAG1 'h3', @a ; }
sub H3A  { my @a = @_ ; _TAG2 'h3', @a ; }
sub H4   { my @a = @_ ; _TAG1 'h4', @a ; }
sub H4A  { my @a = @_ ; _TAG2 'h4', @a ; }
sub URL
  { my $hrf = sprintf 'href="%s"', shift ;
    my $txt = shift ;
    my @a = @_ ;
    _TAG2 'a', $hrf, $txt, @a ;
  }

sub NAME
  { my $nam = sprintf 'name="%s"', shift ;
    my $txt = shift ;
    my @a = @_ ;
    _TAG2 'a', $nam, $txt, @a ;
  }

sub URLA
  { my $hrf = sprintf 'href="%s"', shift ;
    my $txt = shift ;
    my $nam = shift ;
    my @a = @_ ;
    _TAG2 'a', "$hrf name=\"$nam\"", $txt, @a ;
  }

sub nl { "\n" ; }

sub RED { my $txt = shift ; SPAN $txt, 'red' ; }
sub BIG { my $txt = shift ; SPAN $txt, 'big' ; } 
sub BRB { my $txt = shift ; SPAN $txt, 'brb' ; } 
sub GRN { my $txt = shift ; SPAN $txt, 'grn' ; } 
sub BLD  { my @a = @_ ; _TAG1 'b', @a ; }
sub ITA  { my @a = @_ ; _TAG1 'i', @a ; }
sub SMA  { my @a = @_ ; _TAG1 'small', @a ; }

sub TOP
  { my $sty = 'style="float:right"' ;
    ( $UPRF -> { tops }
    ? "<a href='#'><img src='/icons/hand.up.gif' $sty alt='top'></a>\n"
    : ''
    ) ;
  }

my %quote =
  ( '<' => 'lt'
  , '>' => 'gt'
  , '&' => 'amp'
  , "'" => '#8216'
  , '"' => 'quot'
  ) ;
sub _quote { my $x = shift ; exists $quote { $x } ? "\&$quote{$x};" : $x ; }
sub quote { my $x = shift || '' ; join '', map { _quote $_ } split '', $x ; }

sub logo
  { my $img = sprintf '<img src="%s" class="logo" alt="dmon"/>', LOGO ;
    URL '/', $img ;
  }

sub XTRA () { $HTTPS and $USER ; }

sub get_prefs
  { my $DBS = shift ;
    $UPRF =
      ( $USER
      ? $DBS -> select1_hash ( USERtab, where => "user = '$USER'" )
      : {}
      ) ;
  }

my $HEAD_SENT = 0 ;
my $TITL_SENT = '' ;
sub HEAD
  { my $subt = shift ;
    return '' if $HEAD_SENT ++ ;
    $TITL_SENT = $VNAME . ( $subt ? " - $subt" : '' ) ;
    ( header ( -charset=>'utf-8' )
    . start_html
        ( -title    => $TITL_SENT
        , -encoding => 'utf-8'
        , -head     => 
            [ meta
               ( { -http_equiv => 'refresh'
                 , -content    => 300
                 }
               )
            ]
        , -style    => { -code => $STYLE }
        )
    ) ;
  }

sub TAIL
  { my $valid = '/images/valid-xhtml10-blue.png' ;
    ( hr
    . nl
    . a ( { href => 'http://validator.w3.org/check?uri=referer' }
        , sprintf '<img class="logo" src="%s" alt="XHTML-1.0"/>', $valid
        )
    . ( scalar localtime )
    . nl
    . end_html
    . nl
    ) ;
  }

sub ERR
  { my $fmt = shift ;
    my @msg = @_ ;
    print HEAD 'error' ;
    print H2 'Error' ;
    print BQ sprintf $fmt, @msg ;
    print TAIL ;
    exit ;
  }

sub _fmt_vu
  { my $v = shift ;
    my $u = shift ;
    $v = sprintf "%.2f", $v if $v != int $v ;
    $v ? "$v $u" . ( $v == 1 ? '' : 's' ) : '' ;
  } ;

my $units =
  [ { nam => 'week'  , mod =>  0 }
  , { nam => 'day'   , mod =>  7 }
  , { nam => 'hour'  , mod => 24 }
  , { nam => 'minute', mod => 60 }
  , { nam => 'second', mod => 60 }
  ] ;

# init
  { my $siz = 1 ;
    my $mod = 1 ;
    my $nxt = undef ;
    for my $u ( reverse @$units )
      { $u -> { siz } = $siz *= $mod ;
        $u -> { nxt } = $nxt ;
        $mod = $u -> { mod } ;
        $nxt = $u ;
      }
  }
sub set_cnts ;
sub set_cnts
  { my $prec = shift ;
    my $unit = shift ;
    my $ival = shift ;
    my $nzs  = shift ;
    return 0 unless $unit ;
    my $res = 0 ;
    my $siz = $unit -> { siz } ;
    my $mod = $unit -> { mod } ;
    if ( $prec and $nzs == $prec and $ival )
      { $res = sprintf '%.2f', $ival / ( $mod * $siz ) ; }
    else
      { my $cnt = int ( $ival / $siz ) ;
        my $nz  = ( $cnt ? 1 : 0 ) ;
        $cnt += set_cnts
          ( $prec, $unit -> { nxt }, $ival % $siz, $nzs + $nz ) ;
        if ( $mod and $cnt == $mod )
          { $cnt = 0 ; $res = 1 ; }
        $unit -> { cnt } = $cnt ; 
      }
    $res ;
  } ;

sub secs
  { my $ival = shift ;
    my $prec = shift ; $prec = 4 unless defined $prec ;
    my $res ;

    if ( $ival < 0 )
      { $res = sprintf "-%d seconds", -$ival ; }
    else
      { for my $u ( @$units ) { $u -> { cnt } = 0 ; }
        $ival = int ( $ival + 0.5 ) ;
        set_cnts ( $prec, $units -> [ 0 ], $ival, 0 ) ;
        $res = join ' ', map { _fmt_vu ( @{ $_ } { qw(cnt nam) } ) ; }
          grep { $_ -> { cnt } } @$units ;
        $res ||= '0 seconds' ;
      }
    $res ;
  }

sub make_dbs
  { my $file = shift ;
    my $dbs  = TS -> Make ( file => $file ) ;
    my $dbh  = $dbs -> connect ;
    return undef unless $dbs -> dbh ;
    OBB::TT 'pmaker db connected %s file %s', !! $dbs -> dbh, $file ;
    $dbs -> add_tab ( ACKStab ) unless $dbs -> has_tab ( ACKStab ) ;
    for my $nam ( qw(hnam item user levl) )
      { my $typ = $nam eq 'levl' ? 'int' : 'text' ;
        $dbs -> add_col ( ACKStab, $nam, $typ )
          unless $dbs -> has_col ( ACKStab, $nam ) ;
      }
    $dbs -> add_tab ( USERtab ) unless $dbs -> has_tab ( USERtab ) ;
    for my $nam ( qw(user pswd) )
      { $dbs -> add_col ( USERtab, $nam, 'text' )
          unless $dbs -> has_col ( USERtab, $nam ) ;
      }
    for my $nam ( qw(tops) )
      { $dbs -> add_col ( USERtab, $nam, 'int' )
          unless $dbs -> has_col ( USERtab, $nam ) ;
      }
    $dbs ;
  }

sub del_ack
  { my $dbs = shift ;
    my $HST = shift ;
    my $ITM = shift ;
    $dbs -> delete ( ACKStab, where => "hnam = '$HST' and item = '$ITM'" ) ;
  }

sub add_ack
  { my $dbs = shift ;
    my $HOST = shift ;
    my $ITEM = shift ;
    my $LEVL = shift ;
    del_ack ( $dbs, $HOST, $ITEM ) ;
    $dbs -> save_hash
      ( ACKStab
      , { hnam => $HOST
        , item => $ITEM
        , levl => $LEVL
        , user => $USER
        }
      ) ;
  }

sub nack_hrf
  { my $hnam = shift ;
    my $name = shift ; # item-name
    my %args =
      ( NACK => 1
      , HOST => $hnam
      , ITEM => $name
      ) ;
    sprintf '%s?%s', $SCRPT
      , join '&amp;', map { "$_=$args{$_}" } sort keys %args ;
  }

sub get_secret
  { my $conf = shift ;
    my $file = $conf -> secrfil ;
    my $res = Util::text_file $file ; chomp $res ;
    ERR "no cgi secret [$file]" unless defined $res and length $res ;
    $res ;
  }

###################################################################
package Prblm ;
use base qw(OBB) ;
__PACKAGE__ -> mk_getset ( qw(itm txt) ) ;

sub ackr_href
  { my $self = shift ;
    my $host = shift ;
    my $item = $self -> itm ;
    return '' unless $item and defined $item -> val ;
    my %args =
      ( ACKR => 1
      , HOST => $host -> hnam
      , ITEM => $item -> name
      , LEVL => $item -> levl
      ) ;
    sprintf '%s?%s', $SCRPT
      , join '&amp;', map { "$_=$args{$_}" } sort keys %args ;
  }

sub acked
  { my $self = shift ;
    my $dbs  = shift ;
    my $hnam = shift ;
    my $itm  = $self -> itm ;
    return 0 unless $itm ;
    my $name = $itm -> name ;
    my $levl = $itm -> levl ;
    $dbs -> count
      ( main::ACKStab
      , where => "hnam = '$hnam' and item = '$name' and levl = $levl"
      ) ;
  }

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

my $prog = substr $0, rindex ( $0, '/' ) + 1 ;
my $Usage = <<USAGE ;
Usage: $prog [-v] [-q] [-d] [-h] [-c file]
option v : be verbose
option q : be quiet
option d : show debug info
option h : show help ; exit
option c : use config <file> ;
           default [ @{[join ', ', Conf::FILES]} ]
USAGE
sub Usage { die "$_[0]$Usage" ; }
sub Error { die "[error] $prog: $_[0]\n" ; }
sub Warn  { 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

$| = 1 ;

use Getopt::Long ;
Getopt::Long::config ( 'no_ignore_case' ) ;
my %opt = () ; Usage '' unless GetOptions
  ( \%opt, qw(v q d h c=s T test) ) ;
# Usage("Arg count\n") if @ARGV > 0 ;

$opt{d} ||= $opt{T} ;
$opt{v} ||= $opt{d} ;
OBB -> Verbosity ( 'Quiet'   ) ;
OBB -> Verbosity ( 'Verbose' ) if $opt{v} ;
OBB -> Verbosity ( 'Debug'   ) if $opt{d} ;
OBB -> Verbosity ( 'Trace'   ) if $opt{T} ;

if ( $opt{h} ) { print $Usage ; exit ; }

my $conf  = Conf -> Make ( file => $opt{c} ) ;

$conf -> logdir ( '' ) ;
$conf -> PORT ( 23007 ) if $opt{test} ;
$conf -> Dmp ( 'config' ) if $opt{v} ;
Util  -> INITx ( conf => $conf ) ;

my $threads = Threads -> Make ;
my $PMAKER  = Pmaker -> Make ( conf => $conf, threads => $threads ) ;
my $hnam    = $PMAKER -> hnam ;
my $wrk_err = $PMAKER -> work -> error ;
my $Items   = $PMAKER -> Items ;
my $Kinds   = $Kinds::KINDS ;
my $SECRET  = get_secret $conf ;
my $DBFILE  = $conf -> dbs_pmkr ;
my $DBS     = make_dbs $DBFILE or ERR "httpd can't create/write %s", $DBFILE ;

# OBB::Dmp [ $Items -> probes ] ; exit ;

ERR "$hnam : $wrk_err" if $wrk_err ;
ERR "no server found" unless $PMAKER -> server ;

my @IVALS  = qw(hour day week month year) ;
my %IVALS  = qw(hour hr day day week wk month mon year yr) ;
my $server = $PMAKER -> server -> hnam ;
my $q      = CGI -> new ;

my $HOST = $q -> param ( 'HOST' ) ;
my $ITEM = $q -> param ( 'ITEM' ) ;
my $IVAL = $q -> param ( 'IVAL' ) || 'hour' ;
my $ACKR = $q -> param ( 'ACKR' ) ;
my $LEVL = $q -> param ( 'LEVL' ) ;
my $NACK = $q -> param ( 'NACK' ) ;
my $PREF = $q -> param ( 'PREF' ) ;
my $DOPW = $q -> param ( 'DOPW' ) ;
my $QUIT = $q -> param ( 'QUIT' ) ;
my $NEWP = $q -> param ( 'NEWP' ) ;
my $OLDP = $q -> param ( 'OLDP' ) ;
my $SUBM = $q -> param ( 'SUBM' ) ;
my $ALRT = $q -> param ( 'ALRT' ) ;
my $EVNT = $q -> param ( 'EVNT' ) ; $EVNT = '1d' unless defined $EVNT ;

ERR quote "bad HOST [$HOST]" if $HOST and $HOST !~ /^[a-z0-9][-_.\w]*$/i ;
ERR quote "bad ITEM [$ITEM]" if $ITEM and $ITEM !~ /^\w+$/ ;
ERR quote "bad IVAL [$IVAL]" if $IVAL and $IVAL !~ /^\w+$/ ;
ERR quote "bad ACKR [$ACKR]" if $ACKR and $ACKR !~ /^\d+$/ ;
ERR quote "bad NACK [$NACK]" if $NACK and $NACK !~ /^\d+$/ ;
ERR quote "bad LEVL [$LEVL]" if $LEVL and $LEVL !~ /^\d+$/ ;
ERR quote "bad EVNT [$EVNT]" unless defined Util::secs4spec ( $EVNT ) ;

sub tag_ival { $IVALS { $_[0] } || $_[0] ; }
my @EVNTS  = qw(all -- 1h 4h 12h 1d 2d12h 1w -- 5 10 20) ;
sub arg_evnt { $_[0] eq 'all' ? 0 : $_[0] ; }

if ( $opt{v} )
  { printf "server : %s\n", $server ;
    $PMAKER -> Dmp ( 'PMAKER' ) if $opt{d} ;
  }

# print "<pre>\n" ;
# $PMAKER -> Dmp ( 'PMAKER' ) ;
# print "</pre>\n" ;

my $from_server = [] ;
my $send_server = $PMAKER -> send_server
  ( ( ( $HOST and $ITEM )
    ? "CLIENTS $HOST $ITEM 0"
    : "CLIENTS $EVNT"
    )
  , $from_server
  ) ;
ERR "can't connect to server (%s:%s)", $server, $conf -> PORT 
  unless $send_server ;
my $recv ;

while ( ! $recv )
  { $threads -> do_a_loop ;
    if ( @$from_server )
      { $recv = shift @$from_server ;
        $recv -> body if $opt{d} ;
        printf "received message type [%s]\n", $recv -> type if $opt{v} ;
        my $cdmp = $recv -> cdmp ;
        $PMAKER -> get_clients ( $cdmp ) ;
        $PMAKER -> event0 ( $recv -> event0 ) ;
        $PMAKER -> noalrt ( $recv -> noalrt ) ;
        my $events = $PMAKER -> get_events ( $recv -> events ) ;
        my $levels = $PMAKER -> levels ;
        for my $event ( @$events )
          { my $hnam = $event -> hnam ;
            my $host = $PMAKER -> clients -> { $hnam }
              || Host::Client -> Make
                   ( hnam => $hnam, show => $hnam, ips => [] ) ;
            my $name = $event -> item ;
            my $undf = Fitl::UNDF ;
            $event -> item ( $Items -> item ( $name ) ) ;
            $event -> host ( $host ) ;
            $event -> lold ( $levels -> [ $event -> lold ] || $undf ) ;
            $event -> lnew ( $levels -> [ $event -> lnew ] || $undf ) ;
          }
      }
  }

my $clients = $PMAKER -> clients ;
my $events  = $PMAKER -> events  ;
my $event0  = $PMAKER -> event0  ;

sub add_log
  { my $fmt = shift || '<empty>' ;
    my $msg = sprintf $fmt, @_ ;
    my $date = localtime ;
    my $user = $USER || 'unkown' ;
    my $log  = $conf -> log_pmkr ;
    if ( $log and open LOG, '>>', $log )
      { printf LOG "%s [%s] %s\n", $date, $user, $msg ; close LOG ; }
  }

sub date
  { my $x = shift ;
    my $y = shift || 'never' ;
    $x ? Util::date ( $x ) : SPAN $y, 'brb' ;
  }

sub is_old ($) { my $x = shift || 0 ; time - $x > 400 ; }

sub repr_date
  { my $x = shift || 0 ;
    my $res = date $x ;
    is_old $x ? SPAN ( $res, 'red' ) : $res ;
  }

sub by_show { $a -> show cmp $b -> show ; }
sub by_client_show
  { my $aa = $clients -> { $a } ? $clients -> { $a } -> show : $a ;
    my $bb = $clients -> { $b } ? $clients -> { $b } -> show : $b ;
    $aa cmp $bb ;
  }

sub has_perr ($)
  { my $client = shift ;
    my $items  = $client -> state -> items ;
    scalar grep $_ -> perr, @$items ;
  }

sub by_rlvl { $b -> levl <=> $a -> levl ; }

sub has_state { my $client = shift ; $client -> t_state ; }

sub has_fits ($)
  { my $client = shift ;
    my $items  = $client -> state -> items ;
    my @nfine  = grep { $_ -> fit and $_ -> fit ne 'fine' }
      sort by_rlvl @$items ;
    $nfine [ 0 ] ? $nfine [ 0 ] -> fitl -> show : '' ;
  }

sub has_item ($$)
  { my $client = shift ;
    my $name   = shift ;
    my $items  = $client -> state -> items ;
    scalar grep { $_ -> name eq $name } @$items ;
  }

sub xargs ($)
  { my $client = shift ; $PMAKER -> work -> xargs -> { $client -> hnam } ; }
sub xfits ($)
  { my $client = shift ; $PMAKER -> work -> xfits -> { $client -> hnam } ; }

sub host_url
  { my $hnam = shift ;
    my $text = shift ;
    ( $clients -> { $hnam }
    ? ( URL "#host.$hnam", $DARR . ( $text ? " $text" : '' ), @_ )
    : $GONE
    ) ;
  }

sub host_url_abs
  { my $hnam = shift ;
    my $text = shift || $hnam ;
    ( $clients -> { $hnam }
    ? ( URL "$SCRPT#host.$hnam", $text , @_ )
    : 'xxx ' . $GONE
    ) ;
  }

sub item_url
  { my $name = shift ;
    ( $Items -> have ( $name )
    ? URL "#item.$name", $DARR, MENU
    : $GONE
    ) ;
  }

sub plot_ref
  { my $client = shift ;
    my $server = shift ;
    my $item = shift ;
    my $ival = shift ;
    my $name = $item -> name ;
    my $kind = $item -> kind ;
    my $hnam = $client -> hnam ;
    my $show = $client -> show ;
    my $wrkr = $client -> wrkr || $hnam ;
    $server = 'localhost' if $server eq $Util::canonical_hostname ;
    my @vars = qw(SERV WRKR HOST SHOW COLS KIND IVAL) ;
    my $fmt  = join '&amp;', map { "$_=\%s" } @vars ;
    my @vals = ( $server, $wrkr, $hnam, $show, $name, $kind ) ;
    my $qwe = sprintf $fmt , @vals, $ival ;
    my $ref = sprintf '%s?%s', $conf -> plot_url, $qwe ;
    ( $ref, tag_ival $ival ) ;
  }

sub home_url  { URL $SCRPT, 'home' ; }
sub plot_url  { URL plot_ref @_ ; }
sub plot_urls { join "\n", grep length $_, map { plot_url @_, $_ } @IVALS ; }

sub hist_item_url
  { my $item = shift ;
    my $ival = shift ;
    if ( grep { has_item $_, $item } values %$clients )
      { URL "$SCRPT?ITEM=$item&amp;IVAL=$ival", tag_ival $ival ; }
    else
      { '' ; }
  }

sub hist_item_urls
  { my $item = shift ;
    join "\n", grep length $_, map { hist_item_url $item, $_ } @IVALS ;
  }

sub hist_host_url
  { my $hnam = shift ;
    my $ival = shift ;
    URL "$SCRPT?HOST=$hnam&amp;IVAL=$ival", tag_ival $ival ;
  }

sub hist_host_urls
  { my $hnam = shift ;
    join "\n", grep length $_, map { hist_host_url $hnam, $_ } @IVALS ;
  }

sub hist_ival_url
  { my $hnam = shift ;
    my $inam = shift ;
    my $text = shift ;
    ( ( $clients -> { $hnam } and $Items -> have ( $inam ) )
    ?  URL "$SCRPT?HOST=$hnam&amp;ITEM=$inam", $text, @_
    : $text
    ) ;
  }

sub event_url
  { my $spec = shift ;
    my $arg  = arg_evnt $spec ;
    ( $spec eq '--'
    ? '&mdash;'
    : ( $arg eq $EVNT
      ? BLD $spec
      : URL "$SCRPT?EVNT=$arg", $spec
      )
    ) ;
  }

sub event_urls { join "\n", map { event_url $_ } @EVNTS ; }

sub prob_txt
  { my $item = shift ;
    my $hnam = shift ;
    my $name = $item -> name ;
    sprintf '%s <i>%s</i> is %s%s'
      , ( item_url $name )
      , ( hist_ival_url $hnam, $name, $name, MENU )
      , RED ( $item -> fitl -> show )
      , ( defined $item -> val
        ? ( sprintf ' [%s]', $item -> Repr ( $item -> repr ) )
        : ''
        ) ;
  }

sub change_txt
  { my $evnt = shift ;
    my $item = $evnt -> item ;
    my $vold = $evnt -> vold ;
    my $vnew = $evnt -> vnew ;
    my $mesg = $evnt -> mesg || '' ;
    my $told = defined $vold ? $item -> Repr ( $item -> repr ( $vold ) ) : '' ;
    my $tnew = defined $vnew ? $item -> Repr ( $item -> repr ( $vnew ) ) : '' ;
    my $text = join ' &rarr; ', grep length $_, ( $told, $tnew ) ;
    join ' ', grep length $_, $text, $mesg ;
  }

sub mk_summary
  { my $cnt = 0 ;
    my @trs = () ;
    my $ack = 0 ;
    for my $client ( sort by_show values %$clients )
      { my $hnam = $client -> hnam ;
        my $show = $client -> show ;
        my $url1 = host_url $hnam, '', MENU ;
        my $errs = has_perr $client ;
        my $items = $client -> state -> items ;
        my @probs = () ;
        my $norp ;
        my $trep = has_state $client ;
        unless ( $trep )
          { push @probs, Prblm -> Make ( txt => SPAN 'no report', 'brb' ) ; }
        elsif ( is_old $trep )
          { push @probs, Prblm -> Make ( txt => SPAN 'old report', 'brb' ) ; }
        if ( $errs )
          { my $cnt = @$items ;
            my $txt =
              ( $errs == $cnt 
              ? "can't probe"
              : ( sprintf 'probe errors (%s of %s)', $errs, $cnt )
              ) ;
            push @probs, Prblm -> Make ( txt => $txt ) ;
          }
          
        for my $itm ( @$items )
          { if ( $itm -> levl )
              { my $name = $itm -> name ;
                my $txt  = prob_txt $itm, $hnam ;
                my $prob = Prblm -> Make ( itm => $itm, txt => $txt ) ;
                if ( $prob -> acked ( $DBS, $hnam ) )
                  { $ack ++ ; }
                else
                  { push @probs, $prob ; }
              }
          }
        if ( @probs )
          { my $probs = @probs ;
            my $th0   = THA ( "rowspan='$probs'", "$url1 $show", LEFT ) ;
            for my $prob ( @probs )
              { my $hrf = $prob -> ackr_href ( $client ) ;
                push @trs,
                  ( $th0
                  . ( TD $prob -> txt )
                  . ( XTRA
                    ? TD ( $hrf ? URL $hrf, 'hide problem', MENU : '' )
                    : ''
                    )
                  ) ;
                $th0 = '' ;
              }
          }
        $cnt += @$items ;
      }
    my $at1 = sprintf "colspan='%d'", ( XTRA ? 2 : 1 ) ;
    my $at2 = sprintf "colspan='%d'", ( XTRA ? 3 : 2 ) ;
    my $th0 = TRx ( TH ( 'date' ) . THA ( $at1, scalar localtime ), 'head' ) ;
    my $tr0 = $th0 . TRx
      ( ( TH 'host' )
      . ( TH sprintf 'problems - %s of %s', scalar @trs, $cnt )
      . ( XTRA ? TH 'click' : '' )
      , 'subhead'
      ) ;
    TAB
      ( $tr0
      . ( @trs
        ? ( join "\n", map { TR $_ } @trs )
        : ( TRx THA $at2, "no problems" )
        )
      ) .
      ( $ack
      ?  UL LI URL '#head.Acked', "$DARR <b>hidden problems : $ack</b>", MENU
      : ''
      ) ;
  }

sub mk_clients
  { my $cnt = scalar values %$clients ;
    my $tr0 = TRx
      ( ( TH "hosts [$cnt]" )
      . ( TH 'probs' )
      . ( TH 'last report' )
      . ( TH 'history' )
      , 'head'
      ) ;
    my @trs = () ;
    for my $client ( sort by_show values %$clients )
      { my $hnam = $client -> hnam ;
        my $show = $client -> show ;
        my $hfit = has_fits $client || '' ;
        my $url1 = host_url $hnam, '', MENU ;
        my $url2 = host_url $hnam, "error", ERRY ;
        my $url3 = host_url $hnam, "$hfit", ERRY ;
        my $prob =
          ( ( has_perr $client ) ? $url2
          : ( $hfit ) ? $url3
          : ''
          ) ;
        push @trs,
          ( TH ( "$url1 $show", LEFT )
          . TH ( $prob, LEFT )
          . TD ( repr_date ( $client -> t_state ), RGHT )
          . TD ( hist_host_urls ( $client -> hnam ) )
          ) ;
      }
    TAB $tr0 . join "\n", map { TR $_ } @trs ;
  }

sub mk_xargs
  { my $client = shift ;
    my $xargs  = xargs $client ;
    return '' unless $xargs ;
    my $tr0 = TRx ( ( TH 'item' ) . ( TH 'probe with' ), 'subhead' ) ;
    my @trs = () ;
    for my $itm ( sort keys %$xargs )
      { my $args = $xargs -> { $itm } ;
        my $url  = item_url $itm ;
        push @trs, ( TH ( "$url $itm", LEFT ) . TD ( "@$args" ) ) ;
      }
    TAB $tr0 . join "\n", map { TR $_ } @trs ;
  }

sub mk_xfits
  { my $client = shift ;
    my $xfits  = xfits $client ;
    return '' unless $xfits ;
    my $tr0 = TRx ( ( TH 'item' ) . ( TH 'fitter' ), 'subhead' ) ;
    my @trs = () ;
    for my $itm ( sort keys %$xfits )
      { my $fitr = $xfits -> { $itm } ;
        my $url  = item_url $itm ;
        push @trs, ( TH ( "$url $itm", LEFT ) . TD ( quote $fitr ) ) ;
      }
    TAB $tr0 . join "\n", map { TR $_ } @trs ;
  }

sub mk_client
  { my $client = shift ;
    my $perr   = has_perr $client ;
    my $fits   = has_fits $client ;
    my $items  = $client -> state -> items ;
    my $tr0    = TRx
      ( ( TH 'item' )
      . ( TH 'state' )
      . ( TH 'age' )
      . ( TH 'history' )
      . ( $perr ? TH 'error'   : '' )
      . ( $fits ? TH 'fitness' : '' )
      , 'subhead'
      ) ;
    my @trs = () ;
    for my $itm ( @$items )
      { my $val = $itm -> repr ;
        my $tim = $itm -> vtim ;
        my $err = $itm -> perr ;
        my $fit = $itm -> fit  ;
        my $url = item_url $itm -> name ;
        my $rep = $itm -> Repr ;
        my $txt_age = ( defined $tim ) ? SMA secs ( time - $tim ) : 'no_age' ;
        my $txt_err = $err ? RED "probe <i>$err</i>" : '' ;
        my $txt_fit =
          ( $fit eq 'fine'
          ? ''
          : ( defined $itm -> fitl
            ? ( SPAN $itm -> fitl -> show, 'brb' )
            : 'itm fitl undefined'
            )
          ) ;
        my $txt_url = join ' &larr; ', grep length $_
          , hist_ival_url ( $client -> hnam, $itm -> name, 'all' )
          , plot_urls ( $client, $server, $itm )
          ;
        push @trs,
          ( ( TH "$url $rep", LEFT ) 
          . ( TD $val, RGHT )
          . ( TD $txt_age, RGHT )
          . ( TD $txt_url )
          . ( $perr ? TD $txt_err : '' )
          . ( $fits ? TD $txt_fit : '' )
          ) ;
      }
    my $tab1 =
      ( @trs
      ? ( TAB $tr0 . join "\n", map { TR $_ } @trs )
      : ( SPAN "&rarr; no state received", 'brb' )
      ) ;
    my $tab2 = mk_xargs $client ;
    my $tab3 = mk_xfits $client ;
    join "<p />\n", grep length $_, $tab1, $tab2, $tab3 ;
  }

sub mk_item
  { my $item = shift ;
    my $name = $item -> name ;
    my $args = $item -> args ;
    my $dftr = $PMAKER -> work -> dftr ( $name ) ;
    my $xargs = $PMAKER -> work -> xargs_item ( $name ) ;
    my @xargs = map
      { my $host = $clients -> { $_ } ;
        my $th = $host ? $host -> show : $_ ;
        THl ( "$HARR $th" ) . TD ( $xargs -> { $_ } ) ;
      } sort by_client_show keys %$xargs ;
    my $xfits = $PMAKER -> work -> xfits_item ( $name ) ;
    my @xfits = map
      { my $host = $clients -> { $_ } ;
        my $th = $host ? $host -> show : $_ ;
        THl ( "$HARR $th" ) . TD ( quote $xfits -> { $_ } ) ;
      } sort by_client_show keys %$xfits ;
    my @trs = () ;
    push @trs,
      ( THl ( 'name'  , 'subhead' ) . TD ( $name )
      , THl ( 'kind'  , 'subhead' ) . TD ( $item -> kind )
      , THl ( 'probe' , 'subhead' ) . TD ( $item -> probe )
      , THl ( 'args'  , 'subhead' ) . TD ( join ' ', @$args )
      , @xargs
      , THl ( 'fitter', 'subhead' ) . TD ( quote $dftr )
      , @xfits
      ) ;
    TAB join "\n", map { TRx $_ } @trs ;
  }

sub mk_events_meta
  { my $secs = Util::secs4spec ( $EVNT ) ;
    my $li = 'showing ' .
      ( $EVNT =~ /^\d+$/
      ? ( $EVNT
        ? "the last $EVNT events"
        : "all events"
        )
      : ( sprintf "all events since <i>%s</i> ; %s ago"
            , lc ( scalar localtime ( time - $secs ) )
            , secs ( $secs )
        )
      ) ;
    my $hist =
      ( $event0
      ? ( sprintf 'event history starts at <i>%s</i>'
            , lc scalar localtime $event0
        )
      : 'no event history'
      ) ;
    UL join "\n", map { LI $_ } ( $li, 'show : ' . event_urls, $hist ) ;
  }

sub mk_events
  { my $full = shift ; $full = 1 unless defined $full ;
    my $many = @$events > 6 ;
    my $tr0 =
      ( $many
      ? TRx TH6 sprintf ( "%d events", scalar @$events ), 'head'
      : ''
      ) ;
    my $tr1 = TRx
      ( ( TH 'date' )
      . ( $full ? TH 'host' : '' )
      . ( $full ? TH 'item' : '' )
      . ( TH 'from' )
      . ( TH 'to' )
      . ( TH 'change' )
      , ( $many ? 'subhead' : 'head' )
      ) ;
    my @trs = () ;
    for my $event ( @$events )
      { my $host = $event -> host ;
        my $show = $host -> show ;
        my $hurl = host_url $event -> hnam, '', MENU ;
        my $name = $event -> item -> name ;
        my $iurl = item_url $name ;
        my $url1 = hist_ival_url $event -> hnam, $name, $name, MENU ;
        my $lold = $event -> lold -> show ;
        my $lnew = $event -> lnew -> show ;
        push @trs,
          ( TD ( date ( $event -> TIME ), RGHT )
          . ( $full ? TD "$hurl $show" : '' )
          . ( $full ? TD "$iurl $url1" : '' )
          . TD ( $event -> lold -> levl ? BRB $lold : GRN $lold )
          . TD ( $event -> lnew -> levl ? BRB $lnew : GRN $lnew )
          . TD ( change_txt $event )
          ) ;
      }
    ( @$events
    ? ( TAB $tr0 . $tr1 . join "\n", map { TR $_ } @trs )
    : ( RED ITA 'no events' )
    ) ;
  }

sub mk_items
  { my $tr0 = TRx
      ( ( TH 'item' )
      . ( TH 'kind' )
      . ( TH 'probe' )
      . ( TH 'args' )
      . ( TH 'default fitter' )
      , 'head'
      ) ;
    my @trs = () ;
    for my $item ( $Items -> list )
      { my $args = $item -> args ;
        my $name = $item -> name ;
        my $dftr = $PMAKER -> work -> dftr ( $name ) ;
        my $iurl = item_url $name ;
        push @trs,
          ( TH ( "$iurl $name", LEFT ) 
          . TD ( $item -> kind )
          . TD ( $item -> probe )
          . TD ( join ' ', @$args )
          . TD ( quote $dftr )
          ) ;
      }
    TAB $tr0 . join "\n", map { TR $_ } @trs ;
  }

sub mk_items1
  { my @list = $Items -> list ;
    my $cnt  = scalar @list ;
    my $tr0  = TRx
      ( ( TH "items [$cnt]" )
      . ( TH 'history' )
      , 'head'
      ) ;
    my @trs = () ;
    for my $item ( @list )
      { my $name = $item -> name ;
        my $iurl = item_url $name ;
        push @trs,
          ( TH ( "$iurl $name", LEFT ) 
          . TD ( hist_item_urls $name )
          ) ;
      }
    TAB $tr0 . join "\n", map { TR $_ } @trs ;
  }

sub mk_snmps
  { my $tr0 = TRx
      ( ( TH 'item' )
      . ( TH 'description' )
      . ( TH 'snmp tag' )
      , 'head'
      ) ;
    my @trs = () ;
    my $snmps = Items -> SNMPS ;
    for my $name ( sort keys %$snmps )
      { my $dscr = $snmps -> { $name } [ 0 ] ;
        my $stag = $snmps -> { $name } [ 1 ] ;
        push @trs,
          ( TH ( $name, LEFT ) 
          . TD ( $dscr )
          . TD ( $stag )
          ) ;
      }
    TAB $tr0 . join "\n", map { TR $_ } @trs ;
  }

sub mk_levels
  { my $tr0 = TRx
      ( ( TH 'level' )
      . ( TH 'name' )
      . ( TH 'show' )
      , 'head'
      ) ;
    my @trs = () ;
    my $lvls = $PMAKER -> levels ;
    for my $lvl ( @$lvls )
      { push @trs,
          ( TH  ( $lvl -> levl ) 
          . TDc ( CODE $lvl -> name )
          . TD  ( SPAN $lvl -> show, 'brb' )
          ) ;
      }
    TAB $tr0 . join "\n", map { TR $_ } @trs ;
  }

sub mk_kinds
  { my $tr0 = TRx
      ( ( TH 'kind' )
      . ( TH 'description' )
      . ( TH 'value <i>X</i>' )
      . ( TH 'shown as' )
      , 'head'
      ) ;
    my @trs  = () ;
    my $list = $Kinds -> list ;
    for my $kind ( sort @$list )
      { push @trs ,
          ( THl ( $kind, 'subhead' )
          . TD ( $Kinds -> $kind -> dscr )
          . TD ( $Kinds -> $kind -> stor )
          . TD ( $Kinds -> $kind -> show . ' ' . $Kinds -> $kind -> suff )
          ) ;
      }
    TAB $tr0 . join "\n", map { TR $_ } @trs ;
  }

sub mk_acks
  { my $tr0 = TRx
      ( ( TH 'host' )
      . ( TH 'problem' )
      . ( TH 'hide-level' )
      . ( TH 'user' )
      . ( TH 'date' )
      . ( XTRA ? TH 'click' : '' )
      , 'head'
      ) ;
    my @trs = () ;
    my $flds = 'hnam, item, levl, user, TIME' ;
    my $recs = $DBS -> select ( ACKStab, cols => $flds, order_by => $flds ) ;
    for my $rec ( @$recs )
      { my $href = nack_hrf ( $rec -> [ 0 ], $rec -> [ 1 ] ) ;
        my ( $hnam, $name, $levl, $user, $time ) = @$rec ;
        my $host = $clients -> { $hnam } ;
        my $htxt = $hnam ;
        my $ptxt = SPAN 'host not found', 'brb' ;
        my $utag = 'delete' ;
        if ( $host )
          { my $hurl = host_url $hnam, '', MENU ;
            my $show = $host -> show ;
            $htxt = "$hurl $show" ;
            $ptxt = BRB "no item <i>$name</i>" ;
            my $item = $host -> state -> by_name ( $name ) ; 
            if ( $item )
              { $ptxt = prob_txt ( $item, $hnam ) ;
                $utag = 'show problem ' if $item -> levl ;
              }
          }
        my $fitl = $PMAKER -> levels -> [ $levl ] ;
        my $ltxt = BRB $fitl ? $fitl -> show : "no levl $levl" ;
        my $ttxt = scalar localtime $time ;
        push @trs,
          ( ( join '', THl ( $htxt )
                , map { TD  $_ } ( $ptxt, $ltxt, $user, $ttxt ) )
          . ( XTRA ? TD URL $href, $utag, MENU : '' )
          ) ;
      }
    TAB $tr0 . join "\n", map { TR $_ } @trs ;
  }

sub mk_meta
  { my $cnt_itms = 0 ;
    my $cnt_fits = 0 ;
    for my $client ( sort by_show values %$clients )
      { my $items = $client -> state -> items ;
        my $hnam  = $client -> hnam ;
        $cnt_itms += scalar @$items ;
        $cnt_fits += scalar grep
          { $PMAKER -> work -> hftr ( $hnam, $_ -> name ) } @$items ;
      }
    my $prc =
      ( $cnt_itms
      ? ( sprintf '(%d%%)', int 100 * $cnt_fits / $cnt_itms )
      : ''
      ) ;
    my %tab =
      ( version  => Dmon::Version
      , secr_md5 => Util::md5_text ( $SECRET )
      , page_sec => $conf -> page_sec
      , cookie   => cookie ( COOKIE ) || 'no cookie'
      , fitrs    => "$cnt_fits out of $cnt_itms items have a fitter $prc"
      , cgidata  => $conf -> cgidata
      , cgi_pmkr => $conf -> dbs_pmkr
      , log_pmkr => $conf -> log_pmkr
      , noalrt   => ( $PMAKER -> noalrt ? "don't " : '' ) . 'send alerts'
      ) ;
    TAB join '', map { TRx ( THl ( $_, 'head' ) . TD $tab { $_ } ) ; }
      sort keys %tab ;
  }

sub list_any { my $x = shift ; ( join ' ', @$x ) || '<i>ANY</i>' ; }

sub mk_alerts
  { my $alerts =
      [ map { Alert -> Make ( %$_ ) } @{ $PMAKER -> work -> alerts } ] ;
    my $tr0 = TRx
      ( ( TH 'users'  )
      . ( TH 'level1' )
      . ( TH 'level2' )
      . ( TH 'hosts'  )
      . ( TH 'items'  )
      , 'head'
      ) ;
    my @trs = () ;
    for my $alert ( @$alerts )
      { my $users = list_any $alert -> users ;
        my $hosts = list_any $alert -> hosts ;
        my $items = list_any $alert -> items ;
        my $levl1 = list_any
          [ map { $PMAKER -> levels -> [ $_ ] -> show }
              @{ $alert -> levl1 }
          ] ;
        my $levl2 = list_any
          [ map { $PMAKER -> levels -> [ $_ ] -> show }
              @{ $alert -> levl2 }
          ] ;
        push @trs, TRx
          ( TD ( $users )
          . TD ( $levl1 )
          . TD ( $levl2 )
          . TD ( $hosts )
          . TD ( $items )
          ) ;
#       printf "users [$users] hosts [$hosts] items [$items]\n" ;
#       printf "  levl1 [$levl1] levl2 [$levl2]\n" ;
      }
#   TAB $tr0 . join "\n", map { TR $_ } @trs ;
    TAB join "\n", $tr0, @trs ;
  }

sub NAV
  { my $conf = shift ;
    my $bare = shift || '' ;
    my $serv = $conf -> server ;
    my $url  = URL "#host.$serv", 'server' ;
    my @urls =
      ( $bare
      ? ( home_url )
      : ( URL ( '#head.Evnts' , 'events'  )
        , URL ( '#head.Oview' , 'overview' )
        , URL ( '#head.Acked' , 'hidden'  )
        , $url
        , URL ( '#head.Client', 'clients' )
        , URL ( '#head.Levls' , 'levels'  )
        , URL ( '#head.Kinds' , 'kinds'   )
        , URL ( '#head.Items' , 'items'   )
        , URL ( '#head.Alrts' , 'alerts'  )
        , URL ( '#head.Meta'  , 'meta'    )
        )
      ) ;
    my $attr = 'border="0" cellpadding="5" ' ;
    my $tabl = TABA $attr . 'style="float:left"'
      , TRx join "\n",  map { TH $_ } @urls ;
    my $in  = URL $conf -> page_sec . '?login=1', ITA 'login' ;
    my $out = URL $conf -> page_sec . '?logout=1', ITA 'logout' ;
    my $prf = URL $conf -> page_sec . '?PREF=1', 'prefs' ;
    my $tabr = TABA $attr . 'style="float:right"'
      , TRx
          ( XTRA
          ? ( ( TH $bare eq 'pref' ? $bare : $prf )
            . ( TH "$USER $out" )
            )
          : TH $in
          )
      ;
    DIV $tabl . $tabr . "<br clear=\"all\"/>", 'menubox' ;
  }

sub main_page
  { print NAV $conf ;
    print logo . "\n" ;
    print H2 $VNAME ;

    if ( my $usr = $PMAKER -> noalrt )
      { print UL LI BRB 'The server is <i>not</i> sending alerts ; '
          . "disabled by <i>$usr</i>." ;
      }

    print H3 'Problems' ;
    print BQ mk_summary ;

    print TOP, H3A 'id="head.Evnts"', 'Events' ;
    print mk_events_meta ;
    print BQ mk_events ;

    print TOP, H3A 'id="head.Oview"', 'Overview' ;
    print '<blockquote><div class="left0">', "\n" ;
    print mk_clients ;
    print "</div>\n" ;
    print '<div class="left1">', "\n" ;
    print mk_items1 ;
    print "</div></blockquote>\n" ;
    print '<br clear="all"/>', "\n" ;

    print TOP, H3A 'id="head.Acked"', 'Hidden problems' ;
    print BQ mk_acks ;

    print TOP, H3A 'id="head.Client"', 'clients' ;
    for my $client ( sort by_show values %$clients )
      { my $hnam = $client -> hnam ;
        my $show = $client -> show ;
        my $wrkr = $client -> wrkr ;
        my $tit  = $show eq $hnam ? $show : "$show ; $hnam" ;
        my $tim_last = $client -> t_state ;
        my $txt_last = sprintf 'last received : %s',
          ( $tim_last ? scalar localtime $tim_last : NO_RECV ) ;
        my $wshw = $PMAKER -> show_hnam ( $wrkr ) if $wrkr ;
        my $txt_wrkr = ( $wrkr and $wrkr ne $wshw ) ? "$wshw ($wrkr)" : $wrkr ;
        my $hst_urls = hist_host_urls $hnam ;
        print TOP, H4A "id=\"host.$hnam\"", $tit ;
        print UL
          ( ( LI $txt_last )
          . ( $wrkr ? LI "from : $txt_wrkr" : '' )
          . ( LI "host history &rarr; $hst_urls" )
          ) ;
        print BQ mk_client $client ;
      }

    print TOP, H3A 'id="head.Levls"', 'Fitness levels' ;
    print BQ mk_levels ;

    print TOP, H3A 'id="head.Kinds"', 'Kinds' ;
    print "Each item has an attribute <i>kind</i> ;\n" ;
    print "It describes how values are stored, communicated and shown.\n" ;
    print BQ mk_kinds ;

    print TOP, H3A 'id="head.Items"', 'Items overview' ;
    print BQ ( mk_items ) ;
    print BQ H4 ( 'SNMP descriptions' ) . BQ mk_snmps ;

    print TOP, H3 ( 'item descriptions' ) ;
    for my $item ( $Items -> list )
      { my $name = $item -> name ;
        my $itm_urls = hist_item_urls $name ;
        print TOP, H4A "id=\"item.$name\"", "item <i>$name</i>" ;
        print UL LI "item history &rarr; $itm_urls" if $itm_urls ;
        print BQ mk_item $item ;
      }

    print TOP, H3A 'id="head.Alrts"', 'Alerts' ;
    print "Notify <i>users</i> on a fitness-change from \n" ;
    print "<i>level1</i> to <i>level2</i>, or vice-versa.\n" ;
    print BQ mk_alerts ;

    print TOP, H3A 'id="head.Meta"', 'Meta' ;

    print BQ mk_meta ;

    print TAIL ;
  }

sub item_page
  { my $ITEM = shift ;
    my $IVAL = shift ;
    my $item = $Items -> hash -> { $ITEM } ;
    my $name = $item -> name ;
    my @clnts = grep { has_item $_, $ITEM } values %$clients ;
    ERR "no item <i>$ITEM</i> (ival '$IVAL')" unless $item ;
    ERR "no clients for item <i>$ITEM</i> (ival '$IVAL')" unless @clnts ;
    print NAV $conf, 'home' ;
    print logo . "\n" ;
    print H2 "$VNAME : $name" ;
    print BQ sprintf "$ITEM &rarr; %s", hist_item_urls $ITEM ;
    print H3 "history item <i>$ITEM</i>" ;
    my $dftr = $PMAKER -> work -> dftr ( $name ) ;
    print UL LI quote $dftr if $dftr ;
    for my $client ( sort by_show @clnts )
      { my $hnam = $client -> hnam ;
        my $show = $client -> show ;
        my $tit  = $show eq $hnam ? $show : "$show ; $hnam" ;
        my $img  = sprintf '<img src="%s" alt="ALT"/>' . "\n",
          ( plot_ref $client, $server, $item, $IVAL ) [ 0 ] ;
        print H4A "id=\"host.$hnam\"", $tit ;
        print BQ hist_ival_url $hnam, $name, $img ;
      }
    print TAIL ;
  }

sub host_page
  { my $HOST = shift ;
    my $IVAL = shift ;
    my $client = ( grep { $_ -> hnam eq $HOST } values %$clients ) [ 0 ] ;
    ERR "no client <i>$HOST</i> (ival '$IVAL')" unless $client ;
    my $show  = $client -> show ;
    my $items = $client -> state -> items ;
    ERR "no items for <i>$HOST</i>" unless @$items ;
    print NAV $conf, 'home' ;
    print logo . "\n" ;
    print H2 "$VNAME - $show ; $HOST" ;
    print BQ sprintf "$show &rarr; %s", hist_host_urls ( $HOST ) ;
    print H3 "host <i>$show ; $HOST</i>" ;
    print BQ mk_client $client ;
    print H3 "history host <i>$show</i>" ;
    for my $item ( @$items )
      { my $name = $item -> name ;
        my $hftr = $PMAKER -> work -> hftr ( $HOST, $name ) ;
        my $img  = sprintf '<img src="%s" alt="ALT"/>' . "\n",
          ( plot_ref $client, $server, $item, $IVAL ) [ 0 ] ;
        print H4A "id=\"item.$name\"", "item <i>$name</i>" ;
        print UL LI quote $hftr if $hftr ;
        print BQ hist_ival_url $HOST, $name, $img ;
      }
    print TAIL ;
  }

sub ival_page
  { my $HOST = shift ;
    my $ITEM = shift ;
    my $client = ( grep { $_ -> hnam eq $HOST } values %$clients ) [ 0 ] ;
    ERR "no client <i>$HOST</i>" unless $client ;
    my $show = $client -> show ;
    my $item = $Items -> hash -> { $ITEM } ;
    ERR "no item <i>$ITEM</i>" unless $item ;
    my $name = $item -> name ;
    print NAV $conf, 'home' ;
    print logo . "\n" ;
    print H2 "$VNAME : $show &rarr; $name" ;
    my $hftr = $PMAKER -> work -> hftr ( $HOST, $name ) ;
    my $xarg = $PMAKER -> work -> xargs -> { $HOST } { $item -> name } ;
    my $iarg = $item -> args ;
    my $itm_urls = hist_item_urls $ITEM ;
    my $hst_urls = hist_host_urls $HOST ;
    my $host_url = host_url_abs $HOST ;
    print UL 
      ( ( $hftr ? LI 'fitter : ' . quote $hftr : '' )
      . ( $xarg ? LI 'probe with : ' . "@$xarg ; default : @$iarg" : '' )
      . ( LI "<i>$ITEM</i> on other servers &rarr; $itm_urls" )
      . ( LI "<I>$show</i> history &rarr; $hst_urls" )
      . ( LI "<I>$show</i> = $host_url" )
      ) ;
    print '<div class="left0">', "\n" ;
    for my $ival ( @IVALS )
      { print H4 sprintf "%s &rarr; %s &larr; %s"
          , $show, $item -> name, $ival ;
        print BQ sprintf '<img src="%s" alt="%s"/>' . "\n",
          plot_ref $client, $server, $item, $ival ;
      }
    print "</div>\n" ;
    if ( @$events )
      { print '<div class="left0">', "\n" ;
         print H3 "events $show &rarr; $name" ;
         print UL LI sprintf "events since <i>%s</i>"
           , lc scalar localtime $event0 if $event0 ;
         print BQ mk_events 0 ;
         print "</div>\n" ;
      }
    print '<br clear="all"/>', "\n" ;
    print TAIL ;
  }

sub checksum { Util::md5_text ( $_[0] . $SECRET ) ; }

sub dmon_cookie 
  { my $data = $USER || '' ;
    cookie
      ( -name  => COOKIE
      , -value => ( join ';', $data, checksum $data )
      , -httponly => 1
      ) ;
  }

sub check_cookie
  { my $cookie = cookie ( COOKIE ) || return 0 ;
    my ( $user, $check ) = split /;/, $cookie, 2 ;
    my $data = $user || '' ;
    my $res = ( $user and $check and $check eq checksum $data ) ;
    if ( $res ) { $USER = $user ; }
    $res ;
  }

sub dmon_redirect
  { my $dest = shift ;
    print redirect
      ( -uri    => $dest
      , -status => 303
      , -cookie => dmon_cookie
      ) ;
    exit ;
  }

sub login_form
  { my $name = textfield
      ( -name      => 'USER'
      , -value     => ''
      , -size      => 20
      , -maxlength => 20
      ) ;

    my $pswd = password_field
      ( -name      => 'PSWD'
      , -value     => ''
      , -size      => 20
      , -maxlength => 20
      ) ;

    my $submit = submit ( -name => 'login', -value => 'click' ) ;
    my $reset  = reset ;

    my $sub = "class='subhead'" ;
    my $tab = BQ <<TAB ;
<table cellpadding=2 cellspacing=2 border=2>
<tr><th class="head">user</th><td $sub>$name</td></tr>
<tr><th class="head">password</th><td $sub>$pswd</td></tr>
<tr><th class="head"></th><th $sub>$submit $reset</th></tr>
</table>
TAB
    start_form . $tab . end_form ;
  }

sub set_pw
  { my $pswd = shift ;
    my $abc  = join '', 'a' .. 'z' ;
    my $salt = join '', map { substr $abc, ( int rand 26 ), 1 ; } 1 .. 2 ;
    my $crpt = crypt $pswd, $salt ;
    my $hash = $DBS -> select1_hash ( USERtab, where => "user = '$USER'" ) ;
    $hash -> { pswd } = $crpt ;
    $hash -> { TIME } = time  ;
    $DBS -> delete ( USERtab , where => "user = '$USER'" ) ;
    $DBS -> save_hash ( USERtab, $hash ) ;
  }

sub get_pw
  { my $user = shift ;
    my $pswd = shift ;
    my $recs = 
      $DBS -> select ( USERtab, cols => 'pswd', where => "user = '$user'" ) ;
    @$recs ? $recs -> [ 0 ] [ 0 ] : undef ;
  }

sub vrfy
  { my $user = shift ;
    my $pswd = shift ;
    my $crpt = get_pw $user ;
    if ( defined $crpt and length $crpt )
      { add_log "verify $user [$crpt]" ;
        $crpt eq crypt $pswd, substr $crpt, 0, 2 ;
      }
    else
      { add_log "can't verify $user" ; 0 ; }
  }

sub check_login
  { my $err  = '' ;
    if ( check_cookie )
      { if ( param 'logout' )
          { add_log 'logout' ;
            $USER = ''  ;
            dmon_redirect $conf -> page_sec ;
          }
      }
    elsif ( defined param 'login' )
      { my $user = param ( 'USER' ) || '' ;
        my $pswd = param ( 'PSWD' ) || 'no_pswd' ;
        if ( $user and vrfy $user, $pswd )
          { $USER = $user ; add_log 'login' ;
            dmon_redirect $conf -> page_sec ;
          }
        elsif ( $user )
          { $err = "error : bad login ($user)" ; add_log $err ; }
        else
          { $err = 'please login' ; }
      }

    if ( $err )
      { print HEAD ;
        print logo ;
        print H4 $err if $err ;
        print login_form ;
        print TAIL ;
        exit ;
      }
  }

sub pref_page
  { ERR "no user" unless $USER ;
    my ( $SUBM, $DOPW, $NEWP, $OLDP ) = @_ ;
    my $oldp = password_field
      ( -name      => 'OLDP'
      , -value     => ''
      , -size      => 20
      , -maxlength => 20
      ) ;
    my $newp = password_field
      ( -name      => 'NEWP'
      , -value     => ''
      , -size      => 20
      , -maxlength => 20
      ) ;

    my $submit = submit ( -name => 'DOPW', -value => 'submit' ) ;
    my $cancel = submit ( -name => 'QUIT', -value => 'cancel' ) ;
    my $hidden = hidden ( 'PREF', 1 ) ;
    my $reset  = reset  ( -value => 'reset' ) ;
    my $sub    = "class='subhead'" ;
    my $pswd_form = BQ <<TAB ;
<table cellpadding=2 cellspacing=2 border=2>
<tr><th class="head">old password</th><td $sub>$oldp</td></tr>
<tr><th class="head">new password</th><td $sub>$newp</td></tr>
<tr><th class="head"></th><th $sub>$hidden $submit $reset $cancel</th></tr>
</table>
TAB
    add_log "DOPW [$DOPW] SUBM [$SUBM]" ;
    if ( $DOPW )
      { ERR "no old password" unless defined $OLDP and length $OLDP ;
        ERR "no new password" unless defined $NEWP and length $NEWP ;
        if ( vrfy $USER, $OLDP )
          { add_log "set pw $USER " ;
            set_pw $NEWP ;
            dmon_redirect $conf -> page_sec ;
          }
        else
          { ERR "can't vrfy $USER" ; }
      }

    if ( $SUBM )
      { my $hash = $DBS -> select1_hash ( USERtab, where => "user = '$USER'" ) ;
        my $tops = $hash -> { tops } = $q -> param ( 'TOPS' ) ? 1 : 0 ;
        $DBS -> delete ( USERtab , where => "user = '$USER'" ) ;
        $DBS -> save_hash ( USERtab, $hash ) ;
        add_log "set $USER tops $tops" ;
      }
    my $alert_mesg = '' ;
    if ( $ALRT )
      { my $noal = $q -> param ( 'DOALRT' ) ? 0 : 1 ;
        add_log "set noalrt $noal $USER" ;
        my $msg = sprintf "NO_ALRT %s", ( $noal ? $USER : 0 ) ;
        my $res = $PMAKER -> send_server_sync ( $msg, 'Dmon::Mesg::JSON' ) ;
        $PMAKER -> noalrt ( $noal ? $USER : 0 ) ;
        $alert_mesg = join '', @{ $res -> { lines } } ;
      }

    get_prefs $DBS ;
    my $tops = $UPRF -> { tops } ;
    my $subprf = submit ( -name => 'SUBM', -value => 'submit' ) ;
    my $topbox = checkbox
      ( -name => 'TOPS'
      , -checked => $tops
      , -label   => 'show top-of-page links'
      ) ;
    my $pref_form = BQ <<TAB ;
<table cellpadding=2 cellspacing=2 border=2>
<tr><th $sub>$topbox</td></tr>
<tr><th $sub>$hidden $subprf $reset $cancel</th></tr>
</table>
TAB

    my $alerts  = $PMAKER -> noalrt ? 0 : 1 ;
    my $subalrt = submit ( -name => 'ALRT', -value => 'submit' ) ;
    my $boxalrt = checkbox
      ( -name => 'DOALRT'
      , -checked => $alerts
      , -label   => 'send alerts'
      ) ;
    my $alrt_form = BQ <<TAB ;
<table cellpadding=2 cellspacing=2 border=2>
<tr><th $sub>$boxalrt</td></tr>
<tr><th $sub>$hidden $subalrt $reset $cancel</th></tr>
</table>
TAB

    print HEAD 'preferences' ;
    print NAV $conf, 'pref' ;
    print logo . "\n" ;
    print H2 "$VNAME - preferences" ;
    print H4 "change password <i>$USER</i>" ;
    print start_form . $pswd_form . end_form ;
    print TOP, H4 "set preferences <i>$USER</i>" ;
    print start_form . $pref_form . end_form ;
    print TOP, H4 "set send alerts ; system</i>" ;
    printf UL LI $alert_mesg if $alert_mesg ;
    print start_form . $alrt_form . end_form ;
    print TAIL ;
    exit ;
  }

check_login ;
get_prefs $DBS ;

if ( $ACKR or $NACK )
  { ERR "not authorised" unless $USER ;
    if ( $ACKR )
      { add_ack $DBS, $HOST, $ITEM, $LEVL ;
        add_log "add_ack $HOST $ITEM" ;
      }
    else
      { del_ack $DBS, $HOST, $ITEM ;
        add_log "del_ack $HOST $ITEM" ;
      }
    dmon_redirect $conf -> page_sec ;
  }
elsif ( $PREF and not $QUIT )
  { pref_page $SUBM, $DOPW, $NEWP, $OLDP ; }

print HEAD ;

if ( $HOST and $ITEM )
  { ival_page $HOST, $ITEM ; }
elsif ( $HOST )
  { host_page $HOST, $IVAL ; }
elsif ( $ITEM )
  { item_page $ITEM, $IVAL ; }
else
  { main_page ; }
__END__
=pod

=head1 NAME

  gen-dmon-page - generate dmon report pages

=head1 SYNOPSIS

  Usage: gen-dmon-page [-v] [-q] [-d] [-h] [-c file]
  option v : be verbose
  option q : be quiet
  option d : show debug info
  option h : show help ; exit
  option c : use config <file> ;
             default [ dmon.conf, /etc/dmon/conf ]
  

=head1 DESCRIPTION

CGI-script B<gen-dmon-page> generates B<dmon> report pages.

Program B<gen-dmon-page> recognises the following parameters :

=over 4

=item * HOST

a hostname ; if specified, an overview page for I<HOST> is shown,
containing host-item-plots for some interval (default I<hour>)
for all items the host monitors.

The host-item-plots are clickable and refer to a host-item-page,
containing host-item-plots for all intervals.

=item * ITEM

an item-name ; if specified, an overview page for I<ITEM> is shown,
containing host-item-plots for some interval (default I<hour>)
for all hosts monitoring the item.

The host-item-plots are clickable and refer to a host-item-page.

=item * IVAL

an interval ; hour, day, week, month, year.

=back

If/when no parameters are specified, B<gen-dmon-page> shows a page
containing overviews and details of all (current) problems,
(recent) events, hosts, items etc.

Program B<gen-dmon-page> retrieves client-data from the server with
a C<CLIENTS> command.

The pagemaker work-file for B<gen-dmon-page> contains static information :
default and per/host probe arguments,
default and per/host fitness functions. 

=head1 SEE ALSO

L<dmon|http://dmon.science.uu.nl/dist/dmon.html>, L<users-dmon|http://dmon.science.uu.nl/dist/users-dmon.html>, L<plotter|http://dmon.science.uu.nl/dist/plotter.html>

=head1 LICENSE

You may distribute under the terms of either the GNU General Public
License or the Artistic License, as specified in the Perl 5.10.0 README
file.

=head1 AUTHOR

=for html gen-dmon-page &copy; 2015-2016
<a href="http://www.staff.science.uu.nl/~penni101">Henk P. Penning</a>
- All rights reserved
; dmon-0.05-p214 - Thu Oct 13 17:38:40 2016

=for man Henk P. Penning, <http://www.staff.science.uu.nl/~penni101> ;
dmon-0.05-p214 - Thu Oct 13 17:38:40 2016


=cut