merge from v010
git-svn-id: https://svn.perl.org/qpsmtpd/trunk@57 958fd67b-6ff1-0310-b445-bb7760255be9
This commit is contained in:
commit
5e93c4302a
@ -1 +1,2 @@
|
|||||||
supervise
|
supervise
|
||||||
|
tmp
|
||||||
|
47
Changes
47
Changes
@ -1,3 +1,50 @@
|
|||||||
|
|
||||||
|
v0.10
|
||||||
|
New object oriented internals
|
||||||
|
|
||||||
|
Very flexible plugin
|
||||||
|
|
||||||
|
All functionality not core to SMTP moved to plugins
|
||||||
|
|
||||||
|
Can accept mails as large as your file system will allow (instead of
|
||||||
|
up to as much memory you would allow qpsmtpd to eat).
|
||||||
|
|
||||||
|
2002/09/08
|
||||||
|
Add klez_filter plugin
|
||||||
|
|
||||||
|
Support more return codes for data_post
|
||||||
|
|
||||||
|
Document data_post
|
||||||
|
|
||||||
|
Add plugin name to the log entries when plugins use log()
|
||||||
|
|
||||||
|
Add plugin_name method to the default plugin object.
|
||||||
|
|
||||||
|
Improve error handling in the spamassassin plugin
|
||||||
|
|
||||||
|
|
||||||
|
2002/08/06
|
||||||
|
Spool message bodies to a tmp file so we can support HUGE messages
|
||||||
|
|
||||||
|
API to read the message body (undocumented, subject to change)
|
||||||
|
|
||||||
|
data_post hook (undocumented)
|
||||||
|
|
||||||
|
SpamAssassin plugin (connects to spamd on localhost), see
|
||||||
|
plugins/spamassassin
|
||||||
|
|
||||||
|
|
||||||
|
2002/07/15
|
||||||
|
DNS RBL and RHSBL support via plugins.
|
||||||
|
|
||||||
|
More hooks.
|
||||||
|
|
||||||
|
2002/07/03
|
||||||
|
First (non functional) version of the new object oriented mail engine (0.10).
|
||||||
|
|
||||||
|
|
||||||
|
Changes on the old v0.0x branch:
|
||||||
|
|
||||||
2002/05/09
|
2002/05/09
|
||||||
Klez filter (thanks to Robert Spier)
|
Klez filter (thanks to Robert Spier)
|
||||||
|
|
||||||
|
2
LICENSE
2
LICENSE
@ -1,4 +1,4 @@
|
|||||||
Copyright (c) 2001-2002 Ask Bjoern Hansen
|
Copyright (c) 2001-2002 Ask Bjoern Hansen, Develooper LLC
|
||||||
|
|
||||||
Permission is hereby granted, free of charge, to any person obtaining a copy of
|
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
|
this software and associated documentation files (the "Software"), to deal in
|
||||||
|
97
README
97
README
@ -1,3 +1,5 @@
|
|||||||
|
Qpsmtpd - qmail perl simple mail transfer protocol daemon
|
||||||
|
---------------------------------------------------------
|
||||||
|
|
||||||
web:
|
web:
|
||||||
http://develooper.com/code/qpsmtpd/
|
http://develooper.com/code/qpsmtpd/
|
||||||
@ -5,24 +7,89 @@ web:
|
|||||||
mailinglist:
|
mailinglist:
|
||||||
qpsmtpd-subscribe@perl.org
|
qpsmtpd-subscribe@perl.org
|
||||||
|
|
||||||
Problems:
|
|
||||||
First thing to try is to set $TRACE in qpsmtpd to some number higher
|
What is Qpsmtpd?
|
||||||
than 0 (higher gives more detail) and watch the log. If it doesn't
|
----------------
|
||||||
help you, or even if it does, please post to the maliinglist
|
|
||||||
(subscription instructions above). qpsmtpd is meant to be a drop-in
|
Qpsmtpd is an extensible smtp engine written in Perl. No, make that
|
||||||
replacement for qmail-smtpd, so it should be very easy to get going.
|
easily extensible! See plugins/quit_fortune for a very useful, er,
|
||||||
|
cute example.
|
||||||
|
|
||||||
|
|
||||||
Configuration files:
|
|
||||||
All configuration files goes into $DIR/config/ or /var/qmail/control/
|
|
||||||
|
|
||||||
qpsmtpd is supposed to support all the files that qmail-smtpd
|
What's new in version 0.10?
|
||||||
supports and use them in the same way. When you find that it is not
|
---------------------------
|
||||||
the case, feel free to send a patch to the mailinglist or to
|
|
||||||
|
Version 0.10 is all rearchitected, with an object oriented plugin
|
||||||
|
infrastructure. Weeh, that sounds fancy! Of course it is keeping the
|
||||||
|
well tested core code from version 0.0x which have had more than a
|
||||||
|
years production usage on many sites.
|
||||||
|
|
||||||
|
Noteworthy new features includes a SpamAssassin integration plugin,
|
||||||
|
more documentation and support for arbitrarily large messages without
|
||||||
|
exhausting memory (up to the size of whatever your file system
|
||||||
|
supports).
|
||||||
|
|
||||||
|
|
||||||
|
Installation
|
||||||
|
------------
|
||||||
|
|
||||||
|
Make a new user and a directory where you'll install qpsmtpd. I
|
||||||
|
usually use "smtpd" for the user and /home/smtpd/qpsmtpd/ for the
|
||||||
|
directory.
|
||||||
|
|
||||||
|
Put the files there. If you install from CVS you can just do
|
||||||
|
cvs -d :pserver:anonymous@cvs.perl.org:/cvs/public co qpsmtpd
|
||||||
|
in the /home/smtpd/ dir.
|
||||||
|
|
||||||
|
Now edit the file config/IP and put the ip address you want to use for
|
||||||
|
qpsmtpd on the first line (or use 0 to bind to all interfaces).
|
||||||
|
|
||||||
|
If you use the supervise tools, then you are practically done now!
|
||||||
|
Just symlink /home/smtpd/qpsmtpd into your /services (or /var/services
|
||||||
|
or /var/svscan or whatever) directory. Remember to shutdown
|
||||||
|
qmail-smtpd if you are replacing it with qpsmtpd.
|
||||||
|
|
||||||
|
If you don't use supervise, then you need to run the ./run script in
|
||||||
|
some other way when you startup.
|
||||||
|
|
||||||
|
|
||||||
|
Configuration
|
||||||
|
-------------
|
||||||
|
|
||||||
|
Configuration files can go into either /var/qmail/control or into the
|
||||||
|
config subdirectory of the qpsmtpd installation. Configuration should
|
||||||
|
be compatible with qmail-smtpd making qpsmtpd a drop-in replacement.
|
||||||
|
|
||||||
|
If there is anything missing, then please send a patch (or just
|
||||||
|
information about what's missing) to the mailinglist or to
|
||||||
ask@develooper.com.
|
ask@develooper.com.
|
||||||
|
|
||||||
|
|
||||||
|
Problems
|
||||||
|
--------
|
||||||
|
|
||||||
|
First, check the logfile. As default it goes into log/main/current.
|
||||||
|
Qpsmtpd can log a lot of debug information. You can get more or less
|
||||||
|
by adjusting $TRACE_LEVEL in lib/Qpsmtpd.pm (sorry, no easy switch for
|
||||||
|
that yet). Something between 1 and 3 should give you just a little
|
||||||
|
bit. If you set it to 10 or higher you will get lots of information
|
||||||
|
in the logs.
|
||||||
|
|
||||||
|
If the logfile doesn't give away the problem, then post to the
|
||||||
|
mailinglist (subscription instructions above). If possibly then put
|
||||||
|
the logfile on a webserver and include a reference to it in the mail.
|
||||||
|
|
||||||
|
|
||||||
Extra files you can use to configure qpsmtpd:
|
Extra files you can use to configure qpsmtpd:
|
||||||
|
|
||||||
|
plugins
|
||||||
|
|
||||||
|
List of plugins, one per line, to be loaded in the order they
|
||||||
|
appear in the file. Plugins are in the plugins directory (or in
|
||||||
|
a subdirectory of there).
|
||||||
|
|
||||||
|
|
||||||
rhsbl_zones
|
rhsbl_zones
|
||||||
|
|
||||||
Right hand side blocking lists, one per line. For example:
|
Right hand side blocking lists, one per line. For example:
|
||||||
@ -46,3 +113,11 @@ Configuration files:
|
|||||||
envelope senders will be checked against DNS. If an A or a MX
|
envelope senders will be checked against DNS. If an A or a MX
|
||||||
record can't be found the mail command will return a soft
|
record can't be found the mail command will return a soft
|
||||||
rejection (450).
|
rejection (450).
|
||||||
|
|
||||||
|
|
||||||
|
... everything (?) that qmail-smtpd supports.
|
||||||
|
|
||||||
|
In my test qpsmtpd installation I have a "config/me" file
|
||||||
|
containing the hostname I use for testing qpsmtpd (so it doesn't
|
||||||
|
introduce itself with the normal name of the server).
|
||||||
|
|
113
README.plugins
Normal file
113
README.plugins
Normal file
@ -0,0 +1,113 @@
|
|||||||
|
#
|
||||||
|
# read this with 'perldoc README.plugins' ...
|
||||||
|
#
|
||||||
|
|
||||||
|
=head1 qpsmtpd plugin system; developer documentation
|
||||||
|
|
||||||
|
See the examples in plugins/ and ask questions on the qpsmtpd
|
||||||
|
mailinglist; subscribe by sending mail to qpsmtpd-subscribe@perl.org.
|
||||||
|
|
||||||
|
=head1 General return codes
|
||||||
|
|
||||||
|
Each plugin must return an allowed constant for the hook and (usually)
|
||||||
|
optionally a "message".
|
||||||
|
|
||||||
|
Generally all plugins for a hook are processed until one returns
|
||||||
|
something other than "DECLINED".
|
||||||
|
|
||||||
|
Plugins are run in the order they are listed in the "plugins"
|
||||||
|
configuration.
|
||||||
|
|
||||||
|
=over 4
|
||||||
|
|
||||||
|
=item OK
|
||||||
|
|
||||||
|
Action allowed
|
||||||
|
|
||||||
|
=item DENY
|
||||||
|
|
||||||
|
Action denied
|
||||||
|
|
||||||
|
=item DENYSOFT
|
||||||
|
|
||||||
|
Action denied; return a temporary rejection code (say 450 instead of 550).
|
||||||
|
|
||||||
|
=item DECLINED
|
||||||
|
|
||||||
|
Plugin declined work; proceed as usual. This return code is _always_
|
||||||
|
_allowed_ unless noted otherwise.
|
||||||
|
|
||||||
|
=item DONE
|
||||||
|
|
||||||
|
Finishing processing of the request. Usually used when the plugin
|
||||||
|
sent the response to the client.
|
||||||
|
|
||||||
|
=back
|
||||||
|
|
||||||
|
See more detailed description for each hook below.
|
||||||
|
|
||||||
|
=head1 Hooks
|
||||||
|
|
||||||
|
=head2 mail
|
||||||
|
|
||||||
|
Called right after the envelope sender address is passed. The plugin
|
||||||
|
gets passed a Mail::Address object. Default is to allow the
|
||||||
|
recipient.
|
||||||
|
|
||||||
|
Allowed return codes
|
||||||
|
|
||||||
|
OK - sender allowed
|
||||||
|
DENY - Return a hard failure code
|
||||||
|
DENYSOFT - Return a soft failure code
|
||||||
|
DONE - skip further processing
|
||||||
|
|
||||||
|
|
||||||
|
=head2 rcpt
|
||||||
|
|
||||||
|
Hook for the "rcpt" command. Defaults to deny the mail with a soft
|
||||||
|
error code.
|
||||||
|
|
||||||
|
Allowed return codes
|
||||||
|
|
||||||
|
OK - recipient allowed
|
||||||
|
DENY - Return a hard failure code
|
||||||
|
DENYSOFT - Return a soft failure code
|
||||||
|
DONE - skip further processing
|
||||||
|
|
||||||
|
=head2 data_post
|
||||||
|
|
||||||
|
Hook after receiving all data; just before the message is queued.
|
||||||
|
|
||||||
|
DENY - Return a hard failure code
|
||||||
|
DENYSOFT - Return a soft failure code
|
||||||
|
DONE - skip further processing (message will not be queued)
|
||||||
|
|
||||||
|
All other codes and the message will be queued normally
|
||||||
|
|
||||||
|
|
||||||
|
=head2 connect
|
||||||
|
|
||||||
|
Allowed return codes:
|
||||||
|
|
||||||
|
OK - Stop processing plugins, give the default response
|
||||||
|
DECLINED - Process the next plugin
|
||||||
|
DONE - Stop processing plugins and don't give the default response
|
||||||
|
|
||||||
|
=head2 quit
|
||||||
|
|
||||||
|
Called on the "quit" command.
|
||||||
|
|
||||||
|
Allowed return codes:
|
||||||
|
|
||||||
|
DONE
|
||||||
|
|
||||||
|
Works like the "connect" hook.
|
||||||
|
|
||||||
|
|
||||||
|
=head2 disconnect
|
||||||
|
|
||||||
|
Called just before we shutdown a connection.
|
||||||
|
|
||||||
|
The return code is ignored. If a plugin returns anything but DECLINED
|
||||||
|
the following plugins will not be run (like with all other hooks).
|
||||||
|
|
37
STATUS
Normal file
37
STATUS
Normal file
@ -0,0 +1,37 @@
|
|||||||
|
|
||||||
|
Issues
|
||||||
|
======
|
||||||
|
|
||||||
|
transaction should maybe be a part of the connection object instead
|
||||||
|
of off the main object
|
||||||
|
|
||||||
|
plugin support;
|
||||||
|
|
||||||
|
support plugins for the rest of the commands.
|
||||||
|
|
||||||
|
specify a priority in register_hook. ("LAST", "FIRST", "MIDDLE", or
|
||||||
|
maybe a number)
|
||||||
|
|
||||||
|
plugin access to the data line by line during the DATA phase.
|
||||||
|
|
||||||
|
|
||||||
|
TRACE in Constants.pm is not actually being used. Should it be?
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
Future Ideas
|
||||||
|
============
|
||||||
|
|
||||||
|
Make config() better abstracted or configured (to allow configuration
|
||||||
|
from LDAP etc).
|
||||||
|
|
||||||
|
Make queue() better abstracted or configured (to allow LMTP delivery
|
||||||
|
instead of using qmail-queue).
|
||||||
|
|
||||||
|
Methods to create a bounce message easily; partly so we can accept a
|
||||||
|
mail for one user but bounce it right away for another RCPT'er.
|
||||||
|
|
||||||
|
David Carraway has some thoughts for "user filters"
|
||||||
|
http://nntp.perl.org/group/perl.qpsmtpd/2
|
||||||
|
|
||||||
|
Make it run as a mod_perl 2.0 connection handler module ...
|
4
config.sample/IP
Normal file
4
config.sample/IP
Normal file
@ -0,0 +1,4 @@
|
|||||||
|
0
|
||||||
|
# the first line of this file is being used as the IP
|
||||||
|
# address tcpserver will bind to. Use 0 to bind to all
|
||||||
|
# interfaces.
|
11
config.sample/plugins
Normal file
11
config.sample/plugins
Normal file
@ -0,0 +1,11 @@
|
|||||||
|
quit_fortune
|
||||||
|
require_resolvable_fromhost
|
||||||
|
rhsbl
|
||||||
|
dnsbl
|
||||||
|
|
||||||
|
# this plugin needs to run after all other "rcpt" plugins
|
||||||
|
check_relay
|
||||||
|
|
||||||
|
klez_filter
|
||||||
|
|
||||||
|
spamassassin
|
@ -2,3 +2,4 @@ dsn.rfc-ignorant.org does not accept bounces. This violates RFC 821/2505/2821 ht
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
536
lib/Qpsmtpd.pm
Normal file
536
lib/Qpsmtpd.pm
Normal file
@ -0,0 +1,536 @@
|
|||||||
|
package Qpsmtpd;
|
||||||
|
use strict;
|
||||||
|
use Carp;
|
||||||
|
|
||||||
|
use Qpsmtpd::Connection;
|
||||||
|
use Qpsmtpd::Transaction;
|
||||||
|
use Qpsmtpd::Constants;
|
||||||
|
use Qpsmtpd::Plugin;
|
||||||
|
|
||||||
|
use Mail::Address ();
|
||||||
|
use Mail::Header ();
|
||||||
|
use Sys::Hostname;
|
||||||
|
use IPC::Open2;
|
||||||
|
use Data::Dumper;
|
||||||
|
use POSIX qw(strftime);
|
||||||
|
BEGIN{$^W=0;}
|
||||||
|
use Net::DNS;
|
||||||
|
BEGIN{$^W=1;}
|
||||||
|
|
||||||
|
$Qpsmtpd::VERSION = "0.10";
|
||||||
|
my $TRACE_LEVEL = 6;
|
||||||
|
|
||||||
|
# $SIG{ALRM} = sub { respond(421, "Game over pal, game over. You got a timeout; I just can't wait that long..."); exit };
|
||||||
|
|
||||||
|
|
||||||
|
sub new {
|
||||||
|
my $proto = shift;
|
||||||
|
my $class = ref($proto) || $proto;
|
||||||
|
|
||||||
|
my %args = @_;
|
||||||
|
|
||||||
|
my $self = bless ({ args => \%args }, $class);
|
||||||
|
|
||||||
|
my (@commands) = qw(ehlo helo rset mail rcpt data help vrfy noop quit);
|
||||||
|
my (%commands); @commands{@commands} = ('') x @commands;
|
||||||
|
# this list of valid commands should probably be a method or a set of methods
|
||||||
|
$self->{_commands} = \%commands;
|
||||||
|
|
||||||
|
$self;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
#
|
||||||
|
# method to get the configuration. It just calls get_qmail_config by
|
||||||
|
# default, but it could be overwritten to look configuration up in a
|
||||||
|
# database or whatever.
|
||||||
|
#
|
||||||
|
sub config {
|
||||||
|
my ($self, $c) = @_;
|
||||||
|
|
||||||
|
my %defaults = (
|
||||||
|
me => hostname,
|
||||||
|
timeout => 1200,
|
||||||
|
);
|
||||||
|
|
||||||
|
if (wantarray) {
|
||||||
|
my @config = $self->get_qmail_config($c);
|
||||||
|
@config = @{$defaults{$c}} if (!@config and $defaults{$c});
|
||||||
|
return @config;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
return ($self->get_qmail_config($c) || $defaults{$c});
|
||||||
|
}
|
||||||
|
};
|
||||||
|
|
||||||
|
sub log {
|
||||||
|
my ($self, $trace, @log) = @_;
|
||||||
|
warn join(" ", $$, @log), "\n"
|
||||||
|
if $trace <= $TRACE_LEVEL;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub dispatch {
|
||||||
|
my $self = shift;
|
||||||
|
my ($cmd) = lc shift;
|
||||||
|
|
||||||
|
#$self->respond(553, $state{dnsbl_blocked}), return 1
|
||||||
|
# if $state{dnsbl_blocked} and ($cmd eq "rcpt");
|
||||||
|
|
||||||
|
$self->respond(500, "Unrecognized command"), return 1
|
||||||
|
if ($cmd !~ /^(\w{1,12})$/ or !exists $self->{_commands}->{$1});
|
||||||
|
$cmd = $1;
|
||||||
|
|
||||||
|
if (1 or $self->{_commands}->{$cmd} and $self->can($cmd)) {
|
||||||
|
my ($result) = eval { $self->$cmd(@_) };
|
||||||
|
$self->log(0, "XX: $@") if $@;
|
||||||
|
return $result if defined $result;
|
||||||
|
return $self->fault("command '$cmd' failed unexpectedly");
|
||||||
|
}
|
||||||
|
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub fault {
|
||||||
|
my $self = shift;
|
||||||
|
my ($msg) = shift || "program fault - command not performed";
|
||||||
|
print STDERR "$0[$$]: $msg ($!)\n";
|
||||||
|
return $self->respond(451, "Internal error - try again later - " . $msg);
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
sub start_conversation {
|
||||||
|
my $self = shift;
|
||||||
|
# this should maybe be called something else than "connect", see
|
||||||
|
# lib/Qpsmtpd/TcpServer.pm for more confusion.
|
||||||
|
my ($rc, $msg) = $self->run_hooks("connect");
|
||||||
|
if ($rc != DONE) {
|
||||||
|
$self->respond(220, $self->config('me') ." ESMTP qpsmtpd "
|
||||||
|
. $self->version ." ready; send us your mail, but not your spam.");
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
sub transaction {
|
||||||
|
my $self = shift;
|
||||||
|
use Data::Dumper;
|
||||||
|
#warn Data::Dumper->Dump([\$self], [qw(self)]);
|
||||||
|
return $self->{_transaction} || ($self->{_transaction} = Qpsmtpd::Transaction->new());
|
||||||
|
}
|
||||||
|
|
||||||
|
sub connection {
|
||||||
|
my $self = shift;
|
||||||
|
return $self->{_connection} || ($self->{_connection} = Qpsmtpd::Connection->new());
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
sub helo {
|
||||||
|
my ($self, $hello_host, @stuff) = @_;
|
||||||
|
my $conn = $self->connection;
|
||||||
|
return $self->respond (503, "but you already said HELO ...") if $conn->hello;
|
||||||
|
|
||||||
|
$conn->hello("helo");
|
||||||
|
$conn->hello_host($hello_host);
|
||||||
|
$self->transaction;
|
||||||
|
$self->respond(250, $self->config('me') ." Hi " . $conn->remote_info . " [" . $conn->remote_ip ."]; I am so happy to meet you.");
|
||||||
|
}
|
||||||
|
|
||||||
|
sub ehlo {
|
||||||
|
my ($self, $hello_host, @stuff) = @_;
|
||||||
|
my $conn = $self->connection;
|
||||||
|
return $self->respond (503, "but you already said HELO ...") if $conn->hello;
|
||||||
|
|
||||||
|
$conn->hello("ehlo");
|
||||||
|
$conn->hello_host($hello_host);
|
||||||
|
$self->transaction;
|
||||||
|
|
||||||
|
$self->respond(250,
|
||||||
|
$self->config("me") . " Hi " . $conn->remote_info . " [" . $conn->remote_ip ."]",
|
||||||
|
"PIPELINING",
|
||||||
|
"8BITMIME",
|
||||||
|
($self->config('databytes') ? "SIZE ". ($self->config('databytes'))[0] : ()),
|
||||||
|
);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub mail {
|
||||||
|
my $self = shift;
|
||||||
|
return $self->respond(501, "syntax error in parameters") if $_[0] !~ m/^from:/i;
|
||||||
|
unless ($self->connection->hello) {
|
||||||
|
return $self->respond(503, "please say hello first ...");
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
my $from_parameter = join " ", @_;
|
||||||
|
$self->log(2, "full from_parameter: $from_parameter");
|
||||||
|
my ($from) = ($from_parameter =~ m/^from:\s*(\S+)/i)[0];
|
||||||
|
#warn "$$ from email address : $from\n" if $TRACE;
|
||||||
|
if ($from eq "<>" or $from =~ m/\[undefined\]/) {
|
||||||
|
$from = Mail::Address->new("<>");
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$from = (Mail::Address->parse($from))[0];
|
||||||
|
}
|
||||||
|
return $self->respond(501, "could not parse your mail from command") unless $from;
|
||||||
|
|
||||||
|
my ($rc, $msg) = $self->run_hooks("mail", $from);
|
||||||
|
if ($rc == DONE) {
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
elsif ($rc == DENY) {
|
||||||
|
$msg ||= $from->format . ', denied';
|
||||||
|
$self->log(2, "deny mail from " . $from->format . " ($msg)");
|
||||||
|
$self->respond(550, $msg);
|
||||||
|
}
|
||||||
|
elsif ($rc == DENYSOFT) {
|
||||||
|
$msg ||= $from->format . ', temporarily denied';
|
||||||
|
$self->log(2, "denysoft mail from " . $from->format . " ($msg)");
|
||||||
|
$self->respond(450, $msg);
|
||||||
|
}
|
||||||
|
else { # includes OK
|
||||||
|
$self->log(2, "getting mail from ".$from->format);
|
||||||
|
$self->respond(250, $from->format . ", sender OK - how exciting to get mail from you!");
|
||||||
|
$self->transaction->sender($from);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
sub rcpt {
|
||||||
|
my $self = shift;
|
||||||
|
return $self->respond(501, "syntax error in parameters") unless $_[0] =~ m/^to:/i;
|
||||||
|
return(503, "Use MAIL before RCPT") unless $self->transaction->sender;
|
||||||
|
|
||||||
|
my ($rcpt) = ($_[0] =~ m/to:(.*)/i)[0];
|
||||||
|
$rcpt = $_[1] unless $rcpt;
|
||||||
|
$rcpt = (Mail::Address->parse($rcpt))[0];
|
||||||
|
return $self->respond(501, "could not parse recipient") unless $rcpt;
|
||||||
|
|
||||||
|
my ($rc, $msg) = $self->run_hooks("rcpt", $rcpt);
|
||||||
|
if ($rc == DONE) {
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
elsif ($rc == DENY) {
|
||||||
|
$msg ||= 'relaying denied';
|
||||||
|
$self->respond(550, $msg);
|
||||||
|
}
|
||||||
|
elsif ($rc == DENYSOFT) {
|
||||||
|
$msg ||= 'relaying denied';
|
||||||
|
return $self->respond(550, $msg);
|
||||||
|
}
|
||||||
|
elsif ($rc == OK) {
|
||||||
|
$self->respond(250, $rcpt->format . ", recipient ok");
|
||||||
|
return $self->transaction->add_recipient($rcpt);
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
return $self->respond(450, "Could not determine of relaying is allowed");
|
||||||
|
}
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
sub get_qmail_config {
|
||||||
|
my ($self, $config) = (shift, shift);
|
||||||
|
$self->log(5, "trying to get config for $config");
|
||||||
|
if ($self->{_config_cache}->{$config}) {
|
||||||
|
return wantarray ? @{$self->{_config_cache}->{$config}} : $self->{_config_cache}->{$config}->[0];
|
||||||
|
}
|
||||||
|
my $configdir = '/var/qmail/control';
|
||||||
|
my ($name) = ($0 =~ m!(.*?)/([^/]+)$!);
|
||||||
|
$configdir = "$name/config" if (-e "$name/config/$config");
|
||||||
|
open CF, "<$configdir/$config" or warn "$$ could not open configfile $config: $!", return;
|
||||||
|
my @config = <CF>;
|
||||||
|
chomp @config;
|
||||||
|
@config = grep { $_ and $_ !~ m/^\s*#/ and $_ =~ m/\S/} @config;
|
||||||
|
close CF;
|
||||||
|
$self->log(5, "returning get_config for $config ",Data::Dumper->Dump([\@config], [qw(config)]));
|
||||||
|
$self->{_config_cache}->{$config} = \@config;
|
||||||
|
return wantarray ? @config : $config[0];
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
sub help {
|
||||||
|
my $self = shift;
|
||||||
|
$self->respond(214,
|
||||||
|
"This is qpsmtpd " . $self->version,
|
||||||
|
"See http://develooper.com/code/qpsmtpd/",
|
||||||
|
'To report bugs or send comments, mail to <ask@perl.org>.');
|
||||||
|
}
|
||||||
|
|
||||||
|
sub version {
|
||||||
|
$Qpsmtpd::VERSION;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub noop {
|
||||||
|
my $self = shift;
|
||||||
|
warn Data::Dumper->Dump([\$self], [qw(self)]);
|
||||||
|
$self->respond(250, "OK");
|
||||||
|
|
||||||
|
}
|
||||||
|
|
||||||
|
sub vrfy {
|
||||||
|
shift->respond(252, "Just try sending a mail and we'll see how it turns out ...");
|
||||||
|
}
|
||||||
|
|
||||||
|
sub rset {
|
||||||
|
my $self = shift;
|
||||||
|
$self->{_transaction} = undef;
|
||||||
|
$self->transaction->start();
|
||||||
|
$self->respond(250, "OK");
|
||||||
|
}
|
||||||
|
|
||||||
|
sub quit {
|
||||||
|
my $self = shift;
|
||||||
|
my ($rc, $msg) = $self->run_hooks("quit");
|
||||||
|
if ($rc != DONE) {
|
||||||
|
$self->respond(221, $self->config('me') . " closing connection. Have a wonderful day.");
|
||||||
|
}
|
||||||
|
$self->disconnect();
|
||||||
|
}
|
||||||
|
|
||||||
|
sub disconnect {
|
||||||
|
my $self = shift;
|
||||||
|
$self->run_hooks("disconnect");
|
||||||
|
}
|
||||||
|
|
||||||
|
sub data {
|
||||||
|
my $self = shift;
|
||||||
|
$self->respond(503, "MAIL first"), return 1 unless $self->transaction->sender;
|
||||||
|
$self->respond(503, "RCPT first"), return 1 unless $self->transaction->recipients;
|
||||||
|
$self->respond(354, "go ahead");
|
||||||
|
my $buffer = '';
|
||||||
|
my $size = 0;
|
||||||
|
my $i = 0;
|
||||||
|
my $max_size = ($self->config('databytes'))[0] || 0; # this should work in scalar context
|
||||||
|
my $blocked = "";
|
||||||
|
my %matches;
|
||||||
|
my $in_header = 1;
|
||||||
|
my $complete = 0;
|
||||||
|
|
||||||
|
$self->log(6, "max_size: $max_size / size: $size");
|
||||||
|
|
||||||
|
my $header = Mail::Header->new(Modify => 0, MailFrom => "COERCE");
|
||||||
|
|
||||||
|
my $timeout = $self->config('timeout');
|
||||||
|
|
||||||
|
while (<STDIN>) {
|
||||||
|
$complete++, last if $_ eq ".\r\n";
|
||||||
|
$i++;
|
||||||
|
$self->respond(451, "See http://develooper.com/code/qpsmtpd/barelf.html"), exit
|
||||||
|
if $_ eq ".\n";
|
||||||
|
# add a transaction->blocked check back here when we have line by line plugin access...
|
||||||
|
unless (($max_size and $size > $max_size)) {
|
||||||
|
s/\r\n$/\n/;
|
||||||
|
if ($in_header and m/^\s*$/) {
|
||||||
|
$in_header = 0;
|
||||||
|
my @header = split /\n/, $buffer;
|
||||||
|
|
||||||
|
# ... 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.
|
||||||
|
|
||||||
|
$header->extract(\@header);
|
||||||
|
$buffer = "";
|
||||||
|
|
||||||
|
# FIXME - call plugins to work on just the header here; can
|
||||||
|
# save us buffering the mail content.
|
||||||
|
|
||||||
|
}
|
||||||
|
|
||||||
|
if ($in_header) {
|
||||||
|
$buffer .= $_;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$self->transaction->body_write($_);
|
||||||
|
}
|
||||||
|
|
||||||
|
$size += length $_;
|
||||||
|
}
|
||||||
|
#$self->log(5, "size is at $size\n") unless ($i % 300);
|
||||||
|
|
||||||
|
alarm $timeout;
|
||||||
|
}
|
||||||
|
|
||||||
|
$self->log(6, "max_size: $max_size / size: $size");
|
||||||
|
|
||||||
|
$self->transaction->header($header);
|
||||||
|
|
||||||
|
$header->add("Received", "from ".$self->connection->remote_info
|
||||||
|
." (HELO ".$self->connection->hello_host . ") (".$self->connection->remote_ip
|
||||||
|
. ") by ".$self->config('me')." (qpsmtpd/".$self->version
|
||||||
|
.") with SMTP; ". (strftime('%Y-%m-%d %TZ', gmtime)),
|
||||||
|
0);
|
||||||
|
|
||||||
|
# if we get here without seeing a terminator, the connection is
|
||||||
|
# probably dead.
|
||||||
|
$self->respond(451, "Incomplete DATA"), return 1 unless $complete;
|
||||||
|
|
||||||
|
#$self->respond(550, $self->transaction->blocked),return 1 if ($self->transaction->blocked);
|
||||||
|
$self->respond(552, "Message too big!"),return 1 if $max_size and $size > $max_size;
|
||||||
|
|
||||||
|
my ($rc, $msg) = $self->run_hooks("data_post");
|
||||||
|
if ($rc == DONE) {
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
elsif ($rc == DENY) {
|
||||||
|
$self->respond(552, $msg || "Message denied");
|
||||||
|
}
|
||||||
|
elsif ($rc == DENYSOFT) {
|
||||||
|
$self->respond(452, $msg || "Message denied temporarily");
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
return $self->queue($self->transaction);
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
}
|
||||||
|
|
||||||
|
sub queue {
|
||||||
|
my ($self, $transaction) = @_;
|
||||||
|
|
||||||
|
# these bits inspired by Peter Samuels "qmail-queue wrapper"
|
||||||
|
pipe(MESSAGE_READER, MESSAGE_WRITER) or fault("Could not create message pipe"), exit;
|
||||||
|
pipe(ENVELOPE_READER, ENVELOPE_WRITER) or fault("Could not create envelope pipe"), exit;
|
||||||
|
|
||||||
|
my $child = fork();
|
||||||
|
|
||||||
|
not defined $child and fault(451, "Could not fork"), exit;
|
||||||
|
|
||||||
|
if ($child) {
|
||||||
|
# Parent
|
||||||
|
my $oldfh = select(MESSAGE_WRITER); $| = 1;
|
||||||
|
select(ENVELOPE_WRITER); $| = 1;
|
||||||
|
select($oldfh);
|
||||||
|
|
||||||
|
close MESSAGE_READER or fault("close msg reader fault"),exit;
|
||||||
|
close ENVELOPE_READER or fault("close envelope reader fault"), exit;
|
||||||
|
|
||||||
|
$transaction->header->add("X-SMTPD", "qpsmtpd/".$self->version.", http://develooper.com/code/qpsmtpd/");
|
||||||
|
|
||||||
|
$transaction->header->print(\*MESSAGE_WRITER);
|
||||||
|
$transaction->body_resetpos;
|
||||||
|
while (my $line = $transaction->body_getline) {
|
||||||
|
print MESSAGE_WRITER $line;
|
||||||
|
}
|
||||||
|
close MESSAGE_WRITER;
|
||||||
|
|
||||||
|
my @rcpt = map { "T" . $_->address } $transaction->recipients;
|
||||||
|
my $from = "F".($transaction->sender->address|| "" );
|
||||||
|
print ENVELOPE_WRITER "$from\0", join("\0",@rcpt), "\0\0"
|
||||||
|
or respond(451,"Could not print addresses to queue"),exit;
|
||||||
|
|
||||||
|
close ENVELOPE_WRITER;
|
||||||
|
waitpid($child, 0);
|
||||||
|
my $exit_code = $? >> 8;
|
||||||
|
$exit_code and respond(451, "Unable to queue message ($exit_code)"), exit;
|
||||||
|
$self->respond(250, "Queued.");
|
||||||
|
}
|
||||||
|
elsif (defined $child) {
|
||||||
|
# Child
|
||||||
|
close MESSAGE_WRITER or die "could not close message writer in parent";
|
||||||
|
close ENVELOPE_WRITER or die "could not close envelope writer in parent";
|
||||||
|
|
||||||
|
open(STDIN, "<&MESSAGE_READER") or die "b1";
|
||||||
|
open(STDOUT, "<&ENVELOPE_READER") or die "b2";
|
||||||
|
|
||||||
|
unless (exec '/var/qmail/bin/qmail-queue') {
|
||||||
|
die "should never be here!";
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
sub load_plugins {
|
||||||
|
my $self = shift;
|
||||||
|
my @plugins = $self->config('plugins');
|
||||||
|
|
||||||
|
my ($name) = ($0 =~ m!(.*?)/([^/]+)$!);
|
||||||
|
my $dir = "$name/plugins";
|
||||||
|
$self->log(2, "loading plugins from $dir");
|
||||||
|
|
||||||
|
for my $plugin (@plugins) {
|
||||||
|
$self->log(3, "Loading $plugin");
|
||||||
|
my $plugin_name = $plugin;
|
||||||
|
# Escape everything into valid perl identifiers
|
||||||
|
$plugin_name =~ s/([^A-Za-z0-9_\/])/sprintf("_%2x",unpack("C",$1))/eg;
|
||||||
|
|
||||||
|
# second pass cares for slashes and words starting with a digit
|
||||||
|
$plugin_name =~ s{
|
||||||
|
(/+) # directory
|
||||||
|
(\d?) # package's first character
|
||||||
|
}[
|
||||||
|
"::" . (length $2 ? sprintf("_%2x",unpack("C",$2)) : "")
|
||||||
|
]egx;
|
||||||
|
|
||||||
|
|
||||||
|
my $sub;
|
||||||
|
open F, "$dir/$plugin" or die "could not open $dir/$plugin: $!";
|
||||||
|
{
|
||||||
|
local $/ = undef;
|
||||||
|
$sub = <F>;
|
||||||
|
}
|
||||||
|
close F;
|
||||||
|
|
||||||
|
my $package = "Qpsmtpd::Plugin::$plugin_name";
|
||||||
|
|
||||||
|
my $line = "\n#line 1 $dir/$plugin\n";
|
||||||
|
|
||||||
|
my $eval = join(
|
||||||
|
"\n",
|
||||||
|
"package $package;",
|
||||||
|
'use Qpsmtpd::Constants;',
|
||||||
|
"require Qpsmtpd::Plugin;",
|
||||||
|
'use vars qw(@ISA);',
|
||||||
|
'@ISA = qw(Qpsmtpd::Plugin);',
|
||||||
|
"sub plugin_name { qq[$plugin_name] }",
|
||||||
|
$line,
|
||||||
|
$sub,
|
||||||
|
"\n", # last line comment without newline?
|
||||||
|
);
|
||||||
|
|
||||||
|
#warn "eval: $eval";
|
||||||
|
|
||||||
|
$eval =~ m/(.*)/s;
|
||||||
|
$eval = $1;
|
||||||
|
|
||||||
|
eval $eval;
|
||||||
|
die "eval $@" if $@;
|
||||||
|
|
||||||
|
my $plug = $package->new(qpsmtpd => $self);
|
||||||
|
$plug->register($self);
|
||||||
|
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
sub run_hooks {
|
||||||
|
my ($self, $hook) = (shift, shift);
|
||||||
|
if ($self->{_hooks}->{$hook}) {
|
||||||
|
my @r;
|
||||||
|
for my $code (@{$self->{_hooks}->{$hook}}) {
|
||||||
|
eval { (@r) = &{$code}($self->transaction, @_); };
|
||||||
|
$@ and $self->log(0, "FATAL PLUGIN ERROR: ", $@) and next;
|
||||||
|
$self->log(1, "a $hook hook returned undef!") and next unless defined $r[0];
|
||||||
|
last unless $r[0] == DECLINED;
|
||||||
|
}
|
||||||
|
return @r;
|
||||||
|
}
|
||||||
|
warn "Did not run any hooks ...";
|
||||||
|
return (0, '');
|
||||||
|
}
|
||||||
|
|
||||||
|
sub _register_hook {
|
||||||
|
my $self = shift;
|
||||||
|
my ($hook, $code) = @_;
|
||||||
|
|
||||||
|
#my $plugin = shift; # see comment in Plugin.pm:register_hook
|
||||||
|
|
||||||
|
$self->{_hooks} ||= {};
|
||||||
|
my $hooks = $self->{_hooks};
|
||||||
|
push @{$hooks->{$hook}}, $code;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
1;
|
55
lib/Qpsmtpd/Connection.pm
Normal file
55
lib/Qpsmtpd/Connection.pm
Normal file
@ -0,0 +1,55 @@
|
|||||||
|
package Qpsmtpd::Connection;
|
||||||
|
use strict;
|
||||||
|
|
||||||
|
sub new {
|
||||||
|
my $proto = shift;
|
||||||
|
my $class = ref($proto) || $proto;
|
||||||
|
my $self = {};
|
||||||
|
bless ($self, $class);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub start {
|
||||||
|
my $self = shift;
|
||||||
|
$self = $self->new(@_) unless ref $self;
|
||||||
|
|
||||||
|
my %args = @_;
|
||||||
|
|
||||||
|
for my $f (qw(remote_host remote_ip remote_info)) {
|
||||||
|
$self->$f($args{$f}) if $args{$f};
|
||||||
|
}
|
||||||
|
|
||||||
|
return $self;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub remote_host {
|
||||||
|
my $self = shift;
|
||||||
|
@_ and $self->{_remote_host} = shift;
|
||||||
|
$self->{_remote_host};
|
||||||
|
}
|
||||||
|
|
||||||
|
sub remote_ip {
|
||||||
|
my $self = shift;
|
||||||
|
@_ and $self->{_remote_ip} = shift;
|
||||||
|
$self->{_remote_ip};
|
||||||
|
}
|
||||||
|
|
||||||
|
sub remote_info {
|
||||||
|
my $self = shift;
|
||||||
|
@_ and $self->{_remote_info} = shift;
|
||||||
|
$self->{_remote_info};
|
||||||
|
}
|
||||||
|
|
||||||
|
sub hello {
|
||||||
|
my $self = shift;
|
||||||
|
@_ and $self->{_hello} = shift;
|
||||||
|
$self->{_hello};
|
||||||
|
}
|
||||||
|
|
||||||
|
sub hello_host {
|
||||||
|
my $self = shift;
|
||||||
|
@_ and $self->{_hello_host} = shift;
|
||||||
|
$self->{_hello_host};
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
1;
|
30
lib/Qpsmtpd/Constants.pm
Normal file
30
lib/Qpsmtpd/Constants.pm
Normal file
@ -0,0 +1,30 @@
|
|||||||
|
package Qpsmtpd::Constants;
|
||||||
|
use strict;
|
||||||
|
require Exporter;
|
||||||
|
|
||||||
|
my (@common) = qw(OK DECLINED DONE DENY DENYSOFT TRACE);
|
||||||
|
|
||||||
|
use vars qw($VERSION @ISA @EXPORT);
|
||||||
|
@ISA = qw(Exporter);
|
||||||
|
@EXPORT = @common;
|
||||||
|
|
||||||
|
use constant TRACE => 10;
|
||||||
|
|
||||||
|
use constant OK => 900;
|
||||||
|
use constant DENY => 901;
|
||||||
|
use constant DENYSOFT => 902;
|
||||||
|
use constant DECLINED => 909;
|
||||||
|
use constant DONE => 910;
|
||||||
|
|
||||||
|
|
||||||
|
1;
|
||||||
|
|
||||||
|
|
||||||
|
=head1 NAME
|
||||||
|
|
||||||
|
Qpsmtpd::Constants - Constants should be defined here
|
||||||
|
|
||||||
|
=head1 SYNOPSIS
|
||||||
|
|
||||||
|
Not sure if we are going to use this...
|
||||||
|
|
32
lib/Qpsmtpd/Plugin.pm
Normal file
32
lib/Qpsmtpd/Plugin.pm
Normal file
@ -0,0 +1,32 @@
|
|||||||
|
package Qpsmtpd::Plugin;
|
||||||
|
use strict;
|
||||||
|
|
||||||
|
sub new {
|
||||||
|
my $proto = shift;
|
||||||
|
my $class = ref($proto) || $proto;
|
||||||
|
my %args = @_;
|
||||||
|
bless ({ _qp => $args{qpsmtpd} }, $class);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub register_hook {
|
||||||
|
my ($plugin, $hook, $method) = @_;
|
||||||
|
# I can't quite decide if it's better to parse this code ref or if
|
||||||
|
# we should pass the plugin object and method name ... hmn.
|
||||||
|
$plugin->qp->_register_hook($hook, sub { $plugin->$method(@_) });
|
||||||
|
}
|
||||||
|
|
||||||
|
sub qp {
|
||||||
|
shift->{_qp};
|
||||||
|
}
|
||||||
|
|
||||||
|
sub log {
|
||||||
|
my $self = shift;
|
||||||
|
$self->qp->log(shift, $self->plugin_name . " plugin: " . shift, @_);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub transaction {
|
||||||
|
# not sure if this will work in a non-forking or a threaded daemon
|
||||||
|
shift->qp->transaction;
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
64
lib/Qpsmtpd/TcpServer.pm
Normal file
64
lib/Qpsmtpd/TcpServer.pm
Normal file
@ -0,0 +1,64 @@
|
|||||||
|
package Qpsmtpd::TcpServer;
|
||||||
|
use strict;
|
||||||
|
use base qw(Qpsmtpd);
|
||||||
|
|
||||||
|
sub start_connection {
|
||||||
|
my $self = shift;
|
||||||
|
|
||||||
|
die "Qpsmtpd::TcpServer must be started by tcpserver\n"
|
||||||
|
unless $ENV{TCPREMOTEIP};
|
||||||
|
|
||||||
|
my $remote_host = $ENV{TCPREMOTEHOST} || ( $ENV{TCPREMOTEIP} ? "[$ENV{TCPREMOTEIP}]" : "[noip!]");
|
||||||
|
my $remote_info = $ENV{TCPREMOTEINFO} ? "$ENV{TCPREMOTEINFO}\@$remote_host" : $remote_host;
|
||||||
|
my $remote_ip = $ENV{TCPREMOTEIP};
|
||||||
|
|
||||||
|
$self->SUPER::connection->start(remote_info => $remote_info,
|
||||||
|
remote_ip => $remote_ip,
|
||||||
|
remote_host => $remote_host,
|
||||||
|
@_);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub run {
|
||||||
|
my $self = shift;
|
||||||
|
|
||||||
|
# should be somewhere in Qpsmtpd.pm and not here...
|
||||||
|
$self->load_plugins;
|
||||||
|
|
||||||
|
$self->start_conversation;
|
||||||
|
|
||||||
|
# this should really be the loop and read_input should just get one line; I think
|
||||||
|
|
||||||
|
$self->read_input;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub read_input {
|
||||||
|
my $self = shift;
|
||||||
|
my $timeout = $self->config('timeout');
|
||||||
|
alarm $timeout;
|
||||||
|
while (<STDIN>) {
|
||||||
|
alarm 0;
|
||||||
|
$_ =~ s/\r?\n$//s; # advanced chomp
|
||||||
|
$self->log(1, "dispatching $_");
|
||||||
|
defined $self->dispatch(split / +/, $_)
|
||||||
|
or $self->respond(502, "command unrecognized: '$_'");
|
||||||
|
alarm $timeout;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
sub respond {
|
||||||
|
my ($self, $code, @messages) = @_;
|
||||||
|
while (my $msg = shift @messages) {
|
||||||
|
my $line = $code . (@messages?"-":" ").$msg;
|
||||||
|
$self->log(1, "$line");
|
||||||
|
print "$line\r\n" or ($self->log("Could not print [$line]: $!"), return 0);
|
||||||
|
}
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub disconnect {
|
||||||
|
my $self = shift;
|
||||||
|
$self->SUPER::disconnect(@_);
|
||||||
|
exit;
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
115
lib/Qpsmtpd/Transaction.pm
Normal file
115
lib/Qpsmtpd/Transaction.pm
Normal file
@ -0,0 +1,115 @@
|
|||||||
|
package Qpsmtpd::Transaction;
|
||||||
|
use strict;
|
||||||
|
#use Carp qw(carp);
|
||||||
|
use IO::File qw(O_RDWR O_CREAT);
|
||||||
|
|
||||||
|
# For unique filenames. We write to a local tmp dir so we don't need
|
||||||
|
# to make them unpredictable.
|
||||||
|
my $transaction_counter = 0;
|
||||||
|
|
||||||
|
sub new { start(@_) }
|
||||||
|
|
||||||
|
sub start {
|
||||||
|
my $proto = shift;
|
||||||
|
my $class = ref($proto) || $proto;
|
||||||
|
my %args = @_;
|
||||||
|
my $self = { _rcpt => [], started => time };
|
||||||
|
bless ($self, $class);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub add_recipient {
|
||||||
|
my $self = shift;
|
||||||
|
@_ and push @{$self->{_recipients}}, shift;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub recipients {
|
||||||
|
my $self = shift;
|
||||||
|
($self->{_recipients} ? @{$self->{_recipients}} : ());
|
||||||
|
}
|
||||||
|
|
||||||
|
sub sender {
|
||||||
|
my $self = shift;
|
||||||
|
@_ and $self->{_sender} = shift;
|
||||||
|
$self->{_sender};
|
||||||
|
}
|
||||||
|
|
||||||
|
sub header {
|
||||||
|
my $self = shift;
|
||||||
|
@_ and $self->{_header} = shift;
|
||||||
|
$self->{_header};
|
||||||
|
}
|
||||||
|
|
||||||
|
# blocked() will return when we actually can do something useful with it...
|
||||||
|
#sub blocked {
|
||||||
|
# my $self = shift;
|
||||||
|
# carp 'Use of transaction->blocked is deprecated;'
|
||||||
|
# . 'tell ask@develooper.com if you have a reason to use it';
|
||||||
|
# @_ and $self->{_blocked} = shift;
|
||||||
|
# $self->{_blocked};
|
||||||
|
#}
|
||||||
|
|
||||||
|
sub notes {
|
||||||
|
my $self = shift;
|
||||||
|
my $key = shift;
|
||||||
|
@_ and $self->{_notes}->{$key} = shift;
|
||||||
|
$self->{_notes}->{$key};
|
||||||
|
}
|
||||||
|
|
||||||
|
sub add_header_line {
|
||||||
|
my $self = shift;
|
||||||
|
$self->{_header} .= shift;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub body_write {
|
||||||
|
my $self = shift;
|
||||||
|
my $data = shift;
|
||||||
|
unless ($self->{_body_file}) {
|
||||||
|
-d "tmp" or mkdir("tmp", 0700) or die "Could not create dir tmp: $!";
|
||||||
|
$self->{_filename} = "/home/smtpd/qpsmtpd/tmp/" . join(":", time, $$, $transaction_counter++);
|
||||||
|
$self->{_body_file} = IO::File->new($self->{_filename}, O_RDWR|O_CREAT)
|
||||||
|
or die "Could not open file $self->{_filename} - $! "; # . $self->{_body_file}->error;
|
||||||
|
}
|
||||||
|
# go to the end of the file
|
||||||
|
seek($self->{_body_file},0,2)
|
||||||
|
unless $self->{_body_file_writing};
|
||||||
|
$self->{_body_file_writing} = 1;
|
||||||
|
$self->{_body_file}->print(ref $data eq "SCALAR" ? $$data : $data)
|
||||||
|
and $self->{_body_size} += length (ref $data eq "SCALAR" ? $$data : $data);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub body_size {
|
||||||
|
shift->{_body_size} || 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub body_resetpos {
|
||||||
|
my $self = shift;
|
||||||
|
return unless $self->{_body_file};
|
||||||
|
seek($self->{_body_file}, 0,0);
|
||||||
|
$self->{_body_file_writing} = 0;
|
||||||
|
1;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub body_getline {
|
||||||
|
my $self = shift;
|
||||||
|
return unless $self->{_body_file};
|
||||||
|
seek($self->{_body_file}, 0,0)
|
||||||
|
if $self->{_body_file_writing};
|
||||||
|
$self->{_body_file_writing} = 0;
|
||||||
|
my $line = $self->{_body_file}->getline;
|
||||||
|
return $line;
|
||||||
|
|
||||||
|
}
|
||||||
|
|
||||||
|
sub DESTROY {
|
||||||
|
my $self = shift;
|
||||||
|
# would we save some disk flushing if we unlinked the file before
|
||||||
|
# closing it?
|
||||||
|
|
||||||
|
undef $self->{_body_file} if $self->{_body_file};
|
||||||
|
if ($self->{_filename} and -e $self->{_filename}) {
|
||||||
|
unlink $self->{_filename} or $self->log(0, "Could not unlink ", $self->{_filename}, ": $!");
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
1;
|
@ -1 +1,2 @@
|
|||||||
|
main
|
||||||
supervise
|
supervise
|
||||||
|
5
log/run
5
log/run
@ -1,2 +1,5 @@
|
|||||||
#! /bin/sh
|
#! /bin/sh
|
||||||
exec multilog t s1000000 n20 /var/log/qmail/qpsmtpd
|
export LOGDIR=./main
|
||||||
|
mkdir $LOGDIR
|
||||||
|
exec multilog t s1000000 n20 $LOGDIR
|
||||||
|
|
||||||
|
23
plugins/check_relay
Normal file
23
plugins/check_relay
Normal file
@ -0,0 +1,23 @@
|
|||||||
|
# this plugin checks the standard rcpthosts config and
|
||||||
|
# $ENV{RELAYCLIENT} to see if relaying is allowed.
|
||||||
|
#
|
||||||
|
# It should be configured to be run _LAST_!
|
||||||
|
#
|
||||||
|
|
||||||
|
sub register {
|
||||||
|
my ($self, $qp) = @_;
|
||||||
|
$self->register_hook("rcpt", "check_relay");
|
||||||
|
}
|
||||||
|
|
||||||
|
sub check_relay {
|
||||||
|
my ($self, $transaction, $recipient) = @_;
|
||||||
|
my $host = lc $recipient->host;
|
||||||
|
my @rcpt_hosts = $self->qp->config("rcpthosts");
|
||||||
|
return (OK) if exists $ENV{RELAYCLIENT};
|
||||||
|
for my $allowed (@rcpt_hosts) {
|
||||||
|
$allowed =~ s/^\s*(\S+)/$1/;
|
||||||
|
return (OK) if $host eq lc $allowed;
|
||||||
|
return (OK) if substr($allowed,0,1) eq "." and $host =~ m/\Q$allowed\E$/i;
|
||||||
|
}
|
||||||
|
return (DENY);
|
||||||
|
}
|
62
plugins/dnsbl
Normal file
62
plugins/dnsbl
Normal file
@ -0,0 +1,62 @@
|
|||||||
|
|
||||||
|
sub register {
|
||||||
|
my ($self, $qp) = @_;
|
||||||
|
$self->register_hook("connect", "connect_handler");
|
||||||
|
$self->register_hook("rcpt", "rcpt_handler");
|
||||||
|
#$self->register_hook("disconnect", "disconnect_handler");
|
||||||
|
}
|
||||||
|
|
||||||
|
sub connect_handler {
|
||||||
|
my ($self, $transaction) = @_;
|
||||||
|
my $remote_ip = $self->qp->connection->remote_ip;
|
||||||
|
|
||||||
|
my %dnsbl_zones = map { (split /\s+/, $_, 2)[0,1] } $self->qp->config('dnsbl_zones');
|
||||||
|
return unless %dnsbl_zones;
|
||||||
|
|
||||||
|
my $reversed_ip = join(".", reverse(split(/\./, $remote_ip)));
|
||||||
|
|
||||||
|
# we should queue these lookups in the background and just fetch the
|
||||||
|
# results in the first rcpt handler ... oh well.
|
||||||
|
|
||||||
|
my $result = "";
|
||||||
|
|
||||||
|
my $res = new Net::DNS::Resolver;
|
||||||
|
for my $dnsbl (keys %dnsbl_zones) {
|
||||||
|
$self->log(3, "Checking $reversed_ip.$dnsbl");
|
||||||
|
my $query = $res->query("$reversed_ip.$dnsbl", "TXT");
|
||||||
|
if ($query) {
|
||||||
|
my $a_record = 0;
|
||||||
|
foreach my $rr ($query->answer) {
|
||||||
|
$a_record = 1 if $rr->type eq "A";
|
||||||
|
next unless $rr->type eq "TXT";
|
||||||
|
$self->log(10, "got txt record");
|
||||||
|
$result = $rr->txtdata and last;
|
||||||
|
}
|
||||||
|
$a_record and $result = "Blocked by $dnsbl";
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
warn "$$ query for $reversed_ip.$dnsbl failed: ", $res->errorstring, "\n"
|
||||||
|
unless $res->errorstring eq "NXDOMAIN";
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
$transaction->notes('dnsbl', $result);
|
||||||
|
|
||||||
|
return DECLINED;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub rcpt_handler {
|
||||||
|
my ($self, $transaction, $rcpt) = @_;
|
||||||
|
my $note = $transaction->notes('rhsbl');
|
||||||
|
return (DENY, $note) if $note;
|
||||||
|
return DECLINED;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub disconnect_handler {
|
||||||
|
# if we queued stuff in the background we should make sure it got
|
||||||
|
# cleaned up here.
|
||||||
|
return DECLINED;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
1;
|
36
plugins/klez_filter
Normal file
36
plugins/klez_filter
Normal file
@ -0,0 +1,36 @@
|
|||||||
|
sub register {
|
||||||
|
my ($self, $qp) = @_;
|
||||||
|
$self->register_hook("data_post", "check_klez");
|
||||||
|
}
|
||||||
|
|
||||||
|
sub check_klez {
|
||||||
|
my ($self, $transaction) = @_;
|
||||||
|
|
||||||
|
# klez files are always around 140K
|
||||||
|
return (DECLINED)
|
||||||
|
if $transaction->body_size < 60_000
|
||||||
|
or $transaction->body_size > 220_000;
|
||||||
|
|
||||||
|
# maybe it would be worthwhile to add a check for
|
||||||
|
# Content-Type: multipart/alternative; here?
|
||||||
|
|
||||||
|
# make sure we read from the beginning;
|
||||||
|
$transaction->body_resetpos;
|
||||||
|
|
||||||
|
my $line_number = 0;
|
||||||
|
my $seen_klez_signature = 0;
|
||||||
|
|
||||||
|
while ($_ = $transaction->body_getline) {
|
||||||
|
last if $line_number++ > 40;
|
||||||
|
|
||||||
|
m/^Content-type:.*(?:audio|application)/i
|
||||||
|
and ++$seen_klez_signature and next;
|
||||||
|
|
||||||
|
return (DENY, "Klez Virus Detected")
|
||||||
|
if $seen_klez_signature
|
||||||
|
and m!^TVqQAAMAAAAEAAAA//8AALgAAAAAAAAAQA!;
|
||||||
|
|
||||||
|
}
|
||||||
|
|
||||||
|
return (DECLINED);
|
||||||
|
}
|
17
plugins/quit_fortune
Normal file
17
plugins/quit_fortune
Normal file
@ -0,0 +1,17 @@
|
|||||||
|
|
||||||
|
sub register {
|
||||||
|
shift->register_hook("quit", "quit_handler");
|
||||||
|
}
|
||||||
|
|
||||||
|
sub quit_handler {
|
||||||
|
my $qp = shift->qp;
|
||||||
|
|
||||||
|
# if she talks EHLO she is probably too sophisticated to enjoy the
|
||||||
|
# fun, so skip it.
|
||||||
|
return (DECLINED) if ($qp->connection->hello || '') eq "ehlo";
|
||||||
|
|
||||||
|
my @fortune = `/usr/games/fortune -s`;
|
||||||
|
@fortune = map { chop; s/^/ \/ /; $_ } @fortune;
|
||||||
|
$qp->respond(221, $qp->config('me') . " closing connection.", @fortune);
|
||||||
|
return DONE;
|
||||||
|
}
|
46
plugins/require_resolvable_fromhost
Normal file
46
plugins/require_resolvable_fromhost
Normal file
@ -0,0 +1,46 @@
|
|||||||
|
use Net::DNS qw(mx);
|
||||||
|
|
||||||
|
sub register {
|
||||||
|
my ($self, $qp) = @_;
|
||||||
|
$self->register_hook("mail", "mail_handler");
|
||||||
|
}
|
||||||
|
|
||||||
|
sub mail_handler {
|
||||||
|
my ($self, $transaction, $sender) = @_;
|
||||||
|
|
||||||
|
$sender->format ne "<>"
|
||||||
|
and $self->qp->config("require_resolvable_fromhost")
|
||||||
|
and !check_dns($sender->host)
|
||||||
|
and return (DENYSOFT,
|
||||||
|
($sender->host
|
||||||
|
? "Could not resolve ". $sender->host
|
||||||
|
: "FQDN required in the envelope sender"));
|
||||||
|
|
||||||
|
return DECLINED;
|
||||||
|
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
sub check_dns {
|
||||||
|
my $host = shift;
|
||||||
|
|
||||||
|
# for stuff where we can't even parse a hostname out of the address
|
||||||
|
return 0 unless $host;
|
||||||
|
|
||||||
|
return 1 if $host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/;
|
||||||
|
|
||||||
|
my $res = new Net::DNS::Resolver;
|
||||||
|
return 1 if mx($res, $host);
|
||||||
|
my $query = $res->search($host);
|
||||||
|
if ($query) {
|
||||||
|
foreach my $rr ($query->answer) {
|
||||||
|
return 1 if $rr->type eq "A" or $rr->type eq "MX";
|
||||||
|
}
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
warn "$$ query for $host failed: ", $res->errorstring, "\n"
|
||||||
|
unless $res->errorstring eq "NXDOMAIN";
|
||||||
|
}
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
42
plugins/rhsbl
Normal file
42
plugins/rhsbl
Normal file
@ -0,0 +1,42 @@
|
|||||||
|
|
||||||
|
sub register {
|
||||||
|
my ($self, $qp) = @_;
|
||||||
|
$self->register_hook("mail", "mail_handler");
|
||||||
|
$self->register_hook("rcpt", "rcpt_handler");
|
||||||
|
}
|
||||||
|
|
||||||
|
sub mail_handler {
|
||||||
|
my ($self, $transaction, $sender) = @_;
|
||||||
|
# lookup the address here; but always just return DECLINED
|
||||||
|
# we will store the state for rejection when rcpt is being run, some
|
||||||
|
# MTAs gets confused when you reject mail during MAIL FROM:
|
||||||
|
#
|
||||||
|
# If we were really clever we would do the lookup in the background
|
||||||
|
# but that must wait for another day. (patches welcome! :-) )
|
||||||
|
if ($sender->format ne "<>" and $self->qp->config('rhsbl_zones')) {
|
||||||
|
my %rhsbl_zones = map { (split /\s+/, $_, 2)[0,1] } $self->qp->config('rhsbl_zones');
|
||||||
|
my $host = $sender->host;
|
||||||
|
for my $rhsbl (keys %rhsbl_zones) {
|
||||||
|
$transaction->notes('rhsbl', "Mail from $host rejected because it $rhsbl_zones{$rhsbl}")
|
||||||
|
if check_rhsbl($self, $rhsbl, $host);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
sub rcpt_handler {
|
||||||
|
my ($self, $transaction, $rcpt) = @_;
|
||||||
|
my $note = $transaction->notes('rhsbl');
|
||||||
|
return (DENY, $note) if $note;
|
||||||
|
return DECLINED;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub check_rhsbl {
|
||||||
|
my ($self, $rhsbl, $host) = @_;
|
||||||
|
return 0 unless $host;
|
||||||
|
$self->log(2, "checking $host in $rhsbl");
|
||||||
|
return 1 if ((gethostbyname("$host.$rhsbl"))[4]);
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
|
76
plugins/spamassassin
Normal file
76
plugins/spamassassin
Normal file
@ -0,0 +1,76 @@
|
|||||||
|
|
||||||
|
#
|
||||||
|
# Requires the spamd patch attached to this spamassassin bug:
|
||||||
|
# http://bugzilla.spamassassin.org/show_bug.cgi?id=660
|
||||||
|
#
|
||||||
|
# The patch is going to be included in SpamAssassin 2.40.
|
||||||
|
#
|
||||||
|
# ... or you can change REPORT_IFSPAM to REPORT below; but the headers
|
||||||
|
# will be a bit different than you are used to.
|
||||||
|
#
|
||||||
|
#
|
||||||
|
|
||||||
|
use Socket qw(:DEFAULT :crlf);
|
||||||
|
use IO::Handle;
|
||||||
|
|
||||||
|
sub register {
|
||||||
|
my ($self, $qp) = @_;
|
||||||
|
$self->register_hook("data_post", "check_spam");
|
||||||
|
}
|
||||||
|
|
||||||
|
#my $rv = check_spam();
|
||||||
|
#die "failure!" unless defined $rv;
|
||||||
|
#print "rv: $rv\n";
|
||||||
|
|
||||||
|
sub check_spam {
|
||||||
|
my ($self, $transaction) = @_;
|
||||||
|
|
||||||
|
return (DECLINED) if $transaction->body_size > 500_000;
|
||||||
|
|
||||||
|
my $remote = 'localhost';
|
||||||
|
my $port = 783;
|
||||||
|
if ($port =~ /\D/) { $port = getservbyname($port, 'tcp') }
|
||||||
|
die "No port" unless $port;
|
||||||
|
my $iaddr = inet_aton($remote) or
|
||||||
|
$self->log(1, "Could not resolve host: $remote") and return (DECLINED);
|
||||||
|
my $paddr = sockaddr_in($port, $iaddr);
|
||||||
|
|
||||||
|
my $proto = getprotobyname('tcp');
|
||||||
|
socket(SPAMD, PF_INET, SOCK_STREAM, $proto)
|
||||||
|
or $self->log(1, "Could not open socket: $!") and return (DECLINED);
|
||||||
|
|
||||||
|
connect(SPAMD, $paddr)
|
||||||
|
or $self->log(1, "Could not connect to spamassassin daemon: $!") and return DECLINED;
|
||||||
|
|
||||||
|
SPAMD->autoflush(1);
|
||||||
|
|
||||||
|
$transaction->body_resetpos;
|
||||||
|
|
||||||
|
print SPAMD "REPORT_IFSPAM SPAMC/1.0" . CRLF;
|
||||||
|
# or CHECK or REPORT or SYMBOLS
|
||||||
|
|
||||||
|
print SPAMD join CRLF, split /\n/, $transaction->header->as_string;
|
||||||
|
print SPAMD CRLF;
|
||||||
|
|
||||||
|
while (my $line = $transaction->body_getline) {
|
||||||
|
chomp $line;
|
||||||
|
print SPAMD $line, CRLF;
|
||||||
|
}
|
||||||
|
print SPAMD CRLF;
|
||||||
|
shutdown(SPAMD, 1);
|
||||||
|
my $line0 = <SPAMD>; # get the first protocol lines out
|
||||||
|
if ($line0) {
|
||||||
|
$transaction->header->add("X-Spam-Check-By", $self->qp->config('me'));
|
||||||
|
}
|
||||||
|
while (<SPAMD>) {
|
||||||
|
warn "GOT FROM SPAMD1: $_";
|
||||||
|
next unless m/\S/;
|
||||||
|
s/\r?\n$/\n/;
|
||||||
|
my @h = split /: /, $_, 2;
|
||||||
|
|
||||||
|
$transaction->header->add(@h);
|
||||||
|
last if $h[0] eq "Spam" and $h[1] =~ m/^False/;
|
||||||
|
|
||||||
|
}
|
||||||
|
return (OK);
|
||||||
|
}
|
390
qpsmtpd
390
qpsmtpd
@ -10,398 +10,22 @@
|
|||||||
#
|
#
|
||||||
#
|
#
|
||||||
|
|
||||||
package QPsmtpd;
|
use lib 'lib';
|
||||||
$QPsmtpd::VERSION = "0.07b";
|
use Qpsmtpd::TcpServer;
|
||||||
use strict;
|
use strict;
|
||||||
$| = 1;
|
$| = 1;
|
||||||
use Mail::Address ();
|
|
||||||
use Sys::Hostname;
|
|
||||||
use IPC::Open2;
|
|
||||||
use Data::Dumper;
|
|
||||||
BEGIN{$^W=0;}
|
|
||||||
use Net::DNS;
|
|
||||||
BEGIN{$^W=1;}
|
|
||||||
|
|
||||||
delete $ENV{ENV};
|
delete $ENV{ENV};
|
||||||
$ENV{PATH} = '/var/qmail/bin';
|
$ENV{PATH} = '/var/qmail/bin';
|
||||||
|
|
||||||
use vars qw($TRACE);
|
# should this be ->new ?
|
||||||
|
my $qpsmtpd = Qpsmtpd::TcpServer->new();
|
||||||
|
$qpsmtpd->start_connection();
|
||||||
|
$qpsmtpd->run();
|
||||||
|
|
||||||
$TRACE = 0;
|
__END__
|
||||||
|
|
||||||
my %config;
|
|
||||||
$config{me} = get_config('me') || hostname;
|
|
||||||
$config{timeout} = get_config('timeoutsmtpd') || 1200;
|
|
||||||
|
|
||||||
my (@commands) = qw(ehlo helo rset mail rcpt data help vrfy noop quit);
|
|
||||||
my (%commands); @commands{@commands} = ('') x @commands;
|
|
||||||
|
|
||||||
my %state;
|
|
||||||
|
|
||||||
respond(220, "$config{me} qpsmtpd $QPsmtpd::VERSION Service ready, send me all your stuff!");
|
|
||||||
|
|
||||||
my $remote_host = $ENV{TCPREMOTEHOST} || "[$ENV{TCPREMOTEIP}]";
|
|
||||||
$state{remote_info} = $ENV{TCPREMOTEINFO} ? "$ENV{TCPREMOTEINFO}\@$remote_host" : $remote_host;
|
|
||||||
$state{remote_ip} = $ENV{TCPREMOTEIP};
|
|
||||||
|
|
||||||
$SIG{ALRM} = sub { respond(421, "Game over pal, game over. You got a timeout; I just can't wait that long..."); exit };
|
|
||||||
|
|
||||||
$state{dnsbl_blocked} = check_dnsbl($state{remote_ip});
|
|
||||||
|
|
||||||
my ($commands) = '';
|
|
||||||
alarm $config{timeout};
|
|
||||||
while (<STDIN>) {
|
|
||||||
alarm 0;
|
|
||||||
$_ =~ s/\r?\n$//s; # advanced chomp
|
|
||||||
warn "$$ dispatching $_\n" if $TRACE;
|
|
||||||
defined dispatch(split / +/, $_)
|
|
||||||
or respond(502, "command unrecognized: '$_'");
|
|
||||||
alarm $config{timeout};
|
|
||||||
}
|
|
||||||
|
|
||||||
sub dispatch {
|
|
||||||
my ($cmd) = lc shift;
|
|
||||||
|
|
||||||
respond(553, $state{dnsbl_blocked}), return 1
|
|
||||||
if $state{dnsbl_blocked} and ($cmd eq "rcpt");
|
|
||||||
|
|
||||||
respond(500, "Unrecognized command"), return 1
|
|
||||||
if ($cmd !~ /^(\w{1,12})$/ or !exists $commands{$1});
|
|
||||||
$cmd = $1;
|
|
||||||
|
|
||||||
|
|
||||||
if (exists $commands{$cmd}) {
|
|
||||||
my ($result) = eval "&$cmd";
|
|
||||||
warn "$$ $@" if $@;
|
|
||||||
return $result if defined $result;
|
|
||||||
return fault("command '$cmd' failed unexpectedly");
|
|
||||||
}
|
|
||||||
|
|
||||||
return;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub respond {
|
|
||||||
my ($code, @messages) = @_;
|
|
||||||
while (my $msg = shift @messages) {
|
|
||||||
my $line = $code . (@messages?"-":" ").$msg;
|
|
||||||
print "$line\r\n";
|
|
||||||
warn "$$ $line\n" if $TRACE;
|
|
||||||
}
|
|
||||||
return 1;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub fault {
|
|
||||||
my ($msg) = shift || "program fault - command not performed";
|
|
||||||
print STDERR "$0[$$]: $msg ($!)\n";
|
|
||||||
return respond(451, "Internal error - try again later - " . $msg);
|
|
||||||
}
|
|
||||||
|
|
||||||
sub helo {
|
|
||||||
my ($hello_host, @stuff) = @_;
|
|
||||||
return respond (503, "but you already said HELO ...") if $state{hello};
|
|
||||||
$state{hello} = "helo";
|
|
||||||
$state{hello_host} = $hello_host;
|
|
||||||
$state{transaction} = {};
|
|
||||||
respond(250, "$config{me} Hi $state{remote_info} [$state{remote_ip}]; I am so happy to meet you.");
|
|
||||||
}
|
|
||||||
|
|
||||||
sub ehlo {
|
|
||||||
my ($hello_host, @stuff) = @_;
|
|
||||||
return respond (503, "but you already said HELO ...") if $state{hello};
|
|
||||||
$state{hello} = "ehlo";
|
|
||||||
$state{hello_host} = $hello_host;
|
|
||||||
$state{transaction} = {};
|
|
||||||
respond(250,
|
|
||||||
"$config{me} Hi $state{remote_info} [$state{remote_ip}].",
|
|
||||||
"PIPELINING",
|
|
||||||
"8BITMIME",
|
|
||||||
(get_config('databytes') ? "SIZE ". (get_config('databytes'))[0] : ()),
|
|
||||||
);
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub mail {
|
|
||||||
return respond(501, "syntax error in parameters") if $_[0] !~ m/^from:/i;
|
|
||||||
unless ($state{hello}) {
|
|
||||||
return respond(503, "please say hello first ...");
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
my $from_parameter = join " ", @_;
|
|
||||||
warn "$$ full from_parameter: $from_parameter\n" if $TRACE;
|
|
||||||
my ($from) = ($from_parameter =~ m/^from:\s*(\S+)/i)[0];
|
|
||||||
#warn "$$ from email address : $from\n" if $TRACE;
|
|
||||||
if ($from eq "<>" or $from =~ m/\[undefined\]/) {
|
|
||||||
$from = Mail::Address->new("<>");
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
$from = (Mail::Address->parse($from))[0];
|
|
||||||
}
|
|
||||||
return respond(501, "could not parse your mail from command") unless $from;
|
|
||||||
|
|
||||||
$from->format ne "<>"
|
|
||||||
and get_config("require_resolvable_fromhost")
|
|
||||||
and !check_dns($from->host)
|
|
||||||
and return respond(450, $from->host ? "Could not resolve ". $from->host : "FQDN required in the envelope sender");
|
|
||||||
|
|
||||||
warn "$$ getting mail from ",$from->format,"\n" if $TRACE;
|
|
||||||
respond(250, $from->format . ", sender OK - I always like getting mail from you!");
|
|
||||||
|
|
||||||
$state{transaction} = { from => $from };
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub rcpt {
|
|
||||||
return respond(501, "syntax error in parameters") unless $_[0] =~ m/^to:/i;
|
|
||||||
return(503, "Use MAIL before RCPT") unless $state{transaction}->{from};
|
|
||||||
|
|
||||||
my $from = $state{transaction}->{from};
|
|
||||||
if ($from->format ne "<>" and get_config('rhsbl_zones')) {
|
|
||||||
my %rhsbl_zones = map { (split /\s+/, $_, 2)[0,1] } get_config('rhsbl_zones');
|
|
||||||
my $host = $from->host;
|
|
||||||
for my $rhsbl (keys %rhsbl_zones) {
|
|
||||||
respond("550", "Mail from $host rejected because it $rhsbl_zones{$rhsbl}"), return 1
|
|
||||||
if check_rhsbl($rhsbl, $host);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
my ($rcpt) = ($_[0] =~ m/to:(.*)/i)[0];
|
|
||||||
$rcpt = $_[1] unless $rcpt;
|
|
||||||
$rcpt = (Mail::Address->parse($rcpt))[0];
|
|
||||||
return respond(501, "could not parse recipient") unless $rcpt;
|
|
||||||
return respond(550, "will not relay for ". $rcpt->host) unless check_relay($rcpt->host);
|
|
||||||
push @{$state{transaction}->{rcpt}}, $rcpt;
|
|
||||||
respond(250, $rcpt->format . ", recipient OK");
|
|
||||||
}
|
|
||||||
|
|
||||||
sub data {
|
|
||||||
respond(503, "MAIL first"), return 1 unless $state{transaction}->{from};
|
|
||||||
respond(503, "RCPT first"), return 1 unless $state{transaction}->{rcpt};
|
|
||||||
respond(354, "go ahead");
|
|
||||||
my $buffer = '';
|
|
||||||
my $size = 0;
|
|
||||||
my $i = 0;
|
|
||||||
my $max_size = (get_config('databytes'))[0] || 0;
|
|
||||||
my $blocked = "";
|
|
||||||
my %matches;
|
|
||||||
my $header = 1;
|
|
||||||
my $complete = 0;
|
|
||||||
|
|
||||||
warn "$$ max_size: $max_size / size: $size" if $TRACE > 5;
|
|
||||||
|
|
||||||
while (<STDIN>) {
|
|
||||||
$complete++, last if $_ eq ".\r\n";
|
|
||||||
$i++;
|
|
||||||
respond(451, "See http://develooper.com/code/qpsmtpd/barelf.html"), exit
|
|
||||||
if $_ eq ".\n";
|
|
||||||
unless ($max_size and $size > $max_size) {
|
|
||||||
s/\r\n$/\n/;
|
|
||||||
$header = 0 if $header and m/^\s*$/;
|
|
||||||
|
|
||||||
if ($header) {
|
|
||||||
|
|
||||||
$matches{"aol.com"} = 1 if m/aol\.com/;
|
|
||||||
|
|
||||||
$blocked = "Your mail looks too much like that SirCam nonsense, please go away"
|
|
||||||
if $state{transaction}->{from}->format eq "<>"
|
|
||||||
and $_ eq "Content-Disposition: Multipart message\n";
|
|
||||||
|
|
||||||
$blocked = "No List Builder spam for us, thank you."
|
|
||||||
if m/^From: List Builder <notifications\@bcentral.com>/;
|
|
||||||
|
|
||||||
$blocked = q[Don't send W32.Badtrans.B@mm virus to us, please]
|
|
||||||
if $matches{"aol.com"} and m/^From: .* <_/;
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
# Might be klez
|
|
||||||
m/^Content-type:.*(?:audio|application)/i
|
|
||||||
and $matches{"klez"}=1;
|
|
||||||
|
|
||||||
# we've seen the Klez signature, we're probably infected
|
|
||||||
$blocked = q[Take your Klez virus and stuff it! HAND.]
|
|
||||||
if $matches{"klez"} and m!^TVqQAAMAAAAEAAAA//8AALgAAAAAAAAAQA!;
|
|
||||||
|
|
||||||
$buffer .= $_;
|
|
||||||
$size += length $_;
|
|
||||||
}
|
|
||||||
warn "$$ size is at $size\n" unless ($i % 300);
|
|
||||||
|
|
||||||
alarm $config{timeout};
|
|
||||||
}
|
|
||||||
|
|
||||||
warn "$$ max_size: $max_size / size: $size" if $TRACE > 5;
|
|
||||||
|
|
||||||
# if we get here without seeing a terminator, the connection is
|
|
||||||
# probably dead.
|
|
||||||
respond(451, "Incomplete DATA"), return 1 unless $complete;
|
|
||||||
|
|
||||||
respond(550, $blocked),return 1 if $blocked;
|
|
||||||
respond(552, "Message too big!"),return 1 if $max_size and $size > $max_size;
|
|
||||||
|
|
||||||
# these bits inspired by Peter Samuels "qmail-queue wrapper"
|
|
||||||
pipe(MESSAGE_READER, MESSAGE_WRITER) or fault("Could not create message pipe"), exit;
|
|
||||||
pipe(ENVELOPE_READER, ENVELOPE_WRITER) or fault("Could not create envelope pipe"), exit;
|
|
||||||
|
|
||||||
my $child = fork();
|
|
||||||
|
|
||||||
not defined $child and fault(451, "Could not fork"), exit;
|
|
||||||
|
|
||||||
if ($child) {
|
|
||||||
# Parent
|
|
||||||
my $oldfh = select(MESSAGE_WRITER); $| = 1;
|
|
||||||
select(ENVELOPE_WRITER); $| = 1;
|
|
||||||
select($oldfh);
|
|
||||||
|
|
||||||
close MESSAGE_READER or fault("close msg reader fault"),exit;
|
|
||||||
close ENVELOPE_READER or fault("close envelope reader fault"), exit;
|
|
||||||
print MESSAGE_WRITER "Received: from $state{remote_info} (HELO $state{hello_host}) ($state{remote_ip})\n";
|
|
||||||
print MESSAGE_WRITER " by $config{me} (qpsmtpd/$QPsmtpd::VERSION) with SMTP; ", scalar gmtime, " -0000\n";
|
|
||||||
print MESSAGE_WRITER $buffer;
|
|
||||||
close MESSAGE_WRITER;
|
|
||||||
|
|
||||||
my @rcpt = map { "T" . $_->address } @{$state{transaction}->{rcpt}};
|
|
||||||
my $from = "F".($state{transaction}->{from}->address|| "" );
|
|
||||||
print ENVELOPE_WRITER "$from\0", join("\0",@rcpt), "\0\0"
|
|
||||||
or respond(451,"Could not print addresses to queue"),exit;
|
|
||||||
|
|
||||||
close ENVELOPE_WRITER;
|
|
||||||
waitpid($child, 0);
|
|
||||||
my $exit_code = $? >> 8;
|
|
||||||
$exit_code and respond(451, "Unable to queue message ($exit_code)"), exit;
|
|
||||||
respond(250, "Message queued; it better be worth it.");
|
|
||||||
}
|
|
||||||
elsif (defined $child) {
|
|
||||||
# Child
|
|
||||||
close MESSAGE_WRITER or die "could not close message writer in parent";
|
|
||||||
close ENVELOPE_WRITER or die "could not close envelope writer in parent";
|
|
||||||
|
|
||||||
open(STDIN, "<&MESSAGE_READER") or die "b1";
|
|
||||||
open(STDOUT, "<&ENVELOPE_READER") or die "b2";
|
|
||||||
|
|
||||||
unless (exec '/var/qmail/bin/qmail-queue') {
|
|
||||||
die "should never be here!";
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
return 1;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub rset {
|
|
||||||
$state{transaction} = {};
|
|
||||||
respond(250, "OK");
|
|
||||||
}
|
|
||||||
|
|
||||||
sub noop {
|
|
||||||
respond(250, "OK");
|
|
||||||
}
|
|
||||||
|
|
||||||
sub vrfy {
|
|
||||||
respond(252, "Just try sending a mail and we'll see how it turns out ...");
|
|
||||||
}
|
|
||||||
|
|
||||||
sub help {
|
|
||||||
respond(214,
|
|
||||||
"This is qpsmtpd $QPsmtpd::VERSION",
|
|
||||||
"See http://develooper.com/code/qpsmtpd/",
|
|
||||||
"To report bugs or whatnot, send mail to <ask\@perl.org>.");
|
|
||||||
}
|
|
||||||
|
|
||||||
sub quit {
|
|
||||||
respond(221, "$config{me} closing connection. Have a wonderful day");
|
|
||||||
exit;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub check_rhsbl {
|
|
||||||
my ($rhsbl, $host) = @_;
|
|
||||||
return 0 unless $host;
|
|
||||||
warn "$$ checking $host in $rhsbl\n" if $TRACE > 2;
|
|
||||||
return 1 if ((gethostbyname("$host.$rhsbl"))[4]);
|
|
||||||
return 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub check_dnsbl {
|
|
||||||
my ($ip, $debug) = @_;
|
|
||||||
local $TRACE = 5 if $debug;
|
|
||||||
my %dnsbl_zones = map { (split /\s+/, $_, 2)[0,1] } get_config('dnsbl_zones');
|
|
||||||
return unless %dnsbl_zones;
|
|
||||||
|
|
||||||
my $reversed_ip = join(".", reverse(split(/\./, $ip)));
|
|
||||||
|
|
||||||
my $res = new Net::DNS::Resolver;
|
|
||||||
for my $dnsbl (keys %dnsbl_zones) {
|
|
||||||
warn "$$ Checking $reversed_ip.$dnsbl ..." if $TRACE > 2;
|
|
||||||
my $query = $res->query("$reversed_ip.$dnsbl", "TXT");
|
|
||||||
if ($query) {
|
|
||||||
my $a_record = 0;
|
|
||||||
foreach my $rr ($query->answer) {
|
|
||||||
$a_record = 1 if $rr->type eq "A";
|
|
||||||
next unless $rr->type eq "TXT";
|
|
||||||
warn "got txt record" if $TRACE > 9;
|
|
||||||
return $rr->txtdata;
|
|
||||||
}
|
|
||||||
return "Blocked by $dnsbl" if $a_record;
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
warn "$$ query for $reversed_ip.$dnsbl failed: ", $res->errorstring, "\n"
|
|
||||||
unless $res->errorstring eq "NXDOMAIN";
|
|
||||||
}
|
|
||||||
}
|
|
||||||
return "";
|
|
||||||
}
|
|
||||||
|
|
||||||
sub check_dns {
|
|
||||||
my $host = shift;
|
|
||||||
|
|
||||||
# for stuff where we can't even parse a hostname out of the address
|
|
||||||
return 0 unless $host;
|
|
||||||
|
|
||||||
return 1 if $host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/;
|
|
||||||
|
|
||||||
my $res = new Net::DNS::Resolver;
|
|
||||||
return 1 if mx($res, $host);
|
|
||||||
my $query = $res->search($host);
|
|
||||||
if ($query) {
|
|
||||||
foreach my $rr ($query->answer) {
|
|
||||||
return 1 if $rr->type eq "A" or $rr->type eq "MX";
|
|
||||||
}
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
warn "$$ query for $host failed: ", $res->errorstring, "\n"
|
|
||||||
unless $res->errorstring eq "NXDOMAIN";
|
|
||||||
}
|
|
||||||
return 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub check_relay {
|
|
||||||
my $host = lc shift;
|
|
||||||
my @rcpt_hosts = get_config("rcpthosts");
|
|
||||||
return 1 if exists $ENV{RELAYCLIENT};
|
|
||||||
for my $allowed (@rcpt_hosts) {
|
|
||||||
$allowed =~ s/^\s*(\S+)/$1/;
|
|
||||||
return 1 if $host eq lc $allowed;
|
|
||||||
return 1 if substr($allowed,0,1) eq "." and $host =~ m/\Q$allowed\E$/i;
|
|
||||||
}
|
|
||||||
return 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
my %config_cache;
|
|
||||||
sub get_config {
|
|
||||||
my $config = shift;
|
|
||||||
warn "$$ trying to get config for $config" if $TRACE > 4;
|
|
||||||
return @{$config_cache{$config}} if $config_cache{$config};
|
|
||||||
my $configdir = '/var/qmail/control';
|
|
||||||
my ($name) = ($0 =~ m!(.*?)/([^/]+)$!);
|
|
||||||
$configdir = "$name/config" if (-e "$name/config/$config");
|
|
||||||
open CF, "<$configdir/$config" or warn "$$ could not open configfile $config: $!", return;
|
|
||||||
my @config = <CF>;
|
|
||||||
chomp @config;
|
|
||||||
@config = grep { $_ and $_ !~ m/\s*#/ } @config;
|
|
||||||
close CF;
|
|
||||||
warn "$$ returning get_config for $config ",Data::Dumper->Dump([\@config], [qw(config)]) if $TRACE > 4;
|
|
||||||
$config_cache{$config} = \@config;
|
|
||||||
return wantarray ? @config : $config[0];
|
|
||||||
}
|
|
||||||
|
|
||||||
1;
|
1;
|
||||||
|
2
run
2
run
@ -3,6 +3,6 @@ QMAILDUID=`id -u smtpd`
|
|||||||
NOFILESGID=`id -g smtpd`
|
NOFILESGID=`id -g smtpd`
|
||||||
exec /usr/local/bin/softlimit -m 10000000 \
|
exec /usr/local/bin/softlimit -m 10000000 \
|
||||||
/usr/local/bin/tcpserver -c 10 -v -p \
|
/usr/local/bin/tcpserver -c 10 -v -p \
|
||||||
-u $QMAILDUID -g $NOFILESGID 0 smtp \
|
-u $QMAILDUID -g $NOFILESGID `head -1 config/IP` smtp \
|
||||||
./qpsmtpd 2>&1
|
./qpsmtpd 2>&1
|
||||||
|
|
||||||
|
Loading…
Reference in New Issue
Block a user