[svn:qpsmtpd] rev 389 - branches/high_perf/plugins
[email protected] 8 Mar 2005 22:58:10 -0000
| Newsgroups | perl.cvs.qpsmtpd |
|---|---|
| Message-ID | <[email protected]> |
Author: msergeant
Date: Tue Mar 8 14:58:09 2005
New Revision: 389
Modified:
branches/high_perf/plugins/check_earlytalker
branches/high_perf/plugins/dnsbl
branches/high_perf/plugins/require_resolvable_fromhost
branches/high_perf/plugins/rhsbl
Log:
High perf versions of these plugins
Modified: branches/high_perf/plugins/check_earlytalker
==============================================================================
--- branches/high_perf/plugins/check_earlytalker (original)
+++ branches/high_perf/plugins/check_earlytalker Tue Mar 8 14:58:09 2005
@@ -53,14 +53,14 @@
my ($self, $qp, @args) = @_;
if (@args % 2) {
- $self->log(LOGERROR, "Unrecognized/mismatched arguments");
- return undef;
+ $self->log(LOGERROR, "Unrecognized/mismatched arguments");
+ return undef;
}
$self->{_args} = {
- 'wait' => 1,
- 'action' => 'denysoft',
- 'defer-reject' => 0,
- @args,
+ 'wait' => 1,
+ 'action' => 'denysoft',
+ 'defer-reject' => 0,
+ @args,
};
$self->register_hook('connect', 'connect_handler');
$self->register_hook('mail', 'mail_handler')
@@ -70,17 +70,11 @@
sub connect_handler {
my ($self, $transaction) = @_;
- my $in = new IO::Select;
- my $ip = $self->qp->connection->remote_ip;
-
- return DECLINED
- if ($self->qp->connection->notes('whitelistclient'));
-
- $in->add(\*STDIN) || return DECLINED;
- if ($in->can_read($self->{_args}->{'wait'})) {
- $self->log(LOGNOTICE, "remote host started talking before we said hello [$ip]");
+
+ if ($self->argh->can_read($self->{_args}->{'wait'})) {
+ $self->log(LOGNOTICE, 'remote host started talking before we said hello');
if ($self->{_args}->{'defer-reject'}) {
- $self->qp->connection->notes('earlytalker', 1);
+ $self->connection->notes('earlytalker', 1);
} else {
my $msg = 'Connecting host started transmitting before SMTP greeting';
return (DENY,$msg) if $self->{_args}->{'action'} eq 'deny';
@@ -96,7 +90,7 @@
my ($self, $txn) = @_;
my $msg = 'Connecting host started transmitting before SMTP greeting';
- return DECLINED unless $self->qp->connection->notes('earlytalker');
+ return DECLINED unless $self->connection->notes('earlytalker');
return (DENY,$msg) if $self->{_args}->{'action'} eq 'deny';
return (DENYSOFT,$msg) if $self->{_args}->{'action'} eq 'denysoft';
return DECLINED;
Modified: branches/high_perf/plugins/dnsbl
==============================================================================
--- branches/high_perf/plugins/dnsbl (original)
+++ branches/high_perf/plugins/dnsbl Tue Mar 8 14:58:09 2005
@@ -1,14 +1,17 @@
+#!/usr/bin/perl -w
+
+use Danga::DNS;
+
sub register {
- my ($self, $qp) = @_;
+ my ($self) = @_;
$self->register_hook("connect", "connect_handler");
$self->register_hook("rcpt", "rcpt_handler");
- $self->register_hook("disconnect", "disconnect_handler");
}
sub connect_handler {
my ($self, $transaction) = @_;
- my $remote_ip = $self->qp->connection->remote_ip;
+ my $remote_ip = $self->connection->remote_ip;
# perform RBLSMTPD checks to mimic Dan Bernstein's rblsmtpd
if (defined($ENV{'RBLSMTPD'})) {
@@ -23,123 +26,66 @@
$self->log(LOGDEBUG, "RBLSMTPD not set for $remote_ip");
}
- my $allow = grep { s/\.?$/./; $_ eq substr($remote_ip . '.', 0, length $_) } $self->qp->config('dnsbl_allow');
+ my $allow = grep { s/\.?$/./; $_ eq substr($remote_ip . '.', 0, length $_) } $self->config('dnsbl_allow');
return DECLINED if $allow;
- my %dnsbl_zones = map { (split /:/, $_, 2)[0,1] } $self->qp->config('dnsbl_zones');
+ my %dnsbl_zones = map { (split /:/, $_, 2)[0,1] } $self->config('dnsbl_zones');
return DECLINED unless %dnsbl_zones;
my $reversed_ip = join(".", reverse(split(/\./, $remote_ip)));
- # we should queue these lookups in the background and just fetch the
- # results in the first rcpt handler ... oh well.
-
- my $res = new Net::DNS::Resolver;
- $res->tcp_timeout(30);
- $res->udp_timeout(30);
-
- my $sel = IO::Select->new();
-
for my $dnsbl (keys %dnsbl_zones) {
# fix to find A records, if the dnsbl_zones line has a second field 20/1/04 ++msp
if (defined($dnsbl_zones{$dnsbl})) {
$self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for A record in the background");
- $sel->add($res->bgsend("$reversed_ip.$dnsbl"));
+ Danga::DNS->new(
+ callback => sub { $self->process_a_result($dnsbl_zones{$dnsbl}, @_) },
+ host => "$reversed_ip.$dnsbl",
+ type => 'A',
+ client => $self->argh->input_sock,
+ );
} else {
$self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for TXT record in the background");
- $sel->add($res->bgsend("$reversed_ip.$dnsbl", "TXT"));
+ Danga::DNS->new(
+ callback => sub { $self->process_txt_result(@_) },
+ host => "$reversed_ip.$dnsbl",
+ type => 'TXT',
+ client => $self->argh->input_sock,
+ );
}
}
- $self->qp->connection->notes('dnsbl_sockets', $sel);
-
return DECLINED;
}
-sub process_sockets {
- my ($self) = @_;
-
- my $conn = $self->qp->connection;
-
- return $conn->notes('dnsbl')
- if $conn->notes('dnsbl');
-
- my %dnsbl_zones = map { (split /:/, $_, 2)[0,1] } $self->qp->config('dnsbl_zones');
-
- my $res = new Net::DNS::Resolver;
- $res->tcp_timeout(30);
- $res->udp_timeout(30);
-
- my $sel = $conn->notes('dnsbl_sockets') or return "";
- my $remote_ip = $self->qp->connection->remote_ip;
-
- my $result;
-
- $self->log(LOGDEBUG, "waiting for dnsbl dns");
-
- # don't wait more than 8 seconds here
- my @ready = $sel->can_read(8);
-
- $self->log(LOGDEBUG, "DONE waiting for dnsbl dns, got " , scalar @ready, " answers ...") ;
- return '' unless @ready;
-
- for my $socket (@ready) {
- my $query = $res->bgread($socket);
- $sel->remove($socket);
- undef $socket;
-
- my $dnsbl;
-
- if ($query) {
- my $a_record = 0;
- foreach my $rr ($query->answer) {
- $a_record = 1 if $rr->type eq "A";
- my $name = $rr->name;
- ($dnsbl) = ($name =~ m/(?:\d+\.){4}(.*)/) unless $dnsbl;
- $dnsbl = $name unless $dnsbl;
- $self->log(LOGDEBUG, "name ", $rr->name);
- next unless $rr->type eq "TXT";
- $self->log(LOGDEBUG, "got txt record");
- $result = $rr->txtdata and last;
- }
- #$a_record and $result = "Blocked by $dnsbl";
-
- if ($a_record) {
- if (defined $dnsbl_zones{$dnsbl}) {
- $result = $dnsbl_zones{$dnsbl};
- #$result =~ s/%IP%/$ENV{'TCPREMOTEIP'}/g;
- $result =~ s/%IP%/$remote_ip/g;
- } else {
- # shouldn't get here?
- $result = "Blocked by $dnsbl";
- }
- }
- }
- else {
- $self->log(LOGERROR, "$dnsbl query failed: ", $res->errorstring)
- unless $res->errorstring eq "NXDOMAIN";
- }
-
- if ($result) {
- #kill any other pending I/O
- $conn->notes('dnsbl_sockets', undef);
- $result = join("\n", $self->qp->config('dnsbl_rejectmsg'), $result);
- return $conn->notes('dnsbl', $result);
- }
- }
-
- if ($sel->count) {
- # loop around if we have dns blacklists left to see results from
- return $self->process_sockets();
- }
-
- # er, the following code doesn't make much sense anymore...
-
- # if there was more to read; then forget it
- $conn->notes('dnsbl_sockets', undef);
-
- return $conn->notes('dnsbl', $result);
+sub process_a_result {
+ my $self = shift;
+ my ($template, $result, $query) = @_;
+
+ warn("Result for A $query: $result\n");
+ if ($result !~ /^\d+\.\d+\.\d+\.\d+$/) {
+ # NXDOMAIN or ERROR possibly...
+ return;
+ }
+
+ my $ip = $self->connection->remote_ip;
+ $template =~ s/%IP%/$ip/g;
+ my $conn = $self->connection;
+ $conn->notes('dnsbl', $template) unless $conn->notes('dnsbl');
+}
+sub process_txt_result {
+ my $self = shift;
+ my ($result, $query) = @_;
+
+ warn("Result for TXT $query: $result\n");
+ if ($result !~ /[a-z]/) {
+ # NXDOMAIN or ERROR probably...
+ return;
+ }
+
+ my $conn = $self->connection;
+ $conn->notes('dnsbl', $result) unless $conn->notes('dnsbl');
}
sub rcpt_handler {
@@ -148,33 +94,13 @@
# RBLSMTPD being non-empty means it contains the failure message to return
if (defined ($ENV{'RBLSMTPD'}) && $ENV{'RBLSMTPD'} ne '') {
my $result = $ENV{'RBLSMTPD'};
- my $remote_ip = $self->qp->connection->remote_ip;
+ my $remote_ip = $self->connection->remote_ip;
$result =~ s/%IP%/$remote_ip/g;
- return (DENY, join(" ", $self->qp->config('dnsbl_rejectmsg'), $result));
+ return (DENY, join(" ", $self->config('dnsbl_rejectmsg'), $result));
}
- my $note = $self->process_sockets;
- my $whitelist = $self->qp->connection->notes('whitelisthost');
- if ( $note ) {
- if ( $rcpt->user =~ /^(?:postmaster|abuse|mailer-daemon|root)$/i ) {
- $self->log(2, "Don't blacklist special account: ".$rcpt->user);
- }
- elsif ( $whitelist ) {
- $self->log(2, "Whitelist overrode blacklist: $whitelist");
- }
- else {
- return (DENY, $note);
- }
- }
- return DECLINED;
-
-}
-
-sub disconnect_handler {
- my ($self, $transaction) = @_;
-
- $self->qp->connection->notes('dnsbl_sockets', undef);
-
+ my $note = $self->connection->notes('dnsbl');
+ return (DENY, $note) if $note;
return DECLINED;
}
Modified: branches/high_perf/plugins/require_resolvable_fromhost
==============================================================================
--- branches/high_perf/plugins/require_resolvable_fromhost (original)
+++ branches/high_perf/plugins/require_resolvable_fromhost Tue Mar 8 14:58:09 2005
@@ -1,51 +1,67 @@
-use Net::DNS qw(mx);
+#!/usr/bin/perl
+
+use Danga::DNS;
sub register {
- my ($self, $qp) = @_;
- $self->register_hook("mail", "mail_handler");
+ my ($self) = @_;
+ $self->register_hook("mail", "mail_handler");
+ $self->register_hook("rcpt", "rcpt_handler");
}
sub mail_handler {
- my ($self, $transaction, $sender) = @_;
-
- return DECLINED
- if ($self->qp->connection->notes('whitelistclient'));
-
- $sender->format ne "<>"
- and $self->qp->config("require_resolvable_fromhost")
- and !$self->check_dns($sender->host)
- and return (DENYSOFT,
- ($sender->host
- ? "Could not resolve ". $sender->host
- : "FQDN required in the envelope sender"));
-
- return DECLINED;
-
+ my ($self, $transaction, $sender) = @_;
+
+ $sender->format ne "<>" and $self->check_dns($sender->host);
+
+ return DECLINED;
}
sub check_dns {
- my ($self, $host) = @_;
-
- # for stuff where we can't even parse a hostname out of the address
- return 0 unless $host;
-
- return 1 if $host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/;
+ my ($self, $host) = @_;
+
+ # for stuff where we can't even parse a hostname out of the address
+ return unless $host;
+
+ return $self->transaction->notes('resolvable', 1)
+ if $host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/;
+
+ Danga::DNS->new(
+ callback => sub { $self->dns_result(@_) },
+ host => $host,
+ type => "MX",
+ client => $self->argh->input_sock,
+ );
+ Danga::DNS->new(
+ callback => sub { $self->dns_result(@_) },
+ host => $host,
+ client => $self->argh->input_sock,
+ );
+}
- my $res = new Net::DNS::Resolver;
- $res->tcp_timeout(30);
- $res->udp_timeout(30);
- return 1 if mx($res, $host);
- my $query = $res->search($host);
- if ($query) {
- foreach my $rr ($query->answer) {
- return 1 if $rr->type eq "A" or $rr->type eq "MX";
+sub dns_result {
+ my ($self, $result, $query) = @_;
+
+ if ($result =~ /^[A-Z]+$/) {
+ # probably an error
+ $self->log(LOGDEBUG, "DNS error: $result looking up $query");
+ return;
}
- }
- else {
- $self->log(LOGWARN, "$$ query for $host failed: ", $res->errorstring)
- unless $res->errorstring eq "NXDOMAIN";
- }
- return 0;
+
+ $self->log(LOGDEBUG, "DNS lookup $query returned: $result");
+ $self->transaction->notes('resolvable', 1);
}
+sub rcpt_handler {
+ my ($self, $transaction) = @_;
+
+ if (!$transaction->notes('resolvable')) {
+ my $sender = $transaction->sender;
+ return (DENYSOFT,
+ ($sender->host
+ ? "Could not resolve ". $sender->host
+ : "FQDN required in the envelope sender"));
+ }
+
+ return DECLINED;
+}
Modified: branches/high_perf/plugins/rhsbl
==============================================================================
--- branches/high_perf/plugins/rhsbl (original)
+++ branches/high_perf/plugins/rhsbl Tue Mar 8 14:58:09 2005
@@ -1,38 +1,39 @@
+#!/usr/bin/perl
+
+use Danga::DNS;
+
sub register {
- my ($self, $qp) = @_;
+ my ($self) = @_;
$self->register_hook('mail', 'mail_handler');
$self->register_hook('rcpt', 'rcpt_handler');
- $self->register_hook('disconnect', 'disconnect_handler');
}
sub mail_handler {
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');
+ my %rhsbl_zones = map { (split /\s+/, $_, 2)[0,1] } $self->config('rhsbl_zones');
if ($sender->format ne '<>' and %rhsbl_zones) {
- my $helo = $self->qp->connection->hello_host;
+ 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) {
+ for my $rhsbl (keys %rhsbl_zones) {
$self->log(LOGDEBUG, "Checking $host.$rhsbl for A record in the background");
- $sel->add($res->bgsend("$host.$rhsbl"));
- $rhsbl_zones_map{"$host.$rhsbl"} = $rhsbl_zones{$rhsbl};
+ Danga::DNS->new(
+ callback => sub { $self->process_result($host, $rhsbl_zones{$rhsbl}, @_) },
+ host => "$host.$rhsbl",
+ client => $self->argh->input_sock,
+ );
+ }
}
- }
-
- %{$self->{_rhsbl_zones_map}} = %rhsbl_zones_map;
- $transaction->notes('rhsbl_sockets', $sel);
} else {
$self->log(LOGDEBUG, 'no RHS checks necessary');
}
@@ -40,80 +41,28 @@
return DECLINED;
}
-sub rcpt_handler {
- 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});
+sub process_result {
+ my ($self, $host, $template, $result, $query) = @_;
+
+ if ($result !~ /^\d+\.\d+\.\d+\.\d+$/) {
+ # NXDOMAIN or error
+ return;
}
- }
- 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;
- }
- }
- } else {
- $self->log(LOGCRIT, "query failed: ", $res->errorstring) unless $res->errorstring eq 'NXDOMAIN';
+
+ 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");
}
-
- if ($result) {
- #kill any other pending I/O
- $trans->notes('rhsbl_sockets', undef);
- return $trans->notes('rhsbl', $result);
+ else {
+ $tran->notes('rhsbl', "Mail from HELO $host rejected because it $template");
}
- }
-
- 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 disconnect_handler {
- my ($self, $transaction) = @_;
+sub rcpt_handler {
+ my ($self, $transaction, $rcpt) = @_;
- $transaction->notes('rhsbl_sockets', undef);
+ my $result = $transaction->notes('rhsbl');
+ return (DENY, $result) if $result;
return DECLINED;
}