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