#!/usr/pkg/bin/perl
#
# $Id: $
#
# Copyright (c) 2007 .SE (The Internet Infrastructure Foundation).
#                    All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright
#    notice, this list of conditions and the following disclaimer in the
#    documentation and/or other materials provided with the distribution.
#
# THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
# DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
# GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER
# IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
# OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
# IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#
######################################################################

use 5.01001;
use utf8;
use strict;
use warnings;

use DNSCheck;
use Net::SMTP;
use DBI;
use MIME::Lite;
use Text::Template;
use File::Spec::Functions;

my $reggie;
my $dc;
my $source_id;
my $templatedir;
my $domaintemplate;
my $registrartemplate;

my $active_rp_id;
my $address_rp_id;

my $debug = undef;

sub setup {
    $dc = DNSCheck->new( { locale => "en" } );
    $reggie = get_reggie_dbh( $dc->config->get( "reggie" ) );

    my $activekey  = $dc->config->get( "12hour" )->{activekey};
    my $addresskey = $dc->config->get( "12hour" )->{addresskey};

    ( $active_rp_id )  = $reggie->selectrow_array( q[select RP_ID from REGISTRAR_PROPERTIES where PROP_KEY = ?], undef, $activekey );
    ( $address_rp_id ) = $reggie->selectrow_array( q[select RP_ID from REGISTRAR_PROPERTIES where PROP_KEY = ?], undef, $addresskey );

    my $source_name = $dc->config->get( "12hour" )->{sourcestring};
    ( $source_id ) = $dc->dbh->selectrow_array( q[SELECT id FROM source WHERE name = ?], undef, $source_name );
    die "No source information in database.\n" unless defined( $source_id );

    $templatedir = $dc->config->get( "12hour" )->{templatedir};
    $domaintemplate = Text::Template->new( SOURCE => catfile( $templatedir, 'domain.template' ) )
      or die "Failed to construct domain template: $Text::Template::ERROR";
    $registrartemplate = Text::Template->new( SOURCE => catfile( $templatedir, 'registrar.template' ) )
      or die "Failed to construct registrar tempalte: $Text::Template::ERROR";
}

sub tests_for_domain {
    my $tref = shift;

    my $rref = $dc->dbh->selectall_arrayref(
        q[
        SELECT id, timestamp,level,message,arg0,arg1,arg2,arg3,
            arg4,arg5,arg6,arg7,arg8,arg9
        FROM results
        WHERE 
            test_id = ? 
            AND (level = 'ERROR' OR level = 'CRITICAL')
            AND message LIKE 'DNSSEC:%'
            ORDER BY id ASC
        ], undef, $tref->{id}
    );

    return [ map { $_->[3] } @$rref ];
}

sub get_reggie_dbh {
    my $conf = shift;

    my $dsn = sprintf( "DBI:mysql:database=%s;hostname=%s;port=%s", $conf->{"database"}, $conf->{"host"}, $conf->{"port"} );

    my $dbh = DBI->connect( $dsn, $conf->{"user"}, $conf->{"password"}, { RaiseError => 1, AutoCommit => 1 } );
    die "Failed to connect to Reggie: " . $DBI::errstr unless defined( $dbh );

    return $dbh;

}

sub get_registrar_info {
    my $domain = shift;

    my ( $email3, $display_name, $registrar_id ) = $reggie->selectrow_array(
        q[
        select EMAIL3, DISPLAY_NAME, REGISTRAR_ID
        from REGISTRARS, USERS, DOMAINS
        where DOMAINS.NAME = ? and DOMAINS.CLID = USERS.USER_ID and DOMAINS.CLID = REGISTRARS.EPP_USER_ID
        ], undef, $domain
    );

    my $propquery = $reggie->prepare(
        q[
        select VALUE
        from REGISTRARS_TO_PROPERTIES
        where RP_ID = ? and REGISTRAR_ID = ?]
    );

    $propquery->execute( $active_rp_id, $registrar_id );
    my ( $mail_active ) = $propquery->fetchrow_array;

    $propquery->execute( $address_rp_id, $registrar_id );
    my ( $mail_address ) = $propquery->fetchrow_array;

    $email3 = $mail_address if ( $mail_address and $mail_active );

    return ( $email3, $display_name, $registrar_id );
}

sub aggregate_registrar_info {
    my @domains = @_;
    my %res;

    my $no_registrar_address = $dc->config->get( "12hour" )->{fallback}
      || 'failure@example.com';

    foreach my $d ( @domains ) {
        my ( $mail, $name, $registrar_id ) = get_registrar_info( $d );

        my $r = get_test_results( $d );
        if ( $r->{count_critical} + $r->{count_error} == 0 ) {
            next;    # A later test was clean
        }
        $r->{messages} = tests_for_domain( $r );
        $mail = $no_registrar_address unless defined( $mail );
        $name = "Unknown registrar"   unless defined( $name );
        $res{$name}{mail} = $mail;
        $res{$name}{domains}{$d} = $r;
    }
    return %res;
}

