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

Merge branches/0.3x back to trunk.

Browse Source 
Too many individual changes to document.  Trust me... ;-)

Lightly tested (i.e. it accepts and delivers mail with minimal plugins).

NOTES/LIMITATIONS: 
logging/adaptive currently eats some log messages.
auth_vpopmail_sql is currently broken (needs continuations?).
'make test' fails in dnsbl (no Test::Qpsmtpd::input_sock() method).


git-svn-id: https://svn.perl.org/qpsmtpd/trunk@588 958fd67b-6ff1-0310-b445-bb7760255be9
This commit is contained in:
John Peacock 2005-12-22 21:30:53 +00:00
parent 8ac6157ee8
commit 2535e77293
24 changed files with 566 additions and 143 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
.perltidyrc Normal file
View File

@ -0,0 +1,16 @@
-i=4 # 4 space indentation (we used to use 2; in the future we'll use 4)
-ci=2 # continuation indention
-pt=2 # tight parens
-sbt=2 # tight square parens
-bt=2 # tight curly braces
-bbt=0 # open code block curly braces
-lp # line up with parentheses
-cti=1 # align closing parens with opening parens ("closing token placement")
# -nolq # don't outdent long quotes (not sure if we should enable this)

43
Changes
View File

@ -1,10 +1,20 @@
0.40
Make the clamdscan plugin temporarily deny mail if if can't talk to clamd
(Filippo Carletti)
0.31.1 - 2005/11/18
Add missing files to the distribution, oops... (Thanks Budi Ang!)
(exim plugin, tls plugin, various sample configuration files)
0.31 -
0.31 - 2005/11/16
STARTTLS support (see plugins/tls)
Added queue/exim-bsmtp plugin to spool accepted mail into an Exim
backend via BSMTP. (Devin Carraway)
New plugin inheritance system, see the bottom of README.plugins for
more information
qpsmtpd-forkserver: --listen-address may now be given more than once, to
request listening on multiple local addresses (Devin Carraway)
@ -17,14 +27,41 @@
postfix backend, which expects to have write permission to a fifo
which usually belongs to group postdrop). (pjh)
qpsmtpd-forkserver: if -d or --detach is given on the commandline,
forkserver will detach from the controlling terminal and daemonize
itself (Devin Carraway)
replace some fun smtp comments with boring ones.
example patterns for badrcptto plugin - Gordon Rowell
Extend require_resolvable_fromhost to include a configurable list of
"impossible" addresses to combat spammer forging. (Hanno Hecker)
Use qmail/control/smtpdgreeting if it exists, otherwise
show the original qpsmtpd greeting (with version information).
Apply slight variation on patch from Peter Holzer to allow specification of
an explicit $QPSMTPD_CONFIG variable to specify where the config lives,
overriding $QMAIL/control and /var/qmail/control if set. The usual
"last location with the file wins" rule still applies.
Refactor Qpsmtpd::Address
when disconncting with a temporary failure, return 421 rather than
450 or 451. (Peter J. Holzer)
The unrecognized_command hook now uses DENY_DISCONNECT return
for disconnecting the user.
If the environment variable $QPSMTPD_CONFIG is set, qpsmtpd will look
for its config files in the directory given therein, in addition to (and
in preference to) other locations. (Peter J. Holzer)
Updated documentation
Various minor cleanups
0.30 - 2005/07/05

5
MANIFEST
View File

@ -1,6 +1,8 @@
Changes
config.sample/badhelo
config.sample/badrcptto_patterns
config.sample/dnsbl_zones
config.sample/invalid_resolvable_fromhost
config.sample/IP
config.sample/logging
config.sample/loglevel
@ -8,6 +10,7 @@ config.sample/plugins
config.sample/relayclients
config.sample/require_resolvable_fromhost
config.sample/rhsbl_zones
config.sample/size_threshold
CREDITS
lib/Apache/Qpsmtpd.pm
lib/Qpsmtpd.pm
@ -55,6 +58,7 @@ plugins/logging/adaptive
plugins/logging/devnull
plugins/logging/warn
plugins/milter
plugins/queue/exim-bsmtp
plugins/queue/maildir
plugins/queue/postfix-queue
plugins/queue/qmail-queue
@ -65,6 +69,7 @@ plugins/require_resolvable_fromhost
plugins/rhsbl
plugins/sender_permitted_from
plugins/spamassassin
plugins/tls
plugins/virus/aveclient
plugins/virus/bitdefender
plugins/virus/check_for_hi_virus

