High perf versions of these plugins
git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@389 958fd67b-6ff1-0310-b445-bb7760255be9
This commit is contained in:
Matt Sergeant
parent
b5b3950ef9
commit
6495f41bb2
@ -70,17 +70,11 @@ sub register {
|
||||
|
||||
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 @@ sub mail_handler {
|
||||
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;
|
||||
|
||||
164
plugins/dnsbl
164
plugins/dnsbl
@ -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 @@ sub connect_handler {
|
||||
$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) = @_;
|
||||
sub process_a_result {
|
||||
my $self = shift;
|
||||
my ($template, $result, $query) = @_;
|
||||
|
||||
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";
|
||||
warn("Result for A $query: $result\n");
|
||||
if ($result !~ /^\d+\.\d+\.\d+\.\d+$/) {
|
||||
# NXDOMAIN or ERROR possibly...
|
||||
return;
|
||||
}
|
||||
|
||||
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);
|
||||
}
|
||||
my $ip = $self->connection->remote_ip;
|
||||
$template =~ s/%IP%/$ip/g;
|
||||
my $conn = $self->connection;
|
||||
$conn->notes('dnsbl', $template) unless $conn->notes('dnsbl');
|
||||
}
|
||||
|
||||
if ($sel->count) {
|
||||
# loop around if we have dns blacklists left to see results from
|
||||
return $self->process_sockets();
|
||||
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;
|
||||
}
|
||||
|
||||
# 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);
|
||||
|
||||
my $conn = $self->connection;
|
||||
$conn->notes('dnsbl', $result) unless $conn->notes('dnsbl');
|
||||
}
|
||||
|
||||
sub rcpt_handler {
|
||||
@ -148,33 +94,13 @@ sub rcpt_handler {
|
||||
# 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;
|
||||
}
|
||||
|
||||
|
||||
@ -1,26 +1,19 @@
|
||||
use Net::DNS qw(mx);
|
||||
#!/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");
|
||||
}
|
||||
|
||||
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"));
|
||||
$sender->format ne "<>" and $self->check_dns($sender->host);
|
||||
|
||||
return DECLINED;
|
||||
|
||||
}
|
||||
|
||||
|
||||
@ -28,24 +21,47 @@ 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 unless $host;
|
||||
|
||||
return 1 if $host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/;
|
||||
return $self->transaction->notes('resolvable', 1)
|
||||
if $host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/;
|
||||
|
||||
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";
|
||||
}
|
||||
}
|
||||
else {
|
||||
$self->log(LOGWARN, "$$ query for $host failed: ", $res->errorstring)
|
||||
unless $res->errorstring eq "NXDOMAIN";
|
||||
}
|
||||
return 0;
|
||||
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,
|
||||
);
|
||||
}
|
||||
|
||||
sub dns_result {
|
||||
my ($self, $result, $query) = @_;
|
||||
|
||||
if ($result =~ /^[A-Z]+$/) {
|
||||
# probably an error
|
||||
$self->log(LOGDEBUG, "DNS error: $result looking up $query");
|
||||
return;
|
||||
}
|
||||
|
||||
$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;
|
||||
}
|
||||
|
||||
113
plugins/rhsbl
113
plugins/rhsbl
@ -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) {
|
||||
$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 @@ sub mail_handler {
|
||||
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 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});
|
||||
}
|
||||
}
|
||||
my $result = $transaction->notes('rhsbl');
|
||||
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';
|
||||
}
|
||||
|
||||
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 disconnect_handler {
|
||||
my ($self, $transaction) = @_;
|
||||
|
||||
$transaction->notes('rhsbl_sockets', undef);
|
||||
return DECLINED;
|
||||
}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user