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

copy 0.3x to trunk

Browse Source 
git-svn-id: https://svn.perl.org/qpsmtpd/trunk@710 958fd67b-6ff1-0310-b445-bb7760255be9
This commit is contained in:
Robert Spier 2007-02-03 07:51:30 +00:00
commit bcbe814165
79 changed files with 5161 additions and 1998 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

91
Changes
View File

@ -1,4 +1,92 @@
0.40
0.33 (to be)
Update the sample configuration to use zen.spamhaus.org
Support "module" plugins ("My::Plugin" in the config/plugins file)
Make the badmailfrom plugin support (optional) rejection messages after the
rejection pattern (Robin Hugh Johnson)
The ill-named $transaction->body_size() is depreceated now, use
$transaction->data_size() instead. Check your logs for LOGWARN messages
about "body_size" and fix your plugins. (Hanno Hecker)
Instead of failing with cryptic message, ignore lines in config/plugins
for uninstalled plugins. (John Peacock)
Patch to prefork code to make it run (Leonardo Helman). Add --pretty
option to qpsmtpd-prefork to change $0 for child processes (John Peacock).
Add support for multiple plugin directories, whose paths are given by the
'plugin_dirs' configuration. (Devin Carraway, Nick Leverton)
Greylisting DBs may now be stored in a configured location, and are
looked for by default in /var/lib/qpsmtpd/greylisting in addition to the
previous locations relative to the qpsmtpd binary. (Devin Carraway)
New Qpsmtpd::Postfix::Constants to encapsulate all of the current return
codes from Postfix, plus script to generate it. (Hanno Hecker)
Experimental IPv6 support (forkserver only). (Mike Williams)
Add ability to specific socket for syslog (Peter Eisch)
Do the right thing for unimplemented AUTH mechanisms (Brian Szymanski)
relay_only plugin for smart relay host. (John Peacock)
Enhance the spamassassin plugin to support connecting to a remote
spamd process (Kjetil Kjernsmo).
Add SSL encryption method to header to mirror other qmail/SSL patches.
Add tls_before_auth to suppress AUTH unless TLS has already been
established (Robin Johnson).
Fix "help" command when there's no "smtpgreeting" configured (the default)
(Thanks to Thomas Ogrisegg)
Move the Qpsmtpd::Auth POD to a top-level README to be more obvious.
Add Qpsmtpd::Command to gather all parsing logic in one place (Hanno
Hecker)
Fix a spurious newline at the start of messages queued via exim (Devin
Carraway)
Make the clamdscan plugin temporarily deny mail if if can't talk to clamd
(Filippo Carletti)
Improve Qpsmtpd::Transaction documentation (Fred Moyer)
0.32 - 2006/02/26
Add logging/file plugin for simple logging to a file (Devin Carraway and
Peter J. Holzer).
Add logging/syslog plugin for logging via the syslog facility (Devin
Carrway)
Add Qpsmtpd::DSN to return extended SMTP status codes from RFC-1893 and
patch existing plugins to use it when appropriate (Hanno Hecker).
Add plugins/tls_cert to generate appropriately shaped self-signed certs for
TLS support. Add explicit use of CA used to sign cert. Abstract clone()ing
of connection information when switching to TLS. Fix the AUTH code to work
correctly with TLS.
Add hosts_allow plugin to support pre- and post-connection hooks as well
as move --max-from-ip tests out of core (Hanno Hecker).
Improve postfix-queue plugin to support the known processing flags (Hanno
Hecker).
Drop root privileges before loading plugins, rather than after.
A few fixes to the clamdscan plugin (Dave Rolsky)
Various minor fixes and improvements
0.31.1 - 2005/11/18
@ -116,6 +204,7 @@
Fix typo in qpsmtpd-forkserver commandline help
0.29 - 2005/03/03
Store entire incoming message in spool file (so that scanners can read

3
MANIFEST
View File

@ -16,10 +16,12 @@ lib/Apache/Qpsmtpd.pm
lib/Qpsmtpd.pm
lib/Qpsmtpd/Address.pm
lib/Qpsmtpd/Auth.pm
lib/Qpsmtpd/Command.pm
lib/Qpsmtpd/Connection.pm
lib/Qpsmtpd/Constants.pm
lib/Qpsmtpd/Plugin.pm
lib/Qpsmtpd/Postfix.pm
lib/Qpsmtpd/SelectServer.pm
lib/Qpsmtpd/SMTP.pm
lib/Qpsmtpd/TcpServer.pm
lib/Qpsmtpd/Transaction.pm
@ -82,6 +84,7 @@ plugins/virus/sophie
plugins/virus/uvscan
qpsmtpd
qpsmtpd-forkserver
qpsmtpd-server
README
README.logging
README.plugins

7
README
View File

@ -59,7 +59,7 @@ run the following command in the /home/smtpd/ directory.
Beware that the trunk might be unstable and unsuitable for anything but development, so you might want to get a specific release, for example:
svn co http://svn.perl.org/qpsmtpd/tags/0.31.1 .
svn co http://svn.perl.org/qpsmtpd/tags/0.31 .
chmod o+t ~smtpd/qpsmtpd/ (or whatever directory you installed qpsmtpd
in) to make supervise start the log process.
@ -176,6 +176,11 @@ smtpd uses during the data transactions. If this file doesnt exist, it
will default to use $ENV{HOME}/tmp/. This directory should be set with
a mode of 700 and owned by the smtpd user.
=item tls_before_auth
If this file contains anything except a 0 on the first noncomment line, then
AUTH will not be offered unless TLS/SSL are in place, either with STARTTLS,
or SMTP-SSL on port 465.
=item everything (?) that qmail-smtpd supports.

2
README.plugins
View File

@ -333,7 +333,7 @@ loaded. It's mostly for inheritance, below.
=head1 Inheritance
Instead of modifying @ISA directly in your plugin, use the
C< isa_plugin > method from the C< init > subroutine.
C< isa_plugin > method from the init subroutine.
# rcpt_ok_child
sub init {

4
config.sample/dnsbl_zones
View File

@ -1,4 +1,2 @@
rbl.mail-abuse.org
spamsources.fabel.dk
relays.ordb.org
sbl.spamhaus.org
zen.spamhaus.org

13
config.sample/plugins
View File

@ -6,6 +6,19 @@
# plugins/http_config for details.
# http_config http://localhost/~smtpd/config/ http://www.example.com/smtp.pl?config=
# The hosts_allow module must be loaded if you want the -m / --max-from-ip /
# my $MAXCONNIP = 5; # max simultaneous connections from one IP
# settings... without this it will NOT refuse more than $MAXCONNIP connections
# from one IP!
hosts_allow
# enable to accept MAIL FROM:/RCPT TO: addresses without surrounding <>
dont_require_anglebrackets
# enable to reject MAIL FROM:/RCPT TO: parameters if client helo was HELO
# (strict RFC 821)... this is not used in EHLO ...
# parse_addr_withhelo
quit_fortune
check_earlytalker

2
config.sample/tls_before_auth Normal file
View File

@ -0,0 +1,2 @@
# change the next line to 0 if you want to offer AUTH without TLS
1

4
config.sample/tls_ciphers Normal file
View File

@ -0,0 +1,4 @@
# Override default security using suitable string from available ciphers at
# L<http://www.openssl.org/docs/apps/ciphers.html#CIPHER_STRINGS>
# See plugins/tls for details.
HIGH

3
lib/Apache/Qpsmtpd.pm
View File

@ -96,6 +96,7 @@ sub config_dir {
return "/var/qmail/control";
}
sub plugin_dir {
my $self = shift;
return "$self->{qpdir}/plugins";
@ -130,7 +131,7 @@ sub read_input {
while (defined(my $data = $self->getline)) {
$data =~ s/\r?\n$//s; # advanced chomp
$self->log(LOGDEBUG, "dispatching $data");
defined $self->dispatch(split / +/, $data)
defined $self->dispatch(split / +/, $data, 2)
or $self->respond(502, "command unrecognized: '$data'");
last if $self->{_quitting};
}

81
lib/Danga/Client.pm
View File

@ -2,9 +2,11 @@
package Danga::Client;
use base 'Danga::TimeoutSocket';
use fields qw(line pause_count);
use fields qw(line pause_count read_bytes data_bytes callback get_chunks);
use Time::HiRes ();
use bytes;
# 30 seconds max timeout!
sub max_idle_time { 30 }
sub max_connect_time { 1200 }
@ -22,21 +24,94 @@ sub reset_for_next_message {
my Danga::Client $self = shift;
$self->{line} = '';
$self->{pause_count} = 0;
$self->{read_bytes} = 0;
$self->{callback} = undef;
$self->{data_bytes} = '';
$self->{get_chunks} = 0;
return $self;
}
sub get_bytes {
my Danga::Client $self = shift;
my ($bytes, $callback) = @_;
if ($self->{callback}) {
die "get_bytes/get_chunks currently in progress!";
}
$self->{read_bytes} = $bytes;
$self->{data_bytes} = $self->{line};
$self->{read_bytes} -= length($self->{data_bytes});
$self->{line} = '';
if ($self->{read_bytes} <= 0) {
if ($self->{read_bytes} < 0) {
$self->{line} = substr($self->{data_bytes},
$self->{read_bytes}, # negative offset
0 - $self->{read_bytes}, # to end of str
""); # truncate that substr
}
$callback->($self->{data_bytes});
return;
}
$self->{callback} = $callback;
}
sub get_chunks {
my Danga::Client $self = shift;
my ($bytes, $callback) = @_;
if ($self->{callback}) {
die "get_bytes/get_chunks currently in progress!";
}
$self->{read_bytes} = $bytes;
$callback->($self->{line}) if length($self->{line});
$self->{line} = '';
$self->{callback} = $callback;
$self->{get_chunks} = 1;
}
sub end_get_chunks {
my Danga::Client $self = shift;
my $remaining = shift;
$self->{callback} = undef;
$self->{get_chunks} = 0;
if (defined($remaining)) {
$self->process_read_buf(\$remaining);
}
}
sub event_read {
my Danga::Client $self = shift;
if ($self->{callback}) {
$self->{alive_time} = time;
if ($self->{get_chunks}) {
my $bref = $self->read($self->{read_bytes});
return $self->close($!) unless defined $bref;
$self->{callback}->($$bref) if length($$bref);
return;
}
if ($self->{read_bytes} > 0) {
my $bref = $self->read($self->{read_bytes});
return $self->close($!) unless defined $bref;
$self->{read_bytes} -= length($$bref);
$self->{data_bytes} .= $$bref;
}
if ($self->{read_bytes} <= 0) {
# print "Erk, read too much!\n" if $self->{read_bytes} < 0;
my $cb = $self->{callback};
$self->{callback} = undef;
$cb->($self->{data_bytes});
}
}
else {
my $bref = $self->read(8192);
return $self->close($!) unless defined $bref;
$self->process_read_buf($bref);
}
}
sub process_read_buf {
my Danga::Client $self = shift;
my $bref = shift;
$self->{line} .= $$bref;
return if $self->paused();
return if $self->{pause_count} || $self->{closed};
while ($self->{line} =~ s/^(.*?\n)//) {
my $line = $1;
@ -45,7 +120,7 @@ sub process_read_buf {
if ($::DEBUG > 1 and $resp) { print "$$:".($self+0)."S: $_\n" for split(/\n/, $resp) }
$self->write($resp) if $resp;
# $self->watch_read(0) if $self->{pause_count};
last if $self->paused();
return if $self->{pause_count} || $self->{closed};
}
}

160
lib/Danga/DNS.pm
View File

@ -1,160 +0,0 @@
# $Id: DNS.pm,v 1.12 2005/02/14 22:06:08 msergeant Exp $
package Danga::DNS;
# This is the query class - it is really just an encapsulation of the
# hosts you want to query, plus the callback. All the hard work is done
# in Danga::DNS::Resolver.
use fields qw(client hosts num_hosts callback finished results start);
use strict;
use Danga::DNS::Resolver;
my $resolver;
sub trace {
my $level = shift;
print STDERR ("[$$] dns lookup: @_") if $::DEBUG >= $level;
}
sub new {
my Danga::DNS $self = shift;
my %options = @_;
$resolver ||= Danga::DNS::Resolver->new();
my $client = $options{client};
$client->pause_read() if $client;
$self = fields::new($self) unless ref $self;
$self->{hosts} = $options{hosts} ? $options{hosts} : [ $options{host} ];
$self->{num_hosts} = scalar(@{$self->{hosts}}) || "No hosts supplied";
$self->{client} = $client;
$self->{callback} = $options{callback} || die "No callback given";
$self->{finished} = $options{finished};
$self->{results} = {};
$self->{start} = time;
if ($options{type}) {
if ( ($options{type} eq 'A') || ($options{type} eq 'PTR') ) {
if (!$resolver->query($self, @{$self->{hosts}})) {
$client->continue_read() if $client;
return;
}
}
else {
if (!$resolver->query_type($self, $options{type}, @{$self->{hosts}})) {
$client->continue_read() if $client;
return;
}
# die "Unsupported DNS query type: $options{type}";
}
}
else {
if (!$resolver->query($self, @{$self->{hosts}})) {
$client->continue_read() if $client;
return;
}
}
return $self;
}
sub run_callback {
my Danga::DNS $self = shift;
my ($result, $query) = @_;
$self->{results}{$query} = $result;
trace(2, "got $query => $result\n");
eval {
$self->{callback}->($result, $query);
};
if ($@) {
warn($@);
}
}
sub DESTROY {
my Danga::DNS $self = shift;
my $now = time;
foreach my $host (@{$self->{hosts}}) {
if (!exists($self->{results}{$host})) {
print STDERR "DNS timeout (presumably) looking for $host after " . ($now - $self->{start}) . " secs\n";
$self->{callback}->("NXDOMAIN", $host);
}
}
$self->{client}->continue_read() if $self->{client};
if ($self->{finished}) {
$self->{finished}->();
}
}
1;
=head1 NAME
Danga::DNS - a DNS lookup class for the Danga::Socket framework
=head1 SYNOPSIS
Danga::DNS->new(%options);
=head1 DESCRIPTION
This module performs asynchronous DNS lookups, making use of a single UDP
socket (unlike Net::DNS's bgsend/bgread combination), and blocking reading on
a client until the response comes back (this is useful for e.g. SMTP rDNS
lookups where you want the answer before you see the next SMTP command).
Currently this module will only perform A or PTR lookups. A rDNS (PTR) lookup
will be performed if the host matches the regexp: C</^\d+\.\d+\.\d+.\d+$/>.
The lookups time out after 15 seconds.
=head1 API
=head2 C<< Danga::DNS->new( %options ) >>
Create a new DNS query. You do not need to store the resulting object as this
class is all done with callbacks.
Example:
Danga::DNS->new(
callback => sub { print "Got result: $_[0]\n" },
host => 'google.com',
);
=over 4
=item B<[required]> C<callback>
The callback to call when results come in. This should be a reference to a
subroutine. The callback receives two parameters - the result of the DNS lookup
and the host that was looked up.
=item C<host>
A host name to lookup. Note that if the hostname is a dotted quad of numbers then
a reverse DNS (PTR) lookup is performend.
=item C<hosts>
An array-ref list of hosts to lookup.
B<NOTE:> One of either C<host> or C<hosts> is B<required>.
=item C<client>
It is possible to specify a C<Danga::Client> object (or subclass) which you wish
to disable for reading until your DNS result returns.
=item C<type>
You can specify one of: I<"A">, I<"PTR"> or I<"TXT"> here. Other types may be
supported in the future.
=back
=cut

395
lib/Danga/DNS/Resolver.pm
View File

@ -1,395 +0,0 @@
# $Id: Resolver.pm,v 1.3 2005/02/14 22:06:08 msergeant Exp $
package Danga::DNS::Resolver;
use base qw(Danga::Socket);
use fields qw(res dst cache cache_timeout queries);
use Net::DNS;
use Socket;
use strict;
our $last_cleanup = 0;
sub trace {
my $level = shift;
print ("$::DEBUG/$level [$$] dns lookup: @_") if $::DEBUG >= $level;
}
sub new {
my Danga::DNS::Resolver $self = shift;
$self = fields::new($self) unless ref $self;
my $res = Net::DNS::Resolver->new;
my $sock = IO::Socket::INET->new(
Proto => 'udp',
LocalAddr => $res->{'srcaddr'},
LocalPort => ($res->{'srcport'} || undef),
) || die "Cannot create socket: $!";
IO::Handle::blocking($sock, 0);
$self->{dst} = [];
foreach my $ns (@{ $res->{nameservers} }) {
trace(2, "Using nameserver $ns:$res->{port}\n");
my $dst_sockaddr = sockaddr_in($res->{'port'}, inet_aton($ns));
push @{$self->{dst}}, $dst_sockaddr;
}
$self->{res} = $res;
$self->{queries} = {};
$self->{cache} = {};
$self->{cache_timeout} = {};
$self->SUPER::new($sock);
$self->watch_read(1);
$self->AddTimer(5, sub { $self->_do_cleanup });
return $self;
}
sub ns {
my Danga::DNS::Resolver $self = shift;
my $index = shift;
return if $index > $#{$self->{dst}};
return $self->{dst}->[$index];
}
sub pending {
my Danga::DNS::Resolver $self = shift;
return keys(%{$self->{queries}});
}
sub _query {
my Danga::DNS::Resolver $self = shift;
my ($asker, $host, $type, $now) = @_;
if ($ENV{NODNS}) {
$asker->run_callback("NXDNS", $host);
return 1;
}
if (exists($self->{cache}{$type}{$host}) &&
$self->{cache_timeout}{$type}{$host} >= $now) {
# print "CACHE HIT!\n";
my $result = $self->{cache}{$type}{$host};
$self->AddTimer(0, sub {
$asker->run_callback($result, $host);
});
return 1;
}
my $packet = $self->{res}->make_query_packet($host, $type);
my $packet_data = $packet->data;
my $id = $packet->header->id;
my $query = Danga::DNS::Resolver::Query->new(
$self, $asker, $host, $type, $now, $id, $packet_data,
) or return;
$self->{queries}->{$id} = $query;
return 1;
}
sub query_type {
my Danga::DNS::Resolver $self = shift;
my ($asker, $type, @hosts) = @_;
my $now = time();
trace(2, "Trying to resolve $type: @hosts\n");
foreach my $host (@hosts) {
$self->_query($asker, $host, $type, $now) || return;
}
return 1;
}
sub query_txt {
my Danga::DNS::Resolver $self = shift;
my ($asker, @hosts) = @_;
return $self->query_type($asker, "TXT", @hosts);
}
sub query_mx {
my Danga::DNS::Resolver $self = shift;
my ($asker, @hosts) = @_;
return $self->query_type($asker, "MX", @hosts);
}
sub query {
my Danga::DNS::Resolver $self = shift;
my ($asker, @hosts) = @_;
my $now = time();
trace(2, "trying to resolve A/PTR: @hosts\n");
foreach my $host (@hosts) {
$self->_query($asker, $host, 'A', $now) || return;
}
return 1;
}
sub _do_cleanup {
my Danga::DNS::Resolver $self = shift;
my $now = time;
$self->AddTimer(5, sub { $self->_do_cleanup });
my $idle = $self->max_idle_time;
my @to_delete;
while (my ($id, $obj) = each(%{$self->{queries}})) {
if ($obj->{timeout} < ($now - $idle)) {
push @to_delete, $id;
}
}
foreach my $id (@to_delete) {
my $query = delete $self->{queries}{$id};
$query->timeout() and next;
# add back in if timeout caused us to loop to next server
$self->{queries}->{$id} = $query;
}
foreach my $type ('A', 'TXT', 'MX') {
@to_delete = ();
while (my ($query, $t) = each(%{$self->{cache_timeout}{$type}})) {
if ($t < $now) {
push @to_delete, $query;
}
}
foreach my $q (@to_delete) {
delete $self->{cache_timeout}{$type}{$q};
delete $self->{cache}{$type}{$q};
}
}
}
# seconds max timeout!
sub max_idle_time { 30 }
# Danga::DNS
sub event_err { shift->close("dns socket error") }
sub event_hup { shift->close("dns socket error") }
my %type_to_host = (
PTR => 'ptrdname',
A => 'address',
AAAA => 'address',
TXT => 'txtdata',
NS => 'nsdname',
CNAME => 'cname',
);
sub event_read {
my Danga::DNS::Resolver $self = shift;
while (my $packet = $self->{res}->bgread($self->sock)) {
my $err = $self->{res}->errorstring;
my $answers = 0;
my $header = $packet->header;
my $id = $header->id;
my $qobj = delete $self->{queries}->{$id};
if (!$qobj) {
trace(1, "No query for id: $id\n");
return;
}
my $query = $qobj->{host};
my $now = time();
foreach my $rr ($packet->answer) {
if (my $host_method = $type_to_host{$rr->type}) {
my $host = $rr->$host_method;
my $type = $rr->type;
$type = 'A' if $type eq 'PTR';
# print "DNS Lookup $type $query = $host; TTL = ", $rr->ttl, "\n";
$self->{cache}{$type}{$query} = $host;
$self->{cache_timeout}{$type}{$query} = $now + $rr->ttl;
$qobj->run_callback($host);
}
elsif ($rr->type eq "MX") {
my $host = $rr->exchange;
my $preference = $rr->preference;
$self->{cache}{MX}{$query} = [$host, $preference];
$self->{cache_timeout}{MX}{$query} = $now + $rr->ttl;
$qobj->run_callback([$host, $preference]);
}
else {
# came back, but not a PTR or A record
$qobj->run_callback("UNKNOWN");
}
$answers++;
}
if (!$answers) {
if ($err eq "NXDOMAIN") {
# trace("found => NXDOMAIN\n");
$qobj->run_callback("NXDOMAIN");
}
elsif ($err eq "SERVFAIL") {
# try again???
print "SERVFAIL looking for $query\n";
#$self->query($asker, $query);
$qobj->error($err) and next;
# add back in if error() resulted in query being re-issued
$self->{queries}->{$id} = $qobj;
}
elsif ($err eq "NOERROR") {
$qobj->run_callback($err);
}
elsif($err) {
print("error: $err\n");
$qobj->error($err) and next;
$self->{queries}->{$id} = $qobj;
}
else {
# trace("no answers\n");
$qobj->run_callback("NOANSWER");
}
}
}
}
use Carp qw(confess);
sub close {
my Danga::DNS::Resolver $self = shift;
$self->SUPER::close(shift);
# confess "Danga::DNS::Resolver socket should never be closed!";
}
package Danga::DNS::Resolver::Query;
use fields qw( resolver asker host type timeout id data repeat ns nqueries );
use constant MAX_QUERIES => 10;
sub trace {
my $level = shift;
print ("$::DEBUG/$level [$$] dns lookup: @_") if $::DEBUG >= $level;
}
sub new {
my Danga::DNS::Resolver::Query $self = shift;
$self = fields::new($self) unless ref $self;
@$self{qw( resolver asker host type timeout id data )} = @_;
# repeat is number of retries
@$self{qw( repeat ns nqueries )} = (2,0,0);
trace(2, "NS Query: $self->{host} ($self->{id})\n");
$self->send_query || return;
return $self;
}
#sub DESTROY {
# my $self = shift;
# trace(2, "DESTROY $self\n");
#}
sub timeout {
my Danga::DNS::Resolver::Query $self = shift;
trace(2, "NS Query timeout. Trying next host\n");
if ($self->send_query) {
# had another NS to send to, reset timeout
$self->{timeout} = time();
return;
}
# can we loop/repeat?
if (($self->{nqueries} <= MAX_QUERIES) &&
($self->{repeat} > 1))
{
trace(2, "NS Query timeout. Next host failed. Trying loop\n");
$self->{repeat}--;
$self->{ns} = 0;
return $self->timeout();
}
trace(2, "NS Query timeout. All failed. Running callback(TIMEOUT)\n");
# otherwise we really must timeout.
$self->run_callback("TIMEOUT");
return 1;
}
sub error {
my Danga::DNS::Resolver::Query $self = shift;
my ($error) = @_;
trace(2, "NS Query error. Trying next host\n");
if ($self->send_query) {
# had another NS to send to, reset timeout
$self->{timeout} = time();
return;
}
# can we loop/repeat?
if (($self->{nqueries} <= MAX_QUERIES) &&
($self->{repeat} > 1))
{
trace(2, "NS Query error. Next host failed. Trying loop\n");
$self->{repeat}--;
$self->{ns} = 0;
return $self->error($error);
}
trace(2, "NS Query error. All failed. Running callback($error)\n");
# otherwise we really must timeout.
$self->run_callback($error);
return 1;
}
sub run_callback {
my Danga::DNS::Resolver::Query $self = shift;
trace(2, "NS Query callback($self->{host} = $_[0]\n");
$self->{asker}->run_callback($_[0], $self->{host});
}
sub send_query {
my Danga::DNS::Resolver::Query $self = shift;
my $dst = $self->{resolver}->ns($self->{ns}++);
return unless defined $dst;
if (!$self->{resolver}->sock->send($self->{data}, 0, $dst)) {
return;
}
$self->{nqueries}++;
return 1;
}
1;
=head1 NAME
Danga::DNS::Resolver - an asynchronous DNS resolver class
=head1 SYNOPSIS
my $res = Danga::DNS::Resolver->new();
$res->query($obj, @hosts); # $obj implements $obj->run_callback()
=head1 DESCRIPTION
This is a low level DNS resolver class that works within the Danga::Socket
asynchronous I/O framework. Do not attempt to use this class standalone - use
the C<Danga::DNS> class instead.
=cut

232
lib/Qpsmtpd.pm
View File

@ -4,10 +4,8 @@ use vars qw($VERSION $Logger $TraceLevel $Spool_dir $Size_threshold);
use Sys::Hostname;
use Qpsmtpd::Constants;
use Qpsmtpd::Transaction;
use Qpsmtpd::Connection;
$VERSION = "0.40-dev";
$VERSION = "0.33-dev";
sub version { $VERSION };
@ -17,16 +15,25 @@ sub load_logging {
# need to do this differently that other plugins so as to
# not trigger logging activity
my $self = shift;
#warn("load_logging: $self->{hooks}{logging} ", caller(8), "\n");
return if $self->{hooks}->{"logging"};
my $configdir = $self->config_dir("logging");
my $configfile = "$configdir/logging";
my @loggers = $self->_config_from_file($configfile,'logging');
my $dir = $self->plugin_dir;
$self->_load_plugins($dir, @loggers);
$configdir = $self->config_dir('plugin_dirs');
$configfile = "$configdir/plugin_dirs";
my @plugin_dirs = $self->_config_from_file($configfile,'plugin_dirs');
unless (@plugin_dirs) {
my ($name) = ($0 =~ m!(.*?)/([^/]+)$!);
@plugin_dirs = ( "$name/plugins" );
}
foreach my $logger (@loggers) {
my @loaded;
for my $logger (@loggers) {
push @loaded, $self->_load_plugin($logger, @plugin_dirs);
}
foreach my $logger (@loaded) {
$self->log(LOGINFO, "Loaded $logger");
}
@ -76,9 +83,7 @@ sub varlog {
unless ( $rc and $rc == DECLINED or $rc == OK ) {
# no logging plugins registered so fall back to STDERR
my $fd = $self->fd();
warn join(" ", $$ .
(defined $fd ? " fd:$fd" : "") .
(defined $plugin ? " $plugin plugin:" :
defined $hook ? " running plugin ($hook):" : ""),
@log), "\n"
@ -117,8 +122,8 @@ sub config {
sub config_dir {
my ($self, $config) = @_;
my $configdir = ($ENV{QMAIL} || '/var/qmail') . '/control';
my ($name) = ($0 =~ m!(.*?)/([^/]+)$!);
$configdir = "$name/config" if (-e "$name/config/$config");
my ($path) = ($ENV{PROCESS} ? $ENV{PROCESS} : $0) =~ m!(.*?)/([^/]+)$!;
$configdir = "$path/config" if (-e "$path/config/$config");
if (exists $ENV{QPSMTPD_CONFIG}) {
$ENV{QPSMTPD_CONFIG} =~ /^(.*)$/; # detaint
$configdir = $1 if -e "$1/$config";
@ -126,9 +131,15 @@ sub config_dir {
return $configdir;
}
sub plugin_dir {
my ($name) = ($0 =~ m!(.*?)/([^/]+)$!);
my $dir = "$name/plugins";
sub plugin_dirs {
my $self = shift;
my @plugin_dirs = $self->config('plugin_dirs');
unless (@plugin_dirs) {
my ($path) = ($ENV{PROCESS} ? $ENV{PROCESS} : $0) =~ m!(.*?)/([^/]+)$!;
@plugin_dirs = ( "$path/plugins" );
}
return @plugin_dirs;
}
sub get_qmail_config {
@ -245,33 +256,43 @@ sub expand_inclusion_ {
sub load_plugins {
my $self = shift;
# if ($HOOKS) {
# return $self->{hooks} = $HOOKS;
# }
$self->log(LOGWARN, "Plugins already loaded") if $self->{hooks};
$self->{hooks} = {};
my @plugins = $self->config('plugins');
my @loaded;
my $dir = $self->plugin_dir;
$self->log(LOGNOTICE, "loading plugins from $dir");
for my $plugin_line (@plugins) {
my $this_plugin = $self->_load_plugin($plugin_line, $self->plugin_dirs);
push @loaded, $this_plugin if $this_plugin;
}
@plugins = $self->_load_plugins($dir, @plugins);
# $HOOKS = $self->{hooks};
#
return @plugins;
return @loaded;
}
sub _load_plugins {
sub _load_plugin {
my $self = shift;
my ($dir, @plugins) = @_;
my ($plugin_line, @plugin_dirs) = @_;
my @ret;
for my $plugin_line (@plugins) {
my ($plugin, @args) = split ' ', $plugin_line;
my $package;
if ($plugin =~ m/::/) {
# "full" package plugin (My::Plugin)
$package = $plugin;
$package =~ s/[^_a-z0-9:]+//gi;
my $eval = qq[require $package;\n]
.qq[sub ${plugin}::plugin_name { '$plugin' }];
$eval =~ m/(.*)/s;
$eval = $1;
eval $eval;
die "Failed loading $package - eval $@" if $@;
$self->log(LOGDEBUG, "Loading $package ($plugin_line)")
unless $plugin_line =~ /logging/;
}
else {
# regular plugins/$plugin plugin
my $plugin_name = $plugin;
$plugin =~ s/:\d+$//; # after this point, only used for filename
@ -286,70 +307,50 @@ sub _load_plugins {
"::" . (length $2 ? sprintf("_%2x",unpack("C",$2)) : "")
]egx;
my $package = "Qpsmtpd::Plugin::$plugin_name";
$package = "Qpsmtpd::Plugin::$plugin_name";
# don't reload plugins if they are already loaded
unless ( defined &{"${package}::plugin_name"} ) {
Qpsmtpd::Plugin->compile($plugin_name,
$package, "$dir/$plugin", $self->{_test_mode});
$self->log(LOGDEBUG, "Loading $plugin_line")
PLUGIN_DIR: for my $dir (@plugin_dirs) {
if (-e "$dir/$plugin") {
Qpsmtpd::Plugin->compile($plugin_name, $package,
"$dir/$plugin", $self->{_test_mode});
$self->log(LOGDEBUG, "Loading $plugin_line from $dir/$plugin")
unless $plugin_line =~ /logging/;
last PLUGIN_DIR;
}
else {
$self->log(LOGDEBUG, "Failed to load plugin - $plugin - ignoring");
return 0;
}
}
}
}
my $plug = $package->new();
push @ret, $plug;
$plug->_register($self, @args);
}
return @ret;
return $plug;
}
sub transaction {
my $self = shift;
return $self->{_transaction} || $self->reset_transaction();
}
sub reset_transaction {
my $self = shift;
$self->run_hooks("reset_transaction") if $self->{_transaction};
return $self->{_transaction} = Qpsmtpd::Transaction->new();
}
sub connection {
my $self = shift;
@_ and $self->{_connection} = shift;
return $self->{_connection} || ($self->{_connection} = Qpsmtpd::Connection->new());
return {}; # base class implements empty transaction
}
sub run_hooks {
my ($self, $hook) = (shift, shift);
if ($self->{_continuation} && $hook ne "logging" && $hook ne "config") {
die "Continuations in progress from previous hook (this is the $hook hook)";
}
my $hooks = $self->{hooks};
if ($hooks->{$hook}) {
my @r;
my @local_hooks = @{$hooks->{$hook}};
while (@local_hooks) {
my $code = shift @local_hooks;
@r = $self->run_hook($hook, $code, @_);
next unless @r;
if ($r[0] == CONTINUATION) {
$self->pause_read() if $self->isa('Danga::Client');
$self->{_continuation} = [$hook, [@_], @local_hooks];
return $self->run_continuation();
}
last unless $r[0] == DECLINED;
}
$r[0] = DECLINED if not defined $r[0];
return @r;
}
return (0, '');
return $self->hook_responder($hook, [0, ''], [@_]);
}
sub finish_continuation {
my ($self) = @_;
sub run_continuation {
my $self = shift;
die "No continuation in progress" unless $self->{_continuation};
$self->continue_read() if $self->isa('Danga::Client');
my $todo = $self->{_continuation};
@ -359,61 +360,70 @@ sub finish_continuation {
my @r;
while (@$todo) {
my $code = shift @$todo;
@r = $self->run_hook($hook, $code, @$args);
if ($r[0] == CONTINUATION) {
$self->pause_read() if $self->isa('Danga::Client');
$self->{_continuation} = [$hook, $args, @$todo];
return @r;
}
last unless $r[0] == DECLINED;
}
$r[0] = DECLINED if not defined $r[0];
my $responder = $hook . "_respond";
if (my $meth = $self->can($responder)) {
$self->log(LOGNOTICE, "continuation finished on $self\n");
return $meth->($self, $r[0], $r[1], @$args);
}
die "No ${hook}_respond method";
}
sub run_hook {
my ($self, $hook, $code, @args) = @_;
my @r;
if ( $hook eq 'logging' ) { # without calling $self->log()
eval { (@r) = $code->{code}->($self, $self->{_transaction}, @args); };
eval { (@r) = $code->{code}->($self, $self->transaction, @$args); };
$@ and warn("FATAL LOGGING PLUGIN ERROR: ", $@) and next;
}
else {
$self->varlog(LOGINFO, $hook, $code->{name});
eval { (@r) = $code->{code}->($self, $self->transaction, @args); };
$@ and $self->log(LOGCRIT, "FATAL PLUGIN ERROR: ", $@) and return;
$self->varlog(LOGDEBUG, $hook, $code->{name});
eval { (@r) = $code->{code}->($self, $self->transaction, @$args); };
$@ and $self->log(LOGCRIT, "FATAL PLUGIN ERROR: ", $@) and next;
!defined $r[0]
and $self->log(LOGERROR, "plugin ".$code->{name}
."running the $hook hook returned undef!")
and return;
." running the $hook hook returned undef!")
and next;
if ($self->transaction) {
my $tnotes = $self->transaction->notes( $code->{name} );
$tnotes->{"hook_$hook"}->{'return'} = $r[0]
if (!defined $tnotes || ref $tnotes eq "HASH");
} else {
}
else {
my $cnotes = $self->connection->notes( $code->{name} );
$cnotes->{"hook_$hook"}->{'return'} = $r[0]
if (!defined $cnotes || ref $cnotes eq "HASH");
}
# should we have a hook for "OK" too?
if ($r[0] == DENY or $r[0] == DENYSOFT or
if ($r[0] == YIELD) {
$self->pause_read() if $self->isa('Danga::Client');
$self->{_continuation} = [$hook, $args, @$todo];
return @r;
}
elsif ($r[0] == DENY or $r[0] == DENYSOFT or
$r[0] == DENY_DISCONNECT or $r[0] == DENYSOFT_DISCONNECT)
{
$r[1] = "" if not defined $r[1];
$self->log(LOGDEBUG, "Plugin $code->{name}, hook $hook returned $r[0], $r[1]");
$self->log(LOGDEBUG, "Plugin ".$code->{name}.
", hook $hook returned ".return_code($r[0]).", $r[1]");
$self->run_hooks("deny", $code->{name}, $r[0], $r[1]) unless ($hook eq "deny");
}
else {
$r[1] = "" if not defined $r[1];
$self->log(LOGDEBUG, "Plugin ".$code->{name}.
", hook $hook returned ".return_code($r[0]).", $r[1]");
$self->run_hooks("ok", $code->{name}, $r[0], $r[1]) unless ($hook eq "ok");
}
}
return @r;
last unless $r[0] == DECLINED;
}
$r[0] = DECLINED if not defined $r[0];
@r = map { split /\n/ } @r;
return $self->hook_responder($hook, \@r, $args);
}
sub hook_responder {
my ($self, $hook, $msg, $args) = @_;
my $code = shift @$msg;
my $responder = $hook . '_respond';
if (my $meth = $self->can($responder)) {
return $meth->($self, $code, $msg, $args);
}
return $code, @$msg;
}
sub _register_hook {
@ -487,34 +497,16 @@ sub size_threshold {
return $Size_threshold;
}
sub authenticated {
my ($self, $state) = @_;
$self->{_auth_state} = $state if $state;
return (defined $self->{_auth_state} ? $self->{_auth_state} : 0);
}
sub auth_user {
my ($self, $user) = @_;
$self->{_auth_user} = $user if $user;
my $self = shift;
return (defined $self->{_auth_user} ? $self->{_auth_user} : "" );
}
sub auth_ticket {
my ($self, $ticket) = @_;
$self->{_auth_ticket} = $ticket if $ticket;
return (defined $self->{_auth_ticket} ? $self->{_auth_ticket} : "" );
}
sub auth_mechanism {
my ($self, $mechanism) = @_;
$self->{_auth_mechanism} = lc($mechanism) if $mechanism;
my $self = shift;
return (defined $self->{_auth_mechanism} ? $self->{_auth_mechanism} : "" );
}
sub fd {
return shift->{fd};
}
1;
__END__

7
lib/Qpsmtpd/Address.pm
View File

@ -60,7 +60,8 @@ sub new {
my ($class, $user, $host) = @_;
my $self = {};
if ($user =~ /^<(.*)>$/ ) {
($user, $host) = $class->canonify($user)
($user, $host) = $class->canonify($user);
return undef unless defined $user;
}
elsif ( not defined $host ) {
my $address = $user;
@ -308,8 +309,8 @@ sub _addr_cmp {
}
#invert the address so we can sort by domain then user
$left = lc($left->host.'='.$left->user);
$right = lc($right->host.'='.$right->user);
($left = join( '=', reverse( split('@', $left->format))) ) =~ tr/[<>]//d;
($right = join( '=', reverse( split('@',$right->format))) ) =~ tr/[<>]//d;
if ( $swap ) {
($right, $left) = ($left, $right);

125
lib/Qpsmtpd/Auth.pm Normal file
View File

@ -0,0 +1,125 @@
# See the documentation in 'perldoc README.authentication'
package Qpsmtpd::Auth;
use Qpsmtpd::Constants;
use MIME::Base64;
sub e64
{
my ($arg) = @_;
my $res = encode_base64($arg);
chomp($res);
return($res);
}
sub SASL {
# $DB::single = 1;
my ( $session, $mechanism, $prekey ) = @_;
my ( $user, $passClear, $passHash, $ticket, $loginas );
if ( $mechanism eq "plain" ) {
if (!$prekey) {
$session->respond( 334, "Please continue" );
$prekey= <STDIN>;
}
( $loginas, $user, $passClear ) = split /\x0/,
decode_base64($prekey);
# Authorization ID must not be different from
# Authentication ID
if ( $loginas ne '' && $loginas ne $user ) {
$session->respond(535, "Authentication invalid");
return DECLINED;
}
}
elsif ($mechanism eq "login") {
if ( $prekey ) {
$user = decode_base64($prekey);
}
else {
$session->respond(334, e64("Username:"));
$user = decode_base64(<STDIN>);
if ($user eq '*') {
$session->respond(501, "Authentification canceled");
return DECLINED;
}
}
$session->respond(334, e64("Password:"));
$passClear = <STDIN>;
$passClear = decode_base64($passClear);
if ($passClear eq '*') {
$session->respond(501, "Authentification canceled");
return DECLINED;
}
}
elsif ( $mechanism eq "cram-md5" ) {
# rand() is not cryptographic, but we only need to generate a globally
# unique number. The rand() is there in case the user logs in more than
# once in the same second, of if the clock is skewed.
$ticket = sprintf( "<%x.%x\@" . $session->config("me") . ">",
rand(1000000), time() );
# We send the ticket encoded in Base64
$session->respond( 334, encode_base64( $ticket, "" ) );
my $line = <STDIN>;
if ( $line eq '*' ) {
$session->respond( 501, "Authentification canceled" );
return DECLINED;
}
( $user, $passHash ) = split( ' ', decode_base64($line) );
}
else {
#this error is now caught in SMTP.pm's sub auth
$session->respond( 500, "Internal server error" );
return DECLINED;
}
# Make sure that we have enough information to proceed
unless ( $user && ($passClear || $passHash) ) {
$session->respond(504, "Invalid authentification string");
return DECLINED;
}
# try running the specific hooks first
my ( $rc, $msg ) =
$session->run_hooks( "auth-$mechanism", $mechanism, $user, $passClear,
$passHash, $ticket );
# try running the polymorphous hooks next
if ( !$rc || $rc == DECLINED ) {
( $rc, $msg ) =
$session->run_hooks( "auth", $mechanism, $user, $passClear,
$passHash, $ticket );
}
if ( $rc == OK ) {
$msg = "Authentication successful for $user" .
( defined $msg ? " - " . $msg : "" );
$session->respond( 235, $msg );
$session->connection->relay_client(1);
$session->log( LOGINFO, $msg );
$session->{_auth_user} = $user;
$session->{_auth_mechanism} = $mechanism;
s/[\r\n].*//s for ($session->{_auth_user}, $session->{_auth_mechanism});
return OK;
}
else {
$msg = "Authentication failed for $user" .
( defined $msg ? " - " . $msg : "" );
$session->respond( 535, $msg );
$session->log( LOGERROR, $msg );
return DENY;
}
}
# tag: qpsmtpd plugin that sets RELAYCLIENT when the user authentifies
1;

170
lib/Qpsmtpd/Command.pm Normal file
View File

@ -0,0 +1,170 @@
package Qpsmtpd::Command;
=head1 NAME
Qpsmtpd::Command - parse arguments to SMTP commands
=head1 DESCRIPTION
B<Qpsmtpd::Command> provides just one public sub routine: B<parse()>.
This sub expects two or three arguments. The first is the name of the
SMTP command (such as I<HELO>, I<MAIL>, ...). The second must be the remaining
of the line the client sent.
If no third argument is given (or it's not a reference to a CODE) it parses
the line according to RFC 1869 (SMTP Service Extensions) for the I<MAIL> and
I<RCPT> commands and splitting by spaces (" ") for all other.
Any module can supply it's own parsing routine by returning a sub routine
reference from a hook_*_parse. This sub will be called with I<$self>, I<$cmd>
and I<$line>.
On successfull parsing it MUST return B<OK> (the constant from
I<Qpsmtpd::Constants>) success as first argument and a list of
values, which will be the arguments to the hook for this command.
If parsing failed, the second returned value (if any) will be returned to the
client as error message.
=head1 EXAMPLE
Inside a plugin
sub hook_unrecognized_command_parse {
my ($self, $transaction, $cmd) = @_;
return (OK, \&bdat_parser) if ($cmd eq 'bdat');
}
sub bdat_parser {
my ($self,$cmd,$line) = @_;
# .. do something with $line...
return (DENY, "Invalid arguments")
if $some_reason_why_there_is_a_syntax_error;
return (OK, @args);
}
sub hook_unrecognized_command {
my ($self, $transaction, $cmd, @args) = @_;
return (DECLINED) if ($self->qp->connection->hello eq 'helo');
return (DECLINED) unless ($cmd eq 'bdat');
....
}
=cut
use Qpsmtpd::Constants;
use vars qw(@ISA);
@ISA = qw(Qpsmtpd::SMTP);
use strict;
sub parse {
my ($me,$cmd,$line,$sub) = @_;
return (OK) unless defined $line; # trivial case
my $self = {};
bless $self, $me;
$cmd = lc $cmd;
if ($sub and (ref($sub) eq 'CODE')) {
my @ret = eval { $sub->($self, $cmd, $line); };
if ($@) {
$self->log(LOGERROR, "Failed to parse command [$cmd]: $@");
return (DENY, $line, ());
}
## my @log = @ret;
## for (@log) {
## $_ ||= "";
## }
## $self->log(LOGDEBUG, "parse($cmd) => [".join("], [", @log)."]");
return @ret;
}
my $parse = "parse_$cmd";
if ($self->can($parse)) {
# print "CMD=$cmd,line=$line\n";
my @out = eval { $self->$parse($cmd, $line); };
if ($@) {
$self->log(LOGERROR, "$parse($cmd,$line) failed: $@");
return(DENY, "Failed to parse line");
}
return @out;
}
return(OK, split(/ +/, $line)); # default :)
}
sub parse_rcpt {
my ($self,$cmd,$line) = @_;
return (DENY, "Syntax error in command") unless $line =~ s/^to:\s*//i;
return &_get_mail_params($cmd, $line);
}
sub parse_mail {
my ($self,$cmd,$line) = @_;
return (DENY, "Syntax error in command") unless $line =~ s/^from:\s*//i;
return &_get_mail_params($cmd, $line);
}
### RFC 1869:
## 6. MAIL FROM and RCPT TO Parameters
## [...]
##
## esmtp-cmd ::= inner-esmtp-cmd [SP esmtp-parameters] CR LF
## esmtp-parameters ::= esmtp-parameter *(SP esmtp-parameter)
## esmtp-parameter ::= esmtp-keyword ["=" esmtp-value]
## esmtp-keyword ::= (ALPHA / DIGIT) *(ALPHA / DIGIT / "-")
##
## ; syntax and values depend on esmtp-keyword
## esmtp-value ::= 1*<any CHAR excluding "=", SP, and all
## control characters (US ASCII 0-31
## inclusive)>
##
## ; The following commands are extended to
## ; accept extended parameters.
## inner-esmtp-cmd ::= ("MAIL FROM:" reverse-path) /
## ("RCPT TO:" forward-path)
sub _get_mail_params {
my ($cmd,$line) = @_;
my @params = ();
$line =~ s/\s*$//;
while ($line =~ s/\s+([A-Za-z0-9][A-Za-z0-9\-]*(=[^= \x00-\x1f]+)?)$//) {
push @params, $1;
}
@params = reverse @params;
# the above will "fail" (i.e. all of the line in @params) on
# some addresses without <> like
# MAIL FROM: user=name@example.net
# or RCPT TO: postmaster
# let's see if $line contains nothing and use the first value as address:
if ($line) {
# parameter syntax error, i.e. not all of the arguments were
# stripped by the while() loop:
return (DENY, "Syntax error in parameters")
if ($line =~ /\@.*\s/);
return (OK, $line, @params);
}
$line = shift @params;
if ($cmd eq "mail") {
return (OK, "<>") unless $line; # 'MAIL FROM:' --> 'MAIL FROM:<>'
return (DENY, "Syntax error in parameters")
if ($line =~ /\@.*\s/); # parameter syntax error
}
else {
if ($line =~ /\@/) {
return (DENY, "Syntax error in parameters")
if ($line =~ /\@.*\s/);
}
else {
# XXX: what about 'abuse' in Qpsmtpd::Address?
return (DENY, "Syntax error in parameters") if $line =~ /\s/;
return (DENY, "Syntax error in address")
unless ($line =~ /^(postmaster|abuse)$/i);
}
}
## XXX: No: let this do a plugin, so it's not up to us to decide
## if we require <> around an address :-)
## unless ($line =~ /^<.*>$/) { $line = "<".$line.">"; }
return (OK, $line, @params);
}
1;

6
lib/Qpsmtpd/ConfigServer.pm
View File

@ -121,6 +121,10 @@ sub cmd_quit {
$self->close;
}
sub cmd_shutdown {
exit;
}
sub cmd_pause {
my $self = shift;
@ -169,7 +173,7 @@ sub cmd_status {
if ($pob->isa("Qpsmtpd::PollServer")) {
$current_connections++;
}
elsif ($pob->isa("Danga::DNS::Resolver")) {
elsif ($pob->isa("ParaDNS::Resolver")) {
$current_dns = $pob->pending;
}
}

32
lib/Qpsmtpd/Connection.pm
View File

@ -136,6 +136,14 @@ These API docs assume you already have a connection object. See the
source code if you need to construct one. You can access the connection
object via the C<Qpsmtpd> object's C<< $qp->connection >> method.
=head2 new ( )
Instantiates a new Qpsmtpd::Connection object.
=head2 start ( %args )
Initializes the connection object with %args attribute data.
=head2 remote_host( )
The remote host connecting to the server as looked up via reverse dns.
@ -144,11 +152,25 @@ The remote host connecting to the server as looked up via reverse dns.
The remote IP address of the connecting host.
=head2 remote_port( )
The remote port.
=head2 hello( )
=head2 remote_info( )
If your server does an ident lookup on the remote host, this is the
identity of the remote client.
=head2 local_ip( )
The local ip.
=head2 local_port( )
The local port.
=head2 hello( )
Either C<"helo"> or C<"ehlo"> depending on how the remote client
@ -168,4 +190,14 @@ set after a successful return from those hooks.
Connection-wide notes, used for passing data between plugins.
=head2 clone( )
Returns a copy of the Qpsmtpd::Connection object.
=cut
=head2 relay_client( )
True if the client is allowed to relay messages.
=cut

22
lib/Qpsmtpd/Constants.pm
View File

@ -25,10 +25,28 @@ my %return_codes = (
DENYSOFT_DISCONNECT => 904, # 450 + disconnect
DECLINED => 909,
DONE => 910,
CONTINUATION => 911,
AUTH_PENDING => 912,
CONTINUATION => 911, # deprecated - use YIELD
YIELD => 911,
);
my $has_ipv6;
if (
eval {require Socket6;} &&
# INET6 prior to 2.01 will not work; sorry.
eval {require IO::Socket::INET6; IO::Socket::INET6->VERSION("2.00");}
) {
import Socket6;
$has_ipv6=1;
}
else {
$has_ipv6=0;
}
sub has_ipv6 {
return $has_ipv6;
}
use vars qw(@ISA @EXPORT);
@ISA = qw(Exporter);
@EXPORT = (keys(%return_codes), keys(%log_levels), "return_code", "log_level");

621
lib/Qpsmtpd/DSN.pm Normal file
View File

@ -0,0 +1,621 @@
#
# Enhanced Mail System Status Codes - RFC 1893
#
package Qpsmtpd::DSN;
use strict;
use Qpsmtpd::Constants;
=head1 NAME
Qpsmtpd::DSN - Enhanced Mail System Status Codes - RFC 1893
=head1 DESCRIPTION
The B<Qpsmtpd::DSN> implements the I<Enhanced Mail System Status Codes> from
RFC 1893.
=head1 USAGE
Any B<qpsmtpd> plugin can access these status codes. All sub routines are used
the same way:
use Qpsmtpd::DSN;
...;
return Qpsmtpd::DSN->relaying_denied();
or
return Qpsmtpd::DSN->relaying_denied("Relaying from $ip denied");
or
return Qpsmtpd::DSN->relaying_denied(DENY,"Relaying from $ip denied");
If no status message was given, it will use the predefined one from the
RFC. If the first argument is numeric, it will use this as a return code,
else the default return code is used. See below which default return code
is used in the different functions.
The first example will return
I<(DENY, "Relaying denied");>
the others
I<(DENY, "Relaying from $ip denied");>
which will be returned to qpsmtpd.
In those sub routines which don't start with I<addr_, sys_, net_, proto_,
media_, sec_> I've added a default message which describes the status better
than the RFC message.
=cut
my @rfc1893 = (
[
"Other or Undefined Status", # x.0.x
],
[
"Other address status.", # x.1.0
"Bad destination mailbox address.", # x.1.1
"Bad destination system address.", # x.1.2
"Bad destination mailbox address syntax.", # x.1.3
"Destination mailbox address ambiguous.", # x.1.4
"Destination address valid.", # x.1.5
"Destination mailbox has moved, No forwarding address.", # x.1.6
"Bad sender's mailbox address syntax.", # x.1.7
"Bad sender's system address.", # x.1.8
],
[
"Other or undefined mailbox status.", # x.2.0
"Mailbox disabled, not accepting messages.", # x.2.1
"Mailbox full.", # x.2.2
"Message length exceeds administrative limit.", # x.2.3
"Mailing list expansion problem.", # x.2.4
],
[
"Other or undefined mail system status.", # x.3.0
"Mail system full.", # x.3.1
"System not accepting network messages.", # x.3.2
"System not capable of selected features.", # x.3.3
"Message too big for system.", # x.3.4
"System incorrectly configured.", # x.3.5
],
[
"Other or undefined network or routing status.", # x.4.0
"No answer from host.", # x.4.1
"Bad connection.", # x.4.2
"Directory server failure.", # x.4.3
"Unable to route.", # x.4.4
"Mail system congestion.", # x.4.5
"Routing loop detected.", # x.4.6
"Delivery time expired.", # x.4.7
],
[
"Other or undefined protocol status.", # x.5.0
"Invalid command.", # x.5.1
"Syntax error.", # x.5.2
"Too many recipients.", # x.5.3
"Invalid command arguments.", # x.5.4
"Wrong protocol version.", # x.5.5
],
[
"Other or undefined media error.", # x.6.0
"Media not supported.", # x.6.1
"Conversion required and prohibited.", # x.6.2
"Conversion required but not supported.", # x.6.3
"Conversion with loss performed.", # x.6.4
"Conversion Failed.", # x.6.5
],
[
"Other or undefined security status.", # x.7.0
"Delivery not authorized, message refused.", # x.7.1
"Mailing list expansion prohibited.", # x.7.2
"Security conversion required but not possible.", # x.7.3
"Security features not supported.", # x.7.4
"Cryptographic failure.", # x.7.5
"Cryptographic algorithm not supported.", # x.7.6
"Message integrity failure.", # x.7.7
],
);
sub _status {
my $return = shift;
my $const = Qpsmtpd::Constants::return_code($return);
if ($const =~ /^DENYSOFT/) {
return 4;
}
elsif ($const =~ /^DENY/) {
return 5;
}
elsif ($const eq 'OK' or $const eq 'DONE') {
return 2;
}
else { # err .... no :)
return 4; # just 2,4,5 are allowed.. temp error by default
}
}
sub _dsn {
my ($self,$return,$reason,$default,$subject,$detail) = @_;
if (!defined $return) {
$return = $default;
}
elsif ($return !~ /^\d+$/) {
$reason = $return;
$return = $default;
}
my $msg = $rfc1893[$subject][$detail];
unless (defined $msg) {
$detail = 0;
$msg = $rfc1893[$subject][$detail];
unless (defined $msg) {
$subject = 0;
$msg = $rfc1893[$subject][$detail];
}
}
my $class = &_status($return);
if (defined $reason) {
$msg = $reason;
}
return ($return, "$msg (#$class.$subject.$detail)");
}
sub unspecified { shift->_dsn(shift,shift,DENYSOFT,0,0); }
=head1 ADDRESS STATUS
=over 9
=item addr_unspecified
X.1.0
default: DENYSOFT
=cut
sub addr_unspecified { shift->_dsn(shift,shift,DENYSOFT,1,0); }
=item no_such_user, addr_bad_dest_mbox
X.1.1
default: DENY
=cut
sub no_such_user { shift->_dsn(shift,(shift||"No such user"),DENY,1,1); }
sub addr_bad_dest_mbox { shift->_dsn(shift,shift,DENY,1,1); }
=item addr_bad_dest_system
X.1.2
default: DENY
=cut
sub addr_bad_dest_system { shift->_dsn(shift,shift,DENY,1,2); }
=item addr_bad_dest_syntax
X.1.3
default: DENY
=cut
sub addr_bad_dest_syntax { shift->_dsn(shift,shift,DENY,1,3); }
=item addr_dest_ambigous
X.1.4
default: DENYSOFT
=cut
sub addr_dest_ambigous { shift->_dsn(shift,shift,DENYSOFT,1,4); }
=item addr_rcpt_ok
X.1.5
default: OK
=cut
# XXX: do we need this? Maybe in all address verifying plugins?
sub addr_rcpt_ok { shift->_dsn(shift,shift,OK,1,5); }
=item addr_mbox_moved
X.1.6
default: DENY
=cut
sub addr_mbox_moved { shift->_dsn(shift,shift,DENY,1,6); }
=item addr_bad_from_syntax
X.1.7
default: DENY
=cut
sub addr_bad_from_syntax { shift->_dsn(shift,shift,DENY,1,7); }
=item addr_bad_from_system
X.1.8
default: DENY
=back
=cut
sub addr_bad_from_system { shift->_dsn(shift,shift,DENY,1,8); }
=head1 MAILBOX STATUS
=over 5
=item mbox_unspecified
X.2.0
default: DENYSOFT
=cut
sub mbox_unspecified { shift->_dsn(shift,shift,DENYSOFT,2,0); }
=item mbox_disabled
X.2.1
default: DENY ...but RFC says:
The mailbox exists, but is not accepting messages. This may
be a permanent error if the mailbox will never be re-enabled
or a transient error if the mailbox is only temporarily
disabled.
=cut
sub mbox_disabled { shift->_dsn(shift,shift,DENY,2,1); }
=item mbox_full
X.2.2
default: DENYSOFT
=cut
sub mbox_full { shift->_dsn(shift,shift,DENYSOFT,2,2); }
=item mbox_msg_too_long
X.2.3
default: DENY
=cut
sub mbox_msg_too_long { shift->_dsn(shift,shift,DENY,2,3); }
=item mbox_list_expansion_problem
X.2.4
default: DENYSOFT
=back
=cut
sub mbox_list_expansion_problem { shift->_dsn(shift,shift,DENYSOFT,2,4); }
=head1 MAIL SYSTEM STATUS
=over 4
=item sys_unspecified
X.3.0
default: DENYSOFT
=cut
sub sys_unspecified { shift->_dsn(shift,shift,DENYSOFT,3,0); }
=item sys_disk_full
X.3.1
default: DENYSOFT
=cut
sub sys_disk_full { shift->_dsn(shift,shift,DENYSOFT,3,1); }
=item sys_not_accepting_mail
X.3.2
default: DENYSOFT
=cut
sub sys_not_accepting_mail { shift->_dsn(shift,shift,DENYSOFT,3,2); }
=item sys_not_supported
X.3.3
default: DENYSOFT
Selected features specified for the message are not
supported by the destination system. This can occur in
gateways when features from one domain cannot be mapped onto
the supported feature in another.
=cut
sub sys_not_supported { shift->_dsn(shift,shift,DENYSOFT,3,3); }
=item sys_msg_too_big
X.3.4
default DENY
=back
=cut
sub sys_msg_too_big { shift->_dsn(shift,shift,DENY,3,4); }
=head1 NETWORK AND ROUTING STATUS
=cut
=over 4
=item net_unspecified
X.4.0
default: DENYSOFT
=cut
sub net_unspecified { shift->_dsn(shift,shift,DENYSOFT,4,0); }
# not useful # sub net_no_answer { shift->_dsn(shift,shift,4,1); }
# not useful # sub net_bad_connection { shift->_dsn(shift,shift,4,2); }
=item net_directory_server_failed, temp_resolver_failed
X.4.3
default: DENYSOFT
=cut
sub temp_resolver_failed {
shift->_dsn(shift,
(shift || "Temporary address resolution failure"),
DENYSOFT,4,3);
}
sub net_directory_server_failed { shift->_dsn(shift,shift,DENYSOFT,4,3); }
# not useful # sub net_unable_to_route { shift->_dsn(shift,shift,4,4); }
=item net_system_congested
X.4.5
default: DENYSOFT
=cut
sub net_system_congested { shift->_dsn(shift,shift,DENYSOFT,4,5); }
=item net_routing_loop, too_many_hops
X.4.6
default: DENY, but RFC says:
A routing loop caused the message to be forwarded too many
times, either because of incorrect routing tables or a user
forwarding loop. This is useful only as a persistent
transient error.
Why do we want to DENYSOFT something like this?
=back
=cut
sub net_routing_loop { shift->_dsn(shift,shift,DENY,4,6); }
sub too_many_hops { shift->_dsn(shift,(shift || "Too many hops"),DENY,4,6,); }
# not useful # sub delivery_time_expired { shift->_dsn(shift,shift,4,7); }
=head1 MAIL DELIVERY PROTOCOL STATUS
=over 6
=item proto_unspecified
X.5.0
default: DENYSOFT
=cut
sub proto_unspecified { shift->_dsn(shift,shift,DENYSOFT,5,0); }
=item proto_invalid_command
X.5.1
default: DENY
=cut
sub proto_invalid_command { shift->_dsn(shift,shift,DENY,5,1); }
=item proto_syntax_error
X.5.2
default: DENY
=cut
sub proto_syntax_error { shift->_dsn(shift,shift,DENY,5,2); }
=item proto_rcpt_list_too_long, too_many_rcpts
X.5.3
default: DENYSOFT
=cut
sub proto_rcpt_list_too_long { shift->_dsn(shift,shift,DENYSOFT,5,3); }
sub too_many_rcpts { shift->_dsn(shift,shift,DENYSOFT,5,3); }
=item proto_invalid_cmd_args
X.5.4
default: DENY
=cut
sub proto_invalid_cmd_args { shift->_dsn(shift,shift,DENY,5,4); }
=item proto_wrong_version
X.5.5
default: DENYSOFT
=back
=cut
sub proto_wrong_version { shift->_dsn(shift,shift,DENYSOFT,5,5); }
=head1 MESSAGE CONTENT OR MESSAGE MEDIA STATUS
=over 5
=item media_unspecified
X.6.0
default: DENYSOFT
=cut
sub media_unspecified { shift->_dsn(shift,shift,DENYSOFT,6,0); }
=item media_unsupported
X.6.1
default: DENY
=cut
sub media_unsupported { shift->_dsn(shift,shift,DENY,6,1); }
=item media_conv_prohibited
X.6.2
default: DENY
=cut
sub media_conv_prohibited { shift->_dsn(shift,shift,DENY,6,2); }
=item media_conv_unsupported
X.6.3
default: DENYSOFT
=cut
sub media_conv_unsupported { shift->_dsn(shift,shift,DENYSOFT,6,3); }
=item media_conv_lossy
X.6.4
default: DENYSOFT
=back
=cut
sub media_conv_lossy { shift->_dsn(shift,shift,DENYSOFT,6,4); }
=head1 SECURITY OR POLICY STATUS
=over 8
=item sec_unspecified
X.7.0
default: DENYSOFT
=cut
sub sec_unspecified { shift->_dsn(shift,shift,DENYSOFT,7,0); }
=item sec_sender_unauthorized, bad_sender_ip, relaying_denied
X.7.1
default: DENY
=cut
sub sec_sender_unauthorized { shift->_dsn(shift,shift,DENY,7,1); }
sub bad_sender_ip {
shift->_dsn(shift,(shift || "Bad sender's IP"),DENY,7,1,);
}
sub relaying_denied {
shift->_dsn(shift,(shift || "Relaying denied"),DENY,7,1);
}
=item sec_list_dest_prohibited
X.7.2
default: DENY
=cut
sub sec_list_dest_prohibited { shift->_dsn(shift,shift,DENY,7,2); }
=item sec_conv_failed
X.7.3
default: DENY
=cut
sub sec_conv_failed { shift->_dsn(shift,shift,DENY,7,3); }
=item sec_feature_unsupported
X.7.4
default: DENY
=cut
sub sec_feature_unsupported { shift->_dsn(shift,shift,DENY,7,4); }
=item sec_crypto_failure
X.7.5
default: DENY
=cut
sub sec_crypto_failure { shift->_dsn(shift,shift,DENY,7,5); }
=item sec_crypto_algorithm_unsupported
X.7.6
default: DENYSOFT
=cut
sub sec_crypto_algorithm_unsupported { shift->_dsn(shift,shift,DENYSOFT,7,6); }
=item sec_msg_integrity_failure
X.7.7
default: DENY
=back
=cut
sub sec_msg_integrity_failure { shift->_dsn(shift,shift,DENY,7,7); }
1;
# vim: st=4 sw=4 expandtab

41
lib/Qpsmtpd/Plugin.pm
View File

@ -2,11 +2,14 @@ package Qpsmtpd::Plugin;
use Qpsmtpd::Constants;
use strict;
# more or less in the order they will fire
our @hooks = qw(
logging config queue data data_post quit rcpt mail ehlo helo
auth auth-plain auth-login auth-cram-md5
connect reset_transaction unrecognized_command disconnect
deny ok pre-connection post-connection
logging config pre-connection connect ehlo_parse ehlo
helo_parse helo auth_parse auth auth-plain auth-login auth-cram-md5
rcpt_parse rcpt_pre rcpt mail_parse mail mail_pre
data data_post queue_pre queue queue_post
quit reset_transaction disconnect post-connection
unrecognized_command deny ok
);
our %hooks = map { $_ => 1 } @hooks;
@ -16,6 +19,10 @@ sub new {
bless ({}, $class);
}
sub hook_name {
return shift->{_hook};
}
sub register_hook {
my ($plugin, $hook, $method, $unshift) = @_;
@ -26,7 +33,12 @@ sub register_hook {
# 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, { code => sub { local $plugin->{_qp} = shift; local $plugin->{_hook} = $hook; $plugin->$method(@_) },
$plugin->qp->_register_hook
($hook,
{ code => sub { local $plugin->{_qp} = shift;
local $plugin->{_hook} = $hook;
$plugin->$method(@_)
},
name => $plugin->plugin_name,
},
$unshift,
@ -42,18 +54,10 @@ sub _register {
$self->register($qp, @_) if $self->can('register');
}
# Designed to be overloaded
sub init {}
sub register {}
sub qp {
shift->{_qp};
}
sub fd {
shift->qp->fd();
}
sub log {
my $self = shift;
$self->qp->varlog(shift, $self->hook_name, $self->plugin_name, @_)
@ -69,20 +73,16 @@ sub connection {
shift->qp->connection;
}
sub config {
shift->qp->config(@_);
}
sub spool_dir {
shift->qp->spool_dir;
}
sub auth_user {
shift->qp->auth_user(@_);
shift->qp->auth_user;
}
sub auth_mechanism {
shift->qp->auth_mechanism(@_);
shift->qp->auth_mechanism;
}
sub temp_file {
@ -120,7 +120,7 @@ sub isa_plugin {
$self->compile($self->plugin_name . "_isa_$cleanParent",
$newPackage,
"plugins/$parent"); # assumes Cwd is qpsmtpd root
$self->log(LOGDEBUG,"---- $newPackage\n");
warn "---- $newPackage\n";
no strict 'refs';
push @{"${currentPackage}::ISA"}, $newPackage;
}
@ -158,7 +158,6 @@ sub compile {
'@ISA = qw(Qpsmtpd::Plugin);',
($test_mode ? 'use Test::More;' : ''),
"sub plugin_name { qq[$plugin] }",
"sub hook_name { return shift->{_hook}; }",
$line,
$sub,
"\n", # last line comment without newline?

121
lib/Qpsmtpd/PollServer.pm
View File

@ -29,7 +29,7 @@ use fields qw(
);
use Qpsmtpd::Constants;
use Qpsmtpd::Address;
use Danga::DNS;
use ParaDNS;
use Mail::Header;
use POSIX qw(strftime);
use Socket qw(inet_aton AF_INET CRLF);
@ -54,6 +54,7 @@ sub new {
$self->{start_time} = time;
$self->{mode} = 'connect';
$self->load_plugins;
$self->load_logging;
return $self;
}
@ -64,7 +65,7 @@ sub uptime {
}
sub reset_for_next_message {
my $self = shift;
my Qpsmtpd::PollServer $self = shift;
$self->SUPER::reset_for_next_message(@_);
$self->{_commands} = {
@ -85,7 +86,7 @@ sub reset_for_next_message {
}
sub respond {
my $self = shift;
my Qpsmtpd::PollServer $self = shift;
my ($code, @messages) = @_;
while (my $msg = shift @messages) {
my $line = $code . (@messages ? "-" : " ") . $msg;
@ -95,22 +96,16 @@ sub respond {
}
sub fault {
my $self = shift;
my Qpsmtpd::PollServer $self = shift;
$self->SUPER::fault(@_);
return;
}
sub process_line {
my $self = shift;
my Qpsmtpd::PollServer $self = shift;
my $line = shift || return;
if ($::DEBUG > 1) { print "$$:".($self+0)."C($self->{mode}): $line"; }
local $SIG{ALRM} = sub {
my ($pkg, $file, $line) = caller();
die "ALARM: ($self->{mode}) $pkg, $file, $line";
};
my $prev = alarm($self->{cmd_timeout}); # must process a command in < N seconds
eval { $self->_process_line($line) };
alarm($prev);
if ($@) {
print STDERR "Error: $@\n";
return $self->fault("command failed unexpectedly") if $self->{mode} eq 'cmd';
@ -121,7 +116,7 @@ sub process_line {
}
sub _process_line {
my $self = shift;
my Qpsmtpd::PollServer $self = shift;
my $line = shift;
if ($self->{mode} eq 'connect') {
@ -142,7 +137,7 @@ sub _process_line {
}
sub process_cmd {
my $self = shift;
my Qpsmtpd::PollServer $self = shift;
my $line = shift;
my ($cmd, @params) = split(/ +/, $line);
my $meth = lc($cmd);
@ -158,25 +153,21 @@ sub process_cmd {
}
return $resp;
}
elsif ( $self->authenticated == AUTH_PENDING ) {
return $self->auth_process($line);
}
else {
# No such method - i.e. unrecognized command
my ($rc, $msg) = $self->run_hooks("unrecognized_command", $meth, @params);
return $self->unrecognized_command_respond($rc, $msg) unless $rc == CONTINUATION;
return 1;
}
}
sub disconnect {
my $self = shift;
my Qpsmtpd::PollServer $self = shift;
$self->SUPER::disconnect(@_);
$self->close;
}
sub start_conversation {
my $self = shift;
my Qpsmtpd::PollServer $self = shift;
my $conn = $self->connection;
# set remote_host, remote_ip and remote_port
@ -184,28 +175,26 @@ sub start_conversation {
$conn->remote_ip($ip);
$conn->remote_port($port);
$conn->remote_info("[$ip]");
Danga::DNS->new(
client => $self,
ParaDNS->new(
finished => sub { $self->run_hooks("connect") },
# NB: Setting remote_info to the same as remote_host
callback => sub { $conn->remote_info($conn->remote_host($_[0])) },
host => $ip,
);
my ($rc, $msg) = $self->run_hooks("connect");
return $self->connect_respond($rc, $msg) unless $rc == CONTINUATION;
return DONE;
return;
}
sub data {
my $self = shift;
my Qpsmtpd::PollServer $self = shift;
my ($rc, $msg) = $self->run_hooks("data");
return $self->data_respond($rc, $msg) unless $rc == CONTINUATION;
return 1;
}
sub data_respond {
my ($self, $rc, $msg) = @_;
my Qpsmtpd::PollServer $self = shift;
my ($rc, $msg) = @_;
if ($rc == DONE) {
return;
}
@ -234,18 +223,83 @@ sub data_respond {
$self->{mode} = 'data';
$self->{header_lines} = [];
$self->{header_lines} = '';
$self->{data_size} = 0;
$self->{in_header} = 1;
$self->{max_size} = ($self->config('databytes'))[0] || 0; # this should work in scalar context
$self->{max_size} = ($self->config('databytes'))[0] || 0;
$self->log(LOGDEBUG, "max_size: $self->{max_size} / size: $self->{data_size}");
return $self->respond(354, "go ahead");
$self->respond(354, "go ahead");
my $max_get = $self->{max_size} || 1048576;
$self->get_chunks($max_get, sub { $self->got_data($_[0]) });
return 1;
}
sub got_data {
my Qpsmtpd::PollServer $self = shift;
my $data = shift;
my $done = 0;
my $remainder;
if ($data =~ s/^\.\r\n(.*)\z//m) {
$remainder = $1;
$done = 1;
}
# add a transaction->blocked check back here when we have line by line plugin access...
unless (($self->{max_size} and $self->{data_size} > $self->{max_size})) {
$data =~ s/\r\n/\n/mg;
$data =~ s/^\.\./\./mg;
if ($self->{in_header} and $data =~ s/\A(.*?)\n[ \t]*\n//ms) {
$self->{header_lines} .= $1;
# end of headers
$self->{in_header} = 0;
# ... need to check that we don't reformat any of the received lines.
#
# 3.8.2 Received Lines in Gatewaying
# When forwarding a message into or out of the Internet environment, a
# gateway MUST prepend a Received: line, but it MUST NOT alter in any
# way a Received: line that is already in the header.
my @header_lines = split(/\n/, $self->{header_lines});
my $header = Mail::Header->new(\@header_lines,
Modify => 0, MailFrom => "COERCE");
$self->transaction->header($header);
$self->{header_lines} = '';
#$header->add("X-SMTPD", "qpsmtpd/".$self->version.", http://smtpd.develooper.com/");
# FIXME - call plugins to work on just the header here; can
# save us buffering the mail content.
}
if ($self->{in_header}) {
$self->{header_lines} .= $data;
}
else {
$self->transaction->body_write(\$data);
}
$self->{data_size} += length $data;
}
if ($done) {
$self->{mode} = 'cmd';
$self->end_of_data;
$self->end_get_chunks($remainder);
}
}
sub data_line {
my $self = shift;
my Qpsmtpd::PollServer $self = shift;
print "YIKES\n";
my $line = shift;
@ -293,7 +347,7 @@ sub data_line {
push @{ $self->{header_lines} }, $line;
}
else {
$self->transaction->body_write($line);
$self->transaction->body_write(\$line);
}
$self->{data_size} += length $line;
@ -303,7 +357,7 @@ sub data_line {
}
sub end_of_data {
my $self = shift;
my Qpsmtpd::PollServer $self = shift;
#$self->log(LOGDEBUG, "size is at $size\n") unless ($i % 300);
@ -331,7 +385,6 @@ sub end_of_data {
return $self->respond(552, "Message too big!") if $self->{max_size} and $self->{data_size} > $self->{max_size};
my ($rc, $msg) = $self->run_hooks("data_post");
return $self->data_post_respond($rc, $msg) unless $rc == CONTINUATION;
return 1;
}

2
lib/Qpsmtpd/Postfix.pm
View File

@ -162,7 +162,7 @@ sub inject_mail {
my %at = $strm->get_attr;
my $qid = $at{queue_id};
print STDERR "qid=$qid\n";
$strm->print_attr('flags' => '0000');
$strm->print_attr('flags' => $transaction->notes('postfix-queue-flags'));
$strm->print_rec_time();
$strm->print_rec('REC_TYPE_FROM', $transaction->sender->address|| "");
for (map { $_->address } $transaction->recipients) {

86
lib/Qpsmtpd/Postfix/Constants.pm Normal file
View File

@ -0,0 +1,86 @@
#
# Qpsmtpd::Postfix::Constants
#
# This is a generated file, do not edit
#
# created by pf2qp.pl v0.1 @ Sun Oct 29 09:10:18 2006
# postfix version 2.4
#
package Qpsmtpd::Postfix::Constants;
use Qpsmtpd::Constants;
require Exporter;
use vars qw(@ISA @EXPORT %cleanup_soft %cleanup_hard $postfix_version);
use strict;
@ISA = qw(Exporter);
@EXPORT = qw(
%cleanup_soft
%cleanup_hard
$postfix_version
CLEANUP_FLAG_NONE
CLEANUP_FLAG_BOUNCE
CLEANUP_FLAG_FILTER
CLEANUP_FLAG_HOLD
CLEANUP_FLAG_DISCARD
CLEANUP_FLAG_BCC_OK
CLEANUP_FLAG_MAP_OK
CLEANUP_FLAG_MILTER
CLEANUP_FLAG_FILTER_ALL
CLEANUP_FLAG_MASK_EXTERNAL
CLEANUP_FLAG_MASK_INTERNAL
CLEANUP_FLAG_MASK_EXTRA
CLEANUP_STAT_OK
CLEANUP_STAT_BAD
CLEANUP_STAT_WRITE
CLEANUP_STAT_SIZE
CLEANUP_STAT_CONT
CLEANUP_STAT_HOPS
CLEANUP_STAT_RCPT
CLEANUP_STAT_PROXY
CLEANUP_STAT_DEFER
CLEANUP_STAT_MASK_CANT_BOUNCE
CLEANUP_STAT_MASK_INCOMPLETE
);
$postfix_version = "2.4";
use constant CLEANUP_FLAG_NONE => 0; # /* No special features */
use constant CLEANUP_FLAG_BOUNCE => (1<<0); # /* Bounce bad messages */
use constant CLEANUP_FLAG_FILTER => (1<<1); # /* Enable header/body checks */
use constant CLEANUP_FLAG_HOLD => (1<<2); # /* Place message on hold */
use constant CLEANUP_FLAG_DISCARD => (1<<3); # /* Discard message silently */
use constant CLEANUP_FLAG_BCC_OK => (1<<4); # /* Ok to add auto-BCC addresses */
use constant CLEANUP_FLAG_MAP_OK => (1<<5); # /* Ok to map addresses */
use constant CLEANUP_FLAG_MILTER => (1<<6); # /* Enable Milter applications */
use constant CLEANUP_FLAG_FILTER_ALL => (CLEANUP_FLAG_FILTER | CLEANUP_FLAG_MILTER);
use constant CLEANUP_FLAG_MASK_EXTERNAL => (CLEANUP_FLAG_FILTER_ALL | CLEANUP_FLAG_BCC_OK | CLEANUP_FLAG_MAP_OK);
use constant CLEANUP_FLAG_MASK_INTERNAL => CLEANUP_FLAG_MAP_OK;
use constant CLEANUP_FLAG_MASK_EXTRA => (CLEANUP_FLAG_HOLD | CLEANUP_FLAG_DISCARD);
use constant CLEANUP_STAT_OK => 0; # /* Success. */
use constant CLEANUP_STAT_BAD => (1<<0); # /* Internal protocol error */
use constant CLEANUP_STAT_WRITE => (1<<1); # /* Error writing message file */
use constant CLEANUP_STAT_SIZE => (1<<2); # /* Message file too big */
use constant CLEANUP_STAT_CONT => (1<<3); # /* Message content rejected */
use constant CLEANUP_STAT_HOPS => (1<<4); # /* Too many hops */
use constant CLEANUP_STAT_RCPT => (1<<6); # /* No recipients found */
use constant CLEANUP_STAT_PROXY => (1<<7); # /* Proxy reject */
use constant CLEANUP_STAT_DEFER => (1<<8); # /* Temporary reject */
use constant CLEANUP_STAT_MASK_CANT_BOUNCE => (CLEANUP_STAT_BAD | CLEANUP_STAT_WRITE | CLEANUP_STAT_DEFER);
use constant CLEANUP_STAT_MASK_INCOMPLETE => (CLEANUP_STAT_BAD | CLEANUP_STAT_WRITE | CLEANUP_STAT_SIZE | CLEANUP_STAT_DEFER);
%cleanup_soft = (
CLEANUP_STAT_DEFER => "service unavailable (#4.7.1)",
CLEANUP_STAT_PROXY => "queue file write error (#4.3.0)",
CLEANUP_STAT_BAD => "internal protocol error (#4.3.0)",
CLEANUP_STAT_WRITE => "queue file write error (#4.3.0)",
);
%cleanup_hard = (
CLEANUP_STAT_RCPT => "no recipients specified (#5.1.0)",
CLEANUP_STAT_HOPS => "too many hops (#5.4.0)",
CLEANUP_STAT_SIZE => "message file too big (#5.3.4)",
CLEANUP_STAT_CONT => "message content rejected (#5.7.1)",
);
1;

115
lib/Qpsmtpd/Postfix/pf2qp.pl Executable file
View File

@ -0,0 +1,115 @@
#/usr/bin/perl -w
#
#
my $version = "0.1";
$0 =~ s#.*/##;
my $path = $&; # sneaky way to get path back
my $POSTFIX_SRC = shift || die <<"EOF";
Usage:
$0 /path/to/postfix/source
EOF
my $header = "$POSTFIX_SRC/src/global/cleanup_user.h";
my $src = "$POSTFIX_SRC/src/global/cleanup_strerror.c";
my $pf_vers = "$POSTFIX_SRC/src/global/mail_version.h";
my $postfix_version = "";
open VERS, $pf_vers
or die "Could not open $pf_vers: $!\n";
while (<VERS>) {
next unless /^\s*#\s*define\s+MAIL_VERSION_NUMBER\s+"(.+)"\s*$/;
$postfix_version = $1;
last;
}
close VERS;
$postfix_version =~ s/^(\d+\.\d+).*/$1/;
if ($postfix_version < 2.3) {
die "Need at least postfix v2.3";
}
my $start = <<'_END';
#
# Qpsmtpd::Postfix::Constants
#
# This is a generated file, do not edit
#
_END
$start .= "# created by $0 v$version @ ".scalar(gmtime)."\n"
."# postfix version $postfix_version\n"
."#\n";
$start .= <<'_END';
package Qpsmtpd::Postfix::Constants;
use Qpsmtpd::Constants;
require Exporter;
use vars qw(@ISA @EXPORT %cleanup_soft %cleanup_hard $postfix_version);
use strict;
@ISA = qw(Exporter);
_END
my @export = qw(%cleanup_soft %cleanup_hard $postfix_version);
my @out = ();
open HEAD, $header
or die "Could not open $header: $!\n";
while (<HEAD>) {
while (s/\\\n$//) {
$_ .= <HEAD>;
}
chomp;
if (/^\s*#define\s/) {
s/^\s*#define\s*//;
next if /^_/;
s#(/\*.*\*/)##;
my $comment = $1 || "";
my @words = split ' ', $_;
my $const = shift @words;
if ($const eq "CLEANUP_STAT_OK") {
push @out, "";
}
push @export, $const;
push @out, "use constant $const => ". join(" ", @words). "; "
.($comment ? "# $comment ": "");
}
}
close HEAD;
open SRC, $src
or die "Could not open $src: $!\n";
my $data;
{
local $/ = undef;
$data = <SRC>;
}
close SRC;
$data =~ s/.*cleanup_stat_map\[\]\s*=\s*{\s*\n//s;
$data =~ s/};.*$//s;
my @array = split "\n", $data;
my (@denysoft,@denyhard);
foreach (@array) {
chomp;
s/,/ => /;
s/"(\d\.\d\.\d)",\s+"(.*)",/"$2 (#$1)",/;
s!(/\*.*\*/)!# $1!;
s/4\d\d,\s// && push @denysoft, $_;
s/5\d\d,\s// && push @denyhard, $_;
}
open my $CONSTANTS, '>', "$path/Constants.pm";
print ${CONSTANTS} $start, '@EXPORT = qw(', "\n";
while (@export) {
print ${CONSTANTS} "\t", shift @export, "\n";
}
print ${CONSTANTS} ");\n\n",
"\$postfix_version = \"$postfix_version\";\n",
join("\n", @out),"\n\n";
print ${CONSTANTS} "\%cleanup_soft = (\n", join("\n", @denysoft), "\n);\n\n";
print ${CONSTANTS} "\%cleanup_hard = (\n", join("\n", @denyhard), "\n);\n\n1;\n";
close $CONSTANTS;

556
lib/Qpsmtpd/SMTP.pm
View File

@ -1,17 +1,21 @@
package Qpsmtpd::SMTP;
use Qpsmtpd;
@ISA = qw(Qpsmtpd);
my %auth_mechanisms = ();
package Qpsmtpd::SMTP;
use strict;
use Carp;
use Qpsmtpd::Connection;
use Qpsmtpd::Transaction;
use Qpsmtpd::Plugin;
use Qpsmtpd::Constants;
use Qpsmtpd::Auth;
use Qpsmtpd::Address ();
use Qpsmtpd::Command;
use Mail::Header ();
use MIME::Base64;
#use Data::Dumper;
use POSIX qw(strftime);
use Net::DNS;
@ -30,7 +34,7 @@ sub new {
my $self = bless ({ args => \%args }, $class);
my (@commands) = qw(ehlo helo rset mail rcpt data help vrfy noop quit);
my (%commands); @commands{@commands} = (1) x @commands;
my (%commands); @commands{@commands} = ('') x @commands;
# this list of valid commands should probably be a method or a set of methods
$self->{_commands} = \%commands;
@ -48,15 +52,9 @@ sub dispatch {
$self->{_counter}++;
if ( $self->authenticated == AUTH_PENDING ) {
# must be in the middle of prompting for auth parameters
return $self->auth_process($cmd,@_);
}
if ($cmd !~ /^(\w{1,12})$/ or !exists $self->{_commands}->{$1}) {
my ($rc, $msg) = $self->run_hooks("unrecognized_command", $cmd, @_);
return $self->unrecognized_command_respond($rc, $msg, @_) unless $rc == CONTINUATION;
return 1;
$self->run_hooks("unrecognized_command", $cmd, @_);
return 1
}
$cmd = $1;
@ -73,11 +71,11 @@ sub dispatch {
sub unrecognized_command_respond {
my ($self, $rc, $msg) = @_;
if ($rc == DENY_DISCONNECT) {
$self->respond(521, $msg);
$self->respond(521, @$msg);
$self->disconnect;
}
elsif ($rc == DENY) {
$self->respond(500, $msg);
$self->respond(500, @$msg);
}
elsif ($rc != DONE) {
$self->respond(500, "Unrecognized command");
@ -87,7 +85,8 @@ sub unrecognized_command_respond {
sub fault {
my $self = shift;
my ($msg) = shift || "program fault - command not performed";
print STDERR "$0[$$]: $msg ($!)\n";
my ($name) = split /\s+/, $0, 2;
print STDERR $name,"[$$]: $msg ($!)\n";
return $self->respond(451, "Internal error - try again later - " . $msg);
}
@ -96,30 +95,26 @@ 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");
return $self->connect_respond($rc, $msg) unless $rc == CONTINUATION;
$self->run_hooks("connect");
return DONE;
}
sub connect_respond {
my ($self, $rc, $msg) = @_;
if ($rc == DENY) {
$self->respond(550, ($msg || 'Connection from you denied, bye bye.'));
if ($rc == DENY || $rc == DENY_DISCONNECT) {
$msg->[0] ||= 'Connection from you denied, bye bye.';
$self->respond(550, @$msg);
$self->disconnect;
return $rc;
}
elsif ($rc == DENYSOFT) {
$self->respond(450, ($msg || 'Connection from you temporarily denied, bye bye.'));
elsif ($rc == DENYSOFT || $rc == DENYSOFT_DISCONNECT) {
$msg->[0] ||= 'Connection from you temporarily denied, bye bye.';
$self->respond(450, @$msg);
$self->disconnect;
return $rc;
}
elsif ($rc == DONE) {
return $rc;
}
elsif ($rc != DONE) {
my $greets = $self->config('smtpgreeting');
if ( $greets ) {
$greets .= " ESMTP";
$greets .= " ESMTP" unless $greets =~ /(^|\W)ESMTP(\W|$)/;
}
else {
$greets = $self->config('me')
@ -129,73 +124,93 @@ sub connect_respond {
}
$self->respond(220, $greets);
return DONE;
}
}
sub transaction {
my $self = shift;
return $self->{_transaction} || $self->reset_transaction();
}
sub reset_transaction {
my $self = shift;
$self->run_hooks("reset_transaction") if $self->{_transaction};
return $self->{_transaction} = Qpsmtpd::Transaction->new();
}
sub connection {
my $self = shift;
@_ and $self->{_connection} = shift;
return $self->{_connection} || ($self->{_connection} = Qpsmtpd::Connection->new());
}
sub helo {
my ($self, $hello_host, @stuff) = @_;
my ($self, $line) = @_;
my ($rc, @msg) = $self->run_hooks('helo_parse');
my ($ok, $hello_host, @stuff) = Qpsmtpd::Command->parse('helo', $line, $msg[0]);
return $self->respond (501,
"helo requires domain/address - see RFC-2821 4.1.1.1") unless $hello_host;
my $conn = $self->connection;
return $self->respond (503, "but you already said HELO ...") if $conn->hello;
my ($rc, $msg) = $self->run_hooks("helo", $hello_host, @stuff);
return $self->helo_respond($rc, $msg, $hello_host, @stuff) unless $rc == CONTINUATION;
return 1;
$self->run_hooks("helo", $hello_host, @stuff);
}
sub helo_respond {
my ($self, $rc, $msg, $hello_host) = @_;
if ($rc == DENY) {
$self->respond(550, $msg);
}
elsif ($rc == DENYSOFT) {
$self->respond(450, $msg);
my ($self, $rc, $msg, $args) = @_;
my ($hello_host) = @$args;
if ($rc == DONE) {
# do nothing
} elsif ($rc == DENY) {
$self->respond(550, @$msg);
} elsif ($rc == DENYSOFT) {
$self->respond(450, @$msg);
} elsif ($rc == DENY_DISCONNECT) {
$self->respond(550, $msg);
$self->respond(550, @$msg);
$self->disconnect;
} elsif ($rc == DENYSOFT_DISCONNECT) {
$self->respond(450, $msg);
$self->respond(450, @$msg);
$self->disconnect;
}
elsif ($rc != DONE) {
} else {
my $conn = $self->connection;
$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.");
$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 ($self, $line) = @_;
my ($rc, @msg) = $self->run_hooks('ehlo_parse');
my ($ok, $hello_host, @stuff) = Qpsmtpd::Command->parse('ehlo', $line, $msg[0]);
return $self->respond (501,
"ehlo requires domain/address - see RFC-2821 4.1.1.1") unless $hello_host;
my $conn = $self->connection;
return $self->respond (503, "but you already said HELO ...") if $conn->hello;
my ($rc, $msg) = $self->run_hooks("ehlo", $hello_host, @stuff);
return $self->ehlo_respond($rc, $msg, $hello_host, @stuff) unless $rc == CONTINUATION;
return 1;
$self->run_hooks("ehlo", $hello_host, @stuff);
}
sub ehlo_respond {
my ($self, $rc, $msg, $hello_host) = @_;
if ($rc == DENY) {
$self->respond(550, $msg);
}
elsif ($rc == DENYSOFT) {
$self->respond(450, $msg);
my ($self, $rc, $msg, $args) = @_;
my ($hello_host) = @$args;
if ($rc == DONE) {
# do nothing
} elsif ($rc == DENY) {
$self->respond(550, @$msg);
} elsif ($rc == DENYSOFT) {
$self->respond(450, @$msg);
} elsif ($rc == DENY_DISCONNECT) {
$self->respond(550, $msg);
$self->respond(550, @$msg);
$self->disconnect;
} elsif ($rc == DENYSOFT_DISCONNECT) {
$self->respond(450, $msg);
$self->respond(450, @$msg);
$self->disconnect;
}
elsif ($rc != DONE) {
} else {
my $conn = $self->connection;
$conn->hello("ehlo");
$conn->hello_host($hello_host);
@ -206,7 +221,6 @@ sub ehlo_respond {
: ();
# Check for possible AUTH mechanisms
my %auth_mechanisms;
HOOK: foreach my $hook ( keys %{$self->{hooks}} ) {
if ( $hook =~ m/^auth-?(.+)?$/ ) {
if ( defined $1 ) {
@ -219,9 +233,11 @@ HOOK: foreach my $hook ( keys %{$self->{hooks}} ) {
}
}
if ( %auth_mechanisms ) {
# Check if we should only offer AUTH after TLS is completed
my $tls_before_auth = ($self->config('tls_before_auth') ? ($self->config('tls_before_auth'))[0] && $self->transaction->notes('tls_enabled') : 0);
if ( %auth_mechanisms && !$tls_before_auth) {
push @capabilities, 'AUTH '.join(" ",keys(%auth_mechanisms));
$self->{_commands}->{'auth'} = "1";
$self->{_commands}->{'auth'} = "";
}
$self->respond(250,
@ -234,154 +250,44 @@ HOOK: foreach my $hook ( keys %{$self->{hooks}} ) {
}
}
sub e64
{
my ($arg) = @_;
my $res = encode_base64($arg);
chomp($res);
return($res);
sub auth {
my ($self, $line) = @_;
$self->run_hooks('auth_parse', $line);
}
sub auth {
my ( $self, $mechanism, $prekey ) = @_;
sub auth_parse_respond {
my ($self, $rc, $msg, $args) = @_;
my ($line) = @$args;
my ($ok, $mechanism, @stuff) = Qpsmtpd::Command->parse('auth', $line, $msg->[0]);
return $self->respond(501, $mechanism || "Syntax error in command")
unless ($ok == OK);
$mechanism = lc($mechanism);
#they AUTH'd once already
return $self->respond( 503, "but you already said AUTH ..." )
if ( $self->authenticated == OK );
if ( defined $self->{_auth}
and $self->{_auth} == OK );
return $self->respond( 503, "AUTH not defined for HELO" )
if ( $self->connection->hello eq "helo" );
return $self->respond( 503, "SSL/TLS required before AUTH" )
if ( ($self->config('tls_before_auth'))[0]
and $self->transaction->notes('tls_enabled') );
# $DB::single = 1;
$self->auth_mechanism($mechanism);
$self->authenticated(AUTH_PENDING);
if ( $prekey ) { # easy single step
unless ( $mechanism =~ /^(plain|login)$/i ) {
# must be plain or login
$self->respond( 500, "Unrecognized authentification mechanism" );
return DECLINED;
}
my ($passHash, $user, $passClear) = split /\x0/,decode_base64($prekey);
# we have all of the elements ready to go now
if ( $mechanism =~ /login/i ) {
$self->auth_user($user);
return $self->auth_process(e64($passClear));
}
else {
return $self->auth_process($prekey);
}
}
else {
if ( $mechanism =~ /plain/i ) {
$self->respond( 334, "Please continue" );
}
elsif ( $mechanism =~ /login/i ) {
$self->respond( 334, e64("Username:") );
}
elsif ( $mechanism =~ /cram-md5/i ) {
# rand() is not cryptographic, but we only need to generate a globally
# unique number. The rand() is there in case the user logs in more than
# once in the same second, or if the clock is skewed.
my $ticket = sprintf( "<%x.%x\@" . $self->config("me") . ">",
rand(1000000), time() );
# Store this for later
$self->auth_ticket($ticket);
# We send the ticket encoded in Base64
$self->respond( 334, encode_base64( $ticket, "" ) );
}
}
return DECLINED;
}
sub auth_process {
my ($self, $line) = @_;
my ( $user, $passClear, $passHash, $ticket, $mechanism );
# do this once here
$mechanism = $self->auth_mechanism;
$user = $self->auth_user;
$ticket = $self->auth_ticket;
if ( $mechanism eq 'plain' ) {
( $passHash, $user, $passClear ) = split /\x0/,
decode_base64($line);
}
elsif ( $mechanism eq 'login' ) {
if ( $user ) {
# must be getting the password now
$passClear = decode_base64($line);
}
else {
# must be getting the user now
$user = decode_base64($line);
$self->auth_user($user);
$self->respond(334, e64("Password:"));
}
}
elsif ( $mechanism eq "cram-md5" ) {
$line =~ tr/[\r\n]//d; # cannot simply chomp CRLF
( $user, $passHash ) = split( ' ', decode_base64($line) );
}
else {
$self->respond( 500, "Unrecognized authentification mechanism" );
return DECLINED;
}
if ($user eq '*') {
$self->respond(501, "Authentification canceled");
return DECLINED;
}
# check to see if we can proceed with the hooks
if ( $user and ( $passClear or $passHash ) ) {
# try running the specific hooks first
my ( $rc, $msg ) =
$self->run_hooks( "auth-$mechanism",
$mechanism, $user, $passClear,
$passHash, $ticket );
# try running the polymorphous hooks next
if ( !$rc || $rc == DECLINED ) {
( $rc, $msg ) =
$self->run_hooks( "auth", $mechanism, $user, $passClear,
$passHash, $ticket );
}
return $self->auth_respond($rc, $msg, $mechanism, $user)
unless $rc == CONTINUATION;
}
else {
return CONTINUATION;
}
}
sub auth_respond {
my ($self, $rc, $msg, $mechanism, $user) = @_;
if ( $rc == OK ) {
$msg = "Authentication successful for $user" .
( defined $msg ? " - " . $msg : "" );
$self->respond( 235, $msg );
$self->connection->relay_client(1);
$self->log( LOGINFO, $msg );
$self->authenticated(OK);
return OK;
}
else {
$msg = "Authentication failed for $user" .
( defined $msg ? " - " . $msg : "" );
$self->respond( 535, $msg );
$self->log( LOGERROR, $msg );
# if we don't have a plugin implementing this auth mechanism, 504
if( exists $auth_mechanisms{uc($mechanism)} ) {
return $self->{_auth} = Qpsmtpd::Auth::SASL( $self, $mechanism, @stuff );
} else {
$self->respond( 504, "Unimplemented authentification mechanism: $mechanism" );
return DENY;
}
}
sub mail {
my $self = shift;
return $self->respond(501, "syntax error in parameters") if !$_[0] or $_[0] !~ m/^from:/i;
my ($self, $line) = @_;
# -> from RFC2821
# The MAIL command (or the obsolete SEND, SOML, or SAML commands)
# begins a mail transaction. Once started, a mail transaction
@ -405,17 +311,41 @@ sub mail {
unless ($self->connection->hello) {
return $self->respond(503, "please say hello first ...");
}
else {
$self->log(LOGINFO, "full from_parameter: $line");
$self->run_hooks("mail_parse", $line);
}
}
my $from_parameter = join " ", @_;
$self->log(LOGINFO, "full from_parameter: $from_parameter");
sub mail_parse_respond {
my ($self, $rc, $msg, $args) = @_;
my ($line) = @$args;
my ($ok, $from, @params) = Qpsmtpd::Command->parse('mail', $line, $msg->[0]);
return $self->respond(501, $from || "Syntax error in command")
unless ($ok == OK);
my %param;
foreach (@params) {
my ($k,$v) = split /=/, $_, 2;
$param{lc $k} = $v;
}
# to support addresses without <> we now require a plugin
# hooking "mail_pre" to
# return (OK, "<$from>");
# (...or anything else parseable by Qpsmtpd::Address ;-))
# see also comment in sub rcpt()
$self->run_hooks("mail_pre", $from, \%param);
}
my ($from) = ($from_parameter =~ m/^from:\s*(<[^>]*>)/i)[0];
# support addresses without <> ... maybe we shouldn't?
($from) = "<" . ($from_parameter =~ m/^from:\s*(\S+)/i)[0] . ">"
unless $from;
sub mail_pre_respond {
my ($self, $rc, $msg, $args) = @_;
my ($from, $param) = @$args;
if ($rc == OK) {
$from = shift @$msg;
}
$self->log(LOGALERT, "from email address : [$from]");
return $self->respond(501, "could not parse your mail from command")
unless $from =~ /^<.*>$/;
if ($from eq "<>" or $from =~ m/\[undefined\]/ or $from eq "<#@[]>") {
$from = Qpsmtpd::Address->new("<>");
@ -425,36 +355,35 @@ sub mail {
}
return $self->respond(501, "could not parse your mail from command") unless $from;
my ($rc, $msg) = $self->run_hooks("mail", $from);
return $self->mail_respond($rc, $msg, $from) unless $rc == CONTINUATION;
return 1;
$self->run_hooks("mail", $from, %$param);
}
sub mail_respond {
my ($self, $rc, $msg, $from) = @_;
my ($self, $rc, $msg, $args) = @_;
my ($from, $param) = @$args;
if ($rc == DONE) {
return 1;
}
elsif ($rc == DENY) {
$msg ||= $from->format . ', denied';
$self->log(LOGINFO, "deny mail from " . $from->format . " ($msg)");
$self->respond(550, $msg);
$msg->[0] ||= $from->format . ', denied';
$self->log(LOGINFO, "deny mail from " . $from->format . " (@$msg)");
$self->respond(550, @$msg);
}
elsif ($rc == DENYSOFT) {
$msg ||= $from->format . ', temporarily denied';
$self->log(LOGINFO, "denysoft mail from " . $from->format . " ($msg)");
$self->respond(450, $msg);
$msg->[0] ||= $from->format . ', temporarily denied';
$self->log(LOGINFO, "denysoft mail from " . $from->format . " (@$msg)");
$self->respond(450, @$msg);
}
elsif ($rc == DENY_DISCONNECT) {
$msg ||= $from->format . ', denied';
$self->log(LOGINFO, "deny mail from " . $from->format . " ($msg)");
$self->respond(550, $msg);
$msg->[0] ||= $from->format . ', denied';
$self->log(LOGINFO, "deny mail from " . $from->format . " (@$msg)");
$self->respond(550, @$msg);
$self->disconnect;
}
elsif ($rc == DENYSOFT_DISCONNECT) {
$msg ||= $from->format . ', temporarily denied';
$self->log(LOGINFO, "denysoft mail from " . $from->format . " ($msg)");
$self->respond(450, $msg);
$msg->[0] ||= $from->format . ', temporarily denied';
$self->log(LOGINFO, "denysoft mail from " . $from->format . " (@$msg)");
$self->respond(421, @$msg);
$self->disconnect;
}
else { # includes OK
@ -465,45 +394,75 @@ sub mail_respond {
}
sub rcpt {
my $self = shift;
return $self->respond(501, "syntax error in parameters") unless $_[0] and $_[0] =~ m/^to:/i;
my ($self, $line) = @_;
$self->run_hooks("rcpt_parse", $line);
}
sub rcpt_parse_respond {
my ($self, $rc, $msg, $args) = @_;
my ($line) = @$args;
my ($ok, $rcpt, @param) = Qpsmtpd::Command->parse("rcpt", $line, $msg->[0]);
return $self->respond(501, $rcpt || "Syntax error in command")
unless ($ok == OK);
return $self->respond(503, "Use MAIL before RCPT") unless $self->transaction->sender;
my ($rcpt) = ($_[0] =~ m/to:(.*)/i)[0];
$rcpt = $_[1] unless $rcpt;
my %param;
foreach (@param) {
my ($k,$v) = split /=/, $_, 2;
$param{lc $k} = $v;
}
# to support addresses without <> we now require a plugin
# hooking "rcpt_pre" to
# return (OK, "<$rcpt>");
# (... or anything else parseable by Qpsmtpd::Address ;-))
# this means, a plugin can decide to (pre-)accept
# addresses like <user@example.com.> or <user@example.com >
# by removing the trailing "."/" " from this example...
$self->run_hooks("rcpt_pre", $rcpt, \%param);
}
sub rcpt_pre_respond {
my ($self, $rc, $msg, $args) = @_;
my ($rcpt, $param) = @$args;
if ($rc == OK) {
$rcpt = shift @$msg;
}
$self->log(LOGALERT, "to email address : [$rcpt]");
return $self->respond(501, "could not parse recipient")
unless $rcpt =~ /^<.*>$/;
$rcpt = (Qpsmtpd::Address->parse($rcpt))[0];
return $self->respond(501, "could not parse recipient") unless $rcpt;
return $self->respond(501, "could not parse recipient")
if (!$rcpt or ($rcpt->format eq '<>'));
my ($rc, $msg) = $self->run_hooks("rcpt", $rcpt);
return $self->rcpt_respond($rc, $msg, $rcpt) unless $rc == CONTINUATION;
return 1;
$self->run_hooks("rcpt", $rcpt, %$param);
}
sub rcpt_respond {
my ($self, $rc, $msg, $rcpt) = @_;
my ($self, $rc, $msg, $args) = @_;
my ($rcpt, $param) = @$args;
if ($rc == DONE) {
return 1;
}
elsif ($rc == DENY) {
$msg ||= 'relaying denied';
$self->respond(550, $msg);
$msg->[0] ||= 'relaying denied';
$self->respond(550, @$msg);
}
elsif ($rc == DENYSOFT) {
$msg ||= 'relaying denied';
return $self->respond(450, $msg);
$msg->[0] ||= 'relaying denied';
return $self->respond(450, @$msg);
}
elsif ($rc == DENY_DISCONNECT) {
$msg ||= 'delivery denied';
$self->log(LOGINFO, "delivery denied ($msg)");
$self->respond(550, $msg);
$msg->[0] ||= 'delivery denied';
$self->log(LOGINFO, "delivery denied (@$msg)");
$self->respond(550, @$msg);
$self->disconnect;
}
elsif ($rc == DENYSOFT_DISCONNECT) {
$msg ||= 'relaying denied';
$self->log(LOGINFO, "delivery denied ($msg)");
$self->respond(421, $msg);
$msg->[0] ||= 'relaying denied';
$self->log(LOGINFO, "delivery denied (@$msg)");
$self->respond(421, @$msg);
$self->disconnect;
}
elsif ($rc == OK) {
@ -520,7 +479,7 @@ sub help {
my $self = shift;
$self->respond(214,
"This is qpsmtpd " .
$self->config('smtpgreeting') ? '' : $self->version,
($self->config('smtpgreeting') ? '' : $self->version),
"See http://smtpd.develooper.com/",
'To report bugs or send comments, mail to <ask@develooper.com>.');
}
@ -537,23 +496,23 @@ sub vrfy {
# documented in RFC2821#3.5.1
# I also don't think it provides all the proper result codes.
my ($rc, $msg) = $self->run_hooks("vrfy");
return $self->vrfy_respond($rc, $msg) unless $rc == CONTINUATION;
return 1;
$self->run_hooks("vrfy");
}
sub vrfy_respond {
my ($self, $rc, $msg) = @_;
my ($self, $rc, $msg, $args) = @_;
if ($rc == DONE) {
return 1;
}
elsif ($rc == DENY) {
$self->respond(554, $msg || "Access Denied");
$msg->[0] ||= "Access Denied";
$self->respond(554, @$msg);
$self->reset_transaction();
return 1;
}
elsif ($rc == OK) {
$self->respond(250, $msg || "User OK");
$msg->[0] ||= "User OK";
$self->respond(250, @$msg);
return 1;
}
else { # $rc == DECLINED or anything else
@ -570,15 +529,14 @@ sub rset {
sub quit {
my $self = shift;
my ($rc, $msg) = $self->run_hooks("quit");
return $self->quit_respond($rc, $msg) unless $rc == CONTINUATION;
return 1;
$self->run_hooks("quit");
}
sub quit_respond {
my ($self, $rc, $msg) = @_;
my ($self, $rc, $msg, $args) = @_;
if ($rc != DONE) {
$self->respond(221, $self->config('me') . " closing connection. Have a wonderful day.");
$msg->[0] ||= $self->config('me') . " closing connection. Have a wonderful day.";
$self->respond(221, @$msg);
}
$self->disconnect();
}
@ -589,37 +547,37 @@ sub disconnect {
$self->reset_transaction;
}
sub disconnect_respond { }
sub data {
my $self = shift;
my ($rc, $msg) = $self->run_hooks("data");
return $self->data_respond($rc, $msg) unless $rc == CONTINUATION;
return 1;
$self->run_hooks("data");
}
sub data_respond {
my ($self, $rc, $msg) = @_;
my ($self, $rc, $msg, $args) = @_;
if ($rc == DONE) {
return 1;
}
elsif ($rc == DENY) {
$self->respond(554, $msg || "Message denied");
$msg->[0] ||= "Message denied";
$self->respond(554, @$msg);
$self->reset_transaction();
return 1;
}
elsif ($rc == DENYSOFT) {
$self->respond(451, $msg || "Message denied temporarily");
$msg->[0] ||= "Message denied temporarily";
$self->respond(451, @$msg);
$self->reset_transaction();
return 1;
}
elsif ($rc == DENY_DISCONNECT) {
$self->respond(554, $msg || "Message denied");
$msg->[0] ||= "Message denied";
$self->respond(554, @$msg);
$self->disconnect;
return 1;
}
elsif ($rc == DENYSOFT_DISCONNECT) {
$self->respond(421, $msg || "Message denied temporarily");
$msg->[0] ||= "Message denied temporarily";
$self->respond(421, @$msg);
$self->disconnect;
return 1;
}
@ -700,37 +658,57 @@ sub data_respond {
$self->transaction->header($header);
my $smtp = $self->connection->hello eq "ehlo" ? "ESMTP" : "SMTP";
my $authheader = ($self->authenticated == OK)
? "(smtp-auth username $self->auth_user, mechanism $self->auth_mechanism)\n"
: "";
my $esmtp = substr($smtp,0,1) eq "E";
my $authheader;
my $sslheader;
if (defined $self->connection->notes('tls_enabled')
and $self->connection->notes('tls_enabled')) {
$smtp .= "S" if $esmtp; # RFC3848
$sslheader = "(".$self->connection->notes('tls_socket')->get_cipher()." encrypted) ";
}
if (defined $self->{_auth} and $self->{_auth} == OK) {
$smtp .= "A" if $esmtp; # RFC3848
$authheader = "(smtp-auth username $self->{_auth_user}, mechanism $self->{_auth_mechanism})\n";
}
$header->add("Received", "from ".$self->connection->remote_info
." (HELO ".$self->connection->hello_host . ") (".$self->connection->remote_ip
. ")\n $authheader by ".$self->config('me')." (qpsmtpd/".$self->version
.") with $smtp; ". (strftime('%a, %d %b %Y %H:%M:%S %z', localtime)),
.") with $sslheader$smtp; ". (strftime('%a, %d %b %Y %H:%M:%S %z', localtime)),
0);
# if we get here without seeing a terminator, the connection is
# probably dead.
$self->respond(451, "Incomplete DATA"), return 1 unless $complete;
unless ( $complete ) {
$self->respond(451, "Incomplete DATA");
$self->reset_transaction; # clean up after ourselves
return 1;
}
#$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;
if ( $max_size and $size > $max_size ) {
$self->respond(552, "Message too big!");
$self->reset_transaction; # clean up after ourselves
return 1;
}
($rc, $msg) = $self->run_hooks("data_post");
return $self->data_post_respond($rc, $msg) unless $rc == CONTINUATION;
$self->run_hooks("data_post");
}
sub data_post_respond {
my ($self, $rc, $msg) = @_;
my ($self, $rc, $msg, $args) = @_;
if ($rc == DONE) {
return 1;
}
elsif ($rc == DENY) {
$self->respond(552, $msg || "Message denied");
$msg->[0] ||= "Message denied";
$self->respond(552, @$msg);
}
elsif ($rc == DENYSOFT) {
$self->respond(452, $msg || "Message denied temporarily");
$msg->[0] ||= "Message denied temporarily";
$self->respond(452, @$msg);
}
else {
$self->queue($self->transaction);
@ -738,6 +716,7 @@ sub data_post_respond {
# DATA is always the end of a "transaction"
return $self->reset_transaction;
}
sub getline {
@ -752,28 +731,53 @@ sub getline {
sub queue {
my ($self, $transaction) = @_;
my ($rc, $msg) = $self->run_hooks("queue");
return $self->queue_respond($rc, $msg) unless $rc == CONTINUATION;
# First fire any queue_pre hooks
$self->run_hooks("queue_pre");
}
sub queue_pre_respond {
my ($self, $rc, $msg, $args) = @_;
if ($rc == DONE) {
return 1;
}
elsif ($rc != OK and $rc != DECLINED and $rc != 0 ) {
return $self->log(LOGERROR, "pre plugin returned illegal value");
return 0;
}
# If we got this far, run the queue hooks
$self->run_hooks("queue");
}
sub queue_respond {
my ($self, $rc, $msg) = @_;
my ($self, $rc, $msg, $args) = @_;
if ($rc == DONE) {
return 1;
}
elsif ($rc == OK) {
$self->respond(250, ($msg || 'Queued'));
$msg->[0] ||= 'Queued';
$self->respond(250, @$msg);
}
elsif ($rc == DENY) {
$self->respond(552, $msg || "Message denied");
$msg->[0] ||= 'Message denied';
$self->respond(552, @$msg);
}
elsif ($rc == DENYSOFT) {
$self->respond(452, $msg || "Message denied temporarily");
$msg->[0] ||= 'Message denied temporarily';
$self->respond(452, @$msg);
}
else {
$self->respond(451, $msg || "Queuing declined or disabled; try again later" );
$msg->[0] ||= 'Queuing declined or disabled; try again later';
$self->respond(451, @$msg);
}
# And finally run any queue_post hooks
$self->run_hooks("queue_post");
}
sub queue_post_respond {
my ($self, $rc, $msg, $args) = @_;
$self->log(LOGERROR, @$msg) unless ($rc == OK or $rc == 0);
}

44
lib/Qpsmtpd/SMTP/Prefork.pm Normal file
View File

@ -0,0 +1,44 @@
package Qpsmtpd::SMTP::Prefork;
use Qpsmtpd::SMTP;
use Qpsmtpd::Constants;
@ISA = qw(Qpsmtpd::SMTP);
sub dispatch {
my $self = shift;
my ($cmd) = lc shift;
$self->{_counter}++;
if ($cmd !~ /^(\w{1,12})$/ or !exists $self->{_commands}->{$1}) {
my ($rc, @msg) = $self->run_hooks("unrecognized_command", $cmd, @_);
@msg = map { split /\n/ } @msg;
if ($rc == DENY_DISCONNECT) {
$self->respond(521, @msg);
$self->disconnect;
}
elsif ($rc == DENY) {
$self->respond(500, @msg);
}
elsif ($rc == DONE) {
1;
}
else {
$self->respond(500, "Unrecognized command");
}
return 1
}
$cmd = $1;
if (1 or $self->{_commands}->{$cmd} and $self->can($cmd)) {
my ($result) = eval { $self->$cmd(@_) };
if ($@ =~ /^disconnect_tcpserver/) {
die "disconnect_tcpserver";
} elsif ($@) {
$self->log(LOGERROR, "XX: $@") if $@;
}
return $result if defined $result;
return $self->fault("command '$cmd' failed unexpectedly");
}
return;
}

320
lib/Qpsmtpd/SelectServer.pm Normal file
View File

@ -0,0 +1,320 @@
package Qpsmtpd::SelectServer;
use Qpsmtpd::SMTP;
use Qpsmtpd::Constants;
use IO::Socket;
use IO::Select;
use POSIX qw(strftime);
use Socket qw(CRLF);
use Fcntl;
use Tie::RefHash;
use Net::DNS;
@ISA = qw(Qpsmtpd::SMTP);
use strict;
our %inbuffer = ();
our %outbuffer = ();
our %ready = ();
our %lookup = ();
our %qp = ();
our %indata = ();
tie %ready, 'Tie::RefHash';
my $server;
my $select;
our $QUIT = 0;
$SIG{INT} = $SIG{TERM} = sub { $QUIT++ };
sub log {
my ($self, $trace, @log) = @_;
my $level = Qpsmtpd::TRACE_LEVEL();
$level = $self->init_logger unless defined $level;
warn join(" ", fileno($self->client), @log), "\n"
if $trace <= $level;
}
sub main {
my $class = shift;
my %opts = (LocalPort => 25, Reuse => 1, Listen => SOMAXCONN, @_);
$server = IO::Socket::INET->new(%opts) or die "Server: $@";
print "Listening on $opts{LocalPort}\n";
nonblock($server);
$select = IO::Select->new($server);
my $res = Net::DNS::Resolver->new;
# TODO - make this more graceful - let all current SMTP sessions finish
# before quitting!
while (!$QUIT) {
foreach my $client ($select->can_read(1)) {
#print "Reading $client\n";
if ($client == $server) {
my $client_addr;
$client = $server->accept();
next unless $client;
my $ip = $client->peerhost;
my $bgsock = $res->bgsend($ip);
$select->add($bgsock);
$lookup{$bgsock} = $client;
}
elsif (my $qpclient = $lookup{$client}) {
my $packet = $res->bgread($client);
my $ip = $qpclient->peerhost;
my $hostname = $ip;
if ($packet) {
foreach my $rr ($packet->answer) {
if ($rr->type eq 'PTR') {
$hostname = $rr->rdatastr;
}
}
}
# $packet->print;
$select->remove($client);
delete($lookup{$client});
my $qp = Qpsmtpd::SelectServer->new();
$qp->client($qpclient);
$qp{$qpclient} = $qp;
$qp->log(LOGINFO, "Connection number " . keys(%qp));
$inbuffer{$qpclient} = '';
$outbuffer{$qpclient} = '';
$ready{$qpclient} = [];
$qp->start_connection($ip, $hostname);
$qp->load_plugins;
my $rc = $qp->start_conversation;
if ($rc != DONE) {
close($client);
next;
}
$select->add($qpclient);
nonblock($qpclient);
}
else {
my $data = '';
my $rv = $client->recv($data, POSIX::BUFSIZ(), 0);
unless (defined($rv) && length($data)) {
freeclient($client)
unless ($! == POSIX::EWOULDBLOCK() ||
$! == POSIX::EINPROGRESS() ||
$! == POSIX::EINTR());
next;
}
$inbuffer{$client} .= $data;
while ($inbuffer{$client} =~ s/^([^\r\n]*)\r?\n//) {
#print "<$1\n";
push @{$ready{$client}}, $1;
}
}
}
#print "Processing...\n";
foreach my $client (keys %ready) {
my $qp = $qp{$client};
#print "Processing $client = $qp\n";
foreach my $req (@{$ready{$client}}) {
if ($indata{$client}) {
$qp->data_line($req . CRLF);
}
else {
$qp->log(LOGINFO, "dispatching $req");
defined $qp->dispatch(split / +/, $req, 2)
or $qp->respond(502, "command unrecognized: '$req'");
}
}
delete $ready{$client};
}
#print "Writing...\n";
foreach my $client ($select->can_write(1)) {
next unless $outbuffer{$client};
#print "Writing to $client\n";
my $rv = $client->send($outbuffer{$client}, 0);
unless (defined($rv)) {
warn("I was told to write, but I can't: $!\n");
next;
}
if ($rv == length($outbuffer{$client}) ||
$! == POSIX::EWOULDBLOCK())
{
#print "Sent all, or EWOULDBLOCK\n";
if ($qp{$client}->{__quitting}) {
freeclient($client);
next;
}
substr($outbuffer{$client}, 0, $rv, '');
delete($outbuffer{$client}) unless length($outbuffer{$client});
}
else {
print "Error: $!\n";
# Couldn't write all the data, and it wasn't because
# it would have blocked. Shut down and move on.
freeclient($client);
next;
}
}
}
}
sub freeclient {
my $client = shift;
#print "Freeing client: $client\n";
delete $inbuffer{$client};
delete $outbuffer{$client};
delete $ready{$client};
delete $qp{$client};
$select->remove($client);
close($client);
}
sub start_connection {
my $self = shift;
my $remote_ip = shift;
my $remote_host = shift;
$self->log(LOGNOTICE, "Connection from $remote_host [$remote_ip]");
my $remote_info = 'NOINFO';
# if the local dns resolver doesn't filter it out we might get
# ansi escape characters that could make a ps axw do "funny"
# things. So to be safe, cut them out.
$remote_host =~ tr/a-zA-Z\.\-0-9//cd;
$self->SUPER::connection->start(remote_info => $remote_info,
remote_ip => $remote_ip,
remote_host => $remote_host,
@_);
}
sub client {
my $self = shift;
@_ and $self->{_client} = shift;
$self->{_client};
}
sub nonblock {
my $socket = shift;
my $flags = fcntl($socket, F_GETFL, 0)
or die "Can't get flags for socket: $!";
fcntl($socket, F_SETFL, $flags | O_NONBLOCK)
or die "Can't set flags for socket: $!";
}
sub read_input {
my $self = shift;
die "read_input is disabled in SelectServer";
}
sub respond {
my ($self, $code, @messages) = @_;
my $client = $self->client || die "No client!";
while (my $msg = shift @messages) {
my $line = $code . (@messages?"-":" ").$msg;
$self->log(LOGINFO, ">$line");
$outbuffer{$client} .= "$line\r\n";
}
return 1;
}
sub disconnect {
my $self = shift;
#print "Disconnecting\n";
$self->{__quitting} = 1;
$self->SUPER::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");
$indata{$self->client()} = 1;
$self->{__buffer} = '';
$self->{__size} = 0;
$self->{__blocked} = "";
$self->{__in_header} = 1;
$self->{__complete} = 0;
$self->{__max_size} = $self->config('databytes') || 0;
}
sub data_line {
my $self = shift;
local $_ = shift;
if ($_ eq ".\r\n") {
$self->log(LOGDEBUG, "max_size: $self->{__max_size} / size: $self->{__size}");
delete $indata{$self->client()};
my $smtp = $self->connection->hello eq "ehlo" ? "ESMTP" : "SMTP";
if (!$self->transaction->header) {
$self->transaction->header(Mail::Header->new(Modify => 0, MailFrom => "COERCE"));
}
$self->transaction->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('%a, %d %b %Y %H:%M:%S %z', localtime)),
0);
#$self->respond(550, $self->transaction->blocked),return 1 if ($self->transaction->blocked);
$self->respond(552, "Message too big!"),return 1 if $self->{__max_size} and $self->{__size} > $self->{__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 {
$self->queue($self->transaction);
}
# DATA is always the end of a "transaction"
return $self->reset_transaction;
}
elsif ($_ eq ".\n") {
$self->respond(451, "See http://develooper.com/code/qpsmtpd/barelf.html");
$self->{__quitting} = 1;
return;
}
# add a transaction->blocked check back here when we have line by line plugin access...
unless (($self->{__max_size} and $self->{__size} > $self->{__max_size})) {
s/\r\n$/\n/;
s/^\.\./\./;
if ($self->{__in_header} and m/^\s*$/) {
$self->{__in_header} = 0;
my @header = split /\n/, $self->{__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.
my $header = Mail::Header->new(Modify => 0, MailFrom => "COERCE");
$header->extract(\@header);
$self->transaction->header($header);
$self->{__buffer} = "";
}
if ($self->{__in_header}) {
$self->{__buffer} .= $_;
}
else {
$self->transaction->body_write($_);
}
$self->{__size} += length $_;
}
}
1;

37
lib/Qpsmtpd/TcpServer.pm
View File

@ -1,6 +1,7 @@
package Qpsmtpd::TcpServer;
use Qpsmtpd::SMTP;
use Qpsmtpd::Constants;
use Socket;
@ISA = qw(Qpsmtpd::SMTP);
use strict;
@ -12,12 +13,25 @@ my $first_0;
sub start_connection {
my $self = shift;
die "Qpsmtpd::TcpServer must be started by tcpserver\n"
unless $ENV{TCPREMOTEIP};
my ($remote_host, $remote_info, $remote_ip);
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};
if ($ENV{TCPREMOTEIP}) {
# started from tcpserver (or some other superserver which
# exports the TCPREMOTE* variables.
$remote_ip = $ENV{TCPREMOTEIP};
$remote_host = $ENV{TCPREMOTEHOST} || "[$remote_ip]";
$remote_info = $ENV{TCPREMOTEINFO} ? "$ENV{TCPREMOTEINFO}\@$remote_host" : $remote_host;
} else {
# Started from inetd or similar.
# get info on the remote host from the socket.
# ignore ident/tap/...
my $hersockaddr = getpeername(STDIN)
or die "getpeername failed: $0 must be called from tcpserver, (x)inetd or a similar program which passes a socket to stdin";
my ($port, $iaddr) = sockaddr_in($hersockaddr);
$remote_ip = inet_ntoa($iaddr);
$remote_host = gethostbyaddr($iaddr, AF_INET) || "[$remote_ip]";
$remote_info = $remote_host;
}
$self->log(LOGNOTICE, "Connection from $remote_info [$remote_ip]");
# if the local dns resolver doesn't filter it out we might get
@ -61,9 +75,9 @@ sub read_input {
while (<STDIN>) {
alarm 0;
$_ =~ s/\r?\n$//s; # advanced chomp
$self->log(LOGDEBUG, "dispatching $_");
$self->log(LOGINFO, "dispatching $_");
$self->connection->notes('original_string', $_);
defined $self->dispatch(split / +/, $_)
defined $self->dispatch(split / +/, $_, 2)
or $self->respond(502, "command unrecognized: '$_'");
alarm $timeout;
}
@ -72,18 +86,21 @@ sub read_input {
sub respond {
my ($self, $code, @messages) = @_;
my $buf = '';
while (my $msg = shift @messages) {
my $line = $code . (@messages?"-":" ").$msg;
$self->log(LOGDEBUG, $line);
print "$line\r\n" or ($self->log(LOGERROR, "Could not print [$line]: $!"), return 0);
$self->log(LOGINFO, $line);
$buf .= "$line\r\n";
}
print $buf or ($self->log(LOGERROR, "Could not print [$buf]: $!"), return 0);
return 1;
}
sub disconnect {
my $self = shift;
$self->log(LOGDEBUG,"click, disconnecting");
$self->log(LOGINFO,"click, disconnecting");
$self->SUPER::disconnect(@_);
$self->run_hooks("post-connection");
exit;
}

65
lib/Qpsmtpd/TcpServer/Prefork.pm Normal file
View File

@ -0,0 +1,65 @@
package Qpsmtpd::TcpServer::Prefork;
use Qpsmtpd::TcpServer;
use Qpsmtpd::SMTP::Prefork;
use Qpsmtpd::Constants;
@ISA = qw(Qpsmtpd::SMTP::Prefork Qpsmtpd::TcpServer);
my $first_0;
sub start_connection {
my $self = shift;
#reset info
$self->{_connection} = Qpsmtpd::Connection->new(); #reset connection
$self->{_transaction} = Qpsmtpd::Transaction->new(); #reset transaction
$self->SUPER::start_connection(@_);
}
sub read_input {
my $self = shift;
my $timeout =
$self->config('timeoutsmtpd') # qmail smtpd control file
|| $self->config('timeout') # qpsmtpd control file
|| 1200; # default value
alarm $timeout;
eval {
while (<STDIN>) {
alarm 0;
$_ =~ s/\r?\n$//s; # advanced chomp
$self->log(LOGDEBUG, "dispatching $_");
$self->connection->notes('original_string', $_);
defined $self->dispatch(split / +/, $_, 2)
or $self->respond(502, "command unrecognized: '$_'");
alarm $timeout;
}
};
if ($@ =~ /^disconnect_tcpserver/) {
die "disconnect_tcpserver";
} else {
die "died while reading from STDIN (probably broken sender) - $@";
}
alarm(0);
}
sub respond {
my ($self, $code, @messages) = @_;
while (my $msg = shift @messages) {
my $line = $code . (@messages?"-":" ").$msg;
$self->log(LOGDEBUG, $line);
print "$line\r\n" or ($self->log(LOGERROR, "Could not print [$line]: $!"), return 0);
}
return 1;
}
sub disconnect {
my $self = shift;
$self->log(LOGDEBUG,"click, disconnecting");
$self->SUPER::disconnect(@_);
$self->run_hooks("post-connection");
die "disconnect_tcpserver";
}
1;

53
lib/Qpsmtpd/Transaction.pm
View File

@ -13,7 +13,7 @@ sub start {
my $proto = shift;
my $class = ref($proto) || $proto;
my %args = @_;
my $self = { _notes => { capabilities => [] }, _rcpt => [], started => time };
my $self = { _rcpt => [], started => time };
bless ($self, $class);
return $self;
}
@ -141,10 +141,23 @@ sub body_write {
}
}
sub body_size {
sub body_size { # depreceated, use data_size() instead
my $self = shift;
$self->log(LOGWARN, "WARNING: body_size() is depreceated, use data_size() instead");
$self->{_body_size} || 0;
}
sub data_size {
shift->{_body_size} || 0;
}
sub body_length {
my $self = shift;
$self->{_body_size} or return 0;
$self->{_header_size} or return 0;
return $self->{_body_size} - $self->{_header_size};
}
sub body_resetpos {
my $self = shift;
@ -190,6 +203,10 @@ sub body_as_string {
return $str;
}
sub body_fh {
return shift->{_body_file};
}
sub DESTROY {
my $self = shift;
# would we save some disk flushing if we unlinked the file before
@ -294,6 +311,11 @@ use the notes field in the C<Qpsmtpd::Connection> object instead.
Returns the temporary filename used to store the message contents; useful for
virus scanners so that an additional copy doesn't need to be made.
Calling C<body_filename()> also forces spooling to disk. A message is not
spooled to disk if it's size is smaller than
I<$self-E<gt>config("size_threshold")>, default threshold is 0, the sample
config file sets this to 10000.
=head2 body_write( $data )
Write data to the end of the email.
@ -302,7 +324,26 @@ C<$data> can be either a plain scalar, or a reference to a scalar.
=head2 body_size( )
Get the current size of the email.
B<Depreceated>, Use I<data_size()> instead.
=head2 data_size( )
Get the current size of the email. Note that this is not the size of the
message that will be queued, it is the size of what the client sent after
the C<DATA> command. If you need the size that will be queued, use
my $msg_len = length($transaction->header->as_string)
+ $transaction->body_length;
The line above is of course only valid in I<hook_queue( )>, as other plugins
may add headers and qpsmtpd will add it's I<Received:> header.
=head2 body_length( )
Get the current length of the body of the email. This length includes the
empty line between the headers and the body. Until the client has sent
some data of the body of the message (i.e. headers are finished and client
sent the empty line) this will return 0.
=head2 body_resetpos( )
@ -316,6 +357,12 @@ file pointer.
Returns a single line of data from the body of the email.
=head2 body_fh( )
Returns the file handle to the temporary file of the email. This will return
undef if the file is not opened (yet). In I<hook_data( )> or later you can
force spooling to disk by calling I<$transaction-E<gt>body_filename>.
=head1 SEE ALSO
L<Mail::Header>, L<Qpsmtpd::Address>, L<Qpsmtpd::Connection>

15
plugins/auth/auth_vpopmail_sql
View File

@ -60,21 +60,18 @@ sub authsql {
use DBI;
use Qpsmtpd::Constants;
use Digest::HMAC_MD5 qw(hmac_md5_hex);
my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket )
= @_;
# $DB::single = 1;
my $connect = "dbi:mysql:dbname=vpopmail";
my $dbuser = "vpopmailuser";
my $dbpasswd = "**********";
my $dbpasswd = "vpoppasswd";
my $dbh = DBI->connect( $connect, $dbuser, $dbpasswd,
{ PrintError => 0, } )
or (
$self->log(LOGERROR, $DBI::errstr)
and return DECLINED
);
my $dbh = DBI->connect( $connect, $dbuser, $dbpasswd );
$dbh->{ShowErrorStatement} = 1;
my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) =
@_;
my ( $pw_name, $pw_domain ) = split "@", lc($user);
unless ( defined $pw_domain ) {

14
plugins/check_badmailfrom
View File

@ -1,7 +1,7 @@
# -*- perl -*-
=head1 NAME
check_badmailfrom - checks the standard badmailfrom config
check_badmailfrom - checks the badmailfrom config, with per-line reasons
=head1 DESCRIPTION
@ -13,6 +13,9 @@ recipient address for a message if the envelope sender address is
listed in badmailfrom. A line in badmailfrom may be of the form
@host, meaning every address at host."
You may optionally include a message after the sender address (leave a space),
which is used when rejecting the sender.
=head1 NOTES
According to the SMTP protocol, we can't reject until after the RCPT
@ -21,7 +24,7 @@ stage, so store it until later.
=cut
sub hook_mail {
my ($self, $transaction, $sender) = @_;
my ($self, $transaction, $sender, %param) = @_;
my @badmailfrom = $self->qp->config("badmailfrom")
or return (DECLINED);
@ -33,18 +36,21 @@ sub hook_mail {
my $from = lc($sender->user) . '@' . $host;
for my $bad (@badmailfrom) {
my $reason = $bad;
$reason =~ s/^\s*(\S+)[\t\s]+//;
$reason = "sorry, your envelope sender is in my badmailfrom list" unless $reason;
$bad =~ s/^\s*(\S+).*/$1/;
next unless $bad;
$bad = lc $bad;
$self->log(LOGWARN, "Bad badmailfrom config: No \@ sign in $bad") and next unless $bad =~ m/\@/;
$transaction->notes('badmailfrom', "sorry, your envelope sender is in my badmailfrom list")
$transaction->notes('badmailfrom', $reason)
if ($bad eq $from) || (substr($bad,0,1) eq '@' && $bad eq "\@$host");
}
return (DECLINED);
}
sub hook_rcpt {
my ($self, $transaction, $rcpt) = @_;
my ($self, $transaction, $rcpt, %param) = @_;
my $note = $transaction->notes('badmailfrom');
if ($note) {
$self->log(LOGINFO, $note);

4
plugins/check_badmailfromto
View File

@ -17,7 +17,7 @@ Based heavily on check_badmailfrom.
=cut
sub hook_mail {
my ($self, $transaction, $sender) = @_;
my ($self, $transaction, $sender, %param) = @_;
my @badmailfromto = $self->qp->config("badmailfromto")
or return (DECLINED);
@ -41,7 +41,7 @@ sub hook_mail {
}
sub hook_rcpt {
my ($self, $transaction, $rcpt) = @_;
my ($self, $transaction, $rcpt, %param) = @_;
my $recipient = lc($rcpt->user) . '@' . lc($rcpt->host);
my $sender = $transaction->notes('badmailfromto');
if ($sender) {

7
plugins/check_badrcptto
View File

@ -1,7 +1,8 @@
# this plugin checks the badrcptto config (like badmailfrom for rcpt address)
use Qpsmtpd::DSN;
sub hook_rcpt {
my ($self, $transaction, $recipient) = @_;
my ($self, $transaction, $recipient, %param) = @_;
my @badrcptto = $self->qp->config("badrcptto") or return (DECLINED);
return (DECLINED) unless $recipient->host && $recipient->user;
my $host = lc $recipient->host;
@ -9,9 +10,9 @@ sub hook_rcpt {
for my $bad (@badrcptto) {
$bad = lc $bad;
$bad =~ s/^\s*(\S+)/$1/;
return (DENY, "mail to $bad not accepted here")
return Qpsmtpd::DSN->no_such_user("mail to $bad not accepted here")
if $bad eq $from;
return (DENY, "mail to $bad not accepted here")
return Qpsmtpd::DSN->no_such_user("mail to $bad not accepted here")
if substr($bad,0,1) eq '@' && $bad eq "\@$host";
}
return (DECLINED);

2
plugins/check_basicheaders
View File

@ -44,7 +44,7 @@ sub hook_data_post {
my ($self, $transaction) = @_;
return (DENY, "You have to send some data first")
if $transaction->body_size == 0;
if $transaction->data_size == 0;
return (DENY, "Mail with no From header not accepted here")
unless $transaction->header->get('From');

97
plugins/check_earlytalker
View File

@ -44,20 +44,14 @@ issued a deny or denysoft (depending on the value of I<action>). The default
is to react at the SMTP greeting stage by issuing the apropriate response code
and terminating the SMTP connection.
=item check-at [string: connect, data]
Defines when to check for early talkers, either at connect time (pre-greet pause)
or at DATA time (pause before sending "354 go ahead").
The default is I<connect>.
Note that defer-reject has no meaning if check-at is I<data>.
=back
=cut
my $MSG = 'Connecting host started transmitting before SMTP greeting';
use IO::Select;
use warnings;
use strict;
sub register {
my ($self, $qp, @args) = @_;
@ -70,27 +64,22 @@ sub register {
'wait' => 1,
'action' => 'denysoft',
'defer-reject' => 0,
'check-at' => 'connect',
@args,
};
print STDERR "Check at: ", $self->{_args}{'check-at'}, "\n";
if ($qp->isa('Qpsmtpd::Apache')) {
if ($qp->{conn} && $qp->{conn}->isa('Apache2::Connection')) {
require APR::Const;
APR::Const->import(qw(POLLIN SUCCESS));
$self->register_hook($self->{_args}->{'check-at'}, 'check_talker_apr');
$self->register_hook('connect', 'apr_connect_handler');
}
else {
$self->register_hook($self->{_args}->{'check-at'}, 'check_talker_poll');
$self->register_hook('connect', 'connect_handler');
}
$self->register_hook($self->{_args}->{'check-at'}, 'check_talker_post');
if ($self->{_args}{'check-at'} eq 'connect') {
$self->register_hook('mail', 'hook_mail')
$self->register_hook('mail', 'mail_handler')
if $self->{_args}->{'defer-reject'};
}
1;
}
sub check_talker_apr {
sub apr_connect_handler {
my ($self, $transaction) = @_;
return DECLINED if ($self->qp->connection->notes('whitelistclient'));
@ -107,53 +96,47 @@ sub check_talker_apr {
$self->qp->connection->notes('earlytalker', 1);
}
else {
return (DENY,$MSG) if $self->{_args}->{'action'} eq 'deny';
return (DENYSOFT,$MSG) if $self->{_args}->{'action'} eq 'denysoft';
my $msg = 'Connecting host started transmitting before SMTP greeting';
return (DENY,$msg) if $self->{_args}->{'action'} eq 'deny';
return (DENYSOFT,$msg) if $self->{_args}->{'action'} eq 'denysoft';
}
}
else {
$self->log(LOGINFO, "remote host said nothing spontaneous, proceeding");
}
}
sub connect_handler {
my ($self, $transaction) = @_;
my $in = new IO::Select;
my $ip = $self->qp->connection->remote_ip;
return DECLINED
if ($self->qp->connection->notes('whitelistclient'));
$in->add(\*STDIN) || return DECLINED;
if ($in->can_read($self->{_args}->{'wait'})) {
$self->log(LOGNOTICE, "remote host started talking before we said hello [$ip]");
if ($self->{_args}->{'defer-reject'}) {
$self->qp->connection->notes('earlytalker', 1);
} else {
my $msg = 'Connecting host started transmitting before SMTP greeting';
return (DENY,$msg) if $self->{_args}->{'action'} eq 'deny';
return (DENYSOFT,$msg) if $self->{_args}->{'action'} eq 'denysoft';
}
} else {
$self->log(LOGINFO, 'remote host said nothing spontaneous, proceeding');
}
return DECLINED;
}
sub check_talker_poll {
my ($self, $transaction) = @_;
my $qp = $self->qp;
my $conn = $qp->connection;
$qp->AddTimer($self->{_args}{'wait'}, sub { read_now($qp, $conn, $self->{_args}{'check-at'}) });
return CONTINUATION;
}
sub read_now {
my ($qp, $conn, $phase) = @_;
if ($qp->has_data) {
$qp->log(LOGNOTICE, 'remote host started talking before we said hello');
$qp->clear_data if $phase eq 'data';
$conn->notes('earlytalker', 1);
}
$qp->finish_continuation;
}
sub check_talker_post {
my ($self, $transaction) = @_;
my $conn = $self->qp->connection;
return DECLINED unless $conn->notes('earlytalker');
return DECLINED if $self->{'defer-reject'};
return (DENY,$MSG) if $self->{_args}->{'action'} eq 'deny';
return (DENYSOFT,$MSG) if $self->{_args}->{'action'} eq 'denysoft';
return DECLINED; # assume action eq 'log'
}
sub hook_mail {
sub mail_handler {
my ($self, $txn) = @_;
my $msg = 'Connecting host started transmitting before SMTP greeting';
return DECLINED unless $self->connection->notes('earlytalker');
return (DENY,$MSG) if $self->{_args}->{'action'} eq 'deny';
return (DENYSOFT,$MSG) if $self->{_args}->{'action'} eq 'denysoft';
return DECLINED unless $self->qp->connection->notes('earlytalker');
return (DENY,$msg) if $self->{_args}->{'action'} eq 'deny';
return (DENYSOFT,$msg) if $self->{_args}->{'action'} eq 'denysoft';
return DECLINED;
}

6
plugins/check_loop
View File

@ -25,8 +25,9 @@ Written by Keith C. Ivey
Released to the public domain, 17 June 2005.
=cut
use Qpsmtpd::DSN;
sub register {
sub init {
my ($self, $qp, @args) = @_;
$self->{_max_hops} = $args[0] || 100;
@ -45,7 +46,8 @@ sub hook_data_post {
$transaction->header->get('Delivered-To');
if ( $hops >= $self->{_max_hops} ) {
return DENY, "Too many hops. This message is looping.";
# default of too_many_hops is DENY, see comment in POD of Qpsmtpd::DSN
return Qpsmtpd::DSN->too_many_hops();
}
return DECLINED;

2
plugins/check_relay
View File

@ -19,7 +19,7 @@ sub hook_connect {
$connection->relay_client(1);
last;
}
$client_ip =~ s/\d+\.?$//; # strip off another 8 bits
$client_ip =~ s/(\d|\w|::)+(:|\.)?$//; # strip off another 8 bits
}
return (DECLINED);

7
plugins/count_unrecognized_commands
View File

@ -25,8 +25,13 @@ sub register {
$self->{_unrec_cmd_max} = 4;
}
$qp->connection->notes('unrec_cmd_count', 0);
}
sub hook_connect {
my ($self, $transaction) = @_;
$self->qp->connection->notes('unrec_cmd_count', 0);
return DECLINED;
}
sub hook_unrecognized_command {

2
plugins/dns_whitelist_soft
View File

@ -139,7 +139,7 @@ sub process_sockets {
}
sub hook_rcpt {
my ($self, $transaction, $rcpt) = @_;
my ($self, $transaction, $rcpt, %param) = @_;
my $ip = $self->qp->connection->remote_ip || return (DECLINED);
my $note = $self->process_sockets;
if ( $note ) {

205
plugins/dnsbl
View File

@ -1,8 +1,17 @@
#!/usr/bin/perl -w
#!perl -w
use Danga::DNS;
=head1 NAME
sub init {
dnsbl - handle DNS BlackList lookups
=head1 DESCRIPTION
Plugin that checks the IP address of the incoming connection against
a configurable set of RBL services.
=cut
sub register {
my ($self, $qp, $denial ) = @_;
if ( defined $denial and $denial =~ /^disconnect$/i ) {
$self->{_dnsbl}->{DENY} = DENY_DISCONNECT;
@ -16,7 +25,7 @@ sub init {
sub hook_connect {
my ($self, $transaction) = @_;
my $remote_ip = $self->connection->remote_ip;
my $remote_ip = $self->qp->connection->remote_ip;
# perform RBLSMTPD checks to mimic Dan Bernstein's rblsmtpd
if (defined($ENV{'RBLSMTPD'})) {
@ -31,94 +40,162 @@ sub hook_connect {
$self->log(LOGDEBUG, "RBLSMTPD not set for $remote_ip");
}
my $allow = grep { s/\.?$/./; $_ eq substr($remote_ip . '.', 0, length $_) } $self->config('dnsbl_allow');
my $allow = grep { s/\.?$/./; $_ eq substr($remote_ip . '.', 0, length $_) } $self->qp->config('dnsbl_allow');
return DECLINED if $allow;
my %dnsbl_zones = map { (split /:/, $_, 2)[0,1] } $self->config('dnsbl_zones');
my %dnsbl_zones = map { (split /:/, $_, 2)[0,1] } $self->qp->config('dnsbl_zones');
return DECLINED unless %dnsbl_zones;
my $reversed_ip = join(".", reverse(split(/\./, $remote_ip)));
my $total_zones = keys %dnsbl_zones;
my $qp = $self->qp;
# we should queue these lookups in the background and just fetch the
# results in the first rcpt handler ... oh well.
my $res = new Net::DNS::Resolver;
$res->tcp_timeout(30);
$res->udp_timeout(30);
my $sel = IO::Select->new();
my $dom;
for my $dnsbl (keys %dnsbl_zones) {
# fix to find A records, if the dnsbl_zones line has a second field 20/1/04 ++msp
$dom->{"$reversed_ip.$dnsbl"} = 1;
if (defined($dnsbl_zones{$dnsbl})) {
$self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for A record in the background");
Danga::DNS->new(
callback => sub { process_a_result($qp, $dnsbl_zones{$dnsbl}, @_) },
finished => sub { $total_zones--; finished($qp, $total_zones) },
host => "$reversed_ip.$dnsbl",
type => 'A',
client => $self->qp->input_sock,
);
$sel->add($res->bgsend("$reversed_ip.$dnsbl"));
} else {
$self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for TXT record in the background");
Danga::DNS->new(
callback => sub { process_txt_result($qp, @_) },
finished => sub { $total_zones--; finished($qp, $total_zones) },
host => "$reversed_ip.$dnsbl",
type => 'TXT',
client => $self->qp->input_sock,
);
$sel->add($res->bgsend("$reversed_ip.$dnsbl", "TXT"));
}
}
return CONTINUATION;
$self->qp->connection->notes('dnsbl_sockets', $sel);
$self->qp->connection->notes('dnsbl_domains', $dom);
return DECLINED;
}
sub finished {
my ($qp, $total_zones) = @_;
$qp->finish_continuation unless $total_zones;
}
sub process_sockets {
my ($self) = @_;
sub process_a_result {
my ($qp, $template, $result, $query) = @_;
my $conn = $self->qp->connection;
$qp->log(LOGINFO, "Result for A $query: $result\n");
if ($result !~ /^\d+\.\d+\.\d+\.\d+$/) {
# NXDOMAIN or ERROR possibly...
# $qp->finish_continuation if $qp->input_sock->readable;
return;
return $conn->notes('dnsbl')
if $conn->notes('dnsbl');
my %dnsbl_zones = map { (split /:/, $_, 2)[0,1] } $self->qp->config('dnsbl_zones');
my $res = new Net::DNS::Resolver;
$res->tcp_timeout(30);
$res->udp_timeout(30);
my $sel = $conn->notes('dnsbl_sockets') or return "";
my $dom = $conn->notes('dnsbl_domains');
my $remote_ip = $self->qp->connection->remote_ip;
my $result;
$self->log(LOGDEBUG, "waiting for dnsbl dns");
# don't wait more than 8 seconds here
my @ready = $sel->can_read(8);
$self->log(LOGDEBUG, "DONE waiting for dnsbl dns, got " , scalar @ready, " answers ...") ;
return '' unless @ready;
for my $socket (@ready) {
my $query = $res->bgread($socket);
$sel->remove($socket);
undef $socket;
my $dnsbl;
if ($query) {
my $a_record = 0;
foreach my $rr ($query->answer) {
my $name = $rr->name;
$self->log(LOGDEBUG, "name $name");
next unless $dom->{$name};
$self->log(LOGDEBUG, "name $name was queried");
$a_record = 1 if $rr->type eq "A";
($dnsbl) = ($name =~ m/(?:\d+\.){4}(.*)/) unless $dnsbl;
$dnsbl = $name unless $dnsbl;
next unless $rr->type eq "TXT";
$self->log(LOGDEBUG, "got txt record");
$result = $rr->txtdata and last;
}
#$a_record and $result = "Blocked by $dnsbl";
if ($a_record) {
if (defined $dnsbl_zones{$dnsbl}) {
$result = $dnsbl_zones{$dnsbl};
#$result =~ s/%IP%/$ENV{'TCPREMOTEIP'}/g;
$result =~ s/%IP%/$remote_ip/g;
} else {
# shouldn't get here?
$result = "Blocked by $dnsbl";
}
}
}
else {
$self->log(LOGERROR, "$dnsbl query failed: ", $res->errorstring)
unless $res->errorstring eq "NXDOMAIN";
}
my $conn = $qp->connection;
my $ip = $conn->remote_ip;
$template =~ s/%IP%/$ip/g;
$conn->notes('dnsbl', $template) unless $conn->notes('dnsbl');
# $qp->finish_continuation if $qp->input_sock->readable;
}
sub process_txt_result {
my ($qp, $result, $query) = @_;
$qp->log(LOGINFO, "Result for TXT $query: $result\n");
if ($result !~ /[a-z]/) {
# NXDOMAIN or ERROR probably...
# $qp->finish_continuation if $qp->input_sock->readable;
return;
if ($result) {
#kill any other pending I/O
$conn->notes('dnsbl_sockets', undef);
$result = join("\n", $self->qp->config('dnsbl_rejectmsg'), $result);
return $conn->notes('dnsbl', $result);
}
}
my $conn = $qp->connection;
$conn->notes('dnsbl', $result) unless $conn->notes('dnsbl');
# $qp->finish_continuation if $qp->input_sock->readable;
if ($sel->count) {
# loop around if we have dns blacklists left to see results from
return $self->process_sockets();
}
# er, the following code doesn't make much sense anymore...
# if there was more to read; then forget it
$conn->notes('dnsbl_sockets', undef);
return $conn->notes('dnsbl', $result);
}
sub hook_rcpt {
my ($self, $transaction, $rcpt) = @_;
my ($self, $transaction, $rcpt, %param) = @_;
my $connection = $self->qp->connection;
# RBLSMTPD being non-empty means it contains the failure message to return
if (defined ($ENV{'RBLSMTPD'}) && $ENV{'RBLSMTPD'} ne '') {
my $result = $ENV{'RBLSMTPD'};
my $remote_ip = $self->connection->remote_ip;
my $remote_ip = $connection->remote_ip;
$result =~ s/%IP%/$remote_ip/g;
return (DENY, join(" ", $self->config('dnsbl_rejectmsg'), $result));
return ($self->{_dnsbl}->{DENY},
join(" ", $self->qp->config('dnsbl_rejectmsg'), $result));
}
my $note = $self->connection->notes('dnsbl');
return (DENY, $note) if $note;
my $note = $self->process_sockets;
my $whitelist = $connection->notes('whitelisthost');
if ( $note ) {
if ( $rcpt->user =~ /^(?:postmaster|abuse|mailer-daemon|root)$/i ) {
$self->log(LOGWARN, "Don't blacklist special account: ".$rcpt->user);
}
elsif ( $whitelist ) {
$self->log(LOGWARN, "Whitelist overrode blacklist: $whitelist");
}
elsif ( $connection->relay_client() ) {
$self->log(LOGWARN, "Don't blacklist relay/auth clients");
}
else {
return ($self->{_dnsbl}->{DENY}, $note);
}
}
return DECLINED;
}
sub hook_disconnect {
@ -131,14 +208,18 @@ sub hook_disconnect {
1;
=head1 NAME
=head1 Usage
dnsbl - handle DNS BlackList lookups
Add the following line to the config/plugins file:
=head1 DESCRIPTION
dnsbl [disconnect]
Plugin that checks the IP address of the incoming connection against
a configurable set of RBL services.
If you want to immediately drop the connection (since some blacklisted
servers attempt multiple sends per session), add the optional keyword
"disconnect" (case insensitive) to the config line. In most cases, an
IP address that is listed should not be given the opportunity to begin
a new transaction, since even the most volatile blacklists will return
the same answer for a short period of time (the minimum DNS cache period).
=head1 Configuration files

116
plugins/domainkeys Normal file
View File

@ -0,0 +1,116 @@
sub init {
my ($self, $qp, %args) = @_;
foreach my $key ( %args ) {
$self->{$key} = $args{$key};
}
}
sub hook_data_post {
use Mail::DomainKeys::Message;
use Mail::DomainKeys::Policy;
my ($self, $transaction) = @_;
# if this isn't signed, just move along
return DECLINED
unless $transaction->header->get('DomainKey-Signature');
my @body;
$transaction->body_resetpos;
$transaction->body_getline; # \r\n seperator is NOT part of the body
while (my $line = $transaction->body_getline) {
push @body, $line;
}
my $message = load Mail::DomainKeys::Message(
HeadString => $transaction->header->as_string,
BodyReference => \@body) or
$self->log(LOGWARN, "unable to load message"),
return DECLINED;
# no sender domain means no verification
$message->senderdomain or
return DECLINED;
my $status;
# key testing
if ( $message->testing ) {
# Don't do anything else
$status = "testing";
}
elsif ( $message->signed and $message->verify ) {
# verified: add good header
$status = $message->signature->status;
}
else { # not signed or not verified
my $policy = fetch Mail::DomainKeys::Policy(
Protocol => "dns",
Domain => $message->senderdomain
);
if ( $policy ) {
if ( $policy->testing ) {
# Don't do anything else
$status = "testing";
}
elsif ( $policy->signall ) {
# if policy requires all mail to be signed
$status = undef;
}
else { # $policy->signsome
# not signed and domain doesn't sign all
$status = "no signature";
}
}
else {
$status = $message->signed ? "non-participant" : "no signature";
}
}
if ( defined $status ) {
$transaction->header->replace("DomainKey-Status", $status);
$self->log(LOGWARN, "DomainKeys-Status: $status");
return DECLINED;
}
else {
$self->log(LOGERROR, "DomainKeys signature failed to verify");
if ( $self->{warn_only} ) {
return DECLINED;
}
else {
return (DENY, "DomainKeys signature failed to verify");
}
}
}
=cut
=head1 NAME
domainkeys: validate a DomainKeys signature on an incoming mail
=head1 SYNOPSIS
domainkeys [warn_only 1]
Performs a DomainKeys validation on the message. Takes a single
configuration
warn_only 1
which means that messages which are not correctly signed (i.e. signed but
modified or deliberately forged) will not be DENY'd, but an error will still
be issued to the logfile.
=head1 COPYRIGHT
Copyright (C) 2005-2006 John Peacock.
Portions Copyright (C) 2004 Anthony D. Urso. All rights reserved. This
program is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.

19
plugins/dont_require_anglebrackets Normal file
View File

@ -0,0 +1,19 @@
#
# dont_require_anglebrackets - accept addresses in MAIL FROM:/RCPT TO:
# commands without surrounding <>
#
sub hook_mail_pre {
my ($self,$transaction, $addr) = @_;
unless ($addr =~ /^<.*>$/) {
$addr = "<".$addr.">";
}
return (OK, $addr);
}
sub hook_rcpt_pre {
my ($self,$transaction, $addr) = @_;
unless ($addr =~ /^<.*>$/) {
$addr = "<".$addr.">";
}
return (OK, $addr);
}

24
plugins/greylisting
View File

@ -78,6 +78,22 @@ deliveries); in 'off' mode we do nothing (useful for turning
greylisting off globally if using per_recipient configs).
Default: denysoft.
=item db_dir <path>
Path to a directory in which the greylisting DB will be stored. This
directory must be writable by the qpsmtpd user. By default, the first
usable directory from the following list will be used:
=over 4
=item /var/lib/qpsmtpd/greylisting
=item I<BINDIR>/var/db (where BINDIR is the location of the qpsmtpd binary)
=item I<BINDIR>/config
=back
=item per_recipient <bool>
Flag to indicate whether to use per-recipient configs.
@ -85,7 +101,8 @@ Flag to indicate whether to use per-recipient configs.
=item per_recipient_db <bool>
Flag to indicate whether to use per-recipient greylisting
databases (default is to use a shared database).
databases (default is to use a shared database). Per-recipient configuration
directories, if determined, supercede I<db_dir>.
=back
@ -191,7 +208,10 @@ sub denysoft_greylist {
# Setup database location
my $dbdir = $transaction->notes('per_rcpt_configdir')
if $config->{per_recipient_db};
$dbdir ||= -d "$QPHOME/var/db" ? "$QPHOME/var/db" : "$QPHOME/config";
for my $d ($dbdir, $config->{db_dir}, "/var/lib/qpsmtpd/greylisting",
"$QPHOME/var/db", "$QPHOME/config") {
last if $dbdir ||= $d && -d $d && $d;
}
my $db = "$dbdir/$DB";
$self->log(LOGINFO,"using $db as greylisting database");

80
plugins/hosts_allow Normal file
View File

@ -0,0 +1,80 @@
=head1 NAME
hosts_allow - decide if a host is allowed to send mail
=head1 DESCRIPTION
The B<hosts_allow> module decides before the SMTP-Greeting if a host is
allowed to connect. It checks for too many (running) connections from one
host (see -m/--max-from-ip options in qpsmtpd-forkserver) and the config
file I<hosts_allow>.
The plugin takes no arguments.
=head1 CONFIG
The config file contains lines with two or three items. The first is either
an IP address or a network/mask pair. The second is a (valid) return code
from Qpsmtpd::Constants. The last is a comment which will be returned to the
connecting client if the return code is DENY or DENYSOFT (and of course
DENY_DISCONNECT and DENYSOFT_DISCONNECT).
Example:
192.168.3.4 DECLINED
192.168.3.0/24 DENY Sorry, known spam only source
This would exclude 192.168.3.4 from the DENY of 192.168.3.0/24.
=cut
use Qpsmtpd::Constants;
use Socket;
sub hook_pre_connection {
my ($self,$transaction,%args) = @_;
# remote_ip => inet_ntoa($iaddr),
# remote_port => $port,
# local_ip => inet_ntoa($laddr),
# local_port => $lport,
# max_conn_ip => $MAXCONNIP,
# child_addrs => [values %childstatus],
my $remote = $args{remote_ip};
if ($args{max_conn_ip}) {
my $num_conn = 1; # seed with current value
my $raddr = inet_aton($remote);
foreach my $rip (@{$args{child_addrs}}) {
++$num_conn if (defined $rip && $rip eq $raddr);
}
if ($num_conn > $args{max_conn_ip}) {
$self->log(LOGINFO,
"Too many connections from $remote: "
. "$num_conn > " . $args{max_conn_ip}
. "Denying connection.");
return (DENYSOFT, "Sorry, too many connections from $remote, "
."try again later");
}
}
foreach ($self->qp->config("hosts_allow")) {
s/^\s*//;
my ($ipmask, $const, $message) = split /\s+/, $_, 3;
next unless defined $const;
my ($net,$mask) = split '/', $ipmask, 2;
if (!defined $mask) {
$mask = 32;
}
$mask = pack "B32", "1"x($mask)."0"x(32-$mask);
if (join(".", unpack("C4", inet_aton($remote) & $mask)) eq $net) {
$const = Qpsmtpd::Constants::return_code($const) || DECLINED;
return($const, $message);
}
}
return (DECLINED);
}
# vim: sw=4 ts=4 expandtab syn=perl

2
plugins/logging/adaptive
View File

@ -44,10 +44,8 @@ sub hook_logging { # wlog
return DECLINED if defined $plugin and $plugin eq $self->plugin_name;
if ( defined $self->{_maxlevel} && $trace <= $self->{_maxlevel} ) {
my $fd = $self->fd();
warn join(
" ", $$.
(defined $fd ? " fd:$fd" : "") .
(
defined $plugin ? " $plugin plugin:"
: defined $hook ? " running plugin ($hook):"

267
plugins/logging/file Normal file
View File

@ -0,0 +1,267 @@
#!/usr/bin/perl
# $Id$
=head1 NAME
file - Simple log-to-file logging for qpsmtpd
=head1 DESCRIPTION
The 'file' logging plugin for qpsmtpd records qpsmtpd log messages into a
file (or a named pipe, if you prefer.)
=head1 CONFIGURATION
To enable the logging plugin, add a line of this form to the qpsmtpd plugins
configuration file:
=over
logging/file [loglevel I<level>] [reopen] [nosplit] I<path>
For example:
logging/file loglevel LOGINFO /var/log/qpsmtpd.log
logging/file /var/log/qpsmtpd.log.%Y-%m-%d
logging/file loglevel LOGCRIT reopen |/usr/local/sbin/page-sysadmin
=back
Multiple instances of the plugin can be configured by appending :I<N> for any
integer(s) I<N>, to log to multiple files simultaneously, e.g. to log critical
errors and normally verbose logs elsewhere.
The filename or command given can include strftime conversion specifiers,
which can be used to substitute time and date information into the logfile.
The file will be reopened whenever this output changes (for example, with a
format of qpsmtpd.log.%Y-%m-%d-%h, the log would be reopened once per hour).
The list of supported conversion specifiers depends on the strftime()
implementation of your C library. See strftime(3) for details. Additionally,
%i will be expanded to a (hopefully) unique session-id; if %i is used, a new
logfile will be started for each SMTP connection.
The following optional configuration setting can be supplied:
=over
=item nosplit
If specified, the output file or pipe will be reopened at once once per
connection, and only prior to the first log output. This prevents logs for
sessions that span log intervals being split across multiple logfiles.
Without this option, the log will be reopened only when its output filename
changes; if strftime specifiers are not used, the log will not be reopened
at all.
=item reopen
Forces the log output to be reopened once per connection, as soon as something
is available to be logged. This can be combined with a high log severity (see
I<loglevel> below) to facilitate SMTP service alarms with Nagios or a similar
monitoring agent.
=item loglevel I<loglevel>
The internal log level below which messages will be logged. The I<loglevel>
given should be chosen from the list below. Priorities count downward (for
example, if LOGWARN were selected, LOGERROR, LOGCRIT and LOGEMERG messages
would be logged as well).
=over
=item B<LOGDEBUG>
=item B<LOGINFO>
=item B<LOGNOTICE>
=item B<LOGWARN>
=item B<LOGERROR>
=item B<LOGCRIT>
=item B<LOGALERT>
=item B<LOGEMERG>
=back
=back
The chosen I<path> should be writable by the user running qpsmtpd; it will be
created it did not already exist, and appended to otherwise.
=head1 AUTHORS
Devin Carraway <qpsmtpd@devin.com>, with contributions by Peter J.
Holzer <hjp@hjp.at>.
=head1 LICENSE
Copyright (c) 2005-2006, Devin Carraway
Copyright (c) 2006, Peter J. Holzer.
This plugin is licensed under the same terms as the qpsmtpd package itself.
Please see the LICENSE file included with qpsmtpd for details.
=cut
use strict;
use warnings;
use IO::File;
use Sys::Hostname;
use POSIX qw(strftime);
sub register {
my ($self, $qp, @args) = @_;
my %args;
$self->{_loglevel} = LOGWARN;
while (1) {
last if !@args;
if (lc $args[0] eq 'loglevel') {
shift @args;
my $ll = shift @args;
if (!defined $ll) {
warn "Malformed arguments to logging/file plugin";
return;
}
if ($ll =~ /^(\d+)$/) {
$self->{_loglevel} = $1;
}
elsif ($ll =~ /^(LOG\w+)$/) {
$self->{_loglevel} = log_level($1);
defined $self->{_loglevel} or $self->{_loglevel} = LOGWARN;
}
}
elsif (lc $args[0] eq 'nosplit') {
shift @args;
$self->{_nosplit} = 1;
}
elsif (lc $args[0] eq 'reopen') {
shift @args;
$self->{_reopen} = 1;
}
else { last }
}
unless (@args && $args[0]) {
warn "Malformed arguments to syslog plugin";
return;
}
my $output = join(' ', @args);
if ($output =~ /^\s*\|(.*)/) {
$self->{_log_pipe} = 1;
$self->{_log_format} = $1;
} else {
$output =~ /^(.*)/; # detaint
$self->{_log_format} = $1;
}
$self->{_current_output} = '';
$self->{_session_counter} = 0;
1;
}
sub log_output {
my ($self, $txn) = @_;
my $output = $self->{_log_format};
$output =~ s/%i/($txn->notes('logging-session-id') || 'parent')/ge;
$output = strftime $output, localtime;
$output;
}
sub open_log {
my ($self,$output,$qp) = @_;
if ($self->{_log_pipe}) {
unless ($self->{_f} = new IO::File "|$output") {
warn "Error opening log output to command $output: $!";
return undef;
}
} else {
unless ($self->{_f} = new IO::File ">>$output") {
warn "Error opening log output to path $output: $!";
return undef;
}
}
$self->{_current_output} = $output;
$self->{_f}->autoflush(1);
1;
}
# Reopen the output iff the interpolated output filename has changed
# from the one currently open, or if reopening was selected and we haven't
# yet done so during this session.
#
# Returns true if the file was reopened, zero if not, undef on error.
sub maybe_reopen {
my ($self, $txn) = @_;
my $new_output = $self->log_output($txn);
if (!$self->{_current_output} ||
$self->{_current_output} ne $new_output ||
($self->{_reopen} &&
!$txn->notes('file-reopened-this-session'))) {
unless ($self->open_log($new_output, $txn)) {
return undef;
}
$txn->notes('file-reopened-this-session', 1);
return 1;
}
return 0;
}
sub hook_connect {
my ($self, $txn) = @_;
$txn->notes('file-logged-this-session', 0);
$txn->notes('file-reopened-this-session', 0);
$txn->notes('logging-session-id',
sprintf("%08d-%04d-%d",
scalar time, $$, ++$self->{_session_counter}));
return DECLINED;
}
sub hook_disconnect {
my ($self) = @_;
if ($self->{reopen_} && $self->{_f}) {
$self->{_f} = undef;
}
return DECLINED;
}
sub hook_logging {
my ($self, $txn, $trace, $hook, $plugin, @log) = @_;
return DECLINED if !defined $self->{_loglevel} or
$trace > $self->{_loglevel};
return DECLINED if defined $plugin and $plugin eq $self->plugin_name;
# Possibly reopen the log iff:
# - It's not already open
# - We're allowed to split sessions across logfiles
# - We haven't logged anything yet this session
if (!$self->{_f} ||
!$self->{_nosplit} ||
!$txn->notes('file-logged-this-session')) {
unless (defined $self->maybe_reopen($txn)) {
return DECLINED;
}
$txn->notes('file-logged-this-session', 1);
}
my $f = $self->{_f};
print $f scalar localtime, ' ', hostname(), '[', $$, ']: ', @log, "\n";
return DECLINED;
}
# vi: tabstop=4 shiftwidth=4 expandtab:

187
plugins/logging/syslog Normal file
View File

@ -0,0 +1,187 @@
#!/usr/bin/perl
# $Id$
=head1 NAME
syslog - Syslog logging plugin for qpsmtpd
=head1 DESCRIPTION
The syslog plugin for qpsmtpd passes qpsmtpd log messages into the standard
UNIX syslog facility, mapping qpsmtpd priorities to syslog priorities.
=head1 CONFIGURATION
To enable the logging plugin, add a line of this form to the qpsmtpd plugins
configuration file:
=over
logging/syslog [loglevel l] [priority p] [ident str] [facility f] [logsock t]
For example:
logging/syslog loglevel LOGINFO priority LOG_NOTICE
=back
The following optional configuration settings can be supplied:
=over
=item B<loglevel>
The internal log level below which messages will be logged. Priorities count
downward as follows:
=over
=item B<LOGDEBUG>
=item B<LOGINFO>
=item B<LOGNOTICE>
=item B<LOGWARN>
=item B<LOGERROR>
=item B<LOGCRIT>
=item B<LOGALERT>
=item B<LOGEMERG>
=back
=item B<priority>
Normally, log messages will be mapped from the above log levels into the
syslog(3) log levels of their corresponding names. This will cause various
messages to appear or not in syslog outputs according to your syslogd
configuration (typically /etc/syslog.conf). However, if the B<priority>
setting is used, all messages will be logged at that priority regardless of
what the original priority might have been.
=item B<ident>
The ident string that will be attached to messages logged via this plugin.
The default is 'qpsmtpd'.
=item B<facility>
The syslog facility to which logged mesages will be directed. See syslog(3)
for details. The default is LOG_MAIL.
=item B<logsock>
The syslog socket where messages should be sent via syslogsock(). The valid
options are 'udp', 'tcp', 'unix', 'stream' and 'console'. Not all are
available on all systems. See Sys::Syslog for details. The default is
the above list in that order. To select specific sockets, use a comma to
separate the types.
=over
logsock udp,unix
logsock stream
=back
=back
=head1 AUTHOR
Devin Carraway <qpsmtpd@devin.com>
Peter Eisch <peter@boku.net> (logsock support)
=head1 LICENSE
Copyright (c) 2005, Devin Carraway.
This plugin is licensed under the same terms as the qpsmtpd package itself.
Please see the LICENSE file included with qpsmtpd for details.
=cut
use strict;
use warnings;
use Sys::Syslog qw(:DEFAULT setlogsock);
sub register {
my ($self, $qp, @args) = @_;
my %args;
if (@args % 2 == 0) {
%args = @args;
} else {
warn "Malformed arguments to syslog plugin";
return;
}
my $ident = 'qpsmtpd';
my $logopt = 'pid';
my $facility = 'LOG_MAIL';
$self->{_loglevel} = LOGWARN;
if ($args{loglevel}) {
if ($args{loglevel} =~ /^(\d+)$/) {
$self->{_loglevel} = $1;
}
elsif ($args{loglevel} =~ /^(LOG\w+)$/) {
$self->{_loglevel} = log_level($1) || LOGWARN;
}
}
if ($args{priority}) {
if ($args{priority} =~ /^(\d+|LOG\w+)$/) {
$self->{_priority} = $1;
}
}
if ($args{ident} && $args{ident} =~ /^([\w\-.]+)$/) {
$ident = $1;
}
if ($args{facility} && $args{facility} =~ /^(\w+)$/) {
$facility = $1;
}
if ($args{logsock}) {
my @logopt = split(/,/, $args{logsock});
setlogsock(@logopt);
}
unless (openlog $ident, $logopt, $facility) {
warn "Error opening syslog output";
return;
}
}
my %priorities_ = (
0 => 'LOG_EMERG',
1 => 'LOG_ALERT',
2 => 'LOG_CRIT',
3 => 'LOG_ERR',
4 => 'LOG_WARNING',
5 => 'LOG_NOTICE',
6 => 'LOG_INFO',
7 => 'LOG_DEBUG',
);
sub hook_logging {
my ($self, $txn, $trace, $hook, $plugin, @log) = @_;
return DECLINED if $trace > $self->{_loglevel};
return DECLINED if defined $plugin and $plugin eq $self->plugin_name;
my $priority = $self->{_priority} ?
$self->{_priority} : $priorities_{$trace};
syslog $priority, '%s', join(' ', @log);
return DECLINED;
}
# vi: tabstop=4 shiftwidth=4 expandtab

2
plugins/logging/warn
View File

@ -29,11 +29,9 @@ sub hook_logging {
# then these lines will not be logged at all. You can safely comment
# out this line and it will not cause an infinite loop.
return DECLINED if defined $plugin and $plugin eq $self->plugin_name;
my $fd = $self->fd();
warn
join(" ", $$ .
(defined $fd ? " fd:$fd" : "") .
(defined $plugin ? " $plugin plugin:" :
defined $hook ? " running plugin ($hook):" : ""),
@log), "\n"

4
plugins/milter
View File

@ -135,7 +135,7 @@ sub hook_helo {
}
sub hook_mail {
my ($self, $transaction, $address) = @_;
my ($self, $transaction, $address, %param) = @_;
my $milter = $self->qp->connection->notes('milter');
@ -148,7 +148,7 @@ sub hook_mail {
}
sub hook_rcpt {
my ($self, $transaction, $address) = @_;
my ($self, $transaction, $address, %param) = @_;
my $milter = $self->qp->connection->notes('milter');

60
plugins/parse_addr_withhelo Normal file
View File

@ -0,0 +1,60 @@
# parse_addr_withhelo
#
# strict RFC 821 forbids parameters after the
# MAIL FROM:<user@example.net>
# and
# RCPT TO:<someone@example.com>
#
# load this plugin to enforce, else the default EHLO parsing with
# parameters is done.
#
sub hook_mail_parse {
my $self = shift;
return (OK, \&_parse) if ($self->qp->connection->hello eq 'helo');
return (DECLINED);
}
sub hook_rcpt_parse {
my $self = shift;
return (OK, \&_parse) if ($self->qp->connection->hello eq 'helo');
return (DECLINED);
}
sub _parse {
my ($self,$cmd,$line) = @_;
$self->log(LOGDEBUG, "_parse() cmd=[$cmd], line=[$line]");
if ($cmd eq 'mail') {
return(DENY, "Syntax error in command")
unless ($line =~ s/^from:\s*//i);
}
else { # cmd eq 'rcpt'
return(DENY, "Syntax error in command")
unless ($line =~ s/^to:\s*//i);
}
if ($line =~ s/^(<.*>)\s*//) {
my $addr = $1;
return (DENY, "No parameters allowed in ".uc($cmd))
if ($line =~ /^\S/);
return (OK, $addr, ());
}
## now, no <> are given
$line =~ s/\s*$//;
if ($line =~ /\@/) {
return (DENY, "No parameters allowed in ".uc($cmd))
if ($line =~ /\@\S+\s+\S/);
return (OK, $line, ());
}
if ($cmd eq "mail") {
return (OK, "<>") unless $line; # 'MAIL FROM:' -> 'MAIL FROM:<>'
return (DENY, "Could not parse your MAIL FROM command");
}
else {
return (DENY, "Could not parse your RCPT TO command")
unless $line =~ /^(postmaster|abuse)$/i;
}
}

3
plugins/queue/exim-bsmtp
View File

@ -90,8 +90,7 @@ sub hook_queue {
"MAIL FROM:<", ($txn->sender->address || ''), ">\n";
print $tmp "RCPT TO:<", ($_->address || ''), ">\n"
for $txn->recipients;
print $tmp "DATA\n",
$txn->header->as_string, "\n";
print $tmp "DATA\n", $txn->header->as_string;
$txn->body_resetpos;
while (my $line = $txn->body_getline) {
$line =~ s/^\./../;

161
plugins/queue/postfix-queue
View File

@ -1,3 +1,4 @@
=head1 NAME
postfix-queue
@ -8,21 +9,144 @@ This plugin passes mails on to the postfix cleanup daemon.
=head1 CONFIG
It takes one optional parameter, the location of the cleanup socket.
The first optional parameter is the location of the cleanup socket. If it does
not start with a ``/'', it is treated as a flag for cleanup (see below).
If set, the environment variable POSTFIXQUEUE overrides this setting.
If set the environment variable POSTFIXQUEUE overrides this setting.
All other parameters are flags for cleanup, no flags are enabled by default.
See below in ``POSTFIX COMPATIBILITY'' for flags understood by your postfix
version. Supported by all postfix versions E<gt>= 2.1 are:
=over 4
=item FLAG_FILTER
Set the CLEANUP_FLAG_FILTER for cleanup. This enables the use of
I<header_filter>, I<body_filter> or I<content_filter> in postfix' main.cf.
=item FLAG_BCC_OK
Setting this flag enables (for example) the I<recipient_bcc_maps> parameter
=item FLAG_MAP_OK
This flag enables the use of other recipient mappings (e.g.
I<virtual_alias_maps>) in postfix' cleanup.
=item FLAG_MASK_EXTERNAL
This flag mask combines FLAG_FILTER, FLAG_MILTER (only in postfix >= 2.3)
FLAG_BCC_OK and FLAG_MAP_OK and is used by postfix for external messages.
This is probably what you want to use.
=back
For more flags see below in ``POSTFIX COMPATIBILITY'', your postfix version
(grep _FLAG_ src/global/cleanup_user.h) and/or lib/Qpsmtpd/Postfix/Constants.pm
=head1 POSTFIX COMPATIBILITY
The first version of this plugin was written for postfix 1.x.
The next step for Postfix 2.1 (and later) was to add the FLAG_FILTER,
FLAG_BCC_OK and FLAG_MAP_OK flags for submission to the cleanup deamon.
This version can use all flags found in Postfix 2.x (up to 2.4 currently).
Unknown flags are ignored by the cleanup daemon (just tested with postfix
2.1), so it should be safe to set flags just understood by later versions
of postfix/cleanup.
Even if all known flags can be set, some are not that useful when feeding
the message from qpsmtpd, e.g.
=head2 FLAG_NONE
no effect
=head2 FLAG_DISCARD
DON'T USE, use another plugin which hooks the I<hook_queue()> and returns
B<OK> just for the messages you want to drop. As long as this plugin does
not support setting queue flags on the fly from other modules, this flag
would drop ALL messages. Don't use!
=head2 FLAG_BOUNCE
Qpsmtpd should be configured not to accept bad messages...
=head2 FLAG_HOLD
Not useful in production setup, maybe in testing environment (untested, what
real effects this has).
=over 4
=item Flags known by postfix 1.1:
FLAG_NONE - No special features
FLAG_BOUNCE - Bounce bad messages
FLAG_FILTER - Enable content filter
=item Flags known by postfix 2.1, 2.2
all flags from postfix 1.1, plus the following:
FLAG_HOLD - Place message on hold
FLAG_DISCARD - Discard message silently
FLAG_BCC_OK - Ok to add auto-BCC addresses
FLAG_MAP_OK - Ok to map addresses
FLAG_MASK_INTERNAL - alias for FLAG_MAP_OK
FLAG_MASK_EXTERNAL - FILTER, BCC_OK and MAP_OK
=item Flags known by postfix 2.3
all flags from postfix 2.1, up to FLAG_MASK_INTERNAL. New or changed:
FLAG_MILTER - Enable Milter applications
FLAG_FILTER_ALL - FILTER and MILTER
FLAG_MASK_EXTERNAL - FILTER_ALL, BCC_OK, MAP_OK
=item Flags known by postfix 2.4
currently (postfix-2.4-20061019) the same as 2.3
=back
=head1 MAYBE IN FUTURE
Settings the (additional) queue flags from another plugin. Currently at the
beginning of I<hook_queue()> all flags are reset to the flags given as plugin
parameters.
=cut
use Qpsmtpd::Postfix;
use Qpsmtpd::Postfix::Constants;
sub register {
my ($self, $qp, @args) = @_;
$self->log(LOGDEBUG, "using constants generated from Postfix"
."v$postfix_version");
$self->{_queue_flags} = 0;
if (@args > 0) {
$self->{_queue_socket} = $args[0];
$self->log(LOGWARN, "WARNING: Ignoring additional arguments.") if (@args > 1);
} else {
if ($args[0] =~ m#^/#) {
$self->{_queue_socket} = shift @args;
}
else {
$self->{_queue_socket} = "/var/spool/postfix/public/cleanup";
}
foreach (@args) {
if ($self->can("CLEANUP_".$_) and /^(FLAG_[A-Z0-9_]+)$/) {
$_ = $1;
$self->{_queue_flags} |= (eval "CLEANUP_$_;" || 0);
#print STDERR "queue flag: $_: ".$self->{_queue_flags}."\n";
}
else {
$self->log(LOGWARN, "Ignoring unkown cleanup flag $_");
}
}
}
else {
$self->{_queue_socket} = "/var/spool/postfix/public/cleanup";
}
@ -32,13 +156,36 @@ sub register {
sub hook_queue {
my ($self, $transaction) = @_;
$transaction->notes('postfix-queue-flags', $self->{_queue_flags});
# $self->log(LOGDEBUG, "queue-flags=".$transaction->notes('postfix-queue-flags'));
my ($status, $qid, $reason) = Qpsmtpd::Postfix->inject_mail($transaction);
$status and return(DECLINED, "Unable to queue message ($status, $reason)");
if ($status) {
# this split is needed, because if cleanup returns
# CLEANUP_STAT_MASK_INCOMPLETE we might return DENY (CLEANUP_STAT_SIZE)
# instead of DENYSOFT (CLEANUP_STAT_WRITE, CLEANUP_STAT_BAD,
# CLEANUP_STAT_DEFER) ... n.b. this is the behaviour of 667.
foreach my $key (keys %cleanup_soft) {
my $stat = eval $key # keys have the same names as the constants
or next;
if ($status & $stat) {
return (DENYSOFT, $reason || $cleanup_soft{$key});
}
}
foreach my $key (keys %cleanup_hard) {
my $stat = eval $key # keys have the same names as the constants
or next;
if ($status & $stat) {
return (DENY, $reason || $cleanup_hard{$key});
}
}
# we have no idea why we're here.
return (DECLINED, $reason || "Unable to queue message ($status, $reason)");
}
my $msg_id = $transaction->header->get('Message-Id') || '';
$msg_id =~ s/[\r\n].*//s; # don't allow newlines in the Message-Id here
return (OK, "Queued! $msg_id (Queue-Id: $qid)");
}
#vim: sw=2 ts=8
# vim: sw=2 ts=8 syn=perl

2
plugins/queue/smtp-forward
View File

@ -21,7 +21,7 @@ Optionally you can also add a port:
use Net::SMTP;
sub register {
sub init {
my ($self, $qp, @args) = @_;
if (@args > 0) {

2
plugins/quit_fortune
View File

@ -9,8 +9,6 @@ sub hook_quit {
my $fortune = '/usr/games/fortune';
return DECLINED unless -e $fortune;
# local %ENV = ();
my @fortune = `$fortune -s`;
@fortune = map { chop; s/^/ \/ /; $_ } @fortune;
$qp->respond(221, $qp->config('me') . " closing connection.", @fortune);

7
plugins/rcpt_ok
View File

@ -2,9 +2,10 @@
#
# It should be configured to be run _LAST_!
#
use Qpsmtpd::DSN;
sub hook_rcpt {
my ($self, $transaction, $recipient) = @_;
my ($self, $transaction, $recipient, %param) = @_;
my $host = lc $recipient->host;
my @rcpt_hosts = ($self->qp->config("me"), $self->qp->config("rcpthosts"));
@ -30,6 +31,8 @@ sub hook_rcpt {
return (OK);
}
else {
return (DENY);
# default of relaying_denied is obviously DENY,
# we use the default "Relaying denied" message...
return Qpsmtpd::DSN->relaying_denied();
}
}

35
plugins/relay_only Normal file
View File

@ -0,0 +1,35 @@
#!/usr/bin/perl -w
=head1 NAME
relay_only - this plugin only permits relaying
=head1 SYNOPSIS
# in config/plugins
check_relay
relay_only
# other rcpt hooks go here
=head1 DESCRIPTION
This plugin can be used for the case where a server is used as the smart
relay host for internal users and external/authenticated users, but should
not be considered a normal inbound MX server
It should be configured to be run _AFTER_ check_relay and before other
RCPT hooks! Only clients that have authenticated or are listed in the
relayclient file will be allowed to send mail.
=cut
sub hook_rcpt {
if ( shift->qp->connection->relay_client ) {
return (OK);
}
else {
return (DENY);
}
}

175
plugins/require_resolvable_fromhost
View File

@ -1,89 +1,130 @@
#!/usr/bin/perl
use Danga::DNS;
use Qpsmtpd::DSN;
use Net::DNS qw(mx);
use Socket;
my %invalid = ();
my $has_ipv6 = Qpsmtpd::Constants::has_ipv6;
sub init {
my ($self, $qp) = @_;
foreach my $i ($qp->config("invalid_resolvable_fromhost")) {
sub hook_mail {
my ($self, $transaction, $sender, %param) = @_;
return DECLINED
if ($self->qp->connection->notes('whitelistclient'));
foreach my $i ($self->qp->config("invalid_resolvable_fromhost")) {
$i =~ s/^\s*//;
$i =~ s/\s*$//;
if ($i =~ m#^((\d{1,3}\.){3}\d{1,3})/(\d\d?)#) {
$invalid{$1} = $3;
}
}
}
sub hook_mail {
my ($self, $transaction, $sender) = @_;
return DECLINED
if ($self->qp->connection->notes('whitelistclient'));
if ($sender ne "<>"
and $self->qp->config("require_resolvable_fromhost")
and !$self->check_dns($sender->host)) {
if ($sender->host) {
# default of temp_resolver_failed is DENYSOFT
return Qpsmtpd::DSN->temp_resolver_failed("Could not resolve " . $sender->host);
}
else {
# default of addr_bad_from_system is DENY, we use DENYSOFT here to
# get the same behaviour as without Qpsmtpd::DSN...
return Qpsmtpd::DSN->addr_bad_from_system(DENYSOFT,
"FQDN required in the envelope sender");
}
}
return DECLINED;
$self->transaction->notes('resolvable', 1);
return DECLINED if $sender->format eq "<>";
return $self->check_dns($sender->host);
}
sub check_dns {
my ($self, $host) = @_;
my @host_answers;
# for stuff where we can't even parse a hostname out of the address
return DECLINED unless $host;
return 0 unless $host;
if( $host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/ ) {
$self->transaction->notes('resolvable', 1);
return DECLINED;
return 1 if $host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/;
my $res = new Net::DNS::Resolver;
$res->tcp_timeout(30);
$res->udp_timeout(30);
my @mx = mx($res, $host);
foreach my $mx (@mx) {
return mx_valid($self, $mx->exchange, $host);
}
my $total_queries = 2;
my $qp = $self->qp;
$self->log(LOGDEBUG, "Checking $host for MX record in the background");
Danga::DNS->new(
callback => sub { dns_result($qp, @_) },
finished => sub { $total_queries--; finished($qp, $total_queries) },
host => $host,
type => "MX",
client => $qp->input_sock,
);
$self->log(LOGDEBUG, "Checking $host for A record in the background");
Danga::DNS->new(
callback => sub { dns_result($qp, @_) },
finished => sub { $total_queries--; finished($qp, $total_queries) },
host => $host,
client => $qp->input_sock,
);
return CONTINUATION;
}
sub finished {
my ($qp, $total_zones) = @_;
$qp->finish_continuation unless $total_zones;
}
sub dns_result {
my ($qp, $result, $query) = @_;
if ($result =~ /^[A-Z]+$/) {
# probably an error
$qp->log(LOGDEBUG, "DNS error: $result looking up $query");
} else {
$qp->transaction->notes('resolvable', 1);
$qp->log(LOGDEBUG, "DNS lookup $query returned: $result");
my $query = $res->search($host);
if ($query) {
foreach my $rrA ($query->answer) {
push(@host_answers, $rrA);
}
}
sub hook_rcpt {
my ($self, $transaction) = @_;
if (!$transaction->notes('resolvable')) {
my $sender = $transaction->sender;
$self->log(LOGDEBUG, "Could not resolve " .$sender->host) if $sender->host;
return (DENYSOFT,
($sender->host
? "Could not resolve ". $sender->host
: "FQDN required in the envelope sender"));
}
return DECLINED;
if ($has_ipv6) {
my $query = $res->search($host, 'AAAA');
if ($query) {
foreach my $rrAAAA ($query->answer) {
push(@host_answers, $rrAAAA);
}
}
}
if (@host_answers) {
foreach my $rr (@host_answers) {
return is_valid($rr->address) if $rr->type eq "A" or $rr->type eq "AAAA";
return mx_valid($self, $rr->exchange, $host) if $rr->type eq "MX";
}
}
else {
$self->log(LOGWARN, "$$ query for $host failed: ", $res->errorstring)
unless $res->errorstring eq "NXDOMAIN";
}
return 0;
}
sub is_valid {
my $ip = shift;
my ($net,$mask);
### while (($net,$mask) = each %invalid) {
### ... does NOT reset to beginning, will start on
### 2nd invocation after where it denied the first time..., so
### 2nd time the same "MAIL FROM" would be accepted!
foreach $net (keys %invalid) {
$mask = $invalid{$net};
$mask = pack "B32", "1"x($mask)."0"x(32-$mask);
return 0
if join(".", unpack("C4", inet_aton($ip) & $mask)) eq $net;
}
return 1;
}
sub mx_valid {
my ($self, $name, $host) = @_;
my $res = new Net::DNS::Resolver;
my @mx_answers;
my $query = $res->search($name, 'A');
if ($query) {
foreach my $rrA ($query->answer) {
push(@mx_answers, $rrA);
}
}
if ($has_ipv6) {
my $query = $res->search($name, 'AAAA');
if ($query) {
foreach my $rrAAAA ($query->answer) {
push(@mx_answers, $rrAAAA);
}
}
}
if (@mx_answers) {
foreach my $rr (@mx_answers) {
next unless $rr->type eq "A" or $rr->type eq "AAAA";
return is_valid($rr->address);
}
}
else {
$self->log(LOGWARN, "$$ query for $host failed: ", $res->errorstring)
unless $res->errorstring eq "NXDOMAIN";
}
return 0;
}
# vim: ts=2 sw=2 expandtab syn=perl

126
plugins/rhsbl
View File

@ -1,32 +1,38 @@
#!/usr/bin/perl
use Danga::DNS;
sub hook_mail {
my ($self, $transaction, $sender) = @_;
my ($self, $transaction, $sender, %param) = @_;
my $res = new Net::DNS::Resolver;
my $sel = IO::Select->new();
my %rhsbl_zones_map = ();
# Perform any RHS lookups in the background. We just send the query packets here
# and pick up any results in the RCPT handler.
# Perform any RHS lookups in the background. We just send the query packets
# here and pick up any results in the RCPT handler.
# MTAs gets confused when you reject mail during MAIL FROM:
my %rhsbl_zones = map { (split /\s+/, $_, 2)[0,1] } $self->config('rhsbl_zones');
my %rhsbl_zones = map { (split /\s+/, $_, 2)[0,1] } $self->qp->config('rhsbl_zones');
if ($sender->format ne '<>' and %rhsbl_zones) {
my $helo = $self->connection->hello_host;
push(my @hosts, $sender->host);
push(@hosts, $helo) if $helo && $helo ne $sender->host;
#my $helo = $self->qp->connection->hello_host;
#push(@hosts, $helo) if $helo && $helo ne $sender->host;
for my $host (@hosts) {
for my $rhsbl (keys %rhsbl_zones) {
# fix to find TXT records, if the rhsbl_zones line doesn't have second field
if (defined($rhsbl_zones{$rhsbl})) {
$self->log(LOGDEBUG, "Checking $host.$rhsbl for A record in the background");
Danga::DNS->new(
callback => sub { $self->process_result($host, $rhsbl_zones{$rhsbl}, @_) },
host => "$host.$rhsbl",
client => $self->qp->input_sock,
);
$sel->add($res->bgsend("$host.$rhsbl"));
} else {
$self->log(LOGDEBUG, "Checking $host.$rhsbl for TXT record in the background");
$sel->add($res->bgsend("$host.$rhsbl", "TXT"));
}
$rhsbl_zones_map{"$host.$rhsbl"} = $rhsbl_zones{$rhsbl};
}
}
%{$self->{_rhsbl_zones_map}} = %rhsbl_zones_map;
$transaction->notes('rhsbl_sockets', $sel);
} else {
$self->log(LOGDEBUG, 'no RHS checks necessary');
}
@ -34,28 +40,84 @@ sub hook_mail {
return DECLINED;
}
sub process_result {
my ($self, $host, $template, $result, $query) = @_;
if ($result !~ /^\d+\.\d+\.\d+\.\d+$/) {
# NXDOMAIN or error
return;
}
my $tran = $self->transaction;
return if $tran->notes('rhsbl');
if ($host eq $tran->sender->host) {
$tran->notes('rhsbl', "Mail from $host rejected because it $template");
}
else {
$tran->notes('rhsbl', "Mail from HELO $host rejected because it $template");
}
}
sub hook_rcpt {
my ($self, $transaction, $rcpt) = @_;
my $host = $transaction->sender->host;
my $hello = $self->qp->connection->hello_host;
my $result = $transaction->notes('rhsbl');
my $result = $self->process_sockets;
if ($result && defined($self->{_rhsbl_zones_map}{$result})) {
if ($result =~ /^$host\./ ) {
return (DENY, "Mail from $host rejected because it " . $self->{_rhsbl_zones_map}{$result});
} else {
return (DENY, "Mail from HELO $hello rejected because it " . $self->{_rhsbl_zones_map}{$result});
}
}
return (DENY, $result) if $result;
return DECLINED;
}
sub process_sockets {
my ($self) = @_;
my $trans = $self->transaction;
my $result = '';
return $trans->notes('rhsbl') if $trans->notes('rhsbl');
my $res = new Net::DNS::Resolver;
my $sel = $trans->notes('rhsbl_sockets') or return '';
$self->log(LOGDEBUG, 'waiting for rhsbl dns');
# don't wait more than 8 seconds here
my @ready = $sel->can_read(8);
$self->log(LOGDEBUG, 'DONE waiting for rhsbl dns, got ' , scalar @ready, ' answers ...') ;
return '' unless @ready;
for my $socket (@ready) {
my $query = $res->bgread($socket);
$sel->remove($socket);
undef $socket;
if ($query) {
foreach my $rr ($query->answer) {
$self->log(LOGDEBUG, 'got an ' . $rr->type . ' record ' . $rr->name);
if ($rr->type eq 'A') {
$result = $rr->name;
$self->log(LOGDEBUG, "A record found for $result with IP " . $rr->address);
last;
} elsif ($rr->type eq 'TXT') {
$result = $rr->txtdata;
$self->log(LOGDEBUG, "TXT record found: " . $rr->txtdata);
last;
}
}
} else {
$self->log(LOGCRIT, "query failed: ", $res->errorstring) unless $res->errorstring eq 'NXDOMAIN';
}
if ($result) {
#kill any other pending I/O
$trans->notes('rhsbl_sockets', undef);
return $trans->notes('rhsbl', $result);
}
}
if ($sel->count) {
# loop around if we have dns results left
return $self->process_sockets();
}
# if there was more to read; then forget it
$trans->notes('rhsbl_sockets', undef);
return $trans->notes('rhsbl', $result);
}
sub hook_disconnect {
my ($self, $transaction) = @_;
$transaction->notes('rhsbl_sockets', undef);
return DECLINED;
}

4
plugins/sender_permitted_from
View File

@ -34,7 +34,7 @@ sub register {
}
sub hook_mail {
my ($self, $transaction, $sender) = @_;
my ($self, $transaction, $sender, %param) = @_;
return (DECLINED) unless ($sender->format ne "<>"
and $sender->host && $sender->user);
@ -71,7 +71,7 @@ sub hook_mail {
}
sub hook_rcpt {
my ($self, $transaction, $rcpt) = @_;
my ($self, $transaction, $rcpt, %param) = @_;
# special addresses don't get SPF-tested.
return DECLINED if $rcpt and $rcpt->user and $rcpt->user =~ /^(?:postmaster|abuse|mailer-daemon|root)$/i;

17
plugins/spamassassin
View File

@ -44,11 +44,12 @@ might want to make another plugin that does this on a per user basis.
The default is to never munge the subject based on the SpamAssassin score.
=item spamd_socket [/path/to/socket]
=item spamd_socket [/path/to/socket|spamd.host:port]
Beginning with Mail::SpamAssassin 2.60, it is possible to use Unix
domain sockets for spamd. This is faster and more secure than using
a TCP connection.
domain sockets for spamd. This is faster and more secure than using a
TCP connection, but if you run spamd on a remote machine, you need to
use a TCP connection.
=item leave_old_headers [drop|rename|keep]
@ -71,6 +72,7 @@ Make the "subject munge string" configurable
=cut
use Qpsmtpd::DSN;
use Socket qw(:DEFAULT :crlf);
use IO::Handle;
@ -94,12 +96,16 @@ sub hook_data_post { # check_spam
my ($self, $transaction) = @_;
$self->log(LOGDEBUG, "check_spam");
return (DECLINED) if $transaction->body_size > 500_000;
return (DECLINED) if $transaction->data_size > 500_000;
my $leave_old_headers = lc($self->{_args}->{leave_old_headers}) || 'rename';
my $remote = 'localhost';
my $port = 783;
if ($self->{_args}->{spamd_socket} =~ /^([\w.-]+):(\d+)$/) {
$remote = $1;
$port = $2;
}
if ($port =~ /\D/) { $port = getservbyname($port, 'tcp') }
die "No port" unless $port;
my $iaddr = inet_aton($remote) or
@ -225,7 +231,8 @@ sub check_spam_reject {
my $score = $self->get_spam_score($transaction) or return DECLINED;
$self->log(LOGDEBUG, "check_spam_reject: score=$score");
return (DENY, "spam score exceeded threshold")
# default of media_unsupported is DENY, so just change the message
return Qpsmtpd::DSN->media_unsupported("spam score exceeded threshold")
if $score >= $self->{_args}->{reject_threshold};
$self->log(LOGDEBUG, "check_spam_reject: passed");

67
plugins/stats
View File

@ -1,67 +0,0 @@
#!/usr/bin/perl -w
use Time::HiRes qw(time);
my $START_TIME = time;
our $MAILS_RECEIVED = 0;
our $MAILS_REJECTED = 0;
our $MAILS_TEMPFAIL = 0;
sub get_stats {
my $class = shift;
my $uptime = $class->uptime;
my $recvd = $class->mails_received;
my $reject = $class->mails_rejected;
my $soft = $class->mails_tempfailed;
my $rate = $class->mails_per_sec;
return sprintf(" Uptime: %0.2f sec\n".
" Mails Received: % 10d\n".
" 5xx: % 10d\n".
" 4xx: % 10d\n".
"Mails per second: %0.2f\n",
$uptime, $recvd, $reject, $soft, $rate);
}
sub hook_deny {
my ($self, $tran, $plugin, $level) = @_;
if ($level == DENY or $level == DENY_DISCONNECT) {
$MAILS_REJECTED++;
}
elsif ($level == DENYSOFT or $level == DENYSOFT_DISCONNECT) {
$MAILS_TEMPFAIL++;
}
return DECLINED;
}
sub hook_mail {
my $self = shift;
$MAILS_RECEIVED++;
return DECLINED;
}
sub uptime {
return (time() - $START_TIME);
}
sub mails_received {
return $MAILS_RECEIVED;
}
sub mails_rejected {
return $MAILS_REJECTED;
}
sub mails_tempfailed {
return $MAILS_TEMPFAIL;
}
sub mails_per_sec {
my $class = shift;
return ($MAILS_RECEIVED / $class->uptime());
}

151
plugins/tls
View File

@ -8,46 +8,89 @@ tls - plugin to support STARTTLS
# in config/plugins
tls ssl/cert.pem ssl/privkey.pem
tls [B<cert_path priv_key_path ca_path>]
=over indentlevel
=item B<cert_path>
Path to the server certificate file. Default: I<ssl/qpsmtpd-server.crt>
=item B<priv_key_path>
Path to the private key file. Default: I<ssl/qpsmtpd-server.key>
=item B<ca_path>
Path to the certificate autority file. Default: I<ssl/qpsmtpd-ca.crt>
=head1 DESCRIPTION
This plugin implements basic TLS support.
This plugin implements basic TLS support. It can also be used to support
port 465 (SMTP over SSL), but only with qpsmtpd-forkserver. In this case,
be sure to load plugins/tls before any other connect plugins and start
qpsmtpd like this:
qpsmtpd-forkserver --port 25 --port 465
You can also specify multiple --listen-address options as well; see the help
for qpsmtpd-forkserver for more details.
If TLS is successfully negotiated then the C<tls_enabled> field in the
Connection notes is set. If you wish to make TLS mandatory you should check
that field and take appropriate action. Note that you can only do that from
MAIL FROM onwards.
Use the script C<plugins/tls_cert> to automatically generate a self-signed
certificate with the appropriate characteristics. Otherwise, you should
give absolute pathnames to the certificate, key, and the CA root cert
used to sign that certificate.
=head1 CIPHERS and COMPATIBILITY
By default, we use only the plugins that openssl considers to be
"high security". If you need to tweak the available ciphers for some
broken client (such as Versamail 3.x), have a look at the available
ciphers at L<http://www.openssl.org/docs/apps/ciphers.html#CIPHER_STRINGS>,
and put a suitable string in config/tls_ciphers (e.g. "DEFAULT" or
"HIGH:MEDIUM")
=cut
use IO::Socket::SSL; # qw(debug1 debug2 debug3 debug4);
use IO::Socket::SSL;# qw(debug1 debug2 debug3 debug4);
sub init {
my ($self, $qp, $cert, $key) = @_;
my ($self, $qp, $cert, $key, $ca) = @_;
$cert ||= 'ssl/qpsmtpd-server.crt';
$key ||= 'ssl/qpsmtpd-server.key';
unless ( -f $cert && -f $key ) {
$ca ||= 'ssl/qpsmtpd-ca.crt';
unless ( -f $cert && -f $key && -f $ca ) {
$self->log(LOGERROR, "Cannot locate cert/key! Run plugins/tls_cert to generate");
return;
}
$self->tls_cert($cert);
$self->tls_key($key);
$self->tls_ca($ca);
$self->tls_ciphers($self->qp->config('tls_ciphers') || 'HIGH');
$self->log(LOGINFO, "ciphers: $self->tls_ciphers");
local $^W; # this bit is very noisy...
my $ssl_ctx = IO::Socket::SSL::SSL_Context->new(
SSL_use_cert => 1,
SSL_cert_file => $self->tls_cert,
SSL_key_file => $self->tls_key,
SSL_cipher_list => 'HIGH',
SSL_ca_file => $self->tls_ca,
SSL_cipher_list => $self->tls_ciphers,
SSL_server => 1
) or die "Could not create SSL context: $!";
# now extract the password...
$self->ssl_context($ssl_ctx);
# Check for possible AUTH mechanisms
HOOK: foreach my $hook ( keys %{$qp->{hooks}} ) {
no strict 'refs';
if ( $hook =~ m/^auth-?(.+)?$/ ) {
if ( defined $1 ) {
my $hooksub = "hook_$hook";
@ -68,8 +111,10 @@ sub hook_ehlo {
return DECLINED if $self->connection->notes('tls_enabled');
return DENY, "Command refused due to lack of security" if $transaction->notes('ssl_failed');
my $cap = $transaction->notes('capabilities');
$cap ||= [];
push @$cap, 'STARTTLS';
$transaction->notes('tls_enabled', 1);
$transaction->notes('capabilities', $cap);
return DECLINED;
}
@ -82,43 +127,7 @@ sub hook_unrecognized_command {
# OK, now we setup TLS
$self->qp->respond (220, "Go ahead with TLS");
eval {
my $tlssocket;
if ($self->qp->isa('Danga::Socket')) {
# high_perf
$tlssocket = IO::Socket::SSL->start_SSL($self->qp->sock,
SSL_use_cert => 1,
SSL_cert_file => $self->tls_cert,
SSL_key_file => $self->tls_key,
SSL_cipher_list => 'HIGH',
SSL_server => 1,
SSL_reuse_ctx => $self->ssl_context,
) or die "Could not convert SSL socket: $!";
}
else {
$tlssocket = IO::Socket::SSL->new_from_fd(
fileno(STDIN), '+>',
SSL_use_cert => 1,
SSL_cert_file => $self->tls_cert,
SSL_key_file => $self->tls_key,
SSL_cipher_list => 'HIGH',
SSL_server => 1,
SSL_reuse_ctx => $self->ssl_context,
) or die "Could not create SSL socket: $!";
}
# Clone connection object (without data received from client)
$self->qp->connection($self->connection->clone());
$self->qp->reset_transaction;
if ($self->qp->isa('Danga::Socket')) {
$self->connection->notes('tls_socket', $tlssocket);
}
else {
*STDIN = *STDOUT = $self->connection->notes('tls_socket', $tlssocket);
}
$self->connection->notes('tls_enabled', 1);
};
if ($@) {
unless ( _convert_to_ssl($self) ) {
# SSL setup failed. Now we must respond to every command with 5XX
warn("TLS failed: $@\n");
$transaction->notes('ssl_failed', 1);
@ -129,6 +138,48 @@ sub hook_unrecognized_command {
return DONE;
}
sub hook_connect {
my ($self, $transaction) = @_;
my $local_port = $self->qp->connection->local_port;
return DECLINED unless $local_port == 465; # SMTPS
unless ( _convert_to_ssl($self) ) {
return (DENY_DISCONNECT, "Cannot establish SSL session");
}
$self->log(LOGWARN, "Connected via SMTPS");
return DECLINED;
}
sub _convert_to_ssl {
my ($self) = @_;
eval {
my $tlssocket = IO::Socket::SSL->new_from_fd(
fileno(STDIN), '+>',
SSL_use_cert => 1,
SSL_cert_file => $self->tls_cert,
SSL_key_file => $self->tls_key,
SSL_ca_file => $self->tls_ca,
SSL_cipher_list => $self->tls_ciphers,
SSL_server => 1,
SSL_reuse_ctx => $self->ssl_context,
) or die "Could not create SSL socket: $!";
# Clone connection object (without data received from client)
$self->qp->connection($self->connection->clone());
$self->qp->reset_transaction;
*STDIN = *STDOUT = $self->connection->notes('tls_socket', $tlssocket);
$self->connection->notes('tls_enabled', 1);
};
if ($@) {
return 0;
}
else {
return 1;
}
}
sub can_do_tls {
my ($self) = @_;
$self->tls_cert && -r $self->tls_cert;
@ -146,6 +197,18 @@ sub tls_key {
$self->{_tls_key};
}
sub tls_ca {
my $self = shift;
@_ and $self->{_tls_ca} = shift;
$self->{_tls_ca};
}
sub tls_ciphers {
my $self = shift;
@_ and $self->{_tls_ciphers} = shift;
$self->{_tls_ciphers};
}
sub ssl_context {
my $self = shift;
@_ and $self->{_ssl_ctx} = shift;

2
plugins/tls_cert
View File

@ -65,7 +65,7 @@ system('openssl', 'genrsa', '-out', $SERVER_key, 1024) == 0
system('openssl', 'req', '-config', $SERVERfilename, '-new',
'-key', $SERVER_key, '-out', $SERVER_csr) == 0
or die "Cannot create CA cert: $?";
or die "Cannot create server cert: $?";
my ($SIGN, $SIGNfilename) = tempfile( $template, DIR => "ssl", UNLINK => 1);
print ${SIGN} <<"EOT";

4
plugins/virus/bitdefender
View File

@ -80,10 +80,10 @@ sub register {
sub hook_data_post {
my ( $self, $transaction ) = @_;
if ( $transaction->body_size > $self->{"_bitd"}->{"max_size"} ) {
if ( $transaction->data_size > $self->{"_bitd"}->{"max_size"} ) {
$self->log( LOGWARN,
'Mail too large to scan ('
. $transaction->body_size . " vs "
. $transaction->data_size . " vs "
. $self->{"_bitd"}->{"max_size"}
. ")" );
return (DECLINED);

25
plugins/virus/clamav
View File

@ -27,6 +27,13 @@ Path to the clamav commandline scanner. Mail will be passed to the clamav
scanner in Berkeley mbox format (that is, with a "From " line). See the
discussion below on which commandline scanner to use.
=item clamd_conf=I<path> (e.g. I<clamd_conf=/etc/sysconfig/clamd.conf>)
Path to the clamd configuration file. Passed as an argument to the
command-line scanner (--config-file=I<path>).
The default value is '/etc/clamd.conf'.
=item action=E<lt>I<add-header> | I<reject>E<gt> (e.g. I<action=reject>)
Selects an action to take when an inbound message is found to be infected.
@ -42,7 +49,7 @@ Specifies the maximum size, in bytes, for mail to be scanned. Any mail
exceeding this size will be left alone. This is recommended, as large mail
can take an exceedingly long time to scan. The default is 524288, or 512k.
=item tmp_dir=I<path> (e.g. I<max_size=/tmp>)
=item tmp_dir=I<path> (e.g. I<tmp_dir=/tmp>)
Specify an alternate temporary directory. If not specified, the qpsmtpd
I<spool_dir> will be used. If neither is available, I<~/tmp/> will be tried,
@ -120,6 +127,9 @@ sub register {
elsif (/^clamscan_path=(\/[\/\-\_\.a-z0-9A-Z]*)$/) {
$self->{_clamscan_loc} = $1;
}
elsif (/^clamd_conf=(\/[\/\-\_\.a-z0-9A-Z]*)$/) {
$self->{_clamd_conf} = "$1";
}
elsif (/^tmp_dir=(\/[\/\-\_\.a-z0-9A-Z]*)$/) {
$self->{_spool_dir} = $1;
}
@ -138,6 +148,7 @@ sub register {
$self->{_max_size} ||= 512 * 1024;
$self->{_spool_dir} ||= $self->spool_dir();
$self->{_back_compat} ||= ''; # make sure something is set
$self->{_clamd_conf} ||= '/etc/clamd/conf'; # make sure something is set
unless ($self->{_spool_dir}) {
$self->log(LOGERROR, "No spool dir configuration found");
@ -153,9 +164,9 @@ sub register {
sub hook_data_post {
my ($self, $transaction) = @_;
if ($transaction->body_size > $self->{_max_size}) {
if ($transaction->data_size > $self->{_max_size}) {
$self->log(LOGWARN, 'Mail too large to scan ('.
$transaction->body_size . " vs $self->{_max_size})" );
$transaction->data_size . " vs $self->{_max_size})" );
return (DECLINED);
}
@ -172,9 +183,11 @@ sub hook_data_post {
}
# Now do the actual scanning!
my $cmd = $self->{_clamscan_loc}." --stdout "
.$self->{_back_compat}
." --disable-summary $filename 2>&1";
my $cmd = $self->{_clamscan_loc}
. " --stdout "
. $self->{_back_compat}
. " --config-file=" . $self->{_clamd_conf}
. " --disable-summary $filename 2>&1";
$self->log(LOGDEBUG, "Running: $cmd");
my $output = `$cmd`;

6
plugins/virus/clamdscan
View File

@ -107,8 +107,8 @@ sub hook_data_post {
my ( $self, $transaction ) = @_;
$DB::single = 1;
if ( $transaction->body_size > $self->{"_clamd"}->{"max_size"} * 1024 ) {
$self->log( LOGNOTICE, "Declining due to body_size" );
if ( $transaction->data_size > $self->{"_clamd"}->{"max_size"} * 1024 ) {
$self->log( LOGNOTICE, "Declining due to data_size" );
return (DECLINED);
}
@ -155,7 +155,7 @@ sub hook_data_post {
unless ( $clamd->ping() ) {
$self->log( LOGERROR, "Cannot ping clamd server - did you provide the correct clamd port or socket?" );
return DECLINED;
return DENYSOFT;
}
if ( my %found = $clamd->scan($filename) ) {

4
plugins/virus/klez_filter
View File

@ -4,9 +4,9 @@ sub hook_data_post {
# klez files are always sorta big .. how big? Dunno.
return (DECLINED)
if $transaction->body_size < 60_000;
if $transaction->data_size < 60_000;
# 220k was too little, so let's just disable the "big size check"
# or $transaction->body_size > 1_000_000;
# or $transaction->data_size > 1_000_000;
# maybe it would be worthwhile to add a check for
# Content-Type: multipart/alternative; here?

4
plugins/virus/sophie
View File

@ -16,8 +16,8 @@ sub hook_data_post {
my ( $self, $transaction ) = @_;
$DB::single = 1;
if ( $transaction->body_size > $self->{"_sophie"}->{"max_size"} * 1024 ) {
$self->log( LOGNOTICE, "Declining due to body_size" );
if ( $transaction->data_size > $self->{"_sophie"}->{"max_size"} * 1024 ) {
$self->log( LOGNOTICE, "Declining due to data_size" );
return (DECLINED);
}

2
plugins/virus/uvscan
View File

@ -55,7 +55,7 @@ sub hook_data_post {
my ($self, $transaction) = @_;
return (DECLINED)
if $transaction->body_size > 250_000;
if $transaction->data_size > 250_000;
# Ignore non-multipart emails
my $content_type = $transaction->header->get('Content-Type');

360
qpsmtpd
View File

@ -1,347 +1,31 @@
#!/usr/bin/perl
use lib "./lib";
BEGIN {
delete $ENV{ENV};
delete $ENV{BASH_ENV};
$ENV{PATH} = '/bin:/usr/bin:/var/qmail/bin:/usr/local/bin';
}
#!/usr/bin/perl -Tw
# Copyright (c) 2001 Ask Bjoern Hansen. See the LICENSE file for details.
# The "command dispatch" system is taken from colobus - http://trainedmonkey.com/colobus/
#
# this is designed to be run under tcpserver (http://cr.yp.to/ucspi-tcp.html)
# or inetd if you're into that sort of thing
#
#
# For more information see http://develooper.com/code/qpsmtpd/
#
#
use lib 'lib';
use Qpsmtpd::TcpServer;
use strict;
use vars qw($DEBUG);
use FindBin qw();
# TODO: need to make this taint friendly
use lib "$FindBin::Bin/lib";
use Danga::Socket;
use Danga::Client;
use Qpsmtpd::PollServer;
use Qpsmtpd::ConfigServer;
use Qpsmtpd::Constants;
use IO::Socket;
use Carp;
use POSIX qw(WNOHANG);
use Getopt::Long;
$| = 1;
$|++;
delete $ENV{ENV};
$ENV{PATH} = '/bin:/usr/bin:/var/qmail/bin';
use Socket qw(SOMAXCONN IPPROTO_TCP SO_KEEPALIVE TCP_NODELAY SOL_SOCKET);
my $qpsmtpd = Qpsmtpd::TcpServer->new();
$qpsmtpd->load_plugins();
$qpsmtpd->start_connection();
$qpsmtpd->run();
$SIG{'PIPE'} = "IGNORE"; # handled manually
__END__
$DEBUG = 0;
my $CONFIG_PORT = 20025;
my $CONFIG_LOCALADDR = '127.0.0.1';
my $PORT = 2525;
my $LOCALADDR = '0.0.0.0';
my $PROCS = 1;
my $MAXCONN = 15; # max simultaneous connections
my $USER = 'smtpd'; # user to suid to
my $MAXCONNIP = 5; # max simultaneous connections from one IP
my $PAUSED = 0;
my $NUMACCEPT = 20;
sub help {
print <<EOT;
Usage:
qpsmtpd [OPTIONS]
Options:
-l, --listen-address addr : listen on a specific address; default 0.0.0.0
-p, --port P : listen on a specific port; default 2525
-c, --limit-connections N : limit concurrent connections to N; default 15
-u, --user U : run as a particular user; defualt 'smtpd'
-m, --max-from-ip M : limit connections from a single IP; default 5
-j, --procs J : spawn J processes; default 1
-a, --accept K : accept up to K conns per loop; default 20
-h, --help : this page
--use-poll : force use of poll() instead of epoll()/kqueue()
NB: The server uses poll() style loops running inside J child processes. Set J
to the number of CPUs you have at your disposal.
EOT
exit(0);
}
GetOptions(
'p|port=i' => \$PORT,
'l|listen-address=s' => \$LOCALADDR,
'j|procs=i' => \$PROCS,
'd|debug+' => \$DEBUG,
'c|limit-connections=i' => \$MAXCONN,
'm|max-from-ip=i' => \$MAXCONNIP,
'u|user=s' => \$USER,
'a|accept=i' => \$NUMACCEPT,
'h|help' => \&help,
'use-poll' => \&force_poll,
) || help();
# detaint the commandline
if ($PORT =~ /^(\d+)$/) { $PORT = $1 } else { &help }
if ($LOCALADDR =~ /^([\d\w\-.]+)$/) { $LOCALADDR = $1 } else { &help }
if ($USER =~ /^([\w\-]+)$/) { $USER = $1 } else { &help }
if ($MAXCONN =~ /^(\d+)$/) { $MAXCONN = $1 } else { &help }
if ($PROCS =~ /^(\d+)$/) { $PROCS = $1 } else { &help }
if ($NUMACCEPT =~ /^(\d+)$/) { $NUMACCEPT = $1 } else { &help }
my $_NUMACCEPT = $NUMACCEPT;
# This is a bit of a hack, but we get to approximate MAXCONN stuff when we
# have multiple children listening on the same socket.
$MAXCONN /= $PROCS;
$MAXCONNIP /= $PROCS;
sub force_poll {
$Danga::Socket::HaveEpoll = 0;
$Danga::Socket::HaveKQueue = 0;
}
# Danga::Socket::init_poller();
my $POLL = "with " . ($Danga::Socket::HaveEpoll ? "epoll()" :
$Danga::Socket::HaveKQueue ? "kqueue()" : "poll()");
my $SERVER;
my $CONFIG_SERVER;
my %childstatus = ();
run_as_server();
exit(0);
sub _fork {
my $pid = fork;
if (!defined($pid)) { die "Cannot fork: $!" }
return $pid if $pid;
# Fixup Net::DNS randomness after fork
srand($$ ^ time);
local $^W;
delete $INC{'Net/DNS/Header.pm'};
require Net::DNS::Header;
# cope with different versions of Net::DNS
eval {
$Net::DNS::Resolver::global{id} = 1;
$Net::DNS::Resolver::global{id} = int(rand(Net::DNS::Resolver::MAX_ID()));
# print "Next DNS ID: $Net::DNS::Resolver::global{id}\n";
};
if ($@) {
# print "Next DNS ID: " . Net::DNS::Header::nextid() . "\n";
}
# Fixup lost kqueue after fork
$Danga::Socket::HaveKQueue = undef;
Danga::Socket::init_poller();
}
sub spawn_child {
_fork and return;
$SIG{CHLD} = "DEFAULT";
Qpsmtpd::PollServer->OtherFds(fileno($SERVER) => \&accept_handler);
Qpsmtpd::PollServer->EventLoop();
exit;
}
sub sig_chld {
$SIG{CHLD} = 'IGNORE';
while ( (my $child = waitpid(-1,WNOHANG)) > 0) {
last unless $child > 0;
print "child $child died\n";
delete $childstatus{$child};
}
# restart a new child (assuming this one died)
spawn_child();
$SIG{CHLD} = \&sig_chld;
}
sub run_as_server {
local $::MAXconn = $MAXCONN;
# establish SERVER socket, bind and listen.
$SERVER = IO::Socket::INET->new(LocalPort => $PORT,
LocalAddr => $LOCALADDR,
Type => SOCK_STREAM,
Proto => IPPROTO_TCP,
Blocking => 0,
Reuse => 1,
Listen => SOMAXCONN )
or die "Error creating server $LOCALADDR:$PORT : $@\n";
IO::Handle::blocking($SERVER, 0);
binmode($SERVER, ':raw');
$CONFIG_SERVER = IO::Socket::INET->new(LocalPort => $CONFIG_PORT,
LocalAddr => $CONFIG_LOCALADDR,
Type => SOCK_STREAM,
Proto => IPPROTO_TCP,
Blocking => 0,
Reuse => 1,
Listen => 1 )
or die "Error creating server $CONFIG_LOCALADDR:$CONFIG_PORT : $@\n";
IO::Handle::blocking($CONFIG_SERVER, 0);
binmode($CONFIG_SERVER, ':raw');
# Drop priviledges
my (undef, undef, $quid, $qgid) = getpwnam $USER or
die "unable to determine uid/gid for $USER\n";
$) = "";
POSIX::setgid($qgid) or
die "unable to change gid: $!\n";
POSIX::setuid($quid) or
die "unable to change uid: $!\n";
$> = $quid;
# Load plugins here
my $plugin_loader = Qpsmtpd::SMTP->new();
$plugin_loader->load_plugins;
$plugin_loader->log(LOGINFO, 'Running as user '.
(getpwuid($>) || $>) .
', group '.
(getgrgid($)) || $)));
if ($PROCS > 1) {
$SIG{'CHLD'} = \&sig_chld;
my @kids;
for (1..$PROCS) {
push @kids, spawn_child();
}
$SIG{INT} = $SIG{TERM} = sub { $SIG{CHLD} = "IGNORE"; kill 2 => @kids; exit };
$plugin_loader->log(LOGDEBUG, "Listening on $PORT with $PROCS children $POLL");
sleep while (1);
}
else {
$plugin_loader->log(LOGDEBUG, "Listening on $PORT with single process $POLL");
Qpsmtpd::PollServer->OtherFds(fileno($SERVER) => \&accept_handler,
fileno($CONFIG_SERVER) => \&config_handler,
);
while (1) {
Qpsmtpd::PollServer->EventLoop();
}
exit;
}
}
sub config_handler {
my $csock = $CONFIG_SERVER->accept();
if (!$csock) {
# warn("accept failed on config server: $!");
return;
}
binmode($csock, ':raw');
printf("Config server connection\n") if $DEBUG;
IO::Handle::blocking($csock, 0);
setsockopt($csock, IPPROTO_TCP, TCP_NODELAY, pack("l", 1)) or die;
my $client = Qpsmtpd::ConfigServer->new($csock);
$client->watch_read(1);
return;
}
# Accept all new connections
sub accept_handler {
my $running;
my $descriptors = Danga::Client->DescriptorMap;
$running = scalar keys %$descriptors;
for (1 .. $NUMACCEPT) {
if ($running >= $MAXCONN) {
::log(LOGINFO,"Too many connections: $running >= $MAXCONN.");
return;
}
$running++;
if (! _accept_handler($running)) {
# got here because we have too many accepts.
$NUMACCEPT = $_NUMACCEPT;
return;
}
}
# got here because we have accept's left.
# So double the number we accept next time.
$NUMACCEPT *= 2;
}
use Errno qw(EAGAIN EWOULDBLOCK);
sub _accept_handler {
my $running = shift;
my $csock = $SERVER->accept();
if (!$csock) {
# warn("accept() failed: $!");
return;
if ($! == EAGAIN || $! == EWOULDBLOCK) {
return;
}
else {
warn("accept() failed: $!");
return 1;
}
}
binmode($csock, ':raw');
printf("Listen child making a Qpsmtpd::PollServer for %d.\n", fileno($csock))
if $DEBUG;
IO::Handle::blocking($csock, 0);
setsockopt($csock, IPPROTO_TCP, TCP_NODELAY, pack("l", 1)) or die;
# multiplex mode
my $client = Qpsmtpd::PollServer->new($csock);
my $rem_ip = $client->peer_ip_string;
if ($PAUSED) {
$client->write("451 Sorry, this server is currently paused\r\n");
$client->close;
return 1;
}
if ($MAXCONNIP) {
my $num_conn = 1; # seed with current value
# If we for-loop directly over values %childstatus, a SIGCHLD
# can call REAPER and slip $rip out from under us. Causes
# "Use of freed value in iteration" under perl 5.8.4.
my $descriptors = Danga::Client->DescriptorMap;
my @obj = values %$descriptors;
foreach my $obj (@obj) {
local $^W;
# This is a bit of a slow way to do this. Wish I could cache the method call.
++$num_conn if ($obj->peer_ip_string eq $rem_ip);
}
if ($num_conn > $MAXCONNIP) {
$client->log(LOGINFO,"Too many connections from $rem_ip: "
."$num_conn > $MAXCONNIP. Denying connection.");
$client->write("451 Sorry, too many connections from $rem_ip, try again later\r\n");
$client->close;
return 1;
}
$client->log(LOGINFO, "accepted connection $running/$MAXCONN ($num_conn/$MAXCONNIP) from $rem_ip");
}
$client->push_back_read("Connect\n");
$client->watch_read(1);
return 1;
}
########################################################################
sub log {
my ($level,$message) = @_;
# $level not used yet. this is reimplemented from elsewhere anyway
warn("$$ fd:? $message\n");
}
sub pause {
my ($pause) = @_;
$PAUSED = $pause;
}
1;

311
qpsmtpd-async Executable file
View File

@ -0,0 +1,311 @@
#!/usr/bin/perl
use lib "./lib";
BEGIN {
delete $ENV{ENV};
delete $ENV{BASH_ENV};
$ENV{PATH} = '/bin:/usr/bin:/var/qmail/bin:/usr/local/bin';
}
use strict;
use vars qw($DEBUG);
use FindBin qw();
# TODO: need to make this taint friendly
use lib "$FindBin::Bin/lib";
use Danga::Socket;
use Danga::Client;
use Qpsmtpd::PollServer;
use Qpsmtpd::ConfigServer;
use Qpsmtpd::Constants;
use IO::Socket;
use Carp;
use POSIX qw(WNOHANG);
use Getopt::Long;
$|++;
use Socket qw(SOMAXCONN IPPROTO_TCP SO_KEEPALIVE TCP_NODELAY SOL_SOCKET);
$SIG{'PIPE'} = "IGNORE"; # handled manually
$DEBUG = 0;
my $CONFIG_PORT = 20025;
my $CONFIG_LOCALADDR = '127.0.0.1';
my $PORT = 2525;
my $LOCALADDR = '0.0.0.0';
my $PROCS = 1;
my $USER = 'smtpd'; # user to suid to
my $PAUSED = 0;
my $NUMACCEPT = 20;
my $ACCEPT_RSET = Danga::Socket->AddTimer(30, \&reset_num_accept);
# make sure we don't spend forever doing accept()
use constant ACCEPT_MAX => 1000;
sub reset_num_accept {
$NUMACCEPT = 20;
}
sub help {
print <<EOT;
Usage:
qpsmtpd [OPTIONS]
Options:
-l, --listen-address addr : listen on a specific address; default 0.0.0.0
-p, --port P : listen on a specific port; default 2525
-u, --user U : run as a particular user; defualt 'smtpd'
-j, --procs J : spawn J processes; default 1
-h, --help : this page
--use-poll : force use of poll() instead of epoll()/kqueue()
EOT
exit(0);
}
GetOptions(
'p|port=i' => \$PORT,
'l|listen-address=s' => \$LOCALADDR,
'j|procs=i' => \$PROCS,
'd|debug+' => \$DEBUG,
'u|user=s' => \$USER,
'h|help' => \&help,
) || help();
# detaint the commandline
if ($PORT =~ /^(\d+)$/) { $PORT = $1 } else { &help }
if ($LOCALADDR =~ /^([\d\w\-.]+)$/) { $LOCALADDR = $1 } else { &help }
if ($USER =~ /^([\w\-]+)$/) { $USER = $1 } else { &help }
if ($PROCS =~ /^(\d+)$/) { $PROCS = $1 } else { &help }
sub force_poll {
$Danga::Socket::HaveEpoll = 0;
$Danga::Socket::HaveKQueue = 0;
}
my $POLL = "with " . ($Danga::Socket::HaveEpoll ? "epoll()" :
$Danga::Socket::HaveKQueue ? "kqueue()" : "poll()");
my $SERVER;
my $CONFIG_SERVER;
my %childstatus = ();
run_as_server();
exit(0);
sub _fork {
my $pid = fork;
if (!defined($pid)) { die "Cannot fork: $!" }
return $pid if $pid;
# Fixup Net::DNS randomness after fork
srand($$ ^ time);
local $^W;
delete $INC{'Net/DNS/Header.pm'};
require Net::DNS::Header;
# cope with different versions of Net::DNS
eval {
$Net::DNS::Resolver::global{id} = 1;
$Net::DNS::Resolver::global{id} = int(rand(Net::DNS::Resolver::MAX_ID()));
# print "Next DNS ID: $Net::DNS::Resolver::global{id}\n";
};
if ($@) {
# print "Next DNS ID: " . Net::DNS::Header::nextid() . "\n";
}
# Fixup lost kqueue after fork
$Danga::Socket::HaveKQueue = undef;
}
sub spawn_child {
my $plugin_loader = shift || Qpsmtpd::SMTP->new;
if (my $pid = _fork) {
return $pid;
}
$SIG{HUP} = $SIG{CHLD} = $SIG{INT} = $SIG{TERM} = 'DEFAULT';
$SIG{PIPE} = 'IGNORE';
Qpsmtpd::PollServer->OtherFds(fileno($SERVER) => \&accept_handler);
$plugin_loader->run_hooks('post-fork');
Qpsmtpd::PollServer->EventLoop();
exit;
}
sub sig_chld {
my $spawn_count = 0;
while ( (my $child = waitpid(-1,WNOHANG)) > 0) {
if (!defined $childstatus{$child}) {
next;
}
last unless $child > 0;
print "SIGCHLD: child $child died\n";
delete $childstatus{$child};
$spawn_count++;
}
if ($spawn_count) {
for (1..$spawn_count) {
# restart a new child if in poll server mode
my $pid = spawn_child();
$childstatus{$pid} = 1;
}
}
$SIG{CHLD} = \&sig_chld;
}
sub HUNTSMAN {
$SIG{CHLD} = 'DEFAULT';
kill 'INT' => keys %childstatus;
exit(0);
}
sub run_as_server {
# establish SERVER socket, bind and listen.
$SERVER = IO::Socket::INET->new(LocalPort => $PORT,
LocalAddr => $LOCALADDR,
Type => SOCK_STREAM,
Proto => IPPROTO_TCP,
Blocking => 0,
Reuse => 1,
Listen => SOMAXCONN )
or die "Error creating server $LOCALADDR:$PORT : $@\n";
IO::Handle::blocking($SERVER, 0);
binmode($SERVER, ':raw');
$CONFIG_SERVER = IO::Socket::INET->new(LocalPort => $CONFIG_PORT,
LocalAddr => $CONFIG_LOCALADDR,
Type => SOCK_STREAM,
Proto => IPPROTO_TCP,
Blocking => 0,
Reuse => 1,
Listen => 1 )
or die "Error creating server $CONFIG_LOCALADDR:$CONFIG_PORT : $@\n";
IO::Handle::blocking($CONFIG_SERVER, 0);
binmode($CONFIG_SERVER, ':raw');
# Drop priviledges
my (undef, undef, $quid, $qgid) = getpwnam $USER or
die "unable to determine uid/gid for $USER\n";
$) = "";
POSIX::setgid($qgid) or
die "unable to change gid: $!\n";
POSIX::setuid($quid) or
die "unable to change uid: $!\n";
$> = $quid;
# Load plugins here
my $plugin_loader = Qpsmtpd::SMTP->new();
$plugin_loader->load_plugins;
$plugin_loader->log(LOGINFO, 'Running as user '.
(getpwuid($>) || $>) .
', group '.
(getgrgid($)) || $)));
$SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
if ($PROCS > 1) {
for (1..$PROCS) {
my $pid = spawn_child($plugin_loader);
$childstatus{$pid} = 1;
}
$plugin_loader->log(LOGDEBUG, "Listening on $PORT with $PROCS children $POLL");
$SIG{'CHLD'} = \&sig_chld;
sleep while (1);
}
else {
$plugin_loader->log(LOGDEBUG, "Listening on $PORT with single process $POLL");
Qpsmtpd::PollServer->OtherFds(fileno($SERVER) => \&accept_handler,
fileno($CONFIG_SERVER) => \&config_handler,
);
$plugin_loader->run_hooks('post-fork');
while (1) {
Qpsmtpd::PollServer->EventLoop();
}
exit;
}
}
sub config_handler {
my $csock = $CONFIG_SERVER->accept();
if (!$csock) {
# warn("accept failed on config server: $!");
return;
}
binmode($csock, ':raw');
printf("Config server connection\n") if $DEBUG;
IO::Handle::blocking($csock, 0);
setsockopt($csock, IPPROTO_TCP, TCP_NODELAY, pack("l", 1)) or die;
my $client = Qpsmtpd::ConfigServer->new($csock);
$client->watch_read(1);
return;
}
# Accept all new connections
sub accept_handler {
for (1 .. $NUMACCEPT) {
return unless _accept_handler();
}
# got here because we have accept's left.
# So double the number we accept next time.
$NUMACCEPT *= 2;
$NUMACCEPT = ACCEPT_MAX if $NUMACCEPT > ACCEPT_MAX;
$ACCEPT_RSET->cancel;
$ACCEPT_RSET = Danga::Socket->AddTimer(30, \&reset_num_accept);
}
use Errno qw(EAGAIN EWOULDBLOCK);
sub _accept_handler {
my $csock = $SERVER->accept();
if (!$csock) {
# warn("accept() failed: $!");
return;
}
binmode($csock, ':raw');
printf("Listen child making a Qpsmtpd::PollServer for %d.\n", fileno($csock))
if $DEBUG;
IO::Handle::blocking($csock, 0);
#setsockopt($csock, IPPROTO_TCP, TCP_NODELAY, pack("l", 1)) or die;
my $client = Qpsmtpd::PollServer->new($csock);
if ($PAUSED) {
$client->write("451 Sorry, this server is currently paused\r\n");
$client->close;
return 1;
}
$client->push_back_read("Connect\n");
$client->watch_read(1);
return 1;
}
########################################################################
sub log {
my ($level,$message) = @_;
# $level not used yet. this is reimplemented from elsewhere anyway
warn("$$ fd:? $message\n");
}
sub pause {
my ($pause) = @_;
$PAUSED = $pause;
}

184
qpsmtpd-forkserver
View File

@ -7,25 +7,31 @@
#
use lib 'lib';
use Qpsmtpd::TcpServer;
use Qpsmtpd::Constants;
use IO::Socket;
use IO::Select;
use Qpsmtpd::PollServer;
use Socket;
use Getopt::Long;
use POSIX qw(:sys_wait_h :errno_h :signal_h);
use Net::DNS::Header;
use strict;
$| = 1;
my $has_ipv6 = Qpsmtpd::Constants::has_ipv6;
if ($has_ipv6) {
eval 'use Socket6';
}
# Configuration
my $MAXCONN = 15; # max simultaneous connections
my $PORT = 2525; # port number
my @PORT; # port number(s)
my @LOCALADDR; # ip address(es) to bind to
my $USER = 'smtpd'; # user to suid to
my $MAXCONNIP = 5; # max simultaneous connections from one IP
my $PID_FILE = ''; # file to which server PID will be written
my $PID_FILE = '';
my $DETACH; # daemonize on startup
our $DEBUG = 0;
sub usage {
print <<"EOT";
@ -33,49 +39,60 @@ usage: qpsmtpd-forkserver [ options ]
-l, --listen-address addr : listen on specific address(es); can be specified
multiple times for multiple bindings. Default is
0.0.0.0 (all interfaces).
-p, --port P : listen on a specific port; default 2525
-p, --port P : listen on a specific port; default 2525; can be
specified multiple times for multiple bindings.
-c, --limit-connections N : limit concurrent connections to N; default 15
-u, --user U : run as a particular user (default 'smtpd')
-m, --max-from-ip M : limit connections from a single IP; default 5
--pid-file P : print main servers PID to file P
-h, --help : this page
--use-poll : force use of poll() instead of epoll()/kqueue()
-d, --detach : detach from controlling terminal (daemonize)
EOT
exit 0;
}
GetOptions('l|listen-address=s' => \@LOCALADDR,
GetOptions('h|help' => \&usage,
'l|listen-address=s' => \@LOCALADDR,
'c|limit-connections=i' => \$MAXCONN,
'm|max-from-ip=i' => \$MAXCONNIP,
'p|port=i' => \$PORT,
'p|port=s' => \@PORT,
'u|user=s' => \$USER,
'pid-file=s' => \$PID_FILE,
'debug+' => \$DEBUG,
'use-poll' => \&force_poll,
'h|help' => \&usage,
'd|detach' => \$DETACH,
) || &usage;
sub force_poll {
$Danga::Socket::HaveEpoll = 0;
$Danga::Socket::HaveKQueue = 0;
}
# detaint the commandline
if ($PORT =~ /^(\d+)$/) { $PORT = $1 } else { &usage }
@LOCALADDR = ( '0.0.0.0' ) if !@LOCALADDR;
if ($has_ipv6) {
@LOCALADDR = ( '[::]' ) if !@LOCALADDR;
}
else {
@LOCALADDR = ( '0.0.0.0' ) if !@LOCALADDR;
}
@PORT = ( 2525 ) if !@PORT;
my @LISTENADDR;
for (0..$#LOCALADDR) {
if ($LOCALADDR[$_] =~ /^([\d\w\-.]+)$/) {
$LOCALADDR[$_] = $1;
if ($LOCALADDR[$_] =~ /^(\[.*\]|[\d\w\-.]+)(?::(\d+))?$/) {
if ( defined $2 ) {
push @LISTENADDR, { 'addr' => $1, 'port' => $2 };
} else {
my $addr = $1;
for (0..$#PORT) {
if ( $PORT[$_] =~ /^(\d+)$/ ) {
push @LISTENADDR, { 'addr' => $addr, 'port' => $1 };
} else {
&usage;
}
}
}
} else {
&usage;
}
}
if ($USER =~ /^([\w\-]+)$/) { $USER = $1 } else { &usage }
if ($MAXCONN =~ /^(\d+)$/) { $MAXCONN = $1 } else { &usage }
delete @ENV{'ENV','CDPATH','IFS','BASH_ENV'};
delete $ENV{ENV};
$ENV{PATH} = '/bin:/usr/bin:/var/qmail/bin';
my %childstatus = ();
@ -101,16 +118,24 @@ $SIG{INT} = \&HUNTSMAN;
$SIG{TERM} = \&HUNTSMAN;
my $select = new IO::Select;
my $server;
# establish SERVER socket(s), bind and listen.
for my $listen_addr (@LOCALADDR) {
my $server = IO::Socket::INET->new(LocalPort => $PORT,
LocalAddr => $listen_addr,
for my $listen_addr (@LISTENADDR) {
my @Socket_opts = (LocalPort => $listen_addr->{'port'},
LocalAddr => $listen_addr->{'addr'},
Proto => 'tcp',
Reuse => 1,
Blocking => 0,
Listen => SOMAXCONN )
or die "Creating TCP socket $listen_addr:$PORT: $!\n";
Listen => SOMAXCONN);
if ($has_ipv6) {
$server = IO::Socket::INET6->new(@Socket_opts)
or die "Creating TCP socket $listen_addr->{'addr'}:$listen_addr->{'port'}: $!\n";
}
else {
$server = IO::Socket::INET->new(@Socket_opts)
or die "Creating TCP socket $listen_addr->{'addr'}:$listen_addr->{'port'}: $!\n";
}
IO::Handle::blocking($server, 0);
$select->add($server);
}
@ -138,7 +163,7 @@ if ($PID_FILE) {
}
# Load plugins here
my $qpsmtpd = bless {},'Qpsmtpd'; # ugh - probably should have new() in Qpsmtpd.pm
my $qpsmtpd = Qpsmtpd::TcpServer->new();
# Drop privileges
my (undef, undef, $quid, $qgid) = getpwnam $USER or
@ -159,7 +184,9 @@ $> = $quid;
$qpsmtpd->load_plugins;
::log(LOGINFO,"Listening on port $PORT");
foreach my $listen_addr ( @LISTENADDR ) {
::log(LOGINFO,"Listening on $listen_addr->{'addr'}:$listen_addr->{'port'}");
}
::log(LOGINFO, 'Running as user '.
(getpwuid($>) || $>) .
', group '.
@ -200,27 +227,41 @@ while (1) {
# possible something condition...
next;
}
# Make this client blocking while we figure out if we actually want to
# do something with it.
IO::Handle::blocking($client, 1);
my ($port, $iaddr) = sockaddr_in($hisaddr);
if ($MAXCONNIP) {
my $num_conn = 1; # seed with current value
my ($port, $iaddr) = ($server->sockdomain == AF_INET) ? (sockaddr_in($hisaddr)) : (sockaddr_in6($hisaddr));
my $localsockaddr = getsockname($client);
my ($lport, $laddr) = ($server->sockdomain == AF_INET) ? (sockaddr_in($localsockaddr)) : (sockaddr_in6($localsockaddr));
my $nto_iaddr = ($server->sockdomain == AF_INET) ? (inet_ntoa($iaddr)) : (inet_ntop(AF_INET6(), $iaddr));
my $ton_iaddr = ($server->sockdomain == AF_INET) ? (inet_aton($iaddr)) : (inet_pton(AF_INET6(), $iaddr));
my $nto_laddr = ($server->sockdomain == AF_INET) ? (inet_ntoa($laddr)) : (inet_ntop(AF_INET6(), $laddr));
$nto_iaddr =~ s/::ffff://;
$nto_laddr =~ s/::ffff://;
foreach my $rip (values %childstatus) {
++$num_conn if (defined $rip && $rip eq $iaddr);
my ($rc, @msg) = $qpsmtpd->run_hooks("pre-connection",
remote_ip => $nto_iaddr,
remote_port => $port,
local_ip => $nto_laddr,
local_port => $lport,
max_conn_ip => $MAXCONNIP,
child_addrs => [values %childstatus],
);
if ($rc == DENYSOFT || $rc == DENYSOFT_DISCONNECT) {
unless ($msg[0]) {
@msg = ("Sorry, try again later");
}
if ($num_conn > $MAXCONNIP) {
my $rem_ip = inet_ntoa($iaddr);
::log(LOGINFO,"Too many connections from $rem_ip: "
."$num_conn > $MAXCONNIP. Denying connection.");
$client->autoflush(1);
print $client "451 Sorry, too many connections from $rem_ip, try again later\r\n";
&respond_client($client, 451, @msg);
close $client;
next;
}
elsif ($rc == DENY || $rc == DENY_DISCONNECT) {
unless ($msg[0]) {
@msg = ("Sorry, service not available for you");
}
&respond_client($client, 550, @msg);
close $client;
next;
}
my $pid = safe_fork();
if ($pid) {
# parent
@ -233,7 +274,10 @@ while (1) {
# otherwise child
# all children should have different seeds, to prevent conflicts
srand( time ^ ($$ + ($$ << 15)) );
srand();
for (0 .. rand(65536)) {
Net::DNS::Header::nextid();
}
close($server);
@ -243,35 +287,37 @@ while (1) {
::log(LOGINFO, "Connection Timed Out");
exit; };
my $localsockaddr = getsockname($client);
my ($lport, $laddr) = sockaddr_in($localsockaddr);
$ENV{TCPLOCALIP} = inet_ntoa($laddr);
$ENV{TCPLOCALIP} = $nto_laddr;
# my ($port, $iaddr) = sockaddr_in($hisaddr);
$ENV{TCPREMOTEIP} = inet_ntoa($iaddr);
$ENV{TCPREMOTEIP} = $nto_iaddr;
if ($server->sockdomain == AF_INET) {
$ENV{TCPREMOTEHOST} = gethostbyaddr($iaddr, AF_INET) || "Unknown";
}
else {
my ($family, $socktype, $proto, $saddr, $canonname, @res) = getaddrinfo($iaddr, $port, AF_UNSPEC);
$ENV{TCPREMOTEHOST} = $canonname || "Unknown";
}
# don't do this!
#$0 = "qpsmtpd-forkserver: $ENV{TCPREMOTEIP} / $ENV{TCPREMOTEHOST}";
::log(LOGINFO, "Accepted connection $running/$MAXCONN from $ENV{TCPREMOTEIP} / $ENV{TCPREMOTEHOST}");
$::LineMode = 1;
# dup to STDIN/STDOUT
POSIX::dup2(fileno($client), 0);
POSIX::dup2(fileno($client), 1);
# Make this client non-blocking so it works with the Danga framework
IO::Handle::blocking($client, 0);
my $qp = Qpsmtpd::PollServer->new($client);
$qp->load_plugins;
$qp->init_logger;
$qp->push_back_read("Connect\n");
Qpsmtpd::PollServer->AddTimer(0.1, sub { });
while (1) {
$qp->enable_read;
my $line = $qp->get_line;
last if !defined($line);
my $output = $qp->process_line($line);
$qp->write($output) if $output;
}
$qpsmtpd->start_connection
(
local_ip => $ENV{TCPLOCALIP},
local_port => $lport,
remote_ip => $ENV{TCPREMOTEIP},
remote_port => $port,
);
$qpsmtpd->run();
$qpsmtpd->run_hooks("post-connection");
exit; # child leaves
}
}
@ -281,6 +327,18 @@ sub log {
$qpsmtpd->log($level,$message);
}
sub respond_client {
my ($client, $code, @message) = @_;
$client->autoflush(1);
while (my $msg = shift @message) {
my $line = $code . (@message?"-":" ").$msg;
::log(LOGDEBUG, $line);
print $client "$line\r\n"
or (::log(LOGERROR, "Could not print [$line]: $!"), return 0);
}
return 1;
}
### routine to protect process during fork
sub safe_fork {

601
qpsmtpd-prefork Executable file
View File

@ -0,0 +1,601 @@
#!/usr/bin/perl -Tw
# High performance pre-forking qpsmtpd daemon, Copyright (C) 2006 SoftScan
# http://www.softscan.co.uk
#
# Based on qpsmtpd-forkserver Copyright (C) 2001 Ask Bjoern Hansen
# See the LICENSE file for details.
#
# For more information see http://develooper.com/code/qpsmtpd/
# safety guards
use strict;
# includes
use IO::Socket;
use POSIX;
use IPC::Shareable(':all');
use lib 'lib';
use Qpsmtpd::TcpServer::Prefork;
use Qpsmtpd::Constants;
use Getopt::Long;
#use Time::HiRes qw(gettimeofday tv_interval);
# secure shell
$ENV{'PATH'} = '/bin:/usr/bin';
delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
# version
my $VERSION = "1.0";
# qpsmtpd instance
my $qpsmtpd;
# cmd's needed by IPC
my $ipcrm = '/usr/bin/ipcrm';
my $ipcs = '/usr/bin/ipcs';
my $xargs = '/usr/bin/xargs';
# vars we need
my $chld_shmem; # shared mem to keep track of children (and their connections)
my %children;
my $chld_pool;
my $chld_busy;
my $d; # socket
# default settings
my $pid_path = '/var/run/qpsmtpd/';
my $PID = $pid_path . "/qpsmtpd.pid";
my $d_port = 25;
my $d_addr = "0.0.0.0";
my $debug = 0;
my $max_children = 15; # max number of child processes to spawn
my $idle_children = 5; # number of idle child processes to spawn
my $maxconnip = 10;
my $child_lifetime = 100; # number of times a child may be reused
my $loop_sleep = 30; # seconds main_loop sleeps before checking children
my $re_nice = 5; # substracted from parents current nice level
my $d_start = 0;
my $quiet = 0;
my $status = 0;
my $signal = '';
my $pretty = 0;
my $user;
# help text
sub usage {
print <<"EOT";
Usage: qpsmtpd-prefork [ options ]
--quiet : Be quiet (even errors are suppressed)
--version : Show version information
--debug : Enable debug output
--interface addr : Interface daemon should listen on (default: $d_addr)
--port int : TCP port daemon should listen on (default: $d_port)
--max-from-ip int : Limit number of connections from single IP (default: $maxconnip, 0 to disable)
--children int : Max number of children that can be spawned (default: $max_children)
--idle-children int : Number of idle children to spawn (default: $idle_children, 0 to disable)
--pretty-child : Change child process name (default: 0)
--user username : User the daemon should run as
--pid-file path : Path to pid file
--renice-parent int : Subtract value from parent process nice level (default: $re_nice)
--help : This message
EOT
exit 0;
}
# get arguments
GetOptions(
'quiet' => \$quiet,
'version' => sub { print "Qpsmtpd Daemon - version $VERSION\n"; exit 0; },
'debug' => \$debug,
'interface=s' => \$d_addr,
'port=i' => \$d_port,
'max-from-ip=i' => \$maxconnip,
'children=i' => \$max_children,
'idle-children=i' => \$idle_children,
'pretty-child' => \$pretty,
'user=s' => \$user,
'renice-parent=i' => \$re_nice,
'help' => \&usage,
) || &usage;
$user = $1 if ($user =~ /(\w+)/);
# set max from ip to max number of children if option is set to disabled
$maxconnip = $max_children if ($maxconnip == 0);
#to fix limit counter error in plugin <hosts_allow>
$maxconnip++;
#ensure that idle_children matches value given to max_children
$idle_children = $max_children
if (!$idle_children || $idle_children > $max_children || $idle_children < -1);
$chld_pool = $idle_children;
run();
#start daemon
sub run {
# get UUID/GUID
my ($uuid, $ugid, $group);
if ($user) {
my $T_uuid = `id -u $user`;
my $T_ugid = `id -g $user`;
my $T_group = `id -n -g $user`;
chomp($T_uuid);
chomp($T_ugid);
chomp($T_group);
# make the following vars taint happy
$uuid = $1 if ($T_uuid =~ /(\d+)/);
$ugid = $1 if ($T_ugid =~ /(\d+)/);
$group = $1 if ($T_group =~ /(\w+)/);
die("FATAL: unknown user <$user> or missing group information")
if (!$uuid || !$ugid);
}
# create new socket (used by clients to communicate with daemon)
$d =
new IO::Socket::INET(
LocalPort => $d_port,
LocalAddr => $d_addr,
Proto => 'tcp',
Listen => SOMAXCONN,
Reuse => 1,
);
die "FATAL: Failed to start daemon.\nReason: $!\n(It may be nessesary to "
. "wait 20 secs before starting daemon again)\n"
unless $d;
info("qpsmtpd-prefork daemon, version: $VERSION, staring on host: " .
"$d_addr, port: $d_port (user: $user [$<])");
# reset priority
my $old_nice = getpriority(0, 0);
my $new_nice = $old_nice - $re_nice;
if ($new_nice < 20 && $new_nice > -20) {
setpriority(0, 0, $1) if ($new_nice =~ /(\-?\d+)/);
info("parent daemon nice level: $1");
}
else {
die "FATAL: new nice level: $new_nice is not between -19 and 19 "
. "(old level = $old_nice, renice value = $re_nice)";
}
if ($user) {
# change UUID/UGID
$) = "$ugid $ugid"; # effective gid
$( = $ugid; # real gid
$> = $uuid; # effective uid
$< = $uuid; # real uid. we now cannot setuid anymore
die "FATAL: failed to setuid to user: $user, uid: $uuid\n"
if ($> != $uuid and $> != ($uuid - 2**32));
}
# setup shared memory
$chld_shmem = shmem("qpsmtpd", 1);
untie $chld_shmem;
# Interrupt handler
$SIG{INT} = $SIG{TERM} = sub {
# terminate daemon (and children)
my $sig = shift;
# prevent another signal and disable reaper
$SIG{$sig} = $SIG{CHLD} = $SIG{HUP} = 'IGNORE';
unlink("$PID");
# close socket
$d->close();
my $cnt = kill 'INT' => keys %children;
# cleanup shared memory
IPC::Shareable->clean_up;
info("shutdown of daemon (and $cnt children)");
exit;
};
# Hup handler
$SIG{HUP} = sub {
# reload qpmstpd plugins
$qpsmtpd->load_plugins;
kill 'HUP' => keys %children;
info("reload daemon requested");
};
# setup qpsmtpd_instance
$qpsmtpd = qpmsptd_instance();
# child reaper
$SIG{CHLD} = \&reaper;
spawn_children();
main_loop();
exit;
}
# initialize children (only done at daemon startup)
sub spawn_children {
# block signals while new children are being spawned
my $sigset = block_signal(SIGCHLD);
for (1 .. $chld_pool) {
new_child();
}
# reset block signals
unblock_signal($sigset);
}
# cleanup after child dies
sub reaper {
my $stiff;
my @stiffs;
while (($stiff = waitpid(-1, &WNOHANG)) > 0) {
my $res = WEXITSTATUS($?);
info("child terminated, pid: $stiff (status $?, res: $res)");
delete $children{$stiff}; # delete pid from children
# add pid to array so it later can be removed from shared memory
push @stiffs, $stiff;
}
# remove connection info from shared memory and get number
# of busy children (use by main_loop)
$chld_busy = shmem_opt(undef, \@stiffs, undef, undef);
$SIG{CHLD} = \&reaper;
}
#main_loop: main loop (spawn new children)
#arg0: void
#ret0: void
sub main_loop {
while (1) {
# sleep EXPR seconds or until signal (i.e. child death) is received
my $sleept = sleep $loop_sleep;
# block CHLD signals to avoid race, anyway does it matter?
my $sigset = block_signal(SIGCHLD);
# get number of busy children, if sleep wasn't interrupted by signal
$chld_busy = shmem_opt(undef, undef, undef, undef, 1)
if ($sleept == $loop_sleep);
# calculate children in pool (if valid busy children number)
if (defined($chld_busy)) {
info("busy children: $chld_busy");
$chld_pool = $chld_busy + $idle_children;
}
# ensure pool limit is max_children
$chld_pool = $max_children if ($chld_pool > $max_children);
# spawn children
for (my $i = scalar(keys %children) ; $i < $chld_pool ; $i++) {
new_child(); # add to the child pool
}
info( "children pool: $chld_pool (currently spawned: "
. scalar(keys %children)
. ")");
# unblock signals
unblock_signal($sigset);
}
}
# block_signal: block signals
# arg0..n: int with signal(s) to block
# ret0: ref str with sigset (used to later unblock signal)
sub block_signal {
my @signal = @_; #arg0..n
my ($sigset, $blockset);
$sigset = POSIX::SigSet->new();
$blockset = POSIX::SigSet->new(@signal);
sigprocmask(SIG_BLOCK, $blockset, $sigset)
or die "Could not block @signal signals: $!\n";
return ($sigset);
}
# unblock_signal: unblock/reset and receive pending signals
# arg0: ref str with sigset
# ret0: void
sub unblock_signal {
my $sigset = shift; # arg0
sigprocmask(SIG_SETMASK, $sigset)
or die "Could not restore signals: $!\n";
}
# new_child: initialize new child
# arg0: void
# ret0: void
sub new_child {
# daemonize away from the parent process
my $pid;
die "Cannot fork child: $!\n" unless defined($pid = fork);
if ($pid) {
# in parent
$children{$pid} = 1;
info("new child, pid: $pid");
return;
}
# in child
# reset priority
setpriority 0, 0, getpriority(0, 0) + $re_nice;
# reset signals
my $sigset = POSIX::SigSet->new();
my $blockset = POSIX::SigSet->new(SIGCHLD);
sigprocmask(SIG_UNBLOCK, $blockset, $sigset)
or die "Could not unblock SIGHUP signal: $!\n";
$SIG{CHLD} = $SIG{INT} = $SIG{TERM} = $SIG{ALRM} = 'DEFAULT';
# child should exit if it receives HUP signal (note: blocked while child
# is busy, but restored once done)
$SIG{HUP} = sub {
info("signal HUP received, going to exit");
exit 1;
};
# continue to accept connections until "old age" is reached
for (my $i = 0 ; $i < $child_lifetime ; $i++) {
# accept a connection
if ( $pretty ) {
$ENV{PROCESS} = $0 if not defined $ENV{PROCESS}; # 1st time only
$0 = 'qpsmtpd child'; # set pretty child name in process listing
}
my ($client, $iinfo) = $d->accept()
or die
"failed to create new object - $!"; # wait here until client connects
info("connect from: " . $client->peerhost . ":" . $client->peerport);
# set STDIN/STDOUT and autoflush
POSIX::dup2(fileno($client), 0)
|| die "unable to duplicate filehandle to STDIN - $!";
POSIX::dup2(fileno($client), 1)
|| die "unable to duplicate filehandle to STDOUT - $!";
$| = 1;
# connection recieved, block signals
my $sigset = block_signal(SIGHUP);
# start a session if connection looks valid
qpsmtpd_session($client, $qpsmtpd) if ($iinfo);
# close connection and cleanup
$client->shutdown(2);
# unset block and receive pending signals
unblock_signal($sigset);
}
exit; # this child has reached its end-of-life
}
# respond to client
# arg0: ref to socket object (client)
# arg1: int with SMTP reply code
# arg2: arr with message
# ret0: int 0|1 (0 = failure, 1 = success)
sub respond_client {
my ($client, $code, @message) = @_;
$client->autoflush(1);
while (my $msg = shift @message) {
my $line = $code . (@message ? "-" : " ") . $msg;
info("reply to client: <$line>");
print $client "$line\r\n"
or (info("Could not print [$line]: $!"), return 0);
}
return 1;
}
# qpsmtpd_instance: setup qpsmtpd instance
# arg0: void
# ret0: ref to qpsmtpd_instance
sub qpmsptd_instance {
my $qpsmtpd = Qpsmtpd::TcpServer::Prefork->new();
$qpsmtpd->load_plugins;
$qpsmtpd->spool_dir;
$qpsmtpd->size_threshold;
return ($qpsmtpd);
}
# shmem: tie to shared memory hash
# arg0: str with glue
# arg1: int 0|1 (0 = don't create shmem, 1 = create shmem)
# ret0: ref to shared hash
sub shmem {
my $glue = shift; #arg0
my $create = shift || 0; #arg1
my %options = (
create => $create,
exclusive => 0,
mode => 0640,
destroy => 0,
);
my %shmem_hash;
eval {
tie %shmem_hash, 'IPC::Shareable', $glue, {%options}
|| die "unable to tie to shared memory - $!";
};
if ($@) {
info("$@");
return;
}
return (\%shmem_hash);
}
# shmem_opt: connect to shared memory and perform options
# arg0: ref to hash where shared memory should be copied to
# arg1: ref to arr with pid(s) to delete
# arg2: int with pid to add (key)
# arg3: str with packed iaddr to add (value)
# arg4: int 0|1 check and cleanup shared memory (0 = no, 1 = yes - default 0)
# ret0: int with number of busy children (undef if error)
sub shmem_opt {
my $ref_shmem = shift; #arg0
my $ref_pid_del = shift; #arg1
my $pid_add_key = shift; #arg2
my $pid_add_value = shift; #arg3
my $check = shift || 0; #arg4
# check arguments
if ( (defined($pid_add_key) && !defined($pid_add_value))
|| (!defined($pid_add_key) && defined($pid_add_value)))
{
return;
}
my ($chld_shmem, $chld_busy);
eval {
$chld_shmem = &shmem("qpsmtpd", 0); #connect to shared memory hash
if (tied %{$chld_shmem}) {
# perform options
(tied %{$chld_shmem})->shlock(LOCK_EX);
# delete
if ($ref_pid_del) {
foreach my $pid_del (@{$ref_pid_del}) {
delete $$chld_shmem{$pid_del};
}
}
# add
$$chld_shmem{$pid_add_key} = $pid_add_value if ($pid_add_key);
# copy
%{$ref_shmem} = %{$chld_shmem} if ($ref_shmem);
if ($check) {
# loop through pid list and delete orphaned processes
foreach my $pid (keys %{$chld_shmem}) {
if (!kill 0, $pid) {
delete $$chld_shmem{$pid};
warn("orphaned child, pid: $pid removed from memory");
}
}
}
# count number of busy children
$chld_busy = scalar(keys %{$chld_shmem});
(tied %{$chld_shmem})->shunlock;
# untie from shared memory
untie $chld_shmem || die "unable to untie from shared memory";
}
};
# check for error
if ($@) {
undef($chld_busy);
warn("$@");
}
return ($chld_busy);
}
# info: write info
# arg0: str with debug text
sub info {
my $text = shift; #arg0
return if (!$debug);
my ($sec, $min, $hour, $mday, $mon, $year) = localtime(time);
my $nowtime = sprintf "%02d/%02d/%02d %02d:%02d:%02d", $mday, $mon + 1,
$year + 1900, $hour, $min, $sec;
chomp($text);
print STDERR "$nowtime:$$: $text\n";
}
# start qpmstpd session
# arg0: ref to socket object
# arg1: ref to qpsmtpd instance
# ret0: void
sub qpsmtpd_session {
my $client = shift; #arg0
my $qpsmtpd = shift; #arg1
# get local/remote hostname, port and ip address
my ($port, $iaddr) = sockaddr_in(getpeername($client)); #remote
my ($lport, $laddr) = sockaddr_in(getsockname($client)); #local
# get current connected ip addresses (from shared memory)
my %children;
shmem_opt(\%children, undef, $$, $iaddr);
my ($rc, @msg) =
$qpsmtpd->run_hooks(
"pre-connection",
remote_ip => inet_ntoa($iaddr),
remote_port => $port,
local_ip => inet_ntoa($laddr),
local_port => $lport,
max_conn_ip => $maxconnip,
child_addrs => [values %children],
);
if ( $rc == DENYSOFT
|| $rc == DENYSOFT_DISCONNECT
|| $rc == DENY
|| $rc == DENY_DISCONNECT)
{
#smtp return code to reply client with (seed with soft deny)
my $rc_reply = 451;
unless ($msg[0]) {
if ($rc == DENYSOFT || $rc == DENYSOFT_DISCONNECT) {
@msg = ("Sorry, try again later");
}
else {
@msg = ("Sorry, service not available to you");
$rc_reply = 550;
}
}
respond_client($client, $rc_reply, @msg);
# remove pid from shared memory
shmem_opt(undef, [$$], undef, undef);
# retur so child can be reused
return;
}
# all children should have different seeds, to prevent conflicts
srand(time ^ ($$ + ($$ << 15)));
# ALRM handler
$SIG{ALRM} = sub {
print $client "421 Connection Timed Out\n";
info("Connection Timed Out");
# kill the child
exit 1;
};
# set enviroment variables
$ENV{TCPLOCALIP} = inet_ntoa($laddr);
$ENV{TCPREMOTEIP} = inet_ntoa($iaddr);
$ENV{TCPREMOTEHOST} = gethostbyaddr($iaddr, AF_INET) || "Unknown";
# run qpmsptd functions
$SIG{__DIE__} = 'DEFAULT';
eval {
$qpsmtpd->start_connection(
local_ip => $ENV{TCPLOCALIP},
local_port => $lport,
remote_ip => $ENV{TCPREMOTEIP},
remote_port => $client->peerport,
);
$qpsmtpd->run();
$qpsmtpd->run_hooks("post-connection");
};
if ($@ !~ /^(disconnect_tcpserver|died while reading from STDIN)/) {
warn("$@");
}
# child is now idle again so remove it's pid from shared mem
shmem_opt(undef, [$$], undef, undef);
info("remote host: $ENV{TCPREMOTEIP} left...");
}

28
qpsmtpd-server Executable file
View File

@ -0,0 +1,28 @@
#!/usr/bin/perl -Tw
# Copyright (c) 2001 Ask Bjoern Hansen. See the LICENSE file for details.
# The "command dispatch" system is taken from colobus - http://trainedmonkey.com/colobus/
#
# this is designed to be run under tcpserver (http://cr.yp.to/ucspi-tcp.html)
# or inetd if you're into that sort of thing
#
#
# For more information see http://develooper.com/code/qpsmtpd/
#
#
use lib 'lib';
use Qpsmtpd::SelectServer;
use strict;
$| = 1;
delete $ENV{ENV};
$ENV{PATH} = '/bin:/usr/bin:/var/qmail/bin';
Qpsmtpd::SelectServer->main();
__END__
1;

4
t/Test/Qpsmtpd.pm
View File

@ -70,8 +70,8 @@ sub config_dir {
'./config.sample';
}
sub plugin_dir {
'./plugins';
sub plugin_dirs {
('./plugins');
}
sub log {

7
t/addresses.t
View File

@ -27,4 +27,11 @@ $command = 'MAIL FROM:<ask@p.qpsmtpd-test.askask.com> SIZE=1230';
is(($smtpd->command($command))[0], 250, $command);
is($smtpd->transaction->sender->format, '<ask@p.qpsmtpd-test.askask.com>', 'got the right sender');
$command = 'MAIL FROM:<ask@perl.org> SIZE=1230 CORRECT-WITHOUT-ARG';
is(($smtpd->command($command))[0], 250, $command);
$command = 'MAIL FROM:';
is(($smtpd->command($command))[0], 250, $command);
is($smtpd->transaction->sender->format, '<>', 'got the right sender');

7
t/qpsmtpd-address.t
View File

@ -2,7 +2,7 @@
use strict;
$^W = 1;
use Test::More tests => 29;
use Test::More qw/no_plan/;
BEGIN {
use_ok('Qpsmtpd::Address');
@ -101,3 +101,8 @@ my @test_list = sort @unsorted_list;
is_deeply( \@test_list, \@sorted_list, "sort via overloaded 'cmp' operator");
# RT#38746 - non-RFC compliant address should return undef
$as='<user@example.com#>';
$ao = Qpsmtpd::Address->new($as);
is ($ao, undef, "illegal $as");