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