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