1#!/usr/bin/perl 2# 3# $Id: Resolver.pm 883 2010-06-15 08:27:51Z 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::Resolver; 32 33require 5.008; 34use warnings; 35use strict; 36 37our $SVN_VERSION = '$Revision: 883 $'; 38 39use YAML; 40use Net::IP; 41use Time::HiRes qw[gettimeofday tv_interval]; 42 43# In order to be able to know for sure where certain information comes from, 44# and/or modify parts of resolver chains, we need to do our own recursive 45# lookups rather than rely on an external caching recursive resolver. This 46# module is supposed to do recursive lookups. It seems to work, but was 47# written by someone who is not a DNS expert, so comments on the module logic 48# is very welcome. 49sub new { 50 my $class = shift; 51 my $parent = shift; 52 my $self = {}; 53 54 bless $self, $class; 55 56 $self->{parent} = $parent; 57 58 my $config = $self->config->get("dns"); 59 $self->{debug} = $parent->config->get("debug"); 60 $self->{debug} -= 1 if $self->{debug}; 61 62 $self->{cache} = $parent->config->get('root_zone_data'); 63 $self->{current} = ''; 64 65 $self->{resolver} = Net::DNS::Resolver->new( 66 67 # RFC3330 reserved address. As close to guaranteed *not* to have a nameserver 68 # on it as we're likely to get (the module does not accept an empty list). 69 nameservers => ['192.0.2.1'], 70 ); 71 $self->{resolver}->persistent_tcp(0); 72 $self->{resolver}->cdflag(1); 73 $self->{resolver}->recurse(0); 74 $self->{resolver}->dnssec(0); 75 $self->{resolver}->debug(1) if ($self->{debug} and $self->{debug} > 1); 76 $self->{resolver}->udp_timeout($config->{udp_timeout}); 77 $self->{resolver}->tcp_timeout($config->{tcp_timeout}); 78 $self->{resolver}->retry($config->{retry}); 79 $self->{resolver}->retrans($config->{retrans}); 80 81 $self->{ipv6} = $parent->config->get("net")->{ipv6}; 82 $self->{ipv4} = $parent->config->get("net")->{ipv4}; 83 84 return $self; 85} 86 87# Standard utility methods 88sub resolver { 89 return $_[0]->{resolver}; 90} 91 92sub parent { 93 return $_[0]->{parent}; 94} 95 96sub cache { 97 return $_[0]->{cache}; 98} 99 100sub config { 101 return $_[0]->parent->config; 102} 103 104sub logger { 105 return $_[0]->parent->logger; 106} 107 108# Timing information 109 110sub times { 111 my $self = shift; 112 113 $self->{times} ||= {}; 114 return $self->{times}; 115} 116 117# Interface methods to underlying Net::DNS::Resolver object 118 119sub errorstring { 120 my $self = shift; 121 122 return $self->resolver->errorstring(@_); 123} 124 125sub dnssec { 126 my $self = shift; 127 128 return $self->resolver->dnssec(@_); 129} 130 131sub recursion { 132 my $self = shift; 133 134 return $self->resolver->recurse(@_); 135} 136 137sub cdflag { 138 my $self = shift; 139 140 return $self->resolver->cdflag(@_); 141} 142 143# Methods to support undelegated testing 144 145sub add_fake_glue { 146 my $self = shift; 147 my $zone = shift; 148 my $nsname = shift; 149 my $nsip = shift; 150 151 return unless Net::IP->new($nsip); 152 153 $nsname = $self->canonicalize_name($nsname); 154 $zone = $self->canonicalize_name($zone); 155 156 $self->cache->{ns}{$zone}{$nsname} = 1; 157 $self->cache->{ips}{$nsname}{$nsip} = 1; 158 $self->{fake}{ns}{$zone} = 1; 159 $self->{fake}{ips}{$nsname} = 1; 160 161 return $self; 162} 163 164# Return a list of zones with fake glue 165sub faked_zones { 166 my $self = shift; 167 168 return 169 map { my $tmp = $_; $tmp =~ s/\.$//; $tmp } keys %{ $self->{fake}{ns} }; 170} 171 172# Return a list of NS names for a zone with fake glue 173sub faked_zone { 174 my $self = shift; 175 my $name = shift; 176 177 $name = $self->canonicalize_name($name); 178 179 if ($self->{fake}{ns}{$name}) { 180 return map { my $tmp = $_; $tmp =~ s/\.$//; $tmp } 181 keys %{ $self->cache->{ns}{$name} }; 182 } else { 183 return; 184 } 185} 186 187# Return a made-up packet with information for a name 188sub fake_packet { 189 my $self = shift; 190 my $zone = shift; 191 my $name = shift; 192 my $type = shift; 193 194 $name = $self->canonicalize_name($name); 195 196 my @ns = $self->faked_zone($zone); 197 my @ips = keys %{ $self->cache->{ips}{$name} }; 198 my $version; 199 200 if ($type eq 'A') { 201 $version = 4; 202 } elsif ($type eq 'AAAA') { 203 $version = 6; 204 } else { 205 return; # Can't or won't fake that 206 } 207 208 @ips = 209 map { $_->ip } 210 grep { defined($_) and $_->version == $version } 211 map { Net::IP->new($_) } @ips; 212 213 my $p = Net::DNS::Packet->new; 214 215 $p->unique_push('answer', Net::DNS::RR->new("$name 4711 IN $type $_")) 216 for @ips; 217 218 for my $ns (@ns) { 219 $p->unique_push('authority', Net::DNS::RR->new("$zone 4711 IN NS $ns")); 220 for my $ip ( 221 keys %{ $self->cache->{ips}{ $self->canonicalize_name($ns) } }) 222 { 223 my $t = (Net::IP->new($ip)->version == 4) ? 'A' : 'AAAA'; 224 $p->unique_push('additional', 225 Net::DNS::RR->new("$ns 4711 IN $t $ip")); 226 } 227 } 228 229 $p->header->aa(1); 230 231 return $p; 232} 233 234# Add stuff to our cache. 235# 236# We cache known nameserver lists for names, and IP addresses for names. 237sub remember { 238 my ($self, $p) = @_; 239 240 return unless defined($p); 241 242 foreach my $rr ($p->answer, $p->additional, $p->authority) { 243 my $n = $self->canonicalize_name($rr->name); 244 if ($rr->type eq 'A' or $rr->type eq 'AAAA') { 245 $self->{cache}{ips}{$n}{ Net::IP->new($rr->address)->ip } = 1 246 unless $self->{fake}{ips}{$n}; 247 } 248 if ($rr->type eq 'NS') { 249 print STDERR "remember: NS $n (" 250 . $rr->name . ") " 251 . $rr->nsdname . ".\n" 252 if $self->{debug}; 253 $self->{cache}{ns}{$n}{ $self->canonicalize_name($rr->nsdname) } = 1 254 unless $self->{fake}{ns}{$n}; 255 } 256 } 257 258 return $self; 259} 260 261# Class method to generate data with which to preload the cache. 262sub get_preload_data { 263 my $self = shift; 264 my $source = shift; 265 my %cache; 266 267 my $res = Net::DNS::Resolver->new; 268 $res->nameservers($source) if defined($source); 269 my $z = $res->send('.', 'IN', 'NS'); 270 271 if (!defined($z) or $z->header->ancount == 0) { 272 die "Failed to get root zone data"; 273 } 274 275 foreach my $rr ($z->answer) { 276 next unless $rr->type eq 'NS'; 277 278 $cache{ns}{'.'}{ $self->canonicalize_name($rr->nsdname) } = 1; 279 } 280 281 foreach my $nsname (keys %{ $cache{ns}{'.'} }) { 282 $nsname = $self->canonicalize_name($nsname); 283 284 my $a = $res->send($nsname, 'IN', 'A'); 285 next if (!defined($a) or $a->header->ancount == 0); 286 foreach my $rr ($a->answer) { 287 next unless $rr->type eq 'A'; 288 289 $cache{ips}{$nsname}{ $rr->address } = 1; 290 } 291 292 my $aaaa = $res->send($nsname, 'IN', 'AAAA'); 293 next if (!defined($aaaa) or $aaaa->header->ancount == 0); 294 foreach my $rr ($aaaa->answer) { 295 next unless $rr->type eq 'AAAA'; 296 297 $cache{ips}{$nsname}{ $rr->address } = 1; 298 } 299 } 300 301 return \%cache; 302} 303 304# Reformat a name into a standardized form, for ease of comparison 305sub canonicalize_name { 306 my $self = shift; 307 my $name = shift; 308 309 my $i = Net::IP->new($name); 310 if ($name and $name =~ m|^[0-9.:]+$| and defined($i)) { 311 $name = $i->reverse_ip; 312 } 313 314 $name = lc($name); 315 316 $name .= '.' unless substr($name, -1) eq '.'; 317 318 return $name; 319} 320 321# Strip the leftmost label off a DNS name. If there are no labels left after 322# removing one, returns a single period for the root level. 323sub strip_label { 324 my $self = shift; 325 my $name = shift; 326 327 my @labels = split /\./, $name; 328 shift @labels; 329 330 if (@labels) { 331 return $self->canonicalize_name(join '.', @labels); 332 } else { 333 return '.'; 334 } 335} 336 337# Take a name, and return the nameserver names for the highest parent level we 338# have in cache. Which, at worst, will be the root zone, the data for which we 339# initialize on object creation. 340sub highest_known_ns { 341 my $self = shift; 342 my $name = shift; 343 344 $name = $self->canonicalize_name($name); 345 346 # If there are more than one zone with fake glue, and one is a parent of 347 # another, choose the one with the most labels in it. 348 my $faked = ( 349 sort { $b =~ y/././ <=> $a =~ y/././ } 350 grep { $name =~ /\Q$_\E$/ } $self->faked_zones 351 )[0]; 352 353 if ($faked) { 354 return keys %{ $self->cache->{ns}{$faked} }; 355 } 356 357 my @candidates; 358 while (1) { 359 my @tmp = 360 $self->simple_names_to_ips(keys %{ $self->{cache}{ns}{$name} }) 361 if $self->{cache}{ns}{$name}; 362 push @candidates, @tmp if @tmp; 363 364 if ($name eq '.') { 365 last; 366 } 367 368 $name = $self->strip_label($name); 369 } 370 371 if (!@candidates) { 372 die "Root zone cache missing."; 373 } else { 374 return @candidates; 375 } 376} 377 378sub simple_names_to_ips { 379 my $self = shift; 380 my @names = map { $self->canonicalize_name($_) } @_; 381 my @ips; 382 383 foreach my $n (@names) { 384 if ($self->cache->{ips}{$n}) { 385 push @ips, keys %{ $self->cache->{ips}{$n} }; 386 } 387 } 388 389 return @ips; 390} 391 392sub names_to_ips { 393 my $self = shift; 394 my @names = map { $self->canonicalize_name($_) } @_; 395 my @ips; 396 397 foreach my $n (@names) { 398 if ($self->cache->{ips}{$n}) { 399 push @ips, keys %{ $self->cache->{ips}{$n} }; 400 } else { 401 next if $self->{poison}{$n}; 402 $self->{poison}{$n} = 1; # Block lookups of this name 403 my $p = $self->recurse($n, 'A'); 404 $self->remember($p); 405 406 if ($self->cache->{ips}{$n}) { 407 push @ips, keys %{ $self->cache->{ips}{$n} }; 408 $self->{poison}{$n} = 0; # Allow lookups of name 409 } 410 } 411 } 412 413 return @ips; 414} 415 416# Send a query to a specified set of nameservers and return the result. 417sub get { 418 my $self = shift; 419 my $name = shift; 420 my $type = shift || 'NS'; 421 my $class = shift || 'IN'; 422 my @ns = @_; 423 424 print STDERR "get: $name $type $class @ns " . (caller(1))[3] . "\n" 425 if $self->{debug}; 426 427 @ns = map { $_->ip } grep { 428 ($_->version == 4 and $self->{ipv4}) 429 or ($_->version == 6 and $self->{ipv6}) 430 } map { 431 Net::IP->new($_) 432 } @ns; 433 434 return unless @ns; 435 436 my @ns_old = $self->{resolver}->nameservers; 437 $self->{resolver}->nameservers(@ns) if @ns; 438 439 my $before = [gettimeofday()]; 440 my $p = $self->{resolver}->send($name, $class, $type); 441 my $duration = tv_interval($before); 442 443 if ($p and $p->answerfrom) { 444 push @{ $self->times->{ $p->answerfrom } }, $duration; 445 } 446 447 print STDERR "get: " . $p->string . "\n" 448 if (defined($p) and $self->{debug} and $self->{debug} > 1); 449 $self->remember($p) if defined($p); 450 451 $self->{resolver}->nameservers(@ns_old); 452 return $p; 453} 454 455# Recursively look up stuff. 456# 457# Resolution procedure of a name 458# ============================== 459# 460# 1. Get ns names for the highest level we know of (root, probably). 461# 462# 2. Do name-to-ip for names. Discard names we can't translate. 463# 464# 3. Push IPs on stack of servers to ask, unless they've already been there. 465# 466# 4. Pop IP from stack. Send question to it. Remember we asked it. 467# If the stack is empty, return undef. 468# 469# 5. If we get a response, clear the stack. 470# 471# 6. If the reply is authoritative, return it. 472# If it is not, but contains records in Authority section, get names from 473# those records and go to 2, unless the records point to a name higher in 474# the chain, in which case we terminate and return undef. 475 476sub recurse { 477 my ($self, $name, $type, $class, $cnames) = @_; 478 $type ||= 'NS'; 479 $class ||= 'IN'; 480 $cnames ||= {}; 481 482 print STDERR "recurse: $name $type $class\n" if $self->{debug}; 483 484 # See if it should be faked 485 if (($type eq 'A' or $type eq 'AAAA') 486 and $self->{fake}{ips}{ $self->canonicalize_name($name) }) 487 { 488 return $self->fake_packet(undef, $name, $type); 489 } 490 491 my @stack = $self->highest_known_ns($name); 492 my %seen; 493 my $candidate; 494 495 my $level = -1; 496 497 while (@stack) { 498 my $ns = pop(@stack); 499 print STDERR "recurse: Popped $ns (stack is " 500 . scalar(@stack) 501 . " entries deep).\n" 502 if $self->{debug}; 503 $seen{$ns} = 1; 504 my $p = $self->get($name, $type, $class, $ns); 505 if (!defined($p)) { 506 print STDERR "recurse: No response packet.\n" if $self->{debug}; 507 next; 508 } elsif ($p->header->aa) { 509 print STDERR "recurse: Authoritative response.\n" if $self->{debug}; 510 511 if ( $p->header->rcode ne 'NOERROR' 512 and $p->header->rcode ne 'NXDOMAIN') 513 { 514 print STDERR 515 "recurse: ...but it's not good. Saving as candidate.\n" 516 if $self->{debug}; 517 $candidate = $p; 518 next; 519 } 520 521 if ( $type ne 'CNAME' 522 and $p->header->ancount > 0 523 and grep { $_->type eq 'CNAME' } $p->answer) 524 { 525 print STDERR "recurse: Resolving CNAME.\n" if $self->{debug}; 526 my $cnamerr = (grep { $_->type eq 'CNAME' } $p->answer)[0]; 527 return $p if $cnames->{ $cnamerr->cname }; # Break loops 528 $cnames->{ $cnamerr->cname } = 1; 529 my $tmp = 530 $self->recurse($cnamerr->cname, $type, $class, $cnames); 531 if ($tmp) { 532 print STDERR "recurse: Adding CNAME to response packet.\n" 533 if $self->{debug}; 534 $tmp->unique_push(answer => $cnamerr) 535 unless (keys %$cnames) > 1; 536 return $tmp; 537 } else { 538 return $p; 539 } 540 } 541 542 return $p; 543 } elsif ($p->header->rcode ne 'NOERROR') { 544 print STDERR "recurse: Response code " . $p->header->rcode . "\n" 545 if $self->{debug}; 546 $candidate = $p unless $candidate; 547 next; 548 } elsif ( 549 $p->header->ancount > 0 and grep { 550 $_->type eq 'CNAME' 551 } $p->answer 552 ) 553 { 554 print STDERR "recurse: Resolving non-auth CNAME.\n" 555 if $self->{debug}; 556 my $cnamerr = (grep { $_->type eq 'CNAME' } $p->answer)[0]; 557 return $p if $cnames->{ $cnamerr->cname }; # Break loops 558 $cnames->{ $cnamerr->cname } = 1; 559 my $tmp = $self->recurse($cnamerr->cname, $type, $class, $cnames); 560 if ($tmp) { 561 print STDERR "recurse: Adding CNAME to response packet.\n" 562 if $self->{debug}; 563 $tmp->unique_push(answer => $cnamerr) 564 unless (keys %$cnames) > 1; 565 return $tmp; 566 } else { 567 return $p; 568 } 569 } elsif ($p->header->nscount > 0) { 570 571 my $zname = ($p->authority)[0]->name; 572 my $m = $self->matching_labels($name, $zname); 573 574 if ($m < $level) { 575 print STDERR "recurse: Bad referral. Skipping to next server.\n" 576 if $self->{debug}; 577 next; # Resolving chain redirecting up 578 } 579 580 $level = $m; 581 582 print STDERR "recurse: Got " 583 . scalar($p->authority) 584 . " authority records. Reloading stack.\n" 585 if $self->{debug}; 586 @stack = (); 587 588 $self->remember($p); 589 if (my @fns = $self->faked_zone($zname)) { 590 push @stack, 591 grep { !$seen{$_} } $self->simple_names_to_ips(@fns); 592 } else { 593 push @stack, grep { !$seen{$_} } $self->names_to_ips( 594 map { $_->nsdname } 595 grep { $_->type eq 'NS' } $p->authority 596 ); 597 } 598 next; 599 } else { 600 print STDERR "recurse: Fell through: " . $p->print 601 if $self->{debug}; 602 } 603 } 604 605 print STDERR "recurse: Ran out of servers.\n" if $self->{debug}; 606 607 # Ran out of servers before we got a good reply, return what we've got 608 if ($candidate) { 609 return $candidate; 610 } else { 611 return; 612 } 613} 614 615sub matching_labels { 616 my $self = shift; 617 my ($n1, $n2) = @_; 618 619 my @n1 = reverse split /\./, $n1; 620 my @n2 = reverse split /\./, $n2; 621 my $count = 0; 622 623 while (@n1 and @n2) { 624 my $i = shift @n1; 625 my $j = shift @n2; 626 627 if ($i eq $j) { 628 $count += 1; 629 } else { 630 last; 631 } 632 } 633 634 return $count; 635} 636 637=head1 NAME 638 639DNSCheck::Lookup::Resolver - a recursive DNS resolver for DNSCheck 640 641=head1 DESCRIPTION 642 643This module does recursive lookups, and is heavily used by L<DNSCheck::Lookup::DNS>. 644 645=head1 METHODS 646 647=over 648 649=item ->new($parent) 650 651Creates and configures a new resolver object. The parent object should be a 652L<DNSCheck> object, and it will be used to find DNS resolver configuration 653information. 654 655=item ->get($name, $type, $class, @nameservers) 656 657Send a DNS query to specified servers. 658 659=item ->recurse($name, $type, [$class]) 660 661Do a recursive query. If the class is not specified, it defaults to IN. 662 663=back 664 665=cut 666