byterazor/qpsmtpd
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Create async version of dns_whitelist_soft, rhsbl and uribl plugins.

Browse Source 
git-svn-id: https://svn.perl.org/qpsmtpd/trunk@921 958fd67b-6ff1-0310-b445-bb7760255be9
This commit is contained in:
Radu Greab 2008-06-02 15:51:04 +00:00 committed by Ask Bjørn Hansen
parent 7f07f16a44
commit 4c93c85f55
9 changed files with 516 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Changes
View File

@ -1,3 +1,5 @@
Create async version of dns_whitelist_soft, rhsbl and uribl plugins.
async: added pre- and post-connection hooks
Qpsmtpd::Connection->notes are now reset on end of connection (currently

4
MANIFEST
View File

@ -29,6 +29,7 @@ lib/Qpsmtpd/Connection.pm
lib/Qpsmtpd/Constants.pm
lib/Qpsmtpd/DSN.pm
lib/Qpsmtpd/Plugin.pm
lib/Qpsmtpd/Plugin/Async/DNSBLBase.pm
lib/Qpsmtpd/PollServer.pm
lib/Qpsmtpd/Postfix.pm
lib/Qpsmtpd/Postfix/Constants.pm
@ -47,9 +48,12 @@ MANIFEST This list of files
MANIFEST.SKIP
META.yml Module meta-data (added by MakeMaker)
plugins/async/check_earlytalker
plugins/async/dns_whitelist_soft
plugins/async/dnsbl
plugins/async/require_resolvable_fromhost
plugins/async/rhsbl
plugins/async/queue/smtp-forward
plugins/async/uribl
plugins/auth/auth_cvm_unix_local
plugins/auth/auth_flat_file
plugins/auth/auth_ldap_bind

87
lib/Qpsmtpd/Plugin/Async/DNSBLBase.pm Normal file
View File

@ -0,0 +1,87 @@
package Qpsmtpd::Plugin::Async::DNSBLBase;
# Class methods shared by the async plugins using DNS based blacklists or
# whitelists.
use strict;
use Qpsmtpd::Constants;
use ParaDNS;
sub lookup {
my ($class, $qp, $A_lookups, $TXT_lookups) = @_;
my $total_zones = @$A_lookups + @$TXT_lookups;
my ($A_pdns, $TXT_pdns);
if (@$A_lookups) {
$qp->log(LOGDEBUG, "Checking ",
join(", ", @$A_lookups),
" for A record in the background");
$A_pdns = ParaDNS->new(
callback => sub {
my ($result, $query) = @_;
return if $result !~ /^\d+\.\d+\.\d+\.\d+$/;
$qp->log(LOGDEBUG, "Result for A $query: $result");
$class->process_a_result($qp, $result, $query);
},
finished => sub {
$total_zones -= @$A_lookups;
$class->finished($qp, $total_zones);
},
hosts => [@$A_lookups],
type => 'A',
client => $qp->input_sock,
);
return unless defined $A_pdns;
}
if (@$TXT_lookups) {
$qp->log(LOGDEBUG, "Checking ",
join(", ", @$TXT_lookups),
" for TXT record in the background");
$TXT_pdns = ParaDNS->new(
callback => sub {
my ($result, $query) = @_;
return if $result !~ /[a-z]/;
$qp->log(LOGDEBUG, "Result for TXT $query: $result");
$class->process_txt_result($qp, $result, $query);
},
finished => sub {
$total_zones -= @$TXT_lookups;
$class->finished($qp, $total_zones);
},
hosts => [@$TXT_lookups],
type => 'TXT',
client => $qp->input_sock,
);
unless (defined $TXT_pdns) {
undef $A_pdns;
return;
}
}
return 1;
}
sub finished {
my ($class, $qp, $total_zones) = @_;
$qp->log(LOGDEBUG, "Finished ($total_zones)");
$qp->run_continuation unless $total_zones;
}
# plugins should implement the following two methods to do something
# useful with the results
sub process_a_result {
my ($class, $qp, $result, $query) = @_;
}
sub process_txt_result {
my ($class, $qp, $result, $query) = @_;
}
1;

90
plugins/async/dns_whitelist_soft Normal file
View File

@ -0,0 +1,90 @@
#!perl -w
use Qpsmtpd::Plugin::Async::DNSBLBase;
sub init {
my $self = shift;
my $class = ref $self;
no strict 'refs';
push @{"${class}::ISA"}, 'Qpsmtpd::Plugin::Async::DNSBLBase';
}
sub hook_connect {
my ($self, $transaction) = @_;
my $class = ref $self;
my %whitelist_zones =
map { (split /\s+/, $_, 2)[0, 1] } $self->qp->config('whitelist_zones');
return DECLINED unless %whitelist_zones;
my $remote_ip = $self->connection->remote_ip;
my $reversed_ip = join(".", reverse(split(/\./, $remote_ip)));
# type TXT lookup only
return DECLINED
unless $class->lookup($self->qp, [],
[map { "$reversed_ip.$_" } keys %whitelist_zones],
);
return YIELD;
}
sub process_txt_result {
my ($class, $qp, $result, $query) = @_;
my $connection = $qp->connection;
$connection->notes('whitelisthost', $result)
unless $connection->notes('whitelisthost');
}
sub hook_rcpt {
my ($self, $transaction, $rcpt) = @_;
my $connection = $self->qp->connection;
if (my $note = $connection->notes('whitelisthost')) {
my $ip = $connection->remote_ip;
$self->log(LOGNOTICE, "Host $ip is whitelisted: $note");
}
return DECLINED;
}
1;
=head1 NAME
dns_whitelist_soft - dns-based whitelist override for other qpsmtpd plugins
=head1 DESCRIPTION
The dns_whitelist_soft plugin allows selected host to be whitelisted as
exceptions to later plugin processing. It is most suitable for multisite
installations, so that the whitelist is stored in one location and available
from all.
=head1 CONFIGURATION
To enable the plugin, add it to the ~qpsmtpd/config/plugins file as usual.
It should precede any plugins whose rejections you wish to override. You may
have to alter those plugins to check the appropriate notes field.
Several configuration files are supported, corresponding to different
parts of the SMTP conversation:
=over 4
=item whitelist_zones
Any IP address listed in the whitelist_zones file is queried using
the connecting MTA's IP address. Any A or TXT answer means that the
remote HOST address can be selectively exempted at other stages by plugins
testing for a 'whitelisthost' connection note.
=back
NOTE: in contrast to the non-async version, the other 'connect' hooks
fired after the 'connect' hook of this plugin will see the 'whitelisthost'
connection note, if set by this plugin.
=cut

86
plugins/async/dnsbl
View File

@ -1,20 +1,27 @@
#!/usr/bin/perl -w
use ParaDNS;
use Qpsmtpd::Plugin::Async::DNSBLBase;
sub init {
my ($self, $qp, $denial) = @_;
my $class = ref $self;
{
no strict 'refs';
push @{"${class}::ISA"}, 'Qpsmtpd::Plugin::Async::DNSBLBase';
}
if (defined $denial and $denial =~ /^disconnect$/i) {
$self->{_dnsbl}->{DENY} = DENY_DISCONNECT;
}
else {
$self->{_dnsbl}->{DENY} = DENY;
}
}
sub hook_connect {
my ($self, $transaction) = @_;
my $class = ref $self;
my $remote_ip = $self->connection->remote_ip;
@ -29,72 +36,47 @@ sub hook_connect {
my $reversed_ip = join(".", reverse(split(/\./, $remote_ip)));
my $total_zones = keys %dnsbl_zones;
my $qp = $self->qp;
for my $dnsbl (keys %dnsbl_zones) {
my @A_zones = grep { defined($dnsbl_zones{$_}) } keys %dnsbl_zones;
my @TXT_zones = grep { !defined($dnsbl_zones{$_}) } 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");
ParaDNS->new(
callback => sub {
process_a_result($qp, $dnsbl_zones{$dnsbl}, @_);
},
finished => sub { $total_zones--; finished($qp, $total_zones) },
host => "$reversed_ip.$dnsbl",
type => 'A',
client => $self->qp->input_sock,
if (@A_zones) {
# message templates for responding to the client
$self->connection->notes(
dnsbl_templates => {
map {
+"$reversed_ip.$_" => $dnsbl_zones{$_}
} @A_zones
}
);
}
else {
$self->log(LOGDEBUG,
"Checking $reversed_ip.$dnsbl for TXT record in the background"
return DECLINED
unless $class->lookup($self->qp,
[map { "$reversed_ip.$_" } @A_zones],
[map { "$reversed_ip.$_" } @TXT_zones],
);
ParaDNS->new(
callback => sub { process_txt_result($qp, @_) },
finished => sub { $total_zones--; finished($qp, $total_zones) },
host => "$reversed_ip.$dnsbl",
type => 'TXT',
client => $self->qp->input_sock,
);
}
}
return YIELD;
}
sub finished {
my ($qp, $total_zones) = @_;
$qp->log(LOGINFO, "Finished ($total_zones)");
$qp->run_continuation unless $total_zones;
}
sub process_a_result {
my ($qp, $template, $result, $query) = @_;
$qp->log(LOGINFO, "Result for A $query: $result");
if ($result !~ /^\d+\.\d+\.\d+\.\d+$/) {
# NXDOMAIN or ERROR possibly...
return;
}
my ($class, $qp, $result, $query) = @_;
my $conn = $qp->connection;
return if $conn->notes('dnsbl');
my $templates = $conn->notes('dnsbl_templates');
my $ip = $conn->remote_ip;
my $template = $templates->{$query};
$template =~ s/%IP%/$ip/g;
$conn->notes('dnsbl', $template) unless $conn->notes('dnsbl');
$conn->notes('dnsbl', $template);
}
sub process_txt_result {
my ($qp, $result, $query) = @_;
$qp->log(LOGINFO, "Result for TXT $query: $result");
if ($result !~ /[a-z]/) {
# NXDOMAIN or ERROR probably...
return;
}
my ($class, $qp, $result, $query) = @_;
my $conn = $qp->connection;
$conn->notes('dnsbl', $result) unless $conn->notes('dnsbl');

94
plugins/async/rhsbl Normal file
View File

@ -0,0 +1,94 @@
#!perl -w
use Qpsmtpd::Plugin::Async::DNSBLBase;
sub init {
my $self = shift;
my $class = ref $self;
no strict 'refs';
push @{"${class}::ISA"}, 'Qpsmtpd::Plugin::Async::DNSBLBase';
}
sub hook_mail {
my ($self, $transaction, $sender) = @_;
my $class = ref $self;
return DECLINED if $sender->format eq '<>';
my %rhsbl_zones =
map { (split /\s+/, $_, 2)[0, 1] } $self->qp->config('rhsbl_zones');
return DECLINED unless %rhsbl_zones;
my $sender_host = $sender->host;
my @A_zones = grep { defined($rhsbl_zones{$_}) } keys %rhsbl_zones;
my @TXT_zones = grep { !defined($rhsbl_zones{$_}) } keys %rhsbl_zones;
if (@A_zones) {
# message templates for responding to the client
$transaction->notes(rhsbl_templates =>
{map { +"$sender_host.$_" => $rhsbl_zones{$_} } @A_zones});
}
return DECLINED
unless $class->lookup($self->qp,
[map { "$sender_host.$_" } @A_zones],
[map { "$sender_host.$_" } @TXT_zones],
);
return YIELD;
}
sub process_a_result {
my ($class, $qp, $result, $query) = @_;
my $transaction = $qp->transaction;
$transaction->notes('rhsbl',
$transaction->notes('rhsbl_templates')->{$query})
unless $transaction->notes('rhsbl');
}
sub process_txt_result {
my ($class, $qp, $result, $query) = @_;
my $transaction = $qp->transaction;
$transaction->notes('rhsbl', $result) unless $transaction->notes('rhsbl');
}
sub hook_rcpt {
my ($self, $transaction, $rcpt) = @_;
my $host = $transaction->sender->host;
my $note = $transaction->notes('rhsbl');
return (DENY, "Mail from $host rejected because it $note") if $note;
return DECLINED;
}
1;
=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

144
plugins/async/uribl Normal file
View File

@ -0,0 +1,144 @@
#!/usr/bin/perl -w
use Qpsmtpd::Plugin::Async::DNSBLBase;
use strict;
use warnings;
sub init {
my ($self, $qp, %args) = @_;
my $class = ref $self;
$self->isa_plugin("uribl");
{
no strict 'refs';
push @{"${class}::ISA"}, 'Qpsmtpd::Plugin::Async::DNSBLBase';
}
$self->SUPER::init($qp, %args);
}
sub register {
my $self = shift;
$self->register_hook('data_post', 'start_data_post');
$self->register_hook('data_post', 'finish_data_post');
}
sub start_data_post {
my ($self, $transaction) = @_;
my $class = ref $self;
my @names;
my $queries = $self->lookup_start($transaction, sub {
my ($self, $name) = @_;
push @names, $name;
});
my @hosts;
foreach my $z (keys %{$self->{uribl_zones}}) {
push @hosts, map { "$_.$z" } @names;
}
$transaction->notes(uribl_results => {});
$transaction->notes(uribl_zones => $self->{uribl_zones});
return DECLINED
unless @hosts && $class->lookup($self->qp, [ @hosts ], [ @hosts ]);
return YIELD;
}
sub finish_data_post {
my ($self, $transaction) = @_;
my $matches = $self->collect_results($transaction);
for (@$matches) {
$self->log(LOGWARN, $_->{desc});
if ($_->{action} eq 'add-header') {
$transaction->header->add('X-URIBL-Match', $_->{desc});
} elsif ($_->{action} eq 'deny') {
return (DENY, $_->{desc});
} elsif ($_->{action} eq 'denysoft') {
return (DENYSOFT, $_->{desc});
}
}
return DECLINED;
}
sub init_resolver { }
sub process_a_result {
my ($class, $qp, $result, $query) = @_;
my $transaction = $qp->transaction;
my $results = $transaction->notes('uribl_results');
my $zones = $transaction->notes('uribl_zones');
foreach my $z (keys %$zones) {
if ($query =~ /^(.*)\.$z$/) {
my $name = $1;
$results->{$z}->{$name}->{a} = $result;
}
}
}
sub process_txt_result {
my ($class, $qp, $result, $query) = @_;
my $transaction = $qp->transaction;
my $results = $transaction->notes('uribl_results');
my $zones = $transaction->notes('uribl_zones');
foreach my $z (keys %$zones) {
if ($query =~ /^(.*)\.$z$/) {
my $name = $1;
$results->{$z}->{$name}->{txt} = $result;
}
}
}
sub collect_results {
my ($self, $transaction) = @_;
my $results = $transaction->notes('uribl_results');
my @matches;
foreach my $z (keys %$results) {
foreach my $n (keys %{$results->{$z}}) {
if (exists $results->{$z}->{$n}->{a}) {
if ($self->evaluate($z, $results->{$z}->{$n}->{a})) {
$self->log(LOGDEBUG, "match $n in $z");
push @matches, {
action => $self->{uribl_zones}->{$z}->{action},
desc => "$n in $z: " .
($results->{$z}->{$n}->{txt} || $results->{$z}->{$n}->{a}),
};
}
}
}
}
return \@matches;
}
1;
=head1 NAME
uribl - URIBL blocking plugin for qpsmtpd
=head1 DESCRIPTION
This plugin implements DNSBL lookups for URIs found in spam, such as that
implemented by SURBL (see E<lt>http://surbl.org/E<gt>). Incoming messages are
scanned for URIs, which are then checked against one or more URIBLs in a
fashion similar to DNSBL systems.
=head1 CONFIGURATION
See the documentation of the non-async version. The timeout config option is
ignored, the ParaDNS timeout is used instead.
=cut

6
plugins/dns_whitelist_soft
View File

@ -24,7 +24,7 @@ parts of the SMTP conversation:
=item whitelist_zones
Any IP address listed in the whitelist_zones file is queried using
the connecting MTA's IP address. Any A or TXT answer is means that the
the connecting MTA's IP address. Any A or TXT answer means that the
remote HOST address can be selectively exempted at other stages by plugins
testing for a 'whitelisthost' connection note.
@ -34,6 +34,10 @@ NOTE: other 'connect' hooks will continue to fire (e.g. dnsbl), since the DNS
queries happen in the background. This plugin's 'rcpt_handler' retrieves
the results of the query and sets the connection note if found.
If you switch to qpsmtpd-async and to the async version of this plugin, then
the 'whitelisthost' connection note will be available to the other 'connect'
hooks, see the documentation of the async plugin.
=head1 AUTHOR
John Peacock <jpeacock@rowman.com>

65
plugins/uribl
View File

@ -137,7 +137,8 @@ my %strict_twolevel_cctlds = (
'za' => 1,
);
sub register {
# async version: OK
sub init {
my ($self, $qp, %args) = @_;
$self->{action} = $args{action} || 'add-header';
@ -181,11 +182,17 @@ sub register {
( map { ($_ => 1) } @whitelist )
};
$self->{resolver} = new Net::DNS::Resolver or return undef;
$self->{resolver}->udp_timeout($self->{timeout});
$self->init_resolver;
}
# async version: not used
sub register {
my $self = shift;
$self->register_hook('data_post', 'data_handler');
}
# async version: not used
sub send_query {
my $self = shift;
my $name = shift || return undef;
@ -230,6 +237,7 @@ sub send_query {
$count;
}
# async version: not used
sub lookup_finish {
my $self = shift;
$self->{socket_idx} = {};
@ -237,6 +245,7 @@ sub lookup_finish {
undef $self->{socket_select};
}
# async version: OK
sub evaluate {
my $self = shift;
my $zone = shift || return undef;
@ -251,8 +260,10 @@ sub evaluate {
return ($v & $mask);
}
sub data_handler {
my ($self, $transaction) = @_;
# async version: OK
sub lookup_start {
my ($self, $transaction, $start_query) = @_;
my $l;
my $queries = 0;
my %pending;
@ -297,7 +308,7 @@ sub data_handler {
my $rev = join('.', reverse @octets);
$self->log(LOGDEBUG, "uribl: matched pure-integer ipaddr $1 ($fwd)");
unless (exists $pending{$rev}) {
$queries += $self->send_query($rev);
$queries += $start_query->($self, $rev);
$pending{$rev} = 1;
}
}
@ -320,7 +331,7 @@ sub data_handler {
my $rev = join('.', reverse @octets);
$self->log(LOGDEBUG, "uribl: matched URI ipaddr $fwd");
unless (exists $pending{$rev}) {
$queries += $self->send_query($rev);
$queries += $start_query->($self, $rev);
$pending{$rev} = 1;
}
}
@ -348,7 +359,7 @@ sub data_handler {
my $subhost = join('.', @host_domains);
unless (exists $pending{$subhost}) {
$self->log(LOGINFO, "URIBL: checking sub-host $subhost");
$queries += $self->send_query($subhost);
$queries += $start_query->($self, $subhost);
$pending{$subhost} = 1;
}
shift @host_domains;
@ -379,7 +390,7 @@ sub data_handler {
my $subhost = join('.', @host_domains);
unless (exists $pending{$subhost}) {
$self->log(LOGINFO, "URIBL: checking sub-host $subhost");
$queries += $self->send_query($subhost);
$queries += $start_query->($self, $subhost);
$pending{$subhost} = 1;
}
shift @host_domains;
@ -389,11 +400,13 @@ sub data_handler {
}
$transaction->body_resetpos;
unless ($queries) {
$self->log(LOGINFO, "No URIs found in mail");
return DECLINED;
return $queries;
}
# async version: not used
sub collect_results {
my ($self, $transaction) = @_;
my $matches = 0;
my $complete = 0;
my $start_time = time;
@ -454,7 +467,25 @@ sub data_handler {
$self->lookup_finish;
for (@matches) {
return \@matches;
}
# async version: not used
sub data_handler {
my ($self, $transaction) = @_;
my $queries = $self->lookup_start($transaction, sub {
my ($self, $name) = @_;
return $self->send_query($name);
});
unless ($queries) {
$self->log(LOGINFO, "No URIs found in mail");
return DECLINED;
}
my $matches = $self->collect_results($transaction);
for (@$matches) {
$self->log(LOGWARN, $_->{desc});
if ($_->{action} eq 'add-header') {
$transaction->header->add('X-URIBL-Match', $_->{desc});
@ -467,6 +498,14 @@ sub data_handler {
return DECLINED;
}
# async version: not used
sub init_resolver {
my $self = shift;
$self->{resolver} = new Net::DNS::Resolver or return undef;
$self->{resolver}->udp_timeout($self->{timeout});
}
1;
# vi: ts=4 sw=4 expandtab syn=perl