149 lines
4.1 KiB
Perl
149 lines
4.1 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);
|
|
|
|
my $denial;
|
|
if ( @_ == 1 ) {
|
|
$denial = shift;
|
|
if ( defined $denial && $denial =~ /^disconnect$/i ) {
|
|
$self->{_args}{reject_type} = 'disconnect';
|
|
}
|
|
else {
|
|
$self->{_args}{reject_type} = 'perm';
|
|
}
|
|
}
|
|
else {
|
|
$self->{_args} = { @_ };
|
|
};
|
|
|
|
if ( ! defined $self->{_args}{reject} ) {
|
|
$self->{_args}{reject} = 1;
|
|
};
|
|
$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->init_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;
|
|
};
|
|
|
|
sub init_resolver {
|
|
my $self = shift;
|
|
return $self->{_resolver} if $self->{_resolver};
|
|
$self->log( LOGDEBUG, "initializing Net::DNS::Resolver");
|
|
$self->{_resolver} = Net::DNS::Resolver->new(dnsrch => 0);
|
|
my $timeout = $self->{_args}{timeout} || 8;
|
|
$self->{_resolver}->tcp_timeout($timeout);
|
|
$self->{_resolver}->udp_timeout($timeout);
|
|
return $self->{_resolver};
|
|
};
|
|
|