1# You may distribute under the terms of either the GNU General Public License 2# or the Artistic License (the same terms as Perl itself) 3# 4# (C) Paul Evans, 2011-2015 -- leonerd@leonerd.org.uk 5 6package IO::Async::Resolver::DNS; 7 8use strict; 9use warnings; 10 11our $VERSION = '0.06'; 12 13use Future; 14use IO::Async::Resolver 0.52; # returns Future 15 16use Carp; 17use Net::DNS; 18 19use List::UtilsBy qw( weighted_shuffle_by ); 20 21# Re-export the constants 22use IO::Async::Resolver::DNS::Constants qw( /^ERR_/ ); 23 24use Exporter 'import'; 25our @EXPORT_OK = @IO::Async::Resolver::DNS::Constants::EXPORT_OK; 26 27=head1 NAME 28 29C<IO::Async::Resolver::DNS> - resolve DNS queries using C<IO::Async> 30 31=head1 SYNOPSIS 32 33 use IO::Async::Loop; 34 use IO::Async::Resolver::DNS; 35 36 my $loop = IO::Async::Loop->new; 37 my $resolver = $loop->resolver; 38 39 $resolver->res_query( 40 dname => "cpan.org", 41 type => "MX", 42 )->then( sub { 43 my ( $pkt ) = @_; 44 45 foreach my $mx ( $pkt->answer ) { 46 next unless $mx->type eq "MX"; 47 48 printf "preference=%d exchange=%s\n", 49 $mx->preference, $mx->exchange; 50 } 51 })->get; 52 53=head1 DESCRIPTION 54 55This module extends the L<IO::Async::Resolver> class with extra methods and 56resolver functions to perform DNS-specific resolver lookups. It does not 57directly provide any methods or functions of its own. 58 59These functions are provided for performing DNS-specific lookups, to obtain 60C<MX> or C<SRV> records, for example. For regular name resolution, the usual 61C<getaddrinfo> and C<getnameinfo> methods on the standard 62C<IO::Async::Resolver> should be used. 63 64If L<Net::LibResolv> is installed then it will be used for actually sending 65and receiving DNS packets, in preference to a internally-constructed 66L<Net::DNS::Resolver> object. C<Net::LibResolv> will be more efficient and 67shares its implementation with the standard resolver used by the rest of the 68system. C<Net::DNS::Resolver> reimplements the logic itself, so it may have 69differences in behaviour from that provided by F<libresolv>. The ability to 70use the latter is provided to allow for an XS-free dependency chain, or for 71other situations where C<Net::LibResolv> is not available. 72 73=head2 Record Extraction 74 75If certain record type queries are made, extra information is returned to the 76C<on_resolved> continuation, containing the results from the DNS packet in a 77more useful form. This information will be in a list of extra values following 78the packet value. 79 80 my ( $pkt, @data ) = $f->get; 81 82 $on_resolved->( $pkt, @data ) 83 84The type of the elements in C<@data> will depend on the DNS record query type: 85 86=over 4 87 88=cut 89 90sub _extract 91{ 92 my ( $pkt, $type ) = @_; 93 94 my $code = __PACKAGE__->can( "_extract_$type" ) or return ( $pkt ); 95 96 return $code->( $pkt ); 97} 98 99=item * A and AAAA 100 101The C<A> or C<AAAA> records will be unpacked and returned in a list of 102strings. 103 104 @data = ( "10.0.0.1", 105 "10.0.0.2" ); 106 107 @data = ( "fd00:0:0:0:0:0:0:1" ); 108 109=cut 110 111*_extract_A = \&_extract_addresses; 112*_extract_AAAA = \&_extract_addresses; 113sub _extract_addresses 114{ 115 my ( $pkt ) = @_; 116 117 my @addrs; 118 119 foreach my $rr ( $pkt->answer ) { 120 push @addrs, $rr->address if $rr->type eq "A" or $rr->type eq "AAAA"; 121 } 122 123 return ( $pkt, @addrs ); 124} 125 126=item * PTR 127 128The C<PTR> records will be unpacked and returned in a list of domain names. 129 130 @data = ( "foo.example.com" ); 131 132=cut 133 134sub _extract_PTR 135{ 136 my ( $pkt ) = @_; 137 138 my @names; 139 140 foreach my $rr ( $pkt->answer ) { 141 push @names, $rr->ptrdname if $rr->type eq "PTR"; 142 } 143 144 return ( $pkt, @names ); 145} 146 147=item * MX 148 149The C<MX> records will be unpacked, in order of C<preference>, and returned in 150a list of HASH references. Each HASH reference will contain keys called 151C<exchange> and C<preference>. If the exchange domain name is included in the 152DNS C<additional> data, then the HASH reference will also include a key called 153C<address>, its value containing a list of C<A> and C<AAAA> record C<address> 154fields. 155 156 @data = ( { exchange => "mail.example.com", 157 preference => 10, 158 address => [ "10.0.0.1", "fd00:0:0:0:0:0:0:1" ] } ); 159 160=cut 161 162sub _extract_MX 163{ 164 my ( $pkt ) = @_; 165 166 my @mx; 167 my %additional; 168 169 foreach my $rr ( $pkt->additional ) { 170 push @{ $additional{$rr->name}{address} }, $rr->address if $rr->type eq "A" or $rr->type eq "AAAA"; 171 } 172 173 foreach my $ans ( sort { $a->preference <=> $b->preference } grep { $_->type eq "MX" } $pkt->answer ) { 174 my $exchange = $ans->exchange; 175 push @mx, { exchange => $exchange, preference => $ans->preference }; 176 $mx[-1]{address} = $additional{$exchange}{address} if $additional{$exchange}{address}; 177 } 178 return ( $pkt, @mx ); 179} 180 181=item * SRV 182 183The C<SRV> records will be unpacked and sorted first by order of priority, 184then by a weighted shuffle by weight, and returned in a list of HASH 185references. Each HASH reference will contain keys called C<priority>, 186C<weight>, C<target> and C<port>. If the target domain name is included in the 187DNS C<additional> data, then the HASH reference will also contain a key called 188C<address>, its value containing a list of C<A> and C<AAAA> record C<address> 189fields. 190 191 @data = ( { priority => 10, 192 weight => 10, 193 target => "server1.service.example.com", 194 port => 1234, 195 address => [ "10.0.1.1" ] } ); 196 197=cut 198 199sub _extract_SRV 200{ 201 my ( $pkt ) = @_; 202 203 my @srv; 204 my %additional; 205 206 foreach my $rr ( $pkt->additional ) { 207 push @{ $additional{$rr->name}{address} }, $rr->address if $rr->type eq "A" or $rr->type eq "AAAA"; 208 } 209 210 my %srv_by_prio; 211 # Need to work in two phases. Split by priority then shuffle within 212 foreach my $ans ( grep { $_->type eq "SRV" } $pkt->answer ) { 213 push @{ $srv_by_prio{ $ans->priority } }, $ans; 214 } 215 216 foreach my $prio ( sort { $a <=> $b } keys %srv_by_prio ) { 217 foreach my $ans ( weighted_shuffle_by { $_->weight || 1 } @{ $srv_by_prio{$prio} } ) { 218 my $target = $ans->target; 219 push @srv, { priority => $ans->priority, 220 weight => $ans->weight, 221 target => $target, 222 port => $ans->port }; 223 $srv[-1]{address} = $additional{$target}{address} if $additional{$target}{address}; 224 } 225 } 226 return ( $pkt, @srv ); 227} 228 229=back 230 231=head1 Error Reporting 232 233The two possible back-end modules that implement the resolver query functions 234provided here differ in their semantics for error reporting. To account for 235this difference and to lead to more portable user code, errors reported by the 236back-end modules are translated to one of the following (exported) constants. 237 238 ERR_NO_HOST # The specified host name does not exist 239 ERR_NO_ADDRESS # The specified host name does not provide answers for the 240 given query type 241 ERR_TEMPORARY # A temporary failure that may disappear on retry 242 ERR_UNRECOVERABLE # Any other error 243 244=cut 245 246=head1 RESOLVER METHODS 247 248The following methods documented with a trailing call to C<< ->get >> return 249L<Future> instances. 250 251=cut 252 253=head2 res_query 254 255 ( $pkt, @data ) = $resolver->res_query( %params )->get 256 257Performs a resolver query on the name, class and type, and invokes a 258continuation when a result is obtained. 259 260Takes the following named parameters: 261 262=over 8 263 264=item dname => STRING 265 266Domain name to look up 267 268=item type => STRING 269 270Name of the record type to look up (e.g. C<MX>) 271 272=item class => STRING 273 274Name of the record class to look up. Defaults to C<IN> so normally this 275argument is not required. 276 277=back 278 279On failure on C<IO::Async> versions that support extended failure results 280(0.68 and later), the extra detail will be an error value matching one of the 281C<ERR_*> constants listed above. 282 283 ->fail( $message, resolve => res_query => $errnum ) 284 285Note that due to the two possible back-end implementations it is not 286guaranteed that messages have any particular format; they are intended for 287human consumption only, and the C<$errnum> value should be used for making 288decisions in other code. 289 290When not returning a C<Future>, the following extra arguments are used as 291callbacks instead: 292 293=over 8 294 295=item on_resolved => CODE 296 297Continuation which is invoked after a successful lookup. Will be passed a 298L<Net::DNS::Packet> object containing the result. 299 300 $on_resolved->( $pkt ) 301 302For certain query types, this continuation may also be passed extra data in a 303list after the C<$pkt> 304 305 $on_resolved->( $pkt, @data ) 306 307See the B<Record Extraction> section above for more detail. 308 309=item on_error => CODE 310 311Continuation which is invoked after a failed lookup. 312 313=back 314 315=cut 316 317sub IO::Async::Resolver::res_query 318{ 319 my $self = shift; 320 my %args = @_; 321 322 my $dname = $args{dname} or croak "Expected 'dname'"; 323 my $class = $args{class} || "IN"; 324 my $type = $args{type} or croak "Expected 'type'"; 325 326 my $on_resolved = delete $args{on_resolved}; 327 !$on_resolved or ref $on_resolved or croak "Expected 'on_resolved' to be a reference"; 328 329 my $f = $self->resolve( 330 type => "res_query", 331 data => [ $dname, $class, $type ], 332 )->then( sub { 333 my ( $data ) = @_; 334 my $pkt = Net::DNS::Packet->new( \$data ); 335 Future->done( _extract( $pkt, $type ) ); 336 }); 337 338 $f->on_done( $on_resolved ) if $on_resolved; 339 $f->on_fail( $args{on_error} ) if $args{on_error}; 340 341 $self->adopt_future( $f ) unless defined wantarray; 342 343 return $f; 344} 345 346=head2 res_search 347 348Performs a resolver query on the name, class and type, and invokes a 349continuation when a result is obtained. Identical to C<res_query> except that 350it additionally implements the default domain name search behaviour. 351 352=cut 353 354sub IO::Async::Resolver::res_search 355{ 356 my $self = shift; 357 my %args = @_; 358 359 my $dname = $args{dname} or croak "Expected 'dname'"; 360 my $class = $args{class} || "IN"; 361 my $type = $args{type} or croak "Expected 'type'"; 362 363 my $on_resolved = delete $args{on_resolved}; 364 !$on_resolved or ref $on_resolved or croak "Expected 'on_resolved' to be a reference"; 365 366 my $f = $self->resolve( 367 type => "res_search", 368 data => [ $dname, $class, $type ], 369 )->then( sub { 370 my ( $data ) = @_; 371 my $pkt = Net::DNS::Packet->new( \$data ); 372 Future->done( _extract( $pkt, $type ) ); 373 }); 374 375 $f->on_done( $on_resolved ) if $on_resolved; 376 $f->on_fail( $args{on_error} ) if $args{on_error}; 377 378 $self->adopt_future( $f ) unless defined wantarray; 379 380 return $f; 381} 382 383# We'd prefer to use libresolv to actually talk DNS as it'll be more efficient 384# and more standard to the OS 385my @impls = qw( 386 LibResolvImpl 387 NetDNSImpl 388); 389 390while( !defined &res_query ) { 391 die "Unable to load an IO::Async::Resolver::DNS implementation\n" unless @impls; 392 eval { require "IO/Async/Resolver/DNS/" . shift(@impls) . ".pm" }; 393} 394 395IO::Async::Resolver::register_resolver res_query => \&res_query; 396IO::Async::Resolver::register_resolver res_search => \&res_search; 397 398=head1 AUTHOR 399 400Paul Evans <leonerd@leonerd.org.uk> 401 402=cut 403 4040x55AA; 405