File Coverage

blib/lib/POE/Component/Client/DNS/Recursive.pm
Criterion Covered Total %
statement 193 257 75.1
branch 45 78 57.6
condition 12 25 48.0
subroutine 21 22 95.4
pod 1 1 100.0
total 272 383 71.0


line stmt bran cond sub pod time code
1             package POE::Component::Client::DNS::Recursive;
2             $POE::Component::Client::DNS::Recursive::VERSION = '1.12';
3             #ABSTRACT: A recursive DNS client for POE
4              
5 7     7   712757 use strict;
  7         8  
  7         164  
6 7     7   22 use warnings;
  7         9  
  7         175  
7 7     7   27 use Carp;
  7         8  
  7         348  
8 7     7   26 use Socket qw[:all];
  7         9  
  7         6548  
9 7     7   2912 use Net::IP::Minimal qw(:PROC);
  7         3848  
  7         664  
10 7     7   2558 use IO::Socket::IP;
  7         20748  
  7         36  
11 7     7   4965 use POE qw(NFA);
  7         21  
  7         59  
12 7     7   28052 use Net::DNS::Packet;
  7         133969  
  7         13675  
13              
14             my @hc_hints = qw(
15             198.41.0.4
16             192.228.79.201
17             192.33.4.12
18             128.8.10.90
19             192.203.230.10
20             192.5.5.241
21             192.112.36.4
22             128.63.2.53
23             192.36.148.17
24             );
25              
26             sub resolve {
27 6     6 1 2934 my $package = shift;
28 6         28 my %opts = @_;
29 6         44 $opts{lc $_} = delete $opts{$_} for keys %opts;
30             croak "$package requires a 'host' argument\n"
31 6 50       27 unless $opts{host};
32             croak "$package requires an 'event' argument\n"
33 6 50       22 unless $opts{event};
34 6 100 66     50 $opts{nameservers} = [ ] unless $opts{nameservers} and ref $opts{nameservers} eq 'ARRAY';
35 6         11 @{ $opts{nameservers} } = grep { ip_get_version( $_ ) } @{ $opts{nameservers} };
  6         31  
  2         46  
  6         17  
36 6         12 my $options = delete $opts{options};
37 6         20 my $self = bless \%opts, $package;
38 6         29 my $sender = $poe_kernel->get_active_session();
39 6         43 $self->{_sender} = $sender;
40 6         142 POE::NFA->spawn(
41             object_states => {
42             initial => [
43             $self => { setup => '_start' },
44             $self => [qw(_default)],
45             ],
46             hints => [
47             $self => {
48             _init => '_hints_go',
49             _setup => '_send',
50             _read => '_hints',
51             _timeout => '_hints_timeout',
52             },
53             ],
54             query => [
55             $self => {
56             _setup => '_send',
57             _read => '_query',
58             _timeout => '_query_timeout',
59             },
60             ],
61             done => [
62             $self => [qw(_close _error)],
63             ],
64             },
65             runstate => $self,
66             )->goto_state( 'initial' => 'setup' );
67 6         207 return $self;
68             }
69              
70             sub _default {
71 6     6   2127 return 0;
72             }
73              
74             sub _start {
75 6     6   5697 my ($kernel,$machine,$runstate) = @_[KERNEL,MACHINE,RUNSTATE];
76 6         12 my $sender = $runstate->{_sender};
77 6 50 33     32 if ( $kernel == $sender and !$runstate->{session} ) {
78 0         0 croak "Not called from another POE session and 'session' wasn't set\n";
79             }
80 6         9 my $sender_id;
81 6 50       26 if ( $runstate->{session} ) {
82 0 0       0 if ( my $ref = $kernel->alias_resolve( $runstate->{session} ) ) {
83 0         0 $sender_id = $ref->ID();
84             }
85             else {
86 0         0 croak "Could not resolve 'session' to a valid POE session\n";
87             }
88             }
89             else {
90 6         24 $sender_id = $sender->ID();
91             }
92             $kernel->refcount_increment( $sender_id, __PACKAGE__ )
93 6 100       51 unless ref $runstate->{event} eq 'POE::Session::AnonEvent';
94 6         118 $kernel->detach_myself();
95 6         274 $runstate->{sender_id} = $sender_id;
96 6   33     56 my $type = $runstate->{type} || ( ip_get_version( $runstate->{host} ) ? 'PTR' : 'A' );
97 6   50     149 my $class = $runstate->{class} || 'IN';
98 6         17 $runstate->{qstack} = [ ];
99             $runstate->{current} = {
100             query => $runstate->{host},
101             type => $type,
102 6         71 packet => Net::DNS::Packet->new($runstate->{host},$type,$class),
103             };
104 6         828 $runstate->{socket} = IO::Socket::IP->new( Proto => 'udp' );
105 6         3563 $machine->goto_state( 'hints', '_init' );
106 6         376 return;
107             }
108              
109             sub _hints_go {
110 8     8   1781 my ($kernel,$machine,$runstate) = @_[KERNEL,MACHINE,RUNSTATE];
111 8         12 my $hints;
112 8 100       9 if ( scalar @{ $runstate->{nameservers} } ) {
  8         28  
113 2         5 $hints = $runstate->{nameservers};
114             }
115             else {
116 6         27 $hints = [ @hc_hints ];
117             }
118 8         19 $runstate->{_hints} = $hints;
119 8         49 $machine->goto_state( 'hints', '_setup', Net::DNS::Packet->new('.','NS','IN'), splice( @$hints, rand($#{$hints}), 1) );
  8         621  
120 8         439 return;
121             }
122              
123             sub _send {
124 26     26   7523 my ($machine,$runstate,$state,$packet,$ns) = @_[MACHINE,RUNSTATE,STATE,ARG0,ARG1];
125 26         56 my $socket = $runstate->{socket};
126 26         111 my $data = $packet->data;
127 26         15316 my $ai;
128             {
129 26         33 my %hints = (flags => AI_NUMERICHOST, socktype => SOCK_DGRAM, protocol => IPPROTO_UDP);
  26         117  
130 26         353 my ($err, @res) = getaddrinfo($ns, '53', \%hints);
131 26 50       81 if ( $err ) {
132 0         0 warn "'$ns' didn't produce an valid server address\n";
133 0         0 $machine->goto_state( 'done', '_error', $err );
134 0         0 return;
135             }
136 26         65 $ai = shift @res;
137             }
138 26         149 $socket->socket( $ai->{family}, $ai->{socktype}, $ai->{protocol} );
139 26 50       4720 unless ( send( $socket, $data, 0, $ai->{addr} ) == length($data) ) {
140 0         0 $machine->goto_state( 'done', '_error', "$ns: $!" );
141 0         0 return;
142             }
143 26         147 $poe_kernel->select_read( $socket, '_read' );
144 26   50     2314 $poe_kernel->delay( '_timeout', $runstate->{timeout} || 5 );
145 26         1878 return;
146             }
147              
148             sub _hints {
149 8     8   38681 my ($machine,$runstate,$socket) = @_[MACHINE,RUNSTATE,ARG0];
150 8         34 $poe_kernel->delay( '_timeout' );
151 8         714 my $packet = _read_socket( $socket );
152 8         14 my %hints;
153 8 50       35 if (my @ans = $packet->answer) {
154 8         89 foreach my $rr (@ans) {
155 104 50 33     208 if ($rr->name =~ /^\.?$/ and
156             $rr->type eq "NS") {
157             # Found root authority
158 104         2784 my $server = lc $rr->rdatastr;
159 104         4301 $server =~ s/\.$//;
160 104         284 $hints{$server} = [];
161             }
162             }
163 8         39 foreach my $rr ($packet->additional) {
164 90 50       1821 if (my $server = lc $rr->name){
165 90 100       2880 if ( $rr->type eq "A") {
166 78 50       569 if ($hints{$server}) {
167 78         66 push @{ $hints{$server} }, $rr->rdatastr;
  78         207  
168             }
169             }
170             }
171             }
172             }
173 8 100       80 if ( $runstate->{trace} ) {
174 2 100       9 if ( ref $runstate->{trace} eq 'POE::Session::AnonEvent' ) {
175 1         5 $runstate->{trace}->( $packet );
176             }
177             else {
178 1         7 $poe_kernel->post( $runstate->{sender_id}, $runstate->{trace}, $packet );
179             }
180             }
181 8         232 $runstate->{hints} = \%hints;
182 8         32 my @ns = _ns_from_cache( $runstate->{hints} );
183 8 100       27 unless ( scalar @ns ) {
184 2         8 $machine->goto_state( 'hints', '_init' );
185 2         182 return;
186             }
187 6         15 my $query = $runstate->{current};
188 6         17 $query->{servers} = \@ns;
189 6         27 my ($nameserver) = splice @ns, rand($#ns), 1;
190 6         37 $machine->goto_state( 'query', '_setup', $query->{packet}, $nameserver );
191 6         722 return;
192             }
193              
194             sub _hints_timeout {
195 2     2   10010404 my ($machine,$runstate) = @_[MACHINE,RUNSTATE];
196 2         7 my $hints = $runstate->{_hints};
197 2 50       5 if ( scalar @{ $hints } ) {
  2 0       13  
198 2         35 $machine->goto_state( 'hints', '_setup', Net::DNS::Packet->new('.','NS','IN'), splice( @$hints, rand($#{$hints}), 1) );
  2         192  
199             }
200             elsif ( defined $runstate->{nameservers} ) {
201 0         0 $machine->goto_state( 'hints', '_init' );
202 0         0 return;
203             }
204             else {
205 0         0 $machine->goto_state( 'done', '_error', 'Ran out of authority records' );
206             }
207 2         238 return;
208             }
209              
210             sub _query {
211 16     16   774364 my ($machine,$runstate,$socket) = @_[MACHINE,RUNSTATE,ARG0];
212 16         93 $poe_kernel->delay( '_timeout' );
213 16         1877 my $packet = _read_socket( $socket );
214 16         27 my @ns;
215 16         72 my $status = $packet->header->rcode;
216 16 100       2000 if ( $status ne 'NOERROR' ) {
217 1         7 $machine->goto_state( 'done', '_error', $status );
218 1         156 return;
219             }
220 15 100       61 if (my @ans = $packet->answer) {
221             # This is the end of the chain.
222 5 50       48 unless ( scalar @{ $runstate->{qstack} } ) {
  5         32  
223 5         30 $machine->goto_state( 'done', '_close', $packet );
224 5         532 return;
225             }
226             # Okay we have queries pending.
227 0         0 push @ns, $_->rdatastr for grep { $_->type eq 'A' } @ans;
  0         0  
228 0         0 $runstate->{current} = pop @{ $runstate->{qstack} };
  0         0  
229             }
230             else {
231 10 100       122 if ( $runstate->{trace} ) {
232 4         21 $poe_kernel->post( $runstate->{sender_id}, $runstate->{trace}, $packet );
233             }
234 10         472 my $authority = _authority( $packet );
235 10         45 @ns = _ns_from_cache( $authority );
236 10 50       58 unless ( scalar @ns ) {
237 0         0 $runstate->{current}->{authority} = $authority;
238 0         0 push @{ $runstate->{qstack} }, $runstate->{current};
  0         0  
239 0         0 my $host = ( keys %{ $authority } )[rand scalar keys %{ $authority }];
  0         0  
  0         0  
240 0         0 delete $authority->{$host};
241             $runstate->{current} = {
242 0         0 query => $host,
243             type => 'A',
244             packet => Net::DNS::Packet->new($host,'A','IN'),
245             };
246 0         0 @ns = _ns_from_cache( $runstate->{hints} );
247             }
248             }
249 10         25 my $query = $runstate->{current};
250 10         24 $query->{servers} = \@ns;
251 10         58 my ($nameserver) = splice @ns, rand($#ns), 1;
252 10         57 $poe_kernel->yield( '_setup', $query->{packet}, $nameserver );
253 10         783 return;
254             }
255              
256             sub _query_timeout {
257 0     0   0 my ($machine,$runstate) = @_[MACHINE,RUNSTATE];
258 0         0 my $query = $runstate->{current};
259 0         0 my $servers = $query->{servers};
260 0         0 my ($nameserver) = splice @{ $servers }, rand($#{ $servers }), 1;
  0         0  
  0         0  
261             # actually check here if there is something on the stack.
262             # pop off the most recent, and get the next authority record
263             # push back on to the stack and do a lookup for the authority
264             # record. No authority records left, then complain and bailout.
265 0 0       0 unless ( $nameserver ) {
266 0 0       0 if ( scalar @{ $runstate->{qstack} } ) {
  0         0  
267 0         0 $runstate->{current} = pop @{ $runstate->{qstack} };
  0         0  
268 0         0 my $host = ( keys %{ $runstate->{current}->{authority} } )[rand scalar keys %{ $runstate->{current}->{authority} }];
  0         0  
  0         0  
269 0 0       0 unless ( $host ) { # Oops
270 0         0 $machine->goto_state( 'done', '_error', 'Ran out of authority records' );
271 0         0 return; # OMG
272             }
273 0         0 delete $runstate->{current}->{authority}->{ $host };
274 0         0 push @{ $runstate->{qstack} }, $runstate->{current};
  0         0  
275             $runstate->{current} = {
276 0         0 query => $host,
277             type => 'A',
278             packet => Net::DNS::Packet->new($host,'A','IN'),
279             };
280 0         0 my @ns = _ns_from_cache( $runstate->{hints} );
281 0         0 $runstate->{current}->{servers} = \@ns;
282 0         0 ($nameserver) = splice @ns, rand($#ns), 1;
283             }
284             else {
285 0         0 $machine->goto_state( 'done', '_error', 'Ran out of authority records' );
286 0         0 return; # OMG
287             }
288             }
289 0 0       0 unless ( $nameserver ) { # SERVFAIL? maybe
290 0         0 $machine->goto_state( 'done', '_error', 'Ran out of nameservers to query' );
291 0         0 return;
292             }
293 0         0 $poe_kernel->yield( '_setup', $query->{packet}, $nameserver );
294 0         0 return;
295             }
296              
297             sub _error {
298 1     1   184 my ($kernel,$machine,$runstate,$error) = @_[KERNEL,MACHINE,RUNSTATE,ARG0];
299 1         6 $kernel->select_read( $runstate->{socket} ); # Just in case
300 1         23 my $resp = {};
301 1         11 $resp->{$_} = $runstate->{$_} for qw(host type class context);
302 1         4 $resp->{response} = undef;
303 1         3 $resp->{error} = $error;
304 1         1 delete $runstate->{trace};
305 1 50       5 if ( ref $runstate->{event} eq 'POE::Session::AnonEvent' ) {
306 0         0 my $postback = delete $runstate->{event};
307 0         0 $postback->( $resp );
308             }
309             else {
310 1         5 $kernel->post( $runstate->{sender_id}, $runstate->{event}, $resp );
311 1         70 $kernel->refcount_decrement( $runstate->{sender_id}, __PACKAGE__ );
312             }
313 1         39 return;
314             }
315              
316             sub _close {
317 5     5   713 my ($kernel,$machine,$runstate,$packet) = @_[KERNEL,MACHINE,RUNSTATE,ARG0];
318 5         49 $kernel->select_read( $runstate->{socket} ); # Just in case
319 5         94 my $resp = {};
320 5         52 $resp->{$_} = $runstate->{$_} for qw(host type class context);
321 5         15 $resp->{response} = $packet;
322 5         21 delete $runstate->{trace};
323 5 100       63 if ( ref $runstate->{event} eq 'POE::Session::AnonEvent' ) {
324 2         4 my $postback = delete $runstate->{event};
325 2         8 $postback->( $resp );
326             }
327             else {
328 3         82 $kernel->post( $runstate->{sender_id}, $runstate->{event}, $resp );
329 3         567 $kernel->refcount_decrement( $runstate->{sender_id}, __PACKAGE__ );
330             }
331 5         435 return;
332             }
333              
334             sub _authority {
335 10   50 10   32 my $packet = shift || return;
336 10         15 my %hints;
337 10 50       41 if (my @ans = $packet->authority) {
338 10         105 foreach my $rr (@ans) {
339 85 50       170 if ( $rr->type eq 'NS') {
340             # Found root authority
341 85         678 my $server = lc $rr->rdatastr;
342 85         3974 $server =~ s/\.$//;
343 85         250 $hints{$server} = [];
344             }
345             }
346 10         47 foreach my $rr ($packet->additional) {
347 90 50       1784 if (my $server = lc $rr->name){
348 90 50 66     2695 push @{ $hints{$server} }, $rr->rdatastr if $rr->type eq 'A' and $hints{$server};
  84         749  
349             }
350             }
351             }
352 10         174 return \%hints;
353             }
354              
355             sub _read_socket {
356 24   50 24   116 my $socket = shift || return;
357 24         99 $poe_kernel->select_read( $socket );
358 24         2472 my $message;
359 24 50       213 unless ( $socket->recv( $message, 512 ) ) {
360 0         0 warn "$!\n";
361 0         0 return;
362             }
363 24         1052 my ($in, $len) = Net::DNS::Packet->new( \$message, 0 );
364 24 50       46217 if ( $@ ) {
365 0         0 warn "$@\n";
366 0         0 return;
367             }
368 24 50       100 unless ( $len ) {
369 0         0 warn "Bad size\n";
370 0         0 return;
371             }
372 24         58 return $in;
373             }
374              
375             sub _ns_from_cache {
376 18   50 18   53 my $hashref = shift || return;
377 18         22 my @ns;
378 18         33 foreach my $ns (keys %{ $hashref }) {
  18         125  
379 189 100       132 push @ns, @{ $hashref->{$ns} } if scalar @{ $hashref->{$ns} };
  162         232  
  189         322  
380             }
381 18         87 return @ns;
382             }
383              
384             'Recursive lookup, recursive lookup, recursive lookup ....';
385              
386             __END__