8
README
View File

@ -57,13 +57,9 @@ run the following command in the /home/smtpd/ directory.
svn co http://svn.perl.org/qpsmtpd/trunk .
Or if you want a specific release, use for example
Beware that the trunk might be unstable and unsuitable for anything but development, so you might want to get a specific release, for example:
svn co http://svn.perl.org/qpsmtpd/tags/0.30 .
In the branch L<http://svn.perl.org/qpsmtpd/branches/high_perf/> we
have an experimental event based version of qpsmtpd that can handle
thousands of simultaneous connections with very little overhead.
svn co http://svn.perl.org/qpsmtpd/tags/0.31.1 .
chmod o+t ~smtpd/qpsmtpd/ (or whatever directory you installed qpsmtpd
in) to make supervise start the log process.

4
STATUS
View File

@ -10,13 +10,15 @@ pez (or pezmail)
Near term roadmap
=================
0.31:
0.32:
- Bugfixes
- add module requirements to the META.yml file
0.40:
- Add user configuration plugin
- Add plugin API for checking if a local email address is valid
- use keyword "ESMTPA" in Received header in case of authentication to comply with RFC 3848.
0.50:
Include the popular check_delivery[1] functionality via the 0.30 API

6
config.sample/invalid_resolvable_fromhost Normal file
View File

@ -0,0 +1,6 @@
# include full network block including mask
127.0.0.0/8
0.0.0.0/8
224.0.0.0/4
169.254.0.0/16
10.0.0.0/8

3
config.sample/size_threshold Normal file
View File

@ -0,0 +1,3 @@
# Messages below the size below will be stored in memory and not spooled.
# Without this file, the default is 0 bytes, i.e. all messages will be spooled.
10000

29
lib/Qpsmtpd.pm
View File

