lib/AnyEvent/DNS.pm

=head1 NAME

AnyEvent::DNS - fully asynchronous DNS resolution

=head1 SYNOPSIS

 use AnyEvent::DNS;

=head1 DESCRIPTION

This module offers both a number of DNS convenience functions as well
as a fully asynchronous and high-performance pure-perl stub resolver.

=head2 CONVENIENCE FUNCTIONS

# none yet

=over 4

=cut

package AnyEvent::DNS;

use strict;

use AnyEvent::Util ();

=back

=head2 DNS EN-/DECODING FUNCTIONS

=over 4

=cut

our %opcode_id = (
   query  => 0,
   iquery => 1,
   status => 2,
   map +($_ => $_), 3..15
);

our %opcode_str = reverse %opcode_id;

our %rcode_id = (
   ok       => 0,
   formerr  => 1,
   servfail => 2,
   nxdomain => 3,
   notimp   => 4,
   refused  => 5,
   map +($_ => $_), 6..15
);

our %rcode_str = reverse %rcode_id;

our %type_id = (
   a     =>   1,
   ns    =>   2,
   md    =>   3,
   mf    =>   4,
   cname =>   5,
   soa   =>   6,
   mb    =>   7,
   mg    =>   8,
   mr    =>   9,
   null  =>  10,
   wks   =>  11,
   ptr   =>  12,
   hinfo =>  13,
   minfo =>  14,
   mx    =>  15,
   txt   =>  16,
   aaaa  =>  28,
   srv   =>  33,
   axfr  => 252,
   mailb => 253,
   "*"   => 255,
);

our %type_str = reverse %type_id;

our %class_id = (
   in  =>   1,
   ch  =>   3,
   hs  =>   4,
   "*" => 255,
);

our %class_str = reverse %class_id;

# names MUST have a trailing dot
sub _enc_qname($) {
   pack "(C/a)*", (split /\./, shift), ""
}

sub _enc_qd() {
   (_enc_qname $_->[0]) . pack "nn",
     ($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}),
     ($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] || "in"})
}

sub _enc_rr() {
   die "encoding of resource records is not supported";
}

=item $pkt = AnyEvent::DNS::dns_pack $dns

Packs a perl data structure into a DNS packet. Reading RFC1034 is strongly
recommended, then everything will be totally clear. Or maybe not.

Resource records are not yet encodable.

Examples:

  # very simple request, using lots of default values:
  { rd => 1, qd => [ [ "host.domain", "a"] ] }

  # more complex example, showing how flags etc. are named:

  {
     id => 10000,
     op => "query",
     rc => "nxdomain",

     # flags
     qr => 1,
     aa => 0,
     tc => 0,
     rd => 0,
     ra => 0,

     qd => [@rr], # query section
     an => [@rr], # answer section
     ns => [@rr], # authority section
     ar => [@rr], # additional records section
  }

=cut

sub dns_pack($) {
   my ($req) = @_;

   pack "nn nnnn a* a* a* a*",
      $req->{id},

      ! !$req->{qr}   * 0x8000
      + $opcode_id{$req->{op}} * 0x0800
      + ! !$req->{aa} * 0x0400
      + ! !$req->{tc} * 0x0200
      + ! !$req->{rd} * 0x0100
      + ! !$req->{ra} * 0x0080
      + $rcode_id{$req->{rc}} * 0x0001,

      scalar @{ $req->{qd} || [] },
      scalar @{ $req->{an} || [] },
      scalar @{ $req->{ns} || [] },
      scalar @{ $req->{ar} || [] },

      (join "", map _enc_qd, @{ $req->{qd} || [] }),
      (join "", map _enc_rr, @{ $req->{an} || [] }),
      (join "", map _enc_rr, @{ $req->{ns} || [] }),
      (join "", map _enc_rr, @{ $req->{ar} || [] });
}

our $ofs;
our $pkt;

# bitches
sub _dec_qname {
   my @res;
   my $redir;
   my $ptr = $ofs;
   my $cnt;

   while () {
      return undef if ++$cnt >= 256; # to avoid DoS attacks

      my $len = ord substr $pkt, $ptr++, 1;

      if ($len & 0xc0) {
         $ptr++;
         $ofs = $ptr if $ptr > $ofs;
         $ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff;
      } elsif ($len) {
         push @res, substr $pkt, $ptr, $len;
         $ptr += $len;
      } else {
         $ofs = $ptr if $ptr > $ofs;
         return join ".", @res;
      }
   }
}

sub _dec_qd {
   my $qname = _dec_qname;
   my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;
   [$qname, $type_str{$qt} || $qt, $class_str{$qc} || $qc]
}

