File Coverage

blib/lib/Net/Abuse/Utils/Spamhaus.pm
Criterion Covered Total %
statement 9 55 16.3
branch 0 26 0.0
condition 0 4 0.0
subroutine 3 6 50.0
pod 2 2 100.0
total 14 93 15.0


line stmt bran cond sub pod time code
1             package Net::Abuse::Utils::Spamhaus;
2              
3 1     1   15152 use 5.008008;
  1         3  
  1         31  
4 1     1   4 use strict;
  1         1  
  1         28  
5 1     1   4 use warnings;
  1         4  
  1         734  
6              
7             our $VERSION = '0.07';
8             $VERSION = eval $VERSION; # see L
9              
10             =head1 NAME
11              
12             Net::Abuse::Utils::Spamhaus - Perl extension for checking data against the spamhaus blacklists
13              
14             =head1 SYNOPSIS
15              
16             use Net::Abuse::Utils::Spamhaus qw(check_fqdn check_ip);
17             my $addr = '222.186.44.110';
18             my $ret = check_ip($addr);
19              
20             $addr = 'test';
21             $ret = check_fqdn($addr);
22              
23             foreach (@$ret){
24             warn $_->{'assessment'}.': '.$_->{'description'}.' -- '.$_->{'id'};
25             }
26              
27             =head1 DESCRIPTION
28              
29             =head2 EXPORT
30              
31             check_ip, check_fqdn
32             =cut
33              
34             require Exporter;
35             our @ISA = qw(Exporter);
36              
37             # Items to export into callers namespace by default. Note: do not export
38             # names by default without a very good reason. Use EXPORT_OK instead.
39             # Do not simply export all your public functions/methods/constants.
40              
41             # This allows declaration use Net::Abuse::Utils::Spamhaus ':all';
42             # If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
43             # will save memory.
44             our %EXPORT_TAGS = ( 'all' => [ qw(
45             check_ip check_fqdn
46             ) ] );
47              
48             our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
49              
50             our @EXPORT = qw(
51             check_ip check_fqdn
52             );
53              
54             # Preloaded methods go here.
55             # http://www.spamhaus.org/zen/
56             my $ip_codes = {
57             '127.0.0.2' => {
58             assessment => 'spam',
59             description => 'Direct UBE sources, spam operations & spam services',
60             },
61             '127.0.0.3' => {
62             assessment => 'spam',
63             description => 'Direct snowshoe spam sources detected via automation',
64             },
65             '127.0.0.4' => {
66             assessment => 'exploit',
67             description => 'CBL + customised NJABL. 3rd party exploits (proxies, trojans, etc.)',
68             },
69             '127.0.0.5' => {
70             assessment => 'exploit',
71             description => 'CBL + customised NJABL. 3rd party exploits (proxies, trojans, etc.)',
72             },
73             '127.0.0.6' => {
74             assessment => 'exploit',
75             description => 'CBL + customised NJABL. 3rd party exploits (proxies, trojans, etc.)',
76             },
77             '127.0.0.7' => {
78             assessment => 'exploit',
79             description => 'CBL + customised NJABL. 3rd party exploits (proxies, trojans, etc.)',
80             },
81             '127.0.0.10' => {
82             assessment => 'spam',
83             description => 'End-user Non-MTA IP addresses set by ISP outbound mail policy',
84             },
85             '127.0.0.11' => {
86             assessment => 'spam',
87             description => 'End-user Non-MTA IP addresses set by ISP outbound mail policy',
88             },
89             };
90              
91             # http://www.spamhaus.org/faq/section/Spamhaus%20DBL
92             my $fqdn_codes = {
93             '127.0.1.2' => {
94             assessment => 'suspicious',
95             description => 'spammed domain',
96             },
97             '127.0.1.3' => {
98             assessment => 'suspicious',
99             description => 'spammed redirector / url shortener',
100             },
101             '127.0.1.4' => {
102             assessment => 'phishing',
103             description => 'phishing domain',
104             },
105             '127.0.1.5' => {
106             assessment => 'malware',
107             description => 'malware domain',
108             },
109             '127.0.1.6' => {
110             assessment => 'botnet',
111             description => 'Botnet C&C domain',
112             },
113             '127.0.1.102' => {
114             assessment => 'suspicious',
115             description => 'abused legit spam',
116             },
117             '127.0.1.103' => {
118             assessment => 'suspicious',
119             description => 'abused legit spammed redirector',
120             },
121             '127.0.1.104' => {
122             assessment => 'phishing',
123             description => 'abused legit phish',
124             },
125             '127.0.1.105' => {
126             assessment => 'malware',
127             description => 'abused legit malware',
128             },
129             '127.0.1.106' => {
130             assessment => 'botnet',
131             description => 'abused legit botnet',
132             },
133             '127.0.1.255' => {
134             description => 'BANNED',
135             },
136             };
137              
138             sub _return_rr {
139 0     0     my $lookup = shift;
140 0   0       my $type = shift || 'A';
141 0           my $timeout = shift;
142            
143             # little more thread friendly
144 0           require Net::DNS::Resolver;
145 0           my $r = Net::DNS::Resolver->new(recursive => 0);
146            
147 0 0         if($timeout){
148 0           $r->udp_timeout($timeout);
149 0           $r->tcp_timeout($timeout);
150             }
151            
152              
153 0           my $pkt = $r->send($lookup);
154 0 0         return unless($pkt);
155 0           my @rdata = $pkt->answer();
156 0 0         return unless(@rdata);
157 0           return (\@rdata);
158             }
159             =head2 FUNCTIONS
160              
161             =over
162            
163             =item check_fqdn()
164              
165             accepts: a fully qualified domain name (ex: example.com)
166             returns: an ARRAYREF of HASHREF's based on the spamhaus dbl
167              
168             =cut
169              
170             sub check_fqdn {
171 0     0 1   my $addr = shift;
172 0   0       my $timeout = shift || 10;
173              
174 0           my $lookup = $addr.'.dbl.spamhaus.org';
175 0           my $rdata = _return_rr($lookup,undef,$timeout);
176 0 0         return unless($rdata);
177            
178 0           my @array;
179 0           foreach (@$rdata){
180 0 0         next unless($_->address());
181 0 0         next unless($_->type() eq 'A');
182 0           my $code = $fqdn_codes->{$_->address()};
183 0 0         unless($code){
184 0           warn 'unknown return code: '.$_->address().' library ('.$VERSION.') needs updating, contact module author ('.$lookup.')';
185 0 0         $code->{'description'} = 'unknown' unless($code->{'description'});
186 0 0         $code->{'assessment'} = 'unknown' unless($code->{'assessment'});
187             }
188              
189 0 0         if($code->{'description'} =~ /BANNED/){
190 0           warn 'BANNED received from spamhaus, you should contact them and work it out';
191 0           return;
192             }
193 0           push(@array,{
194             id => 'http://www.spamhaus.org/query/dbl?domain='.$addr,
195             assessment => $code->{'assessment'},
196             description => $code->{'description'},
197             });
198             }
199 0           return(\@array);
200             }
201              
202             =item check_ip()
203              
204             accepts: a properly formatted ipv4 address (ex: 1.1.1.1)
205             returns: an ARRAY REF of HASHREF's based on feedback from the spamhaus zen list
206              
207             =cut
208              
209             sub check_ip {
210 0     0 1   my $addr = shift;
211 0           my $timeout = shift;
212            
213 0           my @bits = split(/\./,$addr);
214 0           my $lookup = join('.',reverse(@bits));
215 0           $lookup .= '.zen.spamhaus.org';
216              
217 0           my $rdata = _return_rr($lookup,undef,$timeout);
218 0 0         return unless($rdata);
219            
220 0           my $array;
221 0           foreach (@$rdata){
222 0 0         next unless($_->type() eq 'A');
223 0           my $code = $ip_codes->{$_->address()};
224              
225             # these aren't really malicious assessments, skip them
226             # see http://www.spamhaus.org/faq/answers.lasso?section=Spamhaus%20PBL#183
227 0 0         next if($_->address() =~ /\.(10|11)$/);
228 0           push(@$array,{
229             assessment => $code->{'assessment'},
230             description => $code->{'description'},
231             id => 'http://www.spamhaus.org/query/bl?ip='.$addr,
232             });
233             }
234 0           return($array);
235             }
236            
237             1;
238             __END__