qpsmtpd/plugins/rhsbl

#!/usr/bin/perl

use Danga::DNS;

sub hook_mail {
  my ($self, $transaction, $sender) = @_;

  my %rhsbl_zones_map = ();

  # Perform any RHS lookups in the background. We just send the query packets here
  # and pick up any results in the RCPT handler.
  # MTAs gets confused when you reject mail during MAIL FROM:

  my %rhsbl_zones = map { (split /\s+/, $_, 2)[0,1] } $self->config('rhsbl_zones');

  if ($sender->format ne '<>' and %rhsbl_zones) {
    my $helo = $self->connection->hello_host;
    push(my @hosts, $sender->host);
    push(@hosts, $helo) if $helo && $helo ne $sender->host;
    for my $host (@hosts) {
      for my $rhsbl (keys %rhsbl_zones) {
        $self->log(LOGDEBUG, "Checking $host.$rhsbl for A record in the background");
        Danga::DNS->new(
          callback => sub { $self->process_result($host, $rhsbl_zones{$rhsbl}, @_) },
          host => "$host.$rhsbl",
          client => $self->qp->input_sock,
        );
      }
    }
  } else {
    $self->log(LOGDEBUG, 'no RHS checks necessary');
  }

  return DECLINED;
}

sub process_result {
    my ($self, $host, $template, $result, $query) = @_;
    
    if ($result !~ /^\d+\.\d+\.\d+\.\d+$/) {
        # NXDOMAIN or error
        return;
    }
    
    my $tran = $self->transaction;
    return if $tran->notes('rhsbl');
    if ($host eq $tran->sender->host) {
        $tran->notes('rhsbl', "Mail from $host rejected because it $template");
    }
    else {
        $tran->notes('rhsbl', "Mail from HELO $host rejected because it $template");
    }
}

sub hook_rcpt {
  my ($self, $transaction, $rcpt) = @_;

  my $result = $transaction->notes('rhsbl');
  return (DENY, $result) if $result;
  return DECLINED;
}