1#!/usr/bin/perl
2#
3# $Id: $
4#
5# Copyright (c) 2007 .SE (The Internet Infrastructure Foundation).
6#                    All rights reserved.
7#
8# Redistribution and use in source and binary forms, with or without
9# modification, are permitted provided that the following conditions
10# are met:
11# 1. Redistributions of source code must retain the above copyright
12#    notice, this list of conditions and the following disclaimer.
13# 2. Redistributions in binary form must reproduce the above copyright
14#    notice, this list of conditions and the following disclaimer in the
15#    documentation and/or other materials provided with the distribution.
16#
17# THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
18# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
19# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
20# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
21# DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
22# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
23# GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
24# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER
25# IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
26# OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
27# IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
28#
29######################################################################
30
31use strict;
32use warnings;
33
34use DNSCheck;
35use Net::SMTP;
36use DBI;
37use MIME::Lite;
38use Text::Template;
39use File::Spec::Functions;
40
41use YAML;
42
43my $reggie;
44my $dc;
45my $source_id;
46my $templatedir;
47my $domaintemplate;
48my $registrartemplate;
49
50my $active_rp_id;
51my $address_rp_id;
52
53sub setup {
54    $dc = DNSCheck->new({ locale => "en" });
55    $reggie = get_reggie_dbh($dc->config->get("reggie"));
56
57    my $activekey  = $dc->config->get("12hour")->{activekey};
58    my $addresskey = $dc->config->get("12hour")->{addresskey};
59
60    ($active_rp_id) = $reggie->selectrow_array(
61        q[select RP_ID from REGISTRAR_PROPERTIES where PROP_KEY = ?],
62        undef, $activekey);
63    ($address_rp_id) = $reggie->selectrow_array(
64        q[select RP_ID from REGISTRAR_PROPERTIES where PROP_KEY = ?],
65        undef, $addresskey);
66
67    my $source_name = $dc->config->get("12hour")->{sourcestring};
68    ($source_id) =
69      $dc->dbh->selectrow_array(q[SELECT id FROM source WHERE name = ?],
70        undef, $source_name);
71    die "No source information in database.\n" unless defined($source_id);
72
73    $templatedir = $dc->config->get("12hour")->{templatedir};
74    $domaintemplate =
75      Text::Template->new(SOURCE => catfile($templatedir, 'domain.template'))
76      or die "Failed to construct domain template: $Text::Template::ERROR";
77    $registrartemplate =
78      Text::Template->new(SOURCE => catfile($templatedir, 'registrar.template'))
79      or die "Failed to construct registrar tempalte: $Text::Template::ERROR";
80}
81
82sub tests_for_domain {
83    my $tref   = shift;
84    my $locale = $dc->locale();
85
86    my $rref = $dc->dbh->selectall_hashref(
87        q[
88        SELECT id, timestamp,level,message,arg0,arg1,arg2,arg3,
89            arg4,arg5,arg6,arg7,arg8,arg9
90        FROM results
91        WHERE test_id = ? AND (level = 'ERROR' OR level = 'CRITICAL')
92        ], 'id', undef, $tref->{id}
93    );
94
95    foreach my $t (keys %$rref) {
96        $rref->{$t}{formatted} =
97          $locale->expand(grep { defined($_) }
98              @{ $rref->{$t} }
99              {qw(message arg0 arg1 arg2 arg3 arg4 arg5 arg6 arg7 arg8 arg9)});
100    }
101
102    return $rref;
103}
104
105sub generate_mail_for_registrar {
106    my $name = shift;
107    my $ref  = shift;
108    my @domains;
109
110    foreach my $d (keys %{ $ref->{domains} }) {
111        push @domains,
112          [
113            $d,
114            tests_for_domain($ref->{domains}{$d}),
115            [split(/\s+/, $ref->{domains}{$d}{source_data})],
116            $ref->{domains}{$d}{count_critical},
117            $ref->{domains}{$d}{count_error},
118            $ref->{domains}{$d}{id},
119            $ref->{domains}{$d}{time_t},
120          ];
121    }
122
123    @domains = sort { $a->[0] cmp $b->[0] } @domains;
124
125    my $msg = MIME::Lite->new(
126        From    => $dc->config->get("12hour")->{from},
127        To      => $ref->{mail},
128        Subject => $dc->config->get("12hour")->{subject},
129        Type    => 'multipart/mixed',
130    );
131    $msg->attach(
132        Type => 'text/plain;charset=utf-8',
133        Data => $registrartemplate->fill_in(
134            HASH => {
135                name           => $name,
136                domains        => \@domains,
137                domaintemplate => \$domaintemplate,
138            }
139        ),
140    );
141    $msg->attach(
142        Type        => 'application/x-yaml',
143        Data        => produce_yaml($ref->{domains}, @domains),
144        Disposition => 'attachment',
145        Filename    => 'dnscheck_results.yaml',
146    );
147
148    my $bcc = $dc->config->get("12hour")->{archive};
149    if ($bcc) {
150        $msg->add(Bcc => $bcc);
151    }
152
153    return $msg;
154}
155
156sub produce_yaml {
157    my %ref     = %{ shift(@_) };
158    my @domains = @_;
159
160    foreach my $d (@domains) {
161        my $n = $d->[0];
162        foreach (sort keys %{ $d->[1] }) {
163            my $t = $d->[1]{$_};
164            push @{ $ref{$n}{tests} },
165              {
166                message   => $t->{message},
167                timestamp => $t->{timestamp},
168                formatted => $t->{formatted},
169                level     => $t->{level},
170                args      => [
171                    grep { $_ } (
172                        $t->{arg0}, $t->{arg1}, $t->{arg2}, $t->{arg3},
173                        $t->{arg4}, $t->{arg5}, $t->{arg6}, $t->{arg7},
174                        $t->{arg8}, $t->{arg9}
175                    )
176                ],
177              };
178        }
179        delete $ref{$n}{id};
180        delete $ref{$n}{source_id};
181        $ref{$n}{changed_types} = $ref{$n}{source_data};
182        delete $ref{$n}{source_data};
183    }
184
185    return Dump(\%ref);
186}
187
188sub get_reggie_dbh {
189    my $conf = shift;
190
191    my $dsn = sprintf("DBI:mysql:database=%s;hostname=%s;port=%s",
192        $conf->{"database"}, $conf->{"host"}, $conf->{"port"});
193
194    my $dbh =
195      DBI->connect($dsn, $conf->{"user"}, $conf->{"password"},
196        { RaiseError => 1, AutoCommit => 1 });
197    die "Failed to connect to Reggie: " . $DBI::errstr unless defined($dbh);
198
199    return $dbh;
200
201}
202
203sub get_registrar_info {
204    my $domain = shift;
205
206    my ($email3, $display_name, $registrar_id) = $reggie->selectrow_array(
207        q[
208        select EMAIL3, DISPLAY_NAME, REGISTRAR_ID
209        from REGISTRARS, USERS, DOMAINS
210        where DOMAINS.NAME = ? and DOMAINS.CLID = USERS.USER_ID and DOMAINS.CLID = REGISTRARS.EPP_USER_ID
211        ], undef, $domain
212    );
213
214    my $propquery = $reggie->prepare(
215        q[
216        select VALUE
217        from REGISTRARS_TO_PROPERTIES
218        where RP_ID = ? and REGISTRAR_ID = ?]
219    );
220
221    $propquery->execute($active_rp_id, $registrar_id);
222    my ($mail_active) = $propquery->fetchrow_array;
223
224    $propquery->execute($address_rp_id, $registrar_id);
225    my ($mail_address) = $propquery->fetchrow_array;
226
227    $email3 = $mail_address if ($mail_address and $mail_active);
228
229    return ($email3, $display_name, $mail_active);
230}
231
232sub aggregate_registrar_info {
233    my @domains = @_;
234    my %res;
235
236    my $no_registrar_address = $dc->config->get("12hour")->{fallback}
237      || 'failure@example.com';
238
239    foreach my $d (@domains) {
240        my ($mail, $name, $sendp) = get_registrar_info($d);
241        next if ($mail and !$sendp);
242
243        my $r = get_test_results($d);
244        if ($r->{count_critical} + $r->{count_error} == 0) {
245            next;    # A later test was clean
246        }
247        $mail = $no_registrar_address unless defined($mail);
248        $name = "Unknown registrar"   unless defined($name);
249        $res{$name}{mail} = $mail;
250        $res{$name}{domains}{$d} = $r;
251    }
252    return %res;
253}
254
255sub domains_tested_last_day {
256    my $aref = $dc->dbh->selectall_arrayref(
257        q[
258        SELECT DISTINCT domain
259        FROM tests
260        WHERE begin > subtime(now(),?)
261            AND (count_critical + count_error) > 0
262            AND source_id = ?
263        ], undef, $dc->config->get("12hour")->{timespan}, $source_id
264    );
265    return map { $_->[0] } @$aref;
266}
267
268sub get_test_results {
269    my $domain = shift;
270
271    my $test = $dc->dbh->selectrow_hashref(
272        q[
273        SELECT *, unix_timestamp(begin) as time_t FROM tests WHERE domain = ? AND source_id = ? ORDER BY id DESC LIMIT 1
274        ], undef, $domain, $source_id
275    );
276    die "Domain $domain not tested!\n" unless $test;
277    return $test;
278}
279
280setup();
281my %data = aggregate_registrar_info(domains_tested_last_day());
282
283foreach my $reg (keys %data) {
284    if ($dc->config->get("12hour")->{debug}) {
285        print generate_mail_for_registrar($reg, $data{$reg})->as_string;
286    } else {
287        eval {
288            generate_mail_for_registrar($reg, $data{$reg})
289              ->send('smtp', $dc->config->get("12hour")->{smtphost});
290        };
291        if ($@) {
292            print STDERR $@;
293        }
294    }
295}
296
297=head1 NAME
298
299dnscheck-12hourmailer - email registrars about problems in their domains
300
301=head1 DESCRIPTION
302
303This script will look through the C<tests> table in the L<DNSCheck> database,
304pick out the ones that resulted in problems classified at level C<CRITICAL> or
305C<ERROR>, group the domains thus found by registrar and send each registrar an
306email listing the problematic zones and some basic information on the problems.
307
308The registrar data is taken from the REGGIE database for the C<.se> domain,
309and thus the script will probably be of limited use to other organisations as
310is. Other users will almost certainly need to write their own version of the
311L<get_registrar_info> function. It expects a single domain name as its input,
312and returns C<undef> (if no registrar could be found) or a two-element list
313with the contact email address for and name of the relevant registrar (in that
314order).
315
316It might be useful to simply make the function return a fixed list with an
317email address and a name string, in which case single email with all problems
318will be sent to the address given.
319
320=head1 CONFIGURATION
321
322This script uses the same YAML files as the rest of the DNSCheck system. It
323looks for its information under the key C<12hour>. The subkeys it uses are the
324following.
325
326=over
327
328=item smtphost
329
330The full name of the SMTP server to use for sending emails.
331
332=item from
333
334The string to put in the C<From> line of the sent emails.
335
336=item subject
337
338The string to put in the C<subject> line of the sent emails.
339
340=item timespan
341
342How far into the past the script should look for tests. The value should be a
343string that will be understood as a time value by MySQL (for example,
344"12:00:00" is twelve hours, zero minutes and zero seconds).
345
346=item debug
347
348A Perl boolean value. If it is true, emails will be printed to standard output
349instead of sent.
350
351=item sourcestring
352
353The string identifying the source of the tests to consider mailing about.
354
355=back
356