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

merge from v010

Browse Source 
git-svn-id: https://svn.perl.org/qpsmtpd/trunk@57 958fd67b-6ff1-0310-b445-bb7760255be9
This commit is contained in:
Ask Bjørn Hansen 2002-09-08 13:52:12 +00:00
commit 5e93c4302a
26 changed files with 1463 additions and 412 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.cvsignore
View File

@ -1 +1,2 @@
supervise
tmp

47
Changes
View File

@ -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
Klez filter (thanks to Robert Spier)

2
LICENSE
View File

@ -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
this software and associated documentation files (the "Software"), to deal in

101
README
View File

@ -1,3 +1,5 @@
Qpsmtpd - qmail perl simple mail transfer protocol daemon
---------------------------------------------------------
web:
http://develooper.com/code/qpsmtpd/
@ -5,23 +7,88 @@ web:
mailinglist:
qpsmtpd-subscribe@perl.org
Problems:
First thing to try is to set $TRACE in qpsmtpd to some number higher
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
replacement for qmail-smtpd, so it should be very easy to get going.
What is Qpsmtpd?
----------------
Qpsmtpd is an extensible smtp engine written in Perl. No, make that
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
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
ask@develooper.com.
What's new in version 0.10?
---------------------------
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.
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:
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).
Extra files you can use to configure qpsmtpd:
rhsbl_zones
@ -46,3 +113,11 @@ Configuration files:
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
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
View 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
View 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
View 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
View 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

1
config.sample/rhsbl_zones
View File

@ -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
View 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
View 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
View 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
View 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
View 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
View 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
log/.cvsignore
View File

@ -1 +1,2 @@
main
supervise

5
log/run
View File

@ -1,2 +1,5 @@
#! /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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View File

@ -10,398 +10,22 @@
#
#
package QPsmtpd;
$QPsmtpd::VERSION = "0.07b";
use lib 'lib';
use Qpsmtpd::TcpServer;
use strict;
$| = 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};
$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;

2
run
View File

@ -3,6 +3,6 @@ QMAILDUID=`id -u smtpd`
NOFILESGID=`id -g smtpd`
exec /usr/local/bin/softlimit -m 10000000 \
/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