our %dec_rr = (
     1 => sub { Socket::inet_ntoa $_ }, # a
     2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns
     5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname
     6 => sub { 
             local $ofs = $ofs - length;
             my $mname = _dec_qname;
             my $rname = _dec_qname;
             ($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)
          }, # soa
    11 => sub { ((Socket::inet_aton substr $_, 0, 4), unpack "C a*", substr $_, 4) }, # wks
    12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr
    13 => sub { unpack "C/a C/a", $_ },
    15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_qname) }, # mx
    16 => sub { unpack "C/a", $_ }, # txt
    28 => sub { sprintf "%04x:%04x:%04x:%04x:%04x:%04x:%04x:%04x", unpack "n8" }, # aaaa
    33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_qname) }, # srv
);

sub _dec_rr {
   my $qname = _dec_qname;

   my ($rt, $rc, $ttl, $rdlen) = unpack "nn N n", substr $pkt, $ofs; $ofs += 10;
   local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;

   [
      $qname,
      $type_str{$rt}  || $rt,
      $class_str{$rc} || $rc,
      ($dec_rr{$rt} || sub { $_ })->(),
   ]
}

=item $dns = AnyEvent::DNS::dns_unpack $pkt

Unpacks a DNS packet into a perl data structure.

Examples:

  # a non-successful reply
  {
    'qd' => [
              [ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]
            ],
    'rc' => 'nxdomain',
    'ar' => [],
    'ns' => [
              [
                'uni-karlsruhe.de',
                'soa',
                'in',
                'netserv.rz.uni-karlsruhe.de',
                'hostmaster.rz.uni-karlsruhe.de',
                2008052201,
                10800,
                1800,
                2592000,
                86400
              ]
            ],
    'tc' => '',
    'ra' => 1,
    'qr' => 1,
    'id' => 45915,
    'aa' => '',
    'an' => [],
    'rd' => 1,
    'op' => 'query'
  }

  # a successful reply

  {
    'qd' => [ [ 'www.google.de', 'a', 'in' ] ],
    'rc' => 0,
    'ar' => [
              [ 'a.l.google.com', 'a', 'in', '209.85.139.9' ],
              [ 'b.l.google.com', 'a', 'in', '64.233.179.9' ],
              [ 'c.l.google.com', 'a', 'in', '64.233.161.9' ],
            ],
    'ns' => [
              [ 'l.google.com', 'ns', 'in', 'a.l.google.com' ],
              [ 'l.google.com', 'ns', 'in', 'b.l.google.com' ],
            ],
    'tc' => '',
    'ra' => 1,
    'qr' => 1,
    'id' => 64265,
    'aa' => '',
    'an' => [
              [ 'www.google.de', 'cname', 'in', 'www.google.com' ],
              [ 'www.google.com', 'cname', 'in', 'www.l.google.com' ],
              [ 'www.l.google.com', 'a', 'in', '66.249.93.104' ],
              [ 'www.l.google.com', 'a', 'in', '66.249.93.147' ],
            ],
    'rd' => 1,
    'op' => 0
  }

=cut

sub dns_unpack($) {
   local $pkt = shift;
   my ($id, $flags, $qd, $an, $ns, $ar)
      = unpack "nn nnnn A*", $pkt;

   local $ofs = 6 * 2;

   {
      id => $id,
      qr => ! ! ($flags & 0x8000),
      aa => ! ! ($flags & 0x0400),
      tc => ! ! ($flags & 0x0200),
      rd => ! ! ($flags & 0x0100),
      ra => ! ! ($flags & 0x0080),
      op => $opcode_str{($flags & 0x001e) >> 11},
      rc => $rcode_str{($flags & 0x000f)},

      qd => [map _dec_qd, 1 .. $qd],
      an => [map _dec_rr, 1 .. $an],
      ns => [map _dec_rr, 1 .. $ns],
      ar => [map _dec_rr, 1 .. $ar],
   }
}

#############################################################################

=back

=head2 THE AnyEvent::DNS RESOLVER CLASS

This is the class which deos the actual protocol work.

=over 4

=cut

use Carp ();
use Scalar::Util ();
use Socket ();

our $NOW;

=item $resolver = new AnyEvent::DNS key => value...

Creates and returns a new resolver. The following options are supported:

=over 4

=item server => [...]

A list of server addressses (default C<v127.0.0.1>) in network format (4
octets for IPv4, 16 octets for IPv6 - not yet supported).

=item timeout => [...]

A list of timeouts to use (also determines the number of retries). To make
three retries with individual time-outs of 2, 5 and 5 seconds, use C<[2,
5, 5]>, which is also the default.

=item search => [...]

The default search list of suffixes to append to a domain name (default: none).

=item ndots => $n

The number of dots (default: C<1>) that a name must have so that the resolver
tries to resolve the name without any suffixes first.

=item max_outstanding => $n

Most name servers do not handle many parallel requests very well. This option
limits the numbe rof outstanding requests to C<$n> (default: C<10>), that means
if you request more than this many requests, then the additional requests will be queued
until some other requests have been resolved.

=back

=cut

