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

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