#!/usr/bin/perl
# $Id: index.cgi 672 2011-11-18 23:37:35Z pro $ $URL: svn://svn.setun.net/lan/trunk/pinger/index.cgi $

=head1 usage

create file named "list":
> touch list

add to file "list" your hosts line-by-line:

==

microsoft.com http desc=bill%20sux
google.com ssh

 ya.ru 80
  yandex.ru mail=admin@yandex.ru
www.ru

#commented.host
#spaces before host - level for hiding
==

=INSTALL

portmaster p5-MIME-Lite
or
cpan MIME::Lite

=todo

custom refresh (cookie)

=cut

our $VERSION = '0.00' . '.' . ( split( ' ', '$Revision: 672 $' ) )[1];
use strict;
use Time::HiRes qw(time);
use Net::Ping;
use Data::Dumper;
$Data::Dumper::Useqq = $Data::Dumper::SortKeys = $Data::Dumper::Indent = $Data::Dumper::Terse = 1;
our %config = (
  charset   => 'utf8',
  list_file => 'list',
  timeout   => 1,
  refresh   => 300,
  tries     => 3,
  custom    => 1,
  port      => 'http',
  list_save => 'list_saved',
  list_old  => 600,
  hide_port => 1,
  dir_save  => './',
  #list_old  => 10,
  mail => 'root@localhost',
);
my ( %logs, $logto );

sub use_try ($;@) {
  ( my $path = ( my $module = shift ) . '.pm' ) =~ s{::}{/}g;
  $INC{$path} or eval 'use ' . $module . ' qw(' . ( join ' ', @_ ) . ');1;' and $INC{$path};
}

sub get_params_one(@) {    # p=x,p=y,p=z => p=x,p1=y,p2=z ; p>=z => p=z, p_mode='>'; p => p; -p => -p=1;
  local %_ = %{ ref $_[0] eq 'HASH' ? shift : {} };
  for (@_) {               # PERL RULEZ # SORRY # 8-) #
    tr/+/ /, s/%([a-f\d]{2})/pack 'C', hex $1/gei for my ( $k, $v ) = /^([^=]+=?)=(.+)$/ ? ( $1, $2 ) : ( /^([^=]*)=?$/, /^-/ );
    $_{"${1}_mode$2"} .= $3 if $k =~ s/^(.+?)(\d*)([=!><~@]+)$/$1$2/;
    $k =~ s/(\d*)$/($1 < 100 ? $1 + 1 : last)/e while defined $_{$k};
    $_{$k} = $v;           #lc can be here
  }
  wantarray ? %_ : \%_;
}

sub get_params(;$$) {      #v6
  my ( $par_string, $delim ) = @_;
  $delim ||= '&';
  local %_;
  read( STDIN, local $_ = '', $ENV{'CONTENT_LENGTH'} )
    if !$par_string and $ENV{'CONTENT_LENGTH'};
  %_ = (
    %_,
    $par_string
    ? ( get_params_one( undef, split( $delim, $par_string ) ) )
    : (
      get_params_one( undef, @ARGV ), map { get_params_one( undef, split $delim, $_ ) }
        split( /;\s*/, $ENV{'HTTP_COOKIE'} ),
      $ENV{'QUERY_STRING'}, $_
    )
  );
  return wantarray ? %_ : \%_;
}
sub is_array ($) { UNIVERSAL::isa( $_[0], 'ARRAY' ) }
sub is_array_size ($) { is_array( $_[0] ) and @{ $_[0] } }
sub is_hash ($) { UNIVERSAL::isa( $_[0], 'HASH' ) }
sub is_hash_size ($) { is_hash( $_[0] ) and %{ $_[0] } }
sub is_code ($) { UNIVERSAL::isa( $_[0], 'CODE' ) }
sub code_run ($;@) { my $f = shift; return $f->(@_) if is_code $f }

sub array (@) {
  local @_ = map { is_array $_ ? @$_ : $_ } @_;
  wantarray ? @_ : \@_;
}

sub array_any (@) {
  local @_ = map { is_array $_ ? @$_ : is_hash $_ ? sort keys %$_ : is_code $_ ? $_->() : $_ } @_;
  wantarray ? @_ : \@_;
}

