145 lines
3.8 KiB
Perl
145 lines
3.8 KiB
Perl
#!perl -w
|
|
|
|
=head1 NAME
|
|
|
|
rhsbl - handle RHSBL lookups
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
Pluging that checks the host part of the sender's address against a
|
|
configurable set of RBL services.
|
|
|
|
=head1 CONFIGURATION
|
|
|
|
This plugin reads the lists to use from the rhsbl_zones configuration
|
|
file. Normal domain based dns blocking lists ("RBLs") which contain TXT
|
|
records are specified simply as:
|
|
|
|
dsn.rfc-ignorant.org
|
|
|
|
To configure RBL services which do not contain TXT records in the DNS,
|
|
but only A records, specify, after a whitespace, your own error message
|
|
to return in the SMTP conversation e.g.
|
|
|
|
abuse.rfc-ignorant.org does not support abuse@domain
|
|
|
|
=cut
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use Qpsmtpd::Constants;
|
|
|
|
sub register {
|
|
my ($self, $qp) = (shift, shift);
|
|
|
|
if (@_ == 1) {
|
|
$self->legacy_positional_args(@_);
|
|
}
|
|
else {
|
|
$self->{_args} = {@_};
|
|
}
|
|
|
|
$self->{_args}{reject} = 1 if !defined $self->{_args}{reject};
|
|
$self->{_args}{reject_type} ||= 'perm';
|
|
}
|
|
|
|
sub legacy_positional_args {
|
|
my ($self, $denial) = @_;
|
|
|
|
if (defined $denial && $denial =~ /^disconnect$/i) {
|
|
$self->{_args}{reject_type} = 'disconnect';
|
|
}
|
|
else {
|
|
$self->{_args}{reject_type} = 'perm';
|
|
}
|
|
}
|
|
|
|
sub hook_mail {
|
|
my ($self, $transaction, $sender, %param) = @_;
|
|
|
|
return DECLINED if $self->is_immune();
|
|
|
|
if ($sender->format eq '<>') {
|
|
$self->log(LOGINFO, 'pass, null sender');
|
|
return DECLINED;
|
|
}
|
|
|
|
my %rhsbl_zones = $self->populate_zones() or return DECLINED;
|
|
|
|
my $res = $self->get_resolver();
|
|
|
|
my @hosts = $sender->host;
|
|
for my $host (@hosts) {
|
|
for my $rhsbl (keys %rhsbl_zones) {
|
|
my $query;
|
|
|
|
# fix to find TXT records, if the rhsbl_zones line doesn't have second field
|
|
if (defined($rhsbl_zones{$rhsbl})) {
|
|
$self->log(LOGDEBUG, "Checking $host.$rhsbl for A record");
|
|
$query = $res->query("$host.$rhsbl");
|
|
}
|
|
else {
|
|
$self->log(LOGDEBUG, "Checking $host.$rhsbl for TXT record");
|
|
$query = $res->query("$host.$rhsbl", 'TXT');
|
|
}
|
|
|
|
if (!$query) {
|
|
if ($res->errorstring ne 'NXDOMAIN') {
|
|
$self->log(LOGCRIT, "query failed: ", $res->errorstring);
|
|
}
|
|
next;
|
|
}
|
|
|
|
my $result;
|
|
foreach my $rr ($query->answer) {
|
|
$self->log(LOGDEBUG,
|
|
'got an ' . $rr->type . ' record ' . $rr->name);
|
|
if ($rr->type eq 'A') {
|
|
$self->log(LOGDEBUG,
|
|
"A record found for $result with IP " . $rr->address);
|
|
$result = $rr->name;
|
|
}
|
|
elsif ($rr->type eq 'TXT') {
|
|
$result = $rr->txtdata;
|
|
$self->log(LOGDEBUG, "TXT record found: " . $rr->txtdata);
|
|
}
|
|
|
|
next if !$result;
|
|
|
|
$self->log(LOGINFO, "fail, $result");
|
|
|
|
if ($transaction->sender) {
|
|
my $host = $transaction->sender->host;
|
|
if ($result =~ /^$host\./) {
|
|
return $self->get_reject(
|
|
"Mail from $host rejected because it $result");
|
|
}
|
|
}
|
|
|
|
my $hello = $self->qp->connection->hello_host;
|
|
return $self->get_reject(
|
|
"Mail from HELO $hello rejected because it $result");
|
|
}
|
|
}
|
|
}
|
|
|
|
$self->log(LOGINFO, "pass");
|
|
return DECLINED;
|
|
}
|
|
|
|
sub populate_zones {
|
|
my $self = shift;
|
|
|
|
my %rhsbl_zones =
|
|
map { (split /\s+/, $_, 2)[0, 1] } $self->qp->config('rhsbl_zones');
|
|
|
|
if (!keys %rhsbl_zones) {
|
|
$self->log(LOGINFO, 'pass, no zones');
|
|
return;
|
|
}
|
|
|
|
return %rhsbl_zones;
|
|
}
|
|
|