sub domains_tested_last_day {
    my $aref = $dc->dbh->selectall_arrayref(
        q[
        SELECT DISTINCT domain
        FROM tests
        JOIN results ON tests.id = results.test_id
        WHERE begin > subtime(now(),?) 
            AND source_id = ?
            AND message LIKE 'DNSSEC:%'
            AND level = 'ERROR'
        ], undef, $dc->config->get( "12hour" )->{timespan}, $source_id
    );
    return map { $_->[0] } @$aref;
}

sub get_test_results {
    my $domain = shift;

    my $test = $dc->dbh->selectrow_hashref(
        q[
        SELECT *, unix_timestamp(begin) as time_t FROM tests WHERE domain = ? AND source_id = ? ORDER BY id DESC LIMIT 1
        ], undef, $domain, $source_id
    );
    die "Domain $domain not tested!\n" unless $test;
    return $test;
}

sub build_mail_from {
    my $ref = shift;
    my %ll  = %{ $dc->config->{'loglevels'} };
    my $out = '';

    my @msgs =
      sort { $a cmp $b }
      grep { /^DNSSEC:/ }
      grep { $ll{$_} eq 'error' or $ll{$_} eq 'critical' }
      keys %ll;

    $out .= <<EOF;
<HTML>
    <HEAD>
        <TITLE>DNSSEC Problem Report</TITLE>
    </HEAD>
    <BODY>
EOF

    $out .= '<TABLE border="1">';
    $out .= "<tr> <th>Registry</th> <th>Domain</th> ";
    $out .= "<th>$_</th> " for map { my $f = $_; $f =~ s/:/: /g; $f =~ s/_/_ /g; $f } @msgs;
    $out .= "</tr>\n";

    foreach my $registry ( keys %$ref ) {
        foreach my $domain ( keys %{ $ref->{$registry}{domains} } ) {
            my $dhash = $ref->{$registry}{'domains'}{$domain};
            my $url = sprintf( 'http://dnscheck.iis.se/?time=%d&id=%d&view=basic&lang=', $dhash->{time_t}, $dhash->{id} );
            $out .= '<tr>';
            $out .= "<td>$registry</td>";
            $out .= "<td><a href='$url'>$domain</a></td>";
            my %tmp = map { $_ => 1 } @{ $dhash->{'messages'} };
            foreach my $msg ( @msgs ) {
                $out .= '<td>';
                if ( $tmp{$msg} ) {
                    $out .= 'X';
                }
                else {
                    $out .= '&nbsp;';
                }
                $out .= '</td> ';
            }
            $out .= "</tr>\n";
        }
    }

    $out .= <<EOF;
        </TABLE>
    </BODY>
</HTML>
EOF

    return $out;
}

setup();

my %data = aggregate_registrar_info( domains_tested_last_day() );

my $mailtext = build_mail_from( \%data );

my $mail = MIME::Lite->new(
    Type    => 'text/html',
    Subject => 'DNSSEC Failures Report',
    From    => $dc->config->get( "12hour" )->{from},
    To      => $dc->config->get( "12hour" )->{dnssec_to},
    Data    => $mailtext
);

if ( $debug or $dc->config->get( "12hour" )->{debug} ) {
    $mail->print;
}
else {
    $mail->send( 'smtp', $dc->config->get( "12hour" )->{smtphost} );
}

=head1 NAME

dnscheck-dnssecmailer - email the registry about domains with DNSSEC problems

=head1 DESCRIPTION

This script will look through the C<tests> table in the L<DNSCheck> database,
pick out the ones that resulted in problems classified at level C<CRITICAL> or
C<ERROR> coming from the DNSSEC section, summarize them in a table and mail it 
to a pre-determined address.

The registrar data is taken from the REGGIE database for the C<.se> domain,
and thus the script will probably be of limited use to other organisations as
is. Other users will almost certainly need to write their own version of the
L<get_registrar_info> function. It expects a single domain name as its input,
and returns C<undef> (if no registrar could be found) or a two-element list
with the contact email address for and name of the relevant registrar (in that
order).

It might be useful to simply make the function return a fixed list with an
email address and a name string, in which case single email with all problems
will be sent to the address given.

=head1 CONFIGURATION

This script uses the same YAML files as the rest of the DNSCheck system. It
looks for its information under the key C<12hour>. The subkeys it uses are the
following.

=over

=item smtphost

The full name of the SMTP server to use for sending emails.

=item from

The string to put in the C<From> line of the sent emails.

=item dnssec_to

The address to send the report to.

=item timespan

How far into the past the script should look for tests. The value should be a
string that will be understood as a time value by MySQL (for example,
"12:00:00" is twelve hours, zero minutes and zero seconds).

=item debug

A Perl boolean value. If it is true, emails will be printed to standard output
instead of sent.

=item sourcestring

The string identifying the source of the tests to consider mailing about.

=back