@ -1,13 +1,13 @@
package Qpsmtpd;
use strict;
use vars qw($VERSION $Logger $TraceLevel $Spool_dir);
use vars qw($VERSION $Logger $TraceLevel $Spool_dir $Size_threshold);
use Sys::Hostname;
use Qpsmtpd::Constants;
use Qpsmtpd::Transaction;
use Qpsmtpd::Connection;
$VERSION = "0.31-dev";
$VERSION = "0.40-dev";
sub version { $VERSION };
@ -242,8 +242,6 @@ sub expand_inclusion_ {
}
#our $HOOKS;
sub load_plugins {
my $self = shift;
@ -480,6 +478,29 @@ sub temp_dir {
return $dirname;
}
sub size_threshold {
my $self = shift;
unless ( defined $Size_threshold ) {
$Size_threshold = $self->config('size_threshold') || 0;
$self->log(LOGNOTICE, "size_threshold set to $Size_threshold");
}
return $Size_threshold;
}
sub auth_user {
my ($self, $user) = @_;
$user =~ s/[\r\n].*//s;
$self->{_auth_user} = $user if $user;
return (defined $self->{_auth_user} ? $self->{_auth_user} : "" );
}
sub auth_mechanism {
my ($self, $mechanism) = @_;
$mechanism =~ s/[\r\n].*//s;
$self->{_auth_mechanism} = $mechanism if $mechanism;
return (defined $self->{_auth_mechanism} ? $self->{_auth_mechanism} : "" );
}
1;
__END__

200
lib/Qpsmtpd/Address.pm
View File

@ -1,16 +1,74 @@
#!/usr/bin/perl -w
package Qpsmtpd::Address;
use strict;
=head1 NAME
Qpsmtpd::Address - Lightweight E-Mail address objects
=head1 DESCRIPTION
Based originally on cut and paste from Mail::Address and including
every jot and tittle from RFC-2821/2822 on what is a legal e-mail
address for use during the SMTP transaction.
=head1 USAGE
my $rcpt = Qpsmtpd::Address->new('<email.address@example.com>');
The objects created can be used as is, since they automatically
stringify to a standard form, and they have an overloaded comparison
for easy testing of values.
=head1 METHODS
=cut
use overload (
'""' => \&format,
'cmp' => \&_addr_cmp,
);
=head2 new()
Can be called two ways:
=over 4
=item * Qpsmtpd::Address->new('<full_address@example.com>')
The normal mode of operation is to pass the entire contents of the
RCPT TO: command from the SMTP transaction. The value will be fully
parsed via the L<canonify> method, using the full RFC 2821 rules.
=item * Qpsmtpd::Address->new("user", "host")
If the caller has already split the address from the domain/host,
this mode will not L<canonify> the input values. This is not
recommended in cases of user-generated input for that reason. This
can be used to generate Qpsmtpd::Address objects for accounts like
"<postmaster>" or indeed for the bounce address "<>".
=back
The resulting objects can be stored in arrays or used in plugins to
test for equality (like in badmailfrom).
=cut
sub new {
my ($class, $address) = @_;
my $self = [ ];
if ($address =~ /^<(.*)>$/) {
$self->[0] = $1;
} else {
$self->[0] = $address;
my ($class, $user, $host) = @_;
my $self = {};
if ($user =~ /^<(.*)>$/ ) {
($user, $host) = $class->canonify($user)
}
bless ($self, $class);
return $self;
elsif ( not defined $host ) {
my $address = $user;
($user, $host) = $address =~ m/(.*)(?:\@(.*))/;
}
$self->{_user} = $user;
$self->{_host} = $host;
return bless $self, $class;
}
# Definition of an address ("path") from RFC 2821:
@ -110,6 +168,15 @@ sub new {
#
# (We ignore all obs forms)
=head2 canonify()
Primarily an internal method, it is used only on the path portion of
an e-mail message, as defined in RFC-2821 (this is the part inside the
angle brackets and does not include the "human readable" portion of an
address). It returns a list of (local-part, domain).
=cut
sub canonify {
my ($dummy, $path) = @_;
my $atom = '[a-zA-Z0-9!#\$\%\&\x27\*\+\x2D\/=\?\^_`{\|}~]+';
@ -131,60 +198,131 @@ sub canonify {
# empty path is ok
return "" if $path eq "";
#
# bare postmaster is permissible, perl RFC-2821 (4.5.1)
return ("postmaster", undef) if $path eq "postmaster";
my ($localpart, $domainpart) = ($path =~ /^(.*)\@($domain)$/);
return undef unless defined $localpart;
return (undef) unless defined $localpart;
if ($localpart =~ /^$atom(\.$atom)*/) {
# simple case, we are done
return $path;
return ($localpart, $domainpart);
}
if ($localpart =~ /^"(($qtext|\\$text)*)"$/) {
$localpart = $1;
$localpart =~ s/\\($text)/$1/g;
return "$localpart\@$domainpart";
return ($localpart, $domainpart);
}
return undef;
return (undef);
}
=head2 parse()
Retained as a compatibility method, it is completely equivalent
to new() called with a single parameter.
sub parse {
my ($class, $line) = @_;
my $a = $class->canonify($line);
return ($class->new($a)) if (defined $a);
return undef;
=cut
sub parse { # retain for compatibility only
return shift->new(shift);
}
=head2 address()
Can be used to reset the value of an existing Q::A object, in which
case it takes a parameter with or without the angle brackets.
Returns the stringified representation of the address. NOTE: does
not escape any of the characters that need escaping, nor does it
include the surrounding angle brackets. For that purpose, see
L<format>.
=cut
sub address {
my ($self, $val) = @_;
my $oldval = $self->[0];
return $self->[0] = $val if (defined($val));
return $oldval;
if ( defined($val) ) {
$val = "<$val>" unless $val =~ /^<.+>$/;
my ($user, $host) = $self->canonify($val);
$self->{_user} = $user;
$self->{_host} = $host;
}
return ( defined $self->{_user} ? $self->{_user} : '' )
. ( defined $self->{_host} ? '@'.$self->{_host} : '' );
}
=head2 format()
Returns the canonical stringified representation of the address. It
does escape any characters requiring it (per RFC-2821/2822) and it
does include the surrounding angle brackets. It is also the default
stringification operator, so the following are equivalent:
print $rcpt->format();
print $rcpt;
=cut
sub format {
my ($self) = @_;
my $qchar = '[^a-zA-Z0-9!#\$\%\&\x27\*\+\x2D\/=\?\^_`{\|}~.]';
my $s = $self->[0];
return '<>' unless $s;
my ($user, $host) = $s =~ m/(.*)\@(.*)/;
if ($user =~ s/($qchar)/\\$1/g) {
return qq{<"$user"\@$host>};
return '<>' unless defined $self->{_user};
if ( ( my $user = $self->{_user}) =~ s/($qchar)/\\$1/g) {
return qq(<"$user")
. ( defined $self->{_host} ? '@'.$self->{_host} : '' ). ">";
}
return "<$s>";
return "<".$self->address().">";
}
=head2 user()
Returns the "localpart" of the address, per RFC-2821, or the portion
before the '@' sign.
=cut
sub user {
my ($self) = @_;
my ($user, $host) = $self->[0] =~ m/(.*)\@(.*)/;
return $user;
return $self->{_user};
}
=head2 host()
Returns the "domain" part of the address, per RFC-2821, or the portion
after the '@' sign.
=cut
sub host {
my ($self) = @_;
my ($user, $host) = $self->[0] =~ m/(.*)\@(.*)/;
return $host;
return $self->{_host};
}
sub _addr_cmp {
require UNIVERSAL;
my ($left, $right, $swap) = @_;
my $class = ref($left);
unless ( UNIVERSAL::isa($right, $class) ) {
$right = $class->new($right);
}
#invert the address so we can sort by domain then user
$left = lc($left->host.'='.$left->user);
$right = lc($right->host.'='.$right->user);
if ( $swap ) {
($right, $left) = ($left, $right);
}
return ($left cmp $right);
}
=head1 COPYRIGHT
Copyright 2004-2005 Peter J. Holzer. See the LICENSE file for more
information.
=cut
1;

18
lib/Qpsmtpd/Auth.pm
View File

@ -226,19 +226,6 @@ sub e64
return($res);
}
sub Qpsmtpd::SMTP::auth {
my ( $self, $arg, @stuff ) = @_;
#they AUTH'd once already
return $self->respond( 503, "but you already said AUTH ..." )
if ( defined $self->{_auth}
and $self->{_auth} == OK );
return $self->respond( 503, "AUTH not defined for HELO" )
if ( $self->connection->hello eq "helo" );
return $self->{_auth} = Qpsmtpd::Auth::SASL( $self, $arg, @stuff );
}
sub SASL {
# $DB::single = 1;
@ -326,9 +313,8 @@ sub SASL {
$session->connection->relay_client(1);
$session->log( LOGINFO, $msg );
$session->{_auth_user} = $user;
$session->{_auth_mechanism} = $mechanism;
s/[\r\n].*//s for ($session->{_auth_user}, $session->{_auth_mechanism});
$session->auth_user($user);
$session->auth_mechanism($mechanism);
return OK;
}

12
lib/Qpsmtpd/Plugin.pm
View File

@ -37,9 +37,9 @@ sub _register {
my $self = shift;
my $qp = shift;
local $self->{_qp} = $qp;
$self->init($qp, @_);
$self->init($qp, @_) if $self->can('init');
$self->_register_standard_hooks($qp, @_);
$self->register($qp, @_);
$self->register($qp, @_) if $self->can('register');
}
# Designed to be overloaded
@ -73,6 +73,14 @@ sub spool_dir {
shift->qp->spool_dir;
}
sub auth_user {
shift->qp->auth_user(@_);
}
sub auth_mechanism {
shift->qp->auth_mechanism(@_);
}
sub temp_file {
my $self = shift;
my $tempfile = $self->qp->temp_file;

2
lib/Qpsmtpd/PollServer.pm
View File

@ -15,6 +15,8 @@ use fields qw(
hooks
start_time
_auth
_auth_user
_auth_mechanism
_commands
_config_cache
_connection

18
lib/Qpsmtpd/SMTP.pm
View File

@ -196,7 +196,9 @@ sub ehlo_respond {
$conn->hello_host($hello_host);
$self->transaction;
my @capabilities = @{ $self->transaction->notes('capabilities') };
my @capabilities = $self->transaction->notes('capabilities')
? @{ $self->transaction->notes('capabilities') }
: ();
# Check for possible AUTH mechanisms
my %auth_mechanisms;
@ -227,6 +229,19 @@ HOOK: foreach my $hook ( keys %{$self->{hooks}} ) {
}
}
sub auth {
my ( $self, $arg, @stuff ) = @_;
#they AUTH'd once already
return $self->respond( 503, "but you already said AUTH ..." )
if ( defined $self->{_auth}
and $self->{_auth} == OK );
return $self->respond( 503, "AUTH not defined for HELO" )
if ( $self->connection->hello eq "helo" );
return $self->{_auth} = Qpsmtpd::Auth::SASL( $self, $arg, @stuff );
}
sub mail {
my $self = shift;
return $self->respond(501, "syntax error in parameters") if !$_[0] or $_[0] !~ m/^from:/i;
@ -365,7 +380,6 @@ sub rcpt_respond {
return 0;
}
sub help {
my $self = shift;
$self->respond(214,

2
lib/Qpsmtpd/TcpServer.pm
View File

@ -39,7 +39,7 @@ sub run {
my $self = shift;
# should be somewhere in Qpsmtpd.pm and not here...
$self->load_plugins;
$self->load_plugins unless $self->{hooks};
my $rc = $self->start_conversation;
return if $rc != DONE;

36
lib/Qpsmtpd/Transaction.pm
View File

@ -15,9 +15,6 @@ sub start {
my %args = @_;
my $self = { _notes => { capabilities => [] }, _rcpt => [], started => time };
bless ($self, $class);
my $sz = $self->config('memory_threshold');
$sz = 10_000 unless defined($sz);
$self->{_size_threshold} = $sz;
return $self;
}
@ -91,13 +88,28 @@ sub body_current_pos {
return $self->{_body_current_pos} || 0;
}
# TODO - should we create the file here if we're storing as an array?
sub body_filename {
my $self = shift;
return unless $self->{_body_file};
$self->body_spool() unless $self->{_filename};
$self->{_body_file}->flush(); # so contents won't be cached
return $self->{_filename};
}
sub body_spool {
my $self = shift;
$self->log(LOGINFO, "spooling message to disk");
$self->{_filename} = $self->temp_file();
$self->{_body_file} = IO::File->new($self->{_filename}, O_RDWR|O_CREAT, 0600)
or die "Could not open file $self->{_filename} - $! "; # . $self->{_body_file}->error;
if ($self->{_body_array}) {
foreach my $line (@{ $self->{_body_array} }) {
$self->{_body_file}->print($line) or die "Cannot print to temp file: $!";
}
$self->{_body_start} = $self->{_header_size};
}
$self->{_body_array} = undef;
}
sub body_write {
my $self = shift;
my $data = shift;
@ -125,19 +137,7 @@ sub body_write {
$self->{_body_size} += length($1);
++$self->{_body_current_pos};
}
if ($self->{_body_size} >= $self->{_size_threshold}) {
#warn("spooling to disk\n");
$self->{_filename} = $self->temp_file();
$self->{_body_file} = IO::File->new($self->{_filename}, O_RDWR|O_CREAT, 0600)
or die "Could not open file $self->{_filename} - $! "; # . $self->{_body_file}->error;
if ($self->{_body_array}) {
foreach my $line (@{ $self->{_body_array} }) {
$self->{_body_file}->print($line) or die "Cannot print to temp file: $!";
}
$self->{_body_start} = $self->{_header_size};
}
$self->{_body_array} = undef;
}
$self->body_spool if ( $self->{_body_size} >= $self->size_threshold() );
}
}

28
plugins/dnsbl
View File

@ -2,13 +2,18 @@
use Danga::DNS;
sub register {
my ($self) = @_;
$self->register_hook("connect", "connect_handler");
$self->register_hook("connect", "pickup_handler");
sub init {
my ($self, $qp, $denial ) = @_;
if ( defined $denial and $denial =~ /^disconnect$/i ) {
$self->{_dnsbl}->{DENY} = DENY_DISCONNECT;
}
else {
$self->{_dnsbl}->{DENY} = DENY;
}
}
sub connect_handler {
sub hook_connect {
my ($self, $transaction) = @_;
my $remote_ip = $self->connection->remote_ip;
@ -99,8 +104,9 @@ sub process_txt_result {
# $qp->finish_continuation if $qp->input_sock->readable;
}
sub pickup_handler {
my ($self, $transaction) = @_;
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 '') {
@ -115,6 +121,14 @@ sub pickup_handler {
return DECLINED;
}
sub hook_disconnect {
my ($self, $transaction) = @_;
$self->qp->connection->notes('dnsbl_sockets', undef);
return DECLINED;
}
1;
=head1 NAME

138
plugins/queue/exim-bsmtp Normal file
View File

@ -0,0 +1,138 @@
=head1 NAME
exim-bsmtp
$Id$
=head1 DESCRIPTION
This plugin enqueues mail from qpsmtpd into Exim via BSMTP
=head1 INSTALLATION
The qpsmtpd user B<must> be configured in the I<trusted_users> setting
in your Exim configuration. If it is not, queueing will still work,
but sender addresses will not be honored by exim, which will make all
mail appear to originate from the smtpd user itself.
=head1 CONFIGURATION
The plugin accepts configuration settings in space-delimited name/value
pairs. For example:
queue/exim-bsmtp exim_path /usr/sbin/exim4
=over 4
=item exim_path I<path>
The path to use to execute the Exim BSMTP receiver; by default this is
I</usr/sbin/rsmtp>. The commandline switch '-bS' will be added (this is
actually redundant with rsmtp, but harmless).
=cut
=head1 LICENSE
Copyright (c) 2004 by Devin Carraway <qpsmtpd@devin.com>
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.
=cut
use strict;
use warnings;
use IO::File;
use Sys::Hostname qw(hostname);
use File::Temp qw(tempfile);
sub register {
my ($self, $qp, %args) = @_;
$self->{_exim_path} = $args{exim_path} || '/usr/sbin/rsmtp';
$self->{_exim_path} = $1 if $self->{_exim_path} =~ /(.*)/;
unless (-x $self->{_exim_path}) {
$self->log(LOGERROR, "Could not find exim at $self->{_exim_path};".
" please set exim_path in config/plugins");
return undef;
}
}
sub hook_queue {
my ($self, $txn) = @_;
my $tmp_dir = $self->qp->config('spool_dir') || '/tmp';
$tmp_dir = $1 if ($tmp_dir =~ /(.*)/);
my ($tmp, $tmpfn) = tempfile("exim-bsmtp.$$.XXXXXX", DIR => $tmp_dir);
unless ($tmp && $tmpfn) {
$self->log(LOGERROR, "Couldn't create tempfile: $!");
return (DECLINED, 'Internal error enqueueing mail');
}
print $tmp "HELO ", hostname(), "\n",
"MAIL FROM:<", ($txn->sender->address || ''), ">\n";
print $tmp "RCPT TO:<", ($_->address || ''), ">\n"
for $txn->recipients;
print $tmp "DATA\n",
$txn->header->as_string, "\n";
$txn->body_resetpos;
while (my $line = $txn->body_getline) {
$line =~ s/^\./../;
print $tmp $line;
}
print $tmp ".\nQUIT\n";
close $tmp;
my $cmd = "$self->{_exim_path} -bS < $tmpfn";
$self->log(LOGDEBUG, "executing cmd $cmd");
my $exim = new IO::File "$cmd|";
unless ($exim) {
$self->log(LOGERROR, "Could not execute $self->{_exim_path}: $!");
unlink $tmpfn or $self->log(LOGERROR, "unlink: $tmpfn: $!");
return (DECLINED, "Internal error enqueuing mail");
}
# Normally exim produces no output in BSMTP mode; anything that
# does come out is an error worth logging.
my $start = time;
while (<$exim>) {
chomp;
$self->log(LOGERROR, "exim: $_");
}
$self->log(LOGDEBUG, "BSMTP finished (".(time - $start)." sec)");
$exim->close;
my $exit = $?;
unlink $tmpfn or $self->log(LOGERROR, "unlink: $tmpfn: $!");
$self->log(LOGDEBUG, "Exitcode from exim: $exit");
if (($exit >> 8) != 0) {
$self->log(LOGERROR, 'BSMTP enqueue failed; exitcode '.($exit >> 8).
" from $self->{_exim_path} -bS");
return (DECLINED, 'Internal error enqueuing mail');
}
$self->log(LOGINFO, "Enqueued to exim via BSMTP");
return (OK, "Queued!");
}
1;
# vi: ts=4 sw=4 expandtab syn=perl

23
plugins/require_resolvable_fromhost
View File

@ -1,22 +1,29 @@
#!/usr/bin/perl
use Danga::DNS;
sub register {
my ($self) = @_;
$self->register_hook("mail", "mail_handler");
$self->register_hook("rcpt", "rcpt_handler");
my %invalid = ();
sub init {
my ($self, $qp) = @_;
foreach my $i ($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;
}
}
}
sub mail_handler {
sub hook_mail {
my ($self, $transaction, $sender) = @_;
return DECLINED
if ($self->qp->connection->notes('whitelistclient'));
$self->transaction->notes('resolvable', 1);
return DECLINED if $sender->format eq "<>";
return $self->check_dns($sender->host);
}
sub check_dns {
my ($self, $host) = @_;
@ -66,7 +73,7 @@ sub dns_result {
}
sub rcpt_handler {
sub hook_rcpt {
my ($self, $transaction) = @_;
if (!$transaction->notes('resolvable')) {

11
plugins/rhsbl
View File

@ -2,14 +2,7 @@
use Danga::DNS;
sub register {
my ($self) = @_;
$self->register_hook('mail', 'mail_handler');
$self->register_hook('rcpt', 'rcpt_handler');
}
sub mail_handler {
sub hook_mail {
my ($self, $transaction, $sender) = @_;
my %rhsbl_zones_map = ();
@ -59,7 +52,7 @@ sub process_result {
}
}
sub rcpt_handler {
sub hook_rcpt {
my ($self, $transaction, $rcpt) = @_;
my $result = $transaction->notes('rhsbl');

17
plugins/tls
View File

@ -39,6 +39,7 @@ sub init {
SSL_server => 1
) or die "Could not create SSL context: $!";
# now extract the password...
$self->ssl_context($ssl_ctx);
# Check for possible AUTH mechanisms
@ -104,10 +105,18 @@ sub hook_unrecognized_command {
my $conn = $self->connection;
# Create a new connection object with subset of information collected thus far
my $newconn = Qpsmtpd::Connection->new();
for (qw(local_ip local_port remote_ip remote_port remote_host remote_info relay_client)) {
$newconn->$_($conn->$_());
}
my $newconn = Qpsmtpd::Connection->new(
map { $_ => $conn->$_ }
qw(
local_ip
local_port
remote_ip
remote_port
remote_host
remote_info
relay_client
),
);
$self->qp->connection($newconn);
$self->qp->reset_transaction;
if ($self->qp->isa('Danga::Socket')) {

7
plugins/virus/clamdscan
View File

@ -118,7 +118,7 @@ sub hook_data_post {
unless ( $content_type
&& $content_type =~ m!\bmultipart/.*\bboundary="?([^"]+)!i )
{
$self->log( LOGERROR, "non-multipart mail - skipping" );
$self->log( LOGNOTICE, "non-multipart mail - skipping" );
return DECLINED;
}
@ -153,7 +153,10 @@ sub hook_data_post {
$clamd = Clamd->new(); # default unix domain socket
}
return (DENYSOFT) unless $clamd->ping();
unless ( $clamd->ping() ) {
$self->log( LOGERROR, "Cannot ping clamd server - did you provide the correct clamd port or socket?" );
return DECLINED;
}
if ( my %found = $clamd->scan($filename) ) {
my $viruses = join( ",", values(%found) );

3
qpsmtpd
View File

@ -24,9 +24,6 @@ use Getopt::Long;
$|++;
# For debugging
# $SIG{USR1} = sub { Carp::confess("USR1") };
use Socket qw(SOMAXCONN IPPROTO_TCP SO_KEEPALIVE TCP_NODELAY SOL_SOCKET);
$SIG{'PIPE'} = "IGNORE"; # handled manually

33
qpsmtpd-forkserver
View File

@ -39,7 +39,7 @@ usage: qpsmtpd-forkserver [ options ]
-u, --user U : run as a particular user (default 'smtpd')
-m, --max-from-ip M : limit connections from a single IP; default 5
--pid-file P : print main servers PID to file P
--detach : detach from controlling terminal (daemonize)
-d, --detach : detach from controlling terminal (daemonize)
EOT
exit 0;
}
@ -51,8 +51,8 @@ GetOptions('h|help' => \&usage,
'p|port=i' => \$PORT,
'u|user=s' => \$USER,
'pid-file=s' => \$PID_FILE,
'd|debug+' => \$DEBUG,
'detach' => \$DETACH,
'debug+' => \$DEBUG,
'd|detach' => \$DETACH,
) || &usage;
# detaint the commandline
@ -172,6 +172,10 @@ if ($PID_FILE) {
close PID;
}
# Populate class cached variables
$qpsmtpd->spool_dir;
$qpsmtpd->size_threshold;
while (1) {
REAPER();
my $running = scalar keys %childstatus;
@ -189,7 +193,6 @@ while (1) {
# possible something condition...
next;
}
# Make this client blocking while we figure out if we actually want to
# do something with it.
IO::Handle::blocking($client, 1);
@ -233,7 +236,17 @@ while (1) {
::log(LOGINFO, "Connection Timed Out");
exit; };
::log(LOGINFO, "Accepted connection $running/$MAXCONN");
my $localsockaddr = getsockname($client);
my ($lport, $laddr) = sockaddr_in($localsockaddr);
$ENV{TCPLOCALIP} = inet_ntoa($laddr);
# my ($port, $iaddr) = sockaddr_in($hisaddr);
$ENV{TCPREMOTEIP} = inet_ntoa($iaddr);
$ENV{TCPREMOTEHOST} = gethostbyaddr($iaddr, AF_INET) || "Unknown";
# don't do this!
#$0 = "qpsmtpd-forkserver: $ENV{TCPREMOTEIP} / $ENV{TCPREMOTEHOST}";
::log(LOGINFO, "Accepted connection $running/$MAXCONN from $ENV{TCPREMOTEIP} / $ENV{TCPREMOTEHOST}");
$::LineMode = 1;
@ -245,11 +258,11 @@ while (1) {
$qp->push_back_read("Connect\n");
Qpsmtpd::PollServer->AddTimer(0.1, sub { });
while (1) {
$qp->enable_read;
my $line = $qp->get_line;
last if !defined($line);
my $output = $qp->process_line($line);
$qp->write($output) if $output;
$qp->enable_read;
my $line = $qp->get_line;
last if !defined($line);
my $output = $qp->process_line($line);
$qp->write($output) if $output;
}
exit; # child leaves

47
t/qpsmtpd-address.t
View File

@ -2,7 +2,7 @@
use strict;
$^W = 1;
use Test::More tests => 28;
use Test::More tests => 29;
BEGIN {
use_ok('Qpsmtpd::Address');
@ -16,6 +16,11 @@ $ao = Qpsmtpd::Address->parse($as);
ok ($ao, "parse $as");
is ($ao->format, $as, "format $as");
$as = '<postmaster>';
$ao = Qpsmtpd::Address->parse($as);
ok ($ao, "parse $as");
is ($ao->format, $as, "format $as");
$as = '<foo@example.com>';
$ao = Qpsmtpd::Address->parse($as);
ok ($ao, "parse $as");
@ -38,21 +43,6 @@ $ao = Qpsmtpd::Address->parse($as);
ok ($ao, "parse $as");
is ($ao->format, '<"foo\ bar"@example.com>', "format $as");
$as = 'foo@example.com';
$ao = Qpsmtpd::Address->parse($as);
is ($ao, undef, "can't parse $as");
$as = '<@example.com>';
is (Qpsmtpd::Address->parse($as), undef, "can't parse $as");
$as = '<@123>';
is (Qpsmtpd::Address->parse($as), undef, "can't parse $as");
$as = '<user>';
is (Qpsmtpd::Address->parse($as), undef, "can't parse $as");
$as = 'foo@example.com';
$ao = Qpsmtpd::Address->new($as);
ok ($ao, "new $as");
@ -79,10 +69,35 @@ $as = '<foo@foo.x.example.com>';
$ao = Qpsmtpd::Address->new($as);
ok ($ao, "new $as");
is ($ao->format, $as, "format $as");
is ("$ao", $as, "overloaded stringify $as");
$as = 'foo@foo.x.example.com';
ok ($ao = Qpsmtpd::Address->parse("<$as>"), "parse <$as>");
is ($ao && $ao->address, $as, "address $as");
ok ($ao eq $as, "overloaded 'cmp' operator");
my @unsorted_list = map { Qpsmtpd::Address->new($_) }
qw(
"musa_ibrah@caramail.comandrea.luger"@wifo.ac.at
foo@example.com
ask@perl.org
foo@foo.x.example.com
jpeacock@cpan.org
test@example.com
);
# NOTE that this is sorted by _host_ not by _domain_
my @sorted_list = map { Qpsmtpd::Address->new($_) }
qw(
jpeacock@cpan.org
foo@example.com
test@example.com
foo@foo.x.example.com
ask@perl.org
"musa_ibrah@caramail.comandrea.luger"@wifo.ac.at
);
my @test_list = sort @unsorted_list;
is_deeply( \@test_list, \@sorted_list, "sort via overloaded 'cmp' operator");