qpsmtpd/plugins/rhsbl

#!perl -w

sub register {
  my ($self, $qp, $denial ) = @_;
  if ( defined $denial and $denial =~ /^disconnect$/i ) {
    $self->{_rhsbl}->{DENY} = DENY_DISCONNECT;
  }
  else {
    $self->{_rhsbl}->{DENY} = DENY;
  }

}

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

  my $res = new Net::DNS::Resolver;
  my $sel = IO::Select->new();
  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->qp->config('rhsbl_zones');

  if ($sender->format ne '<>' and %rhsbl_zones) {
    push(my @hosts, $sender->host);
    #my $helo = $self->qp->connection->hello_host;
    #push(@hosts, $helo) if $helo && $helo ne $sender->host;
    for my $host (@hosts) {
    for my $rhsbl (keys %rhsbl_zones) {
      # 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 in the background");
        $sel->add($res->bgsend("$host.$rhsbl"));
      } else {
        $self->log(LOGDEBUG, "Checking $host.$rhsbl for TXT record in the background");
        $sel->add($res->bgsend("$host.$rhsbl", "TXT"));
      }
        $rhsbl_zones_map{"$host.$rhsbl"} = $rhsbl_zones{$rhsbl};
    }
  }

    %{$self->{_rhsbl_zones_map}} = %rhsbl_zones_map;
    $transaction->notes('rhsbl_sockets', $sel);
  } else {
    $self->log(LOGDEBUG, 'no RHS checks necessary');
  }

  return DECLINED;
}

sub hook_rcpt {
  my ($self, $transaction, $rcpt) = @_;
  my $host = $transaction->sender->host;
  my $hello = $self->qp->connection->hello_host;

  my $result = $self->process_sockets;
  if ($result && defined($self->{_rhsbl_zones_map}{$result})) {
    if ($result =~ /^$host\./ ) {
      return ($self->{_rhsbl}->{DENY}, "Mail from $host rejected because it " . $self->{_rhsbl_zones_map}{$result});
    } else {
      return ($self->{_rhsbl}->{DENY}, "Mail from HELO $hello rejected because it " . $self->{_rhsbl_zones_map}{$result});
    }
  }
  return ($self->{_rhsbl}->{DENY}, $result) if $result;
  return DECLINED;
}

sub process_sockets {
  my ($self) = @_;
  my $trans = $self->transaction;
  my $result = '';

  return $trans->notes('rhsbl') if $trans->notes('rhsbl');

  my $res = new Net::DNS::Resolver;
  my $sel = $trans->notes('rhsbl_sockets') or return '';

  $self->log(LOGDEBUG, 'waiting for rhsbl dns');

  # don't wait more than 8 seconds here
  my @ready = $sel->can_read(8);

  $self->log(LOGDEBUG, 'DONE waiting for rhsbl dns, got ' , scalar @ready, ' answers ...') ;
  return '' unless @ready;

  for my $socket (@ready) {
    my $query = $res->bgread($socket);
    $sel->remove($socket);
    undef $socket;

    if ($query) {
      foreach my $rr ($query->answer) {
        $self->log(LOGDEBUG, 'got an ' . $rr->type . ' record ' . $rr->name);
        if ($rr->type eq 'A') {
          $result = $rr->name;
          $self->log(LOGDEBUG, "A record found for $result with IP " . $rr->address);
          last;
        } elsif ($rr->type eq 'TXT') {
          $result = $rr->txtdata;
          $self->log(LOGDEBUG, "TXT record found: " . $rr->txtdata);
          last;
        }
      }
    } else {
      $self->log(LOGCRIT, "query failed: ", $res->errorstring) unless $res->errorstring eq 'NXDOMAIN';
    }

    if ($result) {
      #kill any other pending I/O
      $trans->notes('rhsbl_sockets', undef);
      return $trans->notes('rhsbl', $result);
    }
  }

  if ($sel->count) {
    # loop around if we have dns results left
    return $self->process_sockets();
  }

  # if there was more to read; then forget it
  $trans->notes('rhsbl_sockets', undef);

  return $trans->notes('rhsbl', $result);
}

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

  $transaction->notes('rhsbl_sockets', undef);
  return DECLINED;
}


=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