package Net::Blacklist::Client;
# Many thanks to Asher Blum <asher@wildspark.com> for the original
# Net::RBLClient, from which this module unashamedly steals.
use strict;
use warnings;
use IO::Socket;
use Time::HiRes qw(time);
use Net::DNS::Packet;
use vars qw($VERSION $ip_re $domain_re);
$ip_re = qr(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3});
$domain_re = qr([a-zA-Z0-9-]{1,63}(?:\.[a-zA-Z0-9-]{1,63})*\.[a-zA-Z0-9]{1,6});
$VERSION = '0.3';
sub new {
my($class, %args) = @_;
my $self = {
lists_domain => [ lists_domain() ],
lists_ip => [ lists_ip() ],
query_txt => 1,
max_time => 8,
timeout => 1,
max_hits => 1000,
max_replies => 1000,
udp_maxlen => 4000,
server => 'resolv.conf',
};
bless($self, $class);
foreach my $key (keys %args) {
defined($self->{$key}) or die "Invalid key: $key";
$self->{$key} = $args{$key};
}
# Read the contents of resolv.conf and set the server to the first
# nameserver we find listed, if the server is set to 'resolv.conf'
if ($self->{server} eq 'resolv.conf'){
open my $resolv_fh, '/etc/resolv.conf' or die "Can't open resolv.conf: $!";
local $/;
my $resolv = <$resolv_fh>;
if ($resolv =~ /^nameserver\s+($ip_re)/m){
$self->{server} = $1;
}else{
die "No nameserver found in resolv.conf; specify a nameserver IP in constructor";
}
}
return $self;
}
sub lookup_domain{
my ($self, $domain) = @_;
die "Do not recognise domain '$domain'" unless $domain =~ /^$domain_re$/;
return $self->lookup_all(lc($domain), $self->{lists_domain});
}
sub lookup_ip{
my ($self, $ip) = @_;
die "Do not recognise IP address '$ip'" unless $ip =~ /^$ip_re$/;
my $reverse_ip = join '.', reverse split(/\./, $ip);
return $self->lookup_all($reverse_ip, $self->{lists_ip});
}
sub lookup_all{
my ($self, $partial, $lists) = @_;
foreach my $list (@$lists){
my $query = join '.', ($partial, $list);
# Send the A lookup
$self->send_packet_a($query);
# optionally send the TXT lookup
if ($self->{query_txt}){
$self->send_packet_txt($query);
}
}
return $self->collect_responses;
}
sub collect_responses{
my ($self) = @_;
my $hits = my $replies = 0;
my $deadline = time + $self->{max_time};
my $results = {};
# Continue receiving packets until:
# * There are no more pending
# * The timeout is exceeded
# * Max hits or max replies are met
while ($self->{_pending} > 0 && time < $deadline) {
my $msg = '';
eval{
local $SIG{ALRM} = sub{ die "alarm time out" };
alarm $self->{timeout};
$self->sock->recv($msg, $self->{udp_maxlen}) || die "recv: $!";
alarm 0;
1;
};
if ($msg){
my ($domain, $res, $type) = decode_packet($msg);
if (defined $type && $type eq 'TXT' && $self->{query_txt}) {
$results->{$domain}{txt} = $res;
}elsif ($res){
$replies++;
$hits++ if $res;
if ($self->{query_txt}){
$results->{$domain}{a} = $res;
}else{
$results->{$domain} = $res;
}
return 1 if $hits >= $self->{max_hits} ||
$replies >= $self->{max_replies};
}
$self->{_pending}--;
}
}
$self->{_pending} = 0;
return $results;
}
sub decode_packet{
# takes a raw DNS response packet
# returns domain, response
my $data = shift;
my $packet = Net::DNS::Packet->new(\$data);
my @answer = $packet->answer;
{
my ($res, $domain, $type);
foreach my $answer (@answer) {
{
# removed $answer->answerfrom because it caused an error
# with some types of answers
my $name = lc $answer->name;
#warn "Packet contained answers to different domains ($domain != $name)"
# if defined $domain && $name ne $domain;
$domain = $name;
}
$domain =~ s/^\d+\.\d+\.\d+\.\d+\.//;
$type = $answer->type;
$res = $type eq 'A' ? inet_ntoa($answer->rdata) :
$type eq 'CNAME' ? cleanup($answer->rdata) :
$type eq 'TXT' ? (defined $res && "$res; ")
. $answer->txtdata :
'?';
last unless $type eq 'TXT';
}
return $domain, $res, $type if defined $res;
}
# OK, there were no answers -
# need to determine which domain
# sent the packet.
my @question = $packet->question;
foreach my $question(@question) {
my $domain = $question->qname;
$domain =~ s/^\d+\.\d+\.\d+\.\d+\.//;
return ($domain, undef);
}
}
sub cleanup {
# remove control chars and stuff
$_[ 0 ] =~ tr/a-zA-Z0-9./ /cs;;
$_[ 0 ];
}
# Packet generation
sub send_packet_a{
my ($self, $query) = @_;
$self->send_packet($query, 'A');
}
sub send_packet_txt{
my ($self, $query) = @_;
$self->send_packet($query, 'TXT', 'IN');
}
sub send_packet{
my ($self, $query, @pkt_args) = @_;
my ($packet, $error) = Net::DNS::Packet->new($query, @pkt_args);
die "Cannot build DNS query for $query, type $pkt_args[0]: $error" unless $packet;
$self->sock->send($packet->data) || die "Could not sent $pkt_args[0] packet for query '$query': $!";
$self->{_pending}++;
}
# returns a UDP socket connected to the specified server
sub sock{
my ($self) = @_;
$self->{_sock} ||= IO::Socket::INET->new(
Proto => 'udp',
PeerPort => 53,
PeerAddr => $self->{server},
) or die "Failed to create UDP client";
return $self->{_sock};
}
# Lists of lists..
sub lists_domain{
return qw(
multi.uribl.com
multi.surbl.org
);
}
sub lists_ip{
return qw(
0spam.fusionzero.com
dnsbl.ahbl.org
opm.blitzed.org
cbl.abuseat.org
bl.csma.biz
sbl.csma.biz
dnsbl.cyberlogic.net
bl.deadbeef.com
spamsources.dnsbl.info
dnsbl.net.au
t1.dnsbl.net.au
dun.dnsrbl.net
spam.dnsrbl.net
list.dsbl.org
unconfirmed.dsbl.org
multihop.dsbl.org
spamsources.fabel.dk
blackholes.five-ten-sg.com
hil.habeas.com
blocked.hilli.dk
blackholes.intersil.net
ipwhois.rfc-ignorant.org
dnsbl.jammconsulting.com
3y.spam.mrs.kithrup.com
relays.bl.kundenserver.de
spamguard.leadmon.net
relays.nether.net
unsure.nether.net
combined.njabl.org
no-more-funn.moensted.dk
dnsbl.antispam.or.id
relays.ordb.org
psbl.surriel.com
dnsbl.rangers.eu.org
access.redhawk.org
dnsbl.regedit64.net
relays.visi.com
sbbl.they.com
sbl.spamhaus.org
xbl.spamhaus.org
rbl.snark.net
dnsbl.solid.net
dnsbl.sorbs.net
blacklist.spambag.org
bl.spamcannibal.org
bl.spamcop.net
map.spam-rbl.com
bl.spamthwart.com
l1.spews.dnsbl.sorbs.net
l2.spews.dnsbl.sorbs.net
block.dnsbl.sorbs.net
bl.technovision.dk
blackholes.uceb.org
dnsbl-1.uceprotect.net
dnsbl-2.uceprotect.net
virbl.dnsbl.bit.nl
vox.schpider.com
db.wpbl.info
ubl.unsubscore.com
dnsbl.tqmcube.com
abuse.rfc-ignorant.org
bogusmx.rfc-ignorant.org
dsn.rfc-ignorant.org
postmaster.rfc-ignorant.org
whois.rfc-ignorant.org
ex.dnsbl.org
in.dnsbl.org
unconfirmed.dsbl.org
list.dsbl.org
);
}
=head1 NAME
Net::Blacklist::Client - Queries multiple RBLs or URIBLs in parallel.
=head1 SYNOPSIS
use Net::Blacklist::Client;
my $rbl = Net::Blacklist::Client->new;
my $result = $rbl->lookup_ip('127.0.0.2');
foreach my $list (keys %$result){
printf "%s: %s (%s)\n", $list, $result->{$list}->{a}, $result->{$list}->{txt};
}
=head1 DESCRIPTION
This module is used to discover what RBL's are listing a particular IP
address. It parallelizes requests for fast response.
This module is heavily based on L<Net::RBLClient> by Asher Blum. It adds
an updated list of RBLs and removes many dead ones, the ability to look
up domains in domain-specific RBLs, and changes the output format.
Although it is very similar and does the same job, due to the changes in
the output formats, it is not suitable as a drop-in replacement.
An RBL, or Realtime Blackhole List, is a list of IP addresses meeting some
criteria such as involvement in Unsolicited Bulk Email. Each RBL has
its own criteria for addition and removal of addresses. If you want to
block email or other traffic to/from your network based on one or more
RBLs, you should carefully study the behavior of those RBLs before and
during such blocking.
=head1 CONSTRUCTOR
=over 4
=item new( [ARGS] )
Takes an optional hash of arguments:
=over 4
=item lists_ip
An arraref of domains representing IP address RBL root domains. Each element
in the array should be a string representing the root domain for the RBL you
wish to use, for example 'bl.spamcop.net' is the root domain of Spamcop's
blacklist. Use this if you want to query a specific list of RBLs - if this
argument is omitted, a large list of default RBLs is used.
=item lists_domain
Similar to lists_ip, but these are used when querying domains with
lookup_domain. Note that IP and domain RBLs are usually separate, so using
a list of IP RBLs to check domains is a bad plan. Currently, the URIBL and
SURBL services are used by default.
=item query_txt
This option controls whether Net::Blacklist::Client looks up corresponding
TXT records. The TXT record is used by many RBL's store additional
information about the reason for including an IP address or links to pages
that contain such information.
Default: True
=item max_time
The maximum time in seconds that the lookup function should take. In fact,
the function can take up to C<max_time + timeout> seconds. Max_time need
not be integer. Of course, if the lookup returns due to max_time, some
DNS replies will be missed.
Default: 8 seconds.
=item timeout
The maximum time in seconds spent awaiting each DNS reply packet. The
only reason to change this is if C<max_time> is decreased to a small value.
Default: 1 second.
=item max_hits
A hit is an affirmative response, stating that the IP address is on a certain
list. If C<max_hits> hits are received, C<lookup()> returns immediately.
This lets the calling program save time.
Default: 1000 (effectively out of the picture).
=item max_replies
A reply from an RBL could be affirmative or negative. Either way, it counts
towards C<max_replies>. C<Lookup()> returns when C<max_replies> replies
have been received.
=item udp_maxlen
The maximum number of bytes read from a DNS reply packet. There's probably
no reason to change this.
Default: 4000
=item server
The local nameserver to use for all queries. Should be either a resolvable
hostname or a dotted quad IP address.
By default, the first nameserver in /etc/resolv.conf will be used.
=back
=head1 METHODS
=item lookup_ip( IPADDR )
Lookup one IP address on all RBL's previously defined. The IP address
must be expressed in dotted quad notation, like '1.2.3.4'. C<lookup_ip>
returns a reference to a hash with each list the IP appears on as keys.
The values depend on the status of the C<query_txt> constructor option, if
it is enabled, than a the value of the hash returned by C<lookup_ip> will
by a hashref with the keys C<a> and C<txt>, containing the A and TXT
records returned by the RBL. If it is disabled then the value is simply
set to the IP address returned by the A record request.
=item lookup_domain( DOMAIN )
Exactly the same as C<lookup_ip>, except it accepts a domain, and uses
a different list of domain-specific RBLs. The hash reference returned is
in exactly the same format.
=back
=head1 AUTHOR
Dan Thomas E<lt>F<dan@cpan.org>E<gt>
Based on L<Net::RBLClient> by Asher Blum E<lt>F<asher@wildspark.com>E<gt>
=head1 COPYRIGHT
Copyright (C) 2007 Dan Thomas. The original Net::RBLClient is Copyright
(C) 2002 Asher Blum. All rights reserved.
This code is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.
=cut
1;