#!/usr/bin/env perl

use strict;
use warnings;

use vars qw( $VERSION );
$VERSION = '0.01';

use Config::YAML;
use HTML::TreeBuilder;
use HTTP::Request;
use LWP::UserAgent;
use LWP::ConnCache;
use DateTime::Format::Strptime;
use DBI;
use Email::Send;

use Getopt::Long qw( GetOptions :config auto_help auto_version );
use Pod::Usage qw( pod2usage );

my ($debug, $email);

GetOptions(
    'debug|d'   => \$debug,
    'email|s=s' => \$email,
) || pod2usage( 2 );

pod2usage( -msg => "Unknown option: @ARGV", -exitval => 2 ) if @ARGV;

my $filter_records = 1;

my $rcfile = "$ENV{HOME}/.arclogrc";
$rcfile = File::Spec->canonpath($rcfile);

my $c = read_rcfile($rcfile);
my $myhosts = $c->get_hosts;
die "no hosts configured" unless $myhosts;
my $logdb = $c->get_logdb;
die "no log file configured" unless $logdb;
my $dbh = DBI->connect("dbi:SQLite:dbname=$logdb","","");
die "can not open logdb" unless $dbh;

$dbh->do("CREATE TABLE IF NOT EXISTS log(stamp TEXT, record TEXT, PRIMARY KEY(record))")
    or die "db error";

my $errors;
my $output;
###
if (defined $email) {
    close(STDOUT);
    close(STDERR);
    open(STDOUT, '>', \$output) or die "Can't open STDOUT: $!";
    open(STDERR, '>', \$errors) or die "Can't open STDERR: $!";
}

# HTTP authentication realm
my $realm = "Raid Console";
my $user = "admin"; # unconfigurable on the areca card as far as I know
my $http_port = "81";

# collection of fetched HTML log pages
my %log_pages;

# iterate over the list of hosts and passwords
foreach my $host (keys %$myhosts) {
    my $hostport = "$host:$http_port";
    my $ua = LWP::UserAgent->new;
    $ua->timeout(10);
    $ua->conn_cache(LWP::ConnCache->new());
    $ua->credentials( "$hostport", $realm, $user => $myhosts->{$host});

    # first query: access the doc root to setup HTTP digest auth and grab
    # exclusive control of the HTTP admin interace
    my $res = $ua->request(HTTP::Request->new(GET => "http://$hostport/"));
    unless ($res->is_success) {
        warn "can't access $hostport: ", $res->status_line;
        next;
    }
    
    # second query: access the log page
    my $req = HTTP::Request->new(GET => "http://$hostport/evt0.htm");

    # if the referer is not set the access attempt with fail
    $req->referer("http://$hostport/menu.htm");
    # we must copy the auth credentals from the first query attempt as LWP
    # seems to always do a non digest access attempt first, which fails, and
    # then does the HTTP digest.  In the case of the arcea card this first non
    # authed query resets the state of the card and we have to go back and
    # request '/' again.
    $req->header( Authorization => $res->request->header('Authorization'));
    $res= $ua->request($req);
    unless ($res->is_success) {
        die "can't access $hostport: ", $res->status_line;
    }

    $log_pages{$host} = $res->content;    
}

my $strptime = DateTime::Format::Strptime->new(
    pattern => '%Y-%m-%d %H:%M:%S'
);

my @records;
foreach my $host (keys %log_pages) {
    my $page = $log_pages{$host};
    my $root = HTML::TreeBuilder->new->parse($page);
    my $table = $root->look_down('_tag', 'table');
    foreach my $row ($table->descendants) {
        next unless $row->tag eq "tr";
        my $row_data = parse_row($row);
        if (defined $row_data) {
            # add the host name to the hash
            $row_data->{host} = $host;
            push @records, $row_data;
        }
    }
}

