qpsmtpd/plugins/rhsbl

#!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} = { @_ };
    };
}

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);
                };

                if ( $result ) {
                    $self->log(LOGINFO, "fail, $result");

                    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};
};