sub new {
   my ($class, %arg) = @_;

   socket my $fh, &Socket::AF_INET, &Socket::SOCK_DGRAM, 0
      or Carp::croak "socket: $!";

   AnyEvent::Util::fh_nonblocking $fh, 1;

   my $self = bless {
      server  => [v127.0.0.1],
      timeout => [2, 5, 5],
      search  => [],
      ndots   => 1,
      max_outstanding => 10,
      reuse   => 300, # reuse id's after 5 minutes only, if possible
      %arg,
      fh      => $fh,
      reuse_q => [],
   }, $class;

   # search should default to gethostname's domain
   # but perl lacks a good posix module

   Scalar::Util::weaken (my $wself = $self);
   $self->{rw} = AnyEvent->io (fh => $fh, poll => "r", cb => sub { $wself->_recv });

   $self->_compile;

   $self
}

=item $resolver->parse_resolv_conv ($string)

Parses the given string a sif it were a F<resolv.conf> file. The following
directives are supported:

C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,
C<options> (C<timeout>, C<attempts>, C<ndots>).

Everything else is silently ignored.

=cut

sub parse_resolv_conf {
   my ($self, $resolvconf) = @_;

   $self->{server} = [];
   $self->{search} = [];

   my $attempts;

   for (split /\n/, $resolvconf) {
      if (/^\s*#/) {
         # comment
      } elsif (/^\s*nameserver\s+(\S+)\s*$/i) {
         my $ip = $1;
         if (AnyEvent::Util::dotted_quad $ip) {
            push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip;
         } else {
            warn "nameserver $ip invalid and ignored\n";
         }
      } elsif (/^\s*domain\s+(\S*)\s+$/i) {
         $self->{search} = [$1];
      } elsif (/^\s*search\s+(.*?)\s*$/i) {
         $self->{search} = [split /\s+/, $1];
      } elsif (/^\s*sortlist\s+(.*?)\s*$/i) {
         # ignored, NYI
      } elsif (/^\s*options\s+(.*?)\s*$/i) {
         for (split /\s+/, $1) {
            if (/^timeout:(\d+)$/) {
               $self->{timeout} = [$1];
            } elsif (/^attempts:(\d+)$/) {
               $attempts = $1;
            } elsif (/^ndots:(\d+)$/) {
               $self->{ndots} = $1;
            } else {
               # debug, rotate, no-check-names, inet6
            }
         }
      }
   }

   $self->{timeout} = [($self->{timeout}[0]) x $attempts]
      if $attempts;

   $self->_compile;
}

=item $resolver->load_resolv_conf

Tries to load and parse F</etc/resolv.conf>. If there will ever be windows
support, then this function will do the right thing under windows, too.

=cut

sub load_resolv_conf {
   my ($self) = @_;

   open my $fh, "</etc/resolv.conf"
      or return;

   local $/;
   $self->parse_resolv_conf (<$fh>);
}

sub _compile {
   my $self = shift;

   my @retry;

   for my $timeout (@{ $self->{timeout} }) {
      for my $server (@{ $self->{server} }) {
         push @retry, [$server, $timeout];
      }
   }

   $self->{retry} = \@retry;
}

sub _recv {
   my ($self) = @_;

   while (my $peer = recv $self->{fh}, my $res, 1024, 0) {
      my ($port, $host) = Socket::unpack_sockaddr_in $peer;

      return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };

      $res = AnyEvent::DNS::dns_unpack $res
         or return;

      my $id = $self->{id}{$res->{id}};

      return unless ref $id;

      $NOW = time;
      $id->[1]->($res);
   }
}

sub _exec {
   my ($self, $req, $retry) = @_;

   if (my $retry_cfg = $self->{retry}[$retry]) {
      my ($server, $timeout) = @$retry_cfg;
      
      $self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {
         $NOW = time;

         # timeout, try next
         $self->_exec ($req, $retry + 1);
      }), sub {
         my ($res) = @_;

         # success
         $self->{id}{$req->[2]} = 1;
         push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];
         --$self->{outstanding};
         $self->_scheduler;

         $req->[1]->($res);
      }];

      send $self->{fh}, $req->[0], 0, Socket::pack_sockaddr_in 53, $server;
   } else {
      # failure
      $self->{id}{$req->[2]} = 1;
      push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];
      --$self->{outstanding};
      $self->_scheduler;

      $req->[1]->();
   }
}

sub _scheduler {
   my ($self) = @_;

   $NOW = time;

   # first clear id reuse queue
   delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }
      while @{ $self->{reuse_q} } && $self->{reuse_q}[0] <= $NOW;

   while ($self->{outstanding} < $self->{max_outstanding}) {
      my $req = shift @{ $self->{queue} }
         or last;

      while () {
         $req->[2] = int rand 65536;
         last unless exists $self->{id}{$req->[2]};
      }

      $self->{id}{$req->[2]} = 1;
      substr $req->[0], 0, 2, pack "n", $req->[2];

      ++$self->{outstanding};
      $self->_exec ($req, 0);
   }
}

=item $resolver->request ($req, $cb->($res))

Sends a single request (a hash-ref formated as specified for
C<AnyEvent::DNS::dns_pack>) to the configured nameservers including
retries. Calls the callback with the decoded response packet if a reply
was received, or no arguments on timeout.

