1#!/usr/bin/perl 2# 3# $Id: Delegation.pm 873 2010-02-02 13:13:53Z calle $ 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 31package DNSCheck::Test::Delegation; 32 33require 5.008; 34use warnings; 35use strict; 36 37our $SVN_VERSION = '$Revision: 873 $'; 38 39use base 'DNSCheck::Test::Common'; 40use Net::IP qw[:PROC]; 41 42###################################################################### 43 44sub test { 45 my $self = shift; 46 my $zone = shift; 47 my $history = shift; 48 49 my $parent = $self->parent; 50 51 return unless $parent->config->should_run; 52 53 if (!defined($history) && $parent->dbh) { 54 $history = $parent->dbh->selectcol_arrayref( 55 'SELECT DISTINCT nameserver FROM delegation_history WHERE domain=?', 56 undef, $zone 57 ); 58 } 59 60 my $qclass = $self->qclass; 61 my $logger = $parent->logger; 62 my $errors = 0; 63 64 my $testable = undef; 65 66 $logger->module_stack_push(); 67 $logger->auto("DELEGATION:BEGIN", $zone); 68 69 if ($parent->undelegated_test 70 and scalar($parent->resolver->faked_zones) == 0) 71 { 72 $errors = $logger->auto('DELEGATION:BROKEN_UNDELEGATED', $zone); 73 $testable = 0; 74 goto DONE; 75 } 76 77 my $packet; 78 79 ($errors, $testable) = $self->ns_parent_child_matching($zone); 80 goto DONE unless $testable; 81 82 $errors += $self->enough_nameservers($zone); 83 $errors += $self->consistent_glue($zone); 84 $errors += $self->in_zone_ns_glue($zone); 85 86 # Test old namservers if we have history 87 if ($history) { 88 $self->check_history($zone, $history); 89 } 90 91 DONE: 92 $logger->auto("DELEGATION:END", $zone); 93 $logger->module_stack_pop(); 94 95 return ($errors, $testable); 96} 97 98################################################################ 99# Utility functions 100################################################################ 101 102sub _get_glue { 103 my $parent = shift; 104 my $zone = shift; 105 106 my $qclass = $parent->config->get("dns")->{class}; 107 my $logger = $parent->logger; 108 109 my @glue = (); 110 111 my @ns = $parent->dns->get_nameservers_at_parent($zone, $qclass); 112 @ns = () unless $ns[0]; 113 114 foreach my $nameserver (@ns) { 115 my $ipv4 = $parent->dns->query_parent($zone, $nameserver, $qclass, "A"); 116 117 if ($ipv4) { 118 my @sorted_ipv4 = 119 sort { $a->{name} cmp $b->{name} } ($ipv4->additional); 120 121 foreach my $rr (@sorted_ipv4) { 122 if ($rr->type eq "A" and $rr->name eq $nameserver) { 123 $logger->auto("DELEGATION:GLUE_FOUND_AT_PARENT", 124 $zone, $rr->name, $rr->address); 125 push @glue, $rr; 126 } 127 } 128 } 129 130 my $ipv6 = 131 $parent->dns->query_parent($zone, $nameserver, $qclass, "AAAA"); 132 133 if ($ipv6) { 134 my @sorted_ipv6 = 135 sort { $a->{name} cmp $b->{name} } ($ipv6->additional); 136 137 foreach my $rr (@sorted_ipv6) { 138 if ($rr->type eq "AAAA" and $rr->name eq $nameserver) { 139 $logger->auto("DELEGATION:GLUE_FOUND_AT_PARENT", 140 $zone, $rr->name, $rr->address); 141 push @glue, $rr; 142 } 143 } 144 } 145 } 146 147 return @glue; 148} 149 150################################################################ 151# Single tests 152################################################################ 153 154sub consistent_glue { 155 my $self = shift; 156 my $zone = shift; 157 158 my $parent = $self->parent; 159 my $logger = $self->logger; 160 my $qclass = $self->qclass; 161 162 return unless $parent->config->should_run; 163 164 my $errors = 0; 165 166 # REQUIRE: check for inconsistent glue 167 my @glue = _get_glue($parent, $zone); 168 foreach my $g (@glue) { 169 $logger->auto("DELEGATION:MATCHING_GLUE", $g->name, $g->address); 170 171 # make sure we only check in-zone-glue 172 unless ($g->name =~ /$zone$/i) { 173 $logger->auto("DELEGATION:GLUE_SKIPPED", $g->name, "out-of-zone"); 174 next; 175 } 176 177 my $c = $parent->dns->query_child($zone, $g->name, $g->class, $g->type); 178 179 if ($c and $c->header->rcode eq "NOERROR") { 180 ## got NOERROR, might be good or bad - dunno yet 181 182 if ($c->header->ancount > 0) { 183 ## got positive answer back, let's see if this makes any sense 184 185 my $found = 0; 186 foreach my $rr ($c->answer) { 187 if ( lc($rr->name) eq lc($g->name) 188 and $rr->class eq $g->class 189 and $rr->type eq $g->type 190 and $rr->address eq $g->address) 191 { 192 $logger->auto("DELEGATION:GLUE_FOUND_AT_CHILD", 193 $zone, $g->name, $g->address); 194 $found++; 195 } 196 } 197 198 unless ($found) { 199 $errors += 200 $logger->auto("DELEGATION:INCONSISTENT_GLUE", $g->name); 201 } 202 } elsif ($c->header->nscount > 0) { 203 ## got referer or nothing, authority section needs study 204 205 my $soa = undef; 206 my $ns = undef; 207 208 foreach my $rr ($c->authority) { 209 $soa = $rr if ($rr->type eq "SOA"); 210 $ns = $rr if ($rr->type eq "NS"); 211 } 212 213 ## got NOERROR and NS in authority section -> referer 214 if ($ns) { 215 $logger->auto("DELEGATION:GLUE_SKIPPED", $g->name, 216 "referer"); 217 next; 218 } 219 220 ## got NOERROR and SOA in authority section -> not found 221 if ($soa) { 222 $logger->auto("DELEGATION:GLUE_MISSING_AT_CHILD", $g->name); 223 next; 224 } 225 } 226 } elsif ($c and $c->header->rcode eq "REFUSED") { 227 ## got REFUSED, probably not authoritative 228 $logger->auto("DELEGATION:GLUE_SKIPPED", $g->name, "refused"); 229 next; 230 } elsif ($c and $c->header->rcode eq "SERVFAIL") { 231 ## got SERVFAIL, most likely not authoritative 232 $logger->auto("DELEGATION:GLUE_SKIPPED", $g->name, "servfail"); 233 next; 234 } else { 235 ## got something else, let's blame the user... 236 $errors += 237 $logger->auto("DELEGATION:GLUE_MISSING_AT_CHILD", $g->name); 238 next; 239 } 240 } 241 242 # TODO: check for loop in glue record chain (i.e. unresolvable) 243 244 # TODO: warning if glue chain is longer than 3 lookups 245 246 return $errors; 247} 248 249sub ns_parent_child_matching { 250 my $self = shift; 251 my $zone = shift; 252 253 my $errors = 0; 254 my $testable; 255 256 return unless $self->parent->config->should_run; 257 258 my @ns_at_parent = 259 $self->parent->dns->get_nameservers_at_parent($zone, $self->qclass); 260 @ns_at_parent = () unless $ns_at_parent[0]; 261 if (scalar @ns_at_parent) { 262 $self->logger->auto("DELEGATION:NS_AT_PARENT", 263 join(",", @ns_at_parent)); 264 $testable = 1; 265 } else { 266 $errors += $self->logger->auto("DELEGATION:NOT_FOUND_AT_PARENT"); 267 $testable = 0; 268 } 269 270 my @ns_at_child = 271 $self->parent->dns->get_nameservers_at_child($zone, $self->qclass); 272 @ns_at_child = () unless $ns_at_child[0]; 273 if (scalar @ns_at_child) { 274 $self->logger->auto("DELEGATION:NS_AT_CHILD", join(",", @ns_at_child)); 275 } else { 276 $errors += $self->logger->auto("DELEGATION:NOT_FOUND_AT_CHILD"); 277 $testable = 0; 278 } 279 280 # REQUIRE: all NS at parent must exist at child [IIS.KVSE.001.01/r2] 281 my @ns_at_both; 282 foreach my $ns (@ns_at_parent) { 283 unless (scalar grep(/^$ns$/i, @ns_at_child)) { 284 $errors += $self->logger->auto("DELEGATION:EXTRA_NS_PARENT", $ns); 285 } else { 286 push @ns_at_both, $ns; 287 } 288 } 289 290 # REQUIRE: at least two (2) NS records at parent [IIS.KVSE.001.01/r1] 291 # Modified to check for NS records that exist at both parent and child. 292 if (@ns_at_both == 1) { 293 $self->logger->auto("DELEGATION:TOO_FEW_NS", scalar @ns_at_both); 294 } elsif (@ns_at_both == 0 and $testable) { 295 $self->logger->auto( 296 "DELEGATION:NO_COMMON_NS_NAMES", 297 join(",", @ns_at_parent), 298 join(",", @ns_at_child) 299 ); 300 } elsif (@ns_at_both > 1) { 301 ## Everything is fine. 302 } 303 304 # REQUIRE: all NS at child may exist at parent 305 foreach my $ns (@ns_at_child) { 306 unless (scalar grep(/^$ns$/i, @ns_at_parent)) { 307 $self->logger->auto("DELEGATION:EXTRA_NS_CHILD", $ns); 308 } 309 } 310 311 return ($errors, $testable); 312} 313 314sub enough_nameservers { 315 my $self = shift; 316 my $zone = shift; 317 my $errors = 0; 318 319 return unless $self->parent->config->should_run; 320 321 # REQUIRE: at least two IPv4 nameservers must be found 322 my $ipv4_ns = 323 $self->parent->dns->get_nameservers_ipv4($zone, $self->qclass); 324 if ($ipv4_ns && scalar(@{$ipv4_ns} < 2)) { 325 $errors += 326 $self->logger->auto("DELEGATION:TOO_FEW_NS_IPV4", scalar @{$ipv4_ns}); 327 } 328 unless ($ipv4_ns) { 329 $errors += $self->logger->auto("DELEGATION:NO_NS_IPV4"); 330 } 331 332 # REQUIRE: at least two IPv6 nameservers should be found 333 my $ipv6_ns = 334 $self->parent->dns->get_nameservers_ipv6($zone, $self->qclass); 335 if ($ipv6_ns && scalar(@{$ipv6_ns} < 2)) { 336 $errors += 337 $self->logger->auto("DELEGATION:TOO_FEW_NS_IPV6", scalar @{$ipv6_ns}); 338 } 339 unless ($ipv6_ns) { 340 $errors += $self->logger->auto("DELEGATION:NO_NS_IPV6"); 341 } 342 343 return $errors; 344} 345 346sub check_history { 347 my $self = shift; 348 my $zone = shift; 349 my $previous = shift; 350 351 my $parent = $self->parent; 352 my $qclass = $self->qclass; 353 my $logger = $self->logger; 354 355 return unless $parent->config->should_run; 356 357 my @old = (); 358 359 my @ns_at_parent = $parent->dns->get_nameservers_at_parent($zone, $qclass); 360 my $current = \@ns_at_parent; 361 362 # Build a hash with all IP addresses for all current nameservers 363 my %current_addresses = 364 map { $_ => 1 } 365 map { $parent->dns->find_addresses($_, $qclass) } @$current; 366 367 # do not check current nameservers 368 foreach my $ns (@$previous) { 369 unless (grep(/^$ns$/, @$current)) { 370 push @old, $ns; 371 } 372 } 373 374 $logger->auto("DELEGATION:NS_HISTORY", $zone, join(",", @old)); 375 376 foreach my $ns (@old) { 377 my @addresses = $parent->dns->find_addresses($ns, $qclass); 378 379 # FIXME: also skip current IP addresses 380 381 foreach my $address (@addresses) { 382 383 # Skip to next address if this one leads to a current server 384 next if $current_addresses{$address}; 385 my $packet = 386 $parent->dns->query_explicit($zone, $qclass, "SOA", $address, 387 { noservfail => 1 }); 388 if ($packet && $packet->header->aa) { 389 $logger->auto("DELEGATION:STILL_AUTH", $ns, $address, $zone); 390 } 391 } 392 } 393 394 return; 395} 396 397sub in_zone_ns_glue { 398 my ($self, $zone) = @_; 399 400 return unless $self->parent->config->should_run; 401 402 my %glue = map { $_->name, $_->address } _get_glue($self->parent, $zone); 403 my @ns_at_parent = 404 $self->parent->dns->get_nameservers_at_parent($zone, $self->qclass); 405 406 foreach my $ns (@ns_at_parent) { 407 if ($ns =~ /\Q$zone\E$/ and !$glue{$ns}) { 408 $self->logger->auto("DELEGATION:INZONE_NS_WITHOUT_GLUE", $ns, 409 $zone); 410 } 411 } 412} 413 4141; 415 416__END__ 417 418 419=head1 NAME 420 421DNSCheck::Test::Delegation - Test zone delegation 422 423=head1 DESCRIPTION 424 425Test zone delegation. The following tests are made: 426 427=over 4 428 429=item * 430All nameservers at parent must exist at child. 431 432=item * 433Nameservers at child may exist at parent. 434 435=item * 436# REQUIRE: at least two (2) NS records at parent [IIS.KVSE.001.01/r1] 437 438=item * 439# REQUIRE: check for inconsistent glue 440 441=back 442 443=head1 METHODS 444 445=over 446 447=item ->test($zonename, $historyarrayref) 448 449Run the default set of delegation tests on the given domain with the specified 450history. 451 452=item ->ns_parent_child_matching($zonename) 453 454Only run the tests checking if the parent and child nameserver information 455matches. Returns a two-element list, with the first element being the number 456of problems at levels ERROR and CRITICAL, and the second element being a 457boolean flag indicating if the zone is at all testable. If that flag is false, 458there is not point in running any further tests, since they will almst 459invariably fail. 460 461=item ->consistent_glue($zonename) 462 463Check that the glue records for the zone make sense. 464 465=item ->enough_nameservers($zonename) 466 467Check that there are a sufficient number of nameservers for the given zone. 468 469=item ->check_history($zonename, $historyarrayref) 470 471Go through the nameservers that used to be authoritative for this zone and 472check that they no longer answer authoritatively for it. 473 474=back 475 476Where nothing else is said, all methods return the total number of errors 477found at levels ERROR and CRITICAL. 478 479=head1 EXAMPLES 480 481=head1 SEE ALSO 482 483L<DNSCheck>, L<DNSCheck::Logger> 484 485=cut 486