1#!/usr/bin/perl
2#
3# $Id: DNS.pm 821 2009-10-21 14:04:35Z 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::Lookup::DNS;
32
33use strict;
34use warnings;
35require 5.008;
36
37our $SVN_VERSION = '$Revision: 821 $';
38
39use List::Util 'shuffle';
40use Carp;
41
42use Data::Dumper;
43use Net::DNS 0.59;
44use Net::IP 1.25;
45
46use Crypt::OpenSSL::Random qw(random_bytes);
47use Digest::SHA1 qw(sha1);
48use Digest::BubbleBabble qw(bubblebabble);
49
50######################################################################
51
52sub new {
53    my $proto = shift;
54    my $class = ref($proto) || $proto;
55    my $self  = {};
56    bless $self, $class;
57
58    my $parent = shift;
59
60    $self->{_parent} = $parent;
61    my $config = $parent->config;
62
63    $self->{debug} = $config->get("debug");
64
65    if ($self->{debug} && $self->{debug} >= 2) {
66        $self->{debug_resolver} = 1;
67    } else {
68        $self->{debug_resolver} = 0;
69    }
70
71    # hash PACKET at resolver indexed by QNAME,QTYPE,QCLASS
72    $self->{cache}{resolver} = ();
73
74    # hash PACKET at parent indexed by QNAME,QTYPE,QCLASS
75    $self->{cache}{parent} = ();
76
77    # hash PACKET at child indexed by QNAME,QTYPE,QCLASS
78    $self->{cache}{child} = ();
79
80    # hash of NAMESERVERS index QNAME,QCLASS,PROTOCOL
81    $self->{nameservers} = ();
82
83    # hash of PARENT indexed by CHILD,QCLASS
84    $self->{parent} = ();
85
86    # hash of SOMETHING indexed by ADDRESSES
87    $self->{blacklist} = ();
88
89    $self->{default} = $parent->config->get("dns");
90
91    # set up global resolver
92    $self->{resolver} = $parent->resolver;
93
94    return $self;
95}
96
97sub DESTROY {
98
99}
100
101######################################################################
102
103sub flush {
104    my $self = shift;
105
106    $self->{cache}{resolver} = ();
107    $self->{cache}{parent}   = ();
108    $self->{cache}{child}    = ();
109    $self->{blacklist}       = ();
110}
111
112sub parent {
113    my $self = shift;
114
115    return $self->{_parent};
116}
117
118sub logger {
119    my $self = shift;
120
121    return $self->parent->logger;
122}
123
124sub resolver {
125    my $self = shift;
126
127    return $self->{resolver};
128}
129
130######################################################################
131
132sub query_resolver {
133    my $self   = shift;
134    my $qname  = shift;
135    my $qclass = shift;
136    my $qtype  = shift;
137
138    $self->logger->auto("DNS:QUERY_RESOLVER", $qname, $qclass, $qtype);
139
140    unless ($self->{cache}{resolver}{$qname}{$qclass}{$qtype}) {
141        $self->{cache}{resolver}{$qname}{$qclass}{$qtype} =
142          $self->{resolver}->recurse($qname, $qtype, $qclass);
143
144        if ($self->check_timeout($self->{resolver})) {
145            $self->logger->auto("DNS:RESOLVER_QUERY_TIMEOUT",
146                $qname, $qclass, $qtype);
147            return;
148        }
149    }
150
151    my $packet = $self->{cache}{resolver}{$qname}{$qclass}{$qtype};
152
153    if ($packet) {
154        $self->logger->auto("DNS:RESOLVER_RESPONSE",
155            sprintf("%d answer(s)", $packet->header->ancount));
156    }
157
158    return $packet;
159}
160
161######################################################################
162
163sub query_parent {
164    my $self   = shift;
165    my $zone   = shift;
166    my $qname  = shift;
167    my $qclass = shift;
168    my $qtype  = shift;
169
170    $self->logger->auto("DNS:QUERY_PARENT", $zone, $qname, $qclass, $qtype);
171
172    unless ($self->{cache}{parent}{$zone}{$qname}{$qclass}{$qtype}) {
173        $self->{cache}{parent}{$zone}{$qname}{$qclass}{$qtype} =
174          $self->query_parent_nocache($zone, $qname, $qclass, $qtype);
175    }
176
177    my $packet = $self->{cache}{parent}{$zone}{$qname}{$qclass}{$qtype};
178
179    if ($packet) {
180        $self->logger->auto(
181            "DNS:PARENT_RESPONSE",
182            sprintf(
183                "%d answer(s), %d authority",
184                $packet->header->ancount, $packet->header->nscount
185            )
186        );
187    }
188
189    return $packet;
190}
191
192sub query_parent_nocache {
193    my $self   = shift;
194    my $zone   = shift;
195    my $qname  = shift;
196    my $qclass = shift;
197    my $qtype  = shift;
198    my $flags  = shift;
199
200    $self->logger->auto("DNS:QUERY_PARENT_NOCACHE",
201        $zone, $qname, $qclass, $qtype);
202
203    if (my @ns = $self->parent->resolver->faked_zone($zone)) {
204        if ($qtype eq 'NS') {
205            die "Looking for NS from parent for faked domain.\n";
206        } elsif (
207            ($qtype eq 'A' or $qtype eq 'AAAA') and (
208                grep {
209                    /$qname/
210                } @ns
211            )
212          )
213        {
214            my $p = $self->parent->resolver->fake_packet($zone, $qname, $qtype);
215            return $p if defined($p);
216        }
217    }
218
219    # find parent
220    $self->logger->auto("DNS:FIND_PARENT", $zone, $qclass);
221    my $parent = $self->find_parent($zone, $qclass);
222    unless ($parent) {
223        $self->logger->auto("DNS:NO_PARENT", $zone, $qclass);
224        return;
225    } else {
226        $self->logger->auto("DNS:PARENT_OF", $parent, $zone, $qclass);
227    }
228
229    # initialize parent nameservers
230    $self->init_nameservers($parent, $qclass);
231
232    # find parent to query
233    my $ipv4 = $self->get_nameservers_ipv4($parent, $qclass);
234    my $ipv6 = $self->get_nameservers_ipv6($parent, $qclass);
235    my @target = ();
236    @target = (@target, @{$ipv4}) if ($ipv4);
237    @target = (@target, @{$ipv6}) if ($ipv6);
238    unless (scalar @target) {
239        $self->logger->auto("DNS:NO_PARENT_NS", $parent, $zone, $qclass);
240        return;
241    }
242
243    # randomize name server addresses
244    @target = shuffle(@target);
245
246    return $self->_query_multiple($qname, $qclass, $qtype, $flags, @target);
247}
248
249######################################################################
250
251sub query_child {
252    my $self   = shift;
253    my $zone   = shift;
254    my $qname  = shift;
255    my $qclass = shift;
256    my $qtype  = shift;
257
258    $self->logger->auto("DNS:QUERY_CHILD", $zone, $qname, $qclass, $qtype);
259
260    unless ($self->{cache}{child}{$zone}{$qname}{$qclass}{$qtype}) {
261        $self->{cache}{child}{$zone}{$qname}{$qclass}{$qtype} =
262          $self->query_child_nocache($zone, $qname, $qclass, $qtype);
263    }
264
265    my $packet = $self->{cache}{child}{$zone}{$qname}{$qclass}{$qtype};
266
267    if ($packet) {
268        $self->logger->auto("DNS:CHILD_RESPONSE",
269            sprintf("%d answer(s)", $packet->header->ancount));
270    }
271
272    return $packet;
273}
274
275sub query_child_nocache {
276    my $self   = shift;
277    my $zone   = shift;
278    my $qname  = shift;
279    my $qclass = shift;
280    my $qtype  = shift;
281    my $flags  = shift;
282    my $parent = $self->parent;
283
284    $self->logger->auto("DNS:QUERY_CHILD_NOCACHE",
285        $zone, $qname, $qclass, $qtype);
286
287    # initialize child nameservers
288    $self->init_nameservers($zone, $qclass);
289
290    # find child to query
291    my @target = ();
292
293    my $ipv4 = $self->get_nameservers_ipv4($zone, $qclass);
294    my $ipv6 = $self->get_nameservers_ipv6($zone, $qclass);
295    @target = (@target, @{$ipv4}) if ($ipv4);
296    @target = (@target, @{$ipv6}) if ($ipv6);
297
298    unless (scalar @target) {
299        $self->logger->auto("DNS:NO_CHILD_NS", $zone, $qclass);
300        return;
301    }
302
303    $flags->{aaonly} = 1;
304
305    return $self->_query_multiple($qname, $qclass, $qtype, $flags, @target);
306}
307
308######################################################################
309
310sub query_explicit {
311    my $self    = shift;
312    my $qname   = shift;
313    my $qclass  = shift;
314    my $qtype   = shift;
315    my $address = shift;
316    my $flags   = shift;
317
318    $self->logger->auto("DNS:QUERY_EXPLICIT", $address, $qname, $qclass,
319        $qtype);
320
321    unless ($self->_querible($address)) {
322        return;
323    }
324
325    my $resolver = $self->_setup_resolver($flags);
326
327    # $resolver->nameserver($address);
328
329    if ($self->check_blacklist($address, $qname, $qclass, $qtype)) {
330        $self->logger->auto("DNS:ADDRESS_BLACKLISTED",
331            $address, $qname, $qclass, $qtype);
332        return;
333    }
334
335    my $packet = $resolver->get($qname, $qtype, $qclass, $address);
336
337    if ($self->check_timeout($resolver)) {
338        $self->logger->auto("DNS:QUERY_TIMEOUT",
339            $address, $qname, $qclass, $qtype);
340        $self->add_blacklist($address, $qname, $qclass, $qtype);
341        $self->logger->auto("DNS:ADDRESS_BLACKLIST_ADD",
342            $address, $qname, $qclass, $qtype);
343        return;
344    }
345
346    unless ($packet) {
347        $self->logger->auto("DNS:LOOKUP_ERROR", $resolver->errorstring);
348        return;
349    }
350
351    # FIXME: improve; see RFC 2671 section 5.3
352    # FIXME: Can FORMERR appear when called from Nameserver.pm?
353    #        I.e. returning undef would generate NO_TCP/NO_UDP
354    if ($packet->header->rcode eq "FORMERR"
355        && ($flags->{bufsize} || $flags->{dnssec}))
356    {
357        $self->logger->auto("DNS:NO_EDNS", $address);
358        return;
359    }
360
361    # FIXME: improve; see RFC 2671 section 5.3
362    if ($packet->header->rcode eq "FORMERR") {
363        $self->logger->auto("DNS:LOOKUP_ERROR", $resolver->errorstring);
364        return;
365    }
366
367    # FIXME: Returns $packet since we don't want NAMESERVER:NO_TCP/NO_UDP
368    if ($packet->header->rcode eq "SERVFAIL" && uc($qtype) eq "SOA") {
369        unless (defined($flags) && $flags->{noservfail}) {
370            $self->logger->auto("DNS:SOA_SERVFAIL", $address);
371        }
372        $self->add_blacklist($address, $qname, $qclass, $qtype);
373        $self->logger->auto("DNS:ADDRESS_BLACKLIST_ADD",
374            $address, $qname, $qclass, $qtype);
375        return $packet;
376    }
377
378    # FIXME: notice, warning, error?
379    if ($packet->header->rcode ne "NOERROR") {
380        $self->logger->auto("DNS:NO_ANSWER", $address, $qname, $qclass, $qtype);
381        return;
382    }
383
384    # ignore non-authoritative answers unless flag aaonly is unset
385    unless ($packet && $packet->header->aa) {
386        if ($flags && $flags->{aaonly}) {
387            unless ($flags->{aaonly} == 0) {
388                $self->logger->auto("DNS:NOT_AUTH", $address, $qname, $qclass,
389                    $qtype);
390                return;
391            }
392        }
393    }
394
395    $self->logger->auto("DNS:EXPLICIT_RESPONSE",
396        sprintf("%d answer(s)", $packet->header->ancount));
397
398    foreach my $rr ($packet->answer) {
399        $self->logger->auto("DNS:ANSWER_DUMP", _rr2string($rr));
400    }
401
402    return $packet;
403}
404
405######################################################################
406
407sub _query_multiple {
408    my $self   = shift;
409    my $qname  = shift;
410    my $qclass = shift;
411    my $qtype  = shift;
412    my $flags  = shift;
413    my @target = @_;
414
415    # set up resolver
416    my $resolver = $self->_setup_resolver($flags);
417
418    my $packet  = undef;
419    my $timeout = 0;
420
421    for my $address (@target) {
422        unless ($self->_querible($address)) {
423            next;
424        }
425
426        $packet = $resolver->get($qname, $qtype, $qclass, $address);
427
428        # ignore non-authoritative answers if flag aaonly is set
429        unless ($packet && $packet->header->aa) {
430            if ($flags && $flags->{aaonly}) {
431                if ($flags->{aaonly} == 1) {
432                    $self->logger->auto("DNS:NOT_AUTH", $address, $qname,
433                        $qclass, $qtype);
434                    next;
435                }
436            }
437        }
438
439        last if ($packet && $packet->header->rcode ne "SERVFAIL");
440
441        if ($self->check_timeout($resolver)) {
442            $timeout++;
443        }
444    }
445
446    unless ($packet && $packet->header->rcode ne "SERVFAIL") {
447        if ($timeout) {
448            $self->logger->auto("DNS:QUERY_TIMEOUT", join(",", @target),
449                $qname, $qclass, $qtype);
450        } else {
451            $self->logger->auto("DNS:LOOKUP_ERROR", $resolver->errorstring);
452        }
453    }
454
455    return $packet;
456}
457
458######################################################################
459
460sub _setup_resolver {
461    my $self  = shift;
462    my $flags = shift;
463
464    $self->logger->auto("DNS:SETUP_RESOLVER");
465
466    # set up resolver
467    my $resolver = DNSCheck::Lookup::Resolver->new($self->parent);
468
469    $resolver->resolver->cdflag(1);
470    $resolver->resolver->usevc(0);
471    $resolver->resolver->defnames(0);
472
473    if ($flags) {
474        if ($flags->{transport}) {
475            if ($flags->{transport} eq "udp") {
476                $resolver->resolver->usevc(0);
477            } elsif ($flags->{transport} eq "tcp") {
478                $resolver->resolver->usevc(1);
479            } else {
480                die "unknown transport";
481            }
482
483            if ($flags->{transport} eq "udp" && $flags->{bufsize}) {
484                $self->logger->auto("DNS:SET_BUFSIZE", $flags->{bufsize});
485                $resolver->resolver->udppacketsize($flags->{bufsize});
486            }
487        }
488
489        # if ($flags->{recurse}) {
490        #    $resolver->recurse(1);
491        # }
492
493        if ($flags->{dnssec}) {
494            $resolver->dnssec(1);
495        }
496    }
497
498    if ($resolver->resolver->usevc) {
499        $self->logger->auto("DNS:TRANSPORT_TCP");
500    } else {
501        $self->logger->auto("DNS:TRANSPORT_UDP");
502    }
503
504    # if ($resolver->recurse) {
505    #     $self->logger->auto("DNS:RECURSION_DESIRED");
506    # } else {
507    #     $self->logger->auto("DNS:RECURSION_DISABLED");
508    # }
509
510    # if ($resolver->resolver->dnssec) {
511    #     $self->logger->auto("DNS:DNSSEC_DESIRED");
512    # } else {
513    #     $self->logger->auto("DNS:DNSSEC_DISABLED");
514    # }
515
516    return $resolver;
517}
518
519######################################################################
520
521sub get_nameservers_ipv4 {
522    my $self   = shift;
523    my $qname  = shift;
524    my $qclass = shift;
525
526    $self->init_nameservers($qname, $qclass);
527
528    return $self->{nameservers}{$qname}{$qclass}{ipv4};
529}
530
531sub get_nameservers_ipv6 {
532    my $self   = shift;
533    my $qname  = shift;
534    my $qclass = shift;
535
536    $self->init_nameservers($qname, $qclass);
537
538    return $self->{nameservers}{$qname}{$qclass}{ipv6};
539}
540
541sub get_nameservers_at_parent {
542    my $self   = shift;
543    my $qname  = shift;
544    my $qclass = shift;
545
546    my @ns;
547
548    $self->logger->auto("DNS:GET_NS_AT_PARENT", $qname, $qclass);
549
550    if ($self->resolver->faked_zone($qname)) {
551        return sort $self->resolver->faked_zone($qname);
552    }
553
554    my $packet = $self->query_parent($qname, $qname, $qclass, "NS");
555
556    return unless ($packet);
557
558    if ($packet->authority > 0) {
559        foreach my $rr ($packet->authority) {
560            if (($rr->type eq "NS") && $rr->nsdname) {
561                push @ns, $rr->nsdname;
562            }
563        }
564    } else {
565        foreach my $rr ($packet->answer) {
566            if (($rr->type eq "NS") && $rr->nsdname) {
567                push @ns, $rr->nsdname;
568            }
569        }
570    }
571
572    return sort(@ns);
573}
574
575sub get_nameservers_at_child {
576    my $self   = shift;
577    my $qname  = shift;
578    my $qclass = shift;
579
580    my @ns;
581
582    $self->logger->auto("DNS:GET_NS_AT_CHILD", $qname, $qclass);
583
584    my $packet = $self->query_child($qname, $qname, $qclass, "NS");
585
586    return unless ($packet);
587
588    foreach my $rr ($packet->answer) {
589        if (($rr->type eq "NS") && $rr->nsdname) {
590            push @ns, $rr->nsdname;
591        }
592    }
593
594    return sort(@ns);
595}
596
597######################################################################
598
599sub init_nameservers {
600    my $self   = shift;
601    my $qname  = shift;
602    my $qclass = shift;
603
604    unless ($self->{nameservers}{$qname}{$qclass}{ns}) {
605        $self->_init_nameservers_helper($qname, $qclass);
606    }
607}
608
609sub _init_nameservers_helper {
610    my $self   = shift;
611    my $qname  = shift;
612    my $qclass = shift;
613
614    my %nsv4;
615    my %nsv6;
616
617    $self->logger->auto("DNS:INITIALIZING_NAMESERVERS", $qname, $qclass);
618
619    $self->{nameservers}{$qname}{$qclass}{ns}   = ();
620    $self->{nameservers}{$qname}{$qclass}{ipv4} = ();
621    $self->{nameservers}{$qname}{$qclass}{ipv6} = ();
622
623    # Lookup name servers
624    my $ns = $self->query_resolver($qname, $qclass, "NS");
625
626    # If we cannot find any nameservers, we're done
627    goto DONE unless ($ns);
628
629    foreach my $rr ($ns->answer) {
630        if (($rr->type eq "NS") && $rr->nsdname) {
631            push @{ $self->{nameservers}{$qname}{$qclass}{ns} }, $rr->nsdname;
632        }
633    }
634
635    goto DONE unless ($self->{nameservers}{$qname}{$qclass}{ns});
636
637    foreach my $ns (sort @{ $self->{nameservers}{$qname}{$qclass}{ns} }) {
638
639        # Lookup IPv4 addresses for name servers
640        my $ipv4 = $self->query_resolver($ns, $qclass, "A");
641
642        if (defined($ipv4)) {
643            foreach my $rr ($ipv4->answer) {
644                if (($rr->type eq "A") && $rr->address) {
645                    $nsv4{ $rr->address } = 1;
646                    $self->logger->auto("DNS:NAMESERVER_FOUND", $qname, $qclass,
647                        $rr->name, $rr->address);
648                }
649            }
650        }
651
652        # Lookup IPv6 addresses for name servers
653        my $ipv6 = $self->query_resolver($ns, $qclass, "AAAA");
654
655        if (defined($ipv6)) {
656            foreach my $rr ($ipv6->answer) {
657                if (($rr->type eq "AAAA") && $rr->address) {
658                    $nsv6{ $rr->address } = 1;
659                    $self->logger->auto("DNS:NAMESERVER_FOUND", $qname, $qclass,
660                        $rr->name, $rr->address);
661                }
662            }
663        }
664    }
665
666  DONE:
667    $self->{nameservers}{$qname}{$qclass}{ipv4} = [keys %nsv4];
668    $self->{nameservers}{$qname}{$qclass}{ipv6} = [keys %nsv6]
669      if (keys %nsv6) > 0;
670    $self->logger->auto("DNS:NAMESERVERS_INITIALIZED", $qname, $qclass);
671}
672
673sub prep_fake_glue {
674    my $self = shift;
675    my $zone = shift;
676
677    unless ($self->{nameservers}{$zone} and $self->{nameservers}{$zone}{'IN'}) {
678        $self->{nameservers}{$zone}{'IN'} = {};
679    }
680
681    my $cache = $self->{nameservers}{$zone}{'IN'};
682    push @{ $cache->{'ns'} }, $self->parent->fake_glue_names;
683    foreach my $ip ($self->parent->fake_glue_ips) {
684        my $i = Net::IP->new($ip);
685        if (!defined($i)) {
686            $self->parent->logger->auto("DNS:MALFORMED_FAKE_IP ($ip)");
687        } elsif ($i->version == 4) {
688            push @{ $cache->{'ipv4'} }, $ip;
689        } else {
690            push @{ $cache->{'ipv6'} }, $ip;
691        }
692    }
693}
694
695######################################################################
696
697sub find_parent {
698    my $self   = shift;
699    my $qname  = shift;
700    my $qclass = shift;
701
702    unless ($self->{parent}{$qname}{$qclass}) {
703        $self->{parent}{$qname}{$qclass} =
704          $self->_find_parent_helper($qname, $qclass);
705    }
706
707    my $parent = $self->{parent}{$qname}{$qclass};
708
709    return $parent;
710}
711
712sub _find_parent_helper {
713    my $self   = shift;
714    my $qname  = shift;
715    my $qclass = shift;
716
717    my $parent = undef;
718
719    $self->logger->auto("DNS:FIND_PARENT_BEGIN", $qname, $qclass);
720
721    # start by finding the SOA for the qname
722    my $try = $self->_find_soa($qname, $qclass);
723
724    # if we get an NXDOMAIN back, we're done
725    unless ($try) {
726        goto DONE;
727    }
728
729    $self->logger->auto("DNS:FIND_PARENT_DOMAIN", $try);
730
731    my @labels = split(/\./, $try);
732
733    do {
734        shift @labels;
735        $try = join(".", @labels);
736        $try = "." if ($try eq "");
737
738        $self->logger->auto("DNS:FIND_PARENT_TRY", $try);
739
740        $parent = $self->_find_soa($try, $qclass);
741
742        # if we get an NXDOMAIN back, we're done
743        goto DONE unless ($parent);
744
745        $self->logger->auto("DNS:FIND_PARENT_UPPER", $parent);
746
747        goto DONE if ($try eq $parent);
748    } while ($#labels > 0);
749
750    $parent = $try;
751
752  DONE:
753    if ($parent) {
754        $self->logger->auto("DNS:FIND_PARENT_RESULT", $parent, $qname, $qclass);
755    } else {
756        $self->logger->auto("DNS:NXDOMAIN", $qname, $qclass);
757    }
758
759    return $parent;
760}
761
762sub _find_soa {
763    my $self   = shift;
764    my $qname  = shift;
765    my $qclass = shift;
766    my $answer;
767
768    $answer = $self->{resolver}->recurse($qname, "SOA", $qclass);
769
770    return $qname unless ($answer);
771
772# The following check may run afoul of a bug in BIND 9.x where x is 3 or less,
773# and if so lead to a false CRITICAL error. See RFC 2136 section 7.16 and
774# http://www.ripe.net/ripe/meetings/ripe-51/presentations/pdf/ripe51-enum-e164.pdf
775
776    # return undef if ($answer->header->rcode eq "NXDOMAIN");
777
778    # "Handle" CNAMEs at zone apex
779    foreach my $rr ($answer->answer) {
780        return $qname if ($rr->type eq "CNAME");
781    }
782
783    foreach my $rr ($answer->authority) {
784        return $rr->name if ($rr->type eq "SOA");
785    }
786
787    return $qname;
788}
789
790######################################################################
791
792sub find_mx {
793    my $self   = shift;
794    my $domain = shift;
795
796    my $packet;
797    my @dest = ();
798
799    $self->logger->auto("DNS:FIND_MX_BEGIN", $domain);
800
801    $packet = $self->query_resolver($domain, "IN", 'MX');
802    if ($packet && $packet->header->ancount > 0) {
803        foreach my $rr ($packet->answer) {
804            if (($rr->type eq "MX") && $rr->exchange) {
805                push @dest, [$rr->preference, $rr->exchange];
806            }
807        }
808        @dest = map { $_->[1] } sort { $a->[0] <=> $b->[0] } @dest;
809        goto DONE if (scalar @dest);
810    }
811
812    $packet = $self->query_resolver($domain, "IN", 'A');
813    if ($packet && $packet->header->ancount > 0) {
814        foreach my $rr ($packet->answer) {
815            if ($rr->type eq "A") {
816                push @dest, $domain;
817                goto DONE;
818            }
819        }
820    }
821
822    $packet = $self->query_resolver($domain, "IN", 'AAAA');
823    if ($packet && $packet->header->ancount > 0) {
824        foreach my $rr ($packet->answer) {
825            if ($rr->type eq "AAAA") {
826                push @dest, $domain;
827                goto DONE;
828            }
829        }
830    }
831
832  DONE:
833    $self->logger->auto("DNS:FIND_MX_RESULT", $domain, join(",", @dest));
834
835    return @dest;
836}
837
838sub find_addresses {
839    my $self   = shift;
840    my $qname  = shift;
841    my $qclass = shift;
842
843    my @addresses = ();
844
845    $self->logger->auto("DNS:FIND_ADDRESSES", $qname, $qclass);
846
847    my $ipv4 = $self->query_resolver($qname, $qclass, "A");
848    my $ipv6 = $self->query_resolver($qname, $qclass, "AAAA");
849
850    unless ($ipv4 && $ipv6) {
851        ## FIXME: error
852        goto DONE;
853    }
854
855    unless (($ipv4 && $ipv4->header->ancount)
856        || ($ipv6 && $ipv6->header->ancount))
857    {
858        ## FIXME: error
859        goto DONE;
860    }
861
862    my @answers = ();
863    push @answers, $ipv4->answer if ($ipv4->header->ancount);
864    push @answers, $ipv6->answer if ($ipv6->header->ancount);
865
866    foreach my $rr (@answers) {
867        if (($rr->type eq "A" or $rr->type eq "AAAA") && $rr->address) {
868            push @addresses, $rr->address;
869        }
870    }
871
872  DONE:
873    $self->logger->auto("DNS:FIND_ADDRESSES_RESULT", $qname, $qclass,
874        join(",", @addresses));
875
876    return @addresses;
877}
878
879######################################################################
880
881sub address_is_authoritative {
882    my $self    = shift;
883    my $address = shift;
884    my $qname   = shift;
885    my $qclass  = shift;
886
887    my $logger = $self->logger;
888    my $errors = 0;
889
890    my $packet =
891      $self->query_explicit($qname, $qclass, "SOA", $address, { aaonly => 0 });
892
893    ## timeout is not considered an error
894    goto DONE unless ($packet);
895
896    $errors++ if ($packet->header->aa != 1);
897
898  DONE:
899    return $errors;
900}
901
902sub address_is_recursive {
903    my $self    = shift;
904    my $address = shift;
905    my $qclass  = shift;
906
907    my $logger = $self->logger;
908    my $errors = 0;
909
910    # no blacklisting here, since some nameservers ignore recursive queries
911
912    unless ($self->_querible($address)) {
913        goto DONE;
914    }
915
916    my $resolver = DNSCheck::Lookup::Resolver->new($self->parent);
917    $resolver->recursion(1);
918    $resolver->cdflag(1);
919
920    # create nonexisting domain name
921    my $nxdomain = "nxdomain.example.com";
922    my @tmp = split(/-/, bubblebabble(Digest => sha1(random_bytes(64))));
923    my $nonexisting = sprintf("%s.%s", join("", @tmp[1 .. 6]), $nxdomain);
924
925    my $qtype = "SOA";
926    my $packet = $resolver->get($nonexisting, $qtype, $qclass, $address);
927    if ($self->check_timeout($resolver)) {
928        $self->logger->auto("DNS:QUERY_TIMEOUT", $address, $nonexisting,
929            $qclass, $qtype);
930        goto DONE;
931    }
932
933    goto DONE unless $packet;
934
935    ## recursion available zero is ok
936    goto DONE if ($packet->header->ra == 0);
937
938    ## refused and servfail is ok
939    goto DONE if ($packet->header->rcode eq "REFUSED");
940    goto DONE if ($packet->header->rcode eq "SERVFAIL");
941
942    ## referral is ok
943    goto DONE
944      if (  $packet->header->rcode eq "NOERROR"
945        and $packet->header->ancount == 0
946        and $packet->header->nscount > 0);
947
948    $errors++;
949
950  DONE:
951    return $errors;
952}
953
954######################################################################
955
956sub check_axfr {
957    my $self    = shift;
958    my $address = shift;
959    my $qname   = shift;
960    my $qclass  = shift;
961
962    unless ($self->_querible($address)) {
963        return 0;
964    }
965
966    # set up resolver
967    my $resolver = new Net::DNS::Resolver;
968    $resolver->debug($self->{debug_resolver});
969    $resolver->recurse(0);
970    $resolver->dnssec(0);
971    $resolver->usevc(0);
972    $resolver->defnames(0);
973
974    $resolver->nameservers($address);
975    $resolver->axfr_start($qname, $qclass);
976
977    if ($resolver->axfr_next) {
978        return 1;
979    }
980
981    return 0;
982}
983
984######################################################################
985
986sub query_nsid {
987    my $self    = shift;
988    my $address = shift;
989    my $qname   = shift;
990    my $qclass  = shift;
991    my $qtype   = shift;
992
993    unless ($self->_querible($address)) {
994        return;
995    }
996
997    my $resolver = $self->_setup_resolver();
998    $resolver->nameservers($address);
999
1000    $resolver->debug(1);
1001
1002    my $optrr = new Net::DNS::RR {
1003        name          => "",
1004        type          => "OPT",
1005        class         => 1024,
1006        extendedrcode => 0x00,
1007        ednsflags     => 0x0000,
1008        optioncode    => 0x03,
1009        optiondata    => 0x00,
1010    };
1011
1012    print Dumper($optrr);
1013
1014    my $query = Net::DNS::Packet->new($qname, $qtype, $qclass);
1015    $query->push(additional => $optrr);
1016    $query->header->rd(0);
1017    $query->{'optadded'} = 1;
1018
1019    print Dumper($query);
1020
1021    my $response = $resolver->send($query);
1022
1023    # FIXME: incomplete implementation
1024
1025    return;
1026}
1027
1028######################################################################
1029
1030sub _rr2string {    # Why do this instead of using the native ->string method?
1031    my $rr = shift;
1032    my $rdatastr;
1033
1034    if ($rr->type eq "SOA") {
1035        $rdatastr = sprintf(
1036            "%s %s %d %d %d %d %d",
1037            $rr->mname, $rr->rname,  $rr->serial, $rr->refresh,
1038            $rr->retry, $rr->expire, $rr->minimum
1039        );
1040    } elsif ($rr->type eq "DS") {
1041        $rdatastr = sprintf("%d %d %d %s",
1042            $rr->keytag, $rr->algorithm, $rr->digtype, $rr->digest);
1043    } elsif ($rr->type eq "RRSIG") {
1044        $rdatastr = sprintf(
1045            "%s %d %d %d %s %s %d %s %s",
1046            $rr->typecovered, $rr->algorithm,     $rr->labels,
1047            $rr->orgttl,      $rr->sigexpiration, $rr->siginception,
1048            $rr->keytag,      $rr->signame,       "..."
1049        );
1050    } elsif ($rr->type eq "DNSKEY") {
1051        $rdatastr = sprintf("%d %d %d %s",
1052            $rr->flags, $rr->protocol, $rr->algorithm, "...");
1053    } else {
1054        $rdatastr = $rr->rdatastr;
1055    }
1056
1057    return sprintf("%s %d %s %s %s",
1058        $rr->name, $rr->ttl, $rr->class, $rr->type, $rdatastr);
1059}
1060
1061sub _querible {
1062    my $self    = shift;
1063    my $address = shift;
1064    my $conf    = $self->parent->config->get("net");
1065
1066    my $ip = new Net::IP($address);
1067
1068    if (   ($ip->version == 4 and !$conf->{ipv4})
1069        or ($ip->version == 6 and !$conf->{ipv6}))
1070    {
1071        return 0;
1072    } elsif (($ip->iptype ne "PUBLIC") and ($ip->iptype ne "GLOBAL-UNICAST")) {
1073        $self->logger->auto("DNS:UNQUERIBLE_ADDRESS", $address);
1074        return 0;
1075    } else {
1076        return 1;
1077    }
1078}
1079
1080######################################################################
1081
1082sub clear_blacklist {
1083    my $self = shift;
1084
1085    $self->{blacklist} = ();
1086}
1087
1088sub add_blacklist {
1089    my $self   = shift;
1090    my $qaddr  = shift;
1091    my $qname  = shift;
1092    my $qclass = shift;
1093    my $qtype  = shift;
1094
1095    $self->{blacklist}{$qaddr}{$qname}{$qclass}{$qtype} = 1;
1096}
1097
1098sub check_blacklist {
1099    my $self   = shift;
1100    my $qaddr  = shift;
1101    my $qname  = shift;
1102    my $qclass = shift;
1103    my $qtype  = shift;
1104
1105    return 1 if ($self->{blacklist}{$qaddr}{$qname}{$qclass}{$qtype});
1106    return 0;
1107}
1108
1109sub check_timeout {
1110    my $self = shift;
1111    my $res  = shift;
1112
1113    return 1 if ($res->errorstring eq "query timed out");
1114    return 0;
1115}
1116
1117######################################################################
1118
1119sub preflight_check {
1120    my $self     = shift;
1121    my $resolver = $self->{resolver};
1122    my $name     = shift;
1123
1124    my $packet = $resolver->recurse($name, 'NS');
1125
1126    # Can we find an NS record?
1127    if (defined($packet) and grep { $_->type eq 'NS' } $packet->answer) {
1128
1129        # Yup, return true
1130        return 1;
1131    } elsif (!defined($packet)) {
1132
1133        # Transmission error or something similar, fail on the safe side.
1134        return 1;
1135    }
1136
1137    $packet = $resolver->recurse($name, 'SOA');
1138    if (defined($packet) and grep { $_->type eq 'SOA' } $packet->answer) {
1139        return 1;
1140    } elsif (!defined($packet)) {
1141        return 1;
1142    }
1143
1144    # Was it SERVFAIL? If it was, return true.
1145    if ($resolver->errorstring eq 'SERVFAIL') {
1146        return 1;
1147    }
1148
1149    # No NS, no SOA, no successful return
1150    return;
1151}
1152
11531;
1154
1155__END__
1156
1157
1158=head1 NAME
1159
1160DNSCheck::Lookup::DNS - DNS Lookup
1161
1162=head1 DESCRIPTION
1163
1164Helper functions for looking up information in the DNS (Domain Name System).
1165
1166=head1 METHODS
1167
1168=over
1169
1170=item new($parent);
1171
1172Create a new lookup object. Not recommended to use, create a L<DNSCheck>
1173object and call the L<DNSCheck::dns> method instead.
1174
1175=item flush();
1176
1177Empty the cache and clear the blacklist.
1178
1179=item my $packet = $dns->query_resolver(I<qname>, I<qclass>, I<qtype>);
1180
1181Send a query to the default resolver(s). This will be a L<DNSCheck::Lookup::Resolver> object.
1182
1183=item my $packet = $dns->query_parent(I<zone>, I<qname>, I<qclass>, I<qtype>);
1184
1185=item my $packet = $dns->query_child(I<zone>, I<qname>, I<qclass>, I<qtype>);
1186
1187=item my $packet = $dns->query_explicit(I<qname>, I<qclass>, I<qtype>, I<address>, I<flags>);
1188
1189=item my $addrs = $dns->get_nameservers_ipv4(I<qname>, I<qclass>);
1190
1191=item my $addrs = $dns->get_nameservers_ipv6(I<qname>, I<qclass>);
1192
1193=item my $ns = $dns->get_nameservers_at_parent(I<qname>, I<qclass>);
1194
1195=item my $ns = $dns->get_nameservers_at_child(I<qname>, I<qclass>);
1196
1197=item $dns->init_nameservers(I<qname>, I<qclass>);
1198
1199=item my $parent = $dns->find_parent(I<qname>, I<qclass>);
1200
1201=item my @mx = $dns->find_mail_destination(I<domain>);
1202
1203=item my @addresses = $dns->find_addresses(I<qname>, I<qclass>);
1204
1205=item my $bool = $dns->address_is_authoritative(I<address>, I<qname>, I<qtype>);
1206
1207=item my $bool = $dns->address_is_recursive(I<address>, I<qclass>);
1208
1209=item my $bool = $dns->check_axfr(I<address>, I<qname>, I<qclass>);
1210
1211=item my $string = $dns->query_nsid(I<address>, I<qname>, I<qclass>, I<qtype>);
1212
1213These need to be documented better.
1214
1215=back
1216
1217=head1 EXAMPLES
1218
1219    use DNSCheck::Logger;
1220    use DNSCheck::Lookup::DNS;
1221
1222    my $logger = new DNSCheck::Logger;
1223    my $dns    = new DNSCheck::Lookup::DNS($logger);
1224
1225    my $parent = $dns->query_parent("nic.se", "ns.nic.se", "IN", "A");
1226
1227    $logger->dump();
1228
1229=head1 SEE ALSO
1230
1231L<DNSCheck::Logger>, L<DNSCheck::Lookup::DNS>
1232
1233=cut
1234