File Coverage

lib/Mail/Toaster/DNS.pm
Criterion Covered Total %
statement 88 107 82.2
branch 32 60 53.3
condition 4 10 40.0
subroutine 12 13 92.3
pod 4 8 50.0
total 140 198 70.7


line stmt bran cond sub pod time code
1             package Mail::Toaster::DNS;
2 3     3   1228 use strict;
  3         3  
  3         80  
3 3     3   10 use warnings;
  3         12  
  3         122  
4              
5             our $VERSION = '5.50';
6              
7 3     3   423 use Params::Validate ':all';
  3         5990  
  3         514  
8              
9 3     3   14 use lib 'lib';
  3         3  
  3         20  
10 3     3   614 use parent 'Mail::Toaster::Base';
  3         208  
  3         14  
11              
12             sub is_ip_address {
13 9     9 0 13 my $self = shift;
14 9         86 my %p = validate(
15             @_,
16             { 'ip' => { type => SCALAR, },
17             'rbl' => { type => SCALAR, },
18             $self->get_std_opts,
19             },
20             );
21              
22 9         64 my %args = $self->get_std_args( %p );
23 9         30 my ( $ip, $rbl ) = ( $p{'ip'}, $p{'rbl'} );
24              
25 9 50       84 $ip =~ /^([0-9]{1,3})\.([0-9]{1,3})\.([0-9]{1,3})\.([0-9]{1,3})$/
26             or return $self->error( "invalid IP address format: $ip", %args);
27              
28 9         123 return "$4.$3.$2.$1.$rbl";
29             }
30              
31             sub rbl_test {
32 4     4 1 9 my $self = shift;
33 4         76 my %p = validate(
34             @_, {
35             'zone' => SCALAR,
36             'conf' => {
37             type => HASHREF,
38             optional => 1,
39             default => { rbl_enable_lookup_using => 'net-dns' }
40             },
41             'fatal' => { type => BOOLEAN, optional => 1, default => 1 },
42             },
43             );
44              
45 4         22 my ( $conf, $zone ) = ( $p{'conf'}, $p{'zone'} );
46              
47             # $net_dns->tcp_timeout(5); # really shouldn't matter
48             # $net_dns->udp_timeout(5);
49              
50             # make sure zone has active name servers
51 4 100       17 return if ! $self->rbl_test_ns( conf => $conf, rbl => $zone );
52              
53             # test an IP that should always return an A record
54 3 50       20 return if ! $self->rbl_test_positive_ip( conf => $conf, rbl => $zone );
55              
56             # test an IP that should always yield a negative response
57 3 50       15 return if ! $self->rbl_test_negative_ip( conf => $conf, rbl => $zone );
58              
59 3         29 return 1;
60             }
61              
62             sub rbl_test_ns {
63 6     6 1 234 my $self = shift;
64 6         38 my %p = validate( @_, {
65             'rbl' => SCALAR,
66             'conf' => { type => HASHREF, optional => 1, },
67             $self->get_std_opts,
68             },
69             );
70              
71 6         34 my ( $conf, $rbl ) = ( $p{'conf'}, $p{'rbl'} );
72 6         28 my %args = $self->get_std_args( %p );
73              
74 6         11 my $testns = $rbl;
75              
76             # overrides for dnsbl's where the NS doesn't match the dnsbl name
77 6 50       45 if ( $rbl =~ /rbl\.cluecentral\.net$/ ) { $testns = "rbl.cluecentral.net"; }
  0 50       0  
    100          
    100          
    50          
78 0         0 elsif ( $rbl eq 'spews.blackhole.us' ) { $testns = "ls.spews.dnsbl.sorbs.net"; }
79 1         2 elsif ( $rbl eq 'list.dnswl.org' ) { $testns = "dnswl.org" }
80 2         4 elsif ( $rbl eq 'bl.spamcop.net' ) { $testns = "spamcop.net" }
81 0         0 elsif ( $rbl =~ /\.dnsbl\.sorbs\.net$/ ) { $testns = "dnsbl.sorbs.net" }
82 6   100     23 my $ns = $self->resolve(record=>$testns, type=>'NS', %args ) || 0;
83              
84 6         40 $self->audit( "found $ns NS servers");
85 6         49 return $ns;
86             }
87              
88             sub rbl_test_positive_ip {
89 5     5 1 338 my $self = shift;
90 5         38 my %p = validate(
91             @_,
92             { 'conf' => { type => HASHREF, optional => 1, },
93             'rbl' => { type => SCALAR, },
94             $self->get_std_opts,
95             },
96             );
97              
98 5         40 my %args = $self->get_std_args( %p );
99 5         17 my ( $conf, $rbl ) = ( $p{'conf'}, $p{'rbl'} );
100              
101             # an IP that should always return an A record
102             # for most RBL's this is 127.0.0.2, (2.0.0.127.bl.example.com)
103 5         8 my $ip = 0;
104 5 50       42 my $test_ip = $rbl eq "korea.services.net" ? "61.96.1.1"
    50          
    50          
    50          
    50          
105             : $rbl eq "kr.rbl.cluecentral.net" ? "61.96.1.1"
106             : $rbl eq "cn-kr.blackholes.us" ? "61.96.1.1"
107             : $rbl eq "cn.rbl.cluecentral.net" ? "210.52.214.8"
108             : $rbl =~ /rfc-ignorant\.org$/ ? 0 # no test ips!
109             : "127.0.0.2";
110              
111 5 50       13 return if ! $test_ip;
112 5         19 $self->audit( "rbl_test_positive_ip: testing with ip $test_ip");
113              
114 5 50       27 my $test = $self->is_ip_address( ip => $test_ip, rbl => $rbl, %args ) or return;
115 5         26 $self->audit( "\tquerying $test..." );
116              
117 5         20 my @rrs = $self->resolve( record => $test, type => 'A' );
118              
119 5         53 foreach my $rr ( @rrs ) {
120 3 50       34 next unless $rr =~ /127\.[0-1]\.[0-9]{1,3}/;
121 3         7 $ip++;
122 3         20 $self->audit( " from $rr matched.");
123             }
124              
125 5         29 $self->audit( "rbl_test_positive_ip: we have $ip addresses.");
126 5         38 return $ip;
127             }
128              
129             sub rbl_test_negative_ip {
130 4     4 1 8 my $self = shift;
131 4         36 my %p = validate( @_, {
132             'rbl' => SCALAR,
133             'conf' => { type => HASHREF, optional => 1, },
134             $self->get_std_opts,
135             },
136             );
137              
138 4         37 my %args = $self->get_std_args( %p );
139 4         15 my ( $conf, $rbl ) = ( $p{'conf'}, $p{'rbl'} );
140              
141 4 50       33 my $test_ip = $rbl eq "korea.services.net" ? "208.75.177.127"
    50          
    50          
    50          
142             : $rbl eq "kr.rbl.cluecentral.net" ? "208.75.177.127"
143             : $rbl eq "cn.rbl.cluecentral.net" ? "208.75.177.127"
144             : $rbl eq "us.rbl.cluecentral.net" ? "210.52.214.8"
145             : "208.75.177.127";
146              
147 4 50       21 my $test = $self->is_ip_address( ip => $test_ip, rbl => $rbl, %args ) or return;
148 4         23 $self->audit( "querying $test" );
149              
150 4         21 my @rrs = $self->resolve( record => $test, type => 'A', %args );
151 4 50       73 return 1 if scalar @rrs == 0;
152              
153 0         0 foreach my $rr ( @rrs ) {
154 0 0       0 next unless $rr =~ /127\.0\.0/;
155 0         0 $self->audit( " from $rr matched.");
156             }
157 0         0 return 0;
158             }
159              
160             sub resolve {
161 17     17 0 356 my $self = shift;
162 17         116 my %p = validate(@_, {
163             record => SCALAR,
164             type => SCALAR,
165             timeout=> { type=>SCALAR, optional=>1, default=>5 },
166             conf => { type=>HASHREF, optional=>1, },
167             $self->get_std_opts,
168             },
169             );
170              
171 17         113 my ( $conf, $record, $type ) = ( $p{'conf'}, $p{'record'}, $p{'type'} );
172             #my %args = $self->get_std_args( %p );
173              
174             return $self->resolve_dig($record, $type )
175             if ( $conf
176             && $conf->{'rbl_enable_lookup_using'}
177 17 0 33     46 && $conf->{'rbl_enable_lookup_using'} eq "dig" );
      0        
178              
179 17 50       67 return $self->resolve_dig($record, $type ) if ! $self->util->has_module("Net::DNS");
180 17         65 return $self->resolve_net_dns($record, $type, $p{timeout} );
181             };
182              
183             sub resolve_net_dns {
184 17     17 0 36 my ($self, $record, $type, $timeout) = @_;
185              
186 17         98 $self->audit("resolving $record type $type with Net::DNS");
187              
188 17         75 require Net::DNS;
189 17         104 my $net_dns = Net::DNS::Resolver->new;
190              
191 17   50     988 $timeout ||= '5';
192 17         70 $net_dns->tcp_timeout($timeout);
193 17         179 $net_dns->udp_timeout($timeout);
194              
195 17 100       122 my $query = $net_dns->query( $record, $type ) or
196             return $self->error( "resolver query failed for $record: " . $net_dns->errorstring, fatal => 0);
197              
198 9         516266 my @records;
199 9         41 foreach my $rr (grep { $_->type eq $type } $query->answer ) {
  40         275  
200 39 100       317 if ( $type eq "NS" ) {
    50          
    0          
201 35         81 $self->audit("\t$record $type: ". $rr->nsdname );
202 35         77 push @records, $rr->nsdname;
203             }
204             elsif ( $type eq "A" ) {
205 4         26 $self->audit("\t$record $type: ". $rr->address );
206 4         17 push @records, $rr->address;
207             }
208             elsif ( $type eq "PTR" ) {
209 0         0 push @records, $rr->rdatastr;
210 0         0 $self->audit("\t$record $type: ". $rr->rdatastr );
211             }
212             else {
213 0         0 $self->error("unknown record type: $type", fatal => 0);
214             };
215             }
216 9         288 return @records;
217             };
218              
219             sub resolve_dig {
220 0     0 0   my ($self, $record, $type) = @_;
221              
222 0           $self->audit("resolving $record type $type with dig");
223              
224 0           my $dig = $self->util->find_bin( 'dig' );
225              
226 0           my @records;
227 0           foreach (`$dig $type $record +short`) {
228 0           chomp;
229 0           push @records, $_;
230 0           $self->audit("found $_");
231             }
232 0           return @records;
233             };
234              
235             1;
236             __END__
237              
238              
239             =head1 NAME
240              
241             Mail::Toaster::DNS - DNS functions, primarily to test RBLs
242              
243              
244             =head1 SYNOPSIS
245              
246             A set of subroutines for testing rbls to verify that they are functioning properly. If Net::DNS is installed it will be used but we can also test using dig.
247              
248              
249             =head1 DESCRIPTION
250              
251             These functions are used by toaster-watcher to determine if RBL's are available when generating qmail's smtpd/run control file.
252              
253              
254             =head1 SUBROUTINES
255              
256             =over
257              
258             =item new
259              
260             Create a new DNS method:
261              
262             use Mail::Toaster;
263             use Mail::Toaster::DNS;
264             my $dns = Mail::Toaster::DNS->new;
265              
266              
267             =item rbl_test
268              
269             After the demise of osirusoft and the DDoS attacks currently under way against RBL operators, this little subroutine becomes one of necessity for using RBL's on mail servers. It is called by the toaster-watcher.pl script to test the RBLs before including them in the SMTP invocation.
270              
271             my $r = $dns->rbl_test(conf=>$conf, zone=>"bl.example.com");
272             if ($r) { print "bl tests good!" };
273              
274             arguments required:
275             zone - the zone of a blacklist to test
276              
277             Tests to make sure that name servers are found for the zone and then run several test queries against the zone to verify that the answers it returns are sane. We want to detect if a RBL operator does something like whitelist or blacklist the entire planet.
278              
279             If the blacklist fails any test, the sub will return zero and you should not use that blacklist.
280              
281              
282             =item rbl_test_ns
283              
284             my $count = $t_dns->rbl_test_ns(
285             conf => $conf,
286             rbl => $rbl,
287             );
288              
289             arguments required:
290             rbl - the reverse zone we use to test this rbl.
291              
292             This script requires a zone name. It will then return a count of how many NS records exist for that zone. This sub is used by the rbl tests. Before we bother to look up addresses, we make sure valid nameservers are defined.
293              
294              
295             =item rbl_test_positive_ip
296              
297             $t_dns->rbl_test_positive_ip( rbl=>'sbl.spamhaus.org' );
298              
299             arguments required:
300             rbl - the reverse zone we use to test this rbl.
301              
302             arguments optional:
303             conf
304              
305             A positive test is a test that should always return a RBL match. If it should and does not, then we assume that RBL has been disabled by its operator.
306              
307             Some RBLs have test IP(s) to verify they are working. For geographic RBLs (like korea.services.net) we can simply choose any IP within their allotted space. Most other RBLs use 127.0.0.2 as a positive test.
308              
309             In the case of rfc-ignorant.org, they have no known test IPs and thus we have to skip testing them.
310              
311              
312             =item rbl_test_negative_ip
313              
314             $t_dns->rbl_test_negative_ip(conf=>$conf, rbl=>$rbl);
315              
316             This test is a little more difficult as RBL operators don't typically have an IP that is whitelisted. The DNS location based lists are very easy to test negatively. For the rest I'm listing my own IP as the default unless the RBL has a specific one. At the very least, my site won't get blacklisted that way. ;) I'm open to better suggestions.
317              
318              
319              
320             =back
321              
322             =head1 AUTHOR
323              
324             Matt Simerson <matt@tnpi.net>
325              
326              
327             =head1 BUGS
328              
329             None known. Report any to author.
330              
331              
332             =head1 SEE ALSO
333              
334             The following man/perldoc pages:
335              
336             Mail::Toaster
337             Mail::Toaster::Conf
338             toaster.conf
339             toaster-watcher.conf
340              
341             http://mail-toaster.org/
342              
343              
344             =head1 COPYRIGHT AND LICENSE
345              
346             Copyright (c) 2004-2008, The Network People, Inc. All rights reserved.
347              
348             Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
349              
350             Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
351              
352             Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
353              
354             Neither the name of the The Network People, Inc. nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
355              
356             THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
357              
358             =cut
359