=cut

sub request($$) {
   my ($self, $req, $cb) = @_;

   push @{ $self->{queue} }, [(AnyEvent::DNS::dns_pack $req), $cb];
   $self->_scheduler;
}

=item $resolver->resolve ($qname, $qtype, %options, $cb->($rcode, @rr))

Queries the DNS for the given domain name C<$qname> of type C<$qtype> (a
qtype of "*" is supported and means "any").

The callback will be invoked with a list of matching result records or
none on any error or if the name could not be found.

CNAME chains (although illegal) are followed up to a length of 8.

The following options are supported:

=over 4

=item search => [$suffix...]

Use the given search list (which might be empty), by appending each one
in turn to the C<$qname>. If this option is missing then the configured
C<ndots> and C<search> define its value. If the C<$qname> ends in a dot,
then this option is ignored completely.

=item accept => [$type...]

Lists the acceptable result types: only result types in this set will be
accepted and returned. The default includes the C<$qtype> and nothing
else.

=item class => "class"

Specify the query class ("in" for internet, "ch" for chaosnet and "hs" for
hesiod are the only ones making sense).

=back

Examples:

   $res->resolve ("ruth.plan9.de", "a", sub {
      warn Dumper [@_];
   });

   [
     [
       'ruth.schmorp.de',
       'a',
       'in',
       '129.13.162.95'
     ]
   ]

   $res->resolve ("test1.laendle", "*",
      accept => ["a", "aaaa"],
      sub {
         warn Dumper [@_];
      }
   );

   [
     [
       'test1.laendle',
       'a',
       'in',
       '10.0.0.255'
     ],
     [
       'test1.laendle',
       'aaaa',
       'in',
       '3ffe:1900:4545:0002:0240:0000:0000:f7e1'
     ]
   ]

=cut

