123346f1f5
move old branches aside git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@629 958fd67b-6ff1-0310-b445-bb7760255be9
124 lines
3.6 KiB
Plaintext
124 lines
3.6 KiB
Plaintext
|
|
|
|
sub hook_mail {
|
|
my ($self, $transaction, $sender) = @_;
|
|
|
|
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 (DENY, "Mail from $host rejected because it " . $self->{_rhsbl_zones_map}{$result});
|
|
} else {
|
|
return (DENY, "Mail from HELO $hello rejected because it " . $self->{_rhsbl_zones_map}{$result});
|
|
}
|
|
}
|
|
return (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;
|
|
}
|