sub loadlist {
  my %res   = ();
  my $order = 0;
  for my $sca (@_) {
    next unless $sca;
    open( SSF, '<', $sca ) or next;
    while (<SSF>) {
      next if /^\s*[#;]/;
      my $level = 0;
      ++$level while s/^\s//;
      local @_ = split /\s+/, $_;
      my $host = shift or next;
      $res{$host}{param} = get_params_one(@_);
      $res{$host}{order} = ++$order;
      $res{$host}{level} = $level;
    }
    close(SSF);
  }
  return wantarray ? %res : \%res;
}

sub flush(;$) {
  return if $config{'no_flush'};
  select( ( select( $_[0] || *STDOUT ), $| = 1 )[0] );
}

sub float ($) {    #v1
  return ( $_[0] < 8 and $_[0] - int( $_[0] ) )
    ? sprintf( '%.' . ( $_[0] < 1 ? 3 : ( $_[0] < 3 ? 2 : 1 ) ) . 'f', $_[0] )
    : int( $_[0] );
}
{
  my %fh;
  my $savetime = 0;

  sub file_append(;$@) {
    local $_ = shift;
    for ( defined $_ ? $_ : keys %fh ) {
      close( $fh{$_} ), delete( $fh{$_} ) if $fh{$_} and !@_;
    }
    return if !@_;
    unless ( $fh{$_} ) {
      return unless open $fh{$_}, '>>', $_;
      return unless $fh{$_};
    }
    print { $fh{$_} } @_;
    if ( time() > $savetime + 5 ) {
      close( $fh{$_} ), delete( $fh{$_} ) for keys %fh;
      $savetime = time();
    }
    return @_;
  }
  END { close( $fh{$_} ) for keys %fh; }
}

sub file_rewrite(;$@) {
  unlink $_[0] if $_[0];    #|| return;
  return &file_append, file_append();
}

sub file_read_ref ($) {
  open my $f, '<', $_[0] or return;
  local $/ = undef;
  my $ret = <$f>;
  close $f;
  return \$ret;
}
my $param = get_params;

sub c ($) {
  return exists $param->{ $_[0] } ? $param->{ $_[0] } : $config{ $_[0] };
}
$config{html} = $ENV{SERVER_PORT};
if ( ( $config{custom} and $param->{list} ) ) {
  $config{list_user} = 1;
} else {
  #$config{save} = !$ENV{SERVER_PORT};
  #$config{load} = !$config{save};
  $config{load} = 1 if $ENV{SERVER_PORT} and !c 'force';
}
do 'config.pl';
sub html (@) { return unless c 'html'; print @_; }
sub console (@) { return if c 'html'; print @_, "\n"; }
sub nl () { html "<br/>"; console; }
sub printlog (@) { print join ' ', @_; nl; }

sub print_result ($) {
  my $i = shift;
  if ( c 'debug' or c 'console' ) {
    print qq{PING $i->{ip}: };
    print "icmp_seq=$i->{try} " if $i->{try} > 1;
    print "port=$i->{port} " if $i->{port};
    if   ( $i->{res} ) { print qq{time=$i->{time} } }
    else               { print c 'load' ? $i->{report} : '* '; }
    console;
  }
  html qq{<script type="text/javascript">};
  if ( $i->{res} ) {
    html qq{gid('ip_desc_$i->{ip}').style.background = '#99FF99';};
    html qq{gid('ip_desc_$i->{ip}').innerHTML += '$i->{time}';}
      if !c 'list_loaded';
  } else {
    html qq{gid('ip_desc_$i->{ip}').style.background = '#FF3333';};
    html qq{gid('ip_desc_$i->{ip}').innerHTML += '* ';}
      if !c 'list_loaded';
  }
  html "</script>";
  html "<br/>" if c 'debug';
  flush;
}
html
  qq{Content-type: text/html; charset=$config{charset}\nCache-Control: no-cache\nRefresh: },
  c 'refresh', qq{\n\n};
my $list = loadlist( $config{list_file} ) if !defined c 'only';
if ( $config{custom} ) { $list->{$_} = {} for split /[,\s]+/, $param->{list}; }
$list = {'127.0.0.1'} unless %{ $list || {} };
#if ( c 'load' ) {
#print join ' : ',-M c 'list_save' , -M c 'list_file', c 'list_save' , c 'list_file';#, ( time() - $^T + 86400 * -M c 'list_save' ), c('list_old');
#$_ = ;
#print "r[$$_]";
if ( c('list_old') > ( time() - $^T + 86400 * -M c('dir_save') . c('list_save') )
  and -M c('dir_save') . c('list_save') < -M c 'list_file' )
{
  #print 'tryload';
  html 'scanned ', 86400 * -M c('dir_save') . c('list_save'), 's ago<br/>' if c 'load';
  my $llist = eval ${ file_read_ref c('dir_save') . c('list_save') or \'' } || {};    #'
                                                                                      #warn $@;
                                                                                      #warn "loaded", Dumper $llist, $list;
  if (%$llist) {
    $config{list_loaded} = 1 if c 'load';
    #my $mylist = {%$list};
    my $mylist = $list;
    $list = {};
    for my $ip ( keys %$mylist ) {
      $list->{$ip} = $llist->{$ip};
      $list->{$ip}{$_} = $mylist->{$ip}{$_} for keys %{ $mylist->{$ip} || {} };
    }
  }
  #print_result $i;
  #} else {
  #$config{save} = 1;
}
#}
my @list_ordered =
  sort { $list->{$a}{order} <=> $list->{$b}{order} } keys %$list;
#	<script type="text/javascript" src="js.js"></script>
#<link rel="stylesheet" type="text/css" href="css.css" />
html qq{<?xml version="1.0"?><html xmlns="http://www.w3.org/1999/xhtml"><head>

<script>
function gid(a) {
  if (typeof a == 'object') return a;
  return document.getElementById(a) || {};
};
</script>
<style>

table {
border-collapse:collapse;
}

table * {
border:1px solid gray;
}

</style>

  <title>Pinger</title>
</head><body><table>};
my %p;
++$p{$_} for qw(desc port);
my $level_last = 0;
if ( !$config{list_loaded} ) {
  $_->{res_prev} = $_->{res}, delete $_->{res}, delete $_->{report} for values %$list;
}
for my $ip (@list_ordered) {
  my $i = $list->{$ip};
  next if c 'lite' and $i->{res};
  next if defined c 'level' and $i->{level} > c 'level' and $i->{res};
  $i->{port} ||= $i->{param}{port} || ( grep { $_ and !$p{$_} } keys %{ $i->{param} || {} } )[0];
  html qq{<tr><td>}, qq{.} x $i->{level}, qq{-</td><td>$ip},
    ( $i->{port} && !c 'hide_port' ? ":$i->{port}" : '' ),
    qq{</td><td id="ip_desc_$ip">$i->{report}</td><td>$i->{param}{desc}</td></tr>};
  $level_last = $i->{level};
}
html qq{</table><br/><div id="stat"></div><br/>};
flush;
my $reset = $ENV{REQUEST_URI};
$reset =~ s/\?.*$//g;
html qq{<form method="get" action="$ENV{REQUEST_URI}" id="form">};
html qq{lite: <input type="checkbox" name="lite" },
  ( defined $param->{'lite'} ? 'checked="checked"' : '' ),
  qq{> levelmax: <select name="level"><option></option> },
  ( map { ( qq{<option value="$_"}, ( length c 'level' && c 'level' == $_ ? ' selected="selected"' : '' ), qq{>$_</option>} ) }
    0 .. 5 ),
  qq{</select> refresh: <select name="refresh"><option></option> },
  ( map { ( qq{<option value="$_"}, ( c 'refresh' == $_ ? ' selected="selected"' : '' ), qq{>$_</option>} ) }
    qw(1 5 10 60 120 300 600 1800) ),
  qq{</select>},
  qq{ pingnow: <input type="checkbox" name="force" },
  ( defined $param->{'force'} ? 'checked="checked"' : '' ),
  qq{>},
  qq{<br/>},
  qq{ debug: <input type="checkbox" name="debug" },
  ( defined $param->{'debug'} ? 'checked="checked"' : '' ), qq{>};
if ( $config{custom} ) {
  html qq{<input type="textarea" name="list" value="$param->{list}">},
    qq{ only: <input type="checkbox" name="only" },
    ( defined $param->{'only'} ? 'checked="checked"' : '' ),
    qq{>};
}
html qq{
<br/>
<input type="submit"/> <a href="$reset">reset</a>
</form>
};
html "<hr/>", join ' ', scalar localtime(), ' ', times(), '<br/>'
  if c 'debug';
html "</html>";
if ( $config{list_loaded} ) {
  print "loadedonly:";
  for my $ip (@list_ordered) {
    my $i = $list->{$ip};
    print_result $i;
  }
} else {
  #$_->{res_prev} = $_->{res}, delete $_->{res}, delete $_->{report} for values %$list;
  #print "gopi!";
  for my $try ( 1 .. $config{tries} ) {
    my $pinged = 0;
    for my $ip (@list_ordered) {
      my $i = $list->{$ip};
      $i->{ip} ||= $ip;
      $i->{try} = $try;
      #print "gopi![$i->{ip}] r[$i->{res}] tr[$try]\n";
      next if $i->{res};
      ++$pinged;
      my ($ping);    #, $port );
                     #$port = $i->{port};
                     #$list->{$ip}{port}
                     #print "[$^O]";
                     #print "$i->{ip}\n";
      eval { $ping = Net::Ping->new( $i->{port} || $^O =~ /freebsd|linux|mswin/i ? 'tcp' : 'icmp' ); }
        or print($@), exit;
      $ping->hires();

      if ( $ping->{proto} eq 'tcp' ) {
        $i->{port} ||= $config{port};
        $i->{port} = getservbyname( $i->{port}, $ping->{proto} )
          unless $i->{port} =~ /^\d+$/;
        $ping->{port_num} = $i->{port};
      }
      #my
      #$i->{res_prev} = $i->{res};
      ( $i->{res}, $i->{time} ) = $ping->ping( $i->{ip}, $config{timeout} );
      #print Dumper $i;
      #( $list->{$ip}{res}, $list->{$ip}{'time'}, $list->{$ip}{try} ) = ( $res, $time, $try );
      $i->{time} = float( $i->{time} * 1000 ) . 'ms';
      $i->{report} .= '* ' unless $i->{res};
      $i->{last_seen} = int time(), $i->{report} .= $i->{time}
        if $i->{res};
      print_result $i;
    }
    #print "ip ()[$pinged]";
    last unless $pinged;
  }
  #print Dumper $list;
  for ( grep { defined $_->{res_prev} and $_->{res} ne $_->{res_prev} } values %$list ) {
    #if ( ! ) {
    $_->{'state'} = $_->{res} ? 'on' : 'off';
    #print "on.";
    #$logs{ $_->{ip} } = 'host now on:' . $_->{report} . Dumper $_;
    #} else {
    #$logs{ $_->{ip} } = 'host now OFF: ' . $_->{report} . Dumper $_;
    #print "off.";
    #}
    printlog "host $_->{ip} state changed to $_->{'state'}";
    $logs{ $_->{ip} } = $_;
    #print Dumper $_;
  }
}
my $ok    = 0;
my $total = scalar keys %$list;
for my $ip (@list_ordered) {
  my $i = $list->{$ip};
  ++$ok if $i->{res};
}
my $bad = $total - $ok;
html qq{<script type="text/javascript">};
html qq{gid('stat').innerHTML += 'BAD:$bad  works:$ok  total:$total<br/>';};
html "</script>";
file_rewrite( c('dir_save') . c('list_save'), Dumper $list)
  if !c 'list_loaded' and !c 'list' and !c 'only';    #c 'save';

sub alarmed {
  my ( $timeout, $proc, @proc_param ) = @_;
  my @ret;
  eval {
    local $SIG{ALRM} =
      sub { die "alarm\n" }
      if $timeout;                                    # NB: \n required
    alarm $timeout if $timeout;
    @ret = $proc->(@proc_param) if ref $proc eq 'CODE';
    alarm 0 if $timeout;
  };
  if ( $timeout and $@ ) {
    printlog( 'err', 'Sorry, unknown error (',
      $@, ') runs:', ' [', join( ',', grep $_, map ( ( caller($_) )[2], ( 0 .. 15 ) ) ), ']' ),
      unless $@ eq "alarm\n";                         # propagate unexpected errors
    printlog( 'err', 'Sorry, timeout (', $timeout, ')' );
    return undef;
  } else {
    #printlog('info', 'alarmed else');
  }
  return wantarray ? @ret : $ret[0];
}

sub mail () {
  my %mailto;
  #warn Dumper \%logs;
  for my $s ( keys %logs ) {
    #  next unless $stat{action}{$s};
    $mailto{$_}{$s} = $logs{$s} for grep { $_ } array $list->{$s}{param}{mail}, $config{mail};
  }
  #warn Dumper \%mailto;
  %logs = ();
  for my $mail ( sort keys %mailto ) {
    printlog("cant use [$@]"), last unless use_try 'MIME::Lite';
    eval {
      alarmed(
        $config{mail_timeout} || 30,
        sub {
          for ( values %{ $mailto{$mail} } ) {
            local %_ = %$_;
            #my $host = $mailto{$_}{$s};
            my $data = ( eval $config{mail_body}    || "host $_{ip} ($_{param}{desc}) is $_{state}" );
            my $subj = ( eval $config{mail_subject} || "host $_{ip} is $_{state}" );
            #printlog "body:$data; subj:$subj";
            printlog "sending mail about $_->{ip}",
              MIME::Lite->new(
              To      => $mail,
              From    => ( $config{mail_from} || $0 . '@localhost' ),
              Subject => $subj,
              Data    => $data,
              %{ $config{'mail_new'} || {} },
              )->send( @{ $config{'mail_send'} || [] } );
          }
        }
      );
    };
    printlog "send mail error [$@]" if $@;
  }
  #printlog 'dev', Dumper \%mailto;
}
mail;
#print "</script>";
#print Dumper $list;
#print Dumper \%config,$param;
#print '<pre>', Dumper \%ENV;
#print @!, $!;
1;