File Coverage

blib/lib/Net/DNS/Paranoid.pm
Criterion Covered Total %
statement 89 92 96.7
branch 56 76 73.6
condition 41 63 65.0
subroutine 11 12 91.6
pod 2 2 100.0
total 199 245 81.2


line stmt bran cond sub pod time code
1             package Net::DNS::Paranoid;
2 2     2   47337 use strict;
  2         5  
  2         52  
3 2     2   11 use warnings;
  2         4  
  2         53  
4 2     2   49 use 5.008008;
  2         11  
5             our $VERSION = '0.08';
6              
7             use Class::Accessor::Lite (
8 2         17 rw => [qw(timeout blocked_hosts whitelisted_hosts resolver)]
9 2     2   1535 );
  2         2372  
10 2     2   1935 use Net::DNS;
  2         255319  
  2         2664  
11              
12             sub new {
13 1     1 1 3725 my $class = shift;
14 1 50       7 my %args = @_ ==1 ? %{$_[0]} : @_;
  0         0  
15 1   33     5 $args{resolver} ||= Net::DNS::Resolver->new;
16 1   50     10 $args{whitelisted_hosts} ||= [];
17 1   50     9 $args{blocked_hosts} ||= [];
18 1         6 bless {
19             timeout => 15,
20             %args
21             }, $class;
22             }
23              
24             sub resolve {
25 18     18 1 28084 my ($self, $name, $start_time, $timeout) = @_;
26 18 50       58 $start_time = time() if not defined $start_time;
27 18 50       80 $timeout = $self->timeout if not defined $timeout;
28              
29 18         100 my ($addrs, $errmsg) = $self->_resolve($name, $start_time, $timeout);
30 18         114 return ($addrs, $errmsg);
31             }
32              
33             sub _resolve {
34 19     19   91 my ($self, $host, $start_time, $timeout, $depth) = @_;
35 19         53 my $res = $self->resolver;
36 19   100     131 $depth ||= 0;
37            
38 19 50       45 return (undef, "CNAME recursion depth limit exceeded.") if $depth > 10;
39 19 100       41 return (undef, "DNS lookup resulted in bad host.") if $self->_bad_host($host);
40            
41             # return the IP address if it looks like one and wasn't marked bad
42 4 50       20 return ([$host]) if $host =~ /^\d+\.\d+\.\d+\.\d+$/;
43            
44 4 50       17 my $sock = $res->bgsend($host)
45             or return (undef, "No sock from bgsend");
46            
47             # wait for the socket to become readable, unless this is from our test
48             # mock resolver.
49 4 100 66     5219 unless ($sock && $sock eq "MOCK") {
50 2         4 my $rin = '';
51 2         8 vec($rin, fileno($sock), 1) = 1;
52 2         10 my $nf = select($rin, undef, undef, $self->_time_remain($start_time));
53 2 50       82 return (undef, "DNS lookup timeout") unless $nf;
54             }
55            
56 4 50       58 my $packet = $res->bgread($sock)
57             or return (undef, "DNS bgread failure");
58 4         2821 $sock = undef;
59            
60 4         227 my @addr;
61             my $cname;
62 4         29 foreach my $rr ($packet->answer) {
63 4 100       54 if ($rr->type eq "A") {
    50          
64 3 100       85 return (undef, "Suspicious DNS results from A record") if $self->_bad_host($rr->address);
65             # untaints the address:
66 2         16 push @addr, join(".", ($rr->address =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/));
67             } elsif ($rr->type eq "CNAME") {
68             # will be checked for validity in the recursion path
69 1         24 $cname = $rr->cname;
70             }
71             }
72            
73 3 100       259 return (\@addr) if @addr;
74 1 50       4 return ([]) unless $cname;
75 1         8 return $self->_resolve($cname, $start_time, $timeout, $depth + 1);
76             }
77              
78             # returns seconds remaining given a request
79             sub _time_remain {
80 2     2   3 my $self = shift;
81 2         2 my $start_time = shift;
82            
83 2         336048 return $start_time + $self->{timeout} - time();
84             }
85              
86             sub _host_list_match {
87 47     47   59 my $self = shift;
88 47         58 my $list_name = shift;
89 47         59 my $host = shift;
90            
91 47 50       51 foreach my $rule (@{ $self->{$list_name} || [] }) {
  47         200  
92 48 50       221 if (ref $rule eq "CODE") {
    100          
93 0 0       0 return 1 if $rule->($host);
94             } elsif (ref $rule) {
95             # assume regexp
96 25 100       153 return 1 if $host =~ /$rule/;
97             } else {
98 23 100       116 return 1 if $host eq $rule;
99             }
100             }
101             }
102              
103              
104             sub _bad_host {
105 22     22   75 my $self = shift;
106 22         56 my $host = lc(shift);
107            
108 22 50       130 return 0 if $self->_host_list_match("whitelisted_hosts", $host);
109 22 100       46 return 1 if $self->_host_list_match("blocked_hosts", $host);
110 20 100 66     147 return 1 if
111             $host =~ /^localhost$/i || # localhost is bad. even though it'd be stopped in
112             # a later call to _bad_host with the IP address
113             $host =~ /\s/i; # any whitespace is questionable
114            
115             # Let's assume it's an IP address now, and get it into 32 bits.
116             # Uf at any time something doesn't look like a number, then it's
117             # probably a hostname and we've already either whitelisted or
118             # blacklisted those, so we'll just say it's okay and it'll come
119             # back here later when the resolver finds an IP address.
120 19         63 my @parts = split(/\./, $host);
121 19 100       43 return 0 if @parts > 4;
122            
123             # un-octal/un-hex the parts, or return if there's a non-numeric part
124 17         60 my $overflow_flag = 0;
125 17         33 foreach (@parts) {
126 43 100 100     212 return 0 unless /^\d+$/ || /^0x[a-f\d]+$/;
127 41     0   226 local $SIG{__WARN__} = sub { $overflow_flag = 1; };
  0         0  
128 41 100       251 $_ = oct($_) if /^0/;
129             }
130            
131             # a purely numeric address shouldn't overflow.
132 15 50       35 return 1 if $overflow_flag;
133            
134 15         14 my $addr; # network order packed IP address
135            
136 15 100       64 if (@parts == 1) {
    100          
    100          
    100          
137             # a - 32 bits
138 2 50       7 return 1 if
139             $parts[0] > 0xffffffff;
140 2         6 $addr = pack("N", $parts[0]);
141             } elsif (@parts == 2) {
142             # a.b - 8.24 bits
143 4 50 33     18 return 1 if
144             $parts[0] > 0xff ||
145             $parts[1] > 0xffffff;
146 4         14 $addr = pack("N", $parts[0] << 24 | $parts[1]);
147             } elsif (@parts == 3) {
148             # a.b.c - 8.8.16 bits
149 1 50 33     11 return 1 if
      33        
150             $parts[0] > 0xff ||
151             $parts[1] > 0xff ||
152             $parts[2] > 0xffff;
153 1         5 $addr = pack("N", $parts[0] << 24 | $parts[1] << 16 | $parts[2]);
154             } elsif (@parts == 4) {
155             # a.b.c.d - 8.8.8.8 bits
156 7 50 33     91 return 1 if
      33        
      33        
157             $parts[0] > 0xff ||
158             $parts[1] > 0xff ||
159             $parts[2] > 0xff ||
160             $parts[3] > 0xff;
161 7         42 $addr = pack("N", $parts[0] << 24 | $parts[1] << 16 | $parts[2] << 8 | $parts[3]);
162             } else {
163 1         5 return 1;
164             }
165            
166 14         37 my $haddr = unpack("N", $addr); # host order IP address
167 14 100 100     247 return 1 if
      100        
      66        
      66        
      66        
      100        
      100        
      100        
      66        
168             ($haddr & 0xFF000000) == 0x00000000 || # 0.0.0.0/8
169             ($haddr & 0xFF000000) == 0x0A000000 || # 10.0.0.0/8
170             ($haddr & 0xFF000000) == 0x7F000000 || # 127.0.0.0/8
171             ($haddr & 0xFFF00000) == 0xAC100000 || # 172.16.0.0/12
172             ($haddr & 0xFFFF0000) == 0xA9FE0000 || # 169.254.0.0/16
173             ($haddr & 0xFFFF0000) == 0xC0A80000 || # 192.168.0.0/16
174             ($haddr & 0xFFFFFF00) == 0xC0000200 || # 192.0.2.0/24 "TEST-NET" docs/example code
175             ($haddr & 0xFFFFFF00) == 0xC0586300 || # 192.88.99.0/24 6to4 relay anycast addresses
176             $haddr == 0xFFFFFFFF || # 255.255.255.255
177             ($haddr & 0xF0000000) == 0xE0000000; # multicast addresses
178            
179             # as final IP address check, pass in the canonical a.b.c.d decimal form
180             # to the blacklisted host check to see if matches as bad there.
181 3         18 my $can_ip = join(".", map { ord } split //, $addr);
  12         43  
182 3 100       17 return 1 if $self->_host_list_match("blocked_hosts", $can_ip);
183            
184             # looks like an okay IP address
185 2         17 return 0;
186             }
187              
188             1;
189             __END__