sub resolve($%) {
   my $cb = pop;
   my ($self, $qname, $qtype, %opt) = @_;

   my @search = $qname =~ s/\.$//
      ? ""
      : $opt{search}
        ? @{ $opt{search} }
        : ($qname =~ y/.//) >= $self->{ndots}
          ? ("", @{ $self->{search} })
          : (@{ $self->{search} }, "");

   my $class = $opt{class} || "in";

   my %atype = $opt{accept}
      ? map +($_ => 1), @{ $opt{accept} }
      : ($qtype => 1);

   # advance in searchlist
   my $do_search; $do_search = sub {
      @search
         or return $cb->();

      (my $name = "$qname." . shift @search) =~ s/\.$//;
      my $depth = 2;

      # advance in cname-chain
      my $do_req; $do_req = sub {
         $self->request ({
            rd => 1,
            qd => [[$name, $qtype, $class]],
         }, sub {
            my ($res) = @_
               or return $do_search->();

            my $cname;

            while () {
               my @rr = grep $_->[0] eq $name && ($atype{"*"} || $atype{$_->[1]}), @{ $res->{an} };

               return $cb->(@rr)
                  if @rr;

               # see if there is a cname we can follow
               my @rr = grep $_->[0] eq $name && $_->[1] eq "cname", @{ $res->{an} };

               if (@rr) {
                  $depth--
                     or return $do_search->(); # cname chain too long

                  $cname = 1;
                  $name = $rr[0][3];

               } elsif ($cname) {
                  # follow the cname
                  return $do_req->();

               } else {
                  return $do_search->();
               }
             }
         });
      };

      $do_req->();
   };

   $do_search->();
}

1;

=back

=head1 AUTHOR

 Marc Lehmann <schmorp@schmorp.de>
 http://home.schmorp.de/

=cut

Revision:	1.1
Committed:	Fri May 23 02:47:50 2008 UTC (16 years, 1 month ago) by root
Branch:	MAIN
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	=head1 NAME
2
3			AnyEvent::DNS - fully asynchronous DNS resolution
4
5			=head1 SYNOPSIS
6
7			use AnyEvent::DNS;
8
9			=head1 DESCRIPTION
10
11			This module offers both a number of DNS convenience functions as well
12			as a fully asynchronous and high-performance pure-perl stub resolver.
13
14			=head2 CONVENIENCE FUNCTIONS
15
16			# none yet
17
18			=over 4
19
20			=cut
21
22			package AnyEvent::DNS;
23
24			use strict;
25
26			use AnyEvent::Util ();
27
28			=back
29
30			=head2 DNS EN-/DECODING FUNCTIONS
31
32			=over 4
33
34			=cut
35
36			our %opcode_id = (
37			query => 0,
38			iquery => 1,
39			status => 2,
40			map +($_ => $_), 3..15
41			);
42
43			our %opcode_str = reverse %opcode_id;
44
45			our %rcode_id = (
46			ok => 0,
47			formerr => 1,
48			servfail => 2,
49			nxdomain => 3,
50			notimp => 4,
51			refused => 5,
52			map +($_ => $_), 6..15
53			);
54
55			our %rcode_str = reverse %rcode_id;
56
57			our %type_id = (
58			a => 1,
59			ns => 2,
60			md => 3,
61			mf => 4,
62			cname => 5,
63			soa => 6,
64			mb => 7,
65			mg => 8,
66			mr => 9,
67			null => 10,
68			wks => 11,
69			ptr => 12,
70			hinfo => 13,
71			minfo => 14,
72			mx => 15,
73			txt => 16,
74			aaaa => 28,
75			srv => 33,
76			axfr => 252,
77			mailb => 253,
78			"*" => 255,
79			);
80
81			our %type_str = reverse %type_id;
82
83			our %class_id = (
84			in => 1,
85			ch => 3,
86			hs => 4,
87			"*" => 255,
88			);
89
90			our %class_str = reverse %class_id;
91
92			# names MUST have a trailing dot
93			sub _enc_qname($) {
94			pack "(C/a)*", (split /\./, shift), ""
95			}
96
97			sub _enc_qd() {
98			(_enc_qname $_->[0]) . pack "nn",
99			($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}),
100			($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] \|\| "in"})
101			}
102
103			sub _enc_rr() {
104			die "encoding of resource records is not supported";
105			}
106
107			=item $pkt = AnyEvent::DNS::dns_pack $dns
108
109			Packs a perl data structure into a DNS packet. Reading RFC1034 is strongly
110			recommended, then everything will be totally clear. Or maybe not.
111
112			Resource records are not yet encodable.
113
114			Examples:
115
116			# very simple request, using lots of default values:
117			{ rd => 1, qd => [ [ "host.domain", "a"] ] }
118
119			# more complex example, showing how flags etc. are named:
120
121			{
122			id => 10000,
123			op => "query",
124			rc => "nxdomain",
125
126			# flags
127			qr => 1,
128			aa => 0,
129			tc => 0,
130			rd => 0,
131			ra => 0,
132
133			qd => [@rr], # query section
134			an => [@rr], # answer section
135			ns => [@rr], # authority section
136			ar => [@rr], # additional records section
137			}
138
139			=cut
140
141			sub dns_pack($) {
142			my ($req) = @_;
143
144			pack "nn nnnn a* a* a* a*",
145			$req->{id},
146
147			! !$req->{qr} * 0x8000
148			+ $opcode_id{$req->{op}} * 0x0800
149			+ ! !$req->{aa} * 0x0400
150			+ ! !$req->{tc} * 0x0200
151			+ ! !$req->{rd} * 0x0100
152			+ ! !$req->{ra} * 0x0080
153			+ $rcode_id{$req->{rc}} * 0x0001,
154
155			scalar @{ $req->{qd} \|\| [] },
156			scalar @{ $req->{an} \|\| [] },
157			scalar @{ $req->{ns} \|\| [] },
158			scalar @{ $req->{ar} \|\| [] },
159
160			(join "", map _enc_qd, @{ $req->{qd} \|\| [] }),
161			(join "", map _enc_rr, @{ $req->{an} \|\| [] }),
162			(join "", map _enc_rr, @{ $req->{ns} \|\| [] }),
163			(join "", map _enc_rr, @{ $req->{ar} \|\| [] });
164			}
165
166			our $ofs;
167			our $pkt;
168
169			# bitches
170			sub _dec_qname {
171			my @res;
172			my $redir;
173			my $ptr = $ofs;
174			my $cnt;
175
176			while () {
177			return undef if ++$cnt >= 256; # to avoid DoS attacks
178
179			my $len = ord substr $pkt, $ptr++, 1;
180
181			if ($len & 0xc0) {
182			$ptr++;
183			$ofs = $ptr if $ptr > $ofs;
184			$ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff;
185			} elsif ($len) {
186			push @res, substr $pkt, $ptr, $len;
187			$ptr += $len;
188			} else {
189			$ofs = $ptr if $ptr > $ofs;
190			return join ".", @res;
191			}
192			}
193			}
194
195			sub _dec_qd {
196			my $qname = _dec_qname;
197			my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;
198			[$qname, $type_str{$qt} \|\| $qt, $class_str{$qc} \|\| $qc]
199			}
200
201			our %dec_rr = (
202			1 => sub { Socket::inet_ntoa $_ }, # a
203			2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns
204			5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname
205			6 => sub {
206			local $ofs = $ofs - length;
207			my $mname = _dec_qname;
208			my $rname = _dec_qname;
209			($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)
210			}, # soa
211			11 => sub { ((Socket::inet_aton substr $_, 0, 4), unpack "C a*", substr $_, 4) }, # wks
212			12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr
213			13 => sub { unpack "C/a C/a", $_ },
214			15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_qname) }, # mx
215			16 => sub { unpack "C/a", $_ }, # txt
216			28 => sub { sprintf "%04x:%04x:%04x:%04x:%04x:%04x:%04x:%04x", unpack "n8" }, # aaaa
217			33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_qname) }, # srv
218			);
219
220			sub _dec_rr {
221			my $qname = _dec_qname;
222
223			my ($rt, $rc, $ttl, $rdlen) = unpack "nn N n", substr $pkt, $ofs; $ofs += 10;
224			local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;
225
226			[
227			$qname,
228			$type_str{$rt} \|\| $rt,
229			$class_str{$rc} \|\| $rc,
230			($dec_rr{$rt} \|\| sub { $_ })->(),
231			]
232			}
233
234			=item $dns = AnyEvent::DNS::dns_unpack $pkt
235
236			Unpacks a DNS packet into a perl data structure.
237
238			Examples:
239
240			# a non-successful reply
241			{
242			'qd' => [
243			[ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]
244			],
245			'rc' => 'nxdomain',
246			'ar' => [],
247			'ns' => [
248			[
249			'uni-karlsruhe.de',
250			'soa',
251			'in',
252			'netserv.rz.uni-karlsruhe.de',
253			'hostmaster.rz.uni-karlsruhe.de',
254			2008052201,
255			10800,
256			1800,
257			2592000,
258			86400
259			]
260			],
261			'tc' => '',
262			'ra' => 1,
263			'qr' => 1,
264			'id' => 45915,
265			'aa' => '',
266			'an' => [],
267			'rd' => 1,
268			'op' => 'query'
269			}
270
271			# a successful reply
272
273			{
274			'qd' => [ [ 'www.google.de', 'a', 'in' ] ],
275			'rc' => 0,
276			'ar' => [
277			[ 'a.l.google.com', 'a', 'in', '209.85.139.9' ],
278			[ 'b.l.google.com', 'a', 'in', '64.233.179.9' ],
279			[ 'c.l.google.com', 'a', 'in', '64.233.161.9' ],
280			],
281			'ns' => [
282			[ 'l.google.com', 'ns', 'in', 'a.l.google.com' ],
283			[ 'l.google.com', 'ns', 'in', 'b.l.google.com' ],
284			],
285			'tc' => '',
286			'ra' => 1,
287			'qr' => 1,
288			'id' => 64265,
289			'aa' => '',
290			'an' => [
291			[ 'www.google.de', 'cname', 'in', 'www.google.com' ],
292			[ 'www.google.com', 'cname', 'in', 'www.l.google.com' ],
293			[ 'www.l.google.com', 'a', 'in', '66.249.93.104' ],
294			[ 'www.l.google.com', 'a', 'in', '66.249.93.147' ],
295			],
296			'rd' => 1,
297			'op' => 0
298			}
299
300			=cut
301
302			sub dns_unpack($) {
303			local $pkt = shift;
304			my ($id, $flags, $qd, $an, $ns, $ar)
305			= unpack "nn nnnn A*", $pkt;
306
307			local $ofs = 6 * 2;
308
309			{
310			id => $id,
311			qr => ! ! ($flags & 0x8000),
312			aa => ! ! ($flags & 0x0400),
313			tc => ! ! ($flags & 0x0200),
314			rd => ! ! ($flags & 0x0100),
315			ra => ! ! ($flags & 0x0080),
316			op => $opcode_str{($flags & 0x001e) >> 11},
317			rc => $rcode_str{($flags & 0x000f)},
318
319			qd => [map _dec_qd, 1 .. $qd],
320			an => [map _dec_rr, 1 .. $an],
321			ns => [map _dec_rr, 1 .. $ns],
322			ar => [map _dec_rr, 1 .. $ar],
323			}
324			}
325
326			#############################################################################
327
328			=back
329
330			=head2 THE AnyEvent::DNS RESOLVER CLASS
331
332			This is the class which deos the actual protocol work.
333
334			=over 4
335
336			=cut
337
338			use Carp ();
339			use Scalar::Util ();
340			use Socket ();
341
342			our $NOW;
343
344			=item $resolver = new AnyEvent::DNS key => value...
345
346			Creates and returns a new resolver. The following options are supported:
347
348			=over 4
349
350			=item server => [...]
351
352			A list of server addressses (default C<v127.0.0.1>) in network format (4
353			octets for IPv4, 16 octets for IPv6 - not yet supported).
354
355			=item timeout => [...]
356
357			A list of timeouts to use (also determines the number of retries). To make
358			three retries with individual time-outs of 2, 5 and 5 seconds, use C<[2,
359			5, 5]>, which is also the default.
360
361			=item search => [...]
362
363			The default search list of suffixes to append to a domain name (default: none).
364
365			=item ndots => $n
366
367			The number of dots (default: C<1>) that a name must have so that the resolver
368			tries to resolve the name without any suffixes first.
369
370			=item max_outstanding => $n
371
372			Most name servers do not handle many parallel requests very well. This option
373			limits the numbe rof outstanding requests to C<$n> (default: C<10>), that means
374			if you request more than this many requests, then the additional requests will be queued
375			until some other requests have been resolved.
376
377			=back
378
379			=cut
380
381			sub new {
382			my ($class, %arg) = @_;
383
384			socket my $fh, &Socket::AF_INET, &Socket::SOCK_DGRAM, 0
385			or Carp::croak "socket: $!";
386
387			AnyEvent::Util::fh_nonblocking $fh, 1;
388
389			my $self = bless {
390			server => [v127.0.0.1],
391			timeout => [2, 5, 5],
392			search => [],
393			ndots => 1,
394			max_outstanding => 10,
395			reuse => 300, # reuse id's after 5 minutes only, if possible
396			%arg,
397			fh => $fh,
398			reuse_q => [],
399			}, $class;
400
401			# search should default to gethostname's domain
402			# but perl lacks a good posix module
403
404			Scalar::Util::weaken (my $wself = $self);
405			$self->{rw} = AnyEvent->io (fh => $fh, poll => "r", cb => sub { $wself->_recv });
406
407			$self->_compile;
408
409			$self
410			}
411
412			=item $resolver->parse_resolv_conv ($string)
413
414			Parses the given string a sif it were a F<resolv.conf> file. The following
415			directives are supported:
416
417			C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,
418			C<options> (C<timeout>, C<attempts>, C<ndots>).
419
420			Everything else is silently ignored.
421
422			=cut
423
424			sub parse_resolv_conf {
425			my ($self, $resolvconf) = @_;
426
427			$self->{server} = [];
428			$self->{search} = [];
429
430			my $attempts;
431
432			for (split /\n/, $resolvconf) {
433			if (/^\s*#/) {
434			# comment
435			} elsif (/^\snameserver\s+(\S+)\s$/i) {
436			my $ip = $1;
437			if (AnyEvent::Util::dotted_quad $ip) {
438			push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip;
439			} else {
440			warn "nameserver $ip invalid and ignored\n";
441			}
442			} elsif (/^\sdomain\s+(\S)\s+$/i) {
443			$self->{search} = [$1];
444			} elsif (/^\ssearch\s+(.?)\s*$/i) {
445			$self->{search} = [split /\s+/, $1];
446			} elsif (/^\ssortlist\s+(.?)\s*$/i) {
447			# ignored, NYI
448			} elsif (/^\soptions\s+(.?)\s*$/i) {
449			for (split /\s+/, $1) {
450			if (/^timeout:(\d+)$/) {
451			$self->{timeout} = [$1];
452			} elsif (/^attempts:(\d+)$/) {
453			$attempts = $1;
454			} elsif (/^ndots:(\d+)$/) {
455			$self->{ndots} = $1;
456			} else {
457			# debug, rotate, no-check-names, inet6
458			}
459			}
460			}
461			}
462
463			$self->{timeout} = [($self->{timeout}[0]) x $attempts]
464			if $attempts;
465
466			$self->_compile;
467			}
468
469			=item $resolver->load_resolv_conf
470
471			Tries to load and parse F</etc/resolv.conf>. If there will ever be windows
472			support, then this function will do the right thing under windows, too.
473
474			=cut
475
476			sub load_resolv_conf {
477			my ($self) = @_;
478
479			open my $fh, "</etc/resolv.conf"
480			or return;
481
482			local $/;
483			$self->parse_resolv_conf (<$fh>);
484			}
485
486			sub _compile {
487			my $self = shift;
488
489			my @retry;
490
491			for my $timeout (@{ $self->{timeout} }) {
492			for my $server (@{ $self->{server} }) {
493			push @retry, [$server, $timeout];
494			}
495			}
496
497			$self->{retry} = \@retry;
498			}
499
500			sub _recv {
501			my ($self) = @_;
502
503			while (my $peer = recv $self->{fh}, my $res, 1024, 0) {
504			my ($port, $host) = Socket::unpack_sockaddr_in $peer;
505
506			return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };
507
508			$res = AnyEvent::DNS::dns_unpack $res
509			or return;
510
511			my $id = $self->{id}{$res->{id}};
512
513			return unless ref $id;
514
515			$NOW = time;
516			$id->[1]->($res);
517			}
518			}
519
520			sub _exec {
521			my ($self, $req, $retry) = @_;
522
523			if (my $retry_cfg = $self->{retry}[$retry]) {
524			my ($server, $timeout) = @$retry_cfg;
525
526			$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {
527			$NOW = time;
528
529			# timeout, try next
530			$self->_exec ($req, $retry + 1);
531			}), sub {
532			my ($res) = @_;
533
534			# success
535			$self->{id}{$req->[2]} = 1;
536			push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];
537			--$self->{outstanding};
538			$self->_scheduler;
539
540			$req->[1]->($res);
541			}];
542
543			send $self->{fh}, $req->[0], 0, Socket::pack_sockaddr_in 53, $server;
544			} else {
545			# failure
546			$self->{id}{$req->[2]} = 1;
547			push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];
548			--$self->{outstanding};
549			$self->_scheduler;
550
551			$req->[1]->();
552			}
553			}
554
555			sub _scheduler {
556			my ($self) = @_;
557
558			$NOW = time;
559
560			# first clear id reuse queue
561			delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }
562			while @{ $self->{reuse_q} } && $self->{reuse_q}[0] <= $NOW;
563
564			while ($self->{outstanding} < $self->{max_outstanding}) {
565			my $req = shift @{ $self->{queue} }
566			or last;
567
568			while () {
569			$req->[2] = int rand 65536;
570			last unless exists $self->{id}{$req->[2]};
571			}
572
573			$self->{id}{$req->[2]} = 1;
574			substr $req->[0], 0, 2, pack "n", $req->[2];
575
576			++$self->{outstanding};
577			$self->_exec ($req, 0);
578			}
579			}
580
581			=item $resolver->request ($req, $cb->($res))
582
583			Sends a single request (a hash-ref formated as specified for
584			C<AnyEvent::DNS::dns_pack>) to the configured nameservers including
585			retries. Calls the callback with the decoded response packet if a reply
586			was received, or no arguments on timeout.
587
588			=cut
589
590			sub request($$) {
591			my ($self, $req, $cb) = @_;
592
593			push @{ $self->{queue} }, [(AnyEvent::DNS::dns_pack $req), $cb];
594			$self->_scheduler;
595			}
596
597			=item $resolver->resolve ($qname, $qtype, %options, $cb->($rcode, @rr))
598
599			Queries the DNS for the given domain name C<$qname> of type C<$qtype> (a
600			qtype of "*" is supported and means "any").
601
602			The callback will be invoked with a list of matching result records or
603			none on any error or if the name could not be found.
604
605			CNAME chains (although illegal) are followed up to a length of 8.
606
607			The following options are supported:
608
609			=over 4
610
611			=item search => [$suffix...]
612
613			Use the given search list (which might be empty), by appending each one
614			in turn to the C<$qname>. If this option is missing then the configured
615			C<ndots> and C<search> define its value. If the C<$qname> ends in a dot,
616			then this option is ignored completely.
617
618			=item accept => [$type...]
619
620			Lists the acceptable result types: only result types in this set will be
621			accepted and returned. The default includes the C<$qtype> and nothing
622			else.
623
624			=item class => "class"
625
626			Specify the query class ("in" for internet, "ch" for chaosnet and "hs" for
627			hesiod are the only ones making sense).
628
629			=back
630
631			Examples:
632
633			$res->resolve ("ruth.plan9.de", "a", sub {
634			warn Dumper [@_];
635			});
636
637			[
638			[
639			'ruth.schmorp.de',
640			'a',
641			'in',
642			'129.13.162.95'
643			]
644			]
645
646			$res->resolve ("test1.laendle", "*",
647			accept => ["a", "aaaa"],
648			sub {
649			warn Dumper [@_];
650			}
651			);
652
653			[
654			[
655			'test1.laendle',
656			'a',
657			'in',
658			'10.0.0.255'
659			],
660			[
661			'test1.laendle',
662			'aaaa',
663			'in',
664			'3ffe:1900:4545:0002:0240:0000:0000:f7e1'
665			]
666			]
667
668			=cut
669
670			sub resolve($%) {
671			my $cb = pop;
672			my ($self, $qname, $qtype, %opt) = @_;
673
674			my @search = $qname =~ s/\.$//
675			? ""
676			: $opt{search}
677			? @{ $opt{search} }
678			: ($qname =~ y/.//) >= $self->{ndots}
679			? ("", @{ $self->{search} })
680			: (@{ $self->{search} }, "");
681
682			my $class = $opt{class} \|\| "in";
683
684			my %atype = $opt{accept}
685			? map +($_ => 1), @{ $opt{accept} }
686			: ($qtype => 1);
687
688			# advance in searchlist
689			my $do_search; $do_search = sub {
690			@search
691			or return $cb->();
692
693			(my $name = "$qname." . shift @search) =~ s/\.$//;
694			my $depth = 2;
695
696			# advance in cname-chain
697			my $do_req; $do_req = sub {
698			$self->request ({
699			rd => 1,
700			qd => [[$name, $qtype, $class]],
701			}, sub {
702			my ($res) = @_
703			or return $do_search->();
704
705			my $cname;
706
707			while () {
708			my @rr = grep $_->[0] eq $name && ($atype{"*"} \|\| $atype{$_->[1]}), @{ $res->{an} };
709
710			return $cb->(@rr)
711			if @rr;
712
713			# see if there is a cname we can follow
714			my @rr = grep $_->[0] eq $name && $_->[1] eq "cname", @{ $res->{an} };
715
716			if (@rr) {
717			$depth--
718			or return $do_search->(); # cname chain too long
719
720			$cname = 1;
721			$name = $rr[0][3];
722
723			} elsif ($cname) {
724			# follow the cname
725			return $do_req->();
726
727			} else {
728			return $do_search->();
729			}
730			}
731			});
732			};
733
734			$do_req->();
735			};
736
737			$do_search->();
738			}
739
740			1;
741
742			=back
743
744			=head1 AUTHOR
745
746			Marc Lehmann <schmorp@schmorp.de>
747			http://home.schmorp.de/
748
749			=cut
750