964242f7be
support all of the RBLSMTPD functionality. (Thanks to Mark Powell) git-svn-id: https://svn.perl.org/qpsmtpd/trunk@210 958fd67b-6ff1-0310-b445-bb7760255be9
266 lines
7.4 KiB
Plaintext
266 lines
7.4 KiB
Plaintext
sub register {
|
|
my ($self, $qp) = @_;
|
|
$self->register_hook("connect", "connect_handler");
|
|
$self->register_hook("rcpt", "rcpt_handler");
|
|
$self->register_hook("disconnect", "disconnect_handler");
|
|
}
|
|
|
|
sub connect_handler {
|
|
my ($self, $transaction) = @_;
|
|
|
|
my $remote_ip = $self->qp->connection->remote_ip;
|
|
|
|
# perform RBLSMTPD checks to mimic Dan Bernstein's rblsmtpd
|
|
if (defined($ENV{'RBLSMTPD'})) {
|
|
if ($ENV{'RBLSMTPD'} ne '') {
|
|
$self->log(1, "RBLSMTPD=\"$ENV{'RBLSMTPD'}\" for $remote_ip");
|
|
return DECLINED;
|
|
} else {
|
|
$self->log(1, "RBLSMTPD set, but empty for $remote_ip");
|
|
return DECLINED;
|
|
}
|
|
} else {
|
|
$self->log(1, "RBLSMTPD not set for $remote_ip");
|
|
}
|
|
|
|
my $allow = grep { s/\.?$/./; $_ eq substr($remote_ip . '.', 0, length $_) } $self->qp->config('dnsbl_allow');
|
|
return DECLINED if $allow;
|
|
|
|
my %dnsbl_zones = map { (split /:/, $_, 2)[0,1] } $self->qp->config('dnsbl_zones');
|
|
return DECLINED unless %dnsbl_zones;
|
|
|
|
my $reversed_ip = join(".", reverse(split(/\./, $remote_ip)));
|
|
|
|
# we should queue these lookups in the background and just fetch the
|
|
# results in the first rcpt handler ... oh well.
|
|
|
|
my $res = new Net::DNS::Resolver;
|
|
my $sel = IO::Select->new();
|
|
|
|
for my $dnsbl (keys %dnsbl_zones) {
|
|
# fix to find A records, if the dnsbl_zones line has a second field 20/1/04 ++msp
|
|
if (defined($dnsbl_zones{$dnsbl})) {
|
|
$self->log(7, "Checking $reversed_ip.$dnsbl for A record in the background");
|
|
$sel->add($res->bgsend("$reversed_ip.$dnsbl"));
|
|
} else {
|
|
$self->log(7, "Checking $reversed_ip.$dnsbl for TXT record in the background");
|
|
$sel->add($res->bgsend("$reversed_ip.$dnsbl", "TXT"));
|
|
}
|
|
}
|
|
|
|
$self->qp->connection->notes('dnsbl_sockets', $sel);
|
|
|
|
return DECLINED;
|
|
}
|
|
|
|
sub process_sockets {
|
|
my ($self) = @_;
|
|
|
|
my $conn = $self->qp->connection;
|
|
|
|
return $conn->notes('dnsbl')
|
|
if $conn->notes('dnsbl');
|
|
|
|
my %dnsbl_zones = map { (split /:/, $_, 2)[0,1] } $self->qp->config('dnsbl_zones');
|
|
|
|
my $res = new Net::DNS::Resolver;
|
|
my $sel = $conn->notes('dnsbl_sockets') or return "";
|
|
my $remote_ip = $self->qp->connection->remote_ip;
|
|
|
|
my $result;
|
|
|
|
$self->log(8, "waiting for dnsbl dns");
|
|
|
|
# don't wait more than 8 seconds here
|
|
my @ready = $sel->can_read(8);
|
|
|
|
$self->log(8, "DONE waiting for dnsbl dns, got " , scalar @ready, " answers ...") ;
|
|
return '' unless @ready;
|
|
|
|
for my $socket (@ready) {
|
|
my $query = $res->bgread($socket);
|
|
$sel->remove($socket);
|
|
undef $socket;
|
|
|
|
my $dnsbl;
|
|
|
|
if ($query) {
|
|
my $a_record = 0;
|
|
foreach my $rr ($query->answer) {
|
|
$a_record = 1 if $rr->type eq "A";
|
|
my $name = $rr->name;
|
|
($dnsbl) = ($name =~ m/(?:\d+\.){4}(.*)/) unless $dnsbl;
|
|
$dnsbl = $name unless $dnsbl;
|
|
$self->log(9, "name ", $rr->name);
|
|
next unless $rr->type eq "TXT";
|
|
$self->log(10, "got txt record");
|
|
$result = $rr->txtdata and last;
|
|
}
|
|
#$a_record and $result = "Blocked by $dnsbl";
|
|
|
|
if ($a_record) {
|
|
if (defined $dnsbl_zones{$dnsbl}) {
|
|
$result = $dnsbl_zones{$dnsbl};
|
|
#$result =~ s/%IP%/$ENV{'TCPREMOTEIP'}/g;
|
|
$result =~ s/%IP%/$remote_ip/g;
|
|
} else {
|
|
# shouldn't get here?
|
|
$result = "Blocked by $dnsbl";
|
|
}
|
|
}
|
|
}
|
|
else {
|
|
$self->log(4, "$dnsbl query failed: ", $res->errorstring)
|
|
unless $res->errorstring eq "NXDOMAIN";
|
|
}
|
|
|
|
if ($result) {
|
|
#kill any other pending I/O
|
|
$conn->notes('dnsbl_sockets', undef);
|
|
$result = join("\n", $self->qp->config('dnsbl_rejectmsg'), $result);
|
|
return $conn->notes('dnsbl', $result);
|
|
}
|
|
}
|
|
|
|
if ($sel->count) {
|
|
# loop around if we have dns blacklists left to see results from
|
|
return $self->process_sockets();
|
|
}
|
|
|
|
# er, the following code doesn't make much sense anymore...
|
|
|
|
# if there was more to read; then forget it
|
|
$conn->notes('dnsbl_sockets', undef);
|
|
|
|
return $conn->notes('dnsbl', $result);
|
|
|
|
}
|
|
|
|
sub rcpt_handler {
|
|
my ($self, $transaction, $rcpt) = @_;
|
|
|
|
# RBLSMTPD being non-empty means it contains the failure message to return
|
|
if (defined ($ENV{'RBLSMTPD'}) && $ENV{'RBLSMTPD'} ne '') {
|
|
my $result = $ENV{'RBLSMTPD'};
|
|
my $remote_ip = $self->qp->connection->remote_ip;
|
|
$result =~ s/%IP%/$remote_ip/g;
|
|
return (DENY, join("\n", $self->qp->config('dnsbl_rejectmsg'), $result));
|
|
}
|
|
|
|
my $note = $self->process_sockets;
|
|
return (DENY, $note) if $note;
|
|
return DECLINED;
|
|
}
|
|
|
|
sub disconnect_handler {
|
|
my ($self, $transaction) = @_;
|
|
|
|
$self->qp->connection->notes('dnsbl_sockets', undef);
|
|
|
|
return DECLINED;
|
|
}
|
|
|
|
1;
|
|
|
|
=head1 NAME
|
|
|
|
dnsbl - handle DNS BlackList lookups
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
Plugin that checks the IP address of the incoming connection against
|
|
a configurable set of RBL services.
|
|
|
|
=head1 Configuration files
|
|
|
|
This plugin uses the following configuration files. All of these are optional.
|
|
However, not specifying dnsbl_zones is like not using the plugin at all.
|
|
|
|
=over 4
|
|
|
|
=item dnsbl_zones
|
|
|
|
Normal ip based dns blocking lists ("RBLs") which contain TXT records are
|
|
specified simply as:
|
|
|
|
relays.ordb.org
|
|
spamsources.fabel.dk
|
|
|
|
To configure RBL services which do not contain TXT records in the DNS,
|
|
but only A records (e.g. the RBL+ at http://www.mail-abuse.org), specify your
|
|
own error message to return in the SMTP conversation after a colon e.g.
|
|
|
|
rbl-plus.mail-abuse.org:You are listed at - http://http://www.mail-abuse.org/cgi-bin/lookup?%IP%
|
|
|
|
The string %IP% will be replaced with the IP address of incoming connection.
|
|
Thus a fully specified file could be:
|
|
|
|
sbl-xbl.spamhaus.org
|
|
list.dsbl.org
|
|
rbl-plus.mail-abuse.ja.net:Listed by rbl-plus.mail-abuse.ja.net - see <URL:http://www.mail-abuse.org/cgi-bin/lookup?%IP%>
|
|
relays.ordb.org
|
|
|
|
=item dnsbl_allow
|
|
|
|
List of allowed ip addresses that bypass RBL checking. Format is one entry per line,
|
|
with either a full IP address or a truncated IP address with a period at the end.
|
|
For example:
|
|
|
|
192.168.1.1
|
|
172.16.33.
|
|
|
|
NB the environment variable RBLSMTPD is considered before this file is
|
|
referenced. See below.
|
|
|
|
=item dnsbl_rejectmsg
|
|
|
|
A textual message that is sent to the sender on an RBL failure. The TXT record
|
|
from the RBL list is also sent, but this file can be used to indicate what
|
|
action the sender should take.
|
|
|
|
For example:
|
|
|
|
If you think you have been blocked in error, then please forward
|
|
this entire error message to your ISP so that they can fix their problems.
|
|
The next line often contains a URL that can be visited for more information.
|
|
|
|
=back
|
|
|
|
=head1 Environment Variables
|
|
|
|
=head2 RBLSMTPD
|
|
|
|
The environment variable RBLSMTPD is supported and mimics the behaviour of
|
|
Dan Bernstein's rblsmtpd. The exception to this is the '-' char at the
|
|
start of RBLSMTPD which is used to force a hard error in Dan's rblsmtpd.
|
|
NB I don't really see the benefit
|
|
of using a soft error for a site in an RBL list. This just complicates
|
|
things as it takes 7 days (or whatever default period) before a user
|
|
gets an error email back. In the meantime they are complaining that their
|
|
emails are being "lost" :(
|
|
|
|
=over 4
|
|
|
|
=item RBLSMTPD is set and non-empty
|
|
|
|
The contents are used as the SMTP conversation error.
|
|
Use this for forcibly blocking sites you don't like
|
|
|
|
=item RBLSMTPD is set, but empty
|
|
|
|
In this case no RBL checks are made.
|
|
This can be used for local addresses.
|
|
|
|
=item RBLSMTPD is not set
|
|
|
|
All RBL checks will be made.
|
|
This is the setting for remote sites that you want to check against RBL.
|
|
|
|
=back
|
|
|
|
=head1 Revisions
|
|
|
|
See: http://cvs.perl.org/viewcvs/qpsmtpd/plugins/dnsbl
|
|
|
|
=cut
|