From 6495f41bb2d01a13261730bfd2e7ad19ca05d24e Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Tue, 8 Mar 2005 22:58:09 +0000 Subject: [PATCH] High perf versions of these plugins git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@389 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/check_earlytalker | 28 ++--- plugins/dnsbl | 174 ++++++++-------------------- plugins/require_resolvable_fromhost | 96 ++++++++------- plugins/rhsbl | 117 ++++++------------- 4 files changed, 150 insertions(+), 265 deletions(-) diff --git a/plugins/check_earlytalker b/plugins/check_earlytalker index b44192b..f8cd5a1 100644 --- a/plugins/check_earlytalker +++ b/plugins/check_earlytalker @@ -53,14 +53,14 @@ sub register { 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 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; diff --git a/plugins/dnsbl b/plugins/dnsbl index 9c4ec80..a89beee 100644 --- a/plugins/dnsbl +++ b/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) = @_; - - 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"; - } - } +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; } - else { - $self->log(LOGERROR, "$dnsbl query failed: ", $res->errorstring) - unless $res->errorstring eq "NXDOMAIN"; + + 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; } - - 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); - + + 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; } diff --git a/plugins/require_resolvable_fromhost b/plugins/require_resolvable_fromhost index c469533..48b7a95 100644 --- a/plugins/require_resolvable_fromhost +++ b/plugins/require_resolvable_fromhost @@ -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 $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; + 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, + ); } +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; +} diff --git a/plugins/rhsbl b/plugins/rhsbl index ee45e6c..a5c7f59 100644 --- a/plugins/rhsbl +++ b/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) { + 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; -}