async removed
1. the known users of async don't upgrade 2. async becomes a win when concurrent connections exceed a few hundred simultaneous 3. anyone that needs async should be looking at Haraka instead 4. the perl async dependencies aren't maintained
This commit is contained in:
Matt Simerson
parent
ed3e550d7f
commit
1e82ae1bc7
8
MANIFEST
8
MANIFEST
@ -68,13 +68,6 @@ Makefile.PL
|
|||||||
MANIFEST This list of files
|
MANIFEST This list of files
|
||||||
MANIFEST.SKIP
|
MANIFEST.SKIP
|
||||||
META.yml Module meta-data (added by MakeMaker)
|
META.yml Module meta-data (added by MakeMaker)
|
||||||
plugins/async/dns_whitelist_soft
|
|
||||||
plugins/async/dnsbl
|
|
||||||
plugins/async/earlytalker
|
|
||||||
plugins/async/queue/smtp-forward
|
|
||||||
plugins/async/resolvable_fromhost
|
|
||||||
plugins/async/rhsbl
|
|
||||||
plugins/async/uribl
|
|
||||||
plugins/auth/auth_checkpassword
|
plugins/auth/auth_checkpassword
|
||||||
plugins/auth/auth_cvm_unix_local
|
plugins/auth/auth_cvm_unix_local
|
||||||
plugins/auth/auth_flat_file
|
plugins/auth/auth_flat_file
|
||||||
@ -156,7 +149,6 @@ plugins/virus/sophie
|
|||||||
plugins/virus/uvscan
|
plugins/virus/uvscan
|
||||||
plugins/whitelist
|
plugins/whitelist
|
||||||
qpsmtpd
|
qpsmtpd
|
||||||
qpsmtpd-async
|
|
||||||
qpsmtpd-forkserver
|
qpsmtpd-forkserver
|
||||||
qpsmtpd-prefork
|
qpsmtpd-prefork
|
||||||
README
|
README
|
||||||
|
|||||||
@ -36,7 +36,7 @@ WriteMakefile(
|
|||||||
},
|
},
|
||||||
ABSTRACT => 'Flexible smtpd daemon written in Perl',
|
ABSTRACT => 'Flexible smtpd daemon written in Perl',
|
||||||
AUTHOR => 'Ask Bjoern Hansen <ask@develooper.com>',
|
AUTHOR => 'Ask Bjoern Hansen <ask@develooper.com>',
|
||||||
EXE_FILES => [qw(qpsmtpd qpsmtpd-forkserver qpsmtpd-prefork qpsmtpd-async)],
|
EXE_FILES => [qw(qpsmtpd qpsmtpd-forkserver qpsmtpd-prefork)],
|
||||||
clean => { FILES => [ '*.bak' ], },
|
clean => { FILES => [ '*.bak' ], },
|
||||||
);
|
);
|
||||||
|
|
||||||
|
|||||||
3
README
3
README
@ -110,8 +110,7 @@ information about what's missing) to the mailinglist or a PR to github.
|
|||||||
|
|
||||||
For better performance we recommend using "qpsmtpd-forkserver" or
|
For better performance we recommend using "qpsmtpd-forkserver" or
|
||||||
running qpsmtpd under Apache 2.x. If you need extremely high
|
running qpsmtpd under Apache 2.x. If you need extremely high
|
||||||
concurrency and all your plugins are compatible, you might want to try
|
concurrency use http://haraka.github.io/
|
||||||
the "qpsmtpd-async" model.
|
|
||||||
|
|
||||||
=head1 Plugins
|
=head1 Plugins
|
||||||
|
|
||||||
|
|||||||
@ -94,8 +94,7 @@ information about what's missing) to the mailinglist or a PR to github.
|
|||||||
|
|
||||||
For better performance we recommend using "qpsmtpd-forkserver" or
|
For better performance we recommend using "qpsmtpd-forkserver" or
|
||||||
running qpsmtpd under Apache 2.x. If you need extremely high
|
running qpsmtpd under Apache 2.x. If you need extremely high
|
||||||
concurrency and all your plugins are compatible, you might want to try
|
concurrency use [Haraka](http://haraka.github.io/).
|
||||||
the "qpsmtpd-async" model.
|
|
||||||
|
|
||||||
# Plugins
|
# Plugins
|
||||||
|
|
||||||
|
|||||||
@ -4,7 +4,7 @@
|
|||||||
|
|
||||||
###
|
###
|
||||||
# Conventions:
|
# Conventions:
|
||||||
# plugin names: F<myplugin>, F<qpsmtpd-async>
|
# plugin names: F<myplugin>
|
||||||
# constants: I<LOGDEBUG>
|
# constants: I<LOGDEBUG>
|
||||||
# smtp commands, answers: B<HELO>, B<250 Queued!>
|
# smtp commands, answers: B<HELO>, B<250 Queued!>
|
||||||
#
|
#
|
||||||
|
|||||||
@ -4,7 +4,7 @@
|
|||||||
|
|
||||||
###
|
###
|
||||||
# Conventions:
|
# Conventions:
|
||||||
# plugin names: F<myplugin>, F<qpsmtpd-async>
|
# plugin names: F<myplugin>
|
||||||
# constants: I<LOGDEBUG>
|
# constants: I<LOGDEBUG>
|
||||||
# smtp commands, answers: B<HELO>, B<250 Queued!>
|
# smtp commands, answers: B<HELO>, B<250 Queued!>
|
||||||
#
|
#
|
||||||
@ -42,8 +42,7 @@ connection to the worker process).
|
|||||||
Useful for load-management and rereading large config files at some
|
Useful for load-management and rereading large config files at some
|
||||||
frequency less than once per session.
|
frequency less than once per session.
|
||||||
|
|
||||||
This hook is available in the F<qpsmtpd-forkserver>, F<qpsmtpd-prefork> and
|
This hook is available in F<qpsmtpd-forkserver> and F<qpsmtpd-prefork> flavors.
|
||||||
F<qpsmtpd-async> flavours.
|
|
||||||
|
|
||||||
=cut
|
=cut
|
||||||
|
|
||||||
@ -56,8 +55,7 @@ methods which (I<may>) take some time, like DNS lookups. This will slow down
|
|||||||
B<all> incoming connections, no other connection will be accepted while this
|
B<all> incoming connections, no other connection will be accepted while this
|
||||||
hook is running!
|
hook is running!
|
||||||
|
|
||||||
Arguments this hook receives are (B<NOTE>: currently no C<%args> for
|
Arguments this hook receives are:
|
||||||
F<qpsmtpd-async>):
|
|
||||||
|
|
||||||
my ($self,$transaction,%args) = @_;
|
my ($self,$transaction,%args) = @_;
|
||||||
# %args is:
|
# %args is:
|
||||||
@ -368,8 +366,6 @@ B<NOTE:> BE CAREFUL! If you drop the connection legal MTAs will retry again
|
|||||||
and again, spammers will probably not. This is not RFC compliant and can lead
|
and again, spammers will probably not. This is not RFC compliant and can lead
|
||||||
to an unpredictable mess. Use with caution.
|
to an unpredictable mess. Use with caution.
|
||||||
|
|
||||||
B<NOTE:> This hook does not currently work in async mode.
|
|
||||||
|
|
||||||
Why this hook may be useful for you, see
|
Why this hook may be useful for you, see
|
||||||
L<http://www.nntp.perl.org/group/perl.qpsmtpd/2009/02/msg8502.html>, ff.
|
L<http://www.nntp.perl.org/group/perl.qpsmtpd/2009/02/msg8502.html>, ff.
|
||||||
|
|
||||||
@ -899,20 +895,6 @@ Arguments are
|
|||||||
|
|
||||||
my ($self,$transaction,@args) = @_;
|
my ($self,$transaction,@args) = @_;
|
||||||
|
|
||||||
=head2 hook_post_fork
|
|
||||||
|
|
||||||
B<NOTE:> This hook is only available in qpsmtpd-async.
|
|
||||||
|
|
||||||
It is called while starting qpsmtpd-async. You can run more than one
|
|
||||||
instance of qpsmtpd-async (one per CPU probably). This hook is called
|
|
||||||
after forking one instance.
|
|
||||||
|
|
||||||
Arguments:
|
|
||||||
|
|
||||||
my $self = shift;
|
|
||||||
|
|
||||||
The return values of this hook are discarded.
|
|
||||||
|
|
||||||
=head1 Authentication hooks
|
=head1 Authentication hooks
|
||||||
|
|
||||||
=cut
|
=cut
|
||||||
|
|||||||
@ -4,7 +4,7 @@
|
|||||||
|
|
||||||
###
|
###
|
||||||
# Conventions:
|
# Conventions:
|
||||||
# plugin names: F<myplugin>, F<qpsmtpd-async>
|
# plugin names: F<myplugin>
|
||||||
# constants: I<LOGDEBUG>
|
# constants: I<LOGDEBUG>
|
||||||
# smtp commands, answers: B<HELO>, B<250 Queued!>
|
# smtp commands, answers: B<HELO>, B<250 Queued!>
|
||||||
#
|
#
|
||||||
@ -132,7 +132,7 @@ a good idea. This initialisation happens before any C<fork()> is done.
|
|||||||
Therefore the file handle will be shared by all qpsmtpd processes and the
|
Therefore the file handle will be shared by all qpsmtpd processes and the
|
||||||
database will probably be confused if several different queries arrive on
|
database will probably be confused if several different queries arrive on
|
||||||
the same file handle at the same time (and you may get the wrong answer, if
|
the same file handle at the same time (and you may get the wrong answer, if
|
||||||
any). This is also true for F<qpsmtpd-async> and the pperl flavours, but
|
any). This is also true for the pperl flavor but
|
||||||
not for F<qpsmtpd> started by (x)inetd or tcpserver.
|
not for F<qpsmtpd> started by (x)inetd or tcpserver.
|
||||||
|
|
||||||
In short: don't do it if you want to write portable plugins.
|
In short: don't do it if you want to write portable plugins.
|
||||||
@ -390,12 +390,6 @@ See note above about SMTP specs.
|
|||||||
Finishing processing of the request. Usually used when the plugin sent the
|
Finishing processing of the request. Usually used when the plugin sent the
|
||||||
response to the client.
|
response to the client.
|
||||||
|
|
||||||
=item YIELD
|
|
||||||
|
|
||||||
Only used in F<qpsmtpd-async>, see F<plugins/async/*>
|
|
||||||
|
|
||||||
=back
|
=back
|
||||||
|
|
||||||
=cut
|
=cut
|
||||||
|
|
||||||
# vim: ts=2 sw=2 expandtab
|
|
||||||
|
|||||||
@ -4,7 +4,7 @@
|
|||||||
|
|
||||||
###
|
###
|
||||||
# Conventions:
|
# Conventions:
|
||||||
# plugin names: F<myplugin>, F<qpsmtpd-async>
|
# plugin names: F<myplugin>
|
||||||
# constants: I<LOGDEBUG>
|
# constants: I<LOGDEBUG>
|
||||||
# smtp commands, answers: B<HELO>, B<250 Queued!>
|
# smtp commands, answers: B<HELO>, B<250 Queued!>
|
||||||
#
|
#
|
||||||
|
|||||||
@ -1,241 +0,0 @@
|
|||||||
# $Id: Client.pm,v 1.8 2005/02/14 22:06:38 msergeant Exp $
|
|
||||||
|
|
||||||
package Danga::Client;
|
|
||||||
use base 'Danga::TimeoutSocket';
|
|
||||||
use fields qw(
|
|
||||||
line
|
|
||||||
pause_count
|
|
||||||
read_bytes
|
|
||||||
data_bytes
|
|
||||||
callback
|
|
||||||
get_chunks
|
|
||||||
reader_object
|
|
||||||
);
|
|
||||||
use Time::HiRes ();
|
|
||||||
|
|
||||||
use bytes;
|
|
||||||
|
|
||||||
# 30 seconds max timeout!
|
|
||||||
sub max_idle_time { 30 }
|
|
||||||
sub max_connect_time { 1200 }
|
|
||||||
|
|
||||||
sub new {
|
|
||||||
my Danga::Client $self = shift;
|
|
||||||
$self = fields::new($self) unless ref $self;
|
|
||||||
$self->SUPER::new(@_);
|
|
||||||
|
|
||||||
$self->reset_for_next_message;
|
|
||||||
return $self;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub reset_for_next_message {
|
|
||||||
my Danga::Client $self = shift;
|
|
||||||
$self->{line} = '';
|
|
||||||
$self->{pause_count} = 0;
|
|
||||||
$self->{read_bytes} = 0;
|
|
||||||
$self->{callback} = undef;
|
|
||||||
$self->{reader_object} = undef;
|
|
||||||
$self->{data_bytes} = '';
|
|
||||||
$self->{get_chunks} = 0;
|
|
||||||
return $self;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub get_bytes {
|
|
||||||
my Danga::Client $self = shift;
|
|
||||||
my ($bytes, $callback) = @_;
|
|
||||||
if ($self->{callback}) {
|
|
||||||
die "get_bytes/get_chunks currently in progress!";
|
|
||||||
}
|
|
||||||
$self->{read_bytes} = $bytes;
|
|
||||||
$self->{data_bytes} = $self->{line};
|
|
||||||
$self->{read_bytes} -= length($self->{data_bytes});
|
|
||||||
$self->{line} = '';
|
|
||||||
if ($self->{read_bytes} <= 0) {
|
|
||||||
if ($self->{read_bytes} < 0) {
|
|
||||||
$self->{line} = substr(
|
|
||||||
$self->{data_bytes},
|
|
||||||
$self->{read_bytes}, # negative offset
|
|
||||||
0 - $self->{read_bytes}, # to end of str
|
|
||||||
""
|
|
||||||
); # truncate that substr
|
|
||||||
}
|
|
||||||
$callback->($self->{data_bytes});
|
|
||||||
return;
|
|
||||||
}
|
|
||||||
$self->{callback} = $callback;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub process_chunk {
|
|
||||||
my Danga::Client $self = shift;
|
|
||||||
my $callback = shift;
|
|
||||||
|
|
||||||
my $last_crlf = rindex($self->{line}, "\r\n");
|
|
||||||
|
|
||||||
if ($last_crlf != -1) {
|
|
||||||
if ($last_crlf + 2 == length($self->{line})) {
|
|
||||||
my $data = $self->{line};
|
|
||||||
$self->{line} = '';
|
|
||||||
$callback->($data);
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
my $data = substr($self->{line}, 0, $last_crlf + 2);
|
|
||||||
$self->{line} = substr($self->{line}, $last_crlf + 2);
|
|
||||||
$callback->($data);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub get_chunks {
|
|
||||||
my Danga::Client $self = shift;
|
|
||||||
my ($bytes, $callback) = @_;
|
|
||||||
if ($self->{callback}) {
|
|
||||||
die "get_bytes/get_chunks currently in progress!";
|
|
||||||
}
|
|
||||||
$self->{read_bytes} = $bytes;
|
|
||||||
$self->process_chunk($callback) if length($self->{line});
|
|
||||||
$self->{callback} = $callback;
|
|
||||||
$self->{get_chunks} = 1;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub end_get_chunks {
|
|
||||||
my Danga::Client $self = shift;
|
|
||||||
my $remaining = shift;
|
|
||||||
$self->{callback} = undef;
|
|
||||||
$self->{get_chunks} = 0;
|
|
||||||
if (defined($remaining)) {
|
|
||||||
$self->process_read_buf(\$remaining);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub set_reader_object {
|
|
||||||
my Danga::Client $self = shift;
|
|
||||||
$self->{reader_object} = shift;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub event_read {
|
|
||||||
my Danga::Client $self = shift;
|
|
||||||
if (my $obj = $self->{reader_object}) {
|
|
||||||
$self->{reader_object} = undef;
|
|
||||||
$obj->event_read($self);
|
|
||||||
}
|
|
||||||
elsif ($self->{callback}) {
|
|
||||||
$self->{alive_time} = time;
|
|
||||||
if ($self->{get_chunks}) {
|
|
||||||
my $bref = $self->read($self->{read_bytes});
|
|
||||||
return $self->close($!) unless defined $bref;
|
|
||||||
$self->{line} .= $$bref;
|
|
||||||
$self->process_chunk($self->{callback}) if length($self->{line});
|
|
||||||
return;
|
|
||||||
}
|
|
||||||
if ($self->{read_bytes} > 0) {
|
|
||||||
my $bref = $self->read($self->{read_bytes});
|
|
||||||
return $self->close($!) unless defined $bref;
|
|
||||||
$self->{read_bytes} -= length($$bref);
|
|
||||||
$self->{data_bytes} .= $$bref;
|
|
||||||
}
|
|
||||||
if ($self->{read_bytes} <= 0) {
|
|
||||||
|
|
||||||
# print "Erk, read too much!\n" if $self->{read_bytes} < 0;
|
|
||||||
my $cb = $self->{callback};
|
|
||||||
$self->{callback} = undef;
|
|
||||||
$cb->($self->{data_bytes});
|
|
||||||
}
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
my $bref = $self->read(8192);
|
|
||||||
return $self->close($!) unless defined $bref;
|
|
||||||
$self->process_read_buf($bref);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub process_read_buf {
|
|
||||||
my Danga::Client $self = shift;
|
|
||||||
my $bref = shift;
|
|
||||||
$self->{line} .= $$bref;
|
|
||||||
return if $self->{pause_count} || $self->{closed};
|
|
||||||
|
|
||||||
if ($self->{line} =~ s/^(.*?\n)//) {
|
|
||||||
my $line = $1;
|
|
||||||
$self->{alive_time} = time;
|
|
||||||
my $resp = $self->process_line($line);
|
|
||||||
if ($::DEBUG > 1 and $resp) {
|
|
||||||
print "$$:" . ($self + 0) . "S: $_\n" for split(/\n/, $resp);
|
|
||||||
}
|
|
||||||
$self->write($resp) if $resp;
|
|
||||||
|
|
||||||
# $self->watch_read(0) if $self->{pause_count};
|
|
||||||
return if $self->{pause_count} || $self->{closed};
|
|
||||||
|
|
||||||
# read more in a timer, to give other clients a look in
|
|
||||||
$self->AddTimer(
|
|
||||||
0,
|
|
||||||
sub {
|
|
||||||
if (length($self->{line}) && !$self->paused) {
|
|
||||||
$self->process_read_buf(\"")
|
|
||||||
; # " for bad syntax highlighters
|
|
||||||
}
|
|
||||||
}
|
|
||||||
);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub has_data {
|
|
||||||
my Danga::Client $self = shift;
|
|
||||||
return length($self->{line}) ? 1 : 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub clear_data {
|
|
||||||
my Danga::Client $self = shift;
|
|
||||||
$self->{line} = '';
|
|
||||||
}
|
|
||||||
|
|
||||||
sub paused {
|
|
||||||
my Danga::Client $self = shift;
|
|
||||||
return 1 if $self->{pause_count};
|
|
||||||
return 1 if $self->{closed};
|
|
||||||
return 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub pause_read {
|
|
||||||
my Danga::Client $self = shift;
|
|
||||||
$self->{pause_count}++;
|
|
||||||
|
|
||||||
# $self->watch_read(0);
|
|
||||||
}
|
|
||||||
|
|
||||||
sub continue_read {
|
|
||||||
my Danga::Client $self = shift;
|
|
||||||
$self->{pause_count}--;
|
|
||||||
if ($self->{pause_count} <= 0) {
|
|
||||||
$self->{pause_count} = 0;
|
|
||||||
$self->AddTimer(
|
|
||||||
0,
|
|
||||||
sub {
|
|
||||||
if (length($self->{line}) && !$self->paused) {
|
|
||||||
$self->process_read_buf(\"")
|
|
||||||
; # " for bad syntax highlighters
|
|
||||||
}
|
|
||||||
}
|
|
||||||
);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub process_line {
|
|
||||||
my Danga::Client $self = shift;
|
|
||||||
return '';
|
|
||||||
}
|
|
||||||
|
|
||||||
sub close {
|
|
||||||
my Danga::Client $self = shift;
|
|
||||||
print "closing @_\n" if $::DEBUG;
|
|
||||||
$self->SUPER::close(@_);
|
|
||||||
}
|
|
||||||
|
|
||||||
sub event_err { my Danga::Client $self = shift; $self->close("Error") }
|
|
||||||
|
|
||||||
sub event_hup {
|
|
||||||
my Danga::Client $self = shift;
|
|
||||||
$self->close("Disconnect (HUP)");
|
|
||||||
}
|
|
||||||
|
|
||||||
1;
|
|
||||||
@ -1,67 +0,0 @@
|
|||||||
# $Id: TimeoutSocket.pm,v 1.2 2005/02/02 20:44:35 msergeant Exp $
|
|
||||||
|
|
||||||
package Danga::TimeoutSocket;
|
|
||||||
|
|
||||||
use base 'Danga::Socket';
|
|
||||||
use fields qw(alive_time create_time);
|
|
||||||
|
|
||||||
our $last_cleanup = 0;
|
|
||||||
|
|
||||||
Danga::Socket->AddTimer(15, \&_do_cleanup);
|
|
||||||
|
|
||||||
sub new {
|
|
||||||
my Danga::TimeoutSocket $self = shift;
|
|
||||||
my $sock = shift;
|
|
||||||
$self = fields::new($self) unless ref($self);
|
|
||||||
$self->SUPER::new($sock);
|
|
||||||
|
|
||||||
my $now = time;
|
|
||||||
$self->{alive_time} = $self->{create_time} = $now;
|
|
||||||
|
|
||||||
return $self;
|
|
||||||
}
|
|
||||||
|
|
||||||
# overload these in a subclass
|
|
||||||
sub max_idle_time { 0 }
|
|
||||||
sub max_connect_time { 0 }
|
|
||||||
|
|
||||||
sub Reset {
|
|
||||||
Danga::Socket->Reset;
|
|
||||||
Danga::Socket->AddTimer(15, \&_do_cleanup);
|
|
||||||
}
|
|
||||||
|
|
||||||
sub _do_cleanup {
|
|
||||||
my $now = time;
|
|
||||||
|
|
||||||
Danga::Socket->AddTimer(15, \&_do_cleanup);
|
|
||||||
|
|
||||||
my $sf = __PACKAGE__->get_sock_ref;
|
|
||||||
|
|
||||||
my %max_age; # classname -> max age (0 means forever)
|
|
||||||
my %max_connect; # classname -> max connect time
|
|
||||||
my @to_close;
|
|
||||||
while (my $k = each %$sf) {
|
|
||||||
my Danga::TimeoutSocket $v = $sf->{$k};
|
|
||||||
my $ref = ref $v;
|
|
||||||
next unless $v->isa('Danga::TimeoutSocket');
|
|
||||||
unless (defined $max_age{$ref}) {
|
|
||||||
$max_age{$ref} = $ref->max_idle_time || 0;
|
|
||||||
$max_connect{$ref} = $ref->max_connect_time || 0;
|
|
||||||
}
|
|
||||||
if (my $t = $max_connect{$ref}) {
|
|
||||||
if ($v->{create_time} < $now - $t) {
|
|
||||||
push @to_close, $v;
|
|
||||||
next;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
if (my $t = $max_age{$ref}) {
|
|
||||||
if ($v->{alive_time} < $now - $t) {
|
|
||||||
push @to_close, $v;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
$_->close("Timeout") foreach @to_close;
|
|
||||||
}
|
|
||||||
|
|
||||||
1;
|
|
||||||
@ -277,9 +277,6 @@ sub run_hooks_no_respond {
|
|||||||
warn("FATAL PLUGIN ERROR [" . $code->{name} . "]: ", $@);
|
warn("FATAL PLUGIN ERROR [" . $code->{name} . "]: ", $@);
|
||||||
next;
|
next;
|
||||||
}
|
}
|
||||||
if ($r[0] == YIELD) {
|
|
||||||
die "YIELD not valid from $hook hook";
|
|
||||||
}
|
|
||||||
last unless $r[0] == DECLINED;
|
last unless $r[0] == DECLINED;
|
||||||
}
|
}
|
||||||
$r[0] = DECLINED if not defined $r[0];
|
$r[0] = DECLINED if not defined $r[0];
|
||||||
@ -288,14 +285,10 @@ sub run_hooks_no_respond {
|
|||||||
return (0, '');
|
return (0, '');
|
||||||
}
|
}
|
||||||
|
|
||||||
sub continue_read { } # subclassed in -async
|
|
||||||
sub pause_read { die "Continuations only work in qpsmtpd-async" }
|
|
||||||
|
|
||||||
sub run_continuation {
|
sub run_continuation {
|
||||||
my $self = shift;
|
my $self = shift;
|
||||||
|
|
||||||
die "No continuation in progress" unless $self->{_continuation};
|
die "No continuation in progress" unless $self->{_continuation};
|
||||||
$self->continue_read();
|
|
||||||
my $todo = $self->{_continuation};
|
my $todo = $self->{_continuation};
|
||||||
$self->{_continuation} = undef;
|
$self->{_continuation} = undef;
|
||||||
my $hook = shift @$todo || die "No hook in the continuation";
|
my $hook = shift @$todo || die "No hook in the continuation";
|
||||||
@ -335,12 +328,7 @@ sub run_continuation {
|
|||||||
if (!defined $cnotes || ref $cnotes eq "HASH");
|
if (!defined $cnotes || ref $cnotes eq "HASH");
|
||||||
}
|
}
|
||||||
|
|
||||||
if ($r[0] == YIELD) {
|
if ( $r[0] == DENY
|
||||||
$self->pause_read();
|
|
||||||
$self->{_continuation} = [$hook, $args, @$todo];
|
|
||||||
return @r;
|
|
||||||
}
|
|
||||||
elsif ( $r[0] == DENY
|
|
||||||
or $r[0] == DENYSOFT
|
or $r[0] == DENYSOFT
|
||||||
or $r[0] == DENY_DISCONNECT
|
or $r[0] == DENY_DISCONNECT
|
||||||
or $r[0] == DENYSOFT_DISCONNECT)
|
or $r[0] == DENYSOFT_DISCONNECT)
|
||||||
|
|||||||
@ -25,8 +25,6 @@ my %return_codes = (
|
|||||||
DENYSOFT_DISCONNECT => 904, # 450 + disconnect
|
DENYSOFT_DISCONNECT => 904, # 450 + disconnect
|
||||||
DECLINED => 909,
|
DECLINED => 909,
|
||||||
DONE => 910,
|
DONE => 910,
|
||||||
CONTINUATION => 911, # deprecated - use YIELD
|
|
||||||
YIELD => 911,
|
|
||||||
);
|
);
|
||||||
|
|
||||||
use vars qw(@ISA @EXPORT);
|
use vars qw(@ISA @EXPORT);
|
||||||
|
|||||||
@ -1,87 +0,0 @@
|
|||||||
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;
|
|
||||||
@ -1,367 +0,0 @@
|
|||||||
package Qpsmtpd::PollServer;
|
|
||||||
|
|
||||||
use base ('Danga::Client', 'Qpsmtpd::SMTP');
|
|
||||||
|
|
||||||
# use fields required to be a subclass of Danga::Client. Have to include
|
|
||||||
# all fields used by Qpsmtpd.pm here too.
|
|
||||||
use fields qw(
|
|
||||||
input_sock
|
|
||||||
mode
|
|
||||||
header_lines
|
|
||||||
in_header
|
|
||||||
data_size
|
|
||||||
max_size
|
|
||||||
hooks
|
|
||||||
start_time
|
|
||||||
cmd_timeout
|
|
||||||
conn
|
|
||||||
_auth
|
|
||||||
_auth_mechanism
|
|
||||||
_auth_state
|
|
||||||
_auth_ticket
|
|
||||||
_auth_user
|
|
||||||
_commands
|
|
||||||
_config_cache
|
|
||||||
_connection
|
|
||||||
_continuation
|
|
||||||
_extras
|
|
||||||
_test_mode
|
|
||||||
_transaction
|
|
||||||
);
|
|
||||||
use Qpsmtpd::Constants;
|
|
||||||
use Qpsmtpd::Address;
|
|
||||||
use ParaDNS;
|
|
||||||
use Mail::Header;
|
|
||||||
use POSIX qw(strftime);
|
|
||||||
use Socket qw(inet_aton AF_INET CRLF);
|
|
||||||
use Time::HiRes qw(time);
|
|
||||||
use strict;
|
|
||||||
|
|
||||||
sub max_idle_time { 60 }
|
|
||||||
sub max_connect_time { 1200 }
|
|
||||||
|
|
||||||
sub input_sock {
|
|
||||||
my $self = shift;
|
|
||||||
@_ and $self->{input_sock} = shift;
|
|
||||||
$self->{input_sock} || $self;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub new {
|
|
||||||
my Qpsmtpd::PollServer $self = shift;
|
|
||||||
|
|
||||||
$self = fields::new($self) unless ref $self;
|
|
||||||
$self->SUPER::new(@_);
|
|
||||||
$self->{cmd_timeout} = 5;
|
|
||||||
$self->{start_time} = time;
|
|
||||||
$self->{mode} = 'connect';
|
|
||||||
$self->load_plugins;
|
|
||||||
$self->load_logging;
|
|
||||||
|
|
||||||
my ($rc, @msg) = $self->run_hooks_no_respond("pre-connection");
|
|
||||||
if ($rc == DENYSOFT || $rc == DENYSOFT_DISCONNECT) {
|
|
||||||
@msg = ("Sorry, try again later")
|
|
||||||
unless @msg;
|
|
||||||
$self->respond(451, @msg);
|
|
||||||
$self->disconnect;
|
|
||||||
}
|
|
||||||
elsif ($rc == DENY || $rc == DENY_DISCONNECT) {
|
|
||||||
@msg = ("Sorry, service not available for you")
|
|
||||||
unless @msg;
|
|
||||||
$self->respond(550, @msg);
|
|
||||||
$self->disconnect;
|
|
||||||
}
|
|
||||||
|
|
||||||
return $self;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub uptime {
|
|
||||||
my Qpsmtpd::PollServer $self = shift;
|
|
||||||
|
|
||||||
return (time() - $self->{start_time});
|
|
||||||
}
|
|
||||||
|
|
||||||
sub reset_for_next_message {
|
|
||||||
my Qpsmtpd::PollServer $self = shift;
|
|
||||||
$self->SUPER::reset_for_next_message(@_);
|
|
||||||
|
|
||||||
$self->{_commands} = {
|
|
||||||
ehlo => 1,
|
|
||||||
helo => 1,
|
|
||||||
rset => 1,
|
|
||||||
mail => 1,
|
|
||||||
rcpt => 1,
|
|
||||||
data => 1,
|
|
||||||
help => 1,
|
|
||||||
vrfy => 1,
|
|
||||||
noop => 1,
|
|
||||||
quit => 1,
|
|
||||||
auth => 0, # disabled by default
|
|
||||||
};
|
|
||||||
$self->{mode} = 'cmd';
|
|
||||||
$self->{_extras} = {};
|
|
||||||
}
|
|
||||||
|
|
||||||
sub respond {
|
|
||||||
my Qpsmtpd::PollServer $self = shift;
|
|
||||||
my ($code, @messages) = @_;
|
|
||||||
while (my $msg = shift @messages) {
|
|
||||||
my $line = $code . (@messages ? "-" : " ") . $msg;
|
|
||||||
$self->write("$line\r\n");
|
|
||||||
}
|
|
||||||
return 1;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub fault {
|
|
||||||
my Qpsmtpd::PollServer $self = shift;
|
|
||||||
$self->SUPER::fault(@_);
|
|
||||||
return;
|
|
||||||
}
|
|
||||||
|
|
||||||
my %cmd_cache;
|
|
||||||
|
|
||||||
sub process_line {
|
|
||||||
my Qpsmtpd::PollServer $self = shift;
|
|
||||||
my $line = shift || return;
|
|
||||||
if ($::DEBUG > 1) { print "$$:" . ($self + 0) . "C($self->{mode}): $line"; }
|
|
||||||
if ($self->{mode} eq 'cmd') {
|
|
||||||
$line =~ s/\r?\n$//s;
|
|
||||||
$self->connection->notes('original_string', $line);
|
|
||||||
my ($cmd, @params) = split(/ +/, $line, 2);
|
|
||||||
my $meth = lc($cmd);
|
|
||||||
if (my $lookup =
|
|
||||||
$cmd_cache{$meth}
|
|
||||||
|| $self->{_commands}->{$meth} && $self->can($meth))
|
|
||||||
{
|
|
||||||
$cmd_cache{$meth} = $lookup;
|
|
||||||
eval { $lookup->($self, @params); };
|
|
||||||
if ($@) {
|
|
||||||
my $error = $@;
|
|
||||||
chomp($error);
|
|
||||||
$self->log(LOGERROR, "Command Error: $error");
|
|
||||||
$self->fault("command '$cmd' failed unexpectedly");
|
|
||||||
}
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
# No such method - i.e. unrecognized command
|
|
||||||
my ($rc, $msg) =
|
|
||||||
$self->run_hooks("unrecognized_command", $meth, @params);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
elsif ($self->{mode} eq 'connect') {
|
|
||||||
$self->{mode} = 'cmd';
|
|
||||||
|
|
||||||
# I've removed an eval{} from around this. It shouldn't ever die()
|
|
||||||
# but if it does we're a bit screwed... Ah well :-)
|
|
||||||
$self->start_conversation;
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
die "Unknown mode";
|
|
||||||
}
|
|
||||||
return;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub disconnect {
|
|
||||||
my Qpsmtpd::PollServer $self = shift;
|
|
||||||
$self->SUPER::disconnect(@_);
|
|
||||||
$self->close;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub close {
|
|
||||||
my Qpsmtpd::PollServer $self = shift;
|
|
||||||
$self->run_hooks_no_respond("post-connection");
|
|
||||||
$self->connection->reset;
|
|
||||||
$self->SUPER::close;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub start_conversation {
|
|
||||||
my Qpsmtpd::PollServer $self = shift;
|
|
||||||
|
|
||||||
my $conn = $self->connection;
|
|
||||||
|
|
||||||
# set remote_host, remote_ip and remote_port
|
|
||||||
my ($ip, $port) = split(/:/, $self->peer_addr_string);
|
|
||||||
return $self->close() unless $ip;
|
|
||||||
$conn->remote_ip($ip);
|
|
||||||
$conn->remote_port($port);
|
|
||||||
$conn->remote_info("[$ip]");
|
|
||||||
my ($lip, $lport) = split(/:/, $self->local_addr_string);
|
|
||||||
$conn->local_ip($lip);
|
|
||||||
$conn->local_port($lport);
|
|
||||||
|
|
||||||
ParaDNS->new(
|
|
||||||
finished => sub { $self->continue_read(); $self->run_hooks("connect") },
|
|
||||||
|
|
||||||
# NB: Setting remote_info to the same as remote_host
|
|
||||||
callback => sub { $conn->remote_info($conn->remote_host($_[0])) },
|
|
||||||
host => $ip,
|
|
||||||
);
|
|
||||||
|
|
||||||
return;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub data {
|
|
||||||
my Qpsmtpd::PollServer $self = shift;
|
|
||||||
|
|
||||||
my ($rc, $msg) = $self->run_hooks("data");
|
|
||||||
return 1;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub data_respond {
|
|
||||||
my Qpsmtpd::PollServer $self = shift;
|
|
||||||
my ($rc, $msg) = @_;
|
|
||||||
if ($rc == DONE) {
|
|
||||||
return;
|
|
||||||
}
|
|
||||||
elsif ($rc == DENY) {
|
|
||||||
$msg->[0] ||= "Message denied";
|
|
||||||
$self->respond(554, @$msg);
|
|
||||||
$self->reset_transaction();
|
|
||||||
return;
|
|
||||||
}
|
|
||||||
elsif ($rc == DENYSOFT) {
|
|
||||||
$msg->[0] ||= "Message denied temporarily";
|
|
||||||
$self->respond(451, @$msg);
|
|
||||||
$self->reset_transaction();
|
|
||||||
return;
|
|
||||||
}
|
|
||||||
elsif ($rc == DENY_DISCONNECT) {
|
|
||||||
$msg->[0] ||= "Message denied";
|
|
||||||
$self->respond(554, @$msg);
|
|
||||||
$self->disconnect;
|
|
||||||
return;
|
|
||||||
}
|
|
||||||
elsif ($rc == DENYSOFT_DISCONNECT) {
|
|
||||||
$msg->[0] ||= "Message denied temporarily";
|
|
||||||
$self->respond(451, @$msg);
|
|
||||||
$self->disconnect;
|
|
||||||
return;
|
|
||||||
}
|
|
||||||
return $self->respond(503, "MAIL first") unless $self->transaction->sender;
|
|
||||||
return $self->respond(503, "RCPT first")
|
|
||||||
unless $self->transaction->recipients;
|
|
||||||
|
|
||||||
$self->{header_lines} = '';
|
|
||||||
$self->{data_size} = 0;
|
|
||||||
$self->{in_header} = 1;
|
|
||||||
$self->{max_size} = ($self->config('databytes'))[0] || 0;
|
|
||||||
|
|
||||||
$self->log(LOGDEBUG,
|
|
||||||
"max_size: $self->{max_size} / size: $self->{data_size}");
|
|
||||||
|
|
||||||
$self->respond(354, "go ahead");
|
|
||||||
|
|
||||||
my $max_get = $self->{max_size} || 1048576;
|
|
||||||
$self->get_chunks($max_get, sub { $self->got_data($_[0]) });
|
|
||||||
return 1;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub got_data {
|
|
||||||
my Qpsmtpd::PollServer $self = shift;
|
|
||||||
my $data = shift;
|
|
||||||
|
|
||||||
my $done = 0;
|
|
||||||
my $remainder;
|
|
||||||
if ($data =~ s/^\.\r\n(.*)\z//ms) {
|
|
||||||
$remainder = $1;
|
|
||||||
$done = 1;
|
|
||||||
}
|
|
||||||
|
|
||||||
# add a transaction->blocked check back here when we have line by line plugin access...
|
|
||||||
unless (($self->{max_size} and $self->{data_size} > $self->{max_size})) {
|
|
||||||
$data =~ s/\r\n/\n/mg;
|
|
||||||
$data =~ s/^\.\./\./mg;
|
|
||||||
|
|
||||||
if ($self->{in_header}) {
|
|
||||||
$self->{header_lines} .= $data;
|
|
||||||
|
|
||||||
if ($self->{header_lines} =~ s/\n(\n.*)\z/\n/ms) {
|
|
||||||
$data = $1;
|
|
||||||
|
|
||||||
# end of headers
|
|
||||||
$self->{in_header} = 0;
|
|
||||||
|
|
||||||
# ... need to check that we don't reformat any of the received lines.
|
|
||||||
#
|
|
||||||
# 3.8.2 Received Lines in Gatewaying
|
|
||||||
# When forwarding a message into or out of the Internet environment, a
|
|
||||||
# gateway MUST prepend a Received: line, but it MUST NOT alter in any
|
|
||||||
# way a Received: line that is already in the header.
|
|
||||||
my @header_lines = split(/^/m, $self->{header_lines});
|
|
||||||
|
|
||||||
my $header =
|
|
||||||
Mail::Header->new(
|
|
||||||
\@header_lines,
|
|
||||||
Modify => 0,
|
|
||||||
MailFrom => "COERCE"
|
|
||||||
);
|
|
||||||
$self->transaction->header($header);
|
|
||||||
$self->transaction->body_write($self->{header_lines});
|
|
||||||
$self->{header_lines} = '';
|
|
||||||
|
|
||||||
#$header->add("X-SMTPD", "qpsmtpd/".$self->version.", http://smtpd.develooper.com/");
|
|
||||||
|
|
||||||
# FIXME - call plugins to work on just the header here; can
|
|
||||||
# save us buffering the mail content.
|
|
||||||
|
|
||||||
# Save the start of just the body itself
|
|
||||||
$self->transaction->set_body_start();
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
$self->transaction->body_write(\$data);
|
|
||||||
$self->{data_size} += length $data;
|
|
||||||
}
|
|
||||||
|
|
||||||
if ($done) {
|
|
||||||
$self->end_of_data;
|
|
||||||
$self->end_get_chunks($remainder);
|
|
||||||
}
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
sub end_of_data {
|
|
||||||
my Qpsmtpd::PollServer $self = shift;
|
|
||||||
|
|
||||||
#$self->log(LOGDEBUG, "size is at $size\n") unless ($i % 300);
|
|
||||||
|
|
||||||
$self->log(LOGDEBUG,
|
|
||||||
"max_size: $self->{max_size} / size: $self->{data_size}");
|
|
||||||
|
|
||||||
my $header = $self->transaction->header;
|
|
||||||
if (!$header) {
|
|
||||||
$header = Mail::Header->new(Modify => 0, MailFrom => "COERCE");
|
|
||||||
$self->transaction->header($header);
|
|
||||||
}
|
|
||||||
|
|
||||||
my $smtp = $self->connection->hello eq "ehlo" ? "ESMTP" : "SMTP";
|
|
||||||
my $esmtp = substr($smtp, 0, 1) eq "E";
|
|
||||||
my $authheader;
|
|
||||||
my $sslheader;
|
|
||||||
|
|
||||||
if (defined $self->connection->notes('tls_enabled')
|
|
||||||
and $self->connection->notes('tls_enabled'))
|
|
||||||
{
|
|
||||||
$smtp .= "S" if $esmtp; # RFC3848
|
|
||||||
$sslheader = "("
|
|
||||||
. $self->connection->notes('tls_socket')->get_cipher()
|
|
||||||
. " encrypted) ";
|
|
||||||
}
|
|
||||||
|
|
||||||
if (defined $self->{_auth} and $self->{_auth} == OK) {
|
|
||||||
$smtp .= "A" if $esmtp; # RFC3848
|
|
||||||
$authheader =
|
|
||||||
"(smtp-auth username $self->{_auth_user}, mechanism $self->{_auth_mechanism})\n";
|
|
||||||
}
|
|
||||||
|
|
||||||
$header->add("Received",
|
|
||||||
$self->received_line($smtp, $authheader, $sslheader), 0);
|
|
||||||
|
|
||||||
return $self->respond(552, "Message too big!")
|
|
||||||
if $self->{max_size} and $self->{data_size} > $self->{max_size};
|
|
||||||
|
|
||||||
my ($rc, $msg) = $self->run_hooks("data_post");
|
|
||||||
return 1;
|
|
||||||
}
|
|
||||||
|
|
||||||
1;
|
|
||||||
|
|
||||||
@ -731,8 +731,6 @@ sub data_respond {
|
|||||||
|
|
||||||
$self->transaction->header($header);
|
$self->transaction->header($header);
|
||||||
|
|
||||||
# NOTE: This will not work properly under async. A
|
|
||||||
# data_headers_end_respond needs to be created.
|
|
||||||
my ($rc, $msg) = $self->run_hooks('data_headers_end');
|
my ($rc, $msg) = $self->run_hooks('data_headers_end');
|
||||||
if ($rc == DENY_DISCONNECT) {
|
if ($rc == DENY_DISCONNECT) {
|
||||||
$self->respond(554, $msg || "Message denied");
|
$self->respond(554, $msg || "Message denied");
|
||||||
@ -871,10 +869,7 @@ sub received_line {
|
|||||||
my $header_str;
|
my $header_str;
|
||||||
my ($rc, @received) =
|
my ($rc, @received) =
|
||||||
$self->run_hooks("received_line", $smtp, $authheader, $sslheader);
|
$self->run_hooks("received_line", $smtp, $authheader, $sslheader);
|
||||||
if ($rc == YIELD) {
|
if ($rc == OK) {
|
||||||
die "YIELD not supported for received_line hook";
|
|
||||||
}
|
|
||||||
elsif ($rc == OK) {
|
|
||||||
return join("\n", @received);
|
return join("\n", @received);
|
||||||
}
|
}
|
||||||
else { # assume $rc == DECLINED
|
else { # assume $rc == DECLINED
|
||||||
|
|||||||
@ -6,7 +6,7 @@ Name: %{_package}
|
|||||||
Version: %{_version}
|
Version: %{_version}
|
||||||
Release: %{_release}
|
Release: %{_release}
|
||||||
|
|
||||||
Summary: qpsmtpd + qpsmtpd-apache + qpsmtpd-async
|
Summary: qpsmtpd + qpsmtpd-apache
|
||||||
License: MIT
|
License: MIT
|
||||||
Group: System Environment/Daemons
|
Group: System Environment/Daemons
|
||||||
URL: http://smtpd.develooper.com/
|
URL: http://smtpd.develooper.com/
|
||||||
@ -38,10 +38,6 @@ Requires: perl(mod_perl2)
|
|||||||
Summary: mod_perl-2 connection handler for qpsmtpd
|
Summary: mod_perl-2 connection handler for qpsmtpd
|
||||||
Group: System Environment/Daemons
|
Group: System Environment/Daemons
|
||||||
|
|
||||||
%package async
|
|
||||||
Summary: qpsmtpd using async I/O in a single process
|
|
||||||
Group: System Environment/Daemons
|
|
||||||
|
|
||||||
%package xinetd
|
%package xinetd
|
||||||
Summary: xinetd support for qpsmtpd
|
Summary: xinetd support for qpsmtpd
|
||||||
Group: System Environment/Daemons
|
Group: System Environment/Daemons
|
||||||
@ -52,11 +48,6 @@ Requires: xinetd
|
|||||||
This module implements a mod_perl/apache 2.0 connection handler
|
This module implements a mod_perl/apache 2.0 connection handler
|
||||||
that turns Apache into an SMTP server using Qpsmtpd.
|
that turns Apache into an SMTP server using Qpsmtpd.
|
||||||
|
|
||||||
%description async
|
|
||||||
This package contains the Qpsmtpd::PollServer module, which allows
|
|
||||||
qpsmtd to handle many connections in a single process and the
|
|
||||||
qpsmpd-async which uses it.
|
|
||||||
|
|
||||||
%description xinetd
|
%description xinetd
|
||||||
This package contains the xinetd startup files for qpsmptd.
|
This package contains the xinetd startup files for qpsmptd.
|
||||||
|
|
||||||
@ -126,16 +117,6 @@ if [ "$(cat %{name}-%{version}-%{release}-filelist)X" = "X" ] ; then
|
|||||||
exit -1
|
exit -1
|
||||||
fi
|
fi
|
||||||
|
|
||||||
find ${RPM_BUILD_ROOT}%{_prefix} -type f -print | \
|
|
||||||
sed "s@^$RPM_BUILD_ROOT@@g" | \
|
|
||||||
grep -v packaging | \
|
|
||||||
grep -v README.selinux | \
|
|
||||||
grep -v /Apache | cat - %{name}-%{version}-%{release}-filelist | sort | uniq -u > %{name}-%{version}-%{release}-async-filelist
|
|
||||||
if [ "$(cat %{name}-%{version}-%{release}-async-filelist)X" = "X" ] ; then
|
|
||||||
echo "ERROR: EMPTY FILE LIST"
|
|
||||||
exit -1
|
|
||||||
fi
|
|
||||||
|
|
||||||
find ${RPM_BUILD_ROOT}%{_prefix} -type f -print | \
|
find ${RPM_BUILD_ROOT}%{_prefix} -type f -print | \
|
||||||
sed "s@^$RPM_BUILD_ROOT@@g" | \
|
sed "s@^$RPM_BUILD_ROOT@@g" | \
|
||||||
grep -v [Aa]sync | \
|
grep -v [Aa]sync | \
|
||||||
@ -162,10 +143,6 @@ fi
|
|||||||
%config(noreplace) %{_sysconfdir}/httpd/conf.d/*
|
%config(noreplace) %{_sysconfdir}/httpd/conf.d/*
|
||||||
%doc %{_docdir}/%{name}-apache-%{version}/README.selinux
|
%doc %{_docdir}/%{name}-apache-%{version}/README.selinux
|
||||||
|
|
||||||
%files async -f %{name}-%{version}-%{release}-async-filelist
|
|
||||||
%defattr(-,root,root)
|
|
||||||
%{_datadir}/%{name}/plugins/async/*
|
|
||||||
|
|
||||||
%files xinetd
|
%files xinetd
|
||||||
%defattr(-,root,root)
|
%defattr(-,root,root)
|
||||||
%config(noreplace) %{_sysconfdir}/xinetd.d/smtp
|
%config(noreplace) %{_sysconfdir}/xinetd.d/smtp
|
||||||
|
|||||||
@ -1,88 +0,0 @@
|
|||||||
#!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;
|
|
||||||
}
|
|
||||||
|
|
||||||
=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
|
|
||||||
@ -1,202 +0,0 @@
|
|||||||
#!perl -w
|
|
||||||
|
|
||||||
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;
|
|
||||||
|
|
||||||
my $allow =
|
|
||||||
grep { s/\.?$/./; $_ eq substr($remote_ip . '.', 0, length $_) }
|
|
||||||
$self->qp->config('dnsbl_allow');
|
|
||||||
return DECLINED if $allow;
|
|
||||||
|
|
||||||
my %dnsbl_zones =
|
|
||||||
map { (split /:/, $_, 2)[0, 1] } $self->qp->config('dnsbl_zones');
|
|
||||||
return DECLINED unless %dnsbl_zones;
|
|
||||||
|
|
||||||
my $reversed_ip = join(".", reverse(split(/\./, $remote_ip)));
|
|
||||||
|
|
||||||
my @A_zones = grep { defined($dnsbl_zones{$_}) } keys %dnsbl_zones;
|
|
||||||
my @TXT_zones = grep { !defined($dnsbl_zones{$_}) } keys %dnsbl_zones;
|
|
||||||
|
|
||||||
if (@A_zones) {
|
|
||||||
|
|
||||||
# message templates for responding to the client
|
|
||||||
$self->connection->notes(
|
|
||||||
dnsbl_templates => {
|
|
||||||
map {
|
|
||||||
+"$reversed_ip.$_" => $dnsbl_zones{$_}
|
|
||||||
} @A_zones
|
|
||||||
}
|
|
||||||
);
|
|
||||||
}
|
|
||||||
|
|
||||||
return DECLINED
|
|
||||||
unless $class->lookup($self->qp,
|
|
||||||
[map { "$reversed_ip.$_" } @A_zones],
|
|
||||||
[map { "$reversed_ip.$_" } @TXT_zones],
|
|
||||||
);
|
|
||||||
|
|
||||||
return YIELD;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub process_a_result {
|
|
||||||
my ($class, $qp, $result, $query) = @_;
|
|
||||||
|
|
||||||
my $conn = $qp->connection;
|
|
||||||
return if $class->connection->notes('dnsbl');
|
|
||||||
|
|
||||||
my $templates = $class->connection->notes('dnsbl_templates');
|
|
||||||
my $ip = $conn->remote_ip;
|
|
||||||
|
|
||||||
my $template = $templates->{$query};
|
|
||||||
$template =~ s/%IP%/$ip/g;
|
|
||||||
|
|
||||||
$class->connection->notes('dnsbl', $template);
|
|
||||||
}
|
|
||||||
|
|
||||||
sub process_txt_result {
|
|
||||||
my ($class, $qp, $result, $query) = @_;
|
|
||||||
|
|
||||||
my $conn = $class->connection;
|
|
||||||
$conn->notes('dnsbl', $result) unless $conn->notes('dnsbl');
|
|
||||||
}
|
|
||||||
|
|
||||||
sub hook_rcpt {
|
|
||||||
my ($self, $transaction, $rcpt) = @_;
|
|
||||||
my $connection = $self->qp->connection;
|
|
||||||
|
|
||||||
# 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->connection->remote_ip;
|
|
||||||
$result =~ s/%IP%/$remote_ip/g;
|
|
||||||
return (DENY, join(" ", $self->qp->config('dnsbl_rejectmsg'), $result));
|
|
||||||
}
|
|
||||||
|
|
||||||
my $note = $self->connection->notes('dnsbl');
|
|
||||||
return (DENY, $note) if $note;
|
|
||||||
return DECLINED;
|
|
||||||
}
|
|
||||||
|
|
||||||
=head1 NAME
|
|
||||||
|
|
||||||
dnsbl - handle DNS BlackList lookups
|
|
||||||
|
|
||||||
=head1 DESCRIPTION
|
|
||||||
|
|
||||||
Plugin that checks the IP address of the incoming connection against
|
|
||||||
a configurable set of RBL services.
|
|
||||||
|
|
||||||
=head1 Configuration files
|
|
||||||
|
|
||||||
This plugin uses the following configuration files. All of these are optional.
|
|
||||||
However, not specifying dnsbl_zones is like not using the plugin at all.
|
|
||||||
|
|
||||||
=over 4
|
|
||||||
|
|
||||||
=item dnsbl_zones
|
|
||||||
|
|
||||||
Normal ip based dns blocking lists ("RBLs") which contain TXT records are
|
|
||||||
specified simply as:
|
|
||||||
|
|
||||||
relays.ordb.org
|
|
||||||
spamsources.fabel.dk
|
|
||||||
|
|
||||||
To configure RBL services which do not contain TXT records in the DNS,
|
|
||||||
but only A records (e.g. the RBL+ at http://www.mail-abuse.org), specify your
|
|
||||||
own error message to return in the SMTP conversation after a colon e.g.
|
|
||||||
|
|
||||||
rbl-plus.mail-abuse.org:You are listed at - http://http://www.mail-abuse.org/cgi-bin/lookup?%IP%
|
|
||||||
|
|
||||||
The string %IP% will be replaced with the IP address of incoming connection.
|
|
||||||
Thus a fully specified file could be:
|
|
||||||
|
|
||||||
sbl-xbl.spamhaus.org
|
|
||||||
list.dsbl.org
|
|
||||||
rbl-plus.mail-abuse.ja.net:Listed by rbl-plus.mail-abuse.ja.net - see <URL:http://www.mail-abuse.org/cgi-bin/lookup?%IP%>
|
|
||||||
relays.ordb.org
|
|
||||||
|
|
||||||
=item dnsbl_allow
|
|
||||||
|
|
||||||
List of allowed ip addresses that bypass RBL checking. Format is one entry per line,
|
|
||||||
with either a full IP address or a truncated IP address with a period at the end.
|
|
||||||
For example:
|
|
||||||
|
|
||||||
192.168.1.1
|
|
||||||
172.16.33.
|
|
||||||
|
|
||||||
NB the environment variable RBLSMTPD is considered before this file is
|
|
||||||
referenced. See below.
|
|
||||||
|
|
||||||
=item dnsbl_rejectmsg
|
|
||||||
|
|
||||||
A textual message that is sent to the sender on an RBL failure. The TXT record
|
|
||||||
from the RBL list is also sent, but this file can be used to indicate what
|
|
||||||
action the sender should take.
|
|
||||||
|
|
||||||
For example:
|
|
||||||
|
|
||||||
If you think you have been blocked in error, then please forward
|
|
||||||
this entire error message to your ISP so that they can fix their problems.
|
|
||||||
The next line often contains a URL that can be visited for more information.
|
|
||||||
|
|
||||||
=back
|
|
||||||
|
|
||||||
=head1 Environment Variables
|
|
||||||
|
|
||||||
=head2 RBLSMTPD
|
|
||||||
|
|
||||||
The environment variable RBLSMTPD is supported and mimics the behaviour of
|
|
||||||
Dan Bernstein's rblsmtpd. The exception to this is the '-' char at the
|
|
||||||
start of RBLSMTPD which is used to force a hard error in Dan's rblsmtpd.
|
|
||||||
NB I don't really see the benefit
|
|
||||||
of using a soft error for a site in an RBL list. This just complicates
|
|
||||||
things as it takes 7 days (or whatever default period) before a user
|
|
||||||
gets an error email back. In the meantime they are complaining that their
|
|
||||||
emails are being "lost" :(
|
|
||||||
|
|
||||||
=over 4
|
|
||||||
|
|
||||||
=item RBLSMTPD is set and non-empty
|
|
||||||
|
|
||||||
The contents are used as the SMTP conversation error.
|
|
||||||
Use this for forcibly blocking sites you don't like
|
|
||||||
|
|
||||||
=item RBLSMTPD is set, but empty
|
|
||||||
|
|
||||||
In this case no RBL checks are made.
|
|
||||||
This can be used for local addresses.
|
|
||||||
|
|
||||||
=item RBLSMTPD is not set
|
|
||||||
|
|
||||||
All RBL checks will be made.
|
|
||||||
This is the setting for remote sites that you want to check against RBL.
|
|
||||||
|
|
||||||
=back
|
|
||||||
|
|
||||||
=head1 Revisions
|
|
||||||
|
|
||||||
See: http://cvs.perl.org/viewcvs/qpsmtpd/plugins/dnsbl
|
|
||||||
|
|
||||||
=cut
|
|
||||||
@ -1,141 +0,0 @@
|
|||||||
#!perl -w
|
|
||||||
|
|
||||||
=head1 NAME
|
|
||||||
|
|
||||||
earlytalker - Check that the client doesn't talk before we send the SMTP banner
|
|
||||||
|
|
||||||
=head1 DESCRIPTION
|
|
||||||
|
|
||||||
Checks to see if the remote host starts talking before we've issued a 2xx
|
|
||||||
greeting. If so, we're likely looking at a direct-to-MX spam agent which
|
|
||||||
pipelines its entire SMTP conversation, and will happily dump an entire spam
|
|
||||||
into our mail log even if later tests deny acceptance.
|
|
||||||
|
|
||||||
Depending on configuration, clients which behave in this way are either
|
|
||||||
immediately disconnected with a deny or denysoft code, or else are issued this
|
|
||||||
on all mail/rcpt commands in the transaction.
|
|
||||||
|
|
||||||
=head1 CONFIGURATION
|
|
||||||
|
|
||||||
=over 4
|
|
||||||
|
|
||||||
=item wait [integer]
|
|
||||||
|
|
||||||
The number of seconds to delay the initial greeting to see if the connecting
|
|
||||||
host speaks first. The default is 1. Do not select a value that is too high,
|
|
||||||
or you may be unable to receive mail from MTAs with short SMTP connect or
|
|
||||||
greeting timeouts -- these are known to range as low as 30 seconds, and may
|
|
||||||
in some cases be configured lower by mailserver admins. Network transit time
|
|
||||||
must also be allowed for.
|
|
||||||
|
|
||||||
=item action [string: deny, denysoft, log]
|
|
||||||
|
|
||||||
What to do when matching an early-talker -- the options are I<deny>,
|
|
||||||
I<denysoft> or I<log>.
|
|
||||||
|
|
||||||
If I<log> is specified, the connection will be allowed to proceed as normal,
|
|
||||||
and only a warning will be logged.
|
|
||||||
|
|
||||||
The default is I<denysoft>.
|
|
||||||
|
|
||||||
=item defer-reject [boolean]
|
|
||||||
|
|
||||||
When an early-talker is detected, if this option is set to a true value, the
|
|
||||||
SMTP greeting will be issued as usual, but all RCPT/MAIL commands will be
|
|
||||||
issued a deny or denysoft (depending on the value of I<action>). The default
|
|
||||||
is to react at the SMTP greeting stage by issuing the apropriate response code
|
|
||||||
and terminating the SMTP connection.
|
|
||||||
|
|
||||||
=item check-at [string: connect, data]
|
|
||||||
|
|
||||||
Defines when to check for early talkers, either at connect time (pre-greet pause)
|
|
||||||
or at DATA time (pause before sending "354 go ahead").
|
|
||||||
|
|
||||||
The default is I<connect>.
|
|
||||||
|
|
||||||
Note that defer-reject has no meaning if check-at is I<data>.
|
|
||||||
|
|
||||||
=back
|
|
||||||
|
|
||||||
=cut
|
|
||||||
|
|
||||||
my $MSG = 'Connecting host started transmitting before SMTP greeting';
|
|
||||||
|
|
||||||
sub register {
|
|
||||||
my ($self, $qp, @args) = @_;
|
|
||||||
|
|
||||||
if (@args % 2) {
|
|
||||||
$self->log(LOGERROR, "Unrecognized/mismatched arguments");
|
|
||||||
return undef;
|
|
||||||
}
|
|
||||||
$self->{_args} = {
|
|
||||||
'wait' => 1,
|
|
||||||
'action' => 'denysoft',
|
|
||||||
'defer-reject' => 0,
|
|
||||||
'check-at' => 'connect',
|
|
||||||
@args,
|
|
||||||
};
|
|
||||||
print STDERR "Check at: ", $self->{_args}{'check-at'}, "\n";
|
|
||||||
$self->register_hook($self->{_args}->{'check-at'}, 'check_talker_poll');
|
|
||||||
$self->register_hook($self->{_args}->{'check-at'}, 'check_talker_post');
|
|
||||||
if ($self->{_args}{'check-at'} eq 'connect') {
|
|
||||||
$self->register_hook('mail', 'hook_mail')
|
|
||||||
if $self->{_args}->{'defer-reject'};
|
|
||||||
}
|
|
||||||
1;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub check_talker_poll {
|
|
||||||
my ($self, $transaction) = @_;
|
|
||||||
|
|
||||||
my $qp = $self->qp;
|
|
||||||
my $conn = $qp->connection;
|
|
||||||
my $check_until = time + $self->{_args}{'wait'};
|
|
||||||
$qp->AddTimer(
|
|
||||||
1,
|
|
||||||
sub {
|
|
||||||
read_now($qp, $conn, $check_until, $self->{_args}{'check-at'});
|
|
||||||
}
|
|
||||||
);
|
|
||||||
return YIELD;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub read_now {
|
|
||||||
my ($qp, $conn, $until, $phase) = @_;
|
|
||||||
|
|
||||||
if ($qp->has_data) {
|
|
||||||
$qp->log(LOGNOTICE,
|
|
||||||
'remote host started talking after $phase before we responded');
|
|
||||||
$qp->clear_data if $phase eq 'data';
|
|
||||||
$conn->notes('earlytalker', 1);
|
|
||||||
$qp->run_continuation;
|
|
||||||
}
|
|
||||||
elsif (time >= $until) {
|
|
||||||
|
|
||||||
# no early talking
|
|
||||||
$qp->run_continuation;
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
$qp->AddTimer(1, sub { read_now($qp, $conn, $until, $phase) });
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub check_talker_post {
|
|
||||||
my ($self, $transaction) = @_;
|
|
||||||
|
|
||||||
return DECLINED unless $self->connection->notes('earlytalker');
|
|
||||||
return DECLINED if $self->{'defer-reject'};
|
|
||||||
return (DENY, $MSG) if $self->{_args}->{'action'} eq 'deny';
|
|
||||||
return (DENYSOFT, $MSG) if $self->{_args}->{'action'} eq 'denysoft';
|
|
||||||
return DECLINED; # assume action eq 'log'
|
|
||||||
}
|
|
||||||
|
|
||||||
sub hook_mail {
|
|
||||||
my ($self, $transaction) = @_;
|
|
||||||
|
|
||||||
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;
|
|
||||||
}
|
|
||||||
|
|
||||||
@ -1,413 +0,0 @@
|
|||||||
#!perl -w
|
|
||||||
|
|
||||||
=head1 NAME
|
|
||||||
|
|
||||||
smtp-forward
|
|
||||||
|
|
||||||
=head1 DESCRIPTION
|
|
||||||
|
|
||||||
This plugin forwards the mail via SMTP to a specified server, rather than
|
|
||||||
delivering the email locally.
|
|
||||||
|
|
||||||
=head1 CONFIG
|
|
||||||
|
|
||||||
It takes one required parameter, the IP address or hostname to forward to.
|
|
||||||
|
|
||||||
async/queue/smtp-forward 10.2.2.2
|
|
||||||
|
|
||||||
Optionally you can also add a port:
|
|
||||||
|
|
||||||
async/queue/smtp-forward 10.2.2.2 9025
|
|
||||||
|
|
||||||
=cut
|
|
||||||
|
|
||||||
use Qpsmtpd::Constants;
|
|
||||||
|
|
||||||
sub register {
|
|
||||||
my ($self, $qp) = @_;
|
|
||||||
|
|
||||||
$self->register_hook(queue => "start_queue");
|
|
||||||
$self->register_hook(queue => "finish_queue");
|
|
||||||
}
|
|
||||||
|
|
||||||
sub init {
|
|
||||||
my ($self, $qp, @args) = @_;
|
|
||||||
|
|
||||||
if (@args > 0) {
|
|
||||||
if ($args[0] =~ /^([\.\w_-]+)$/) {
|
|
||||||
$self->{_smtp_server} = $1;
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
die "Bad data in smtp server: $args[0]";
|
|
||||||
}
|
|
||||||
$self->{_smtp_port} = 25;
|
|
||||||
if (@args > 1 and $args[1] =~ /^(\d+)$/) {
|
|
||||||
$self->{_smtp_port} = $1;
|
|
||||||
}
|
|
||||||
|
|
||||||
$self->log(LOGWARN, "WARNING: Ignoring additional arguments.")
|
|
||||||
if (@args > 2);
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
die("No SMTP server specified in smtp-forward config");
|
|
||||||
}
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
sub start_queue {
|
|
||||||
my ($self, $transaction) = @_;
|
|
||||||
|
|
||||||
my $qp = $self->qp;
|
|
||||||
my $SERVER = $self->{_smtp_server};
|
|
||||||
my $PORT = $self->{_smtp_port};
|
|
||||||
$self->log(LOGINFO, "forwarding to $SERVER:$PORT");
|
|
||||||
|
|
||||||
$transaction->notes(
|
|
||||||
'async_sender',
|
|
||||||
AsyncSMTPSender->new(
|
|
||||||
$SERVER, $PORT, $qp, $self, $transaction
|
|
||||||
)
|
|
||||||
);
|
|
||||||
|
|
||||||
return YIELD;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub finish_queue {
|
|
||||||
my ($self, $transaction) = @_;
|
|
||||||
|
|
||||||
my $sender = $transaction->notes('async_sender');
|
|
||||||
$transaction->notes('async_sender', undef);
|
|
||||||
|
|
||||||
my ($rc, $msg) = $sender->results;
|
|
||||||
|
|
||||||
return $rc, $msg;
|
|
||||||
}
|
|
||||||
|
|
||||||
package AsyncSMTPSender;
|
|
||||||
|
|
||||||
use IO::Socket;
|
|
||||||
|
|
||||||
use base qw(Danga::Socket);
|
|
||||||
use fields qw(
|
|
||||||
qp
|
|
||||||
pkg
|
|
||||||
tran
|
|
||||||
state
|
|
||||||
rcode
|
|
||||||
rmsg
|
|
||||||
buf
|
|
||||||
command
|
|
||||||
resp
|
|
||||||
to
|
|
||||||
);
|
|
||||||
|
|
||||||
use constant ST_CONNECTING => 0;
|
|
||||||
use constant ST_CONNECTED => 1;
|
|
||||||
use constant ST_COMMANDS => 2;
|
|
||||||
use constant ST_DATA => 3;
|
|
||||||
|
|
||||||
use Qpsmtpd::Constants;
|
|
||||||
|
|
||||||
sub new {
|
|
||||||
my ($self, $server, $port, $qp, $pkg, $transaction) = @_;
|
|
||||||
$self = fields::new($self) unless ref $self;
|
|
||||||
|
|
||||||
my $sock = IO::Socket::INET->new(
|
|
||||||
PeerAddr => $server,
|
|
||||||
PeerPort => $port,
|
|
||||||
Blocking => 0,
|
|
||||||
)
|
|
||||||
or die "Error connecting to server $server:$port : $!\n";
|
|
||||||
|
|
||||||
IO::Handle::blocking($sock, 0);
|
|
||||||
binmode($sock, ':raw');
|
|
||||||
|
|
||||||
$self->{qp} = $qp;
|
|
||||||
$self->{pkg} = $pkg;
|
|
||||||
$self->{tran} = $transaction;
|
|
||||||
$self->{state} = ST_CONNECTING;
|
|
||||||
$self->{rcode} = DECLINED;
|
|
||||||
$self->{command} = 'connect';
|
|
||||||
$self->{buf} = '';
|
|
||||||
$self->{resp} = [];
|
|
||||||
|
|
||||||
# copy the recipients so we can pop them off one by one
|
|
||||||
$self->{to} = [$transaction->recipients];
|
|
||||||
|
|
||||||
$self->SUPER::new($sock);
|
|
||||||
|
|
||||||
# Watch for write first, this is when the TCP session is established.
|
|
||||||
$self->watch_write(1);
|
|
||||||
|
|
||||||
return $self;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub results {
|
|
||||||
my AsyncSMTPSender $self = shift;
|
|
||||||
return ($self->{rcode}, $self->{rmsg});
|
|
||||||
}
|
|
||||||
|
|
||||||
sub log {
|
|
||||||
my AsyncSMTPSender $self = shift;
|
|
||||||
$self->{qp}->log(@_);
|
|
||||||
}
|
|
||||||
|
|
||||||
sub cont {
|
|
||||||
my AsyncSMTPSender $self = shift;
|
|
||||||
$self->{qp}->run_continuation;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub command {
|
|
||||||
my AsyncSMTPSender $self = shift;
|
|
||||||
my ($command, $params) = @_;
|
|
||||||
$params ||= '';
|
|
||||||
|
|
||||||
$self->log(LOGDEBUG, ">> $command $params");
|
|
||||||
|
|
||||||
$self->write( ($command =~ m/ / ? "$command:" : $command)
|
|
||||||
. ($params ? " $params" : "")
|
|
||||||
. "\r\n");
|
|
||||||
$self->watch_read(1);
|
|
||||||
$self->{command} = ($command =~ /(\S+)/)[0];
|
|
||||||
}
|
|
||||||
|
|
||||||
sub handle_response {
|
|
||||||
my AsyncSMTPSender $self = shift;
|
|
||||||
|
|
||||||
my $method = "cmd_" . lc($self->{command});
|
|
||||||
|
|
||||||
$self->$method(@_);
|
|
||||||
}
|
|
||||||
|
|
||||||
sub cmd_connect {
|
|
||||||
my AsyncSMTPSender $self = shift;
|
|
||||||
my ($code, $response) = @_;
|
|
||||||
|
|
||||||
if ($code != 220) {
|
|
||||||
$self->{rmsg} = "Error on connect: @$response";
|
|
||||||
$self->close;
|
|
||||||
$self->cont;
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
my $host = $self->{qp}->config('me');
|
|
||||||
print "HELOing with $host\n";
|
|
||||||
$self->command((join '', @$response) =~ m/ ESMTP/ ? "EHLO" : "HELO",
|
|
||||||
$host);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub cmd_helo {
|
|
||||||
my AsyncSMTPSender $self = shift;
|
|
||||||
my ($code, $response) = @_;
|
|
||||||
|
|
||||||
if ($code != 250) {
|
|
||||||
$self->{rmsg} = "Error on HELO: @$response";
|
|
||||||
$self->close;
|
|
||||||
$self->cont;
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
$self->command("MAIL", "FROM:" . $self->{tran}->sender->format);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub cmd_ehlo {
|
|
||||||
my AsyncSMTPSender $self = shift;
|
|
||||||
my ($code, $response) = @_;
|
|
||||||
|
|
||||||
if ($code != 250) {
|
|
||||||
$self->{rmsg} = "Error on EHLO: @$response";
|
|
||||||
$self->close;
|
|
||||||
$self->cont;
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
$self->command("MAIL", "FROM:" . $self->{tran}->sender->format);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub cmd_mail {
|
|
||||||
my AsyncSMTPSender $self = shift;
|
|
||||||
my ($code, $response) = @_;
|
|
||||||
|
|
||||||
if ($code != 250) {
|
|
||||||
$self->{rmsg} = "Error on MAIL FROM: @$response";
|
|
||||||
$self->close;
|
|
||||||
$self->cont;
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
$self->command("RCPT", "TO:" . shift(@{$self->{to}})->format);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub cmd_rcpt {
|
|
||||||
my AsyncSMTPSender $self = shift;
|
|
||||||
my ($code, $response) = @_;
|
|
||||||
|
|
||||||
if ($code != 250) {
|
|
||||||
$self->{rmsg} = "Error on RCPT TO: @$response";
|
|
||||||
$self->close;
|
|
||||||
$self->cont;
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
if (@{$self->{to}}) {
|
|
||||||
$self->command("RCPT", "TO:" . shift(@{$self->{to}})->format);
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
$self->command("DATA");
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub cmd_data {
|
|
||||||
my AsyncSMTPSender $self = shift;
|
|
||||||
my ($code, $response) = @_;
|
|
||||||
|
|
||||||
if ($code != 354) {
|
|
||||||
$self->{rmsg} = "Error on DATA: @$response";
|
|
||||||
$self->close;
|
|
||||||
$self->cont;
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
# $self->{state} = ST_DATA;
|
|
||||||
$self->datasend($self->{tran}->header->as_string);
|
|
||||||
$self->{tran}->body_resetpos;
|
|
||||||
my $write_buf = '';
|
|
||||||
while (my $line = $self->{tran}->body_getline) {
|
|
||||||
$line =~ s/\r?\n/\r\n/;
|
|
||||||
$write_buf .= $line;
|
|
||||||
if (length($write_buf) >= 131072) { # 128KB, arbitrary value
|
|
||||||
$self->log(LOGDEBUG, ">> $write_buf");
|
|
||||||
$self->datasend($write_buf);
|
|
||||||
$write_buf = '';
|
|
||||||
}
|
|
||||||
}
|
|
||||||
if (length($write_buf)) {
|
|
||||||
$self->log(LOGDEBUG, ">> $write_buf");
|
|
||||||
$self->datasend($write_buf);
|
|
||||||
}
|
|
||||||
$self->write(".\r\n");
|
|
||||||
$self->{command} = "DATAEND";
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub cmd_dataend {
|
|
||||||
my AsyncSMTPSender $self = shift;
|
|
||||||
my ($code, $response) = @_;
|
|
||||||
|
|
||||||
if ($code != 250) {
|
|
||||||
$self->{rmsg} = "Error after DATA: @$response";
|
|
||||||
$self->close;
|
|
||||||
$self->cont;
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
$self->command("QUIT");
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub cmd_quit {
|
|
||||||
my AsyncSMTPSender $self = shift;
|
|
||||||
my ($code, $response) = @_;
|
|
||||||
|
|
||||||
$self->{rcode} = OK;
|
|
||||||
$self->{rmsg} = "Queued!";
|
|
||||||
$self->close;
|
|
||||||
$self->cont;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub datasend {
|
|
||||||
my AsyncSMTPSender $self = shift;
|
|
||||||
my ($data) = @_;
|
|
||||||
$data =~ s/^\./../mg;
|
|
||||||
$self->write(\$data);
|
|
||||||
}
|
|
||||||
|
|
||||||
sub event_read {
|
|
||||||
my AsyncSMTPSender $self = shift;
|
|
||||||
|
|
||||||
if ($self->{state} == ST_CONNECTED) {
|
|
||||||
$self->{state} = ST_COMMANDS;
|
|
||||||
}
|
|
||||||
|
|
||||||
if ($self->{state} == ST_COMMANDS) {
|
|
||||||
my $in = $self->read(1024);
|
|
||||||
if (!$in) {
|
|
||||||
|
|
||||||
# XXX: connection closed
|
|
||||||
$self->close("lost connection");
|
|
||||||
return;
|
|
||||||
}
|
|
||||||
|
|
||||||
my @lines = split /\r?\n/, $self->{buf} . $$in, -1;
|
|
||||||
$self->{buf} = delete $lines[-1];
|
|
||||||
|
|
||||||
for (@lines) {
|
|
||||||
if (my ($code, $cont, $rest) = /^([0-9]{3})([ -])(.*)/) {
|
|
||||||
$self->log(LOGDEBUG, "<< $code$cont$rest");
|
|
||||||
push @{$self->{resp}}, $rest;
|
|
||||||
|
|
||||||
if ($cont eq ' ') {
|
|
||||||
$self->handle_response($code, $self->{resp});
|
|
||||||
$self->{resp} = [];
|
|
||||||
}
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
$self->log(LOGERROR, "Unrecognised SMTP response line: $_");
|
|
||||||
$self->{rmsg} = "Error from upstream SMTP server";
|
|
||||||
$self->close;
|
|
||||||
$self->cont;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
$self->log(LOGERROR, "SMTP Session occurred out of order");
|
|
||||||
$self->close;
|
|
||||||
$self->cont;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub event_write {
|
|
||||||
my AsyncSMTPSender $self = shift;
|
|
||||||
|
|
||||||
if ($self->{state} == ST_CONNECTING) {
|
|
||||||
$self->watch_write(0);
|
|
||||||
$self->{state} = ST_CONNECTED;
|
|
||||||
$self->watch_read(1);
|
|
||||||
}
|
|
||||||
elsif (0 && $self->{state} == ST_DATA) {
|
|
||||||
|
|
||||||
# send more data
|
|
||||||
if (my $line = $self->{tran}->body_getline) {
|
|
||||||
$self->log(LOGDEBUG, ">> $line");
|
|
||||||
$line =~ s/\r?\n/\r\n/;
|
|
||||||
$self->datasend($line);
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
# no more data.
|
|
||||||
$self->log(LOGINFO, "No more data");
|
|
||||||
$self->watch_write(0);
|
|
||||||
$self->{state} = ST_COMMANDS;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
$self->write(undef);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub event_err {
|
|
||||||
my ($self) = @_;
|
|
||||||
eval { $self->read(1); }; # gives us the correct error in errno
|
|
||||||
$self->{rmsg} = "Read error from remote server: $!";
|
|
||||||
|
|
||||||
#print "lost connection: $!\n";
|
|
||||||
$self->close;
|
|
||||||
$self->cont;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub event_hup {
|
|
||||||
my ($self) = @_;
|
|
||||||
eval { $self->read(1); }; # gives us the correct error in errno
|
|
||||||
$self->{rmsg} = "HUP error from remote server: $!";
|
|
||||||
|
|
||||||
#print "lost connection: $!\n";
|
|
||||||
$self->close;
|
|
||||||
$self->cont;
|
|
||||||
}
|
|
||||||
@ -1,206 +0,0 @@
|
|||||||
#!perl -w
|
|
||||||
|
|
||||||
use strict;
|
|
||||||
use warnings;
|
|
||||||
|
|
||||||
use Qpsmtpd::Constants;
|
|
||||||
use Qpsmtpd::DSN;
|
|
||||||
use Qpsmtpd::TcpServer;
|
|
||||||
|
|
||||||
#use ParaDNS; # moved into register
|
|
||||||
use Socket;
|
|
||||||
|
|
||||||
my %invalid = ();
|
|
||||||
my $has_ipv6 = Qpsmtpd::TcpServer::has_ipv6();
|
|
||||||
|
|
||||||
sub register {
|
|
||||||
my ($self, $qp) = @_;
|
|
||||||
|
|
||||||
foreach my $i ($self->qp->config("invalid_resolvable_fromhost")) {
|
|
||||||
$i =~ s/^\s*//;
|
|
||||||
$i =~ s/\s*$//;
|
|
||||||
if ($i =~ m#^((\d{1,3}\.){3}\d{1,3})/(\d\d?)#) {
|
|
||||||
$invalid{$1} = $3;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
eval 'use ParaDNS';
|
|
||||||
if ($@) {
|
|
||||||
warn "could not load ParaDNS, plugin disabled";
|
|
||||||
return DECLINED;
|
|
||||||
}
|
|
||||||
$self->register_hook(mail => 'hook_mail_start');
|
|
||||||
$self->register_hook(mail => 'hook_mail_done');
|
|
||||||
}
|
|
||||||
|
|
||||||
sub hook_mail_start {
|
|
||||||
my ($self, $transaction, $sender) = @_;
|
|
||||||
|
|
||||||
return DECLINED
|
|
||||||
if ($self->connection->notes('whitelisthost'));
|
|
||||||
|
|
||||||
if ($sender ne '<>') {
|
|
||||||
|
|
||||||
unless ($sender->host) {
|
|
||||||
|
|
||||||
# default of addr_bad_from_system is DENY, we use DENYSOFT here to
|
|
||||||
# get the same behaviour as without Qpsmtpd::DSN...
|
|
||||||
return
|
|
||||||
Qpsmtpd::DSN->addr_bad_from_system(DENYSOFT,
|
|
||||||
"FQDN required in the envelope sender");
|
|
||||||
}
|
|
||||||
|
|
||||||
return DECLINED if $sender->host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/;
|
|
||||||
|
|
||||||
unless ($self->check_dns($sender->host)) {
|
|
||||||
return Qpsmtpd::DSN->temp_resolver_failed(
|
|
||||||
"Could not resolve " . $sender->host);
|
|
||||||
}
|
|
||||||
|
|
||||||
return YIELD;
|
|
||||||
}
|
|
||||||
|
|
||||||
return DECLINED;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub hook_mail_done {
|
|
||||||
my ($self, $transaction, $sender) = @_;
|
|
||||||
|
|
||||||
return DECLINED
|
|
||||||
if ($self->connection->notes('whitelisthost'));
|
|
||||||
|
|
||||||
if ($sender ne "<>" && !$transaction->notes('resolvable_fromhost')) {
|
|
||||||
|
|
||||||
# default of temp_resolver_failed is DENYSOFT
|
|
||||||
return Qpsmtpd::DSN->temp_resolver_failed(
|
|
||||||
"Could not resolve " . $sender->host);
|
|
||||||
}
|
|
||||||
return DECLINED;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub check_dns {
|
|
||||||
my ($self, $host) = @_;
|
|
||||||
my @host_answers;
|
|
||||||
|
|
||||||
my $qp = $self->qp;
|
|
||||||
$qp->input_sock->pause_read;
|
|
||||||
|
|
||||||
my $a_records = [];
|
|
||||||
my $num_queries = 1; # queries in progress
|
|
||||||
my $mx_found = 0;
|
|
||||||
|
|
||||||
ParaDNS->new(
|
|
||||||
callback => sub {
|
|
||||||
my $mx = shift;
|
|
||||||
return if $mx =~ /^[A-Z]+$/; # error
|
|
||||||
|
|
||||||
my $addr = $mx->[0];
|
|
||||||
$mx_found = 1;
|
|
||||||
|
|
||||||
$num_queries++;
|
|
||||||
ParaDNS->new(
|
|
||||||
callback => sub {
|
|
||||||
push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/;
|
|
||||||
},
|
|
||||||
finished => sub {
|
|
||||||
$num_queries--;
|
|
||||||
$self->finish_up($qp, $a_records, $num_queries);
|
|
||||||
},
|
|
||||||
host => $addr,
|
|
||||||
type => 'A',
|
|
||||||
);
|
|
||||||
|
|
||||||
if ($has_ipv6) {
|
|
||||||
$num_queries++;
|
|
||||||
ParaDNS->new(
|
|
||||||
callback => sub {
|
|
||||||
push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/;
|
|
||||||
},
|
|
||||||
finished => sub {
|
|
||||||
$num_queries--;
|
|
||||||
$self->finish_up($qp, $a_records, $num_queries);
|
|
||||||
},
|
|
||||||
host => $addr,
|
|
||||||
type => 'AAAA',
|
|
||||||
);
|
|
||||||
}
|
|
||||||
},
|
|
||||||
finished => sub {
|
|
||||||
|
|
||||||
unless ($mx_found) {
|
|
||||||
|
|
||||||
$num_queries++;
|
|
||||||
ParaDNS->new(
|
|
||||||
callback => sub {
|
|
||||||
push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/;
|
|
||||||
},
|
|
||||||
finished => sub {
|
|
||||||
$num_queries--;
|
|
||||||
$self->finish_up($qp, $a_records, $num_queries);
|
|
||||||
},
|
|
||||||
host => $host,
|
|
||||||
type => 'A',
|
|
||||||
);
|
|
||||||
|
|
||||||
if ($has_ipv6) {
|
|
||||||
$num_queries++;
|
|
||||||
ParaDNS->new(
|
|
||||||
callback => sub {
|
|
||||||
push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/;
|
|
||||||
},
|
|
||||||
finished => sub {
|
|
||||||
$num_queries--;
|
|
||||||
$self->finish_up($qp, $a_records, $num_queries);
|
|
||||||
},
|
|
||||||
host => $host,
|
|
||||||
type => 'AAAA',
|
|
||||||
);
|
|
||||||
}
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
$num_queries--;
|
|
||||||
$self->finish_up($qp, $a_records, $num_queries);
|
|
||||||
},
|
|
||||||
host => $host,
|
|
||||||
type => 'MX',
|
|
||||||
)
|
|
||||||
or $qp->input_sock->continue_read, return;
|
|
||||||
|
|
||||||
return 1;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub finish_up {
|
|
||||||
my ($self, $qp, $a_records, $num_queries) = @_;
|
|
||||||
|
|
||||||
return if defined $qp->transaction->notes('resolvable_fromhost');
|
|
||||||
|
|
||||||
foreach my $addr (@$a_records) {
|
|
||||||
if (is_valid($addr)) {
|
|
||||||
$qp->transaction->notes('resolvable_fromhost', 1);
|
|
||||||
$qp->input_sock->continue_read;
|
|
||||||
$qp->run_continuation;
|
|
||||||
return;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
unless ($num_queries) {
|
|
||||||
|
|
||||||
# all queries returned no valid response
|
|
||||||
$qp->transaction->notes('resolvable_fromhost', 0);
|
|
||||||
$qp->input_sock->continue_read;
|
|
||||||
$qp->run_continuation;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub is_valid {
|
|
||||||
my $ip = shift;
|
|
||||||
my ($net, $mask);
|
|
||||||
foreach $net (keys %invalid) {
|
|
||||||
$mask = $invalid{$net};
|
|
||||||
$mask = pack "B32", "1" x ($mask) . "0" x (32 - $mask);
|
|
||||||
return 0
|
|
||||||
if join(".", unpack("C4", inet_aton($ip) & $mask)) eq $net;
|
|
||||||
}
|
|
||||||
return 1;
|
|
||||||
}
|
|
||||||
@ -1,92 +0,0 @@
|
|||||||
#!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;
|
|
||||||
}
|
|
||||||
|
|
||||||
=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
|
|
||||||
@ -1,151 +0,0 @@
|
|||||||
#!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;
|
|
||||||
}
|
|
||||||
|
|
||||||
=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
|
|
||||||
@ -36,10 +36,6 @@ 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
|
queries happen in the background. This plugin's 'rcpt_handler' retrieves
|
||||||
the results of the query and sets the connection note if found.
|
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
|
=head1 AUTHOR
|
||||||
|
|
||||||
John Peacock <jpeacock@rowman.com>
|
John Peacock <jpeacock@rowman.com>
|
||||||
|
|||||||
@ -114,7 +114,7 @@ p0f v3 requires only the remote IP.
|
|||||||
p0f v2 requires four pieces of information to look up the p0f fingerprint:
|
p0f v2 requires four pieces of information to look up the p0f fingerprint:
|
||||||
local_ip, local_port, remote_ip, and remote_port. TcpServer.pm has been
|
local_ip, local_port, remote_ip, and remote_port. TcpServer.pm has been
|
||||||
has been updated to provide that information when running under djb's
|
has been updated to provide that information when running under djb's
|
||||||
tcpserver. The async, forkserver, and prefork models will likely require
|
tcpserver. The forkserver and prefork models will likely require
|
||||||
some additional changes to make sure these fields are populated.
|
some additional changes to make sure these fields are populated.
|
||||||
|
|
||||||
=head1 ACKNOWLEDGEMENTS
|
=head1 ACKNOWLEDGEMENTS
|
||||||
|
|||||||
@ -36,8 +36,6 @@ Since many connections are from blacklisted IPs, naughty significantly reduces t
|
|||||||
|
|
||||||
Rather than having plugins split processing across hooks, plugins can run to completion when they have the information they need, issue a I<reject naughty> if warranted, and be done.
|
Rather than having plugins split processing across hooks, plugins can run to completion when they have the information they need, issue a I<reject naughty> if warranted, and be done.
|
||||||
|
|
||||||
This may help reduce the code divergence between the sync and async deployment models.
|
|
||||||
|
|
||||||
=head2 authentication
|
=head2 authentication
|
||||||
|
|
||||||
When a user authenticates, the naughty flag on their connection is cleared. This allows users to send email from IPs that fail connection tests such as B<dnsbl>. Note that if I<reject connect> is set, connections will not get the chance to authenticate. To allow clients a chance to authenticate, I<reject mail> works well.
|
When a user authenticates, the naughty flag on their connection is cleared. This allows users to send email from IPs that fail connection tests such as B<dnsbl>. Note that if I<reject connect> is set, connections will not get the chance to authenticate. To allow clients a chance to authenticate, I<reject mail> works well.
|
||||||
|
|||||||
@ -68,19 +68,20 @@ Names of the substitution parameters and the replaced charachters are the same
|
|||||||
L<spamd(8)> supports, for more info see the C<--virtual-config-dir>
|
L<spamd(8)> supports, for more info see the C<--virtual-config-dir>
|
||||||
option of L<spamd(8)>.
|
option of L<spamd(8)>.
|
||||||
|
|
||||||
When called with more than one parameter, this plugin is probably not usable
|
|
||||||
with qpsmtpd-async.
|
|
||||||
|
|
||||||
With the the second parameter being C<%d> it will still deliver one message
|
With the the second parameter being C<%d> it will still deliver one message
|
||||||
for each recipient: With the two recpients C<user@example.org> and
|
for each recipient: With the two recpients C<user@example.org> and
|
||||||
C<user2@example.org> you get two messages in the C<example.org/> directory.
|
C<user2@example.org> you get two messages in the C<example.org/> directory.
|
||||||
|
|
||||||
=cut
|
=cut
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
|
||||||
use File::Path qw(mkpath);
|
use File::Path qw(mkpath);
|
||||||
use Sys::Hostname qw(hostname);
|
use Sys::Hostname qw(hostname);
|
||||||
use Time::HiRes qw(gettimeofday);
|
use Time::HiRes qw(gettimeofday);
|
||||||
|
|
||||||
|
use Qpsmtpd::Constants;
|
||||||
|
|
||||||
sub register {
|
sub register {
|
||||||
my ($self, $qp, @args) = @_;
|
my ($self, $qp, @args) = @_;
|
||||||
|
|
||||||
@ -108,8 +109,7 @@ sub register {
|
|||||||
$self->{_perms} = oct($self->{_perms});
|
$self->{_perms} = oct($self->{_perms});
|
||||||
}
|
}
|
||||||
|
|
||||||
$self->{_perms} = 0700
|
$self->{_perms} ||= 0700;
|
||||||
unless $self->{_perms};
|
|
||||||
|
|
||||||
unless ($self->{_maildir}) {
|
unless ($self->{_maildir}) {
|
||||||
$self->log(LOGWARN, "WARNING: maildir directory not specified");
|
$self->log(LOGWARN, "WARNING: maildir directory not specified");
|
||||||
|
|||||||
@ -64,29 +64,16 @@ sub hook_unrecognized_command {
|
|||||||
$self->log(LOGINFO, "stunnel : $remote_ip:$remote_port");
|
$self->log(LOGINFO, "stunnel : $remote_ip:$remote_port");
|
||||||
|
|
||||||
# DNS reverse
|
# DNS reverse
|
||||||
if ( $self->isa('Qpsmtpd::PollServer') ) {
|
my $res = Net::DNS::Resolver->new( dnsrch => 0 );
|
||||||
eval {
|
$res->tcp_timeout(3);
|
||||||
use ParaDNS;
|
$res->udp_timeout(3);
|
||||||
ParaDNS->new(
|
my $query = $res->query( $remote_ip, 'PTR' );
|
||||||
finished => sub { $self->continue_read() },
|
if ($query) {
|
||||||
callback => sub { $self->connection->remote_host($_[0]) },
|
foreach my $rr ($query->answer) {
|
||||||
host => $remote_ip,
|
next if $rr->type ne 'PTR';
|
||||||
);
|
$self->connection->remote_host( $rr->ptrdname );
|
||||||
|
}
|
||||||
};
|
}
|
||||||
}
|
|
||||||
else {
|
|
||||||
my $res = Net::DNS::Resolver->new( dnsrch => 0 );
|
|
||||||
$res->tcp_timeout(3);
|
|
||||||
$res->udp_timeout(3);
|
|
||||||
my $query = $res->query( $remote_ip, 'PTR' );
|
|
||||||
if ($query) {
|
|
||||||
foreach my $rr ($query->answer) {
|
|
||||||
next if $rr->type ne 'PTR';
|
|
||||||
$self->connection->remote_host( $rr->ptrdname );
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
}
|
||||||
else {
|
else {
|
||||||
return DENY_DISCONNECT;
|
return DENY_DISCONNECT;
|
||||||
|
|||||||
19
plugins/tls
19
plugins/tls
@ -59,8 +59,12 @@ and put a suitable string in config/tls_ciphers (e.g. "DEFAULT" or
|
|||||||
|
|
||||||
=cut
|
=cut
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
|
||||||
use IO::Socket::SSL 0.98;
|
use IO::Socket::SSL 0.98;
|
||||||
|
|
||||||
|
use Qpsmtpd::Constants;
|
||||||
|
|
||||||
sub init {
|
sub init {
|
||||||
my ($self, $qp, $cert, $key, $ca) = @_;
|
my ($self, $qp, $cert, $key, $ca) = @_;
|
||||||
my $dir = -d 'ssl' ? 'ssl' : 'config/ssl';
|
my $dir = -d 'ssl' ? 'ssl' : 'config/ssl';
|
||||||
@ -179,10 +183,6 @@ sub hook_post_connection {
|
|||||||
sub _convert_to_ssl {
|
sub _convert_to_ssl {
|
||||||
my ($self) = @_;
|
my ($self) = @_;
|
||||||
|
|
||||||
if ($self->qp->isa('Qpsmtpd::PollServer')) {
|
|
||||||
return _convert_to_ssl_async($self);
|
|
||||||
}
|
|
||||||
|
|
||||||
eval {
|
eval {
|
||||||
my $tlssocket =
|
my $tlssocket =
|
||||||
IO::Socket::SSL->new_from_fd(
|
IO::Socket::SSL->new_from_fd(
|
||||||
@ -210,14 +210,6 @@ sub _convert_to_ssl {
|
|||||||
return 1;
|
return 1;
|
||||||
}
|
}
|
||||||
|
|
||||||
sub _convert_to_ssl_async {
|
|
||||||
my ($self) = @_;
|
|
||||||
my $upgrader =
|
|
||||||
$self->connection->notes('tls_upgrader', UpgradeClientSSL->new($self));
|
|
||||||
$upgrader->upgrade_socket();
|
|
||||||
return 1;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub can_do_tls {
|
sub can_do_tls {
|
||||||
my ($self) = @_;
|
my ($self) = @_;
|
||||||
$self->tls_cert && -r $self->tls_cert;
|
$self->tls_cert && -r $self->tls_cert;
|
||||||
@ -265,10 +257,9 @@ sub bad_ssl_hook {
|
|||||||
package UpgradeClientSSL;
|
package UpgradeClientSSL;
|
||||||
|
|
||||||
# borrowed heavily from Perlbal::SocketSSL
|
# borrowed heavily from Perlbal::SocketSSL
|
||||||
|
|
||||||
use strict;
|
use strict;
|
||||||
use warnings;
|
use warnings;
|
||||||
no warnings qw(deprecated);
|
no warnings 'deprecated';
|
||||||
|
|
||||||
use IO::Socket::SSL 0.98;
|
use IO::Socket::SSL 0.98;
|
||||||
use Errno qw( EAGAIN );
|
use Errno qw( EAGAIN );
|
||||||
|
|||||||
@ -135,7 +135,6 @@ my %strict_twolevel_cctlds = (
|
|||||||
'za' => 1,
|
'za' => 1,
|
||||||
);
|
);
|
||||||
|
|
||||||
# async version: OK
|
|
||||||
sub init {
|
sub init {
|
||||||
my ($self, $qp, %args) = @_;
|
my ($self, $qp, %args) = @_;
|
||||||
|
|
||||||
@ -161,14 +160,14 @@ sub init {
|
|||||||
for (split /,/, $z[1]) {
|
for (split /,/, $z[1]) {
|
||||||
unless (/^(-?\d+)$/) {
|
unless (/^(-?\d+)$/) {
|
||||||
$self->log(LOGERROR, "Malformed mask $_ for $z[0]");
|
$self->log(LOGERROR, "Malformed mask $_ for $z[0]");
|
||||||
return undef;
|
return;
|
||||||
}
|
}
|
||||||
$mask |= $1 >= 0 ? $1 : 0x00ffffff;
|
$mask |= $1 >= 0 ? $1 : 0x00ffffff;
|
||||||
}
|
}
|
||||||
my $action = $z[2] || $self->{action};
|
my $action = $z[2] || $self->{action};
|
||||||
unless ($action =~ /^(add-header|deny|denysoft|log)$/) {
|
unless ($action =~ /^(add-header|deny|denysoft|log)$/) {
|
||||||
$self->log(LOGERROR, "Unknown action $action for $z[0]");
|
$self->log(LOGERROR, "Unknown action $action for $z[0]");
|
||||||
return undef;
|
return;
|
||||||
}
|
}
|
||||||
|
|
||||||
$self->{uribl_zones}->{$z[0]} = {
|
$self->{uribl_zones}->{$z[0]} = {
|
||||||
@ -184,20 +183,12 @@ sub init {
|
|||||||
$self->init_resolver;
|
$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 {
|
sub send_query {
|
||||||
my $self = shift;
|
my $self = shift;
|
||||||
my $name = shift || return undef;
|
my $name = shift || return;
|
||||||
my $count = 0;
|
my $count = 0;
|
||||||
|
|
||||||
$self->{socket_select} ||= new IO::Select or return undef;
|
$self->{socket_select} ||= new IO::Select or return;
|
||||||
for my $z (keys %{$self->{uribl_zones}}) {
|
for my $z (keys %{$self->{uribl_zones}}) {
|
||||||
my ($s, $s1);
|
my ($s, $s1);
|
||||||
my $index = {
|
my $index = {
|
||||||
@ -240,7 +231,6 @@ sub send_query {
|
|||||||
$count;
|
$count;
|
||||||
}
|
}
|
||||||
|
|
||||||
# async version: not used
|
|
||||||
sub lookup_finish {
|
sub lookup_finish {
|
||||||
my $self = shift;
|
my $self = shift;
|
||||||
$self->{socket_idx} = {};
|
$self->{socket_idx} = {};
|
||||||
@ -248,21 +238,19 @@ sub lookup_finish {
|
|||||||
undef $self->{socket_select};
|
undef $self->{socket_select};
|
||||||
}
|
}
|
||||||
|
|
||||||
# async version: OK
|
|
||||||
sub evaluate {
|
sub evaluate {
|
||||||
my $self = shift;
|
my $self = shift;
|
||||||
my $zone = shift || return undef;
|
my $zone = shift || return;
|
||||||
my $a = shift || return undef;
|
my $a = shift || return;
|
||||||
|
|
||||||
my $mask = $self->{uribl_zones}->{$zone}->{mask} || $self->{mask};
|
my $mask = $self->{uribl_zones}->{$zone}->{mask} || $self->{mask};
|
||||||
$a =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/ or return undef;
|
$a =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/ or return;
|
||||||
my $v =
|
my $v =
|
||||||
(($1 & 0xff) << 24) | (($2 & 0xff) << 16) | (($3 & 0xff) << 8) |
|
(($1 & 0xff) << 24) | (($2 & 0xff) << 16) | (($3 & 0xff) << 8) |
|
||||||
($4 & 0xff);
|
($4 & 0xff);
|
||||||
return ($v & $mask);
|
return ($v & $mask);
|
||||||
}
|
}
|
||||||
|
|
||||||
# async version: OK
|
|
||||||
sub lookup_start {
|
sub lookup_start {
|
||||||
my ($self, $transaction, $start_query) = @_;
|
my ($self, $transaction, $start_query) = @_;
|
||||||
|
|
||||||
@ -442,7 +430,6 @@ sub lookup_start {
|
|||||||
return $queries;
|
return $queries;
|
||||||
}
|
}
|
||||||
|
|
||||||
# async version: not used
|
|
||||||
sub collect_results {
|
sub collect_results {
|
||||||
my ($self, $transaction) = @_;
|
my ($self, $transaction) = @_;
|
||||||
|
|
||||||
@ -512,8 +499,7 @@ sub collect_results {
|
|||||||
return \@matches;
|
return \@matches;
|
||||||
}
|
}
|
||||||
|
|
||||||
# async version: not used
|
sub hook_data {
|
||||||
sub data_handler {
|
|
||||||
my ($self, $transaction) = @_;
|
my ($self, $transaction) = @_;
|
||||||
|
|
||||||
return (DECLINED) if $self->is_immune();
|
return (DECLINED) if $self->is_immune();
|
||||||
@ -526,7 +512,7 @@ sub data_handler {
|
|||||||
}
|
}
|
||||||
);
|
);
|
||||||
|
|
||||||
unless ($queries) {
|
if (!$queries) {
|
||||||
$self->log(LOGINFO, "pass, No URIs found in mail");
|
$self->log(LOGINFO, "pass, No URIs found in mail");
|
||||||
return DECLINED;
|
return DECLINED;
|
||||||
}
|
}
|
||||||
@ -547,11 +533,8 @@ sub data_handler {
|
|||||||
return DECLINED;
|
return DECLINED;
|
||||||
}
|
}
|
||||||
|
|
||||||
# async version: not used
|
|
||||||
sub init_resolver {
|
sub init_resolver {
|
||||||
my $self = shift;
|
my $self = shift;
|
||||||
|
$self->{resolver} = new Net::DNS::Resolver or return;
|
||||||
$self->{resolver} = new Net::DNS::Resolver or return undef;
|
|
||||||
$self->{resolver}->udp_timeout($self->{timeout});
|
$self->{resolver}->udp_timeout($self->{timeout});
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|||||||
464
qpsmtpd-async
464
qpsmtpd-async
@ -1,464 +0,0 @@
|
|||||||
#!/usr/bin/perl
|
|
||||||
|
|
||||||
use lib "./lib";
|
|
||||||
|
|
||||||
BEGIN {
|
|
||||||
delete $ENV{ENV};
|
|
||||||
delete $ENV{BASH_ENV};
|
|
||||||
$ENV{PATH} = '/bin:/usr/bin:/var/qmail/bin:/usr/local/bin';
|
|
||||||
}
|
|
||||||
|
|
||||||
# Profiling - requires Devel::Profiler 0.05
|
|
||||||
#BEGIN { $Devel::Profiler::NO_INIT = 1; }
|
|
||||||
#use Devel::Profiler;
|
|
||||||
|
|
||||||
use strict;
|
|
||||||
use vars qw($DEBUG);
|
|
||||||
use FindBin qw();
|
|
||||||
|
|
||||||
# TODO: need to make this taint friendly
|
|
||||||
use lib "$FindBin::Bin/lib";
|
|
||||||
use Danga::Socket;
|
|
||||||
use Danga::Client;
|
|
||||||
use Qpsmtpd::PollServer;
|
|
||||||
use Qpsmtpd::ConfigServer;
|
|
||||||
use Qpsmtpd::Constants;
|
|
||||||
use IO::Socket;
|
|
||||||
use Carp;
|
|
||||||
use POSIX qw(WNOHANG);
|
|
||||||
use Getopt::Long;
|
|
||||||
use List::Util qw(shuffle);
|
|
||||||
|
|
||||||
$|++;
|
|
||||||
|
|
||||||
use Socket
|
|
||||||
qw(SOMAXCONN IPPROTO_TCP SO_KEEPALIVE TCP_NODELAY SOL_SOCKET AF_UNIX SOCK_STREAM PF_UNSPEC);
|
|
||||||
|
|
||||||
$SIG{'PIPE'} = "IGNORE"; # handled manually
|
|
||||||
|
|
||||||
$DEBUG = 0;
|
|
||||||
|
|
||||||
my $CONFIG_PORT = 20025;
|
|
||||||
my $CONFIG_LOCALADDR = '127.0.0.1';
|
|
||||||
|
|
||||||
my $PORT = 2525;
|
|
||||||
my $LOCALADDR = '0.0.0.0';
|
|
||||||
my $PROCS = 1;
|
|
||||||
my $USER = (getpwuid $>)[0]; # user to suid to
|
|
||||||
$USER = "smtpd" if $USER eq "root";
|
|
||||||
my $PAUSED = 0;
|
|
||||||
my $NUMACCEPT = 20;
|
|
||||||
my $PID_FILE = '';
|
|
||||||
my $ACCEPT_RSET;
|
|
||||||
my $DETACH; # daemonize on startup
|
|
||||||
|
|
||||||
# make sure we don't spend forever doing accept()
|
|
||||||
use constant ACCEPT_MAX => 1000;
|
|
||||||
|
|
||||||
sub reset_num_accept {
|
|
||||||
$NUMACCEPT = 20;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub help {
|
|
||||||
print <<EOT;
|
|
||||||
Usage:
|
|
||||||
qpsmtpd [OPTIONS]
|
|
||||||
|
|
||||||
Options:
|
|
||||||
-l, --listen-address addr : listen on a specific address; default 0.0.0.0
|
|
||||||
-p, --port P : listen on a specific port; default 2525
|
|
||||||
--config-port : config server port; default 20025
|
|
||||||
-u, --user U : run as a particular user; defualt 'smtpd'
|
|
||||||
-j, --procs J : spawn J processes; default 1
|
|
||||||
-d, --detach : detach from controlling terminal (daemonize)
|
|
||||||
--pid-file P : print main servers PID to file P
|
|
||||||
|
|
||||||
-h, --help : this page
|
|
||||||
--use-poll : force use of poll() instead of epoll()/kqueue()
|
|
||||||
EOT
|
|
||||||
exit(0);
|
|
||||||
}
|
|
||||||
|
|
||||||
GetOptions(
|
|
||||||
'p|port=i' => \$PORT,
|
|
||||||
'l|listen-address=s' => \$LOCALADDR,
|
|
||||||
'j|procs=i' => \$PROCS,
|
|
||||||
'v|verbose+' => \$DEBUG,
|
|
||||||
'u|user=s' => \$USER,
|
|
||||||
'pid-file=s' => \$PID_FILE,
|
|
||||||
'd|detach' => \$DETACH,
|
|
||||||
'h|help' => \&help,
|
|
||||||
'config-port=i' => \$CONFIG_PORT,
|
|
||||||
)
|
|
||||||
|| help();
|
|
||||||
|
|
||||||
# detaint the commandline
|
|
||||||
if ($PORT =~ /^(\d+)$/) { $PORT = $1 }
|
|
||||||
else { &help }
|
|
||||||
if ($LOCALADDR =~ /^([\d\w\-.]+)$/) { $LOCALADDR = $1 }
|
|
||||||
else { &help }
|
|
||||||
if ($USER =~ /^([\w\-]+)$/) { $USER = $1 }
|
|
||||||
else { &help }
|
|
||||||
if ($PROCS =~ /^(\d+)$/) { $PROCS = $1 }
|
|
||||||
else { &help }
|
|
||||||
|
|
||||||
sub force_poll {
|
|
||||||
$Danga::Socket::HaveEpoll = 0;
|
|
||||||
$Danga::Socket::HaveKQueue = 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
my $POLL = "with "
|
|
||||||
. (
|
|
||||||
$Danga::Socket::HaveEpoll ? "epoll()"
|
|
||||||
: $Danga::Socket::HaveKQueue ? "kqueue()"
|
|
||||||
: "poll()"
|
|
||||||
);
|
|
||||||
|
|
||||||
my $SERVER;
|
|
||||||
my $CONFIG_SERVER;
|
|
||||||
|
|
||||||
use constant READY => 1;
|
|
||||||
use constant ACCEPTING => 2;
|
|
||||||
use constant RESTARTING => 999;
|
|
||||||
|
|
||||||
my %childstatus = ();
|
|
||||||
|
|
||||||
if ($PID_FILE && -r $PID_FILE) {
|
|
||||||
open PID, "<$PID_FILE"
|
|
||||||
or die "open_pidfile $PID_FILE: $!\n";
|
|
||||||
my $running_pid = <PID> || '';
|
|
||||||
chomp $running_pid;
|
|
||||||
if ($running_pid =~ /^(\d+)/) {
|
|
||||||
if (kill 0, $running_pid) {
|
|
||||||
die "Found an already running qpsmtpd with pid $running_pid.\n";
|
|
||||||
}
|
|
||||||
}
|
|
||||||
close(PID);
|
|
||||||
}
|
|
||||||
|
|
||||||
run_as_server();
|
|
||||||
exit(0);
|
|
||||||
|
|
||||||
sub _fork {
|
|
||||||
my $pid = fork;
|
|
||||||
if (!defined($pid)) { die "Cannot fork: $!" }
|
|
||||||
return $pid if $pid;
|
|
||||||
|
|
||||||
# Fixup Net::DNS randomness after fork
|
|
||||||
srand($$ ^ time);
|
|
||||||
|
|
||||||
local $^W;
|
|
||||||
delete $INC{'Net/DNS/Header.pm'};
|
|
||||||
require Net::DNS::Header;
|
|
||||||
|
|
||||||
# cope with different versions of Net::DNS
|
|
||||||
eval {
|
|
||||||
$Net::DNS::Resolver::global{id} = 1;
|
|
||||||
$Net::DNS::Resolver::global{id} =
|
|
||||||
int(rand(Net::DNS::Resolver::MAX_ID()));
|
|
||||||
|
|
||||||
# print "Next DNS ID: $Net::DNS::Resolver::global{id}\n";
|
|
||||||
};
|
|
||||||
if ($@) {
|
|
||||||
|
|
||||||
# print "Next DNS ID: " . Net::DNS::Header::nextid() . "\n";
|
|
||||||
}
|
|
||||||
|
|
||||||
# Fixup lost kqueue after fork
|
|
||||||
$Danga::Socket::HaveKQueue = undef;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub spawn_child {
|
|
||||||
my $plugin_loader = shift || Qpsmtpd::SMTP->new;
|
|
||||||
|
|
||||||
socketpair(my $reader, my $writer, AF_UNIX, SOCK_STREAM, PF_UNSPEC)
|
|
||||||
|| die "Unable to create a pipe";
|
|
||||||
$writer->autoflush(1);
|
|
||||||
$reader->autoflush(1);
|
|
||||||
|
|
||||||
if (my $pid = _fork) {
|
|
||||||
$childstatus{$pid} = $writer;
|
|
||||||
return $pid;
|
|
||||||
}
|
|
||||||
|
|
||||||
$SIG{CHLD} = $SIG{INT} = $SIG{TERM} = 'DEFAULT';
|
|
||||||
$SIG{PIPE} = 'IGNORE';
|
|
||||||
$SIG{HUP} = 'IGNORE';
|
|
||||||
|
|
||||||
close $CONFIG_SERVER;
|
|
||||||
|
|
||||||
Qpsmtpd::PollServer->Reset;
|
|
||||||
|
|
||||||
Qpsmtpd::PollServer->OtherFds(
|
|
||||||
fileno($reader) => sub { command_handler($reader) },
|
|
||||||
fileno($SERVER) => \&accept_handler,);
|
|
||||||
|
|
||||||
$ACCEPT_RSET = Danga::Socket->AddTimer(30, \&reset_num_accept);
|
|
||||||
|
|
||||||
$plugin_loader->run_hooks('post-fork');
|
|
||||||
|
|
||||||
Qpsmtpd::PollServer->EventLoop();
|
|
||||||
exit;
|
|
||||||
}
|
|
||||||
|
|
||||||
# Note this is broken on KQueue because it requires that it handle signals itself or it breaks the event loop.
|
|
||||||
sub sig_hup {
|
|
||||||
for my $writer (values %childstatus) {
|
|
||||||
print $writer "hup\n";
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub sig_chld {
|
|
||||||
my $spawn_count = 0;
|
|
||||||
while ((my $child = waitpid(-1, WNOHANG)) > 0) {
|
|
||||||
if (!defined $childstatus{$child}) {
|
|
||||||
next;
|
|
||||||
}
|
|
||||||
|
|
||||||
last unless $child > 0;
|
|
||||||
print "SIGCHLD: child $child died\n";
|
|
||||||
delete $childstatus{$child};
|
|
||||||
$spawn_count++;
|
|
||||||
}
|
|
||||||
if ($spawn_count) {
|
|
||||||
for (1 .. $spawn_count) {
|
|
||||||
|
|
||||||
# restart a new child if in poll server mode
|
|
||||||
my $pid = spawn_child();
|
|
||||||
}
|
|
||||||
}
|
|
||||||
$SIG{CHLD} = \&sig_chld;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub HUNTSMAN {
|
|
||||||
$SIG{CHLD} = 'DEFAULT';
|
|
||||||
kill 'INT' => keys %childstatus;
|
|
||||||
if ($PID_FILE && -e $PID_FILE) {
|
|
||||||
unlink $PID_FILE or ::log(LOGERROR, "unlink: $PID_FILE: $!");
|
|
||||||
}
|
|
||||||
exit(0);
|
|
||||||
}
|
|
||||||
|
|
||||||
sub run_as_server {
|
|
||||||
|
|
||||||
# establish SERVER socket, bind and listen.
|
|
||||||
$SERVER = IO::Socket::INET->new(
|
|
||||||
LocalPort => $PORT,
|
|
||||||
LocalAddr => $LOCALADDR,
|
|
||||||
Type => SOCK_STREAM,
|
|
||||||
Proto => IPPROTO_TCP,
|
|
||||||
Blocking => 0,
|
|
||||||
Reuse => 1,
|
|
||||||
Listen => SOMAXCONN
|
|
||||||
)
|
|
||||||
or die "Error creating server $LOCALADDR:$PORT : $@\n";
|
|
||||||
|
|
||||||
IO::Handle::blocking($SERVER, 0);
|
|
||||||
binmode($SERVER, ':raw');
|
|
||||||
|
|
||||||
$CONFIG_SERVER =
|
|
||||||
IO::Socket::INET->new(
|
|
||||||
LocalPort => $CONFIG_PORT,
|
|
||||||
LocalAddr => $CONFIG_LOCALADDR,
|
|
||||||
Type => SOCK_STREAM,
|
|
||||||
Proto => IPPROTO_TCP,
|
|
||||||
Blocking => 0,
|
|
||||||
Reuse => 1,
|
|
||||||
Listen => 1
|
|
||||||
)
|
|
||||||
or die "Error creating server $CONFIG_LOCALADDR:$CONFIG_PORT : $@\n";
|
|
||||||
|
|
||||||
IO::Handle::blocking($CONFIG_SERVER, 0);
|
|
||||||
binmode($CONFIG_SERVER, ':raw');
|
|
||||||
|
|
||||||
# Drop priviledges
|
|
||||||
my (undef, undef, $quid, $qgid) = getpwnam $USER
|
|
||||||
or die "unable to determine uid/gid for $USER\n";
|
|
||||||
my $groups = "$qgid $qgid";
|
|
||||||
while (my (undef, undef, $gid, $members) = getgrent) {
|
|
||||||
my @m = split(/ /, $members);
|
|
||||||
if (grep { $_ eq $USER } @m) {
|
|
||||||
$groups .= " $gid";
|
|
||||||
}
|
|
||||||
}
|
|
||||||
endgrent;
|
|
||||||
$) = $groups;
|
|
||||||
POSIX::setgid($qgid)
|
|
||||||
or die "unable to change gid: $!\n";
|
|
||||||
POSIX::setuid($quid)
|
|
||||||
or die "unable to change uid: $!\n";
|
|
||||||
$> = $quid;
|
|
||||||
|
|
||||||
# Load plugins here
|
|
||||||
my $plugin_loader = Qpsmtpd::SMTP->new();
|
|
||||||
$plugin_loader->load_plugins;
|
|
||||||
|
|
||||||
if ($DETACH) {
|
|
||||||
open STDIN, '/dev/null' or die "/dev/null: $!";
|
|
||||||
open STDOUT, '>/dev/null' or die "/dev/null: $!";
|
|
||||||
open STDERR, '>&STDOUT' or die "open(stderr): $!";
|
|
||||||
defined(my $pid = fork) or die "fork: $!";
|
|
||||||
exit 0 if $pid;
|
|
||||||
POSIX::setsid or die "setsid: $!";
|
|
||||||
}
|
|
||||||
|
|
||||||
if ($PID_FILE) {
|
|
||||||
open PID, ">$PID_FILE" || die "$PID_FILE: $!";
|
|
||||||
print PID $$, "\n";
|
|
||||||
close PID;
|
|
||||||
}
|
|
||||||
|
|
||||||
$plugin_loader->log(LOGINFO,
|
|
||||||
'Running as user '
|
|
||||||
. (getpwuid($>) || $>)
|
|
||||||
. ', group '
|
|
||||||
. (getgrgid($)) || $))
|
|
||||||
);
|
|
||||||
|
|
||||||
$SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
|
|
||||||
|
|
||||||
######################
|
|
||||||
# more Profiling code
|
|
||||||
|
|
||||||
=pod
|
|
||||||
$plugin_loader->run_hooks('post-fork');
|
|
||||||
|
|
||||||
Devel::Profiler->set_options(
|
|
||||||
bad_subs => [qw(Danga::Socket::EventLoop)],
|
|
||||||
sub_filter => sub {
|
|
||||||
my ($pkg, $sub) = @_;
|
|
||||||
return 0 if $sub eq 'AUTOLOAD';
|
|
||||||
return 0 if $pkg =~ /ParaDNS::XS/;
|
|
||||||
return 1;
|
|
||||||
},
|
|
||||||
);
|
|
||||||
Devel::Profiler->init();
|
|
||||||
|
|
||||||
Qpsmtpd::PollServer->OtherFds(
|
|
||||||
fileno($SERVER) => \&accept_handler,
|
|
||||||
fileno($CONFIG_SERVER) => \&config_handler, );
|
|
||||||
|
|
||||||
Qpsmtpd::PollServer->EventLoop;
|
|
||||||
exit;
|
|
||||||
=cut
|
|
||||||
|
|
||||||
#####################
|
|
||||||
|
|
||||||
for (1 .. $PROCS) {
|
|
||||||
my $pid = spawn_child($plugin_loader);
|
|
||||||
}
|
|
||||||
$plugin_loader->log(LOGDEBUG,
|
|
||||||
"Listening on $PORT with $PROCS children $POLL");
|
|
||||||
$SIG{CHLD} = \&sig_chld;
|
|
||||||
$SIG{HUP} = \&sig_hup;
|
|
||||||
|
|
||||||
Qpsmtpd::PollServer->OtherFds(fileno($CONFIG_SERVER) => \&config_handler,);
|
|
||||||
|
|
||||||
Qpsmtpd::PollServer->EventLoop;
|
|
||||||
|
|
||||||
exit;
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
sub config_handler {
|
|
||||||
my $csock = $CONFIG_SERVER->accept();
|
|
||||||
if (!$csock) {
|
|
||||||
|
|
||||||
# warn("accept failed on config server: $!");
|
|
||||||
return;
|
|
||||||
}
|
|
||||||
binmode($csock, ':raw');
|
|
||||||
|
|
||||||
printf("Config server connection\n") if $DEBUG;
|
|
||||||
|
|
||||||
IO::Handle::blocking($csock, 0);
|
|
||||||
setsockopt($csock, IPPROTO_TCP, TCP_NODELAY, pack("l", 1)) or die;
|
|
||||||
|
|
||||||
my $client = Qpsmtpd::ConfigServer->new($csock);
|
|
||||||
$client->watch_read(1);
|
|
||||||
return;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub command_handler {
|
|
||||||
my $reader = shift;
|
|
||||||
|
|
||||||
chomp(my $command = <$reader>);
|
|
||||||
|
|
||||||
#print "Got command: $command\n";
|
|
||||||
|
|
||||||
my $real_command = "cmd_$command";
|
|
||||||
|
|
||||||
no strict 'refs';
|
|
||||||
$real_command->();
|
|
||||||
}
|
|
||||||
|
|
||||||
sub cmd_hup {
|
|
||||||
|
|
||||||
# clear cache
|
|
||||||
print "Clearing cache\n";
|
|
||||||
Qpsmtpd::Config::clear_cache();
|
|
||||||
|
|
||||||
# should also reload modules... but can't do that yet.
|
|
||||||
}
|
|
||||||
|
|
||||||
# Accept all new connections
|
|
||||||
sub accept_handler {
|
|
||||||
for (1 .. $NUMACCEPT) {
|
|
||||||
return unless _accept_handler();
|
|
||||||
}
|
|
||||||
|
|
||||||
# got here because we have accept's left.
|
|
||||||
# So double the number we accept next time.
|
|
||||||
$NUMACCEPT *= 2;
|
|
||||||
$NUMACCEPT = ACCEPT_MAX if $NUMACCEPT > ACCEPT_MAX;
|
|
||||||
$ACCEPT_RSET->cancel if defined $ACCEPT_RSET;
|
|
||||||
$ACCEPT_RSET = Danga::Socket->AddTimer(30, \&reset_num_accept);
|
|
||||||
}
|
|
||||||
|
|
||||||
use Errno qw(EAGAIN EWOULDBLOCK);
|
|
||||||
|
|
||||||
sub _accept_handler {
|
|
||||||
my $csock = $SERVER->accept();
|
|
||||||
if (!$csock) {
|
|
||||||
|
|
||||||
# warn("accept() failed: $!");
|
|
||||||
return;
|
|
||||||
}
|
|
||||||
binmode($csock, ':raw');
|
|
||||||
|
|
||||||
printf("Listen child making a Qpsmtpd::PollServer for %d.\n",
|
|
||||||
fileno($csock))
|
|
||||||
if $DEBUG;
|
|
||||||
|
|
||||||
IO::Handle::blocking($csock, 0);
|
|
||||||
|
|
||||||
#setsockopt($csock, IPPROTO_TCP, TCP_NODELAY, pack("l", 1)) or die;
|
|
||||||
|
|
||||||
#print "Got connection\n";
|
|
||||||
my $client = Qpsmtpd::PollServer->new($csock);
|
|
||||||
|
|
||||||
if ($PAUSED) {
|
|
||||||
$client->write("451 Sorry, this server is currently paused\r\n");
|
|
||||||
$client->close;
|
|
||||||
return 1;
|
|
||||||
}
|
|
||||||
|
|
||||||
$client->process_line("Connect\n");
|
|
||||||
$client->watch_read(1);
|
|
||||||
$client->pause_read();
|
|
||||||
return 1;
|
|
||||||
}
|
|
||||||
|
|
||||||
########################################################################
|
|
||||||
|
|
||||||
sub log {
|
|
||||||
my ($level, $message) = @_;
|
|
||||||
|
|
||||||
# $level not used yet. this is reimplemented from elsewhere anyway
|
|
||||||
warn("$$ fd:? $message\n");
|
|
||||||
}
|
|
||||||
|
|
||||||
sub pause {
|
|
||||||
my ($pause) = @_;
|
|
||||||
$PAUSED = $pause;
|
|
||||||
}
|
|
||||||
@ -85,7 +85,7 @@ sub config_dir {
|
|||||||
}
|
}
|
||||||
|
|
||||||
sub plugin_dirs {
|
sub plugin_dirs {
|
||||||
('./plugins', './plugins/ident', './plugins/async');
|
('./plugins', './plugins/ident');
|
||||||
}
|
}
|
||||||
|
|
||||||
sub log {
|
sub log {
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user