# figure out the last record that we saw
# since the order in the sqllite db isn't guarenteed and we can't sort in the
# db, we have to do this by hand
#
# futher, since it doesn't take 0 time to poll the cards -- and as it testing
# it was determined that some cards weren't properly synced to an NTP server.
# We should figure out the last record time for each host.
my %latest_times;
{
    my $strptime = DateTime::Format::Strptime->new(
        pattern => '%Y-%m-%dT%H:%M:%S'
    );

    # read in the entire database
    my $query = $dbh->prepare("SELECT * FROM log")
    or die "database error: $!";
    $query->execute or die "database error: $!";
    my $records = $query->fetchall_arrayref;

    # sort it for the latest timestamp
    foreach my $rec (@$records) {
        my ($host, $time, $device, $event, $elapse_time, $errors)
            = split(/\|/, $rec->[0]);

        my $dt = $strptime->parse_datetime($time);

        if (not exists $latest_times{$host}) {
            $latest_times{$host} = $dt;
        } elsif ($dt > $latest_times{$host}) {
            $latest_times{$host} = $dt;
        }

    }
}

use Data::Dumper;
#print Dumper(\@records);
# sort by time
# insert all records
@records = sort {
    unless (defined $a->{time} && defined $b->{time}) {
        print Dumper($a);
        print Dumper($b);
    }
    $a->{time} cmp $b->{time}
} @records;
my $query = $dbh->prepare("INSERT OR IGNORE INTO log(stamp, record) VALUES(DATETIME('now'), ?)")
        or die "database error: $!";

my @myfilters;
foreach my $filter (@{$c->get_event_filters}) {
    push @myfilters, qr/$filter/;
}

RECORDS: foreach my $rec (@records) {
    no warnings qw( uninitialized );

    my ($host, $time, $device, $event, $elapse_time, $errors)
        = @$rec{qw( host time device event elapse_time errors )};
    # pack record
    my $rec = "$host|$time|$device|$event|$elapse_time|$errors";
    $query->execute($rec)
        or die "database error: $!";
    warn "inserting $rec\n" if $debug;

    # do not print filtered records
    if ($filter_records) {
        foreach my $filter (@myfilters) {
            next RECORDS if $event =~ /$filter/;
        }
    }
    
    if ($time > $latest_times{$host}) {
        print "$host $time $device $event $elapse_time $errors\n";
    }

    use warnings;
}

exit(0) unless defined $output;

my $message =<<END;
To: $email
From: jhoblitt\@ifa.hawaii.edu
Subject: output from arclog.pl

$errors
$output
END

my $sender = Email::Send->new({mailer => 'SMTP'});
$sender->mailer_args([Host => 'hale.ifa.hawaii.edu']);
$sender->send($message);


sub parse_row
{
    my $row = shift;
    # log table format in firmware "V1.43 2007-4-17"
    #<tr>
    #<th width="15%" height="23">Time</th>
    #<th width="23%" height="23">Device</th>
    #<th width="28%" height="23">Event Type</th>
    #<th width="19%" height="23">Elapse Time</th>
    #<th width="15%" height="23">Errors</th>
    #</tr>
    my @fields;
    foreach my $child ($row->descendants) {
        return if $child->tag eq "th";
        my $text = $child->as_text;
        # translate HTML "&nbsp" into undef
        $text = undef if $text eq chr(160);
        push @fields, $text;
    }
    my %row_data;
    @row_data{qw( time device event elapse_time errors )} = @fields;

    # ipp008 has been returning valid rows with completely empty fields
    return unless defined $row_data{time};

    # parse time string into a DateTime object for easy sorting later
    my $dt = $strptime->parse_datetime($row_data{time});

    unless (defined $dt) {
#        warn "can't parse time string $row_data{time}";
        return;
    }

    $row_data{time} = $dt;

    return \%row_data;
}


sub read_rcfile
{
    my $rcfile = shift;

    return unless defined $rcfile;

    if (!-f $rcfile) {
        open(my $fh, '>', $rcfile) or die "can't open file: $!";
        close($fh) or die "can't close file:$!";
    }

    return Config::YAML->new(
            config => $rcfile,
            output => $rcfile,
    );
}
