#!/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 strict;
use warnings;
use utf8;

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

use YAML;

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

my $active_rp_id;
my $address_rp_id;

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 $locale = $dc->logger->locale();

    my $rref = $dc->dbh->selectall_hashref(
        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')
        ], 'id', undef, $tref->{id}
    );

    foreach my $t ( keys %$rref ) {
        $rref->{$t}{formatted} = $locale->expand( grep { defined( $_ ) } @{ $rref->{$t} }{qw(message arg0 arg1 arg2 arg3 arg4 arg5 arg6 arg7 arg8 arg9)} );
    }

    return $rref;
}

sub generate_mail_for_registrar {
    my $name = shift;
    my $ref  = shift;
    my @domains;

    foreach my $d ( keys %{ $ref->{domains} } ) {
        push @domains, [ $d, tests_for_domain( $ref->{domains}{$d} ), [ split( /\s+/, $ref->{domains}{$d}{source_data} ) ], $ref->{domains}{$d}{count_critical}, $ref->{domains}{$d}{count_error}, $ref->{domains}{$d}{id}, $ref->{domains}{$d}{time_t}, ];
    }

    @domains = sort { $a->[0] cmp $b->[0] } @domains;

    my $msg = MIME::Lite->new(
        From    => $dc->config->get( "12hour" )->{from},
        To      => $ref->{mail},
        Subject => $dc->config->get( "12hour" )->{subject},
        Type    => 'multipart/mixed',
    );
    $msg->attach(
        Type => 'text/plain;charset=utf-8',
        Data => $registrartemplate->fill_in(
            HASH => {
                name           => $name,
                domains        => \@domains,
                domaintemplate => \$domaintemplate,
            }
        ),
    );
    $msg->attach(
        Type        => 'application/x-yaml',
        Data        => produce_yaml( $ref->{domains}, @domains ),
        Disposition => 'attachment',
        Filename    => 'dnscheck_results.yaml',
    );

    my $bcc = $dc->config->get( "12hour" )->{archive};
    if ( $bcc ) {
        $msg->add( Bcc => $bcc );
    }

    return $msg;
}

sub produce_yaml {
    my %ref     = %{ shift( @_ ) };
    my @domains = @_;

    foreach my $d ( @domains ) {
        my $n = $d->[0];
        foreach ( sort keys %{ $d->[1] } ) {
            my $t = $d->[1]{$_};
            push @{ $ref{$n}{tests} },
              {
                message   => $t->{message},
                timestamp => $t->{timestamp},
                formatted => $t->{formatted},
                level     => $t->{level},
                args      => [ grep { $_ } ( $t->{arg0}, $t->{arg1}, $t->{arg2}, $t->{arg3}, $t->{arg4}, $t->{arg5}, $t->{arg6}, $t->{arg7}, $t->{arg8}, $t->{arg9} ) ],
              };
        }
        delete $ref{$n}{id};
        delete $ref{$n}{source_id};
        $ref{$n}{changed_types} = $ref{$n}{source_data};
        delete $ref{$n}{source_data};
    }

    return Dump( \%ref );
}

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, $mail_active );
}

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, $sendp ) = get_registrar_info( $d );
        next if ( $mail and !$sendp );

        my $r = get_test_results( $d );
        if ( $r->{count_critical} + $r->{count_error} == 0 ) {
            next;    # A later test was clean
        }
        $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
        WHERE begin > subtime(now(),?) 
            AND (count_critical + count_error) > 0
            AND source_id = ?
        ], 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;
}

setup();
my %data = aggregate_registrar_info( domains_tested_last_day() );

foreach my $reg ( keys %data ) {
    if ( $dc->config->get( "12hour" )->{debug} ) {
        print generate_mail_for_registrar( $reg, $data{$reg} )->as_string;
    }
    else {
        eval { generate_mail_for_registrar( $reg, $data{$reg} )->send( 'smtp', $dc->config->get( "12hour" )->{smtphost} ); };
        if ( $@ ) {
            print STDERR $@;
        }
    }
}

=head1 NAME

dnscheck-12hourmailer - email registrars about problems in their domains

=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>, group the domains thus found by registrar and send each registrar an
email listing the problematic zones and some basic information on the problems.

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 subject

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

=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
