#!/usr/bin/perl
package Net::DNSBL::MultiDaemon;
use strict;
#use diagnostics;
use vars qw(
$VERSION @ISA @EXPORT_OK %EXPORT_TAGS *R_Sin
$D_CLRRUN $D_SHRTHD $D_TIMONLY $D_QRESP $D_NOTME $D_ANSTOP $D_VERBOSE
);
require Exporter;
@ISA = qw(Exporter);
# DEBUG is a set of semaphores
$D_CLRRUN = 0x1; # clear run flag and force unconditional return
$D_SHRTHD = 0x2; # return short header message
$D_TIMONLY = 0x4; # exit at end of timer section
$D_QRESP = 0x8; # return query response message
$D_NOTME = 0x10; # return received response not for me
$D_ANSTOP = 0x20; # clear run OK flag if ANSWER present
$D_VERBOSE = 0x40; # verbose debug statements to STDERR
$VERSION = do { my @r = (q$Revision: 0.18 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
@EXPORT_OK = qw(
run
bl_lookup
);
%EXPORT_TAGS = (
debug => [qw($D_CLRRUN $D_SHRTHD $D_TIMONLY $D_QRESP $D_NOTME $D_ANSTOP $D_VERBOSE)],
);
Exporter::export_ok_tags('debug');
use Socket;
use Net::DNS::Codes qw(
TypeTxt
T_A
T_AAAA
T_ANY
T_MX
T_CNAME
T_NS
T_TXT
T_SOA
T_AXFR
T_PTR
C_IN
PACKETSZ
HFIXEDSZ
QUERY
NOTIMP
FORMERR
NOERROR
REFUSED
NXDOMAIN
SERVFAIL
BITS_QUERY
RD
QR
);
use Net::DNS::ToolKit 0.16 qw(
newhead
gethead
get_ns
);
use Net::DNS::ToolKit::RR;
#use Net::DNS::ToolKit::Debug qw(
# print_head
# print_buf
#);
use Net::DNSBL::Utilities qw(
s_response
not_found
write_stats
statinit
A1271
A1272
A1274
A1275
A1276
list2NetAddr
matchNetAddr
);
# target for queries about DNSBL zones, create once per session
# this is a global so it can be altered during testing
*R_Sin = \scalar sockaddr_in(53,scalar get_ns());
=head1 NAME
Net::DNSBL::MultiDaemon - multi DNSBL prioritization
=head1 SYNOPSIS
use Net::DNSBL::MultiDaemon qw(
:debug
run
bl_lookup
);
run($BLzone,$L,$R,$DNSBL,$STATs,$Run,$Sfile,$StatStamp,$DEBUG)
bl_lookup($put,$mp,$rtp,$sinaddr,$alarm,$id,$rip,$type,$zone,@blist);
=head1 DESCRIPTION
B<Net::DNSBL::MultiDaemon> is the Perl module that implements the B<multi_dnsbl>
daemon.
B<multi_dnsbl> is a DNS emulator daemon that increases the efficacy of DNSBL
look-ups in a mail system. B<multi_dnsbl> may be used as a stand-alone DNSBL
or as a plug-in for a standard BIND 9 installation.
B<multi_dnsbl> shares a common configuration file format with the
Mail::SpamCannibal sc_BLcheck.pl script so that DNSBL's can be maintained in
a common configuration file for an entire mail installation.
Because DNSBL usefulness is dependent on the nature and source of spam sent to a
specific site and because sometimes DNSBL's may provide intermittant
service, B<multi_dnsbl> interrogates them sorted in the order of B<greatest
successful hits>. DNSBL's that do not respond within the configured timeout
period are not interrogated at all after 6 consecutive failures, and
thereafter will be retried not more often than once every hour until they
come back online. This eliminates the need to place DNSBL's in a particular order in
your MTA's config file or periodically monitor the DNSBL statistics and/or update
the MTA config file.
In addition to optimizing DNSBL interrogation, B<multi_dnsbl> may be
configured to locally accept or reject specified IP's, IP ranges and to
reject specified countries by 2 character country code. By adding a DNSBL
entry of B<in-addr.arpa>, IP's will be rejected that do not return some kind
of valid reverse DNS lookup.
Reject codes are as follows:
blocked by configured DNSBL 127.0.0.2
no reverse DNS 127.0.0.4
BLOCKED (local blacklist) 127.0.0.5
Blocked by Country 127.0.0.6
=head1 OPERATION
The configuration file for B<multi_dnsbl> contains optional IGNORE (always
pass), optional BLOCK (always reject), and optional BBC (block by country) entries against
which all received queries are checked before external DNSBL's are queried.
IP's which pass IGNORE, BLOCK, and BBC test are then checked against the
prioritized list of DNSBL's to try when looking up an IP address for blacklisting.
Internally, B<multi_dnsbl> maintains this list in sorted order (including
'in-addr.arpa') based on the number of responses that
resulted in an acceptable A record being returned from the DNSBL query. For
each IP address query sent to B<multi_dnsbl>, a query is sent to each
configured DNSBL sequentially until all DNSBL's have been queried or an
acceptable A record is returned.
Let us say for example that blackholes.easynet.nl (below) will return an A record
and list.dsbl.org, bl.spamcop.net, dynablock.easynet.nl, will not.
LIST
9451 list.dsbl.org
6516 bl.spamcop.net
2350 dynablock.easynet.nl
575 blackholes.easynet.nl
327 cbl.abuseat.org
309 dnsbl.sorbs.net
195 dnsbl.njabl.org
167 sbl.spamhaus.org
22 spews.dnsbl.net.au
6 relays.ordb.org
1 proxies.blackholes.easynet.nl
0 dsbl.org
A query to B<multi_dnsbl> (pseudo.dnsbl in this example) looks like this
QUERY
1.2.3.4.pseudo.dnsbl
|
V
####################
# multi_dnsbl #
####################
| RESPONSE
+--> 1.2.3.4.list.dsbl.org NXDOMAIN
|
+--> 1.2.3.4.bl.spamcop.net NXDOMAIN
|
+--> 1.2.3.4.dynablock.easynet.nl NXDOMAIN
|
+--> 1.2.3.4.blackholes.easynet.nl A-127.0.0.2
The A record is returned to originator of the Query and the statistics count
on blackholes.easynet.nl is incremented by one.
=head1 INSTALLATION / CONFIGURATION / OPERATION
B<multi_dnsbl> can be installed as either a standalone DNSBL or as a plug-in
to a BIND 9 installation on the same host. In either case, copy the
rc.multi_daemon script to the appropriate startup directory on your host and
modify the start, stop, restart scripts as required. Operation of the script
is as follows:
Syntax: ./rc.multi_dnsbl start /path/to/config.file
./rc.multi_dnsbl start -v /path/to/config.file
./rc.multi_dnsbl stop /path/to/config.file
./rc.multi_dnsbl restart /path/to/config.file
The -v switch will print the scripts
actions verbosely to the STDERR.
=head2 CONFIGURATION FILE
The configuration file for B<multi_dnsbl> shares a common format with the
Mail::SpamCannibal sc_BLcheck.pl script, facilitating common maintenance of
DNSBL's for your MTA installation.
The sample configuration file
B<multi_dnsbl.conf.sample> is heavily commented with the details for each
configuration element. If you plan to use a common configuration file in a
SpamCannibal installation, simply add the following elements to the
B<sc_BlackList.conf> file:
MDstatfile => '/path/to/statistics/file.txt',
MDpidpath => '/path/to/pidfiles', # /var/run
MDzone => 'pseudo.dnsbl',
# OPTIONAL
MDstatrefresh => 300, # seconds
MDipaddr => '0.0.0.0', # PROBABLY NOT WHAT YOU WANT
MDport => 9953,
=head2 STANDALONE OPERATION
For standalone operation, simply set B<MDport = 53>, nothing more is
required.
Interrogating the installation will then return the first
match from the configured list of DNSBL servers.
i.e. dig 2.0.0.127.pseudo.dnsbl
.... results
Note that the results will contain all of the "authority" and "additional"
(glue) records from the responding DNSBL placed into the additional section
of the returned record that will have an authority record from of
"localhost".
=head2 PLUGIN to BIND 9
B<multi_dnsbl> may be used as a plugin helper for a standard bind 9
installation by adding a B<forward> zone to the configuration file as
follows:
//zone pseudo.dnsbl
zone "pseudo.dnsbl" in {
type forward;
forward only;
forwarders {
127.0.0.1 port 9953;
};
};
You may also wish to add one or more of the following statements with
appropriate address_match_lists to restrict access to the facility.
allow-notify {};
allow-query { address_match_list };
allow-recursion { address_match_list };
allow-transfer {};
=head2 MTA CONFIGURATION
Access to DNSBL lookup is configured in the normal fashion for each MTA.
Since MTA's generally must interrogate on port 53, B<multi_dnsbl> must be
installed on a stand-alone server or as a plugin for BIND 9.
A typical configuration line for B<sendmail M4> configuration file is shown
below:
FEATURE(`dnsbl',`pseudo.dnsbl',
`554 Rejected $&{client_addr} found in http://www.my.blacklist.org')dnl
=head1 SYSTEM SIGNALS
B<multi_dnsbl> responds to the following system signals:
=over 4
=item * TERM
Operations the statistics file is updated with the internal counts and the
daemon then exits.
=item * HUP
Operations are stopped including an update of the optional statistics file,
the configuration file is re-read and operations are restarted.
=item * USR1
The statistics file is updated on the next second tick.
=item * USR2
The statistics file is deleted, internal statistics then a new (empty)
statistics file is written on the next second tick.
=back
=head1 PERL MODULE DESCRIPTION
B<Net::DNSBL::MultiDaemon> provides most of the functions that implement
B<multi_dnsbl> which is an MTA helper that interrogates a list of
DNSBL servers in preferential order based on their success rate.
The following describes the workings of individual functions
used to implement B<multi_dnsbl>.
=over 4
=item * run($BLzone,$L,$R,$DNSBL,$STATs,$Run,$Sfile,$StatStamp,$DEBUG);
This function is the 'run' portion for the DNSBL multidaemon
input:
$BLzone zone name,
$L local listen socket object pointer,
$R remote socket object pointer,
$DNSBL config hash pointer,
$STATs statistics hash pointer
$Run pointer to stats refresh time, # must be non-zero
$Sfile statistics file path,
$StatStamp stat file initial time stamp
returns: nothing
=over 2
=item * $BLzone
The fully qualified domain name of the blacklist lookup
=item * $L
A pointer to a UDP listener object
=item * $R
A pointer to a unbound UDP socket
used for interogation an receiving replies for the multiple DNSBL's
=item * $DNSBL
A pointer to the configuration hash of the form:
$DNSBL = {
# Always allow these addresses
'IGNORE' => [ # OPTIONAL
# a single address
'11.22.33.44',
# a range of ip's, ONLY VALID WITHIN THE SAME CLASS 'C'
'22.33.44.55 - 22.33.44.65',
# a CIDR range
'5.6.7.16/28',
# a range specified with a netmask
'7.8.9.128/255.255.255.240',
# you may want these
'10.0.0.0/8',
'172.16.0.0/12',
'192.168.0.0/16',
# this should ALWAYS be here
'127.0.0.0/8', # ignore all test entries and localhost
],
# Always reject these addresses
'BLOCK' => [ # OPTIONAL
# same format as above
],
# Always block these countries
'BBC' => [qw(CN TW RO )],
# Check for reverse lookup failures - OPTIONAL
'in-addr.arpa' => {
timeout => 15, # default timeout is 30
},
# RBL zones as follows: OPTIONAL
'domain.name' => {
accept => {
'127.0.0.2' => 'comment',
'127.0.0.3' => 'comment',
},
# timeout => 30, # default seconds to wait for dnsbl
},
'next.domain' = {
etc....
# included but extracted external to B<run>
MDzone => 'pseudo.dnsbl',
MDstatfile => '/path/to/statistics/file.txt',
MDpidpath => '/path/to/pidfiles
# OPTIONAL, defaults shown
# MDstatrefresh => 300, # max seconds for refresh
# MDipaddr => '0.0.0.0', # PROBABLY NOT WHAT YOU WANT
# MDport => 9953,
# syslog. Specify the facility, one of:
# LOG_EMERG LOG_ALERT LOG_CRIT LOG_ERR LOG_WARNING LOG_NOTICE LOG_INFO LOG_DEBUG
# MDsyslog => 'LOG_WARNING',
};
Zone labels that are not of the form *.*... are ignored, making this hash
table fully compatible with the SpamCannibal sc_Blacklist.conf file.
=item * $STATs
A pointer to a statistics collection array of the form:
$STATs = {
'domain.name' => count,
etc...,
'CountryCode' => count,
etc...
};
Initialize this array with
cntinit($DNSBL,$cp) L<Net::DNSBL::Utilities>/cntinit, then
list2hash($BBC,$cp) L<Net::DNSBL::Utilities>/list2hash, then
statinit($Sfile,$cp) L<Net::DNSBL::Utilities>/statinit, below.
=item * $Run
A POINTER to the time in seconds to refresh the $STATs backing file. Even if
there is not backing file used, this value must be a positive integer.
Setting this value to zero will stop the daemon and force a restart. It is
used by $SIG{HUP} to restart the daemon.
=item * $Sfile
The path to the STATISTICS backing file.
i.e. /some/path/to/filename.ext
If $Sfile is undefined, then the time stamp need not be defined
=item * $StatTimestamp
Normally the value returned by
statinit($Sfile,$cp) L<Net::DNSBL::Utilities>/statinit, below.
=back
=cut
sub run {
my ($BLzone,$L,$R,$DNSBL,$STATs,$Run,$Sfile,$StatStamp,$DEBUG) = @_;
local *_alarm = sub {return $DNSBL->{"$_[0]"}->{timeout} || 30};
$BLzone = lc $BLzone;
$DEBUG = 0 unless $DEBUG;
my $ROK = ($DEBUG & $D_CLRRUN) ? 0:1;
my ( $msg, $t, $targetIP, $cc, $comment,
$Oname,$Otype,$Oclass,$Ottl,$Ordlength,$Odata,
$off,$id,$qr,$opcode,$aa,$tc,$rd,$ra,$mbz,$ad,$cd,$rcode,
$qdcount,$ancount,$nscount,$arcount,
$name,$type,$class,
$ttl,$rdl,@rdata,
$l_Sin,$rip,$zone,@blist,
%remoteThreads,
$rin,$rout,$nfound,
$BBC,@NAignore,@NAblock);
my $LogLevel = 0;
if ($DNSBL->{MDsyslog}) { # if logging requested
require Unix::Syslog;
import Unix::Syslog @Unix::Syslog::EXPORT_OK;
$LogLevel = eval "$DNSBL->{MDsyslog}";
## NOTE, logging must be initiated by the caller
}
# generate NetAddr objects for addresses to always pass
if ($DNSBL->{IGNORE} && ref $DNSBL->{IGNORE} eq 'ARRAY' && @{$DNSBL->{IGNORE}}) {
list2NetAddr($DNSBL->{IGNORE},\@NAignore);
}
# generate NetAddr objects for addresses to always reject
if ($DNSBL->{BLOCK} && ref $DNSBL->{BLOCK} eq 'ARRAY' && @{$DNSBL->{BLOCK}}) {
list2NetAddr($DNSBL->{BLOCK},\@NAblock);
}
# fetch pointer to Geo::IP methods
if ($DNSBL->{BBC} && ref $DNSBL->{BBC} eq 'ARRAY' && @{$DNSBL->{BBC}}) {
require Geo::IP::PurePerl;
$BBC = new Geo::IP::PurePerl;
}
my $filenoL = fileno($L);
my $filenoR = fileno($R);
my $now = time;
my $newstat = 0; # new statistics flag
my $refresh = $now + $$Run; # update statistics "then"
local $SIG{USR1} = sub {$newstat = 2}; # force write of stats now
local $SIG{USR2} = sub { # kill and regenerate statfile
return unless $Sfile;
unlink $Sfile;
foreach(keys %$STATs) {
$STATs->{"$_"} = 0;
}
$StatStamp = statinit($Sfile,$STATs);
syslog($LogLevel,"received USR2, clear stats\n")
if $LogLevel;
$newstat = 2; # re-write on next second tick
};
my $SOAptr = [ # set up bogus SOA
$BLzone,
&T_SOA,
&C_IN,
0, # ttl of SOA record
'localhost',
'root.localhost',
$now,
86400,
43200,
172800,
3600, # cache negative TTL's for an hour
];
my ($get,$put,$parse) = new Net::DNS::ToolKit::RR;
my $numberoftries = 6;
my %deadDNSBL;
foreach(keys %$STATs) {
next unless $_ =~ /\./; # only real domains
$deadDNSBL{"$_"} = 1; # initialize dead DNSBL timers
}
do {
$rin = '';
vec($rin,$filenoL,1) = 1; # always listening to local port
(vec($rin,$filenoR,1) = 1) # listen to remote only if traffic expected
if %remoteThreads;
$nfound = select($rout=$rin,undef,undef,1); # tick each second
if ($nfound > 0) {
###################### IF PROCESS REQUEST ########################
while (vec($rout,$filenoL,1)) { # process request
last unless ($l_Sin = recv($L,$msg,PACKETSZ,0)); # ignore receive errors
if (length($msg) < HFIXEDSZ) { # ignore if less then header size
return 'short header' if $DEBUG & $D_SHRTHD;
last;
}
($off,$id,$qr,$opcode,$aa,$tc,$rd,$ra,$mbz,$ad,$cd,$rcode,
$qdcount,$ancount,$nscount,$arcount)
= gethead(\$msg);
if ($qr) {
return 'query response' if $DEBUG & $D_QRESP;
last;
}
$comment = 'no bl';
if ($opcode != QUERY) {
s_response(\$msg,NOTIMP,$id,1,0,0,0);
$comment = 'not implemented';
} elsif (
$qdcount != 1 ||
$ancount ||
$nscount ||
$arcount
) {
s_response(\$msg,FORMERR,$id,$qdcount,$ancount,$nscount,$arcount);
$comment = 'format error';
} elsif (
(($off,$name,$type,$class) = $get->Question(\$msg,$off)) &&
! $name) { # name must exist
s_response(\$msg,FORMERR,$id,1,0,0,0);
$comment = 'format error';
} elsif ($class != C_IN) { # class must be C_IN
s_response(\$msg,REFUSED,$id,$qdcount,$ancount,$nscount,$arcount);
$comment = 'refused';
} elsif ($name !~ /$BLzone$/i) { # question must be for this zone
s_response(\$msg,NXDOMAIN,$id,1,0,0,0);
$comment = 'not this zone';
} else {
# THIS IS OUR ZONE request, generate a thread to handle it
print STDERR $name,' ',TypeTxt->{$type},' ' if $DEBUG & $D_VERBOSE;
if ( $type == T_A ||
$type == T_ANY) {
if ($name =~ /^((\d+)\.(\d+)\.(\d+)\.(\d+))\.(.+)/ &&
($rip = $1) &&
($targetIP = "$5.$4.$3.$2") &&
($zone = $6) &&
$BLzone eq lc $zone) {
if (@NAignore && matchNetAddr($targetIP,\@NAignore)) { # check for IP's to always pass
not_found($put,$name,$type,$id,\$msg,$SOAptr); # return unconditional NOT FOUND
$STATs->{WhiteList} += 1; # bump WhiteList count
$comment = 'IGNORE';
}
elsif (@NAblock && matchNetAddr($targetIP,\@NAblock)) { # check for IP's to always block
($msg) = _ansrbak($put,$id,1,$rip,$zone,$type,3600,A1275); # answer 127.0.0.5
$STATs->{BlackList} += 1; # bump BlackList count
$comment = 'BLOCK';
}
elsif ($BBC && # check for IP's to block by country
($cc = $BBC->country_code_by_addr($targetIP)) &&
(grep($cc eq $_,@{$DNSBL->{BBC}}))) {
($msg) = _ansrbak($put,$id,1,$rip,$zone,$type,3600,A1276); # answer 127.0.0.6
$STATs->{$cc} += 1; # bump statistics count
$newstat = 1; # notify refresh that update may be needed
$comment = "block $cc";
}
else {
@blist = ();
foreach(sort {$STATs->{"$b"} <=> $STATs->{"$a"}} keys %$STATs) {
next unless $_ =~ /\./; # drop passed,white,black,bbc entries
push @blist, $_;
}
bl_lookup($put,\$msg,\%remoteThreads,$l_Sin,_alarm($blist[0]),$id,$rip,$type,$zone,@blist);
send($R,$msg,0,$R_Sin); # udp may not block
print STDERR $blist[0] if $DEBUG & $D_VERBOSE;
last;
}
} else {
not_found($put,$name,$type,$id,\$msg,$SOAptr);
}
} elsif ($type == T_NS || # answer common queries with a not found
$type == T_MX ||
$type == T_SOA ||
$type == T_CNAME ||
$type == T_TXT) {
not_found($put,$name,$type,$id,\$msg,$SOAptr);
} elsif ($type == T_AXFR) {
s_response(\$msg,REFUSED,$id,1,0,0,0);
$comment = 'refused AXFR';
} else {
s_response(\$msg,NOTIMP,$id,1,0,0,0);
$comment = 'not implemented';
}
}
send($L,$msg,0,$l_Sin); # udp may not block on send
print STDERR " $comment\n" if $DEBUG & $D_VERBOSE;
last;
}
##################### IF RESPONSE ###############################
while (vec($rout,$filenoR,1)) { # A response
undef $msg;
last unless recv($R,$msg,,PACKETSZ,0); # ignore receive errors
if (length($msg) < HFIXEDSZ) { # ignore if less then header size
return 'short header' if $DEBUG & $D_SHRTHD;
last;
}
($off,$id,$qr,$opcode,$aa,$tc,$rd,$ra,$mbz,$ad,$cd,$rcode,
$qdcount,$ancount,$nscount,$arcount)
= gethead(\$msg);
unless ( $tc == 0 &&
$qr == 1 &&
$opcode == QUERY &&
($rcode == NOERROR || $rcode == NXDOMAIN || $rcode == SERVFAIL) &&
$qdcount == 1 &&
exists $remoteThreads{$id}) { # must not be my question!
return 'not me 1' if $DEBUG & $D_NOTME;
last;
}
($l_Sin,$rip,$type,$zone,@blist) = @{$remoteThreads{$id}->{args}};
($off,$name,$t,$class) = $get->Question(\$msg,$off);
my $answer;
if ($ancount && $rcode == &NOERROR) {
$name =~ /^(\d+\.\d+\.\d+\.\d+)\.(.+)$/;
my $z = lc $2;
unless ( $z eq lc $blist[0] && # not my question
$1 eq $rip && # not my question
($t == T_A || $t == T_PTR) && # not my question
$class == C_IN) { # not my question
return 'not me 2' if $DEBUG & $D_NOTME;
last;
}
undef $answer;
ANSWER:
foreach(0..$ancount -1) {
($off,$name,$t,$class,$ttl,$rdl,@rdata) = $get->next(\$msg,$off);
next if $answer; # throw away unneeded answers
if ($t == T_A) {
while($answer = shift @rdata) { # see if answer is on accept list
my $IP = inet_ntoa($answer);
if (grep($IP eq $_,keys %{$DNSBL->{"$blist[0]"}->{accept}})) {
$answer = A1272;
last;
}
undef $answer;
} # end of rdata
}
} # end of each ANSWER
}
elsif ($t == T_PTR && ($rcode == NXDOMAIN || $rcode == SERVFAIL)) { # no reverse lookup
$answer = A1274;
$ttl = 3600;
$nscount = $arcount = 0;
}
if ($answer) { # if valid answer
delete $remoteThreads{$id};
$STATs->{"$blist[0]"} += 1; # bump statistics count
$newstat = 1; # notify refresh that update may be needed
my($nmsg,$noff,@dnptrs) = # make proto answer
_ansrbak($put,$id,$nscount + $arcount +1,$rip,$zone,$type,$ttl,$answer);
# add the ns section from original reply into the authority section so we can see where it came from, it won't hurt anything
foreach(0..$nscount -1) {
($off,$Oname,$Otype,$Oclass,$Ottl,$Ordlength,$Odata)
= $get->next(\$msg,$off);
($noff,@dnptrs) = $put->NS(\$nmsg,$noff,\@dnptrs,
$Oname,$Otype,$Oclass,$Ottl,$Odata);
}
# add the authority section from original reply so we can see where it came from
foreach(0..$arcount -1) {
($off,$Oname,$Otype,$Oclass,$Ottl,$Ordlength,$Odata)
= $get->next(\$msg,$off);
if ($Otype == T_A) {
($noff,@dnptrs) = $put->A(\$nmsg,$noff,\@dnptrs,
$Oname,$Otype,$Oclass,$Ottl,$Odata);
} elsif ($Otype == T_AAAA) {
($noff,@dnptrs) = $put->AAAA(\$nmsg,$noff,\@dnptrs,
$Oname,$Otype,$Oclass,$Ottl,$Odata);
} else {
next; # skip unknown authority types
}
}
$msg = $nmsg;
$ROK = 0 if $DEBUG & $D_ANSTOP;
}
elsif (do {
print STDERR '+' if $DEBUG & $D_VERBOSE;
my $rv = 0;
while(!$rv) {
shift @blist;
unless (@blist) {
$rv = 1;
} else {
last unless $deadDNSBL{"$blist[0]"} > $numberoftries; # ignore hosts that don't answer
}
}
$rv;
}) { # if no more hosts
delete $remoteThreads{$id};
not_found($put,$rip .'.'. $zone,$type,$id,\$msg,$SOAptr); # send not found response
$STATs->{Passed} += 1;
$newstat = 1; # notify refresh that update may be needed
} else {
$deadDNSBL{"$blist[0]"} = 1; # reset retry count
bl_lookup($put,\$msg,\%remoteThreads,$l_Sin,_alarm($blist[0]),$id,$rip,$type,$zone,@blist);
print STDERR $blist[0] if $DEBUG & $D_VERBOSE;
send($R,$msg,0,$R_Sin); # udp may not block
last;
}
send($L,$msg,0,$l_Sin);
if ($DEBUG & $D_VERBOSE) {
if ($answer) {
print STDERR ' ',inet_ntoa($answer),"\n";
} else {
print STDERR " no bl\n";
}
}
last;
}
}
##################### TIMEOUT, do busywork #######################
else { # must be timeout
$now = time; # check various alarm status
foreach $id (keys %remoteThreads) {
next unless $remoteThreads{$id}->{expire} < $now; # expired??
($l_Sin,$rip,$type,$zone,@blist) = @{$remoteThreads{$id}->{args}};
if (++$deadDNSBL{"$blist[0]"} > $numberoftries) {
$deadDNSBL{"$blist[0]"} = 3600; # wait an hour to retry
if ($LogLevel) {
syslog($LogLevel, "timeout connecting to $blist[0]\n");
}
}
if ($blist[0] eq 'in-addr.arpa') { # expired reverse DNS lookup ?
delete $remoteThreads{$id};
$deadDNSBL{"$blist[0]"} = 0; # reset timeout (this one never expires)
$STATs->{"$blist[0]"} += 1; # bump statistics count
$newstat = 1; # notify refresh that update may be needed
($msg) = _ansrbak($put,$id,1,$rip,$zone,$type,3600,A1274);
send($L,$msg,0,$l_Sin);
print STDERR " expired Rdns\n" if $DEBUG & $D_VERBOSE;
}
elsif (do {
print STDERR '?' if $DEBUG & $D_VERBOSE;
my $rv = 0;
while(!$rv) {
shift @blist;
unless (@blist) {
$rv = 1;
} else {
last unless $deadDNSBL{"$blist[0]"} > $numberoftries; # ignore hosts that don't answer
}
}
$rv;
}) { # if no more hosts
delete $remoteThreads{$id};
not_found($put,$rip .'.'. $BLzone,$type,$id,\$msg,$SOAptr);# send not found response
$STATs->{Passed} += 1; # count messages that pass thru this filter
$newstat = 1; # notify refresh that update may be needed
send($L,$msg,0,$l_Sin);
print STDERR " no bl\n" if $DEBUG & $D_VERBOSE;
} else {
bl_lookup($put,\$msg,\%remoteThreads,$l_Sin,_alarm($blist[0]),$id,$rip,$type,$zone,@blist);
send($R,$msg,0,$R_Sin); # udp may not block
print STDERR $blist[0] if $DEBUG & $D_VERBOSE;
}
}
foreach(keys %deadDNSBL) { # eventually retry dead DNSBL
--$deadDNSBL{"$_"} if $deadDNSBL{"$_"} > $numberoftries;
}
if ($newstat > 1 ||
($refresh < $now && $newstat)) { # update stats file
write_stats($Sfile,$STATs,$StatStamp);
$refresh = $now + $$Run;
$newstat = 0;
}
return 'caught timer' if $DEBUG & $D_TIMONLY;
}
} while($$Run && $ROK);
write_stats($Sfile,$STATs,$StatStamp) if $newstat; # always update on exit if needed
}
# answer back prototype
#
# input: $put,$id,$arcount,$rip,$zone,$type,$ttl,$answer
# returns: $message,$off,@dnptrs
#
sub _ansrbak {
my($put,$id,$arc,$rip,$zone,$type,$ttl,$ans) = @_;
my $nmsg;
my $noff = newhead(\$nmsg,
$id,
BITS_QUERY | QR,
1,1,1,$arc,
);
($noff,my @dnptrs) = $put->Question(\$nmsg,$noff, # 1 question
$rip .'.'. $zone,$type,C_IN); # type is T_A or T_ANY
($noff,@dnptrs) = $put->A(\$nmsg,$noff,\@dnptrs, # 1 answer
$rip .'.'. $zone,T_A,C_IN,$ttl,$ans);
($noff,@dnptrs) = $put->NS(\$nmsg,$noff,\@dnptrs, # 1 authority
$zone,T_NS,C_IN,86400,'localhost');
($noff,@dnptrs) = $put->A(\$nmsg,$noff,\@dnptrs, # 1 additional glue
'localhost',T_A,C_IN,86400,A1271); # lie about nameserver 127.0.0.1
return($nmsg,$noff,@dnptrs)
}
=item * bl_lookup($put,$mp,$rtp,$sinaddr,$alarm,$id,$rip,$type,$zone,@blist);
Generates a query message for the first DNSBL in the @blist array. Creates
a thread entry for the response and subsequent queries should the first one fail.
input: put,
message pointer,
remote thread pointer,
sockinaddr,
connection timeout,
id of question,
reverse IP address in text
type of query received, (used in response)
ORIGINAL zone (case preserved),
array of remaining DNSBL's in sorted order
returns: nothing, puts stuff in thread queue
=back
=cut
sub bl_lookup {
my($put,$mp,$rtp,$sinaddr,$alarm,$id,$rip,$type,$zone,@blist) = @_;
my $off = newhead($mp,
$id,
BITS_QUERY | RD,
1,0,0,0,
);
my $Qtype = ($blist[0] eq 'in-addr.arpa')
? &T_PTR
: &T_A;
$put->Question($mp,$off,$rip .'.'. $blist[0],$Qtype,C_IN);
$rtp->{$id} = {
args => [$sinaddr,$rip,$type,$zone,@blist],
expire => time + $alarm,
};
}
=head1 DEPENDENCIES
Unix::Syslog
Geo::IP::PurePerl
NetAddr::IP
Net::DNS::Codes
Net::DNS::ToolKit
=head1 EXPORT_OK
run
bl_lookup
=head1 EXPORT_TAGS :debug
DEBUG is a set of semaphores for the 'run' function
$D_CLRRUN = 0x1; # clear run flag and force unconditional return
$D_SHRTHD = 0x2; # return short header message
$D_TIMONLY = 0x4; # exit at end of timer section
$D_QRESP = 0x8; # return query response message
$D_NOTME = 0x10; # return received response not for me
$D_ANSTOP = 0x20; # clear run OK flag if ANSWER present
$D_VERBOSE = 0x40; # verbose debug statements to STDERR
=head1 AUTHOR
Michael Robinton, michael@bizsystems.com
=head1 COPYRIGHT
Copyright 2003, Michael Robinton & BizSystems
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
=head1 SEE ALSO
L<Net::DNSBL::Utilities>, L<Net::DNS::Codes>, L<Net::DNS::ToolKit>, L<Mail::SpamCannibal>
=cut
1;
syntax highlighted by Code2HTML, v. 0.9.1