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

initial import - based on my qpsmtpd fork

Browse Source 
which will merge into the main branch fairly easily
This commit is contained in:
Matt Simerson 2012-06-22 05:38:01 -04:00
parent 8a24c39f14
commit b00f4c7793
211 changed files with 30127 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
.gitignore vendored
View File

@ -1,15 +1,27 @@
blib/
.build/
_build/
cover_db/
inc/
Build
Build.bat
/config
/config/
/pm_to_blib
/blib/
# only ignore top-level Makefile; we need the one in packaging/rpm!
/Makefile
Makefile.[a-z]*
# ignore file produced by rpm build process
/packaging/rpm/qpsmtpd.spec
packaging/rpm/build/
*~
*.bak
denysoft_greylist.dbm
denysoft_greylist.dbm.lock
greylist.dbm
greylist.dbm.lock
/cover_db/
.last_cover_stats
Makefile
Makefile.old
*.tar.gz
MANIFEST.bak
META.yml
MYMETA.yml
nytprof.out
pm_to_blib

16
.perltidyrc Normal file
View File

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

5
.travis.yml Normal file
View File

@ -0,0 +1,5 @@
language: perl
perl:
- "5.14"
- "5.12"
- "5.10"

36
CREDITS Normal file
View File

@ -0,0 +1,36 @@
Jim Winstead <jimw@trainedmonkey.com>: the core "command dispatch"
system in qpsmtpd is taken from his colobus nntp server. The
check_badmailfrom and check_mailrcptto plugins.
John Peacock <jpeacock@cpan.org>: More changes, fixes and vast
improvements for me to ever catch up on here.
Matt Sergeant <matt@sergeant.org>: Clamav plugin. Patch for the dnsbl
plugin to give us all the dns results. Resident SpamAssassin guru.
PPerl. smtp-forward plugin. Documentation (yay!). Lots of fixes and
tweaks. Apache module. Event based high performance experiment.
Devin Carraway <qpsmtpd@devin.com>: Patch to not accept half mails if
the connection gets dropped at the wrong moment. Support and enable
taint checking. MAIL FROM host dns check configurable. HELO hook.
initial earlytalker plugin.
Andrew Pam <xanni@glasswings.com.au>: fixing the maximum message size
(databytes) stuff.
Marius Kjeldahl <marius@kjeldahl.net>, Zukka Zitting
<jukka.zitting@iki.fi>: Patches for supporting $ENV{RELAYCLIENT}
Robert Spier <robert@perl.org>: Klez filter.
Rasjid Wilcox <rasjidw@openminddev.net>: Lots of patches as per the
Changes file.
Kee Hinckley <nazgul@somewhere.com>: Sent me the correct strftime
format for the dates in the "Received" headers.
Gergely Risko <risko@risko.hu>: Fixed timeout bug when the client sent
DATA and then stopped before sending the next line.
... and many many others per the Changes file and version control logs and
mailing list archives. Thanks everyone!

1001
Changes Normal file
View File

File diff suppressed because it is too large Load Diff

19
LICENSE Normal file
View File

@ -0,0 +1,19 @@
Copyright (C) 2001-2010 Ask Bjoern Hansen, Develooper LLC
Permission is hereby granted, free of charge, to any person obtaining a copy of
this software and associated documentation files (the "Software"), to deal in
the Software without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies
of the Software, and to permit persons to whom the Software is furnished to do
so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.

160
MANIFEST Normal file
View File

@ -0,0 +1,160 @@
.gitignore
Changes
config.sample/badhelo
config.sample/badmailfrom
config.sample/badrcptto_patterns
config.sample/dnsbl_zones
config.sample/flat_auth_pw
config.sample/invalid_resolvable_fromhost
config.sample/IP
config.sample/logging
config.sample/loglevel
config.sample/plugins
config.sample/rcpthosts
config.sample/relayclients
config.sample/require_resolvable_fromhost
config.sample/rhsbl_zones
config.sample/size_threshold
config.sample/tls_before_auth
config.sample/tls_ciphers
CREDITS
docs/advanced.pod
docs/authentication.pod
docs/config.pod
docs/development.pod
docs/hooks.pod
docs/logging.pod
docs/plugins.pod
docs/writing.pod
lib/Apache/Qpsmtpd.pm
lib/Danga/Client.pm
lib/Danga/TimeoutSocket.pm
lib/Qpsmtpd.pm
lib/Qpsmtpd/Address.pm
lib/Qpsmtpd/Auth.pm
lib/Qpsmtpd/Command.pm
lib/Qpsmtpd/ConfigServer.pm
lib/Qpsmtpd/Connection.pm
lib/Qpsmtpd/Constants.pm
lib/Qpsmtpd/DSN.pm
lib/Qpsmtpd/Plugin.pm
lib/Qpsmtpd/Plugin/Async/DNSBLBase.pm
lib/Qpsmtpd/PollServer.pm
lib/Qpsmtpd/Postfix.pm
lib/Qpsmtpd/Postfix/Constants.pm
lib/Qpsmtpd/Postfix/pf2qp.pl
lib/Qpsmtpd/SMTP.pm
lib/Qpsmtpd/SMTP/Prefork.pm
lib/Qpsmtpd/TcpServer.pm
lib/Qpsmtpd/TcpServer/Prefork.pm
lib/Qpsmtpd/Transaction.pm
lib/Qpsmtpd/Utils.pm
LICENSE
log/run
Makefile.PL
MANIFEST This list of files
MANIFEST.SKIP
META.yml Module meta-data (added by MakeMaker)
plugins/async/check_earlytalker
plugins/async/dns_whitelist_soft
plugins/async/dnsbl
plugins/async/queue/smtp-forward
plugins/async/require_resolvable_fromhost
plugins/async/rhsbl
plugins/async/uribl
plugins/auth/auth_checkpassword
plugins/auth/auth_cvm_unix_local
plugins/auth/auth_flat_file
plugins/auth/auth_ldap_bind
plugins/auth/auth_vpopmail
plugins/auth/auth_vpopmail_sql
plugins/auth/auth_vpopmaild
plugins/auth/authdeny
plugins/check_badmailfrom
plugins/check_badmailfromto
plugins/check_badrcptto
plugins/check_badrcptto_patterns
plugins/check_bogus_bounce
plugins/check_basicheaders
plugins/check_earlytalker
plugins/check_loop
plugins/relay
plugins/check_spamhelo
plugins/connection_time
plugins/content_log
plugins/count_unrecognized_commands
plugins/dns_whitelist_soft
plugins/dnsbl
plugins/domainkeys
plugins/dont_require_anglebrackets
plugins/greylisting
plugins/help
plugins/hosts_allow
plugins/http_config
plugins/ident/geoip
plugins/ident/p0f
plugins/logging/adaptive
plugins/logging/apache
plugins/logging/connection_id
plugins/logging/devnull
plugins/logging/file
plugins/logging/syslog
plugins/logging/transaction_id
plugins/logging/warn
plugins/milter
plugins/noop_counter
plugins/parse_addr_withhelo
plugins/queue/exim-bsmtp
plugins/queue/maildir
plugins/queue/postfix-queue
plugins/queue/qmail-queue
plugins/queue/smtp-forward
plugins/quit_fortune
plugins/random_error
plugins/rcpt_ok
plugins/rcpt_regexp
plugins/require_resolvable_fromhost
plugins/rhsbl
plugins/sender_permitted_from
plugins/spamassassin
plugins/tls
plugins/tls_cert
plugins/uribl
plugins/virus/aveclient
plugins/virus/bitdefender
plugins/virus/clamav
plugins/virus/clamdscan
plugins/virus/hbedv
plugins/virus/kavscanner
plugins/virus/klez_filter
plugins/virus/sophie
plugins/virus/uvscan
qpsmtpd
qpsmtpd-async
qpsmtpd-forkserver
qpsmtpd-prefork
README
README.plugins
run
STATUS
t/addresses.t
t/config.t
t/helo.t
t/misc.t
t/plugin_tests.t
t/plugin_tests/auth/auth_flat_file
t/plugin_tests/auth/auth_vpopmail
t/plugin_tests/auth/auth_vpopmail_sql
t/plugin_tests/auth/auth_vpopmaild
t/plugin_tests/auth/authdeny
t/plugin_tests/auth/authnull
t/plugin_tests/check_badrcptto
t/plugin_tests/greylisting
t/plugin_tests/dnsbl
t/plugin_tests/ident/geoip
t/plugin_tests/rcpt_ok
t/qpsmtpd-address.t
t/rset.t
t/tempstuff.t
t/Test/Qpsmtpd.pm
t/Test/Qpsmtpd/Plugin.pm

32
MANIFEST.SKIP Normal file
View File

@ -0,0 +1,32 @@
CVS/.*
\.cvsignore$
\.bak$
\.sw[a-z]$
\.tar$
\.tgz$
\.tar\.gz$
\.o$
\.xsi$
\.bs$
output/.*
\.#
^mess/
^sqlite/
^output/
^tmp/
^blib/
^blibdirs$
^Makefile$
^Makefile\.[a-z]+$
^pm_to_blib$
~$
^MANIFEST\.bak
^tv\.log$
^MakeMaker-\d
\#$
\B\.svn\b
^\.perltidyrc$
^\.git/.*
^cover_db/
\.(orig|rej)$
packaging

38
Makefile.PL Normal file
View File

@ -0,0 +1,38 @@
#!/usr/bin/perl -w
use strict;
use ExtUtils::MakeMaker;
WriteMakefile(
NAME => 'qpsmtpd',
VERSION_FROM => 'lib/Qpsmtpd.pm',
PREREQ_PM => {
'Mail::Header' => 0,
'MIME::Base64' => 0,
'Net::DNS' => 0.39,
'Data::Dumper' => 0,
'File::Temp' => 0,
'Time::HiRes' => 0,
'Net::IP' => 0,
'Date::Parse' => 0,
},
ABSTRACT => 'Flexible smtpd daemon written in Perl',
AUTHOR => 'Ask Bjoern Hansen <ask@develooper.com>',
EXE_FILES => [qw(qpsmtpd qpsmtpd-forkserver qpsmtpd-prefork qpsmtpd-async)],
);
sub MY::libscan {
my $path = $_[1];
return '' if $path =~ /\B\.svn\b/;
return $path;
}
sub MY::postamble {
qq[
testcover :
\t cover -delete && \\
HARNESS_PERL_SWITCHES=-MDevel::Cover \$(MAKE) test && \\
cover
]
}

205
README Normal file
View File

@ -0,0 +1,205 @@
#
# this file is best read with `perldoc README`
#
=head1 NAME
Qpsmtpd - qmail perl simple mail transfer protocol daemon
web:
http://smtpd.develooper.com/
mailinglist:
qpsmtpd-subscribe@perl.org
=head1 DESCRIPTION
What is Qpsmtpd?
Qpsmtpd is an extensible SMTP engine written in Perl. No, make that
easily extensible! See plugins/quit_fortune for a very useful, er,
cute example.
=head2 License
Qpsmtpd is licensed under the MIT License; see the LICENSE file for
more information.
=head2 What's new in this release?
See the Changes file! :-)
=head1 Installation
=head2 Required Perl Modules
The following Perl modules are required:
Net::DNS
MIME::Base64
Mail::Header (part of the MailTools distribution)
If you use a version of Perl older than 5.8.0 you will also need
Data::Dumper
File::Temp
Time::HiRes
The easiest way to install modules from CPAN is with the CPAN shell.
Run it with
perl -MCPAN -e shell
=head2 qpsmtpd installation
Make a new user and a directory where you'll install qpsmtpd. I
usually use "smtpd" for the user and /home/smtpd/qpsmtpd/ for the
directory.
Put the files there. If you install from git you can just do
run the following command in the /home/smtpd/ directory.
git clone git://github.com/smtpd/qpsmtpd.git
Beware that the master branch might be unstable and unsuitable for anything
but development, so you might want to get a specific release, for
example (after running git clone):
git checkout -b local_branch v0.84
chmod o+t ~smtpd/qpsmtpd/ (or whatever directory you installed qpsmtpd
in) to make supervise start the log process.
Edit the file config/IP and put the ip address you want to use for
qpsmtpd on the first line (or use 0 to bind to all interfaces).
If you use the supervise tools, then you are practically done!
Just symlink /home/smtpd/qpsmtpd into your /services (or /var/services
or /var/svscan or whatever) directory. Remember to shutdown
qmail-smtpd if you are replacing it with qpsmtpd.
If you don't use supervise, then you need to run the ./run script in
some other way.
The smtpd user needs write access to ~smtpd/qpsmtpd/tmp/ but should
not need to write anywhere else. This directory can be configured
with the "spool_dir" configuration and permissions can be set with
"spool_perms".
As per version 0.25 the distributed ./run script runs tcpserver with
the -R flag to disable identd lookups. Remove the -R flag if that's
not what you want.
=head2 Configuration
Configuration files can go into either /var/qmail/control or into the
config subdirectory of the qpsmtpd installation. Configuration should
be compatible with qmail-smtpd making qpsmtpd a drop-in replacement.
If qmail is installed in a nonstandard location you should set the
$QMAIL environment variable to that location in your "./run" file.
If there is anything missing, then please send a patch (or just
information about what's missing) to the mailinglist or to
ask@develooper.com.
=head1 Better Performance
For better performance we recommend using "qpsmtpd-forkserver" or
running qpsmtpd under Apache 2.x. If you need extremely high
concurrency and all your plugins are compatible, you might want to try
the "qpsmtpd-async" model.
=head1 Plugins
The qpsmtpd core only implements the SMTP protocol. No useful
function can be done by qpsmtpd without loading plugins.
Plugins are loaded on startup where each of them register their
interest in various "hooks" provided by the qpsmtpd core engine.
At least one plugin MUST allow or deny the RCPT command to enable
receiving mail. The "rcpt_ok" is one basic plugin that does
this. Other plugins provide extra functionality related to this; for
example the require_resolvable_fromhost plugin described above.
=head1 Configuration files
All the files used by qmail-smtpd should be supported; so see the man
page for qmail-smtpd. Extra files used by qpsmtpd include:
=over 4
=item plugins
List of plugins, one per line, to be loaded in the order they
appear in the file. Plugins are in the plugins directory (or in
a subdirectory of there).
=item rhsbl_zones
Right hand side blocking lists, one per line. For example:
dsn.rfc-ignorant.org does not accept bounces - http://www.rfc-ignorant.org/
See http://www.rfc-ignorant.org/ for more examples.
=item dnsbl_zones
Normal ip based DNS blocking lists ("RBLs"). For example:
relays.ordb.org
spamsources.fabel.dk
=item require_resolvable_fromhost
If this file contains anything but a 0 on the first line, envelope
senders will be checked against DNS. If an A or a MX record can't be
found the mail command will return a soft rejection (450).
=item spool_dir
If this file contains a directory, it will be the spool directory
smtpd uses during the data transactions. If this file doesn't 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 spool_perms
The default spool permissions are 0700. If you need some other value,
chmod the directory and set it's octal value in config/spool_perms.
=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.
In my test qpsmtpd installation I have a "config/me" file containing
the hostname I use for testing qpsmtpd (so it doesn't introduce itself
with the normal name of the server).
=back
=head1 Problems
In case of problems, always check the logfile first.
By default, qpsmtpd logs to log/main/current. Qpsmtpd can log a lot of
debug information. You can get more or less by adjusting the number in
config/loglevel. Between 1 and 3 should give you a little. Setting it
to 10 or higher will get lots of information in the logs.
If the logfile doesn't give away the problem, then post to the
mailinglist (subscription instructions above). If possible, put
the logfile on a webserver and include a reference to it in the mail.

13
README.plugins Normal file
View File

@ -0,0 +1,13 @@
#
# read this with 'perldoc README.plugins' ...
#
=head1 qpsmtpd plugin system; developer documentation
Plugin documentation is now in F<docs/plugins.pod>.
See the examples in plugins/ and ask questions on the qpsmtpd
mailinglist; subscribe by sending mail to qpsmtpd-subscribe@perl.org.
=cut

77
STATUS Normal file
View File

@ -0,0 +1,77 @@
New Name Suggestions
====================
ignite
flare(mta)
quench
pez (or pezmail)
Roadmap
=======
- http://code.google.com/p/smtpd/issues
- Bugfixes - qpsmtpd is extremely stable (in production since 2001), but
there are always more things to fix.
- Add user configuration plugin infrastructure
- Add plugin API for checking if a local email address is valid
- Add API to reject individual recipients after the RCPT has been
accepted and generate individual bounce messages.
Issues
======
See http://code.google.com/p/smtpd/issues/list
------ The rest of the list here might be outdated. ------
------ Patches to remove things are welcome. ------
add whitelist support to the dnsbl plugin (and maybe to the rhsbl
plugin too). Preferably both supporting DNS based whitelists and
filebased (CDB) ones.
plugin support;
allow plugins to return multiple response lines (does it have to
join them to one for SMTP?)
support plugins for the rest of the commands.
specify a priority in register_hook. ("LAST", "FIRST", "MIDDLE", or
maybe a number)
plugin access to the data line by line during the DATA phase
(instead of just after)
if qmail-queue can't be loaded we still return 250 ?!
Make a system for configuring the plugins per user/domain/...
support databytes per user / domain
localiphost - support foo@[a.b.c.d] addresses
Move dispatch() etc from SMTP.pm to Qpsmtpd.pm to allow other similar
protocols to use the qpsmtpd framework.
Future Ideas
============
Methods to create a bounce message easily; partly so we can accept a
mail for one user but bounce it right away for another RCPT'er.
The data_post hook should be able to put in the notes what addresses
should go through, bounce and get rejected respectively, and qpsmtpd
should just do the right thing. See also
http://nntp.perl.org/group/perl.qpsmtpd/170
David Carraway has some thoughts for "user filters"
http://nntp.perl.org/group/perl.qpsmtpd/2

26
UPGRADING Normal file
View File

@ -0,0 +1,26 @@
When upgrading from:
v 0.84 or below
CHECK_RELAY, CHECK_NORELAY, RELAY_ONLY
All 3 plugins are deprecated and replaced with a new 'relay' plugin. The new plugin reads the same config files (see 'perldoc plugins/relay') as the previous plugins. To get the equivalent functionality of enabling 'relay_only', use the 'only' argument to the relay plugin as documented in the RELAY ONLY section of plugins/relay.
GREYLISTING plugin:
'mode' config argument is deprecated. Use reject and reject_type instead.
The greylisting DB format has changed to accommodate IPv6 addresses. (The DB key has colon ':' seperated fields, and IPv6 addresses are colon delimited). The new format converts the IPs into integers. There is a new config option named 'upgrade' that when enabled, updates all the records in your DB to the new format. Simply add 'upgrade 1' to the plugin entry in config/plugins, start up qpsmtpd once, make one connection. A log entry will be made, telling how many records were upgraded. Remove the upgrade option from your config.
SPF plugin:
spf_deny setting deprecated. Use reject N setting instead, which provides administrators with more granular control over SPF. For backward compatibility, a spf_deny setting of 1 is mapped to 'reject 3' and a 'spf_deny 2' is mapped to 'reject 4'.
P0F plugin:
defaults to p0f v3 (was v2).
Upgrade p0f to version 3 or add 'version 2' to your p0f line in config/plugins. perldoc plugins/ident/p0f for more details.

4
config.sample/IP Normal file
View File

@ -0,0 +1,4 @@
0
# the first line of this file is being used as the IP
# address tcpserver will bind to. Use 0 to bind to all
# interfaces.

4
config.sample/badhelo Normal file
View File

@ -0,0 +1,4 @@
# these domains never uses their domain when greeting us, so reject transactions
aol.com
yahoo.com

5
config.sample/badmailfrom Normal file
View File

@ -0,0 +1,5 @@
# This is a sample config file for badmailfrom
# - single email address
badmailexample@microsoft.com
# - block and entire host, and provide a custom reason
@www.yahoo.com yahoo never sends from www

9
config.sample/badrcptto Normal file
View File

@ -0,0 +1,9 @@
######## entries used for testing ###
bad@example.com
@bad.example.com
######## Example patterns #######
# Format is pattern\s+Response
# Don't forget to anchor the pattern if required
! Sorry, bang paths not accepted here
@.*@ Sorry, multiple at signs not accepted here
% Sorry, percent hack not accepted here

5
config.sample/badrcptto_patterns Normal file
View File

@ -0,0 +1,5 @@
# Format is pattern\s+Response
# Don't forget to anchor the pattern if required
! Sorry, bang paths not accepted here
@.*@ Sorry, multiple at signs not accepted here
% Sorry, percent hack not accepted here

2
config.sample/dnsbl_allow Normal file
View File

@ -0,0 +1,2 @@
# test entry for dnsbl plugin
192.168.99.5

2
config.sample/dnsbl_zones Normal file
View File

@ -0,0 +1,2 @@
spamsources.fabel.dk
zen.spamhaus.org

4
config.sample/flat_auth_pw Normal file
View File

@ -0,0 +1,4 @@
# used by plugins/auth/auth_flat_file
# example entries
good@example.com:good_pass
bad@example.com:bad_pass

6
config.sample/invalid_resolvable_fromhost Normal file
View File

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

23
config.sample/logging Normal file
View File

@ -0,0 +1,23 @@
# by default, qpsmtpd logs to STDERR at the level set in config/loglevel.
#
# In addition, qpsmtpd will log through any plugins enabled in this file.
# You can enable as many plugins as you wish. Example plugin invocations
# are included below. Just remove the # symbol to enable them.
# default logging plugin
logging/warn 9
#logging/adaptive [accept minlevel] [reject maxlevel] [prefix char]
#logging/adaptive 4 6
# send logs to apache (useful if running qpsmtpd under apache)
#logging/apache
# send logs to the great bit bucket
#logging/devnull
# log to a file
#logging/file loglevel LOGINFO /var/log/qpsmtpd.log
# log to syslog
#logging/syslog loglevel LOGWARN priority LOG_NOTICE

12
config.sample/loglevel Normal file
View File

@ -0,0 +1,12 @@
# Log levels
# LOGDEBUG = 7
# LOGINFO = 6
# LOGNOTICE = 5
# LOGWARN = 4
# LOGERROR = 3
# LOGCRIT = 2
# LOGALERT = 1
# LOGEMERG = 0
#
# This setting controls the built-in qpsmtpd logging.
4

6
config.sample/norelayclients Normal file
View File

@ -0,0 +1,6 @@
# used by plugins/relay
# test entries - http://tools.ietf.org/html/rfc5737
192.0.99.5
192.0.99.6
192.0.98.
# add your own entries below...

94
config.sample/plugins Normal file
View File

@ -0,0 +1,94 @@
#
# Example configuration file for plugins
#
# enable this to get configuration via http; see perldoc
# plugins/http_config for details.
# http_config http://localhost/~smtpd/config/ http://www.example.com/smtp.pl?config=
# hosts_allow does not work with the tcpserver deployment model!
# perldoc plugins/hosts_allow for an alternative.
#
# 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
# information plugins
ident/geoip
#ident/p0f /tmp/.p0f_socket version 3
#connection_time
# 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
# tls should load before count_unrecognized_commands
#tls
check_earlytalker
count_unrecognized_commands 4
relay
require_resolvable_fromhost
rhsbl
dnsbl
check_badmailfrom
check_badrcptto
check_spamhelo
# sender_permitted_from
# greylisting p0f genre,windows
#auth/auth_checkpassword checkpw /usr/local/vpopmail/bin/vchkpw true /usr/bin/true
#auth/auth_vpopmail
#auth/auth_vpopmaild
#auth/auth_vpopmail_sql
auth/auth_flat_file
auth/authdeny
# this plugin needs to run after all other "rcpt" plugins
rcpt_ok
check_basicheaders days 5 reject_type temp
domainkeys
# content filters
virus/klez_filter
# You can run the spamassassin plugin with options. See perldoc
# plugins/spamassassin for details.
#
spamassassin
# rejects mails with a SA score higher than 20 and munges the subject
# of the score is higher than 10.
#
# spamassassin reject_threshold 20 munge_subject_threshold 10
# dspam must run after spamassassin for the learn_from_sa feature to work
dspam learn_from_sa 7 reject 1
# run the clamav virus checking plugin
# virus/clamav
# You must enable a queue plugin - see the options in plugins/queue/ - for example:
# queue to a maildir
# queue/maildir /home/spamtrap/mail
# queue the mail with qmail-queue
# queue/qmail-queue
# If you need to run the same plugin multiple times, you can do
# something like the following
# relay
# relay:0 somearg
# relay:1 someotherarg

1
config.sample/rcpthosts Normal file
View File

@ -0,0 +1 @@
localhost

6
config.sample/relayclients Normal file
View File

@ -0,0 +1,6 @@
# used by plugins/relay
# Format is IP, or IP part with trailing dot
# e.g. "127.0.0.1", or "192.168."
127.0.0.1
# leading/trailing whitespace is ignored
192.0.

3
config.sample/require_resolvable_fromhost Normal file
View File

@ -0,0 +1,3 @@
1
# use 0 to disable; anything else to enable.

5
config.sample/rhsbl_zones Normal file
View File

@ -0,0 +1,5 @@
dsn.rfc-ignorant.org does not accept bounces. This violates RFC 821/2505/2821 http://www.rfc-ignorant.org/

3
config.sample/size_threshold Normal file
View File

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

1
config.sample/smtpauth-checkpassword Normal file
View File

@ -0,0 +1 @@
/usr/local/vpopmail/bin/vchkpw /bin/true

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

10
config.sample/tls_ciphers Normal file
View File

@ -0,0 +1,10 @@
# 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 is a reasonable default that should satisfy most installations
HIGH:!SSLv2
#
# if you have legacy clients that require less secure connections,
# consider using this less secure, but PCI compliant setting:
#DEFAULT:!ADH:!LOW:!EXP:!SSLv2:+HIGH:+MEDIUM

47
docs/FAQ.pod Normal file
View File

@ -0,0 +1,47 @@
# best read with perldoc: perldoc FAQ.pod
=head1 FAQ
=head2 Q: Do I need to enable a logging plugin?
=head2 A: No.
When zero logging plugins are configured, logs are directed to STDERR. This
is the 'default' logging and logs are piped to multilog and stored in
log/main/current.
When more than zero logging plugins are enabled, builtin logging is disabled
and logs are sent to every logging plugin configured in config/plugins.
=head2 Q: How do I watch the logs?
=head2 A: Here's a few examples:
The default log files can be watched in real time lik this:
tail -F ~smtpd/log/main/current
To convert the tai timestamps to human readable date time:
tail -F ~smtpd/log/main/current | tai64nlocal
To exclude the dates entirely, use this command:
tail -F ~smtpd/smtpd/log/main/current | cut -d' ' -f2-3
=head2 Q: How do I get alerts when qpsmtpd has a problem?
=head2 A: Send logs with levels below LOGERROR to syslog.
This can be done by adding the following lines to config/plugins:
logging/syslog loglevel LOGERROR
logging/warn LOGINFO
The warn logging plugin replicates the builtin logging, directing log messages to STDERR. The syslog plugin directs errors to syslog where standard monitoring tools can pick them up and act on them.
With these settings, errors will still get sent to STDERR as well.
=cut

93
docs/advanced.pod Normal file
View File

@ -0,0 +1,93 @@
#
# This file is best read with ``perldoc advanced.pod''
#
###
# Conventions:
# plugin names: F<myplugin>, F<qpsmtpd-async>
# constants: I<LOGDEBUG>
# smtp commands, answers: B<HELO>, B<250 Queued!>
#
# Notes:
# * due to restrictions of some POD parsers, no C<<$object->method()>>
# are allowed, use C<$object-E<gt>method()>
#
=head1 Advanced Playground
=head2 Discarding messages
If you want to make the client think a message has been regularily accepted,
but in real you delete it or send it to F</dev/null>, ..., use something
like the following plugin and load it before your default queue plugin.
sub hook_queue {
my ($self, $transaction) = @_;
if ($transaction->notes('discard_mail')) {
my $msg_id = $transaction->header->get('Message-Id') || '';
$msg_id =~ s/[\r\n].*//s;
return(OK, "Queued! $msg_id");
}
return(DECLINED);
}
=head2 Changing return values
This is an example how to use the C<isa_plugin> method.
The B<rcpt_ok_maxrelay> plugin wraps the B<rcpt_ok> plugin. The B<rcpt_ok>
plugin checks the F<rcpthosts> and F<morercpthosts> config files for
domains, which we accept mail for. If not found it tells the
client that relaying is not allowed. Clients which are marked as
C<relay clients> are excluded from this rule. This plugin counts the
number of unsuccessfull relaying attempts and drops the connection if
too many were made.
The optional parameter I<MAX_RELAY_ATTEMPTS> configures this plugin to drop
the connection after I<MAX_RELAY_ATTEMPTS> unsuccessful relaying attempts.
Set to C<0> to disable, default is C<5>.
Note: Do not load both (B<rcpt_ok> and B<rcpt_ok_maxrelay>). This plugin
should be configured to run I<last>, like B<rcpt_ok>.
use Qpsmtpd::DSN;
sub init {
my ($self, $qp, @args) = @_;
die "too many arguments"
if @args > 1;
$self->{_count_relay_max} = defined $args[0] ? $args[0] : 5;
$self->isa_plugin("rcpt_ok");
}
sub hook_rcpt {
my ($self, $transaction, $recipient) = @_;
my ($rc, @msg) = $self->SUPER::hook_rcpt($transaction, $recipient);
return ($rc, @msg)
unless (($rc == DENY) and $self->{_count_relay_max});
my $count =
($self->connection->notes('count_relay_attempts') || 0) + 1;
$self->connection->notes('count_relay_attempts', $count);
return ($rc, @msg) unless ($count > $self->{_count_relay_max});
return Qpsmtpd::DSN->relaying_denied(DENY_DISCONNECT,
"Too many relaying attempts");
}
=head2 Results of other hooks
B<NOTE:> just copied from README.plugins
If we're in a transaction, the results of a callback are stored in
$self->transaction->notes( $code->{name})->{"hook_$hook"}->{return}
If we're in a connection, store things in the connection notes instead.
B<FIXME>: does the above (regarding connection notes) work?
=cut
# vim: ts=2 sw=2 expandtab

258
docs/authentication.pod Normal file
View File

@ -0,0 +1,258 @@
#
# read this with 'perldoc authentication.pod' ...
#
=head1 NAME
Authentication framework for qpsmtpd
=head1 DESCRIPTION
Provides support for SMTP AUTH within qpsmtpd transactions, see
L<http://www.faqs.org/rfcs/rfc2222.html>
L<http://www.faqs.org/rfcs/rfc2554.html>
for more details.
=head1 USAGE
This code is automatically loaded by Qpsmtpd::SMTP only if a plugin
providing one of the defined L<Auth Hooks> is loaded. The only
time this can happen is if the client process employs the EHLO command to
initiate the SMTP session. If the client uses HELO, the AUTH command is
not available and this module isn't even loaded.
=head2 Plugin Design
An authentication plugin can bind to one or more auth hooks or bind to all
of them at once. See L<Multiple Hook Behavior> for more details.
All plugins must provide two functions:
=over 4
=item * init()
This is the standard function which is called by qpsmtpd for any plugin
listed in config/plugins. Typically, an auth plugin should register at
least one hook, like this:
sub init {
my ($self, $qp) = @_;
$self->register_hook("auth", "authfunction");
}
where in this case "auth" means this plugin expects to support any of
the defined authentication methods.
=item * authfunction()
The plugin must provide an authentication function which is part of
the register_hook call. That function will receive the following
six parameters when called:
=over 4
=item $self
A Qpsmtpd::Plugin object, which can be used, for example, to emit log
entries or to send responses to the remote SMTP client.
=item $transaction
A Qpsmtpd::Transaction object which can be used to examine information
about the current SMTP session like the remote IP address.
=item $mechanism
The lower-case name of the authentication mechanism requested by the
client; either "plain", "login", or "cram-md5".
=item $user
Whatever the remote SMTP client sent to identify the user (may be bare
name or fully qualified e-mail address).
=item $clearPassword
If the particular authentication method supports unencrypted passwords
(currently PLAIN and LOGIN), which will be the plaintext password sent
by the remote SMTP client.
=item $hashPassword
An encrypted form of the remote user's password, using the MD-5 algorithm
(see also the $ticket parameter).
=item $ticket
This is the cryptographic challenge which was sent to the client as part
of a CRAM-MD5 transaction. Since the MD-5 algorithm is one-way, the same
$ticket value must be used on the backend to compare with the encrypted
password sent in $hashPassword.
=back
=back
Plugins should perform whatever checking they want and then return one
of the following values (taken from Qpsmtpd::Constants):
=over 4
=item OK
If the authentication has succeeded, the plugin can return this value and
all subsequently registered hooks will be skipped.
=item DECLINED
If the authentication has failed, but any additional plugins should be run,
this value will be returned. If none of the registered plugins succeed, the
overall authentication will fail. Normally an auth plugin should return
this value for all cases which do not succeed (so that another auth plugin
can have a chance to authenticate the user).
=item DENY
If the authentication has failed, and the plugin wishes this to short circuit
any further testing, it should return this value. For example, a plugin could
register the L<auth-plain> hook and immediately fail any connection which is
not trusted (e.g. not in the same network).
Another reason to return DENY over DECLINED would be if the user name matched
an existing account but the password failed to match. This would make a
dictionary-based attack much harder to accomplish. See the included
auth_vpopmail_sql plugin for how this might be accomplished.
By returning DENY, no further authentication attempts will be made using the
current method and data. A remote SMTP client is free to attempt a second
auth method if the first one fails.
=back
Plugins may also return an optional message with the return code, e.g.
return (DENY, "If you forgot your password, contact your admin");
and this will be appended to whatever response is sent to the remote SMTP
client. There is no guarantee that the end user will see this information,
though, since some prominent MTA's (produced by M$oft) I<helpfully>
hide this information under the default configuration. This message will
be logged locally, if appropriate, based on the configured log level.
=head1 Auth Hooks
The currently defined authentication methods are:
=over 4
=item * auth-plain
Any plugin which registers an auth-plain hook will engage in a plaintext
prompted negotiation. This is the least secure authentication method since
both the user name and password are visible in plaintext. Most SMTP clients
will preferentially choose a more secure method if it is advertised by the
server.
=item * auth-login
A slightly more secure method where the username and password are Base-64
encoded before sending. This is still an insecure method, since it is
trivial to decode the Base-64 data. Again, it will not normally be chosen
by SMTP clients unless a more secure method is not available (or if it fails).
=item * auth-cram-md5
A cryptographically secure authentication method which employs a one-way
hashing function to transmit the secret information without significant
risk between the client and server. The server provides a challenge key
L<$ticket>, which the client uses to encrypt the user's password.
Then both user name and password are concatenated and Base-64 encoded before
transmission.
This hook must normally have access to the user's plaintext password,
since there is no way to extract that information from the transmitted data.
Since the CRAM-MD5 scheme requires that the server send the challenge
L<$ticket> before knowing what user is attempting to log in, there is no way
to use any existing MD5-encrypted password (like is frequently used with MySQL).
=item * auth
A catch-all hook which requires that the plugin support all three preceeding
authentication methods. Any plugins registering the auth hook will be run
only after all other plugins registered for the specific authentication
method which was requested. This allows you to move from more specific
plugins to more general plugins (e.g. local accounts first vs replicated
accounts with expensive network access later).
=back
=head2 Multiple Hook Behavior
If more than one hook is registered for a given authentication method, then
they will be tried in the order that they appear in the config/plugins file
unless one of the plugins returns DENY, which will immediately cease all
authentication attempts for this transaction.
In addition, all plugins that are registered for a specific auth hook will
be tried before any plugins which are registered for the general auth hook.
=head1 VPOPMAIL
There are 4 authentication (smtp-auth) plugins that can be used with
vpopmail.
=over 4
=item auth_vpopmaild
If you aren't sure which one to use, then use auth_vpopmaild. It
supports the PLAIN and LOGIN authentication methods,
doesn't require the qpsmtpd process to run with special permissions, and
can authenticate against vpopmail running on another host. It does require
the vpopmaild server to be running.
=item auth_vpopmail
The next best solution is auth_vpopmail. It requires the p5-vpopmail perl
module and it compiles against libvpopmail.a. There are two catches. The
qpsmtpd daemon must run as the vpopmail user, and you must be running v0.09
or higher for CRAM-MD5 support. The released version is 0.08 but my
CRAM-MD5 patch has been added to the developers repo:
http://github.com/sscanlon/vpopmail
=item auth_vpopmail_sql
If you are using the MySQL backend for vpopmail, then this module can be
used for smtp-auth. It supports LOGIN, PLAIN, and CRAM-MD5. However, it
does not work with some vpopmail features such as alias domains, service
restrictions, nor does it update vpopmail's last_auth information.
=item auth_checkpassword
The auth_checkpassword is a generic authentication module that will work
with any DJB style checkpassword program, including ~vpopmail/bin/vchkpw.
It only supports PLAIN and LOGIN auth methods.
=back
=head1 AUTHOR
John Peacock <jpeacock@cpan.org>
Matt Simerson <msimerson@cpan.org> (added VPOPMAIL)
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2004-2006 John Peacock
Portions based on original code by Ask Bjoern Hansen and Guillaume Filion
This plugin is licensed under the same terms as the qpsmtpd package itself.
Please see the LICENSE file included with qpsmtpd for details.
=cut

200
docs/config.pod Normal file
View File

@ -0,0 +1,200 @@
=head1 Qpsmtpd configuration
The default way of setting config values is placing files with the
name of the config variable in the config directory F<config/>, like
qmail's F</var/qmail/control/> directory. NB: F</var/qmail/control> (or
F<$ENV{QMAIL}/control>) is used if a file does not exist in C<config/>.
The location of the C<config/> directory can be set via the
I<QPSMTPD_CONFIG> environment variable and defaults to the current
working directory.
Any empty line or lines starting with C<#> are ignored. You may use a
plugin which hooks the C<config> hook to store the settings in some other
way. See L<docs/plugins.pod> and L<docs/hooks.pod> for more info on this.
Some settings still have to go in files, because they are loaded before
any plugin can return something via the C<config> hook: C<me>, C<logging>,
C<plugin_dirs> and of course C<plugins>. B<FIXME: more?>
=head2 Core settings
These settings are used by the qpsmtpd core. Any other setting is (hopefully)
documented by the corresponding plugin. Some settings of important plugins
are shown below in L</Plugin settings>.
=over 4
=item plugins
The main config file, where all used plugins and their arguments are listed.
=item me
Sets the hostname which is used all over the place: in the greeting message,
the I<Received: >header, ...
Default is whatever Sys::Hostname's hostname() returns.
=item plugin_dirs
Where to search for plugins (one directory per line), defaults to F<./plugins>.
=item logging
Sets the primary logging destination, see F<plugins/logging/*>. Format
is the same as it's used for the F<plugins> config file. B<NOTE:> only
the first non empty line is used (lines starting with C<#> are counted
as empty).
=item loglevel
This is not used anymore, I<only> if no F<logging/> plugin is in use. Use a
logging plugin.
=item databytes
Maximum size a message may be. Without this setting, there is no limit on the
size. Should be something less than the backend MTA has set as it's maximum
message size (if there is one).
=item size_threshold
When a message is greater than the size given in this config file, it will be
spooled to disk. You probably want to enable spooling to disk for most virus
scanner plugins and F<spamassassin>.
=item smtpgreeting
Override the default SMTP greeting with this string.
=item spool_dir
Where temporary files are stored, defaults to F<~/tmp/>.
=item spool_perms
Permissions of the I<spool_dir>, default is C<0700>. You probably have to
change the defaults for some scanners (e.g. the F<clamdscan> plugin).
=item timeout
=item timeoutsmtpd
Set the timeout for the clients, C<timeoutsmtpd> is the qmail smtpd control
file, C<timeout> the qpsmtpd file. Default is 1200 seconds.
=item tls_before_auth
If set to a true value, clients will have to initiate an SSL secured
connection before any auth succeeds, defaults to C<0>.
=back
=head2 Plugin settings files
=over 4
=item rcpthosts, morercpthosts
Plugin: I<rcpt_ok>
Domains listed in these files will be accepted as valid local domains,
anything else is rejected with a C<Relaying denied> message. If an entry
in the C<rcpthosts> file starts with a C<.>, mails to anything ending with
this string will be accepted, e.g.:
example.com
.example.com
will accept mails for C<user@example.com> and C<user@something.example.com>.
The C<morercpthosts> file is just checked for exact (case insensitive)
matches.
=item hosts_allow
Plugin: F<hosts_allow>.
Don't use this config file. The plugin itself is required to set the
maximum number of concurrent connections. This config setting should
only be used for some extremly rude clients: if list is too big it will
slow down accepting new connections.
=item relayclients
=item morerelayclients
Plugin: F<check_relay>
Allow relaying for hosts listed in this file. The C<relayclients> file accepts
IPs and CIDR entries. The C<morercpthosts> file accepts IPs and C<prefixes>
like C<192.168.2.> (note the trailing dot!). With the given example any host
which IP starts with C<192.168.2.> may relay via us.
=item dnsbl_zones
Plugin: F<dnsbl>
This file specifies the RBL zones list, used by the dnsbl plugin. Ihe IP
address of each connecting host will be checked against each zone given.
A few sample DNSBLs are listed in the sample config file, but you should
evaluate the efficacy and listing policies of a DNSBL before using it.
See also C<dnsbl_allow> and C<dnsbl_rejectmsg> in the documentation of the
C<dnsbl> plugin
=item require_resolvable_fromhost
Plugin: F<require_resolvable_fromhost>
Reject sender addresses where the MX is unresolvable, i.e. a boolean value
is the only value in this file. If the MX resolves to something, reject the
sender address if it resolves to something listed in the
F<invalid_resolvable_fromhost> config file. The I<invalid_resolvable_fromhost>
expects IP addresses or CIDR (i.e. C<network/mask> values) one per line, IPv4
only currenlty.
=back
=head2 Plugin settings arguments
These are arguments that can be set on the config/plugins line, after the name
of the plugin. These config options are available to all plugins.
=over 4
=item loglevel
Adjust the quantity of logging for the plugin. See docs/logging.pod
=item reject
plugin reject [ 0 | 1 | naughty ]
Should the plugin reject mail?
The special 'naughty' case will mark the connection as a naughty. Most plugins
skip processing naughty connections. Filtering plugins can learn from them.
Naughty connections are terminated up by the B<naughty> plugin.
Plugins that use $self->get_reject() or $self->get_reject_type() will
automatically honor this setting.
=item reject_type
plugin reject_type [ perm | temp | disconnect | temp_disconnect ]
Default: perm
Values with temp in the name return a 4xx code and the others return a 5xx
code.
The I<reject_type> argument and the corresponding get_reject_type() method
provides a standard way for plugins to automatically return the selected
rejection type, as chosen by the config setting, the plugin author, or the
get_reject_type() method.
Plugins that are updated to use the $self->get_reject() or
$self->get_reject_type() methods will automatically honor this setting.
=back
=cut

143
docs/development.pod Normal file
View File

@ -0,0 +1,143 @@
=head1 Developing Qpsmtpd
=head2 Mailing List
All qpsmtpd development happens on the qpsmtpd mailing list.
Subscribe by sending mail to qpsmtpd-subscribe@perl.org
=head2 Git
We use git for version control.
Ask owns the master repository at git://github.com/smtpd/qpsmtpd.git
We suggest using github to host your repository -- it makes your
changes easily accessible for pulling into the master. After you
create a github account, go to
http://github.com/smtpd/qpsmtpd/tree/master and click on the "fork"
button to get your own repository.
=head3 Making a working Copy
git clone git@github.com:username/qpsmtpd.git qpsmtpd
will check out your copy into a directory called qpsmtpd
=head3 Making a branch for your change
As a general rule, you'll be better off if you do your changes on a
branch - preferably a branch per unrelated change.
You can use the C<git branch> command to see which branch you are on.
The easiest way to make a new branch is
git checkout -b topic/my-great-change
This will create a new branch with the name "topic/my-great-change"
(and your current commit as the starting point).
=head3 Committing a change
Edit the appropriate files, and be sure to run the test suite.
emacs lib/Qpsmtpd.pm # for example
perl Makefile.PL
make test
When you're ready to check it in...
git add lib/Qpsmtpd.pm # to let git know you changed the file
git add --patch plugin/tls # interactive choose which changes to add
git diff --cached # review changes added
git commit # describe the commit
git log -p # review your commit a last time
git push origin # to send to github
=head3 Commit Descriptions
Though not required, it's a good idea to begin the commit message with
a single short (less than 50 character) line summarizing the change,
followed by a blank line and then a more thorough description. Tools
that turn commits into email, for example, use the first line on the
Subject: line and the rest of the commit in the body.
(From: L<git-commit(1)>)
=head3 Submit patches by mail
The best way to submit patches to the project is to send them to the
mailing list for review. Use the C<git format-patch> command to
generate patches ready to be mailed. For example:
git format-patch HEAD~3
will put each of the last three changes in files ready to be mailed
with the C<git send-email> tool (it might be a good idea to send them
to yourself first as a test).
Sending patches to the mailing list is the most effective way to
submit changes, although it helps if you at the same time also commit
them to a git repository (for example on github).
=head3 Merging changes back in from the master repository
Tell git about the master repository. We're going to call it 'smtpd'
for now, but you could call it anything you want. You only have to do
this once.
git remote add smtpd git://github.com/smtpd/qpsmtpd.git
Pull in data from all remote branches
git remote update
Forward-port local commits to the updated upstream head
git rebase smtpd/master
If you have a change that conflicts with an upstream change (git will
let you know) you have two options.
Manually fix the conflict and then do
git add some/file
git commit
Or if the conflicting upstream commit did the same logical change then
you might want to just skip the local change:
git rebase --skip
Be sure to decide whether you're going to skip before you merge, or
you might get yourself into an odd situation.
Conflicts happen because upstream committers may make minor tweaks to
your change before applying it.
=head3 Throwing away changes
If you get your working copy into a state you don't like, you can
always revert to the last commit:
git reset --hard HEAD
Or throw away your most recent commit:
git reset --hard HEAD^
If you make a mistake with this, git is pretty good about keeping your
commits around even as you merge, rebase and reset away. This log of
your git changes is called with "git reflog".
=head3 Applying other peoples changes
If you get a change in an email with the patch, one easy way to apply
other peoples changes is to use C<git am>. That will go ahead and
commit the change. To modify it, you can use C<git commit --amend>.
If the changes are in a repository, you can add that repository with
"git remote add" and then either merge them in with "git merge" or
pick just the relevant commits with "git cherry-pick".

915
docs/hooks.pod Normal file
View File

@ -0,0 +1,915 @@
#
# This file is best read with ``perldoc plugins.pod''
#
###
# Conventions:
# plugin names: F<myplugin>, F<qpsmtpd-async>
# constants: I<LOGDEBUG>
# smtp commands, answers: B<HELO>, B<250 Queued!>
#
# Notes:
# * due to restrictions of some POD parsers, no C<<$object->method()>>
# are allowed, use C<$object-E<gt>method()>
#
=head1 SMTP hooks
This section covers the hooks, which are run in a normal SMTP connection.
The order of these hooks is like you will (probably) see them, while a mail
is received.
Every hook receives a C<Qpsmtpd::Plugin> object of the currently
running plugin as the first argument. A C<Qpsmtpd::Transaction> object is
the second argument of the current transaction in the most hooks, exceptions
are noted in the description of the hook. If you need examples how the
hook can be used, see the source of the plugins, which are given as
example plugins.
B<NOTE>: for some hooks (post-fork, post-connection, disconnect, deny, ok) the
return values are ignored. This does B<not> mean you can return anything you
want. It just means the return value is discarded and you can not disconnect
a client with I<DENY_DISCONNECT>. The rule to return I<DECLINED> to run the
next plugin for this hook (or return I<OK> / I<DONE> to stop processing)
still applies.
=head2 hook_pre_connection
Called by a controlling process (e.g. forkserver or prefork) after accepting
the remote server, but before beginning a new instance (or handing the
connection to the worker process).
Useful for load-management and rereading large config files at some
frequency less than once per session.
This hook is available in the F<qpsmtpd-forkserver>, F<qpsmtpd-prefork> and
F<qpsmtpd-async> flavours.
=cut
NOT FOR: apache, -server and inetd/pperl
=pod
B<NOTE:> You should not use this hook to do major work and / or use lookup
methods which (I<may>) take some time, like DNS lookups. This will slow down
B<all> incoming connections, no other connection will be accepted while this
hook is running!
Arguments this hook receives are (B<NOTE>: currently no C<%args> for
F<qpsmtpd-async>):
my ($self,$transaction,%args) = @_;
# %args is:
# %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],
# );
B<NOTE:> the C<$transaction> is of course C<undef> at this time.
Allowed return codes are
=over 4
=item DENY / DENY_DISCONNECT
returns a B<550> to the client and ends the connection
=item DENYSOFT / DENYSOFT_DISCONNECT
returns a B<451> to the client and ends the connection
=back
Anything else is ignored.
Example plugins are F<hosts_allow> and F<connection_time>.
=head2 hook_connect
It is called at the start of a connection before the greeting is sent to
the connecting client.
Arguments for this hook are
my $self = shift;
B<NOTE:> in fact you get passed two more arguments, which are C<undef> at this
early stage of the connection, so ignore them.
Allowed return codes are
=over 4
=item OK
Stop processing plugins, give the default response
=item DECLINED
Process the next plugin
=item DONE
Stop processing plugins and dont give the default response, i.e. the plugin
gave the response
=item DENY
Return hard failure code and disconnect
=item DENYSOFT
Return soft failure code and disconnect
=back
Example plugin for this hook is the F<check_relay> plugin.
=head2 hook_helo / hook_ehlo
It is called after the client sent B<EHLO> (hook_ehlo) or B<HELO> (hook_helo)
Allowed return codes are
=over 4
=item DENY
Return a 550 code
=item DENYSOFT
Return a B<450> code
=item DENY_DISCONNECT / DENYSOFT_DISCONNECT
as above but with disconnect
=item DONE
Qpsmtpd wont do anything, the plugin sent the message
=item DECLINED
Qpsmtpd will send the standard B<EHLO>/B<HELO> answer, of course only
if all plugins hooking I<helo/ehlo> return I<DECLINED>.
=back
Arguments of this hook are
my ($self, $transaction, $host) = @_;
# $host: the name the client sent in the
# (EH|HE)LO line
B<NOTE:> C<$transaction> is C<undef> at this point.
=head2 hook_mail_pre
After the B<MAIL FROM: > line sent by the client is broken into
pieces by the C<hook_mail_parse()>, this hook recieves the results.
This hook may be used to pre-accept adresses without the surrounding
I<E<lt>E<gt>> (by adding them) or addresses like
I<E<lt>user@example.com.E<gt>> or I<E<lt>user@example.com E<gt>> by
removing the trailing I<"."> / C<" ">.
Expected return values are I<OK> and an address which must be parseable
by C<Qpsmtpd::Address-E<gt>parse()> on success or any other constant to
indicate failure.
Arguments are
my ($self, $transaction, $addr) = @_;
=head2 hook_mail
Called right after the envelope sender line is parsed (the B<MAIL FROM: >
command). The plugin gets passed a C<Qpsmtpd::Address> object, which means
the parsing and verifying the syntax of the address (and just the syntax,
no other checks) is already done. Default is to allow the sender address.
The remaining arguments are the extensions defined in RFC 1869 (if sent by
the client).
B<NOTE:> According to the SMTP protocol, you can not reject an invalid
sender until after the B<RCPT> stage (except for protocol errors, i.e.
syntax errors in address). So store it in an C<$transaction-E<gt>note()> and
process it later in an rcpt hook.
Allowed return codes are
=over 4
=item OK
sender allowed
=item DENY
Return a hard failure code
=item DENYSOFT
Return a soft failure code
=item DENY_DISCONNECT / DENYSOFT_DISCONNECT
as above but with disconnect
=item DECLINED
next plugin (if any)
=item DONE
skip further processing, plugin sent response
=back
Arguments for this hook are
my ($self,$transaction, $sender, %args) = @_;
# $sender: an Qpsmtpd::Address object for
# sender of the message
Example plugins for the C<hook_mail> are F<require_resolvable_fromhost>
and F<check_badmailfrom>.
=head2 hook_rcpt_pre
See C<hook_mail_pre>, s/MAIL FROM:/RCPT TO:/.
=head2 hook_rcpt
This hook is called after the client sent an I<RCPT TO: > command (after
parsing the line). The given argument is parsed by C<Qpsmtpd::Address>,
then this hook is called. Default is to deny the mail with a soft error
code. The remaining arguments are the extensions defined in RFC 1869
(if sent by the client).
Allowed return codes
=over 4
=item OK
recipient allowed
=item DENY
Return a hard failure code, for example for an I<User does not exist here>
message.
=item DENYSOFT
Return a soft failure code, for example if the connect to a user lookup
database failed
=item DENY_DISCONNECT / DENYSOFT_DISCONNECT
as above but with disconnect
=item DONE
skip further processing, plugin sent response
=back
Arguments are
my ($self, $transaction, $recipient, %args) = @_;
# $rcpt = Qpsmtpd::Address object with
# the given recipient address
Example plugin is F<rcpt_ok>.
=head2 hook_data
After the client sent the B<DATA> command, before any data of the message
was sent, this hook is called.
B<NOTE:> This hook, like B<EHLO>, B<VRFY>, B<QUIT>, B<NOOP>, is an
endpoint of a pipelined command group (see RFC 1854) and may be used to
detect ``early talkers''. Since svn revision 758 the F<check_earlytalker>
plugin may be configured to check at this hook for ``early talkers''.
Allowed return codes are
=over 4
=item DENY
Return a hard failure code
=item DENYSOFT
Return a soft failure code
=item DENY_DISCONNECT / DENYSOFT_DISCONNECT
as above but with disconnect
=item DONE
Plugin took care of receiving data and calling the queue (not recommended)
B<NOTE:> The only real use for I<DONE> is implementing other ways of
receiving the message, than the default... for example the CHUNKING SMTP
extension (RFC 1869, 1830/3030) ... a plugin for this exists at
http://svn.perl.org/qpsmtpd/contrib/vetinari/experimental/chunking, but it
was never tested ``in the wild''.
=back
Arguments:
my ($self, $transaction) = @_;
Example plugin is F<greylisting>.
=head2 hook_received_line
If you wish to provide your own Received header line, do it here. You can use
or discard any of the given arguments (see below).
Allowed return codes:
=over 4
=item OK, $string
use this string for the Received header.
=item anything else
use the default Received header
=back
Arguments are
my ($self, $transaction, $smtp, $auth, $sslinfo) = @_;
# $smtp - the SMTP type used (e.g. "SMTP" or "ESMTP").
# $auth - the Auth header additionals.
# $sslinfo - information about SSL for the header.
=head2 data_headers_end
This hook fires after all header lines of the message data has been received.
Defaults to doing nothing, just continue processing. At this step,
the sender is not waiting for a reply, but we can try and prevent him from
sending the entire message by disconnecting immediately. (Although it is
likely the packets are already in flight due to buffering and pipelining).
B<NOTE:> BE CAREFUL! If you drop the connection legal MTAs will retry again
and again, spammers will probably not. This is not RFC compliant and can lead
to an unpredictable mess. Use with caution.
B<NOTE:> This hook does not currently work in async mode.
Why this hook may be useful for you, see
L<http://www.nntp.perl.org/group/perl.qpsmtpd/2009/02/msg8502.html>, ff.
Allowed return codes:
=over 4
=item DENY_DISCONNECT
Return B<554 Message denied> and disconnect
=item DENYSOFT_DISCONNECT
Return B<421 Message denied temporarily> and disconnect
=item DECLINED
Do nothing
=back
Arguments:
my ($self, $transaction) = @_;
B<FIXME:> check arguments
=head2 hook_data_post
The C<data_post> hook is called after the client sent the final C<.\r\n>
of a message, before the mail is sent to the queue.
Allowed return codes are
=over 4
=item DENY
Return a hard failure code
=item DENYSOFT
Return a soft failure code
=item DENY_DISCONNECT / DENYSOFT_DISCONNECT
as above but with disconnect
=item DONE
skip further processing (message will not be queued), plugin gave the response.
B<NOTE:> just returning I<OK> from a special queue plugin does (nearly)
the same (i.e. dropping the mail to F</dev/null>) and you don't have to
send the response on your own.
If you want the mail to be queued, you have to queue it manually!
=back
Arguments:
my ($self, $transaction) = @_;
Example plugins: F<spamassassin>, F<virus/clamdscan>
=head2 hook_queue_pre
This hook is run, just before the mail is queued to the ``backend''. You
may modify the in-process transaction object (e.g. adding headers) or add
something like a footer to the mail (the latter is not recommended).
Allowed return codes are
=over 4
=item DONE
no queuing is done
=item OK / DECLINED
queue the mail
=back
=head2 hook_queue
When all C<data_post> hooks accepted the message, this hook is called. It
is used to queue the message to the ``backend''.
Allowed return codes:
=over 4
=item DONE
skip further processing (plugin gave response code)
=item OK
Return success message, i.e. tell the client the message was queued (this
may be used to drop the message silently).
=item DENY
Return hard failure code
=item DENYSOFT
Return soft failure code, i.e. if disk full or other temporary queuing
problems
=back
Arguments:
my ($self, $transaction) = @_;
Example plugins: all F<queue/*> plugins
=head2 hook_queue_post
This hook is called always after C<hook_queue>. If the return code is
B<not> I<OK>, a message (all remaining return values) with level I<LOGERROR>
is written to the log.
Arguments are
my $self = shift;
B<NOTE:> C<$transaction> is not valid at this point, therefore not mentioned.
=head2 hook_reset_transaction
This hook will be called several times. At the beginning of a transaction
(i.e. when the client sends a B<MAIL FROM:> command the first time),
after queueing the mail and every time a client sends a B<RSET> command.
Arguments are
my ($self, $transaction) = @_;
B<NOTE:> don't rely on C<$transaction> being valid at this point.
=head2 hook_quit
After the client sent a B<QUIT> command, this hook is called (before the
C<hook_disconnect>).
Allowed return codes
=over 4
=item DONE
plugin sent response
=item DECLINED
next plugin and / or qpsmtpd sends response
=back
Arguments: the only argument is C<$self>
=cut
### XXX: FIXME pass the rest of the line to this hook?
=pod
Expample plugin is the F<quit_fortune> plugin.
=head2 hook_disconnect
This hook will be called from several places: After a plugin returned
I<DENY(|SOFT)_DISCONNECT>, before connection is disconnected or after the
client sent the B<QUIT> command, AFTER the quit hook and ONLY if no plugin
hooking C<hook_quit> returned I<DONE>.
All return values are ignored, arguments are just C<$self>
Example plugin is F<logging/file>
=head2 hook_post_connection
This is the counter part of the C<pre-connection> hook, it is called
directly before the connection is finished, for example, just before the
qpsmtpd-forkserver instance exits or if the client drops the connection
without notice (without a B<QUIT>). This hook is not called if the qpsmtpd
instance is killed.
=cut
FIXME: we should run this hook on a ``SIGHUP'' or some other signal?
=pod
The only argument is C<$self> and all return codes are ignored, it would
be too late anyway :-).
Example: F<connection_time>
=head1 Parsing Hooks
Before the line from the client is parsed by
C<Qpsmtpd::Command-E<gt>parse()> with the built in parser, these hooks
are called. They can be used to supply a parsing function for the line,
which will be used instead of the built in parser.
The hook must return two arguments, the first is (currently) ignored,
the second argument must be a (CODE) reference to a sub routine. This sub
routine receives three arguments:
=over 4
=item $self
the plugin object
=item $cmd
the command (i.e. the first word of the line) sent by the client
=item $line
the line sent by the client without the first word
=back
Expected return values from this sub are I<DENY> and a reason which is
sent to the client or I<OK> and the C<$line> broken into pieces according
to the syntax rules for the command.
B<NOTE: ignore the example from C<Qpsmtpd::Command>, the C<unrecognized_command_parse> hook was never implemented,...>
=head2 hook_helo_parse / hook_ehlo_parse
The provided sub routine must return two or more values. The first is
discarded, the second is the hostname (sent by the client as argument
to the B<HELO> / B<EHLO> command). All other values are passed to the
helo / ehlo hook. This hook may be used to change the hostname the client
sent... not recommended, but if your local policy says only to accept
I<HELO> hosts with FQDNs and you have a legal client which can not be
changed to send his FQDN, this is the right place.
=head2 hook_mail_parse / hook_rcpt_parse
The provided sub routine must return two or more values. The first is
either I<OK> to indicate that parsing of the line was successfull
or anything else to bail out with I<501 Syntax error in command>. In
case of failure the second argument is used as the error message for the
client.
If parsing was successfull, the second argument is the sender's /
recipient's address (this may be without the surrounding I<E<lt>> and
I<E<gt>>, don't add them here, use the C<hook_mail_pre()> /
C<hook_rcpt_pre()> methods for this). All other arguments are
sent to the C<mail / rcpt> hook as B<MAIL> / B<RCPT> parameters (see
RFC 1869 I<SMTP Service Extensions> for more info). Note that
the mail and rcpt hooks expect a list of key/value pairs as the
last arguments.
=head2 hook_auth_parse
B<FIXME...>
=head1 Special hooks
Now some special hooks follow. Some of these hooks are some internal hooks,
which may be used to alter the logging or retrieving config values from
other sources (other than flat files) like SQL databases.
=head2 hook_logging
This hook is called when a log message is written, for example in a plugin
it fires if someone calls C<$self-E<gt>log($level, $msg);>. Allowed
return codes are
=over 4
=item DECLINED
next logging plugin
=item OK
(not I<DONE>, as some might expect!) ok, plugin logged the message
=back
Arguments are
my ($self, $transaction, $trace, $hook, $plugin, @log) = @_;
# $trace: level of message, for example
# LOGWARN, LOGDEBUG, ...
# $hook: the hook in/for which this logging
# was called
# $plugin: the plugin calling this hook
# @log: the log message
B<NOTE:> C<$transaction> may be C<undef>, depending when / where this hook
is called. It's probably best not to try acessing it.
All F<logging/*> plugins can be used as example plugins.
=head2 hook_deny
This hook is called after a plugin returned I<DENY>, I<DENYSOFT>,
I<DENY_DISCONNECT> or I<DENYSOFT_DISCONNECT>. All return codes are ignored,
arguments are
my ($self, $transaction, $prev_plugin, $return, $return_text) = @_;
B<NOTE:> C<$transaction> may be C<undef>, depending when / where this hook
is called. It's probably best not to try acessing it.
Example plugin for this hook is F<logging/adaptive>.
=head2 hook_ok
The counter part of C<hook_deny>, it is called after a plugin B<did not>
return I<DENY>, I<DENYSOFT>, I<DENY_DISCONNECT> or I<DENYSOFT_DISCONNECT>.
All return codes are ignored, arguments are
my ( $self, $transaction, $prev_plugin, $return, $return_text ) = @_;
B<NOTE:> C<$transaction> may be C<undef>, depending when / where this hook
is called. It's probably best not to try acessing it.
=head2 hook_config
Called when a config file is requested, for example in a plugin it fires
if someone calls C<my @cfg = $self-E<gt>qp-E<gt>config($cfg_name);>.
Allowed return codes are
=over 4
=item DECLINED
plugin didn't find the requested value
=item OK
requested values as C<@list>, example:
return (OK, @{$config{$value}})
if exists $config{$value};
return (DECLINED);
=back
Arguments:
my ($self,$transaction,$value) = @_;
# $value: the requested config item(s)
B<NOTE:> C<$transaction> may be C<undef>, depending when / where this hook
is called. It's probably best not to try acessing it.
Example plugin is F<http_config> from the qpsmtpd distribution.
=head2 hook_unrecognized_command
This is called if the client sent a command unknown to the core of qpsmtpd.
This can be used to implement new SMTP commands or just count the number
of unknown commands from the client, see below for examples.
Allowed return codes:
=over 4
=item DENY_DISCONNECT
Return B<521> and disconnect the client
=item DENY
Return B<500>
=item DONE
Qpsmtpd wont do anything; the plugin responded, this is what you want to
return, if you are implementing new commands
=item Anything else...
Return B<500 Unrecognized command>
=back
Arguments:
my ($self, $transaction, $cmd, @args) = @_;
# $cmd = the first "word" of the line
# sent by the client
# @args = all the other "words" of the
# line sent by the client
# "word(s)": white space split() line
B<NOTE:> C<$transaction> may be C<undef>, depending when / where this hook
is called. It's probably best not to try acessing it.
Example plugin is F<tls>.
=head2 hook_help
This hook triggers if a client sends the B<HELP> command, allowed return
codes are:
=over 4
=item DONE
Plugin gave the answer.
=item DENY
The client will get a C<syntax error> message, probably not what you want,
better use
$self->qp->respond(502, "Not implemented.");
return DONE;
=back
Anything else will be send as help answer.
Arguments are
my ($self, $transaction, @args) = @_;
with C<@args> being the arguments from the client's command.
=head2 hook_vrfy
If the client sents the B<VRFY> command, this hook is called. Default is to
return a message telling the user to just try sending the message.
Allowed return codes:
=over 4
=item OK
Recipient Exists
=item DENY
Return a hard failure code
=item DONE
Return nothing and move on
=item Anything Else...
Return a B<252>
=back
Arguments are:
my ($self) = shift;
=cut
FIXME: this sould be changed in Qpsmtpd::SMTP to pass the rest of the line
as arguments to the hook
=pod
=head2 hook_noop
If the client sents the B<NOOP> command, this hook is called. Default is to
return C<250 OK>.
Allowed return codes are:
=over 4
=item DONE
Plugin gave the answer
=item DENY_DISCONNECT
Return error code and disconnect client
=item DENY
Return error code.
=item Anything Else...
Give the default answer of B<250 OK>.
=back
Arguments are
my ($self,$transaction,@args) = @_;
=head2 hook_post_fork
B<NOTE:> This hook is only available in qpsmtpd-async.
It is called while starting qpsmtpd-async. You can run more than one
instance of qpsmtpd-async (one per CPU probably). This hook is called
after forking one instance.
Arguments:
my $self = shift;
The return values of this hook are discarded.
=head1 Authentication hooks
=cut
B<FIXME missing:> auth_parse
#=head2 auth
B<FIXME>
#=head2 auth-plain
B<FIXME>
#=head2 auth-login
B<FIXME>
#=head2 auth-cram-md5
B<FIXME>
=pod
See F<docs/authentication.pod>.
=cut
# vim: ts=2 sw=2 expandtab

191
docs/logging.pod Normal file
View File

@ -0,0 +1,191 @@
#
# read this with 'perldoc docs/logging.pod'
#
=head1 qpsmtpd logging; user documentation
Qpsmtpd has a modular logging system. Here's a few things you need to know:
* The built-in logging prints log messages to STDERR.
* A variety of logging plugins is included, each with its own behavior.
* When a logging plugin is enabled, the built-in logging is disabled.
* plugins/logging/warn mimics the built-in logging.
* Multiple logging plugins can be enabled simultaneously.
Read the POD within each logging plugin (perldoc plugins/logging/B<NAME>)
to learn if it tickles your fancy.
=head2 enabling plugins
To enable logging plugins, edit the file I<config/logging> and uncomment the
entries for the plugins you wish to use.
=head2 logging level
The 'master switch' for loglevel is I<config/loglevel>. Qpsmtpd and active
plugins will output all messages that are less than or equal to the value
specified. The log levels correspond to syslog levels:
LOGDEBUG = 7
LOGINFO = 6
LOGNOTICE = 5
LOGWARN = 4
LOGERROR = 3
LOGCRIT = 2
LOGALERT = 1
LOGEMERG = 0
LOGRADAR = 0
Level 6, LOGINFO, is the level at which most servers should start logging. At
level 6, each plugin should log one and occasionally two entries that
summarize their activity. Here's a few sample lines:
(connect) ident::geoip: SA, Saudi Arabia
(connect) ident::p0f: Windows 7 or 8
(connect) earlytalker: pass: remote host said nothing spontaneous
(data_post) domainkeys: skip: unsigned
(data_post) spamassassin: pass, Spam, 21.7 < 100
(data_post) dspam: fail: agree, Spam, 1.00 c
552 we agree, no spam please (#5.6.1)
Three plugins fired during the SMTP connection phase and 3 more ran during the
data_post phase. Each plugin emitted one entry stating their findings.
If you aren't processing the logs, you can save some disk I/O by reducing the
loglevel, so that the only messages logged are ones that indicate a human
should be taking some corrective action.
=head2 log location
If qpsmtpd is started using the distributed run file (cd ~smtpd; ./run), then
you will see the log entries printed to your terminal. This solution works
great for initial setup and testing and is the simplest case.
A typical way to run qpsmtpd is as a supervised process with daemontools. If
daemontools is already set up, setting up qpsmtpd may be as simple as:
C<ln -s /usr/home/smtpd /var/service/>
If svcscan is running, the symlink will be detected and tcpserver will
run the 'run' files in the ./ and ./log directories. Any log entries
emitted will get handled per the instructions in log/run. The default
location specified in log/run is log/main/current.
=head2 plugin loglevel
Most plugins support a loglevel argument after their config/plugins entry.
The value can be a whole number (N) or a relative number (+/-N), where
N is a whole number from 0-7. See the descriptions of each below.
C<ident/p0f loglevel 5>
C<ident/p0f loglevel -1>
ATTN plugin authors: To support loglevel in your plugin, you must store the
loglevel settings from the plugins/config entry $self->{_args}{loglevel}. A
simple and recommended example is as follows:
sub register {
my ( $self, $qp ) = shift, shift;
$self->log(LOGERROR, "Bad arguments") if @_ % 2;
$self->{_args} = { @_ };
}
=head3 whole number
If loglevel is a whole number, then all log activity in the plugin is logged
at that level, regardless of the level the plugin author selected. This can
be easily understood with a couple examples:
The master loglevel is set at 6 (INFO). The mail admin sets a plugin loglevel
to 7 (DEBUG). No messages from that plugin are emitted because DEBUG log
entries are not <= 6 (INFO).
The master loglevel is 6 (INFO) and the plugin loglevel is set to 5 or 6. All
log entries will be logged because 5 is <= 6.
This behavior is very useful to plugin authors. While testing and monitoring
a plugin, they can set the level of their plugin to log everything. To return
to 'normal' logging, they just update their config/plugins entry.
=head3 relative
Relative loglevel arguments adjust the loglevel of each logging call within
a plugin. A value of I<loglevel +1> would make every logging entry one level
less severe, where a value of I<loglevel -1> would make every logging entry
one level more severe.
For example, if a plugin has a loglevel setting of -1 and that same plugin
logged a LOGDEBUG, it would instead be a LOGINFO message. Relative values
makes it easy to control the verbosity and/or severity of individual plugins.
=head1 qpsmtpd logging system; developer documentation
Qpsmtpd now (as of 0.30-dev) supports a plugable logging architecture, so
that different logging plugins can be supported. See the example logging
plugins in plugins/logging, specifically the L<plugins/logging/warn> and
L<plugins/logging/adaptive> files for examples of how to write your own
logging plugins.
=head1 Internal support for pluggable logging
Any code in the core can call C<$self->log()> and those log lines will be
dispatched to each of the registered logging plugins. When C<log()> is
called from a plugin, the plugin and hook names are automatically included
in the parameters passed the logging hooks. All plugins which register for
the logging hook should expect the following parameters to be passed:
$self, $transaction, $trace, $hook, $plugin, @log
where those terms are:
=over 4
=item C<$self>
The object which was used to call the log() method; this can be any object
within the system, since the core code will automatically load logging
plugins on behalf of any object.
=item C<$transaction>
This is the current SMTP transaction (defined as everything that happens
between HELO/EHLO and QUIT/RSET). If you want to defer outputting certain
log lines, you can store them in the transaction object, but you will need
to bind the C<reset_transaction> hook in order to retrieve that information
before it is discarded when the transaction is closed (see the
L<logging/adaptive> plugin for an example of doing this).
=item C<$trace>
This is the log level (as shown in config.sample/loglevel) that the caller
asserted when calling log(). If you want to output the textural
representation (e.g. C<LOGERROR>) of this in your log messages, you can use
the log_level() function exported by Qpsmtpd::Constants (which is
automatically available to all plugins).
=item C<$hook>
This is the hook that is currently being executed. If log() is called by
any core code (i.e. not as part of a hook), this term will be C<undef>.
=item C<$plugin>
This is the plugin name that executed the log(). Like C<$hook>, if part of
the core code calls log(), this wil be C<undef>. See L<logging/warn> for a
way to prevent logging your own plugin's log entries from within that
plugin (the system will not infinitely recurse in any case).
=item C<@log>
The remaining arguments are as passed by the caller, which may be a single
term or may be a list of values. It is usually sufficient to call
C<join(" ",@log)> to deal with these terms, but it is possible that some
plugin might pass additional arguments with signficance.
=back
Note: if you register a handler for certain hooks, e.g. C<deny>, there may
be additional terms passed between C<$self> and C<$transaction>. See
L<logging/adaptive> for and example.

401
docs/plugins.pod Normal file
View File

@ -0,0 +1,401 @@
#
# This file is best read with ``perldoc plugins.pod''
#
###
# Conventions:
# plugin names: F<myplugin>, F<qpsmtpd-async>
# constants: I<LOGDEBUG>
# smtp commands, answers: B<HELO>, B<250 Queued!>
#
# Notes:
# * due to restrictions of some POD parsers, no C<<$object->method()>>
# are allowed, use C<$object-E<gt>method()>
#
=head1 Introduction
Plugins are the heart of qpsmtpd. The core implements only basic SMTP protocol
functionality. No useful function can be done by qpsmtpd without loading
plugins.
Plugins are loaded on startup where each of them register their interest in
various I<hooks> provided by the qpsmtpd core engine.
At least one plugin B<must> allow or deny the B<RCPT> command to enable
receiving mail. The F<check_relay> plugin is the standard plugin for this.
Other plugins provide extra functionality related to this; for example the
F<require_resolvable_fromhost> plugin.
=head2 Loading Plugins
The list of plugins to load are configured in the I<config/plugins>
configuration file. One plugin per line, empty lines and lines starting
with I<#> are ignored. The order they are loaded is the same as given
in this config file. This is also the order the registered I<hooks>
are run. The plugins are loaded from the F<plugins/> directory or
from a subdirectory of it. If a plugin should be loaded from such a
subdirectory, the directory must also be given, like the
F<virus/clamdscan> in the example below. Alternate plugin directories
may be given in the F<config/plugin_dirs> config file, one directory
per line, these will be searched first before using the builtin fallback
of F<plugins/> relative to the qpsmtpd root directory. It may be
necessary, that the F<config/plugin_dirs> must be used (if you're using
F<Apache::Qpsmtpd>, for example).
Some plugins may be configured by passing arguments in the F<plugins>
config file.
A plugin can be loaded two or more times with different arguments by adding
I<:N> to the plugin filename, with I<N> being a number, usually starting at
I<0>.
Another method to load a plugin is to create a valid perl module, drop this
module in perl's C<@INC> path and give the name of this module as
plugin name. The only restriction to this is, that the module name B<must>
contain I<::>, e.g. C<My::Plugin> would be ok, C<MyPlugin> not. Appending of
I<:0>, I<:1>, ... does not work with module plugins.
check_relay
virus/clamdscan
spamassassin reject_threshold 7
my_rcpt_check example.com
my_rcpt_check:0 example.org
My::Plugin
=head1 Anatomy of a plugin
A plugin has at least one method, which inherits from the
C<Qpsmtpd::Plugin> object. The first argument for this method is always the
plugin object itself (and usually called C<$self>). The most simple plugin
has one method with a predefined name which just returns one constant.
# plugin temp_disable_connection
sub hook_connect {
return(DENYSOFT, "Sorry, server is temporarily unavailable.");
}
While this is a valid plugin, it is not very useful except for rare
circumstances. So let us see what happens when a plugin is loaded.
=head2 Initialisation
After the plugin is loaded the C<init()> method of the plugin is called,
if present. The arguments passed to C<init()> are
=over 4
=item $self
the current plugin object, usually called C<$self>
=item $qp
the Qpsmtpd object, usually called C<$qp>.
=item @args
the values following the plugin name in the F<plugins> config, split by
white space. These arguments can be used to configure the plugin with
default and/or static config settings, like database paths,
timeouts, ...
=back
This is mainly used for inheriting from other plugins, but may be used to do
the same as in C<register()>.
The next step is to register the hooks the plugin provides. Any method which
is named C<hook_$hookname> is automagically added.
Plugins should be written using standard named hook subroutines. This
allows them to be overloaded and extended easily. Because some of the
callback names have characters invalid in subroutine names , they must be
translated. The current translation routine is C<s/\W/_/g;>, see
L</Hook - Subroutine translations> for more info. If you choose
not to use the default naming convention, you need to register the hooks in
your plugin in the C<register()> method (see below) with the
C<register_hook()> call on the plugin object.
sub register {
my ($self, $qp, @args) = @_;
$self->register_hook("mail", "mail_handler");
$self->register_hook("rcpt", "rcpt_handler");
}
sub mail_handler { ... }
sub rcpt_handler { ... }
The C<register()> method is called last. It receives the same arguments as
C<init()>. There is no restriction, what you can do in C<register()>, but
creating database connections and reuse them later in the process may not be
a good idea. This initialisation happens before any C<fork()> is done.
Therefore the file handle will be shared by all qpsmtpd processes and the
database will probably be confused if several different queries arrive on
the same file handle at the same time (and you may get the wrong answer, if
any). This is also true for F<qpsmtpd-async> and the pperl flavours, but
not for F<qpsmtpd> started by (x)inetd or tcpserver.
In short: don't do it if you want to write portable plugins.
=head2 Hook - Subroutine translations
As mentioned above, the hook name needs to be translated to a valid perl
C<sub> name. This is done like
($sub = $hook) =~ s/\W/_/g;
$sub = "hook_$sub";
Some examples follow, for a complete list of available (documented ;-))
hooks (method names), use something like
$ perl -lne 'print if s/^=head2\s+(hook_\S+)/$1/' docs/plugins.pod
All valid hooks are defined in F<lib/Qpsmtpd/Plugins.pm>, C<our @hooks>.
=head3 Translation table
hook method
---------- ------------
config hook_config
queue hook_queue
data hook_data
data_post hook_data_post
quit hook_quit
rcpt hook_rcpt
mail hook_mail
ehlo hook_ehlo
helo hook_helo
auth hook_auth
auth-plain hook_auth_plain
auth-login hook_auth_login
auth-cram-md5 hook_auth_cram_md5
connect hook_connect
reset_transaction hook_reset_transaction
unrecognized_command hook_unrecognized_command
=head2 Inheritance
Inheriting methods from other plugins is an advanced topic. You can alter
arguments for the underlying plugin, prepare something for the I<real>
plugin or skip a hook with this. Instead of modifying C<@ISA>
directly in your plugin, use the C<isa_plugin()> method from the
C<init()> subroutine.
# rcpt_ok_child
sub init {
my ($self, $qp, @args) = @_;
$self->isa_plugin("rcpt_ok");
}
sub hook_rcpt {
my ($self, $transaction, $recipient) = @_;
# do something special here...
$self->SUPER::hook_rcpt($transaction, $recipient);
}
See also chapter C<Changing return values> and
F<contrib/vetinari/rcpt_ok_maxrelay> in SVN.
=head2 Config files
Most of the existing plugins fetch their configuration data from files in the
F<config/> sub directory. This data is read at runtime and may be changed
without restarting qpsmtpd.
B<(FIXME: caching?!)>
The contents of the files can be fetched via
@lines = $self->qp->config("my_config");
All empty lines and lines starting with C<#> are ignored.
If you don't want to read your data from files, but from a database you can
still use this syntax and write another plugin hooking the C<config>
hook.
=head2 Logging
Log messages can be written to the log file (or STDERR if you use the
F<logging/warn> plugin) with
$self->log($loglevel, $logmessage);
The log level is one of (from low to high priority)
=over 4
=item *
LOGDEBUG
=item *
LOGINFO
=item *
LOGNOTICE
=item *
LOGWARN
=item *
LOGERROR
=item *
LOGCRIT
=item *
LOGALERT
=item *
LOGEMERG
=back
While debugging your plugins, set your plugins loglevel to LOGDEBUG. This
will log every logging statement within your plugin.
For more information about logging, see F<docs/logging.pod>.
=head2 Information about the current plugin
Each plugin inherits the public methods from C<Qpsmtpd::Plugin>.
=over 4
=item plugin_name()
Returns the name of the currently running plugin
=item hook_name()
Returns the name of the running hook
=item auth_user()
Returns the name of the user the client is authed as (if authentication is
used, of course)
=item auth_mechanism()
Returns the auth mechanism if authentication is used
=item connection()
Returns the C<Qpsmtpd::Connection> object associated with the current
connection
=item transaction()
Returns the C<Qpsmtpd::Transaction> object associated with the current
transaction
=back
=head2 Temporary Files
The temporary file and directory functions can be used for plugin specific
workfiles and will automatically be deleted at the end of the current
transaction.
=over 4
=item temp_file()
Returns a unique name of a file located in the default spool directory,
but does not open that file (i.e. it is the name not a file handle).
=item temp_dir()
Returns the name of a unique directory located in the default spool
directory, after creating the directory with 0700 rights. If you need a
directory with different rights (say for an antivirus daemon), you will
need to use the base function C<$self-E<gt>qp-E<gt>temp_dir()>, which takes a
single parameter for the permissions requested (see L<mkdir> for details).
A directory created like this will not be deleted when the transaction
is ended.
=item spool_dir()
Returns the configured system-wide spool directory.
=back
=head2 Connection and Transaction Notes
Both may be used to share notes across plugins and/or hooks. The only real
difference is their life time. The connection notes start when a new
connection is made and end, when the connection ends. This can, for example,
be used to count the number of none SMTP commands. The plugin which uses
this is the F<count_unrecognized_commands> plugin from the qpsmtpd core
distribution.
The transaction note starts after the B<MAIL FROM: > command and are just
valid for the current transaction, see below in the I<reset_transaction>
hook when the transaction ends.
=head1 Return codes
Each plugin must return an allowed constant for the hook and (usually)
optionally a ``message'' for the client.
Generally all plugins for a hook are processed until one returns
something other than I<DECLINED>.
Plugins are run in the order they are listed in the F<plugins>
configuration file.
The return constants are defined in C<Qpsmtpd::Constants> and have
the following meanings:
=over 4
=item DECLINED
Plugin declined work; proceed as usual. This return code is I<always allowed>
unless noted otherwise.
=item OK
Action allowed.
=item DENY
Action denied.
=item DENYSOFT
Action denied; return a temporary rejection code (say B<450> instead
of B<550>).
=item DENY_DISCONNECT
Action denied; return a permanent rejection code and disconnect the client.
Use this for "rude" clients. Note that you're not supposed to do this
according to the SMTP specs, but bad clients don't listen sometimes.
=item DENYSOFT_DISCONNECT
Action denied; return a temporary rejection code and disconnect the client.
See note above about SMTP specs.
=item DONE
Finishing processing of the request. Usually used when the plugin sent the
response to the client.
=item YIELD
Only used in F<qpsmtpd-async>, see F<plugins/async/*>
=back
=cut
# vim: ts=2 sw=2 expandtab

271
docs/writing.pod Normal file
View File

@ -0,0 +1,271 @@
#
# This file is best read with ``perldoc writing.pod''
#
###
# Conventions:
# plugin names: F<myplugin>, F<qpsmtpd-async>
# constants: I<LOGDEBUG>
# smtp commands, answers: B<HELO>, B<250 Queued!>
#
# Notes:
# * due to restrictions of some POD parsers, no C<<$object->method()>>
# are allowed, use C<$object-E<gt>method()>
#
=head1 Writing your own plugins
This is a walk through a new queue plugin, which queues the mail to a (remote)
QMQP-Server.
First step is to pull in the necessary modules
use IO::Socket;
use Text::Netstring qw( netstring_encode
netstring_decode
netstring_verify
netstring_read );
We know, we need a server to send the mails to. This will be the same
for every mail, so we can use arguments to the plugin to configure this
server (and port).
Inserting this static config is done in C<register()>:
sub register {
my ($self, $qp, @args) = @_;
die "No QMQP server specified in qmqp-forward config"
unless @args;
$self->{_qmqp_timeout} = 120;
if ($args[0] =~ /^([\.\w_-]+)$/) {
$self->{_qmqp_server} = $1;
}
else {
die "Bad data in qmqp server: $args[0]";
}
$self->{_qmqp_port} = 628;
if (@args > 1 and $args[1] =~ /^(\d+)$/) {
$self->{_qmqp_port} = $1;
}
$self->log(LOGWARN, "WARNING: Ignoring additional arguments.")
if (@args > 2);
}
We're going to write a queue plugin, so we need to hook to the I<queue>
hook.
sub hook_queue {
my ($self, $transaction) = @_;
$self->log(LOGINFO, "forwarding to $self->{_qmqp_server}:"
."$self->{_qmqp_port}");
The first step is to open a connection to the remote server.
my $sock = IO::Socket::INET->new(
PeerAddr => $self->{_qmqp_server},
PeerPort => $self->{_qmqp_port},
Timeout => $self->{_qmqp_timeout},
Proto => 'tcp')
or $self->log(LOGERROR, "Failed to connect to "
."$self->{_qmqp_server}:"
."$self->{_qmqp_port}: $!"),
return(DECLINED);
$sock->autoflush(1);
=over 4
=item *
The client starts with a safe 8-bit text message. It encodes the message
as the byte string C<firstline\012secondline\012 ... \012lastline>. (The
last line is usually, but not necessarily, empty.) The client then encodes
this byte string as a netstring. The client also encodes the envelope
sender address as a netstring, and encodes each envelope recipient address
as a netstring.
The client concatenates all these netstrings, encodes the concatenation
as a netstring, and sends the result.
(from L<http://cr.yp.to/proto/qmqp.html>)
=back
The first idea is to build the package we send, in the order described
in the paragraph above:
my $message = $transaction->header->as_string;
$transaction->body_resetpos;
while (my $line = $transaction->body_getline) {
$message .= $line;
}
$message = netstring_encode($message);
$message .= netstring_encode($transaction->sender->address);
for ($transaction->recipients) {
push @rcpt, $_->address;
}
$message .= join "", netstring_encode(@rcpt);
print $sock netstring_encode($message)
or do {
my $err = $!;
$self->_disconnect($sock);
return(DECLINED, "Failed to print to socket: $err");
};
This would mean, we have to hold the full message in memory... Not good
for large messages, and probably even slower (for large messages).
Luckily it's easy to build a netstring without the help of the
C<Text::Netstring> module if you know the size of the string (for more
info about netstrings see L<http://cr.yp.to/proto/netstrings.txt>).
We start with the sender and recipient addresses:
my ($addrs, $headers, @rcpt);
$addrs = netstring_encode($transaction->sender->address);
for ($transaction->recipients) {
push @rcpt, $_->address;
}
$addrs .= join "", netstring_encode(@rcpt);
Ok, we got the sender and the recipients, now let's see what size the
message is.
$headers = $transaction->header->as_string;
my $msglen = length($headers) + $transaction->body_length;
We've got everything we need. Now build the netstrings for the full package
and the message.
First the beginning of the netstring of the full package
# (+ 2: the ":" and "," of the message's netstring)
print $sock ($msglen + length($msglen) + 2 + length($addrs))
.":"
."$msglen:$headers" ### beginning of messages netstring
or do {
my $err = $!;
$self->_disconnect($sock);
return(DECLINED,
"Failed to print to socket: $err");
};
Go to beginning of the body
$transaction->body_resetpos;
If the message is spooled to disk, read the message in
blocks and write them to the server
if ($transaction->body_fh) {
my $buff;
my $size = read $transaction->body_fh, $buff, 4096;
unless (defined $size) {
my $err = $!;
$self->_disconnect($sock);
return(DECLINED, "Failed to read from body_fh: $err");
}
while ($size) {
print $sock $buff
or do {
my $err = $!;
$self->_disconnect($sock);
return(DECLINED, "Failed to print to socket: $err");
};
$size = read $transaction->body_fh, $buff, 4096;
unless (defined $size) {
my $err = $!;
$self->_disconnect($sock);
return(DECLINED,
"Failed to read from body_fh: $err");
}
}
}
Else we have to read it line by line ...
else {
while (my $line = $transaction->body_getline) {
print $sock $line
or do {
my $err = $!;
$self->_disconnect($sock);
return(DECLINED, "Failed to print to socket: $err");
};
}
}
Message is at the server, now finish the package.
print $sock "," # end of messages netstring
.$addrs # sender + recpients
."," # end of netstring of
# the full package
or do {
my $err = $!;
$self->_disconnect($sock);
return(DECLINED,
"Failed to print to socket: $err");
};
We're done. Now let's see what the remote qmqpd says...
=over 4
=item *
(continued from L<http://cr.yp.to/proto/qmqp.html>:)
The server's response is a nonempty string of 8-bit bytes, encoded as a
netstring.
The first byte of the string is either K, Z, or D. K means that the
message has been accepted for delivery to all envelope recipients. This
is morally equivalent to the 250 response to DATA in SMTP; it is subject
to the reliability requirements of RFC 1123, section 5.3.3. Z means
temporary failure; the client should try again later. D means permanent
failure.
Note that there is only one response for the entire message; the server
cannot accept some recipients while rejecting others.
=back
my $answer = netstring_read($sock);
$self->_disconnect($sock);
if (defined $answer and netstring_verify($answer)) {
$answer = netstring_decode($answer);
$answer =~ s/^K// and return(OK,
"Queued! $answer");
$answer =~ s/^Z// and return(DENYSOFT,
"Deferred: $answer");
$answer =~ s/^D// and return(DENY,
"Denied: $answer");
}
If this is the only F<queue/*> plugin, the client will get a 451 temp error:
return(DECLINED, "Protocol error");
}
sub _disconnect {
my ($self,$sock) = @_;
if (defined $sock) {
eval { close $sock; };
undef $sock;
}
}
=cut
# vim: ts=2 sw=2 expandtab

246
lib/Apache/Qpsmtpd.pm Normal file
View File

@ -0,0 +1,246 @@
package Apache::Qpsmtpd;
use 5.006001;
use strict;
use warnings FATAL => 'all';
use Apache2::ServerUtil ();
use Apache2::Connection ();
use Apache2::Const -compile => qw(OK MODE_GETLINE);
use APR::Const -compile => qw(SO_NONBLOCK EOF SUCCESS);
use APR::Error ();
use APR::Brigade ();
use APR::Bucket ();
use APR::Socket ();
use Apache2::Filter ();
use ModPerl::Util ();
our $VERSION = '0.02';
sub handler {
my Apache2::Connection $c = shift;
$c->client_socket->opt_set(APR::Const::SO_NONBLOCK => 0);
die "\$ENV{QPSMTPD_CONFIG} must be given" unless $ENV{QPSMTPD_CONFIG};
my $qpsmtpd = Qpsmtpd::Apache->new();
$qpsmtpd->start_connection(
ip => $c->remote_ip,
host => $c->remote_host,
info => undef,
conn => $c,
);
$qpsmtpd->run($c);
$qpsmtpd->run_hooks("post-connection");
$qpsmtpd->connection->reset;
return Apache2::Const::OK;
}
package Qpsmtpd::Apache;
use Qpsmtpd::Constants;
use base qw(Qpsmtpd::SMTP);
my %cdir_memo;
sub config_dir {
my ($self, $config) = @_;
if (exists $cdir_memo{$config}) {
return $cdir_memo{$config};
}
if (uc($ENV{QPSMTPD_CONFIG}) eq 'USE-VIRTUAL-DOMAINS') {
my $cdir = $self->{conn}->base_server->dir_config("qpsmtpd.config_dir");
$cdir =~ /^(.*)$/; # detaint
my $configdir = $1 if -e "$1/$config";
$cdir_memo{$config} = $configdir;
} else {
$cdir_memo{$config} = $self->SUPER::config_dir(@_);
}
return $cdir_memo{$config};
}
sub start_connection {
my $self = shift;
my %opts = @_;
$self->{conn} = $opts{conn};
$self->{conn}->client_socket->timeout_set($self->config('timeout') * 1_000_000);
$self->{bb_in} = APR::Brigade->new($self->{conn}->pool, $self->{conn}->bucket_alloc);
$self->{bb_out} = APR::Brigade->new($self->{conn}->pool, $self->{conn}->bucket_alloc);
my $remote_host = $opts{host} || ( $opts{ip} ? "[$opts{ip}]" : "[noip!]");
my $remote_info = $opts{info} ? "$opts{info}\@$remote_host" : $remote_host;
my $remote_ip = $opts{ip};
$self->log(LOGNOTICE, "Connection from $remote_info [$remote_ip]");
$self->SUPER::connection->start(
remote_info => $remote_info,
remote_ip => $remote_ip,
remote_host => $remote_host,
local_ip => $opts{conn}->local_ip,
@_
);
}
sub config {
my $self = shift;
my ($param, $type) = @_;
if (!$type) {
my $opt = $self->{conn}->base_server->dir_config("qpsmtpd.$param");
return $opt if defined($opt);
}
return $self->SUPER::config(@_);
}
sub run {
my $self = shift;
# should be somewhere in Qpsmtpd.pm and not here...
$self->load_plugins;
my $rc = $self->start_conversation;
return if $rc != DONE;
# this should really be the loop and read_input should just
# get one line; I think
$self->read_input();
}
sub getline {
my $self = shift;
my $c = $self->{conn} || die "Cannot getline without a conn";
return if $c->aborted;
my $bb = $self->{bb_in};
while (1) {
my $rc = $c->input_filters->get_brigade($bb, Apache2::Const::MODE_GETLINE);
return if $rc == APR::Const::EOF;
die APR::Error::strerror($rc) unless $rc == APR::Const::SUCCESS;
next unless $bb->flatten(my $data);
$bb->cleanup;
return $data;
}
return '';
}
sub read_input {
my $self = shift;
my $c = $self->{conn};
while (defined(my $data = $self->getline)) {
$data =~ s/\r?\n$//s; # advanced chomp
$self->connection->notes('original_string', $data);
$self->log(LOGDEBUG, "dispatching $data");
defined $self->dispatch(split / +/, $data, 2)
or $self->respond(502, "command unrecognized: '$data'");
last if $self->{_quitting};
}
}
sub respond {
my ($self, $code, @messages) = @_;
my $c = $self->{conn};
while (my $msg = shift @messages) {
my $bb = $self->{bb_out};
my $line = $code . (@messages?"-":" ").$msg;
$self->log(LOGDEBUG, $line);
my $bucket = APR::Bucket->new(($c->bucket_alloc), "$line\r\n");
$bb->insert_tail($bucket);
$c->output_filters->fflush($bb);
# $bucket->remove;
$bb->cleanup;
}
return 1;
}
sub disconnect {
my $self = shift;
$self->SUPER::disconnect(@_);
$self->{_quitting} = 1;
$self->{conn}->client_socket->close();
}
1;
__END__
=head1 NAME
Apache::Qpsmtpd - a mod_perl-2 connection handler for qpsmtpd
=head1 SYNOPSIS
Listen 0.0.0.0:25 smtp
AcceptFilter smtp none
## "smtp" and the AcceptFilter are required for Linux, FreeBSD
## with apache >= 2.1.5, for others it doesn't hurt. See also
## http://httpd.apache.org/docs/2.2/mod/core.html#acceptfilter
## and http://httpd.apache.org/docs/2.2/mod/mpm_common.html#listen
LoadModule perl_module modules/mod_perl.so
<Perl>
use lib qw( /path/to/qpsmtpd/lib );
use Apache::Qpsmtpd;
$ENV{QPSMTPD_CONFIG} = "/path/to/qpsmtpd/config";
</Perl>
<VirtualHost _default_:25>
PerlModule Apache::Qpsmtpd
PerlProcessConnectionHandler Apache::Qpsmtpd
# can specify this in config/plugin_dirs if you wish:
PerlSetVar qpsmtpd.plugin_dirs /path/to/qpsmtpd/plugins
PerlSetVar qpsmtpd.loglevel 4
</VirtualHost>
Using multiple instances of Qpsmtpd on the same server is also
possible by setting:
$ENV{QPSMTPD_CONFIG} = "USE-VIRTUAL-DOMAINS";
Then in the VirtualHost of each config define the configuration
directory:
PerlSetVar qpsmtpd.config_dir /path/to/qpsmtpd/config
Several different configurations can be running on the same
server.
=head1 DESCRIPTION
This module implements a mod_perl/apache 2.0 connection handler
that turns Apache into an SMTP server using Qpsmtpd.
It also allows you to set single-valued config options (such
as I<loglevel>, as seen above) using C<PerlSetVar> in F<httpd.conf>.
This module should be considered beta software as it is not yet
widely tested. However it is currently the fastest way to run
Qpsmtpd, so if performance is important to you then consider this
module.
=head1 BUGS
Probably a few. Make sure you test your plugins carefully.
The Apache scoreboard (/server-status/) mostly works and shows
connections, but could do with some enhancements specific to SMTP.
=head1 AUTHOR
Matt Sergeant, <matt@sergeant.org>
Some credit goes to <mock@obscurity.org> for Apache::SMTP which gave
me the inspiration to do this. <peter@boku.net> added the virtual
host support.
=cut

221
lib/Danga/Client.pm Normal file
View File

@ -0,0 +1,221 @@
# $Id: Client.pm,v 1.8 2005/02/14 22:06:38 msergeant Exp $
package Danga::Client;
use base 'Danga::TimeoutSocket';
use fields qw(
line
pause_count
read_bytes
data_bytes
callback
get_chunks
reader_object
);
use Time::HiRes ();
use bytes;
# 30 seconds max timeout!
sub max_idle_time { 30 }
sub max_connect_time { 1200 }
sub new {
my Danga::Client $self = shift;
$self = fields::new($self) unless ref $self;
$self->SUPER::new( @_ );
$self->reset_for_next_message;
return $self;
}
sub reset_for_next_message {
my Danga::Client $self = shift;
$self->{line} = '';
$self->{pause_count} = 0;
$self->{read_bytes} = 0;
$self->{callback} = undef;
$self->{reader_object} = undef;
$self->{data_bytes} = '';
$self->{get_chunks} = 0;
return $self;
}
sub get_bytes {
my Danga::Client $self = shift;
my ($bytes, $callback) = @_;
if ($self->{callback}) {
die "get_bytes/get_chunks currently in progress!";
}
$self->{read_bytes} = $bytes;
$self->{data_bytes} = $self->{line};
$self->{read_bytes} -= length($self->{data_bytes});
$self->{line} = '';
if ($self->{read_bytes} <= 0) {
if ($self->{read_bytes} < 0) {
$self->{line} = substr($self->{data_bytes},
$self->{read_bytes}, # negative offset
0 - $self->{read_bytes}, # to end of str
""); # truncate that substr
}
$callback->($self->{data_bytes});
return;
}
$self->{callback} = $callback;
}
sub process_chunk {
my Danga::Client $self = shift;
my $callback = shift;
my $last_crlf = rindex($self->{line}, "\r\n");
if ($last_crlf != -1) {
if ($last_crlf + 2 == length($self->{line})) {
my $data = $self->{line};
$self->{line} = '';
$callback->($data);
}
else {
my $data = substr($self->{line}, 0, $last_crlf + 2);
$self->{line} = substr($self->{line}, $last_crlf + 2);
$callback->($data);
}
}
}
sub get_chunks {
my Danga::Client $self = shift;
my ($bytes, $callback) = @_;
if ($self->{callback}) {
die "get_bytes/get_chunks currently in progress!";
}
$self->{read_bytes} = $bytes;
$self->process_chunk($callback) if length($self->{line});
$self->{callback} = $callback;
$self->{get_chunks} = 1;
}
sub end_get_chunks {
my Danga::Client $self = shift;
my $remaining = shift;
$self->{callback} = undef;
$self->{get_chunks} = 0;
if (defined($remaining)) {
$self->process_read_buf(\$remaining);
}
}
sub set_reader_object {
my Danga::Client $self = shift;
$self->{reader_object} = shift;
}
sub event_read {
my Danga::Client $self = shift;
if (my $obj = $self->{reader_object}) {
$self->{reader_object} = undef;
$obj->event_read($self);
}
elsif ($self->{callback}) {
$self->{alive_time} = time;
if ($self->{get_chunks}) {
my $bref = $self->read($self->{read_bytes});
return $self->close($!) unless defined $bref;
$self->{line} .= $$bref;
$self->process_chunk($self->{callback}) if length($self->{line});
return;
}
if ($self->{read_bytes} > 0) {
my $bref = $self->read($self->{read_bytes});
return $self->close($!) unless defined $bref;
$self->{read_bytes} -= length($$bref);
$self->{data_bytes} .= $$bref;
}
if ($self->{read_bytes} <= 0) {
# print "Erk, read too much!\n" if $self->{read_bytes} < 0;
my $cb = $self->{callback};
$self->{callback} = undef;
$cb->($self->{data_bytes});
}
}
else {
my $bref = $self->read(8192);
return $self->close($!) unless defined $bref;
$self->process_read_buf($bref);
}
}
sub process_read_buf {
my Danga::Client $self = shift;
my $bref = shift;
$self->{line} .= $$bref;
return if $self->{pause_count} || $self->{closed};
if ($self->{line} =~ s/^(.*?\n)//) {
my $line = $1;
$self->{alive_time} = time;
my $resp = $self->process_line($line);
if ($::DEBUG > 1 and $resp) { print "$$:".($self+0)."S: $_\n" for split(/\n/, $resp) }
$self->write($resp) if $resp;
# $self->watch_read(0) if $self->{pause_count};
return if $self->{pause_count} || $self->{closed};
# read more in a timer, to give other clients a look in
$self->AddTimer(0, sub {
if (length($self->{line}) && !$self->paused) {
$self->process_read_buf(\""); # " for bad syntax highlighters
}
});
}
}
sub has_data {
my Danga::Client $self = shift;
return length($self->{line}) ? 1 : 0;
}
sub clear_data {
my Danga::Client $self = shift;
$self->{line} = '';
}
sub paused {
my Danga::Client $self = shift;
return 1 if $self->{pause_count};
return 1 if $self->{closed};
return 0;
}
sub pause_read {
my Danga::Client $self = shift;
$self->{pause_count}++;
# $self->watch_read(0);
}
sub continue_read {
my Danga::Client $self = shift;
$self->{pause_count}--;
if ($self->{pause_count} <= 0) {
$self->{pause_count} = 0;
$self->AddTimer(0, sub {
if (length($self->{line}) && !$self->paused) {
$self->process_read_buf(\""); # " for bad syntax highlighters
}
});
}
}
sub process_line {
my Danga::Client $self = shift;
return '';
}
sub close {
my Danga::Client $self = shift;
print "closing @_\n" if $::DEBUG;
$self->SUPER::close(@_);
}
sub event_err { my Danga::Client $self = shift; $self->close("Error") }
sub event_hup { my Danga::Client $self = shift; $self->close("Disconnect (HUP)") }
1;

67
lib/Danga/TimeoutSocket.pm Normal file
View File

@ -0,0 +1,67 @@
# $Id: TimeoutSocket.pm,v 1.2 2005/02/02 20:44:35 msergeant Exp $
package Danga::TimeoutSocket;
use base 'Danga::Socket';
use fields qw(alive_time create_time);
our $last_cleanup = 0;
Danga::Socket->AddTimer(15, \&_do_cleanup);
sub new {
my Danga::TimeoutSocket $self = shift;
my $sock = shift;
$self = fields::new($self) unless ref($self);
$self->SUPER::new($sock);
my $now = time;
$self->{alive_time} = $self->{create_time} = $now;
return $self;
}
# overload these in a subclass
sub max_idle_time { 0 }
sub max_connect_time { 0 }
sub Reset {
Danga::Socket->Reset;
Danga::Socket->AddTimer(15, \&_do_cleanup);
}
sub _do_cleanup {
my $now = time;
Danga::Socket->AddTimer(15, \&_do_cleanup);
my $sf = __PACKAGE__->get_sock_ref;
my %max_age; # classname -> max age (0 means forever)
my %max_connect; # classname -> max connect time
my @to_close;
while (my $k = each %$sf) {
my Danga::TimeoutSocket $v = $sf->{$k};
my $ref = ref $v;
next unless $v->isa('Danga::TimeoutSocket');
unless (defined $max_age{$ref}) {
$max_age{$ref} = $ref->max_idle_time || 0;
$max_connect{$ref} = $ref->max_connect_time || 0;
}
if (my $t = $max_connect{$ref}) {
if ($v->{create_time} < $now - $t) {
push @to_close, $v;
next;
}
}
if (my $t = $max_age{$ref}) {
if ($v->{alive_time} < $now - $t) {
push @to_close, $v;
}
}
}
$_->close("Timeout") foreach @to_close;
}
1;

630
lib/Qpsmtpd.pm Normal file
View File

@ -0,0 +1,630 @@
package Qpsmtpd;
use strict;
use vars qw($VERSION $TraceLevel $Spool_dir $Size_threshold);
use Sys::Hostname;
use Qpsmtpd::Constants;
#use DashProfiler;
$VERSION = "0.84";
my $git;
if (-e ".git") {
local $ENV{PATH} = "/usr/bin:/usr/local/bin:/opt/local/bin/";
$git = `git describe`;
$git && chomp $git;
}
my $hooks = {};
my %defaults = (
me => hostname,
timeout => 1200,
);
my $_config_cache = {};
my %config_dir_memo;
#DashProfiler->add_profile("qpsmtpd");
#my $SAMPLER = DashProfiler->prepare("qpsmtpd");
my $LOGGING_LOADED = 0;
sub _restart {
my $self = shift;
my %args = @_;
if ($args{restart}) {
# reset all global vars to defaults
$self->clear_config_cache;
$hooks = {};
$LOGGING_LOADED = 0;
%config_dir_memo = ();
$TraceLevel = LOGWARN;
$Spool_dir = undef;
$Size_threshold = undef;
}
}
sub DESTROY {
#warn $_ for DashProfiler->profile_as_text("qpsmtpd");
}
sub version { $VERSION . ($git ? "/$git" : "") };
sub TRACE_LEVEL { $TraceLevel }; # leave for plugin compatibility
sub hooks { $hooks; }
sub load_logging {
# need to do this differently than other plugins so as to
# not trigger logging activity
return if $LOGGING_LOADED;
my $self = shift;
return if $hooks->{"logging"};
my $configdir = $self->config_dir("logging");
my $configfile = "$configdir/logging";
my @loggers = $self->_config_from_file($configfile,'logging');
$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" );
}
my @loaded;
for my $logger (@loggers) {
push @loaded, $self->_load_plugin($logger, @plugin_dirs);
}
foreach my $logger (@loaded) {
$self->log(LOGINFO, "Loaded $logger");
}
$configdir = $self->config_dir("loglevel");
$configfile = "$configdir/loglevel";
$TraceLevel = $self->_config_from_file($configfile,'loglevel');
unless (defined($TraceLevel) and $TraceLevel =~ /^\d+$/) {
$TraceLevel = LOGWARN; # Default if no loglevel file found.
}
$LOGGING_LOADED = 1;
return @loggers;
}
sub trace_level {
my $self = shift;
return $TraceLevel;
}
sub init_logger { # needed for compatibility purposes
shift->trace_level();
}
sub log {
my ($self, $trace, @log) = @_;
$self->varlog($trace,join(" ",@log));
}
sub varlog {
my ($self, $trace) = (shift,shift);
my ($hook, $plugin, @log);
if ( $#_ == 0 ) { # log itself
(@log) = @_;
}
elsif ( $#_ == 1 ) { # plus the hook
($hook, @log) = @_;
}
else { # called from plugin
($hook, $plugin, @log) = @_;
}
$self->load_logging; # in case we don't have this loaded yet
my ($rc) = $self->run_hooks_no_respond("logging", $trace, $hook, $plugin, @log)
or return;
return if $rc == DECLINED || $rc == OK; # plugin success
return if $trace > $TraceLevel;
# no logging plugins registered, fall back to STDERR
my $prefix = defined $plugin && defined $hook ? " ($hook) $plugin:" :
defined $plugin ? " $plugin:" :
defined $hook ? " ($hook) running plugin:" : '';
warn join(' ', $$ . $prefix, @log), "\n";
}
sub clear_config_cache {
$_config_cache = {};
}
#
# method to get the configuration. It just calls get_qmail_config by
# default, but it could be overwritten to look configuration up in a
# database or whatever.
#
sub config {
my ($self, $c, $type) = @_;
$self->log(LOGDEBUG, "in config($c)");
# first try the cache
# XXX - is this always the right thing to do? what if a config hook
# can return different values on subsequent calls?
if ($_config_cache->{$c}) {
$self->log(LOGDEBUG, "config($c) returning (@{$_config_cache->{$c}}) from cache");
return wantarray ? @{$_config_cache->{$c}} : $_config_cache->{$c}->[0];
}
# then run the hooks
my ($rc, @config) = $self->run_hooks_no_respond("config", $c);
$self->log(LOGDEBUG, "config($c): hook returned ($rc, @config) ");
if ($rc == OK) {
$self->log(LOGDEBUG, "setting _config_cache for $c to [@config] from hooks and returning it");
$_config_cache->{$c} = \@config;
return wantarray ? @{$_config_cache->{$c}} : $_config_cache->{$c}->[0];
}
# and then get_qmail_config
@config = $self->get_qmail_config($c, $type);
if (@config) {
$self->log(LOGDEBUG, "setting _config_cache for $c to [@config] from get_qmail_config and returning it");
$_config_cache->{$c} = \@config;
return wantarray ? @{$_config_cache->{$c}} : $_config_cache->{$c}->[0];
}
# finally we use the default if there is any:
if (exists($defaults{$c})) {
$self->log(LOGDEBUG, "setting _config_cache for $c to @{[$defaults{$c}]} from defaults and returning it");
$_config_cache->{$c} = [$defaults{$c}];
return wantarray ? @{$_config_cache->{$c}} : $_config_cache->{$c}->[0];
}
return;
}
sub config_dir {
my ($self, $config) = @_;
if (exists $config_dir_memo{$config}) {
return $config_dir_memo{$config};
}
my $configdir = ($ENV{QMAIL} || '/var/qmail') . '/control';
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";
}
return $config_dir_memo{$config} = $configdir;
}
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 {
my ($self, $config, $type) = @_;
$self->log(LOGDEBUG, "trying to get config for $config");
my $configdir = $self->config_dir($config);
my $configfile = "$configdir/$config";
# CDB config support really should be moved to a plugin
if ($type and $type eq "map") {
unless (-e $configfile . ".cdb") {
$_config_cache->{$config} ||= [];
return +{};
}
eval { require CDB_File };
if ($@) {
$self->log(LOGERROR, "No CDB Support! Did NOT read $configfile.cdb, could not load CDB_File module: $@");
return +{};
}
my %h;
unless (tie(%h, 'CDB_File', "$configfile.cdb")) {
$self->log(LOGERROR, "tie of $configfile.cdb failed: $!");
return +{};
}
# We explicitly don't cache cdb entries. The assumption is that
# the data is in a CDB file in the first place because there's
# lots of data and the cache hit ratio would be low.
return \%h;
}
return $self->_config_from_file($configfile, $config);
}
sub _config_from_file {
my ($self, $configfile, $config, $visited) = @_;
unless (-e $configfile) {
$_config_cache->{$config} ||= [];
return;
}
$visited ||= [];
push @{$visited}, $configfile;
open CF, "<$configfile" or warn "$$ could not open configfile $configfile: $!" and return;
my @config = <CF>;
chomp @config;
@config = grep { length($_) and $_ !~ m/^\s*#/ and $_ =~ m/\S/}
map {s/^\s+//; s/\s+$//; $_;} # trim leading/trailing whitespace
@config;
close CF;
my $pos = 0;
while ($pos < @config) {
# recursively pursue an $include reference, if found. An inclusion which
# begins with a leading slash is interpreted as a path to a file and will
# supercede the usual config path resolution. Otherwise, the normal
# config_dir() lookup is employed (the location in which the inclusion
# appeared receives no special precedence; possibly it should, but it'd
# be complicated beyond justifiability for so simple a config system.
if ($config[$pos] =~ /^\s*\$include\s+(\S+)\s*$/) {
my ($includedir, $inclusion) = ('', $1);
splice @config, $pos, 1; # remove the $include line
if ($inclusion !~ /^\//) {
$includedir = $self->config_dir($inclusion);
$inclusion = "$includedir/$inclusion";
}
if (grep($_ eq $inclusion, @{$visited})) {
$self->log(LOGERROR, "Circular \$include reference in config $config:");
$self->log(LOGERROR, "From $visited->[0]:");
$self->log(LOGERROR, " includes $_")
for (@{$visited}[1..$#{$visited}], $inclusion);
return wantarray ? () : undef;
}
push @{$visited}, $inclusion;
for my $inc ($self->expand_inclusion_($inclusion, $configfile)) {
my @insertion = $self->_config_from_file($inc, $config, $visited);
splice @config, $pos, 0, @insertion; # insert the inclusion
$pos += @insertion;
}
} else {
$pos++;
}
}
$_config_cache->{$config} = \@config;
return wantarray ? @config : $config[0];
}
sub expand_inclusion_ {
my $self = shift;
my $inclusion = shift;
my $context = shift;
my @includes;
if (-d $inclusion) {
$self->log(LOGDEBUG, "inclusion of directory $inclusion from $context");
if (opendir(INCD, $inclusion)) {
@includes = map { "$inclusion/$_" }
(grep { -f "$inclusion/$_" and !/^\./ } sort readdir INCD);
closedir INCD;
} else {
$self->log(LOGERROR, "Couldn't open directory $inclusion,".
" referenced from $context ($!)");
}
} else {
$self->log(LOGDEBUG, "inclusion of file $inclusion from $context");
@includes = ( $inclusion );
}
return @includes;
}
sub load_plugins {
my $self = shift;
my @plugins = $self->config('plugins');
my @loaded;
if ($hooks->{queue}) {
#$self->log(LOGWARN, "Plugins already loaded");
return @plugins;
}
for my $plugin_line (@plugins) {
my $this_plugin = $self->_load_plugin($plugin_line, $self->plugin_dirs);
push @loaded, $this_plugin if $this_plugin;
}
return @loaded;
}
sub _load_plugin {
my $self = shift;
my ($plugin_line, @plugin_dirs) = @_;
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
# Escape everything into valid perl identifiers
$plugin_name =~ s/([^A-Za-z0-9_\/])/sprintf("_%2x",unpack("C",$1))/eg;
# second pass cares for slashes and words starting with a digit
$plugin_name =~ s{
(/+) # directory
(\d?) # package's first character
}[
"::" . (length $2 ? sprintf("_%2x",unpack("C",$2)) : "")
]egx;
$package = "Qpsmtpd::Plugin::$plugin_name";
# don't reload plugins if they are already loaded
unless ( defined &{"${package}::plugin_name"} ) {
PLUGIN_DIR: for my $dir (@plugin_dirs) {
if (-e "$dir/$plugin") {
Qpsmtpd::Plugin->compile($plugin_name, $package,
"$dir/$plugin", $self->{_test_mode}, $plugin);
$self->log(LOGDEBUG, "Loading $plugin_line from $dir/$plugin")
unless $plugin_line =~ /logging/;
last PLUGIN_DIR;
}
}
die "Plugin $plugin_name not found in our plugin dirs (",
join(", ", @plugin_dirs),")"
unless defined &{"${package}::plugin_name"};
}
}
my $plug = $package->new();
$plug->_register($self, @args);
return $plug;
}
sub transaction { return {}; } # base class implements empty transaction
sub run_hooks {
my ($self, $hook) = (shift, shift);
if ($hooks->{$hook}) {
my @r;
my @local_hooks = @{$hooks->{$hook}};
$self->{_continuation} = [$hook, [@_], @local_hooks];
return $self->run_continuation();
}
return $self->hook_responder($hook, [0, ''], [@_]);
}
sub run_hooks_no_respond {
my ($self, $hook) = (shift, shift);
if ($hooks->{$hook}) {
my @r;
for my $code (@{$hooks->{$hook}}) {
eval { (@r) = $code->{code}->($self, $self->transaction, @_); };
$@ and warn("FATAL PLUGIN ERROR [" . $code->{name} . "]: ", $@) and next;
if ($r[0] == YIELD) {
die "YIELD not valid from $hook hook";
}
last unless $r[0] == DECLINED;
}
$r[0] = DECLINED if not defined $r[0];
return @r;
}
return (0, '');
}
sub continue_read {} # subclassed in -async
sub pause_read { die "Continuations only work in qpsmtpd-async" }
sub run_continuation {
my $self = shift;
#my $t1 = $SAMPLER->("run_hooks", undef, 1);
die "No continuation in progress" unless $self->{_continuation};
$self->continue_read();
my $todo = $self->{_continuation};
$self->{_continuation} = undef;
my $hook = shift @$todo || die "No hook in the continuation";
my $args = shift @$todo || die "No hook args in the continuation";
my @r;
while (@$todo) {
my $code = shift @$todo;
#my $t2 = $SAMPLER->($hook . "_" . $code->{name}, undef, 1);
#warn("Got sampler called: ${hook}_$code->{name}\n");
$self->varlog(LOGDEBUG, $hook, $code->{name});
my $tran = $self->transaction;
eval { (@r) = $code->{code}->($self, $tran, @$args); };
$@ and $self->log(LOGCRIT, "FATAL PLUGIN ERROR [" . $code->{name} . "]: ", $@) and next;
!defined $r[0]
and $self->log(LOGERROR, "plugin ".$code->{name}
." running the $hook hook returned undef!")
and next;
# note this is wrong as $tran is always true in the
# current code...
if ($tran) {
my $tnotes = $tran->notes( $code->{name} );
$tnotes->{"hook_$hook"}->{'return'} = $r[0]
if (!defined $tnotes || ref $tnotes eq "HASH");
}
else {
my $cnotes = $self->connection->notes( $code->{name} );
$cnotes->{"hook_$hook"}->{'return'} = $r[0]
if (!defined $cnotes || ref $cnotes eq "HASH");
}
if ($r[0] == YIELD) {
$self->pause_read();
$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 ".return_code($r[0]).", $r[1]");
$self->run_hooks_no_respond("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_no_respond("ok", $code->{name}, $r[0], $r[1]) unless ($hook eq "ok");
}
last unless $r[0] == DECLINED;
}
$r[0] = DECLINED if not defined $r[0];
# hook_*_parse() may return a CODE ref..
# ... which breaks when splitting as string:
@r = map { split /\n/ } @r unless (ref($r[1]) eq "CODE");
return $self->hook_responder($hook, \@r, $args);
}
sub hook_responder {
my ($self, $hook, $msg, $args) = @_;
#my $t1 = $SAMPLER->("hook_responder", undef, 1);
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 {
my $self = shift;
my ($hook, $code, $unshift) = @_;
if ($unshift) {
unshift @{$hooks->{$hook}}, $code;
}
else {
push @{$hooks->{$hook}}, $code;
}
}
sub spool_dir {
my $self = shift;
unless ( $Spool_dir ) { # first time through
$self->log(LOGDEBUG, "Initializing spool_dir");
$Spool_dir = $self->config('spool_dir')
|| Qpsmtpd::Utils::tildeexp('~/tmp/');
$Spool_dir .= "/" unless ($Spool_dir =~ m!/$!);
$Spool_dir =~ /^(.+)$/ or die "spool_dir not configured properly";
$Spool_dir = $1; # cleanse the taint
my $Spool_perms = $self->config('spool_perms') || '0700';
if (! -d $Spool_dir) { # create it if it doesn't exist
mkdir($Spool_dir,oct($Spool_perms))
or die "Could not create spool_dir $Spool_dir: $!";
};
# Make sure the spool dir has appropriate rights
$self->log(LOGWARN,
"Permissions on spool_dir $Spool_dir are not $Spool_perms")
unless ((stat $Spool_dir)[2] & 07777) == oct($Spool_perms);
}
return $Spool_dir;
}
# For unique filenames. We write to a local tmp dir so we don't need
# to make them unpredictable.
my $transaction_counter = 0;
sub temp_file {
my $self = shift;
my $filename = $self->spool_dir()
. join(":", time, $$, $transaction_counter++);
return $filename;
}
sub temp_dir {
my $self = shift;
my $mask = shift || 0700;
my $dirname = $self->temp_file();
-d $dirname or mkdir($dirname, $mask)
or die "Could not create temporary directory $dirname: $!";
return $dirname;
}
sub size_threshold {
my $self = shift;
unless ( defined $Size_threshold ) {
$Size_threshold = $self->config('size_threshold') || 0;
$self->log(LOGNOTICE, "size_threshold set to $Size_threshold");
}
return $Size_threshold;
}
sub authenticated {
my $self = shift;
return (defined $self->{_auth} ? $self->{_auth} : "" );
}
sub auth_user {
my $self = shift;
return (defined $self->{_auth_user} ? $self->{_auth_user} : "" );
}
sub auth_mechanism {
my $self = shift;
return (defined $self->{_auth_mechanism} ? $self->{_auth_mechanism} : "" );
}
1;
__END__
=head1 NAME
Qpsmtpd - base class for the qpsmtpd mail server
=head1 DESCRIPTION
This is the base class for the qpsmtpd mail server. See
L<http://smtpd.develooper.com/> and the I<README> file for more information.
=head1 COPYRIGHT
Copyright 2001-2012 Ask Bjørn Hansen, Develooper LLC. See the
LICENSE file for more information.
=cut

362
lib/Qpsmtpd/Address.pm Normal file
View File

@ -0,0 +1,362 @@
#!/usr/bin/perl -w
package Qpsmtpd::Address;
use strict;
=head1 NAME
Qpsmtpd::Address - Lightweight E-Mail address objects
=head1 DESCRIPTION
Based originally on cut and paste from Mail::Address and including
every jot and tittle from RFC-2821/2822 on what is a legal e-mail
address for use during the SMTP transaction.
=head1 USAGE
my $rcpt = Qpsmtpd::Address->new('<email.address@example.com>');
The objects created can be used as is, since they automatically
stringify to a standard form, and they have an overloaded comparison
for easy testing of values.
=head1 METHODS
=cut
use overload (
'""' => \&format,
'cmp' => \&_addr_cmp,
);
=head2 new()
Can be called two ways:
=over 4
=item * Qpsmtpd::Address->new('<full_address@example.com>')
The normal mode of operation is to pass the entire contents of the
RCPT TO: command from the SMTP transaction. The value will be fully
parsed via the L<canonify> method, using the full RFC 2821 rules.
=item * Qpsmtpd::Address->new("user", "host")
If the caller has already split the address from the domain/host,
this mode will not L<canonify> the input values. This is not
recommended in cases of user-generated input for that reason. This
can be used to generate Qpsmtpd::Address objects for accounts like
"<postmaster>" or indeed for the bounce address "<>".
=back
The resulting objects can be stored in arrays or used in plugins to
test for equality (like in badmailfrom).
=cut
sub new {
my ($class, $user, $host) = @_;
my $self = {};
if ($user =~ /^<(.*)>$/ ) {
($user, $host) = $class->canonify($user);
return undef unless defined $user;
}
elsif ( not defined $host ) {
my $address = $user;
($user, $host) = $address =~ m/(.*)(?:\@(.*))/;
}
$self->{_user} = $user;
$self->{_host} = $host;
return bless $self, $class;
}
# Definition of an address ("path") from RFC 2821:
#
# Path = "<" [ A-d-l ":" ] Mailbox ">"
#
# A-d-l = At-domain *( "," A-d-l )
# ; Note that this form, the so-called "source route",
# ; MUST BE accepted, SHOULD NOT be generated, and SHOULD be
# ; ignored.
#
# At-domain = "@" domain
#
# Mailbox = Local-part "@" Domain
#
# Local-part = Dot-string / Quoted-string
# ; MAY be case-sensitive
#
# Dot-string = Atom *("." Atom)
#
# Atom = 1*atext
#
# Quoted-string = DQUOTE *qcontent DQUOTE
#
# Domain = (sub-domain 1*("." sub-domain)) / address-literal
# sub-domain = Let-dig [Ldh-str]
#
# address-literal = "[" IPv4-address-literal /
# IPv6-address-literal /
# General-address-literal "]"
#
# IPv4-address-literal = Snum 3("." Snum)
# IPv6-address-literal = "IPv6:" IPv6-addr
# General-address-literal = Standardized-tag ":" 1*dcontent
# Standardized-tag = Ldh-str
# ; MUST be specified in a standards-track RFC
# ; and registered with IANA
#
# Snum = 1*3DIGIT ; representing a decimal integer
# ; value in the range 0 through 255
# Let-dig = ALPHA / DIGIT
# Ldh-str = *( ALPHA / DIGIT / "-" ) Let-dig
#
# IPv6-addr = IPv6-full / IPv6-comp / IPv6v4-full / IPv6v4-comp
# IPv6-hex = 1*4HEXDIG
# IPv6-full = IPv6-hex 7(":" IPv6-hex)
# IPv6-comp = [IPv6-hex *5(":" IPv6-hex)] "::" [IPv6-hex *5(":"
# IPv6-hex)]
# ; The "::" represents at least 2 16-bit groups of zeros
# ; No more than 6 groups in addition to the "::" may be
# ; present
# IPv6v4-full = IPv6-hex 5(":" IPv6-hex) ":" IPv4-address-literal
# IPv6v4-comp = [IPv6-hex *3(":" IPv6-hex)] "::"
# [IPv6-hex *3(":" IPv6-hex) ":"] IPv4-address-literal
# ; The "::" represents at least 2 16-bit groups of zeros
# ; No more than 4 groups in addition to the "::" and
# ; IPv4-address-literal may be present
#
#
#
# atext and qcontent are not defined in RFC 2821.
# From RFC 2822:
#
# atext = ALPHA / DIGIT / ; Any character except controls,
# "!" / "#" / ; SP, and specials.
# "$" / "%" / ; Used for atoms
# "&" / "'" /
# "*" / "+" /
# "-" / "/" /
# "=" / "?" /
# "^" / "_" /
# "`" / "{" /
# "|" / "}" /
# "~"
# qtext = NO-WS-CTL / ; Non white space controls
#
# %d33 / ; The rest of the US-ASCII
# %d35-91 / ; characters not including "\"
# %d93-126 ; or the quote character
#
# qcontent = qtext / quoted-pair
#
# NO-WS-CTL = %d1-8 / ; US-ASCII control characters
# %d11 / ; that do not include the
# %d12 / ; carriage return, line feed,
# %d14-31 / ; and white space characters
# %d127
#
# quoted-pair = ("\" text) / obs-qp
#
# text = %d1-9 / ; Characters excluding CR and LF
# %d11 /
# %d12 /
# %d14-127 /
# obs-text
#
#
# (We ignore all obs forms)
=head2 canonify()
Primarily an internal method, it is used only on the path portion of
an e-mail message, as defined in RFC-2821 (this is the part inside the
angle brackets and does not include the "human readable" portion of an
address). It returns a list of (local-part, domain).
=cut
# address components are defined as package variables so that they can
# be overriden (in hook_pre_connection, for example) if people have
# different needs.
our $atom_expr = '[a-zA-Z0-9!#%&*+=?^_`{|}~\$\x27\x2D\/]+';
our $address_literal_expr =
'(?:\[(?:\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}|IPv6:[0-9A-Fa-f:.]+)\])';
our $subdomain_expr = '(?:[a-zA-Z0-9](?:[-a-zA-Z0-9]*[a-zA-Z0-9])?)';
our $domain_expr;
our $qtext_expr = '[\x01-\x08\x0B\x0C\x0E-\x1F\x21\x23-\x5B\x5D-\x7F]';
our $text_expr = '[\x01-\x09\x0B\x0C\x0E-\x7F]';
sub canonify {
my ($dummy, $path) = @_;
# strip delimiters
return undef unless ($path =~ /^<(.*)>$/);
$path = $1;
my $domain = $domain_expr ? $domain_expr
: "$subdomain_expr(?:\.$subdomain_expr)*";
# it is possible for $address_literal_expr to be empty, if a site
# doesn't want to allow them
$domain = "(?:$address_literal_expr|$domain)"
if !$domain_expr and $address_literal_expr;
# strip source route
$path =~ s/^\@$domain(?:,\@$domain)*://;
# empty path is ok
return "" if $path eq "";
# bare postmaster is permissible, perl RFC-2821 (4.5.1)
return ("postmaster", undef) if $path =~ m/^postmaster$/i;
my ($localpart, $domainpart) = ($path =~ /^(.*)\@($domain)$/);
return (undef) unless defined $localpart;
if ($localpart =~ /^$atom_expr(\.$atom_expr)*/) {
# simple case, we are done
return ($localpart, $domainpart);
}
if ($localpart =~ /^"(($qtext_expr|\\$text_expr)*)"$/) {
$localpart = $1;
$localpart =~ s/\\($text_expr)/$1/g;
return ($localpart, $domainpart);
}
return (undef);
}
=head2 parse()
Retained as a compatibility method, it is completely equivalent
to new() called with a single parameter.
=cut
sub parse { # retain for compatibility only
return shift->new(shift);
}
=head2 address()
Can be used to reset the value of an existing Q::A object, in which
case it takes a parameter with or without the angle brackets.
Returns the stringified representation of the address. NOTE: does
not escape any of the characters that need escaping, nor does it
include the surrounding angle brackets. For that purpose, see
L<format>.
=cut
sub address {
my ($self, $val) = @_;
if ( defined($val) ) {
$val = "<$val>" unless $val =~ /^<.+>$/;
my ($user, $host) = $self->canonify($val);
$self->{_user} = $user;
$self->{_host} = $host;
}
return ( defined $self->{_user} ? $self->{_user} : '' )
. ( defined $self->{_host} ? '@'.$self->{_host} : '' );
}
=head2 format()
Returns the canonical stringified representation of the address. It
does escape any characters requiring it (per RFC-2821/2822) and it
does include the surrounding angle brackets. It is also the default
stringification operator, so the following are equivalent:
print $rcpt->format();
print $rcpt;
=cut
sub format {
my ($self) = @_;
my $qchar = '[^a-zA-Z0-9!#\$\%\&\x27\*\+\x2D\/=\?\^_`{\|}~.]';
return '<>' unless defined $self->{_user};
if ( ( my $user = $self->{_user}) =~ s/($qchar)/\\$1/g) {
return qq(<"$user")
. ( defined $self->{_host} ? '@'.$self->{_host} : '' ). ">";
}
return "<".$self->address().">";
}
=head2 user([$user])
Returns the "localpart" of the address, per RFC-2821, or the portion
before the '@' sign.
If called with one parameter, the localpart is set and the new value is
returned.
=cut
sub user {
my ($self, $user) = @_;
$self->{_user} = $user if defined $user;
return $self->{_user};
}
=head2 host([$host])
Returns the "domain" part of the address, per RFC-2821, or the portion
after the '@' sign.
If called with one parameter, the domain is set and the new value is
returned.
=cut
sub host {
my ($self, $host) = @_;
$self->{_host} = $host if defined $host;
return $self->{_host};
}
=head2 notes($key[,$value])
Get or set a note on the address. This is a piece of data that you wish
to attach to the address and read somewhere else. For example you can
use this to pass data between plugins.
=cut
sub notes {
my ($self,$key) = (shift,shift);
# Check for any additional arguments passed by the caller -- including undef
return $self->{_notes}->{$key} unless @_;
return $self->{_notes}->{$key} = shift;
}
sub _addr_cmp {
require UNIVERSAL;
my ($left, $right, $swap) = @_;
my $class = ref($left);
unless ( UNIVERSAL::isa($right, $class) ) {
$right = $class->new($right);
}
#invert the address so we can sort by domain then user
($left = join( '=', reverse( split('@', $left->format))) ) =~ tr/[<>]//d;
($right = join( '=', reverse( split('@',$right->format))) ) =~ tr/[<>]//d;
if ( $swap ) {
($right, $left) = ($left, $right);
}
return ($left cmp $right);
}
=head1 COPYRIGHT
Copyright 2004-2005 Peter J. Holzer. See the LICENSE file for more
information.
=cut
1;

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

@ -0,0 +1,223 @@
package Qpsmtpd::Auth;
# See the documentation in 'perldoc docs/authentication.pod'
use strict;
use warnings;
use Qpsmtpd::Constants;
use Digest::HMAC_MD5 qw(hmac_md5_hex);
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' ) {
($loginas, $user, $passClear) = get_auth_details_plain($session,$prekey);
return DECLINED if ! $user || ! $passClear;
}
elsif ( $mechanism eq 'login' ) {
($user, $passClear) = get_auth_details_login($session,$prekey);
return DECLINED if ! $user || ! $passClear;
}
elsif ( $mechanism eq 'cram-md5' ) {
( $ticket, $user, $passHash ) = get_auth_details_cram_md5($session);
return DECLINED if ! $user || ! $passHash;
}
else {
#this error is now caught in SMTP.pm's sub auth
$session->respond( 500, "Internal server error" );
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 = uc($mechanism) . " authentication successful for $user" .
( $msg ? " - $msg" : '');
$session->respond( 235, $msg );
$session->connection->relay_client(1);
if ( $session->connection->notes('naughty' ) ) {
$session->log( LOGINFO, "auth success cleared naughty" );
$session->connection->notes('naughty',0);
};
$session->log( LOGDEBUG, $msg ); # already logged by $session->respond
$session->{_auth_user} = $user;
$session->{_auth_mechanism} = $mechanism;
s/[\r\n].*//s for ($session->{_auth_user}, $session->{_auth_mechanism});
return OK;
}
else {
$msg = uc($mechanism) . " authentication failed for $user" .
( $msg ? " - $msg" : '');
$session->respond( 535, $msg );
$session->log( LOGDEBUG, $msg ); # already logged by $session->respond
return DENY;
}
}
sub get_auth_details_plain {
my ( $session, $prekey ) = @_;
if ( ! $prekey) {
$session->respond( 334, ' ' );
$prekey= <STDIN>;
}
my ( $loginas, $user, $passClear ) = split /\x0/, decode_base64($prekey);
if ( ! $user ) {
if ( $loginas ) {
$session->respond(535, "Authentication invalid ($loginas)");
}
else {
$session->respond(535, "Authentication invalid");
}
return;
};
# Authorization ID must not be different from Authentication ID
if ( $loginas ne '' && $loginas ne $user ) {
$session->respond(535, "Authentication invalid for $user");
return;
}
return ($loginas, $user, $passClear);
};
sub get_auth_details_login {
my ( $session, $prekey ) = @_;
my $user;
if ( $prekey ) {
$user = decode_base64($prekey);
}
else {
$user = get_base64_response($session,'Username:') or return;
}
my $passClear = get_base64_response($session,'Password:') or return;
return ($user, $passClear);
};
sub get_auth_details_cram_md5 {
my ( $session, $ticket ) = @_;
if ( ! $ticket ) { # ticket is only passed in during testing
# 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.
$ticket = sprintf( '<%x.%x@%s>',
rand(1000000), time(), $session->config('me') );
};
# send the base64 encoded ticket
$session->respond( 334, encode_base64( $ticket, '' ) );
my $line = <STDIN>;
if ( $line eq '*' ) {
$session->respond( 501, "Authentication canceled" );
return;
};
my ( $user, $passHash ) = split( ' ', decode_base64($line) );
unless ( $user && $passHash ) {
$session->respond(504, "Invalid authentication string");
return;
}
$session->{auth}{ticket} = $ticket;
return ($ticket, $user, $passHash);
};
sub get_base64_response {
my ($session, $question) = @_;
$session->respond(334, e64($question));
my $answer = decode_base64( <STDIN> );
if ($answer eq '*') {
$session->respond(501, "Authentication canceled");
return;
}
return $answer;
};
sub validate_password {
my ( $self, %a ) = @_;
my ($pkg, $file, $line) = caller();
$file = (split '/', $file)[-1]; # strip off the path
my $src_clear = $a{src_clear};
my $src_crypt = $a{src_crypt};
my $attempt_clear = $a{attempt_clear};
my $attempt_hash = $a{attempt_hash};
my $method = $a{method} or die "missing method";
my $ticket = $a{ticket} || $self->{auth}{ticket};
my $deny = $a{deny} || DENY;
if ( ! $src_crypt && ! $src_clear ) {
$self->log(LOGINFO, "fail: missing password");
return ( $deny, "$file - no such user" );
};
if ( ! $src_clear && $method =~ /CRAM-MD5/i ) {
$self->log(LOGINFO, "skip: cram-md5 not supported w/o clear pass");
return ( DECLINED, $file );
}
if ( defined $attempt_clear ) {
if ( $src_clear && $src_clear eq $attempt_clear ) {
$self->log(LOGINFO, "pass: clear match");
return ( OK, $file );
};
if ( $src_crypt && $src_crypt eq crypt( $attempt_clear, $src_crypt ) ) {
$self->log(LOGINFO, "pass: crypt match");
return ( OK, $file );
}
};
if ( defined $attempt_hash && $src_clear ) {
if ( ! $ticket ) {
$self->log(LOGERROR, "skip: missing ticket");
return ( DECLINED, $file );
};
if ( $attempt_hash eq hmac_md5_hex( $ticket, $src_clear ) ) {
$self->log(LOGINFO, "pass: hash match");
return ( OK, $file );
};
};
$self->log(LOGINFO, "fail: wrong password");
return ( $deny, "$file - wrong password" );
};
# tag: qpsmtpd plugin that sets RELAYCLIENT when the user authenticates
1;

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

@ -0,0 +1,171 @@
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 strict;
use Qpsmtpd::Constants;
use vars qw(@ISA);
@ISA = qw(Qpsmtpd::SMTP);
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;

287
lib/Qpsmtpd/ConfigServer.pm Normal file
View File

@ -0,0 +1,287 @@
package Qpsmtpd::ConfigServer;
use base ('Danga::Client');
use Qpsmtpd::Constants;
use strict;
use fields qw(
_auth
_commands
_config_cache
_connection
_transaction
_test_mode
_extras
other_fds
);
my $PROMPT = "Enter command: ";
sub new {
my Qpsmtpd::ConfigServer $self = shift;
$self = fields::new($self) unless ref $self;
$self->SUPER::new( @_ );
$self->write($PROMPT);
return $self;
}
sub max_idle_time { 3600 } # one hour
sub process_line {
my $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: $pkg, $file, $line";
};
my $prev = alarm(2); # must process a command in < 2 seconds
my $resp = eval { $self->_process_line($line) };
alarm($prev);
if ($@) {
print STDERR "Error: $@\n";
}
return $resp || '';
}
sub respond {
my $self = shift;
my (@messages) = @_;
while (my $msg = shift @messages) {
$self->write("$msg\r\n");
}
return;
}
sub fault {
my $self = shift;
my ($msg) = shift || "program fault - command not performed";
print STDERR "$0 [$$]: $msg ($!)\n";
$self->respond("Error - " . $msg);
return $PROMPT;
}
sub _process_line {
my $self = shift;
my $line = shift;
$line =~ s/\r?\n//;
my ($cmd, @params) = split(/ +/, $line);
my $meth = "cmd_" . lc($cmd);
if (my $lookup = $self->can($meth)) {
my $resp = eval {
$lookup->($self, @params);
};
if ($@) {
my $error = $@;
chomp($error);
Qpsmtpd->log(LOGERROR, "Command Error: $error");
return $self->fault("command '$cmd' failed unexpectedly");
}
return "$resp\n$PROMPT";
}
else {
# No such method - i.e. unrecognized command
return $self->fault("command '$cmd' unrecognised");
}
}
my %helptext = (
help => "HELP [CMD] - Get help on all commands or a specific command",
status => "STATUS - Returns status information about current connections",
list => "LIST [LIMIT] - List the connections, specify limit or negative limit to shrink list",
kill => "KILL (\$IP | \$REF) - Disconnect all connections from \$IP or connection reference \$REF",
pause => "PAUSE - Stop accepting new connections",
continue => "CONTINUE - Resume accepting connections",
reload => "RELOAD - Reload all plugins and config",
quit => "QUIT - Exit the config server",
);
sub cmd_help {
my $self = shift;
my ($subcmd) = @_;
$subcmd ||= 'help';
$subcmd = lc($subcmd);
if ($subcmd eq 'help') {
my $txt = join("\n", map { substr($_, 0, index($_, "-")) } sort values(%helptext));
return "Available Commands:\n\n$txt\n";
}
my $txt = $helptext{$subcmd} || "Unrecognised help option. Try 'help' for a full list.";
return "$txt\n";
}
sub cmd_quit {
my $self = shift;
$self->close;
}
sub cmd_shutdown {
exit;
}
sub cmd_pause {
my $self = shift;
my $other_fds = $self->OtherFds;
$self->{other_fds} = { %$other_fds };
%$other_fds = ();
return "PAUSED";
}
sub cmd_continue {
my $self = shift;
my $other_fds = $self->{other_fds};
$self->OtherFds( %$other_fds );
%$other_fds = ();
return "UNPAUSED";
}
sub cmd_status {
my $self = shift;
# Status should show:
# - Total time running
# - Total number of mails received
# - Total number of mails rejected (5xx)
# - Total number of mails tempfailed (5xx)
# - Avg number of mails/minute
# - Number of current connections
# - Number of outstanding DNS queries
my $output = "Current Status as of " . gmtime() . " GMT\n\n";
if (defined &Qpsmtpd::Plugin::stats::get_stats) {
# Stats plugin is loaded
$output .= Qpsmtpd::Plugin::stats->get_stats;
}
my $descriptors = Danga::Socket->DescriptorMap;
my $current_connections = 0;
my $current_dns = 0;
foreach my $fd (keys %$descriptors) {
my $pob = $descriptors->{$fd};
if ($pob->isa("Qpsmtpd::PollServer")) {
$current_connections++;
}
elsif ($pob->isa("ParaDNS::Resolver")) {
$current_dns = $pob->pending;
}
}
$output .= "Curr Connections: $current_connections / $::MAXconn\n".
"Curr DNS Queries: $current_dns";
return $output;
}
sub cmd_list {
my $self = shift;
my ($count) = @_;
my $descriptors = Danga::Socket->DescriptorMap;
my $list = "Current" . ($count ? (($count > 0) ? " Oldest $count" : " Newest ".-$count) : "") . " Connections: \n\n";
my @all;
foreach my $fd (keys %$descriptors) {
my $pob = $descriptors->{$fd};
if ($pob->isa("Qpsmtpd::PollServer")) {
next unless $pob->connection->remote_ip; # haven't even started yet
push @all, [$pob+0, $pob->connection->remote_ip,
$pob->connection->remote_host, $pob->uptime];
}
}
@all = sort { $a->[3] <=> $b->[3] } @all;
if ($count) {
if ($count > 0) {
@all = @all[$#all-($count-1) .. $#all];
}
else {
@all = @all[0..(abs($count) - 1)];
}
}
foreach my $item (@all) {
$list .= sprintf("%x : %s [%s] Connected %0.2fs\n", map { defined()?$_:'' } @$item);
}
return $list;
}
sub cmd_kill {
my $self = shift;
my ($match) = @_;
return "SYNTAX: KILL (\$IP | \$REF)\n" unless $match;
my $descriptors = Danga::Socket->DescriptorMap;
my $killed = 0;
my $is_ip = (index($match, '.') >= 0);
foreach my $fd (keys %$descriptors) {
my $pob = $descriptors->{$fd};
if ($pob->isa("Qpsmtpd::PollServer")) {
if ($is_ip) {
next unless $pob->connection->remote_ip; # haven't even started yet
if ($pob->connection->remote_ip eq $match) {
$pob->write("550 Your connection has been killed by an administrator\r\n");
$pob->disconnect;
$killed++;
}
}
else {
# match by ID
if ($pob+0 == hex($match)) {
$pob->write("550 Your connection has been killed by an administrator\r\n");
$pob->disconnect;
$killed++;
}
}
}
}
return "Killed $killed connection" . ($killed > 1 ? "s" : "") . "\n";
}
sub cmd_dump {
my $self = shift;
my ($ref) = @_;
return "SYNTAX: DUMP \$REF\n" unless $ref;
require Data::Dumper;
$Data::Dumper::Indent=1;
my $descriptors = Danga::Socket->DescriptorMap;
foreach my $fd (keys %$descriptors) {
my $pob = $descriptors->{$fd};
if ($pob->isa("Qpsmtpd::PollServer")) {
if ($pob+0 == hex($ref)) {
return Data::Dumper::Dumper($pob);
}
}
}
return "Unable to find the connection: $ref. Try the LIST command\n";
}
1;
__END__
=head1 NAME
Qpsmtpd::ConfigServer - a configuration server for qpsmtpd
=head1 DESCRIPTION
When qpsmtpd runs in multiplex mode it also provides a config server that you
can connect to. This allows you to view current connection statistics and other
gumph that you probably don't care about.
=cut

228
lib/Qpsmtpd/Connection.pm Normal file
View File

@ -0,0 +1,228 @@
package Qpsmtpd::Connection;
use strict;
# All of these parameters depend only on the physical connection,
# i.e. not on anything sent from the remote machine. Hence, they
# are an appropriate set to use for either start() or clone(). Do
# not add parameters here unless they also meet that criteria.
my @parameters = qw(
remote_host
remote_ip
remote_info
remote_port
local_ip
local_port
relay_client
);
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my $self = {};
bless ($self, $class);
}
sub start {
my $self = shift;
$self = $self->new(@_) unless ref $self;
my %args = @_;
foreach my $f ( @parameters ) {
$self->$f($args{$f}) if $args{$f};
}
return $self;
}
sub clone {
my $self = shift;
my %args = @_;
my $new = $self->new();
foreach my $f ( @parameters ) {
$new->$f($self->$f()) if $self->$f();
}
$new->{_notes} = $self->{_notes} if defined $self->{_notes};
# reset the old connection object like it's done at the end of a connection
# to prevent leaks (like prefork/tls problem with the old SSL file handle
# still around)
$self->reset unless $args{no_reset};
# should we generate a new id here?
return $new;
}
sub remote_host {
my $self = shift;
@_ and $self->{_remote_host} = shift;
$self->{_remote_host};
}
sub remote_ip {
my $self = shift;
@_ and $self->{_remote_ip} = shift;
$self->{_remote_ip};
}
sub remote_port {
my $self = shift;
@_ and $self->{_remote_port} = shift;
$self->{_remote_port};
}
sub local_ip {
my $self = shift;
@_ and $self->{_local_ip} = shift;
$self->{_local_ip};
}
sub local_port {
my $self = shift;
@_ and $self->{_local_port} = shift;
$self->{_local_port};
}
sub remote_info {
my $self = shift;
@_ and $self->{_remote_info} = shift;
$self->{_remote_info};
}
sub relay_client {
my $self = shift;
@_ and $self->{_relay_client} = shift;
$self->{_relay_client};
}
sub hello {
my $self = shift;
@_ and $self->{_hello} = shift;
$self->{_hello};
}
sub hello_host {
my $self = shift;
@_ and $self->{_hello_host} = shift;
$self->{_hello_host};
}
sub notes {
my ($self,$key) = (shift,shift);
# Check for any additional arguments passed by the caller -- including undef
return $self->{_notes}->{$key} unless @_;
return $self->{_notes}->{$key} = shift;
}
sub reset {
my $self = shift;
$self->{_notes} = undef;
$self = $self->new;
}
1;
__END__
=head1 NAME
Qpsmtpd::Connection - A single SMTP connection
=head1 SYNOPSIS
my $rdns = $qp->connection->remote_host;
my $ip = $qp->connection->remote_ip;
=head1 DESCRIPTION
This class contains details about an individual SMTP connection. A
connection lasts the lifetime of a TCP connection to the SMTP server.
See also L<Qpsmtpd::Transaction> which is a class containing details
about an individual SMTP transaction. A transaction lasts from
C<MAIL FROM> to the end of the C<DATA> marker, or a C<RSET> command,
whichever comes first, whereas a connection lasts until the client
disconnects.
=head1 API
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.
=head2 remote_ip( )
The remote IP address of the connecting host.
=head2 remote_port( )
The remote port.
=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
greeted your server.
NOTE: This field is empty during the helo or ehlo hooks, it is only
set after a successful return from those hooks.
=head2 hello_host( )
The host name specified in the C<HELO> or C<EHLO> command.
NOTE: This field is empty during the helo or ehlo hooks, it is only
set after a successful return from those hooks.
=head2 notes($key [, $value])
Get or set a note on the connection. This is a piece of data that you wish
to attach to the connection and read somewhere else. For example you can
use this to pass data between plugins.
=head2 clone([%args])
Returns a copy of the Qpsmtpd::Connection object. The optional args parameter
may contain:
=over 4
=item no_reset (1|0)
If true, do not reset the original connection object, the author has to care
about that: only the cloned connection object is reset at the end of the
connection
=back
=cut
=head2 relay_client( )
True if the client is allowed to relay messages.
=cut

110
lib/Qpsmtpd/Constants.pm Normal file
View File

@ -0,0 +1,110 @@
package Qpsmtpd::Constants;
use strict;
require Exporter;
# log levels
my %log_levels = (
LOGDEBUG => 7,
LOGINFO => 6,
LOGNOTICE => 5,
LOGWARN => 4,
LOGERROR => 3,
LOGCRIT => 2,
LOGALERT => 1,
LOGEMERG => 0,
LOGRADAR => 0,
);
# return codes
my %return_codes = (
OK => 900,
DENY => 901, # 550
DENYSOFT => 902, # 450
DENYHARD => 903, # 550 + disconnect (deprecated in 0.29)
DENY_DISCONNECT => 903, # 550 + disconnect
DENYSOFT_DISCONNECT => 904, # 450 + disconnect
DECLINED => 909,
DONE => 910,
CONTINUATION => 911, # deprecated - use YIELD
YIELD => 911,
);
use vars qw(@ISA @EXPORT);
@ISA = qw(Exporter);
@EXPORT = (keys(%return_codes), keys(%log_levels), "return_code", "log_level");
foreach (keys %return_codes ) {
eval "use constant $_ => ".$return_codes{$_};
}
foreach (keys %log_levels ) {
eval "use constant $_ => ".$log_levels{$_};
}
sub return_code {
my $test = shift;
if ( $test =~ /^\d+$/ ) { # need to return the textural form
foreach ( keys %return_codes ) {
return $_ if $return_codes{$_} =~ /$test/;
}
}
else { # just return the numeric value
return $return_codes{$test};
}
}
sub log_level {
my $test = shift;
if ( $test =~ /^\d+$/ ) { # need to return the textural form
foreach ( keys %log_levels ) {
return $_ if $log_levels{$_} =~ /$test/;
}
}
else { # just return the numeric value
return $log_levels{$test};
}
}
1;
=head1 NAME
Qpsmtpd::Constants - Constants for plugins to use
=head1 CONSTANTS
See L<README.plugins> for hook specific information on applicable
constants.
Constants available:
=over 4
=item C<OK>
Return this only from the queue phase to indicate the mail was queued
successfully.
=item C<DENY>
Returning this from a hook causes a 5xx error (hard failure) to be
returned to the connecting client.
=item C<DENYSOFT>
Returning this from a hook causes a 4xx error (temporary failure - try
again later) to be returned to the connecting client.
=item C<DECLINED>
Returning this from a hook implies success, but tells qpsmtpd to go
on to the next plugin.
=item C<DONE>
Returning this from a hook implies success, but tells qpsmtpd to
skip any remaining plugins for this phase.
=back
=cut

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

292
lib/Qpsmtpd/Plugin.pm Normal file
View File

@ -0,0 +1,292 @@
package Qpsmtpd::Plugin;
use strict;
use warnings;
use Qpsmtpd::Constants;
# more or less in the order they will fire
our @hooks = qw(
logging config post-fork 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_headers_end data_post queue_pre queue queue_post vrfy noop
quit reset_transaction disconnect post-connection
unrecognized_command deny ok received_line help
);
our %hooks = map { $_ => 1 } @hooks;
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
bless ({}, $class);
}
sub hook_name {
return shift->{_hook};
}
sub register_hook {
my ($plugin, $hook, $method, $unshift) = @_;
die $plugin->plugin_name . " : Invalid hook: $hook" unless $hooks{$hook};
$plugin->{_qp}->log(LOGDEBUG, $plugin->plugin_name, "hooking", $hook)
unless $hook =~ /logging/; # can't log during load_logging()
# 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(@_)
},
name => $plugin->plugin_name,
},
$unshift,
);
}
sub _register {
my $self = shift;
my $qp = shift;
local $self->{_qp} = $qp;
$self->init($qp, @_) if $self->can('init');
$self->_register_standard_hooks($qp, @_);
$self->register($qp, @_) if $self->can('register');
}
sub qp {
shift->{_qp};
}
sub log {
my $self = shift;
return if defined $self->{_hook} && $self->{_hook} eq 'logging';
my $level = $self->adjust_log_level( shift, $self->plugin_name );
$self->{_qp}->varlog($level, $self->{_hook}, $self->plugin_name, @_);
}
sub adjust_log_level {
my ( $self, $cur_level, $plugin_name) = @_;
my $adj = $self->{_args}{loglevel} or return $cur_level;
return $adj if $adj =~ m/^[01234567]$/; # a raw syslog numeral
if ( $adj !~ /^[\+\-][\d]$/ ) {
$self->log( LOGERROR, $self-"invalid $plugin_name loglevel setting ($adj)" );
undef $self->{_args}{loglevel}; # only complain once per plugin
return $cur_level;
};
my $operator = substr($adj, 0, 1);
my $adjust = substr($adj, -1, 1);
my $new_level = $operator eq '+' ? $cur_level + $adjust : $cur_level - $adjust;
$new_level = 7 if $new_level > 7;
$new_level = 0 if $new_level < 0;
return $new_level;
};
sub transaction {
# not sure if this will work in a non-forking or a threaded daemon
shift->qp->transaction;
}
sub connection {
shift->qp->connection;
}
sub spool_dir {
shift->qp->spool_dir;
}
sub auth_user {
shift->qp->auth_user;
}
sub auth_mechanism {
shift->qp->auth_mechanism;
}
sub temp_file {
my $self = shift;
my $tempfile = $self->qp->temp_file;
push @{$self->qp->transaction->{_temp_files}}, $tempfile;
return $tempfile;
}
sub temp_dir {
my $self = shift;
my $tempdir = $self->qp->temp_dir();
push @{$self->qp->transaction->{_temp_dirs}}, $tempdir;
return $tempdir;
}
# plugin inheritance:
# usage:
# sub init {
# my $self = shift;
# $self->isa_plugin("rhsbl");
# $self->SUPER::register(@_);
# }
sub isa_plugin {
my ($self, $parent) = @_;
my ($currentPackage) = caller;
my $cleanParent = $parent;
$cleanParent =~ s/\W/_/g;
my $newPackage = $currentPackage."::_isa_$cleanParent";
# don't reload plugins if they are already loaded
return if defined &{"${newPackage}::plugin_name"};
# find $parent in plugin_dirs
my $parent_dir;
for ($self->qp->plugin_dirs) {
if (-e "$_/$parent") {
$parent_dir = $_;
last;
}
}
die "cannot find plugin '$parent'" unless $parent_dir;
$self->compile($self->plugin_name . "_isa_$cleanParent",
$newPackage,
"$parent_dir/$parent");
warn "---- $newPackage\n";
no strict 'refs';
push @{"${currentPackage}::ISA"}, $newPackage;
}
# why isn't compile private? it's only called from Plugin and Qpsmtpd.
sub compile {
my ($class, $plugin, $package, $file, $test_mode, $orig_name) = @_;
my $sub;
open F, $file or die "could not open $file: $!";
{
local $/ = undef;
$sub = <F>;
}
close F;
my $line = "\n#line 0 $file\n";
if ($test_mode) {
if (open(F, "t/plugin_tests/$orig_name")) {
local $/ = undef;
$sub .= "#line 1 t/plugin_tests/$orig_name\n";
$sub .= <F>;
close F;
}
}
my $eval = join(
"\n",
"package $package;",
'use Qpsmtpd::Constants;',
"require Qpsmtpd::Plugin;",
'use vars qw(@ISA);',
'use strict;',
'@ISA = qw(Qpsmtpd::Plugin);',
($test_mode ? 'use Test::More;' : ''),
"sub plugin_name { qq[$plugin] }",
$line,
$sub,
"\n", # last line comment without newline?
);
#warn "eval: $eval";
$eval =~ m/(.*)/s;
$eval = $1;
eval $eval;
die "eval $@" if $@;
}
sub get_reject {
my $self = shift;
my $message = shift || "why didn't you pass an error message?";
my $log_info = shift || '';
$log_info = ", $log_info" if $log_info;
my $reject = $self->{_args}{reject};
if ( defined $reject && ! $reject ) {
$self->log(LOGINFO, 'fail, reject disabled');
return DECLINED;
};
# the naughty plugin will reject later
if ( $reject eq 'naughty' ) {
$self->log(LOGINFO, 'fail, NAUGHTY');
$self->connection->notes('naughty', $message);
return (DECLINED);
};
# they asked for reject, we give them reject
$self->log(LOGINFO, 'fail'.$log_info);
return ( $self->get_reject_type(), $message);
};
sub get_reject_type {
my $self = shift;
my $default = shift || DENY;
my $deny = $self->{_args}{reject_type} or return $default;
return $deny =~ /^(temp|soft)$/i ? DENYSOFT
: $deny =~ /^(perm|hard)$/i ? DENY
: $deny eq 'disconnect' ? DENY_DISCONNECT
: $deny eq 'temp_disconnect' ? DENYSOFT_DISCONNECT
: $default;
};
sub is_immune {
my $self = shift;
if ( $self->qp->connection->relay_client() ) {
# set by plugins/relay, or Qpsmtpd::Auth
$self->log(LOGINFO, "skip, relay client");
return 1;
};
if ( $self->qp->connection->notes('whitelisthost') ) {
# set by plugins/dns_whitelist_soft or plugins/whitelist
$self->log(LOGINFO, "skip, whitelisted host");
return 1;
};
if ( $self->qp->transaction->notes('whitelistsender') ) {
# set by plugins/whitelist
$self->log(LOGINFO, "skip, whitelisted sender");
return 1;
};
if ( $self->connection->notes('naughty') ) {
# see plugins/naughty
$self->log(LOGINFO, "skip, naughty");
return 1;
};
if ( $self->connection->notes('rejected') ) {
# http://www.steve.org.uk/Software/ms-lite/
$self->log(LOGINFO, "skip, already rejected");
return 1;
};
return;
};
sub _register_standard_hooks {
my ($plugin, $qp) = @_;
for my $hook (@hooks) {
my $hooksub = "hook_$hook";
$hooksub =~ s/\W/_/g;
$plugin->register_hook( $hook, $hooksub )
if ($plugin->can($hooksub));
}
}
1;

87
lib/Qpsmtpd/Plugin/Async/DNSBLBase.pm Normal file
View File

@ -0,0 +1,87 @@
package Qpsmtpd::Plugin::Async::DNSBLBase;
# Class methods shared by the async plugins using DNS based blacklists or
# whitelists.
use strict;
use Qpsmtpd::Constants;
use ParaDNS;
sub lookup {
my ($class, $qp, $A_lookups, $TXT_lookups) = @_;
my $total_zones = @$A_lookups + @$TXT_lookups;
my ($A_pdns, $TXT_pdns);
if (@$A_lookups) {
$qp->log(LOGDEBUG, "Checking ",
join(", ", @$A_lookups),
" for A record in the background");
$A_pdns = ParaDNS->new(
callback => sub {
my ($result, $query) = @_;
return if $result !~ /^\d+\.\d+\.\d+\.\d+$/;
$qp->log(LOGDEBUG, "Result for A $query: $result");
$class->process_a_result($qp, $result, $query);
},
finished => sub {
$total_zones -= @$A_lookups;
$class->finished($qp, $total_zones);
},
hosts => [@$A_lookups],
type => 'A',
client => $qp->input_sock,
);
return unless defined $A_pdns;
}
if (@$TXT_lookups) {
$qp->log(LOGDEBUG, "Checking ",
join(", ", @$TXT_lookups),
" for TXT record in the background");
$TXT_pdns = ParaDNS->new(
callback => sub {
my ($result, $query) = @_;
return if $result !~ /[a-z]/;
$qp->log(LOGDEBUG, "Result for TXT $query: $result");
$class->process_txt_result($qp, $result, $query);
},
finished => sub {
$total_zones -= @$TXT_lookups;
$class->finished($qp, $total_zones);
},
hosts => [@$TXT_lookups],
type => 'TXT',
client => $qp->input_sock,
);
unless (defined $TXT_pdns) {
undef $A_pdns;
return;
}
}
return 1;
}
sub finished {
my ($class, $qp, $total_zones) = @_;
$qp->log(LOGDEBUG, "Finished ($total_zones)");
$qp->run_continuation unless $total_zones;
}
# plugins should implement the following two methods to do something
# useful with the results
sub process_a_result {
my ($class, $qp, $result, $query) = @_;
}
sub process_txt_result {
my ($class, $qp, $result, $query) = @_;
}
1;

349
lib/Qpsmtpd/PollServer.pm Normal file
View File

@ -0,0 +1,349 @@
package Qpsmtpd::PollServer;
use base ('Danga::Client', 'Qpsmtpd::SMTP');
# use fields required to be a subclass of Danga::Client. Have to include
# all fields used by Qpsmtpd.pm here too.
use fields qw(
input_sock
mode
header_lines
in_header
data_size
max_size
hooks
start_time
cmd_timeout
conn
_auth
_auth_mechanism
_auth_state
_auth_ticket
_auth_user
_commands
_config_cache
_connection
_continuation
_extras
_test_mode
_transaction
);
use Qpsmtpd::Constants;
use Qpsmtpd::Address;
use ParaDNS;
use Mail::Header;
use POSIX qw(strftime);
use Socket qw(inet_aton AF_INET CRLF);
use Time::HiRes qw(time);
use strict;
sub max_idle_time { 60 }
sub max_connect_time { 1200 }
sub input_sock {
my $self = shift;
@_ and $self->{input_sock} = shift;
$self->{input_sock} || $self;
}
sub new {
my Qpsmtpd::PollServer $self = shift;
$self = fields::new($self) unless ref $self;
$self->SUPER::new( @_ );
$self->{cmd_timeout} = 5;
$self->{start_time} = time;
$self->{mode} = 'connect';
$self->load_plugins;
$self->load_logging;
my ($rc, @msg) = $self->run_hooks_no_respond("pre-connection");
if ($rc == DENYSOFT || $rc == DENYSOFT_DISCONNECT) {
@msg = ("Sorry, try again later")
unless @msg;
$self->respond(451, @msg);
$self->disconnect;
}
elsif ($rc == DENY || $rc == DENY_DISCONNECT) {
@msg = ("Sorry, service not available for you")
unless @msg;
$self->respond(550, @msg);
$self->disconnect;
}
return $self;
}
sub uptime {
my Qpsmtpd::PollServer $self = shift;
return (time() - $self->{start_time});
}
sub reset_for_next_message {
my Qpsmtpd::PollServer $self = shift;
$self->SUPER::reset_for_next_message(@_);
$self->{_commands} = {
ehlo => 1,
helo => 1,
rset => 1,
mail => 1,
rcpt => 1,
data => 1,
help => 1,
vrfy => 1,
noop => 1,
quit => 1,
auth => 0, # disabled by default
};
$self->{mode} = 'cmd';
$self->{_extras} = {};
}
sub respond {
my Qpsmtpd::PollServer $self = shift;
my ($code, @messages) = @_;
while (my $msg = shift @messages) {
my $line = $code . (@messages ? "-" : " ") . $msg;
$self->write("$line\r\n");
}
return 1;
}
sub fault {
my Qpsmtpd::PollServer $self = shift;
$self->SUPER::fault(@_);
return;
}
my %cmd_cache;
sub process_line {
my Qpsmtpd::PollServer $self = shift;
my $line = shift || return;
if ($::DEBUG > 1) { print "$$:".($self+0)."C($self->{mode}): $line"; }
if ($self->{mode} eq 'cmd') {
$line =~ s/\r?\n$//s;
$self->connection->notes('original_string', $line);
my ($cmd, @params) = split(/ +/, $line, 2);
my $meth = lc($cmd);
if (my $lookup = $cmd_cache{$meth} || $self->{_commands}->{$meth} && $self->can($meth)) {
$cmd_cache{$meth} = $lookup;
eval {
$lookup->($self, @params);
};
if ($@) {
my $error = $@;
chomp($error);
$self->log(LOGERROR, "Command Error: $error");
$self->fault("command '$cmd' failed unexpectedly");
}
}
else {
# No such method - i.e. unrecognized command
my ($rc, $msg) = $self->run_hooks("unrecognized_command", $meth, @params);
}
}
elsif ($self->{mode} eq 'connect') {
$self->{mode} = 'cmd';
# I've removed an eval{} from around this. It shouldn't ever die()
# but if it does we're a bit screwed... Ah well :-)
$self->start_conversation;
}
else {
die "Unknown mode";
}
return;
}
sub disconnect {
my Qpsmtpd::PollServer $self = shift;
$self->SUPER::disconnect(@_);
$self->close;
}
sub close {
my Qpsmtpd::PollServer $self = shift;
$self->run_hooks_no_respond("post-connection");
$self->connection->reset;
$self->SUPER::close;
}
sub start_conversation {
my Qpsmtpd::PollServer $self = shift;
my $conn = $self->connection;
# set remote_host, remote_ip and remote_port
my ($ip, $port) = split(':', $self->peer_addr_string);
return $self->close() unless $ip;
$conn->remote_ip($ip);
$conn->remote_port($port);
$conn->remote_info("[$ip]");
my ($lip,$lport) = split(':', $self->local_addr_string);
$conn->local_ip($lip);
$conn->local_port($lport);
ParaDNS->new(
finished => sub { $self->continue_read(); $self->run_hooks("connect") },
# NB: Setting remote_info to the same as remote_host
callback => sub { $conn->remote_info($conn->remote_host($_[0])) },
host => $ip,
);
return;
}
sub data {
my Qpsmtpd::PollServer $self = shift;
my ($rc, $msg) = $self->run_hooks("data");
return 1;
}
sub data_respond {
my Qpsmtpd::PollServer $self = shift;
my ($rc, $msg) = @_;
if ($rc == DONE) {
return;
}
elsif ($rc == DENY) {
$msg->[0] ||= "Message denied";
$self->respond(554, @$msg);
$self->reset_transaction();
return;
}
elsif ($rc == DENYSOFT) {
$msg->[0] ||= "Message denied temporarily";
$self->respond(451, @$msg);
$self->reset_transaction();
return;
}
elsif ($rc == DENY_DISCONNECT) {
$msg->[0] ||= "Message denied";
$self->respond(554, @$msg);
$self->disconnect;
return;
}
elsif ($rc == DENYSOFT_DISCONNECT) {
$msg->[0] ||= "Message denied temporarily";
$self->respond(451, @$msg);
$self->disconnect;
return;
}
return $self->respond(503, "MAIL first") unless $self->transaction->sender;
return $self->respond(503, "RCPT first") unless $self->transaction->recipients;
$self->{header_lines} = '';
$self->{data_size} = 0;
$self->{in_header} = 1;
$self->{max_size} = ($self->config('databytes'))[0] || 0;
$self->log(LOGDEBUG, "max_size: $self->{max_size} / size: $self->{data_size}");
$self->respond(354, "go ahead");
my $max_get = $self->{max_size} || 1048576;
$self->get_chunks($max_get, sub { $self->got_data($_[0]) });
return 1;
}
sub got_data {
my Qpsmtpd::PollServer $self = shift;
my $data = shift;
my $done = 0;
my $remainder;
if ($data =~ s/^\.\r\n(.*)\z//ms) {
$remainder = $1;
$done = 1;
}
# add a transaction->blocked check back here when we have line by line plugin access...
unless (($self->{max_size} and $self->{data_size} > $self->{max_size})) {
$data =~ s/\r\n/\n/mg;
$data =~ s/^\.\./\./mg;
if ($self->{in_header}) {
$self->{header_lines} .= $data;
if ($self->{header_lines} =~ s/\n(\n.*)\z/\n/ms) {
$data = $1;
# end of headers
$self->{in_header} = 0;
# ... need to check that we don't reformat any of the received lines.
#
# 3.8.2 Received Lines in Gatewaying
# When forwarding a message into or out of the Internet environment, a
# gateway MUST prepend a Received: line, but it MUST NOT alter in any
# way a Received: line that is already in the header.
my @header_lines = split(/^/m, $self->{header_lines});
my $header = Mail::Header->new(\@header_lines,
Modify => 0, MailFrom => "COERCE");
$self->transaction->header($header);
$self->transaction->body_write($self->{header_lines});
$self->{header_lines} = '';
#$header->add("X-SMTPD", "qpsmtpd/".$self->version.", http://smtpd.develooper.com/");
# FIXME - call plugins to work on just the header here; can
# save us buffering the mail content.
# Save the start of just the body itself
$self->transaction->set_body_start();
}
}
$self->transaction->body_write(\$data);
$self->{data_size} += length $data;
}
if ($done) {
$self->end_of_data;
$self->end_get_chunks($remainder);
}
}
sub end_of_data {
my Qpsmtpd::PollServer $self = shift;
#$self->log(LOGDEBUG, "size is at $size\n") unless ($i % 300);
$self->log(LOGDEBUG, "max_size: $self->{max_size} / size: $self->{data_size}");
my $header = $self->transaction->header;
if (!$header) {
$header = Mail::Header->new(Modify => 0, MailFrom => "COERCE");
$self->transaction->header($header);
}
my $smtp = $self->connection->hello eq "ehlo" ? "ESMTP" : "SMTP";
my $esmtp = substr($smtp,0,1) eq "E";
my $authheader;
my $sslheader;
if (defined $self->connection->notes('tls_enabled')
and $self->connection->notes('tls_enabled'))
{
$smtp .= "S" if $esmtp; # RFC3848
$sslheader = "(".$self->connection->notes('tls_socket')->get_cipher()." encrypted) ";
}
if (defined $self->{_auth} and $self->{_auth} == OK) {
$smtp .= "A" if $esmtp; # RFC3848
$authheader = "(smtp-auth username $self->{_auth_user}, mechanism $self->{_auth_mechanism})\n";
}
$header->add("Received", $self->received_line($smtp, $authheader, $sslheader), 0);
return $self->respond(552, "Message too big!") if $self->{max_size} and $self->{data_size} > $self->{max_size};
my ($rc, $msg) = $self->run_hooks("data_post");
return 1;
}
1;

223
lib/Qpsmtpd/Postfix.pm Normal file
View File

@ -0,0 +1,223 @@
package Qpsmtpd::Postfix;
=head1 NAME
Qpsmtpd::Postfix - postfix queueing support for qpsmtpd
=head2 DESCRIPTION
This package implements the protocol Postfix servers use to communicate
with each other. See src/global/rec_type.h in the postfix source for
details.
=cut
use strict;
use IO::Socket::UNIX;
use IO::Socket::INET;
use vars qw(@ISA);
@ISA = qw(IO::Socket::UNIX);
my %rec_types;
sub init {
my ($self) = @_;
%rec_types = (
REC_TYPE_SIZE => 'C', # first record, created by cleanup
REC_TYPE_TIME => 'T', # time stamp, required
REC_TYPE_FULL => 'F', # full name, optional
REC_TYPE_INSP => 'I', # inspector transport
REC_TYPE_FILT => 'L', # loop filter transport
REC_TYPE_FROM => 'S', # sender, required
REC_TYPE_DONE => 'D', # delivered recipient, optional
REC_TYPE_RCPT => 'R', # todo recipient, optional
REC_TYPE_ORCP => 'O', # original recipient, optional
REC_TYPE_WARN => 'W', # warning message time
REC_TYPE_ATTR => 'A', # named attribute for extensions
REC_TYPE_MESG => 'M', # start message records
REC_TYPE_CONT => 'L', # long data record
REC_TYPE_NORM => 'N', # normal data record
REC_TYPE_XTRA => 'X', # start extracted records
REC_TYPE_RRTO => 'r', # return-receipt, from headers
REC_TYPE_ERTO => 'e', # errors-to, from headers
REC_TYPE_PRIO => 'P', # priority
REC_TYPE_VERP => 'V', # VERP delimiters
REC_TYPE_END => 'E', # terminator, required
);
}
sub print_rec {
my ($self, $type, @list) = @_;
die "unknown record type" unless ($rec_types{$type});
$self->print($rec_types{$type});
# the length is a little endian base-128 number where each
# byte except the last has the high bit set:
my $s = "@list";
my $ln = length($s);
while ($ln >= 0x80) {
my $lnl = $ln & 0x7F;
$ln >>= 7;
$self->print(chr($lnl | 0x80));
}
$self->print(chr($ln));
$self->print($s);
}
sub print_rec_size {
my ($self, $content_size, $data_offset, $rcpt_count) = @_;
my $s = sprintf("%15ld %15ld %15ld", $content_size, $data_offset, $rcpt_count);
$self->print_rec('REC_TYPE_SIZE', $s);
}
sub print_rec_time {
my ($self, $time) = @_;
$time = time() unless (defined($time));
my $s = sprintf("%d", $time);
$self->print_rec('REC_TYPE_TIME', $s);
}
sub open_cleanup {
my ($class, $socket) = @_;
my $self;
if ($socket =~ m#^(/.+)#) {
$socket = $1; # un-taint socket path
$self = IO::Socket::UNIX->new(Type => SOCK_STREAM,
Peer => $socket) if $socket;
} elsif ($socket =~ /(.*):(\d+)/) {
my ($host,$port) = ($1,$2); # un-taint address and port
$self = IO::Socket::INET->new(Proto => 'tcp',
PeerAddr => $host,PeerPort => $port)
if $host and $port;
}
unless (ref $self) {
warn "Couldn't open \"$socket\": $!";
return;
}
# allow buffered writes
$self->autoflush(0);
bless ($self, $class);
$self->init();
return $self;
}
sub print_attr {
my ($self, @kv) = @_;
for (@kv) {
$self->print("$_\0");
}
$self->print("\0");
}
sub get_attr {
my ($self) = @_;
local $/ = "\0";
my %kv;
for(;;) {
my $k = $self->getline;
chomp($k);
last unless ($k);
my $v = $self->getline;
chomp($v);
$kv{$k} = $v;
}
return %kv;
}
=head2 print_msg_line($line)
print one line of a message to cleanup.
This removes any linefeed characters from the end of the line
and splits the line across several records if it is longer than
1024 chars.
=cut
sub print_msg_line {
my ($self, $line) = @_;
$line =~ s/\r?\n$//s;
# split into 1k chunks.
while (length($line) > 1024) {
my $s = substr($line, 0, 1024);
$line = substr($line, 1024);
$self->print_rec('REC_TYPE_CONT', $s);
}
$self->print_rec('REC_TYPE_NORM', $line);
}
=head2 inject_mail($transaction)
(class method) inject mail in $transaction into postfix queue via cleanup.
$transaction is supposed to be a Qpsmtpd::Transaction object.
=cut
sub inject_mail {
my ($class, $transaction) = @_;
my @sockets = @{$transaction->notes('postfix-queue-sockets')
// ['/var/spool/postfix/public/cleanup']};
my $strm;
$strm = $class->open_cleanup($_) and last for @sockets;
die "Unable to open any cleanup sockets!" unless $strm;
my %at = $strm->get_attr;
my $qid = $at{queue_id};
print STDERR "qid=$qid\n";
$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) {
$strm->print_rec('REC_TYPE_RCPT', $_);
}
# add an empty message length record.
# cleanup is supposed to understand that.
# see src/pickup/pickup.c
$strm->print_rec('REC_TYPE_MESG', "");
# a received header has already been added in SMTP.pm
# so we can just copy the message:
my $hdr = $transaction->header->as_string;
for (split(/\r?\n/, $hdr)) {
print STDERR "hdr: $_\n";
$strm->print_msg_line($_);
}
$transaction->body_resetpos;
while (my $line = $transaction->body_getline) {
# print STDERR "body: $line\n";
$strm->print_msg_line($line);
}
# finish it.
$strm->print_rec('REC_TYPE_XTRA', "");
$strm->print_rec('REC_TYPE_END', "");
$strm->flush();
%at = $strm->get_attr;
my $status = $at{status};
my $reason = $at{reason};
$strm->close();
return wantarray ? ($status, $qid, $reason || "") : $status;
}
1;
# vim:sw=2

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;

854
lib/Qpsmtpd/SMTP.pm Normal file
View File

@ -0,0 +1,854 @@
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 Data::Dumper;
use POSIX qw(strftime);
use Net::DNS;
# this is only good for forkserver
# can't set these here, cause forkserver resets them
#$SIG{ALRM} = sub { respond(421, "Game over pal, game over. You got a timeout; I just can't wait that long..."); exit };
#$SIG{ALRM} = sub { warn "Connection Timed Out\n"; exit; };
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my %args = @_;
my $self = bless ({ args => \%args }, $class);
my (@commands) = qw(ehlo helo rset mail rcpt data help vrfy noop quit);
my (%commands); @commands{@commands} = ('') x @commands;
# this list of valid commands should probably be a method or a set of methods
$self->{_commands} = \%commands;
$self->SUPER::_restart(%args) if $args{restart}; # calls Qpsmtpd::_restart()
$self;
}
sub command_counter {
my $self = shift;
$self->{_counter} || 0;
}
sub dispatch {
my $self = shift;
my ($cmd) = lc shift;
$self->{_counter}++;
if ($cmd !~ /^(\w{1,12})$/ or !exists $self->{_commands}->{$1}) {
$self->run_hooks("unrecognized_command", $cmd, @_);
return 1;
}
$cmd = $1;
my ($result) = eval { $self->$cmd(@_) };
$self->log(LOGERROR, "XX: $@") if $@;
return $result if defined $result;
return $self->fault("command '$cmd' failed unexpectedly");
}
sub unrecognized_command_respond {
my ($self, $rc, $msg) = @_;
if ($rc == DENY_DISCONNECT) {
$self->respond(521, @$msg);
$self->disconnect;
}
elsif ($rc == DENY) {
$self->respond(500, @$msg);
}
elsif ($rc != DONE) {
$self->respond(500, "Unrecognized command");
}
}
sub fault {
my $self = shift;
my ($msg) = shift || "program fault - command not performed";
my ($name) = split /\s+/, $0, 2;
print STDERR $name,"[$$]: $msg ($!)\n";
return $self->respond(451, "Internal error - try again later - " . $msg);
}
sub start_conversation {
my $self = shift;
# this should maybe be called something else than "connect", see
# lib/Qpsmtpd/TcpServer.pm for more confusion.
$self->run_hooks("connect");
return DONE;
}
sub connect_respond {
my ($self, $rc, $msg) = @_;
if ($rc == DENY || $rc == DENY_DISCONNECT) {
$msg->[0] ||= 'Connection from you denied, bye bye.';
$self->respond(550, @$msg);
$self->disconnect;
}
elsif ($rc == DENYSOFT || $rc == DENYSOFT_DISCONNECT) {
$msg->[0] ||= 'Connection from you temporarily denied, bye bye.';
$self->respond(450, @$msg);
$self->disconnect;
}
elsif ($rc != DONE) {
my $greets = $self->config('smtpgreeting');
if ( $greets ) {
$greets .= " ESMTP" unless $greets =~ /(^|\W)ESMTP(\W|$)/;
}
else {
$greets = $self->config('me')
. " ESMTP qpsmtpd "
. $self->version
. " ready; send us your mail, but not your spam.";
}
$self->respond(220, $greets);
}
}
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, $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;
$self->run_hooks("helo", $hello_host, @stuff);
}
sub helo_respond {
my ($self, $rc, $msg, $args) = @_;
my ($hello_host) = @$args;
if ($rc == DONE) {
# do nothing:
1;
} elsif ($rc == DENY) {
$self->respond(550, @$msg);
} elsif ($rc == DENYSOFT) {
$self->respond(450, @$msg);
} elsif ($rc == DENY_DISCONNECT) {
$self->respond(550, @$msg);
$self->disconnect;
} elsif ($rc == DENYSOFT_DISCONNECT) {
$self->respond(450, @$msg);
$self->disconnect;
} 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.");
}
}
sub ehlo {
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;
$self->run_hooks("ehlo", $hello_host, @stuff);
}
sub ehlo_respond {
my ($self, $rc, $msg, $args) = @_;
my ($hello_host) = @$args;
if ($rc == DONE) {
# do nothing:
1;
} elsif ($rc == DENY) {
$self->respond(550, @$msg);
} elsif ($rc == DENYSOFT) {
$self->respond(450, @$msg);
} elsif ($rc == DENY_DISCONNECT) {
$self->respond(550, @$msg);
$self->disconnect;
} elsif ($rc == DENYSOFT_DISCONNECT) {
$self->respond(450, @$msg);
$self->disconnect;
} else {
my $conn = $self->connection;
$conn->hello("ehlo");
$conn->hello_host($hello_host);
$self->transaction;
my @capabilities = $self->transaction->notes('capabilities')
? @{ $self->transaction->notes('capabilities') }
: ();
# Check for possible AUTH mechanisms
HOOK: foreach my $hook ( keys %{$self->hooks} ) {
if ( $hook =~ m/^auth-?(.+)?$/ ) {
if ( defined $1 ) {
$auth_mechanisms{uc($1)} = 1;
}
else { # at least one polymorphous auth provider
%auth_mechanisms = map {$_,1} qw(PLAIN CRAM-MD5 LOGIN);
last HOOK;
}
}
}
# 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'} = "";
}
$self->respond(250,
$self->config("me") . " Hi " . $conn->remote_info . " [" . $conn->remote_ip ."]",
"PIPELINING",
"8BITMIME",
($self->config('databytes') ? "SIZE ". ($self->config('databytes'))[0] : ()),
@capabilities,
);
}
}
sub auth {
my ($self, $line) = @_;
$self->run_hooks('auth_parse', $line);
}
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 ( defined $self->{_auth} && $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]
&& $self->transaction->notes('tls_enabled') );
# 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 );
};
$self->respond( 504, "Unimplemented authentification mechanism: $mechanism" );
return DENY;
}
sub mail {
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
# consists of a transaction beginning command, one or more RCPT
# commands, and a DATA command, in that order. A mail transaction
# may be aborted by the RSET (or a new EHLO) command. There may be
# zero or more transactions in a session. MAIL (or SEND, SOML, or
# SAML) MUST NOT be sent if a mail transaction is already open,
# i.e., it should be sent only if no mail transaction had been
# started in the session, or it the previous one successfully
# concluded with a successful DATA command, or if the previous one
# was aborted with a RSET.
# sendmail (8.11) rejects a second MAIL command.
# qmail-smtpd (1.03) accepts it and just starts a new transaction.
# Since we are a qmail-smtpd thing we will do the same.
$self->reset_transaction;
unless ($self->connection->hello) {
return $self->respond(503, "please say hello first ...");
}
else {
$self->log(LOGDEBUG, "full from_parameter: $line");
$self->run_hooks("mail_parse", $line);
}
}
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);
}
sub mail_pre_respond {
my ($self, $rc, $msg, $args) = @_;
my ($from, $param) = @$args;
if ($rc == OK) {
$from = shift @$msg;
}
$self->log(LOGDEBUG, "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("<>");
}
else {
$from = (Qpsmtpd::Address->parse($from))[0];
}
return $self->respond(501, "could not parse your mail from command") unless $from;
$self->run_hooks("mail", $from, %$param);
}
sub mail_respond {
my ($self, $rc, $msg, $args) = @_;
my ($from, $param) = @$args;
if ($rc == DONE) {
return 1;
}
elsif ($rc == DENY) {
$msg->[0] ||= $from->format . ', denied';
$self->log(LOGINFO, "deny mail from " . $from->format . " (@$msg)");
$self->respond(550, @$msg);
}
elsif ($rc == DENYSOFT) {
$msg->[0] ||= $from->format . ', temporarily denied';
$self->log(LOGINFO, "denysoft mail from " . $from->format . " (@$msg)");
$self->respond(450, @$msg);
}
elsif ($rc == DENY_DISCONNECT) {
$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->[0] ||= $from->format . ', temporarily denied';
$self->log(LOGINFO, "denysoft mail from " . $from->format . " (@$msg)");
$self->respond(421, @$msg);
$self->disconnect;
}
else { # includes OK
$self->log(LOGDEBUG, "getting mail from ".$from->format);
$self->respond(250, $from->format . ", sender OK - how exciting to get mail from you!");
$self->transaction->sender($from);
}
}
sub rcpt {
my ($self, $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 %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(LOGDEBUG, "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")
if (!$rcpt or ($rcpt->format eq '<>'));
$self->run_hooks("rcpt", $rcpt, %$param);
}
sub rcpt_respond {
my ($self, $rc, $msg, $args) = @_;
my ($rcpt, $param) = @$args;
if ($rc == DONE) {
return 1;
}
elsif ($rc == DENY) {
$msg->[0] ||= 'relaying denied';
$self->respond(550, @$msg);
}
elsif ($rc == DENYSOFT) {
$msg->[0] ||= 'relaying denied';
return $self->respond(450, @$msg);
}
elsif ($rc == DENY_DISCONNECT) {
$msg->[0] ||= 'delivery denied';
$self->log(LOGINFO, "delivery denied (@$msg)");
$self->respond(550, @$msg);
$self->disconnect;
}
elsif ($rc == DENYSOFT_DISCONNECT) {
$msg->[0] ||= 'relaying denied';
$self->log(LOGINFO, "delivery denied (@$msg)");
$self->respond(421, @$msg);
$self->disconnect;
}
elsif ($rc == OK) {
$self->respond(250, $rcpt->format . ", recipient ok");
return $self->transaction->add_recipient($rcpt);
}
else {
return $self->respond(450, "No plugin decided if relaying is allowed");
}
return 0;
}
sub help {
my ($self, @args) = @_;
$self->run_hooks("help", @args);
}
sub help_respond {
my ($self, $rc, $msg, $args) = @_;
return 1
if $rc == DONE;
if ($rc == DENY) {
$msg->[0] ||= "Syntax error, command not recognized";
$self->respond(500, @$msg);
}
else {
unless ($msg->[0]) {
@$msg = (
"This is qpsmtpd " . ($self->config('smtpgreeting') ? '' : $self->version),
"See http://smtpd.develooper.com/",
'To report bugs or send comments, mail to <ask@develooper.com>.');
}
$self->respond(214, @$msg);
}
return 1;
}
sub noop {
my $self = shift;
$self->run_hooks("noop");
}
sub noop_respond {
my ($self, $rc, $msg, $args) = @_;
return 1 if $rc == DONE;
if ($rc == DENY || $rc == DENY_DISCONNECT) {
$msg->[0] ||= "Stop wasting my time."; # FIXME: better default message?
$self->respond(500, @$msg);
$self->disconnect if $rc == DENY_DISCONNECT;
return 1;
}
$self->respond(250, "OK");
return 1;
}
sub vrfy {
my $self = shift;
# Note, this doesn't support the multiple ambiguous results
# documented in RFC2821#3.5.1
# I also don't think it provides all the proper result codes.
$self->run_hooks("vrfy");
}
sub vrfy_respond {
my ($self, $rc, $msg, $args) = @_;
if ($rc == DONE) {
return 1;
}
elsif ($rc == DENY) {
$msg->[0] ||= "Access Denied";
$self->respond(554, @$msg);
$self->reset_transaction();
return 1;
}
elsif ($rc == OK) {
$msg->[0] ||= "User OK";
$self->respond(250, @$msg);
return 1;
}
else { # $rc == DECLINED or anything else
$self->respond(252, "Just try sending a mail and we'll see how it turns out ...");
return 1;
}
}
sub rset {
my $self = shift;
$self->reset_transaction;
$self->respond(250, "OK");
}
sub quit {
my $self = shift;
$self->run_hooks("quit");
}
sub quit_respond {
my ($self, $rc, $msg, $args) = @_;
if ($rc != DONE) {
$msg->[0] ||= $self->config('me') . " closing connection. Have a wonderful day.";
$self->respond(221, @$msg);
}
$self->disconnect();
}
sub disconnect {
my $self = shift;
$self->run_hooks("disconnect");
$self->connection->notes(disconnected => 1);
$self->reset_transaction;
}
sub data {
my $self = shift;
$self->run_hooks("data");
}
sub data_respond {
my ($self, $rc, $msg, $args) = @_;
if ($rc == DONE) {
return 1;
}
elsif ($rc == DENY) {
$msg->[0] ||= "Message denied";
$self->respond(554, @$msg);
$self->reset_transaction();
return 1;
}
elsif ($rc == DENYSOFT) {
$msg->[0] ||= "Message denied temporarily";
$self->respond(451, @$msg);
$self->reset_transaction();
return 1;
}
elsif ($rc == DENY_DISCONNECT) {
$msg->[0] ||= "Message denied";
$self->respond(554, @$msg);
$self->disconnect;
return 1;
}
elsif ($rc == DENYSOFT_DISCONNECT) {
$msg->[0] ||= "Message denied temporarily";
$self->respond(421, @$msg);
$self->disconnect;
return 1;
}
$self->respond(503, "MAIL first"), return 1 unless $self->transaction->sender;
$self->respond(503, "RCPT first"), return 1 unless $self->transaction->recipients;
$self->respond(354, "go ahead");
my $buffer = '';
my $size = 0;
my $i = 0;
my $max_size = ($self->config('databytes'))[0] || 0; # this should work in scalar context
my $blocked = "";
my %matches;
my $in_header = 1;
my $complete = 0;
$self->log(LOGDEBUG, "max_size: $max_size / size: $size");
my $header = Mail::Header->new(Modify => 0, MailFrom => "COERCE");
my $timeout = $self->config('timeout');
while (defined($_ = $self->getline($timeout))) {
$complete++, last if $_ eq ".\r\n";
$i++;
# should probably use \012 and \015 in these checks instead of \r and \n ...
# Reject messages that have either bare LF or CR. rjkaes noticed a
# lot of spam that is malformed in the header.
($_ eq ".\n" or $_ eq ".\r")
and $self->respond(421, "See http://smtpd.develooper.com/barelf.html")
and return $self->disconnect;
# add a transaction->blocked check back here when we have line by line plugin access...
unless (($max_size and $size > $max_size)) {
s/\r\n$/\n/;
s/^\.\./\./;
if ($in_header and m/^$/) {
$in_header = 0;
my @headers = split /^/m, $buffer;
# ... need to check that we don't reformat any of the received lines.
#
# 3.8.2 Received Lines in Gatewaying
# When forwarding a message into or out of the Internet environment, a
# gateway MUST prepend a Received: line, but it MUST NOT alter in any
# way a Received: line that is already in the header.
$header->extract(\@headers);
#$header->add("X-SMTPD", "qpsmtpd/".$self->version.", http://smtpd.develooper.com/");
$buffer = "";
$self->transaction->header($header);
# NOTE: This will not work properly under async. A
# data_headers_end_respond needs to be created.
my ($rc, $msg) = $self->run_hooks('data_headers_end');
if ($rc == DENY_DISCONNECT) {
$self->respond(554, $msg || "Message denied");
$self->disconnect;
return 1;
} elsif ($rc == DENYSOFT_DISCONNECT) {
$self->respond(421, $msg || "Message denied temporarily");
$self->disconnect;
return 1;
}
# Save the start of just the body itself
$self->transaction->set_body_start();
}
# grab a copy of all of the header lines
if ($in_header) {
$buffer .= $_;
}
# copy all lines into the spool file, including the headers
# we will create a new header later before sending onwards
$self->transaction->body_write($_);
$size += length $_;
}
#$self->log(LOGDEBUG, "size is at $size\n") unless ($i % 300);
}
$self->log(LOGDEBUG, "max_size: $max_size / size: $size");
my $smtp = $self->connection->hello eq "ehlo" ? "ESMTP" : "SMTP";
my $esmtp = substr($smtp,0,1) eq "E";
my $authheader = '';
my $sslheader = '';
if (defined $self->connection->notes('tls_enabled')
and $self->connection->notes('tls_enabled')) {
$smtp .= "S" if $esmtp; # RFC3848
$sslheader = "(".$self->connection->notes('tls_socket')->get_cipher()." encrypted) ";
}
if (defined $self->{_auth} and $self->{_auth} == OK) {
$smtp .= "A" if $esmtp; # RFC3848
$authheader = "(smtp-auth username $self->{_auth_user}, mechanism $self->{_auth_mechanism})\n";
}
$header->add("Received", $self->received_line($smtp, $authheader, $sslheader), 0);
# if we get here without seeing a terminator, the connection is
# probably dead.
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);
if ($max_size and $size > $max_size) {
$self->log(LOGALERT, "Message too big: size: $size (max size: $max_size)");
$self->respond(552, "Message too big!");
$self->reset_transaction; # clean up after ourselves
return 1;
}
$self->run_hooks("data_post");
}
sub received_line {
my ($self, $smtp, $authheader, $sslheader) = @_;
my ($rc, @received) = $self->run_hooks("received_line", $smtp, $authheader, $sslheader);
if ($rc == YIELD) {
die "YIELD not supported for received_line hook";
}
elsif ($rc == OK) {
return join("\n", @received);
}
else { # assume $rc == DECLINED
return "from ".$self->connection->remote_info
." (HELO ".$self->connection->hello_host . ") (".$self->connection->remote_ip
. ")\n $authheader by ".$self->config('me')." (qpsmtpd/".$self->version
.") with $sslheader$smtp; ". (strftime('%a, %d %b %Y %H:%M:%S %z', localtime))
}
}
sub data_post_respond {
my ($self, $rc, $msg, $args) = @_;
if ($rc == DONE) {
return 1;
}
elsif ($rc == DENY) {
$msg->[0] ||= "Message denied";
$self->respond(552, @$msg);
# DATA is always the end of a "transaction"
return $self->reset_transaction;
}
elsif ($rc == DENYSOFT) {
$msg->[0] ||= "Message denied temporarily";
$self->respond(452, @$msg);
# DATA is always the end of a "transaction"
return $self->reset_transaction;
}
elsif ($rc == DENY_DISCONNECT) {
$msg->[0] ||= "Message denied";
$self->respond(552, @$msg);
$self->disconnect;
return 1;
}
elsif ($rc == DENYSOFT_DISCONNECT) {
$msg->[0] ||= "Message denied temporarily";
$self->respond(452, @$msg);
$self->disconnect;
return 1;
}
else {
$self->queue($self->transaction);
}
}
sub getline {
my ($self, $timeout) = @_;
alarm $timeout;
my $line = <STDIN>; # default implementation
alarm 0;
return $line;
}
sub queue {
my ($self, $transaction) = @_;
# 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, $args) = @_;
# reset transaction if we queued the mail
$self->reset_transaction;
if ($rc == DONE) {
return 1;
}
elsif ($rc == OK) {
$msg->[0] ||= 'Queued';
$self->respond(250, @$msg);
}
elsif ($rc == DENY) {
$msg->[0] ||= 'Message denied';
$self->respond(552, @$msg);
}
elsif ($rc == DENYSOFT) {
$msg->[0] ||= 'Message denied temporarily';
$self->respond(452, @$msg);
}
else {
$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);
}
1;

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

@ -0,0 +1,30 @@
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}) {
$self->run_hooks("unrecognized_command", $cmd, @_);
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;
}

194
lib/Qpsmtpd/TcpServer.pm Normal file
View File

@ -0,0 +1,194 @@
package Qpsmtpd::TcpServer;
use Qpsmtpd::SMTP;
use Qpsmtpd::Constants;
use Socket;
@ISA = qw(Qpsmtpd::SMTP);
use strict;
use POSIX ();
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;
}
my $first_0;
sub start_connection {
my $self = shift;
my (
$remote_host, $remote_info, $remote_ip, $remote_port,
$local_ip, $local_port, $local_host
);
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;
$remote_port = $ENV{TCPREMOTEPORT};
$local_ip = $ENV{TCPLOCALIP};
$local_port = $ENV{TCPLOCALPORT};
$local_host = $ENV{TCPLOCALHOST};
} 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
# 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;
$first_0 = $0 unless $first_0;
my $now = POSIX::strftime("%H:%M:%S %Y-%m-%d", localtime);
$0 = "$first_0 [$remote_ip : $remote_host : $now]";
$self->SUPER::connection->start(remote_info => $remote_info,
remote_ip => $remote_ip,
remote_host => $remote_host,
remote_port => $remote_port,
local_ip => $local_ip,
local_port => $local_port,
local_host => $local_host,
@_);
}
sub run {
my ($self, $client) = @_;
# Set local client_socket to passed client object for testing socket state on writes
$self->{__client_socket} = $client;
$self->load_plugins unless $self->{hooks};
my $rc = $self->start_conversation;
return if $rc != DONE;
# this should really be the loop and read_input should just get one line; I think
$self->read_input;
}
sub read_input {
my $self = shift;
my $timeout =
$self->config('timeoutsmtpd') # qmail smtpd control file
|| $self->config('timeout') # qpsmtpd control file
|| 1200; # default value
alarm $timeout;
while (<STDIN>) {
alarm 0;
$_ =~ s/\r?\n$//s; # advanced chomp
$self->log(LOGINFO, "dispatching $_");
$self->connection->notes('original_string', $_);
defined $self->dispatch(split / +/, $_, 2)
or $self->respond(502, "command unrecognized: '$_'");
alarm $timeout;
}
alarm(0);
return if $self->connection->notes('disconnected');
$self->reset_transaction;
$self->run_hooks('disconnect');
$self->connection->notes(disconnected => 1);
}
sub respond {
my ($self, $code, @messages) = @_;
my $buf = '';
if ( !$self->check_socket() ) {
$self->log(LOGERROR, "Lost connection to client, cannot send response.");
return(0);
}
while (my $msg = shift @messages) {
my $line = $code . (@messages?"-":" ").$msg;
$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(LOGINFO,"click, disconnecting");
$self->SUPER::disconnect(@_);
$self->run_hooks("post-connection");
$self->connection->reset;
exit;
}
# local/remote port and ip address
sub lrpip {
my ($server, $client, $hisaddr) = @_;
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 $nto_laddr = ($server->sockdomain == AF_INET) ? (inet_ntoa($laddr)) : (inet_ntop(AF_INET6(), $laddr));
$nto_iaddr =~ s/::ffff://;
$nto_laddr =~ s/::ffff://;
return ($port, $iaddr, $lport, $laddr, $nto_iaddr, $nto_laddr);
}
sub tcpenv {
my ($nto_laddr, $nto_iaddr, $no_rdns) = @_;
my $TCPLOCALIP = $nto_laddr;
my $TCPREMOTEIP = $nto_iaddr;
if ($no_rdns) {
return ($TCPLOCALIP, $TCPREMOTEIP, $TCPREMOTEIP ? "[$ENV{TCPREMOTEIP}]" : "[noip!]");
}
my $res = new Net::DNS::Resolver;
$res->tcp_timeout(3);
$res->udp_timeout(3);
my $query = $res->query($nto_iaddr);
my $TCPREMOTEHOST;
if($query) {
foreach my $rr ($query->answer) {
next unless $rr->type eq "PTR";
$TCPREMOTEHOST = $rr->ptrdname;
}
}
return ($TCPLOCALIP, $TCPREMOTEIP, $TCPREMOTEHOST || "Unknown");
}
sub check_socket() {
my $self = shift;
return 1 if ( $self->{__client_socket}->connected );
return 0;
}
1;

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

@ -0,0 +1,79 @@
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->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(LOGINFO, "dispatching $_");
$self->connection->notes('original_string', $_);
defined $self->dispatch(split / +/, $_, 2)
or $self->respond(502, "command unrecognized: '$_'");
alarm $timeout;
}
unless ($self->connection->notes('disconnected')) {
$self->reset_transaction;
$self->run_hooks('disconnect');
$self->connection->notes(disconnected => 1);
}
};
if ($@ =~ /^disconnect_tcpserver/) {
die "disconnect_tcpserver";
} else {
$self->run_hooks("post-connection");
$self->connection->reset;
die "died while reading from STDIN (probably broken sender) - $@";
}
alarm(0);
}
sub respond {
my ($self, $code, @messages) = @_;
if ( !$self->check_socket() ) {
$self->log(LOGERROR, "Lost connection to client, cannot send response.");
return(0);
}
while (my $msg = shift @messages) {
my $line = $code . (@messages?"-":" ").$msg;
$self->log(LOGINFO, $line);
print "$line\r\n" or ($self->log(LOGERROR, "Could not print [$line]: $!"), return 0);
}
return 1;
}
sub disconnect {
my $self = shift;
$self->log(LOGINFO,"click, disconnecting");
$self->SUPER::disconnect(@_);
$self->run_hooks("post-connection");
$self->connection->reset;
die "disconnect_tcpserver";
}
1;

399
lib/Qpsmtpd/Transaction.pm Normal file
View File

@ -0,0 +1,399 @@
package Qpsmtpd::Transaction;
use Qpsmtpd;
@ISA = qw(Qpsmtpd);
use strict;
use Qpsmtpd::Utils;
use Qpsmtpd::Constants;
use Socket qw(inet_aton);
use Sys::Hostname;
use Time::HiRes qw(gettimeofday);
use IO::File qw(O_RDWR O_CREAT);
sub new { start(@_) }
sub start {
my $proto = shift;
my $class = ref($proto) || $proto;
my %args = @_;
my $self = { _rcpt => [], started => time, };
bless ($self, $class);
return $self;
}
sub add_recipient {
my ($self, $rcpt) = @_;
push @{$self->{_recipients}}, $rcpt if $rcpt;
}
sub remove_recipient {
my ($self,$rcpt) = @_;
$self->{_recipients} = [grep {$_->address ne $rcpt->address}
@{$self->{_recipients} || []}] if $rcpt;
}
sub recipients {
my $self = shift;
@_ and $self->{_recipients} = [@_];
($self->{_recipients} ? @{$self->{_recipients}} : ());
}
sub sender {
my $self = shift;
@_ and $self->{_sender} = shift;
$self->{_sender};
}
sub header {
my $self = shift;
@_ and $self->{_header} = shift;
$self->{_header};
}
# blocked() will return when we actually can do something useful with it...
#sub blocked {
# my $self = shift;
# carp 'Use of transaction->blocked is deprecated;'
# . 'tell ask@develooper.com if you have a reason to use it';
# @_ and $self->{_blocked} = shift;
# $self->{_blocked};
#}
sub notes {
my ($self,$key) = (shift,shift);
# Check for any additional arguments passed by the caller -- including undef
return $self->{_notes}->{$key} unless @_;
return $self->{_notes}->{$key} = shift;
}
sub set_body_start {
my $self = shift;
$self->{_body_start} = $self->body_current_pos;
if ($self->{_body_file}) {
$self->{_header_size} = $self->{_body_start};
}
else {
$self->{_header_size} = 0;
if ($self->{_body_array}) {
foreach my $line (@{ $self->{_body_array} }) {
$self->{_header_size} += length($line);
}
}
}
}
sub body_start {
my $self = shift;
@_ and die "body_start now read only";
$self->{_body_start};
}
sub body_current_pos {
my $self = shift;
if ($self->{_body_file}) {
return tell($self->{_body_file});
}
return $self->{_body_current_pos} || 0;
}
sub body_filename {
my $self = shift;
$self->body_spool() unless $self->{_filename};
$self->{_body_file}->flush(); # so contents won't be cached
return $self->{_filename};
}
sub body_spool {
my $self = shift;
$self->log(LOGINFO, "spooling message to disk");
$self->{_filename} = $self->temp_file();
$self->{_body_file} = IO::File->new($self->{_filename}, O_RDWR|O_CREAT, 0600)
or die "Could not open file $self->{_filename} - $! "; # . $self->{_body_file}->error;
if ($self->{_body_array}) {
foreach my $line (@{ $self->{_body_array} }) {
$self->{_body_file}->print($line) or die "Cannot print to temp file: $!";
}
$self->{_body_start} = $self->{_header_size};
}
$self->{_body_array} = undef;
}
sub body_write {
my $self = shift;
my $data = shift;
if ($self->{_body_file}) {
#warn("body_write to file\n");
# go to the end of the file
seek($self->{_body_file},0,2)
unless $self->{_body_file_writing};
$self->{_body_file_writing} = 1;
$self->{_body_file}->print(ref $data eq "SCALAR" ? $$data : $data)
and $self->{_body_size} += length (ref $data eq "SCALAR" ? $$data : $data);
}
else {
#warn("body_write to array\n");
$self->{_body_array} ||= [];
my $ref = ref($data) eq "SCALAR" ? $data : \$data;
pos($$ref) = 0;
while ($$ref =~ m/\G(.*?\n)/gc) {
push @{ $self->{_body_array} }, $1;
$self->{_body_size} += length($1);
++$self->{_body_current_pos};
}
if ($$ref =~ m/\G(.+)\z/gc) {
push @{ $self->{_body_array} }, $1;
$self->{_body_size} += length($1);
++$self->{_body_current_pos};
}
$self->body_spool if ( $self->{_body_size} >= $self->size_threshold() );
}
}
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;
if ($self->{_body_file}) {
my $start = $self->{_body_start} || 0;
seek($self->{_body_file}, $start, 0);
$self->{_body_file_writing} = 0;
}
else {
$self->{_body_current_pos} = $self->{_body_start};
}
1;
}
sub body_getline {
my $self = shift;
if ($self->{_body_file}) {
my $start = $self->{_body_start} || 0;
seek($self->{_body_file}, $start,0)
if $self->{_body_file_writing};
$self->{_body_file_writing} = 0;
my $line = $self->{_body_file}->getline;
return $line;
}
else {
return unless $self->{_body_array};
$self->{_body_current_pos} ||= 0;
my $line = $self->{_body_array}->[$self->{_body_current_pos}];
$self->{_body_current_pos}++;
return $line;
}
}
sub body_as_string {
my $self = shift;
$self->body_resetpos;
local $/;
my $str = '';
while (defined(my $line = $self->body_getline)) {
$str .= $line;
}
return $str;
}
sub body_fh {
return shift->{_body_file};
}
sub dup_body_fh {
my ($self) = @_;
open(my $fh, '<&=', $self->body_fh);
return $fh;
}
sub DESTROY {
my $self = shift;
# would we save some disk flushing if we unlinked the file before
# closing it?
undef $self->{_body_file} if $self->{_body_file};
if ($self->{_filename} and -e $self->{_filename}) {
unlink $self->{_filename} or $self->log(LOGERROR, "Could not unlink ", $self->{_filename}, ": $!");
}
# These may not exist
if ( $self->{_temp_files} ) {
$self->log(LOGDEBUG, "Cleaning up temporary transaction files");
foreach my $file ( @{$self->{_temp_files}} ) {
next unless -e $file;
unlink $file or $self->log(LOGERROR,
"Could not unlink temporary file", $file, ": $!");
}
}
# Ditto
if ( $self->{_temp_dirs} ) {
eval {use File::Path};
$self->log(LOGDEBUG, "Cleaning up temporary directories");
foreach my $dir ( @{$self->{_temp_dirs}} ) {
rmtree($dir) or $self->log(LOGERROR,
"Could not unlink temporary dir", $dir, ": $!");
}
}
}
1;
__END__
=head1 NAME
Qpsmtpd::Transaction - single SMTP session transaction data
=head1 SYNOPSIS
foreach my $recip ($transaction->recipients) {
print "T", $recip->address, "\0";
}
=head1 DESCRIPTION
Qpsmtpd::Transaction maintains a single SMTP session's data, including
the envelope details and the mail header and body.
The docs below cover using the C<$transaction> object from within plugins
rather than constructing a C<Qpsmtpd::Transaction> object, because the
latter is done for you by qpsmtpd.
=head1 API
=head2 add_recipient($recipient)
This adds a new recipient (as in RCPT TO) to the envelope of the mail.
The C<$recipient> is a C<Qpsmtpd::Address> object. See L<Qpsmtpd::Address>
for more details.
=head2 remove_recipient($recipient)
This removes a recipient (as in RCPT TO) from the envelope of the mail.
The C<$recipient> is a C<Qpsmtpd::Address> object. See L<Qpsmtpd::Address>
for more details.
=head2 recipients( )
This returns a list of the current recipients in the envelope.
Each recipient returned is a C<Qpsmtpd::Address> object.
This method is also a setter. Pass in a list of recipients to change
the recipient list to an entirely new list. Note that the recipients
you pass in B<MUST> be C<Qpsmtpd::Address> objects.
=head2 sender( [ ADDRESS ] )
Get or set the sender (MAIL FROM) address in the envelope.
The sender is a C<Qpsmtpd::Address> object.
=head2 header( [ HEADER ] )
Get or set the header of the email.
The header is a <Mail::Header> object, which gives you access to all
the individual headers using a simple API. e.g.:
my $headers = $transaction->header();
my $msgid = $headers->get('Message-Id');
my $subject = $headers->get('Subject');
=head2 notes( $key [, $value ] )
Get or set a note on the transaction. This is a piece of data that you wish
to attach to the transaction and read somewhere else. For example you can
use this to pass data between plugins.
Note though that these notes will be lost when a transaction ends, for
example on a C<RSET> or after C<DATA> completes, so you might want to
use the notes field in the C<Qpsmtpd::Connection> object instead.
=head2 body_filename ( )
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.
C<$data> can be either a plain scalar, or a reference to a scalar.
=head2 body_size( )
B<Deprecated>, 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( )
Resets the body filehandle to the start of the file (via C<seek()>).
Use this function before every time you wish to process the entire
body of the email to ensure that some other plugin has not moved the
file pointer.
=head2 body_getline( )
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>.
=head2 dup_body_fh( )
Returns a dup()'d file handle to the temporary file of the email. This can be
useful if an external module may call close() on the filehandle that is passed
to it. This should only be used for reads, as writing to a dup'd filehandle
may have unintended consequences.
=head1 SEE ALSO
L<Mail::Header>, L<Qpsmtpd::Address>, L<Qpsmtpd::Connection>
=cut

15
lib/Qpsmtpd/Utils.pm Normal file
View File

@ -0,0 +1,15 @@
package Qpsmtpd::Utils;
use strict;
sub tildeexp {
my $path = shift;
$path =~ s{^~([^/]*)} {
$1
? (getpwnam($1))[7]
: ( $ENV{HOME} || $ENV{LOGDIR} || (getpwuid($>))[7])
}ex;
return $path;
}
1;

5
log/run Executable file
View File

@ -0,0 +1,5 @@
#! /bin/sh
export LOGDIR=./main
mkdir -p $LOGDIR
exec multilog t s1000000 n20 $LOGDIR

182
packaging/rpm/Makefile Normal file
View File

@ -0,0 +1,182 @@
# -- generic Makefile for building RPM-based packages out of source
# code control systems (git, cvs, svn)
SCM_TYPE := git
SCM_PATH := ../../
#CVSROOT := $(shell cat 2>/dev/null src/CVS/Root)
#SVN_PATH := $(shell svn info ${SCM_PATH} 2>/dev/null | awk '/^URL:/{print $$2}')
#SVN_REV := $(shell svn info ${SVN_PATH} 2>/dev/null | awk '/^Last Changed Rev:/{print $$4}')
PACKAGE := $(shell cat PACKAGE)
VERSION := $(shell cat VERSION)
RELEASE := $(shell cat RELEASE)
BASE_VER := ${VERSION}-${RELEASE}
CURRENT_PACKAGE := $(PACKAGE)-$(BASE_VER)
TARBALL := $(CURRENT_PACKAGE).tar
DIRNAME := $(shell echo $${PWD})
DIRBASE := $(shell basename $${PWD})
.SUFFIXES:
.PHONY: clean mrclean distclean prepclean all default
.PHONY: rpm rpmdist buildrpm buildrpmdist
.PHONY: buildtarball buildtargz
.PHONY: builddir distdir prepbuildtarball
.PHONY: cvs-export git-export svn-export test-export
.PHONY: cvs-clean git-clean svn-clean test-clean
.PHONY: update
default: rpmdist
# -- the "rpmdist" target will build out of the SCM, but will
# use the user's default build settings (which in many cases
# is exposed as an RPM repository)
#
#rpmdist: buildrpmdist distclean
rpmdist: buildrpmdist
buildrpmdist: buildtargz
@rpmbuild \
--define "_package ${PACKAGE}" \
--define "_version ${VERSION}" \
--define "_release ${RELEASE}" \
-ta ./build/$(TARBALL).gz
# -- the "srpmdist" target will build an SRPM out of the SCM, but
# will use the user's default build settings (which in many
# cases is exposed as an RPM repository)
#
srpmdist: buildsrpmdist
buildsrpmdist: buildtargz
@rpmbuild \
--define "_package ${PACKAGE}" \
--define "_version ${VERSION}" \
--define "_release ${RELEASE}" \
-ts --nodeps ./build/$(TARBALL).gz
# -- the "rpm" target will build out of the SCM, but will leave
# the resulting package in the relative ./build/ directory
#
rpm: buildrpm $(SCM_TYPE)-clean
buildrpm: buildtargz
@echo ${PACKAGE} ${VERSION} ${RELEASE}
@rpmbuild \
--define "_rpmdir ./build/" \
--define "_sourcedir ./build/" \
--define "_srcrpmdir ./build/" \
--define "_package ${PACKAGE}" \
--define "_version ${VERSION}" \
--define "_release ${RELEASE}" \
-ta ./build/$(TARBALL).gz
# -- the "srpm" target will build an SRPM out of the SCM, but
# will leave the resulting package in the relative ./build/
# directory
#
srpm: buildsrpm $(SCM_TYPE)-clean
buildsrpm: buildtargz
@echo ${PACKAGE} ${VERSION} ${RELEASE}
@rpmbuild \
--define "_rpmdir ./build/" \
--define "_sourcedir ./build/" \
--define "_srcrpmdir ./build/" \
--define "_package ${PACKAGE}" \
--define "_version ${VERSION}" \
--define "_release ${RELEASE}" \
-ts --nodeps ./build/$(TARBALL).gz
buildtarball: prepbuildtarball
@tar \
--create \
--directory ./build/ \
--file ./build/$(TARBALL) \
${CURRENT_PACKAGE}
buildtargz: buildtarball
@gzip -c < ./build/$(TARBALL) > ./build/$(TARBALL).gz
prepbuildtarball: $(SCM_TYPE)-export
${MAKE} update \
&& cp ${PACKAGE}.spec ./build/${CURRENT_PACKAGE} \
&& cp files/* ./build/
test-clean:
@cd .. \
&& rm "$(CURRENT_PACKAGE)"
test-export: builddir
@cd .. \
&& ln -snvf $(DIRBASE) $(CURRENT_PACKAGE) \
&& tar \
--create \
--dereference \
--to-stdout \
--exclude "*.git*" \
--exclude "*.svn*" \
--exclude "*/CVS/*" \
--exclude "$(CURRENT_PACKAGE)/build/*" \
$(CURRENT_PACKAGE) \
| tar \
--extract \
--directory $(CURRENT_PACKAGE)/build/ \
--file -
git-export: builddir prepclean
(cd $(SCM_PATH) ; git archive --format=tar --prefix=$(CURRENT_PACKAGE)/ HEAD) \
| tar \
--extract \
--directory ./build/ \
--file -
git-clean:
@:
cvs-export: builddir prepclean
@cd ./build/ \
&& echo CURRENT_PACKAGE: ${CURRENT_PACKAGE} \
&& echo CVSROOT: ${CVSROOT} \
&& CVSROOT=${CVSROOT} cvs export -r HEAD -d$(CURRENT_PACKAGE) ${PACKAGE}
cvs-clean:
@:
svn-export: builddir prepclean
@cd ./build/ \
&& svn export $(SVN_PATH) $(CURRENT_PACKAGE)
svn-clean:
@:
builddir:
@mkdir -p ./build
distdir:
@mkdir -p ./dist
prepclean:
@rm -rf ./build/$(CURRENT_PACKAGE)*
clean:
@rm -rf ./build/* ./dist/* 2>/dev/null || :
mrclean: clean
distclean: clean $(SCM_TYPE)-clean
@rmdir ./build/ ./dist/ 2>/dev/null || :
# -- recursive Makefile calls (during build phase)
#
update: $(PACKAGE).spec VERSION RELEASE
$(PACKAGE).spec: VERSION RELEASE $(PACKAGE).spec.in
@sed \
-e "s|@PACKAGE@|$(PACKAGE)|" \
-e "s|@VERSION@|$(VERSION)|" \
-e "s|@RELEASE@|$(RELEASE)|" \
< $(PACKAGE).spec.in > $@
# -- end of Makefile

1
packaging/rpm/PACKAGE Normal file
View File

@ -0,0 +1 @@
qpsmtpd

1
packaging/rpm/RELEASE Normal file
View File

@ -0,0 +1 @@
0.1

1
packaging/rpm/VERSION Normal file
View File

@ -0,0 +1 @@
0.82

10
packaging/rpm/files/README.selinux Normal file
View File

@ -0,0 +1,10 @@
If you run qpsmtpd-apache on a box with SELinux enabled, you'll need to
allow apache to listen to your SMTP port, typically port 25.
The following command allows apache to listen on port 25:
semanage port -m -t http_port_t -p tcp 25
Use the -d option to remove this permission:
semanage port -d -t http_port_t -p tcp 25

3
packaging/rpm/files/in.qpsmtpd Executable file
View File

@ -0,0 +1,3 @@
#!/bin/sh
export QPSMTPD_CONFIG=/etc/qpsmtpd
exec /usr/bin/qpsmtpd 2> /dev/null

122
packaging/rpm/files/qpsmtpd-forkserver.rc Executable file
View File

@ -0,0 +1,122 @@
#! /bin/bash
#
# qpsmtpd-forkserver Start/Stop the qpsmtpd forking server
#
# chkconfig: 2345 90 60
# description: qpsmtpd is a flexible smtpd daemon written in Perl. \
# Apart from the core SMTP features, all functionality is \
# implemented in small "extension plugins" using the easy \
# to use object oriented plugin API.
# processname: qpsmtpd-forkserver
# config: /etc/qpsmtpd
# pidfile: /var/run/qpsmtpd-forkserver.pid
# Source function library.
. /etc/init.d/functions
. /etc/sysconfig/qpsmtpd-forkserver
RETVAL=0
# See how we were called.
prog="qpsmtpd-forkserver"
start() {
# cleanup environment a bit.
unset PERL_UNICODE
unset LANG
unset LC_TIME
unset LC_ALL
unset BASH_ENV
unset ENV
unset CDPATH
unset IFS
echo -n $"Starting $prog: "
trap "" 1
daemon $prog --detach $QPSMTPD_OPTIONS
RETVAL=$?
echo
[ $RETVAL -eq 0 ] && touch /var/lock/subsys/$prog
return $RETVAL
}
stop() {
echo -n $"Stopping $prog: "
killproc $prog
RETVAL=$?
echo
[ $RETVAL -eq 0 ] && rm -f /var/lock/subsys/$prog
return $RETVAL
}
# functions status() uses pidof, which doesn't work with (?) scripts
qpstatus() {
local base=${1##*/}
local pid
# Test syntax.
if [ "$#" = 0 ] ; then
echo $"Usage: status {program}"
return 1
fi
# Use "/var/run/*.pid" file for pid
if [ -f /var/run/${base}.pid ] ; then
read pid < /var/run/${base}.pid
if [ -n "$pid" ]; then
/bin/ps -p $pid >/dev/null
if [ $? -eq 0 ]; then
echo $"${base} (pid $pid) is running..."
return 0
else
echo $"${base} dead but pid file exists"
return 1
fi
fi
fi
# See if /var/lock/subsys/${base} exists
if [ -f /var/lock/subsys/${base} ]; then
echo $"${base} dead but subsys locked"
return 2
fi
echo $"${base} is stopped"
return 3
}
restart() {
stop
start
}
reload() {
stop
start
}
case "$1" in
start)
start
;;
stop)
stop
;;
restart)
restart
;;
reload)
reload
;;
status)
qpstatus qpsmtpd-forkserver
;;
condrestart)
[ -f /var/lock/subsys/$prog ] && restart || :
;;
*)
echo $"Usage: $0 {start|stop|status|reload|restart|condrestart}"
exit 1
esac
exit $?

3
packaging/rpm/files/qpsmtpd-forkserver.sysconfig Normal file
View File

@ -0,0 +1,3 @@
QPSMTPD_OPTIONS="-p 25 -l 127.0.0.1 --pid-file /var/run/qpsmtpd-forkserver.pid"
export QPSMTPD_CONFIG=/etc/qpsmtpd
export HOME=~smtpd

184
packaging/rpm/files/qpsmtpd-plugin-file_connection Normal file
View File

@ -0,0 +1,184 @@
#!/usr/bin/perl
# $Id: file 478 2005-07-19 07:40:16Z aqua $
=head1 NAME
file_connection - Simple per session log-to-file logging for qpsmtpd
=head1 DESCRIPTION
The 'file_connection' logging plugin for qpsmtpd records qpsmtpd log messages into a
file (or a named pipe, if you prefer.)
The file is reopened for each connection. To facilitate automatic
logfile switching the filename can contain strftime conversion
specifiers, which are expanded immediately before opening the file. This
ensures that a single connection is never split across logfiles.
The list of supported conversion specifiers depends on the strftime
implementation of your C library. See strftime(3) for details.
Additionally, %i exands to a (hopefully) unique session-id.
=head1 CONFIGURATION
To enable the logging plugin, add a line of this form to the qpsmtpd plugins
configuration file:
=over
logging/file_connection [loglevel I<level>] I<path>
For example:
logging/file_connection loglevel LOGINFO /var/log/qpsmtpd/%Y-%m-%d
=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 following optional configuration setting can be supplied:
=over
=item loglevel I<loglevel>
The internal log level below which messages will be logged. The I<loglevel>
given should be chosen from this list. 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 AUTHOR
Peter J. Holzer <hjp@hjp.at>, based on a plugin by
Devin Carraway <qpsmtpd@devin.com>
=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 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_connection plugin";
return;
}
if ($ll =~ /^(\d+)$/) {
$self->{_loglevel} = $1;
}
elsif ($ll =~ /^(LOG\w+)$/) {
$self->{_loglevel} = log_level($1);
defined $self->{_loglevel} or $self->{_loglevel} = LOGWARN;
}
}
else { last }
}
unless (@args && $args[0]) {
warn "Malformed arguments to syslog plugin";
return;
}
$self->{_logfile} = join(' ', @args);
$self->{_log_session_id_prefix} = sprintf("%08x%04x", time(), $$);
$self->{_log_session_id_counter} = 0;
$self->register_hook('logging', 'write_log');
$self->register_hook('pre-connection', 'open_log');
$self->open_log($qp);
}
sub open_log {
my ($self, $qp) = @_;
my $output = $self->{_logfile};
$self->{_log_session_id} =
$self->{_log_session_id_prefix} . "." .
++$self->{_log_session_id_counter};
$output =~ s/%i/$self->{_log_session_id}/;
$output = strftime($output, localtime);
#print STDERR "open_log: output=$output, uid=$>\n";
if ($output =~ /^\s*\|(.*)/) {
unless ($self->{_f} = new IO::File "|$1") {
warn "Error opening log output to command $1: $!";
return;
}
} elsif ($output =~ /^(.*)/) { # detaint
unless ($self->{_f} = new IO::File ">>$1") {
warn "Error opening log output to path $1: $!";
return;
}
}
$self->{_f}->autoflush(1);
return DECLINED;
}
sub write_log {
my ($self, $txn, $trace, $hook, $plugin, @log) = @_;
return DECLINED if $trace > $self->{_loglevel};
return DECLINED if defined $plugin and $plugin eq $self->plugin_name;
$self->open_log unless($self->{_f});
my $f = $self->{_f};
print STDERR "no open file\n" unless (defined $f);
print $f join(" ",
strftime("%Y-%m-%dT%H:%M:%S%z", localtime), $self->{_log_session_id},
(defined $plugin ? " $plugin plugin:" :
defined $hook ? " running plugin ($hook):" : ""),
@log), "\n";
return DECLINED;
}
# vi: tabstop=4 shiftwidth=4 expandtab:

19
packaging/rpm/files/qpsmtpd-xinetd Normal file
View File

@ -0,0 +1,19 @@
# default: on
# description: The telnet server serves telnet sessions; it uses \
# unencrypted username/password pairs for authentication.
service smtp
{
flags = REUSE
socket_type = stream
wait = no
user = smtpd
groups = yes
server = /usr/sbin/in.qpsmtpd
log_on_failure += USERID
disable = yes
rlimit_as = 128M
instances = 40
per_source = 10
cps = 50 10
}

16
packaging/rpm/files/qpsmtpd.conf Normal file
View File

@ -0,0 +1,16 @@
Listen 0.0.0.0:25 smtp
AcceptFilter smtp none
## "smtp" and the AcceptFilter are required for Linux, FreeBSD
## with apache >= 2.1.5, for others it doesn't hurt. See also
## http://httpd.apache.org/docs/2.2/mod/core.html#acceptfilter
## and http://httpd.apache.org/docs/2.2/mod/mpm_common.html#listen
<Perl>
use Apache::Qpsmtpd;
$ENV{QPSMTPD_CONFIG} = "/etc/qpsmtpd";
</Perl>
<VirtualHost _default_:25>
PerlModule Apache::Qpsmtpd
PerlProcessConnectionHandler Apache::Qpsmtpd
</VirtualHost>

335
packaging/rpm/qpsmtpd.spec.in Normal file
View File

@ -0,0 +1,335 @@
Name: %{_package}
Version: %{_version}
Release: %{_release}
Summary: qpsmtpd + qpsmtpd-apache + qpsmtpd-async
License: MIT
Group: System Environment/Daemons
URL: http://smtpd.develooper.com/
BuildRoot: %{_builddir}/%{name}-%{version}-%{release}-root
BuildRequires: perl >= 0:5.00503
BuildArchitectures: noarch
Requires: perl(Mail::Header), perl(Net::DNS) perl(Net::IP) perl(IPC::Shareable)
Requires(pre): coreutils, shadow-utils, perl
Source0: %{name}-%{version}-%{release}.tar.gz
Source1: qpsmtpd-forkserver.rc
Source2: qpsmtpd-forkserver.sysconfig
Source3: qpsmtpd-plugin-file_connection
Source4: qpsmtpd-xinetd
Source5: in.qpsmtpd
Source6: qpsmtpd.conf
Source7: README.selinux
%description
qpsmtpd is a flexible smtpd daemon written in Perl. Apart from the core
SMTP features, all functionality is implemented in small "extension
plugins" using the easy to use object oriented plugin API.
qpsmtpd was originally written as a drop-in qmail-smtpd replacement, but
now it also includes a smtp forward and a postfix "backend".
%package apache
Requires: perl(mod_perl2)
Summary: mod_perl-2 connection handler for qpsmtpd
Group: System Environment/Daemons
%package async
Summary: qpsmtpd using async I/O in a single process
Group: System Environment/Daemons
%description apache
This module implements a mod_perl/apache 2.0 connection handler
that turns Apache into an SMTP server using Qpsmtpd.
%description async
This package contains the Qpsmtpd::PollServer module, which allows
qpsmtd to handle many connections in a single process and the
qpsmpd-async which uses it.
%prep
%setup -q -n %{name}-%{version}-%{release}
%build
CFLAGS="$RPM_OPT_FLAGS" perl Makefile.PL INSTALLSITELIB=%{_prefix}/lib/perl5/site_perl
make
%clean
rm -rf $RPM_BUILD_ROOT
%install
rm -rf $RPM_BUILD_ROOT
eval `perl '-V:installarchlib'`
mkdir -p $RPM_BUILD_ROOT/$installarchlib
if grep -q DESTDIR Makefile
then
make DESTDIR=$RPM_BUILD_ROOT
find blib/lib -name '*.pm.*' -exec rm -f {} \;
make DESTDIR=$RPM_BUILD_ROOT install
else
make PREFIX=$RPM_BUILD_ROOT/usr
find blib/lib -name '*.pm.*' -exec rm -f {} \;
make PREFIX=$RPM_BUILD_ROOT/usr install
fi
mkdir -p ${RPM_BUILD_ROOT}%{_datadir}/%{name}
rm -f ${RPM_BUILD_ROOT}%{_datadir}/%{name}/plugins/*.*
cp -r plugins ${RPM_BUILD_ROOT}%{_datadir}/%{name}/plugins
mkdir -p ${RPM_BUILD_ROOT}%{_sysconfdir}/%{name}
rm -f ${RPM_BUILD_ROOT}%{_sysconfdir}/%{name}/*.*
cp -r config.sample/* ${RPM_BUILD_ROOT}%{_sysconfdir}/%{name}/
echo %{_datadir}/%{name}/plugins > ${RPM_BUILD_ROOT}%{_sysconfdir}/%{name}/plugin_dirs
echo %{_localstatedir}/spool/qpsmtpd > ${RPM_BUILD_ROOT}%{_sysconfdir}/%{name}/spool_dir
echo logging/file_connection loglevel LOGINFO %{_localstatedir}/log/qpsmtpd/%Y-%m-%d > ${RPM_BUILD_ROOT}%{_sysconfdir}/%{name}/logging
mkdir -p ${RPM_BUILD_ROOT}%{_initrddir}
cp %{SOURCE1} ${RPM_BUILD_ROOT}%{_initrddir}/qpsmtpd-forkserver
mkdir -p ${RPM_BUILD_ROOT}%{_sysconfdir}/sysconfig
cp %{SOURCE2} ${RPM_BUILD_ROOT}%{_sysconfdir}/sysconfig/qpsmtpd-forkserver
cp %{SOURCE3} ${RPM_BUILD_ROOT}%{_datadir}/%{name}/plugins/logging/file_connection
mkdir -p ${RPM_BUILD_ROOT}%{_localstatedir}/spool/qpsmtpd
mkdir -p ${RPM_BUILD_ROOT}%{_localstatedir}/log/qpsmtpd
mkdir -p ${RPM_BUILD_ROOT}%{_sysconfdir}/xinetd.d
cp %{SOURCE4} ${RPM_BUILD_ROOT}%{_sysconfdir}/xinetd.d/smtp
mkdir -p ${RPM_BUILD_ROOT}%{_sbindir}
cp %{SOURCE5} ${RPM_BUILD_ROOT}%{_sbindir}/in.smtp
mkdir -p ${RPM_BUILD_ROOT}%{_sysconfdir}/httpd/conf.d
cp %{SOURCE6} ${RPM_BUILD_ROOT}%{_sysconfdir}/httpd/conf.d
mkdir -p $RPM_BUILD_ROOT%{_docdir}/%{name}-apache-%{version}
cp %{SOURCE7} $RPM_BUILD_ROOT%{_docdir}/%{name}-apache-%{version}
[ -x /usr/lib/rpm/brp-compress ] && /usr/lib/rpm/brp-compress
find ${RPM_BUILD_ROOT}%{_prefix} \( -name perllocal.pod -o -name .packlist \) -exec rm {} \;
find ${RPM_BUILD_ROOT}%{_prefix} -type f -print | \
sed "s@^$RPM_BUILD_ROOT@@g" | \
grep -v [Aa]sync | \
grep -v packaging | \
grep -v README.selinux | \
grep -v /Apache | \
grep -v /Danga | \
grep -v Qpsmtpd/ConfigServer.pm | \
grep -v Qpsmtpd/PollServer.pm > %{name}-%{version}-%{release}-filelist
if [ "$(cat %{name}-%{version}-%{release}-filelist)X" = "X" ] ; then
echo "ERROR: EMPTY FILE LIST"
exit -1
fi
%files -f %{name}-%{version}-%{release}-filelist
%defattr(-,root,root)
%doc CREDITS Changes LICENSE README README.plugins STATUS
%{_initrddir}/qpsmtpd-forkserver
%config(noreplace) %{_sysconfdir}/qpsmtpd/*
%config(noreplace) %{_sysconfdir}/xinetd.d/smtp
%config(noreplace) %{_sysconfdir}/sysconfig/qpsmtpd-forkserver
%attr(2750,qpsmtpd,clamav) %dir %{_localstatedir}/spool/qpsmtpd
%attr(0750,smtpd,smtpd) %dir %{_localstatedir}/log/qpsmtpd
%files apache
%defattr(-,root,root)
%{_prefix}/lib/perl5/site_perl/Apache/Qpsmtpd.pm
%{_mandir}/man3/Apache::Qpsmtpd.3pm.gz
%config(noreplace) %{_sysconfdir}/httpd/conf.d/*
%doc %{_docdir}/%{name}-apache-%{version}/README.selinux
%files async
%defattr(-,root,root)
%{_bindir}/qpsmtpd-async
%{_prefix}/lib/perl5/site_perl/Danga/Client.pm
%{_prefix}/lib/perl5/site_perl/Danga/TimeoutSocket.pm
%{_prefix}/lib/perl5/site_perl/Qpsmtpd/ConfigServer.pm
%{_prefix}/lib/perl5/site_perl/Qpsmtpd/Plugin/Async/DNSBLBase.pm
%{_prefix}/lib/perl5/site_perl/Qpsmtpd/PollServer.pm
%{_mandir}/man1/qpsmtpd-async.1.gz
%{_datadir}/%{name}/plugins/async/*
%pre
if ! id smtpd >/dev/null 2>&1
then
# need to create smtpd user.
if perl -e 'exit ! defined(getgrnam("postdrop"))'
then
# if postfix is installed, we will probably use
# queue/postfix, which will need this:
supp="-G postdrop"
fi
useradd -r -M -s /bin/false $supp smtpd
fi
%changelog
* Sun Jul 12 2009 <rpmbuild@robinbowes.com> 0.82-0.1
- Update to latest release
- don't add qpsmtpd to start-up by default
- add apache config file to qpsmtpd-apache package
- remove all patches
- use rpm macros for dirs
- use a filelist for main package instead of a long list of files
* Tue Jul 15 2008 <rpmbuild@robinbowes.com> 0.43-0.7
- Removed SelectServer.pm from .spec file
* Tue Mar 18 2008 <rpmbuild@robinbowes.com> 0.43-0.6
- moved config files back to /etc/qpsmtpd following some changes
to the qpsmtpd src
* Tue Mar 18 2008 <rpmbuild@robinbowes.com> 0.43-0.5
- moved config files to /etc/qpsmtpd/config
* Tue Mar 18 2008 <rpmbuild@robinbowes.com> 0.43-0.4
- Moved qpsmtpd-async to /usr/bin
- Added qpsmtpd-async man page to async package
- Added async smtproute plugin to async package
* Wed Mar 12 2008 <rpmbuild@robinbowes.com> 0.43-0.3
- Makefile.PL now updated in svn, so remove hack
* Wed Mar 12 2008 <rpmbuild@robinbowes.com> 0.43-0.2
- Added qpsmtpd-prefork to qpsmtpd RPM, inc. hack to work round
deficiency in Makefile.PL
* Mon Mar 10 2008 <rpmbuild@robinbowes.com> 0.43-0.1
- Updated to work with Makefile to build from svn
* Wed Sep 12 2007 <rpmbuild@robinbowes.com> 0.40-2.0
- Updated to build trunk-r790
* Tue Jun 12 2007 <hjp@hjp.at> 0.40-1.0
- updated to 0.40 - no code change.
* Thu Jun 07 2007 <hjp@hjp.at> 0.40-0.2
- unset environment variables which are normally tainted in perl.
- updated to 0.40rc1
- added dependency on Net::IP (needed by some plugins)
* Sat May 05 2007 <hjp@hjp.at> 0.33-0.5
- moved environment cleanup into start() function, otherwise
LANG just gets reinitialized.
* Sat May 05 2007 <hjp@hjp.at> 0.33-0.4
- split qpsmtpd-async into a separate package to avoid dependency
on ParaDNS.
* Sat May 05 2007 <hjp@hjp.at> 0.33-0.3
- also unset LANG, LC_ALL and LC_TIME in startup script to prevent
locale specific Received headers (bug reported by Dominik Meyer)
* Sun Feb 25 2007 <hjp@hjp.at> 0.33-0.2
- 0.3x branch has been merged back to trunk.
Got current snapshot (r715) from trunk.
* Sun Feb 25 2007 <hjp@hjp.at> 0.33-0.1
- Start forkserver via "daemon" (Gavin Carr)
- Fixed 'service qpsmtpd-forkserver status' (Gavin Carr)
- Changed policy for config files to noreplace (Gavin Carr)
* Sun Nov 05 2006 <hjp@hjp.at> 0.33-0.0
- Upgraded to current snapshot from 0.3x branch (which should become
0.33 soon-ish)
- included xinetd-support again.
* Sat Mar 18 2006 <hjp@hjp.at> 0.32-2
- fix dnsbl to check whether answer fits query.
- randomize Net::DNS ids for qpsmtpd-forkserver child processes.
* Wed Mar 08 2006 <hjp@hjp.at> 0.32-1
- New upstream 0.32
- rc-file unsets PERL_UNICODE (bug #38397)
* Sat Jan 28 2006 <hjp@hjp.at> 0.31.1-3
- Use ${SOURCE*} macros to refer to source files
- Avoid invoking rpm and other cleanup in pre section
- Invoke chkconfig in post.
- (Thanks to Josko Plazonic for the reporting these problems and
suggesting fixes)
* Tue Nov 30 2005 <hjp@hjp.at> 0.31.1-2
- Revision 170 of plugins/loggin/file_connection:
Return DECLINED from open_log.
Open log in write_log if it isn't already open.
* Tue Nov 29 2005 <hjp@hjp.at> 0.31.1-1
- Commented out queue plugins from sample config
- Added dependencies
- Create smtpd user if it doesn't exist
- Added /var/log/qpsmtpd and /var/spool/qpsmtpd
* Sat Nov 26 2005 <hjp@hjp.at>
- Added file_connection plugin
- Startup file for qpsmtpd-forkserver now uses --detach and assumes that
a suitable logging module is configured (file_connection by default)
* Wed Nov 23 2005 <hjp@hjp.at>
- Forkserver drops privileges before loading plugins now.
* Sun Nov 20 2005 <hjp@hjp.at>
- New upstream 0.31.1
* Mon Nov 14 2005 <hjp@hjp.at> 0.31-8
- New upstream 0.31rc3.
- pre-connection patch slightly simplified since upstream fixed one of
the bugs.
* Tue Aug 23 2005 <hjp@hjp.at>
- forced INSTALLSITELIB=/usr/lib/perl5/site_perl as suggested by
Charlie Brady.
* Sat Aug 20 2005 <hjp@hjp.at> 0.31-7
- RC2 from upstream.
- Removed patches which aren't applied from spec file.
* Fri Jul 22 2005 <hjp@hjp.at> 0.31-6
- New upstream snapshot from 0.31 branch: svn revision 509.
* Sun Jul 17 2005 <hjp@hjp.at> 0.31-5
- include only /etc/init.d/qpsmtpd-forkserver, not /etc/init.d
it conflicts with old initscripts packages.
* Sun Jul 17 2005 <hjp@hjp.at> 0.31-4
- removed tabs from forkserver
* Sun Jul 17 2005 <hjp@hjp.at> 0.31-3
- added startup script for forkserver
- changed BuildArchitectures to noarch.
* Sat Jul 16 2005 <hjp@hjp.at> 0.31-2
- pre-connection hook is now actually called, not just defined.
* Fri Jul 15 2005 <hjp@hjp.at> 0.31-1
- merged with 0.31. Most of my patches are now in the official release.
- merged Gavin's per-user-config patch with my dirs patch, since the
latter needs a way to turn off logging.
- added /etc/qpsmtpd/plugin_dir to package.
* Mon Jun 13 2005 <hjp@hjp.at> 0.29-6
- fixed removal of patch backup files
- fixed option --pid-file
* Sun Jun 12 2005 <hjp@hjp.at>
- avoid installing patch backup files
- split Apache::Qpsmtpd into separate package to avoid dependency hell.
- fixed URL
- changed group to Daemons.
- Fixed installation for newer versions of ExtUtils::MakeMaker
* Wed Jun 1 2005 <hjp@hjp.at> 0.29-5
- Really don't reap children in signal handler.
* Tue May 31 2005 <hjp@hjp.at> 0.29-4
- Return 421 for DENYSOFT_DISCONNECT
- Don't reap children in signal handler.
* Thu May 19 2005 <hjp@hjp.at> 0.29-3
- removed code to accept paths without <>.
* Thu May 19 2005 <hjp@hjp.at> 0.29-2
- added QPSMTPD_CONFIG env variable and plugin_dir config.
- added supplemental groups and support for pid file
- added shared_connect hook
- changed log level for SMTP dialog from DEBUG to INFO
* Thu Apr 21 2005 hjp@hjp.at
- added plugins, /etc and docs.
* Mon Apr 18 2005 hjp@hjp.at
- Specfile autogenerated

134
plugins/async/check_earlytalker Normal file
View File

@ -0,0 +1,134 @@
#!perl -w
=head1 NAME
check_earlytalker - Check that the client doesn't talk before we send the SMTP banner
=head1 DESCRIPTION
Checks to see if the remote host starts talking before we've issued a 2xx
greeting. If so, we're likely looking at a direct-to-MX spam agent which
pipelines its entire SMTP conversation, and will happily dump an entire spam
into our mail log even if later tests deny acceptance.
Depending on configuration, clients which behave in this way are either
immediately disconnected with a deny or denysoft code, or else are issued this
on all mail/rcpt commands in the transaction.
=head1 CONFIGURATION
=over 4
=item wait [integer]
The number of seconds to delay the initial greeting to see if the connecting
host speaks first. The default is 1. Do not select a value that is too high,
or you may be unable to receive mail from MTAs with short SMTP connect or
greeting timeouts -- these are known to range as low as 30 seconds, and may
in some cases be configured lower by mailserver admins. Network transit time
must also be allowed for.
=item action [string: deny, denysoft, log]
What to do when matching an early-talker -- the options are I<deny>,
I<denysoft> or I<log>.
If I<log> is specified, the connection will be allowed to proceed as normal,
and only a warning will be logged.
The default is I<denysoft>.
=item defer-reject [boolean]
When an early-talker is detected, if this option is set to a true value, the
SMTP greeting will be issued as usual, but all RCPT/MAIL commands will be
issued a deny or denysoft (depending on the value of I<action>). The default
is to react at the SMTP greeting stage by issuing the apropriate response code
and terminating the SMTP connection.
=item check-at [string: connect, data]
Defines when to check for early talkers, either at connect time (pre-greet pause)
or at DATA time (pause before sending "354 go ahead").
The default is I<connect>.
Note that defer-reject has no meaning if check-at is I<data>.
=back
=cut
my $MSG = 'Connecting host started transmitting before SMTP greeting';
sub register {
my ($self, $qp, @args) = @_;
if (@args % 2) {
$self->log(LOGERROR, "Unrecognized/mismatched arguments");
return undef;
}
$self->{_args} = {
'wait' => 1,
'action' => 'denysoft',
'defer-reject' => 0,
'check-at' => 'connect',
@args,
};
print STDERR "Check at: ", $self->{_args}{'check-at'}, "\n";
$self->register_hook($self->{_args}->{'check-at'}, 'check_talker_poll');
$self->register_hook($self->{_args}->{'check-at'}, 'check_talker_post');
if ($self->{_args}{'check-at'} eq 'connect') {
$self->register_hook('mail', 'hook_mail')
if $self->{_args}->{'defer-reject'};
}
1;
}
sub check_talker_poll {
my ($self, $transaction) = @_;
my $qp = $self->qp;
my $conn = $qp->connection;
my $check_until = time + $self->{_args}{'wait'};
$qp->AddTimer(1, sub { read_now($qp, $conn, $check_until, $self->{_args}{'check-at'}) });
return YIELD;
}
sub read_now {
my ($qp, $conn, $until, $phase) = @_;
if ($qp->has_data) {
$qp->log(LOGNOTICE, 'remote host started talking after $phase before we responded');
$qp->clear_data if $phase eq 'data';
$conn->notes('earlytalker', 1);
$qp->run_continuation;
}
elsif (time >= $until) {
# no early talking
$qp->run_continuation;
}
else {
$qp->AddTimer(1, sub { read_now($qp, $conn, $until, $phase) });
}
}
sub check_talker_post {
my ($self, $transaction) = @_;
return DECLINED unless $self->connection->notes('earlytalker');
return DECLINED if $self->{'defer-reject'};
return (DENY,$MSG) if $self->{_args}->{'action'} eq 'deny';
return (DENYSOFT,$MSG) if $self->{_args}->{'action'} eq 'denysoft';
return DECLINED; # assume action eq 'log'
}
sub hook_mail {
my ($self, $transaction) = @_;
return DECLINED unless $self->connection->notes('earlytalker');
return (DENY,$MSG) if $self->{_args}->{'action'} eq 'deny';
return (DENYSOFT,$MSG) if $self->{_args}->{'action'} eq 'denysoft';
return DECLINED;
}

88
plugins/async/dns_whitelist_soft Normal file
View File

@ -0,0 +1,88 @@
#!perl -w
use Qpsmtpd::Plugin::Async::DNSBLBase;
sub init {
my $self = shift;
my $class = ref $self;
no strict 'refs';
push @{"${class}::ISA"}, 'Qpsmtpd::Plugin::Async::DNSBLBase';
}
sub hook_connect {
my ($self, $transaction) = @_;
my $class = ref $self;
my %whitelist_zones =
map { (split /\s+/, $_, 2)[0, 1] } $self->qp->config('whitelist_zones');
return DECLINED unless %whitelist_zones;
my $remote_ip = $self->connection->remote_ip;
my $reversed_ip = join(".", reverse(split(/\./, $remote_ip)));
# type TXT lookup only
return DECLINED
unless $class->lookup($self->qp, [],
[map { "$reversed_ip.$_" } keys %whitelist_zones],
);
return YIELD;
}
sub process_txt_result {
my ($class, $qp, $result, $query) = @_;
my $connection = $qp->connection;
$connection->notes('whitelisthost', $result)
unless $connection->notes('whitelisthost');
}
sub hook_rcpt {
my ($self, $transaction, $rcpt) = @_;
my $connection = $self->qp->connection;
if (my $note = $connection->notes('whitelisthost')) {
my $ip = $connection->remote_ip;
$self->log(LOGNOTICE, "Host $ip is whitelisted: $note");
}
return DECLINED;
}
=head1 NAME
dns_whitelist_soft - dns-based whitelist override for other qpsmtpd plugins
=head1 DESCRIPTION
The dns_whitelist_soft plugin allows selected host to be whitelisted as
exceptions to later plugin processing. It is most suitable for multisite
installations, so that the whitelist is stored in one location and available
from all.
=head1 CONFIGURATION
To enable the plugin, add it to the ~qpsmtpd/config/plugins file as usual.
It should precede any plugins whose rejections you wish to override. You may
have to alter those plugins to check the appropriate notes field.
Several configuration files are supported, corresponding to different
parts of the SMTP conversation:
=over 4
=item whitelist_zones
Any IP address listed in the whitelist_zones file is queried using
the connecting MTA's IP address. Any A or TXT answer means that the
remote HOST address can be selectively exempted at other stages by plugins
testing for a 'whitelisthost' connection note.
=back
NOTE: in contrast to the non-async version, the other 'connect' hooks
fired after the 'connect' hook of this plugin will see the 'whitelisthost'
connection note, if set by this plugin.
=cut

202
plugins/async/dnsbl Normal file
View File

@ -0,0 +1,202 @@
#!perl -w
use Qpsmtpd::Plugin::Async::DNSBLBase;
sub init {
my ($self, $qp, $denial) = @_;
my $class = ref $self;
{
no strict 'refs';
push @{"${class}::ISA"}, 'Qpsmtpd::Plugin::Async::DNSBLBase';
}
if (defined $denial and $denial =~ /^disconnect$/i) {
$self->{_dnsbl}->{DENY} = DENY_DISCONNECT;
}
else {
$self->{_dnsbl}->{DENY} = DENY;
}
}
sub hook_connect {
my ($self, $transaction) = @_;
my $class = ref $self;
my $remote_ip = $self->connection->remote_ip;
my $allow =
grep { s/\.?$/./; $_ eq substr($remote_ip . '.', 0, length $_) }
$self->qp->config('dnsbl_allow');
return DECLINED if $allow;
my %dnsbl_zones =
map { (split /:/, $_, 2)[0, 1] } $self->qp->config('dnsbl_zones');
return DECLINED unless %dnsbl_zones;
my $reversed_ip = join(".", reverse(split(/\./, $remote_ip)));
my @A_zones = grep { defined($dnsbl_zones{$_}) } keys %dnsbl_zones;
my @TXT_zones = grep { !defined($dnsbl_zones{$_}) } keys %dnsbl_zones;
if (@A_zones) {
# message templates for responding to the client
$self->connection->notes(
dnsbl_templates => {
map {
+"$reversed_ip.$_" => $dnsbl_zones{$_}
} @A_zones
}
);
}
return DECLINED
unless $class->lookup($self->qp,
[map { "$reversed_ip.$_" } @A_zones],
[map { "$reversed_ip.$_" } @TXT_zones],
);
return YIELD;
}
sub process_a_result {
my ($class, $qp, $result, $query) = @_;
my $conn = $qp->connection;
return if $class->connection->notes('dnsbl');
my $templates = $class->connection->notes('dnsbl_templates');
my $ip = $conn->remote_ip;
my $template = $templates->{$query};
$template =~ s/%IP%/$ip/g;
$class->connection->notes('dnsbl', $template);
}
sub process_txt_result {
my ($class, $qp, $result, $query) = @_;
my $conn = $class->connection;
$conn->notes('dnsbl', $result) unless $conn->notes('dnsbl');
}
sub hook_rcpt {
my ($self, $transaction, $rcpt) = @_;
my $connection = $self->qp->connection;
# RBLSMTPD being non-empty means it contains the failure message to return
if (defined($ENV{'RBLSMTPD'}) && $ENV{'RBLSMTPD'} ne '') {
my $result = $ENV{'RBLSMTPD'};
my $remote_ip = $self->connection->remote_ip;
$result =~ s/%IP%/$remote_ip/g;
return (DENY, join(" ", $self->qp->config('dnsbl_rejectmsg'), $result));
}
my $note = $self->connection->notes('dnsbl');
return (DENY, $note) if $note;
return DECLINED;
}
=head1 NAME
dnsbl - handle DNS BlackList lookups
=head1 DESCRIPTION
Plugin that checks the IP address of the incoming connection against
a configurable set of RBL services.
=head1 Configuration files
This plugin uses the following configuration files. All of these are optional.
However, not specifying dnsbl_zones is like not using the plugin at all.
=over 4
=item dnsbl_zones
Normal ip based dns blocking lists ("RBLs") which contain TXT records are
specified simply as:
relays.ordb.org
spamsources.fabel.dk
To configure RBL services which do not contain TXT records in the DNS,
but only A records (e.g. the RBL+ at http://www.mail-abuse.org), specify your
own error message to return in the SMTP conversation after a colon e.g.
rbl-plus.mail-abuse.org:You are listed at - http://http://www.mail-abuse.org/cgi-bin/lookup?%IP%
The string %IP% will be replaced with the IP address of incoming connection.
Thus a fully specified file could be:
sbl-xbl.spamhaus.org
list.dsbl.org
rbl-plus.mail-abuse.ja.net:Listed by rbl-plus.mail-abuse.ja.net - see <URL:http://www.mail-abuse.org/cgi-bin/lookup?%IP%>
relays.ordb.org
=item dnsbl_allow
List of allowed ip addresses that bypass RBL checking. Format is one entry per line,
with either a full IP address or a truncated IP address with a period at the end.
For example:
192.168.1.1
172.16.33.
NB the environment variable RBLSMTPD is considered before this file is
referenced. See below.
=item dnsbl_rejectmsg
A textual message that is sent to the sender on an RBL failure. The TXT record
from the RBL list is also sent, but this file can be used to indicate what
action the sender should take.
For example:
If you think you have been blocked in error, then please forward
this entire error message to your ISP so that they can fix their problems.
The next line often contains a URL that can be visited for more information.
=back
=head1 Environment Variables
=head2 RBLSMTPD
The environment variable RBLSMTPD is supported and mimics the behaviour of
Dan Bernstein's rblsmtpd. The exception to this is the '-' char at the
start of RBLSMTPD which is used to force a hard error in Dan's rblsmtpd.
NB I don't really see the benefit
of using a soft error for a site in an RBL list. This just complicates
things as it takes 7 days (or whatever default period) before a user
gets an error email back. In the meantime they are complaining that their
emails are being "lost" :(
=over 4
=item RBLSMTPD is set and non-empty
The contents are used as the SMTP conversation error.
Use this for forcibly blocking sites you don't like
=item RBLSMTPD is set, but empty
In this case no RBL checks are made.
This can be used for local addresses.
=item RBLSMTPD is not set
All RBL checks will be made.
This is the setting for remote sites that you want to check against RBL.
=back
=head1 Revisions
See: http://cvs.perl.org/viewcvs/qpsmtpd/plugins/dnsbl
=cut

400
plugins/async/queue/smtp-forward Normal file
View File

@ -0,0 +1,400 @@
#!perl -w
=head1 NAME
smtp-forward
=head1 DESCRIPTION
This plugin forwards the mail via SMTP to a specified server, rather than
delivering the email locally.
=head1 CONFIG
It takes one required parameter, the IP address or hostname to forward to.
async/queue/smtp-forward 10.2.2.2
Optionally you can also add a port:
async/queue/smtp-forward 10.2.2.2 9025
=cut
use Qpsmtpd::Constants;
sub register {
my ($self, $qp) = @_;
$self->register_hook(queue => "start_queue");
$self->register_hook(queue => "finish_queue");
}
sub init {
my ($self, $qp, @args) = @_;
if (@args > 0) {
if ($args[0] =~ /^([\.\w_-]+)$/) {
$self->{_smtp_server} = $1;
}
else {
die "Bad data in smtp server: $args[0]";
}
$self->{_smtp_port} = 25;
if (@args > 1 and $args[1] =~ /^(\d+)$/) {
$self->{_smtp_port} = $1;
}
$self->log(LOGWARN, "WARNING: Ignoring additional arguments.") if (@args > 2);
}
else {
die("No SMTP server specified in smtp-forward config");
}
}
sub start_queue {
my ($self, $transaction) = @_;
my $qp = $self->qp;
my $SERVER = $self->{_smtp_server};
my $PORT = $self->{_smtp_port};
$self->log(LOGINFO, "forwarding to $SERVER:$PORT");
$transaction->notes('async_sender',
AsyncSMTPSender->new($SERVER, $PORT, $qp, $self, $transaction)
);
return YIELD;
}
sub finish_queue {
my ($self, $transaction) = @_;
my $sender = $transaction->notes('async_sender');
$transaction->notes('async_sender', undef);
my ($rc, $msg) = $sender->results;
return $rc, $msg;
}
package AsyncSMTPSender;
use IO::Socket;
use base qw(Danga::Socket);
use fields qw(
qp
pkg
tran
state
rcode
rmsg
buf
command
resp
to
);
use constant ST_CONNECTING => 0;
use constant ST_CONNECTED => 1;
use constant ST_COMMANDS => 2;
use constant ST_DATA => 3;
use Qpsmtpd::Constants;
sub new {
my ($self, $server, $port, $qp, $pkg, $transaction) = @_;
$self = fields::new($self) unless ref $self;
my $sock = IO::Socket::INET->new(
PeerAddr => $server,
PeerPort => $port,
Blocking => 0,
) or die "Error connecting to server $server:$port : $!\n";
IO::Handle::blocking($sock, 0);
binmode($sock, ':raw');
$self->{qp} = $qp;
$self->{pkg} = $pkg;
$self->{tran} = $transaction;
$self->{state} = ST_CONNECTING;
$self->{rcode} = DECLINED;
$self->{command} = 'connect';
$self->{buf} = '';
$self->{resp} = [];
# copy the recipients so we can pop them off one by one
$self->{to} = [ $transaction->recipients ];
$self->SUPER::new($sock);
# Watch for write first, this is when the TCP session is established.
$self->watch_write(1);
return $self;
}
sub results {
my AsyncSMTPSender $self = shift;
return ( $self->{rcode}, $self->{rmsg} );
}
sub log {
my AsyncSMTPSender $self = shift;
$self->{qp}->log(@_);
}
sub cont {
my AsyncSMTPSender $self = shift;
$self->{qp}->run_continuation;
}
sub command {
my AsyncSMTPSender $self = shift;
my ($command, $params) = @_;
$params ||= '';
$self->log(LOGDEBUG, ">> $command $params");
$self->write(($command =~ m/ / ? "$command:" : $command)
. ($params ? " $params" : "") . "\r\n");
$self->watch_read(1);
$self->{command} = ($command =~ /(\S+)/)[0];
}
sub handle_response {
my AsyncSMTPSender $self = shift;
my $method = "cmd_" . lc($self->{command});
$self->$method(@_);
}
sub cmd_connect {
my AsyncSMTPSender $self = shift;
my ($code, $response) = @_;
if ($code != 220) {
$self->{rmsg} = "Error on connect: @$response";
$self->close;
$self->cont;
}
else {
my $host = $self->{qp}->config('me');
print "HELOing with $host\n";
$self->command((join '', @$response) =~ m/ ESMTP/ ? "EHLO" : "HELO", $host);
}
}
sub cmd_helo {
my AsyncSMTPSender $self = shift;
my ($code, $response) = @_;
if ($code != 250) {
$self->{rmsg} = "Error on HELO: @$response";
$self->close;
$self->cont;
}
else {
$self->command("MAIL", "FROM:" . $self->{tran}->sender->format);
}
}
sub cmd_ehlo {
my AsyncSMTPSender $self = shift;
my ($code, $response) = @_;
if ($code != 250) {
$self->{rmsg} = "Error on EHLO: @$response";
$self->close;
$self->cont;
}
else {
$self->command("MAIL", "FROM:" . $self->{tran}->sender->format);
}
}
sub cmd_mail {
my AsyncSMTPSender $self = shift;
my ($code, $response) = @_;
if ($code != 250) {
$self->{rmsg} = "Error on MAIL FROM: @$response";
$self->close;
$self->cont;
}
else {
$self->command("RCPT", "TO:" . shift(@{$self->{to}})->format);
}
}
sub cmd_rcpt {
my AsyncSMTPSender $self = shift;
my ($code, $response) = @_;
if ($code != 250) {
$self->{rmsg} = "Error on RCPT TO: @$response";
$self->close;
$self->cont;
}
else {
if (@{$self->{to}}) {
$self->command("RCPT", "TO:" . shift(@{$self->{to}})->format);
}
else {
$self->command("DATA");
}
}
}
sub cmd_data {
my AsyncSMTPSender $self = shift;
my ($code, $response) = @_;
if ($code != 354) {
$self->{rmsg} = "Error on DATA: @$response";
$self->close;
$self->cont;
}
else {
# $self->{state} = ST_DATA;
$self->datasend($self->{tran}->header->as_string);
$self->{tran}->body_resetpos;
my $write_buf = '';
while (my $line = $self->{tran}->body_getline) {
$line =~ s/\r?\n/\r\n/;
$write_buf .= $line;
if (length($write_buf) >= 131072) { # 128KB, arbitrary value
$self->log(LOGDEBUG, ">> $write_buf");
$self->datasend($write_buf);
$write_buf = '';
}
}
if (length($write_buf)) {
$self->log(LOGDEBUG, ">> $write_buf");
$self->datasend($write_buf);
}
$self->write(".\r\n");
$self->{command} = "DATAEND";
}
}
sub cmd_dataend {
my AsyncSMTPSender $self = shift;
my ($code, $response) = @_;
if ($code != 250) {
$self->{rmsg} = "Error after DATA: @$response";
$self->close;
$self->cont;
}
else {
$self->command("QUIT");
}
}
sub cmd_quit {
my AsyncSMTPSender $self = shift;
my ($code, $response) = @_;
$self->{rcode} = OK;
$self->{rmsg} = "Queued!";
$self->close;
$self->cont;
}
sub datasend {
my AsyncSMTPSender $self = shift;
my ($data) = @_;
$data =~ s/^\./../mg;
$self->write(\$data);
}
sub event_read {
my AsyncSMTPSender $self = shift;
if ($self->{state} == ST_CONNECTED) {
$self->{state} = ST_COMMANDS;
}
if ($self->{state} == ST_COMMANDS) {
my $in = $self->read(1024);
if (!$in) {
# XXX: connection closed
$self->close("lost connection");
return;
}
my @lines = split /\r?\n/, $self->{buf} . $$in, -1;
$self->{buf} = delete $lines[-1];
for(@lines) {
if (my ($code, $cont, $rest) = /^([0-9]{3})([ -])(.*)/) {
$self->log(LOGDEBUG, "<< $code$cont$rest");
push @{$self->{resp}}, $rest;
if($cont eq ' ') {
$self->handle_response($code, $self->{resp});
$self->{resp} = [];
}
}
else {
$self->log(LOGERROR, "Unrecognised SMTP response line: $_");
$self->{rmsg} = "Error from upstream SMTP server";
$self->close;
$self->cont;
}
}
}
else {
$self->log(LOGERROR, "SMTP Session occurred out of order");
$self->close;
$self->cont;
}
}
sub event_write {
my AsyncSMTPSender $self = shift;
if ($self->{state} == ST_CONNECTING) {
$self->watch_write(0);
$self->{state} = ST_CONNECTED;
$self->watch_read(1);
}
elsif (0 && $self->{state} == ST_DATA) {
# send more data
if (my $line = $self->{tran}->body_getline) {
$self->log(LOGDEBUG, ">> $line");
$line =~ s/\r?\n/\r\n/;
$self->datasend($line);
}
else {
# no more data.
$self->log(LOGINFO, "No more data");
$self->watch_write(0);
$self->{state} = ST_COMMANDS;
}
}
else {
$self->write(undef);
}
}
sub event_err {
my ($self) = @_;
eval { $self->read(1); }; # gives us the correct error in errno
$self->{rmsg} = "Read error from remote server: $!";
#print "lost connection: $!\n";
$self->close;
$self->cont;
}
sub event_hup {
my ($self) = @_;
eval { $self->read(1); }; # gives us the correct error in errno
$self->{rmsg} = "HUP error from remote server: $!";
#print "lost connection: $!\n";
$self->close;
$self->cont;
}

181
plugins/async/require_resolvable_fromhost Normal file
View File

@ -0,0 +1,181 @@
#!perl -w
use strict;
use warnings;
use Qpsmtpd::Constants;
use Qpsmtpd::DSN;
use Qpsmtpd::TcpServer;
#use ParaDNS; # moved into register
use Socket;
my %invalid = ();
my $has_ipv6 = Qpsmtpd::TcpServer::has_ipv6();
sub register {
my ( $self, $qp ) = @_;
foreach my $i ( $self->qp->config("invalid_resolvable_fromhost") ) {
$i =~ s/^\s*//;
$i =~ s/\s*$//;
if ( $i =~ m#^((\d{1,3}\.){3}\d{1,3})/(\d\d?)# ) {
$invalid{$1} = $3;
}
}
eval 'use ParaDNS';
if ( $@ ) {
warn "could not load ParaDNS, plugin disabled";
return DECLINED;
};
$self->register_hook( mail => 'hook_mail_start' );
$self->register_hook( mail => 'hook_mail_done' );
}
sub hook_mail_start {
my ( $self, $transaction, $sender ) = @_;
return DECLINED
if ($self->connection->notes('whitelisthost'));
if ( $sender ne '<>' ) {
unless ( $sender->host ) {
# default of addr_bad_from_system is DENY, we use DENYSOFT here to
# get the same behaviour as without Qpsmtpd::DSN...
return Qpsmtpd::DSN->addr_bad_from_system( DENYSOFT,
"FQDN required in the envelope sender" );
}
return DECLINED if $sender->host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/;
unless ($self->check_dns( $sender->host )) {
return Qpsmtpd::DSN->temp_resolver_failed(
"Could not resolve " . $sender->host );
}
return YIELD;
}
return DECLINED;
}
sub hook_mail_done {
my ( $self, $transaction, $sender ) = @_;
return DECLINED
if ( $self->connection->notes('whitelisthost') );
if ( $sender ne "<>" && !$transaction->notes('resolvable_fromhost') ) {
# default of temp_resolver_failed is DENYSOFT
return Qpsmtpd::DSN->temp_resolver_failed(
"Could not resolve " . $sender->host );
}
return DECLINED;
}
sub check_dns {
my ( $self, $host ) = @_;
my @host_answers;
my $qp = $self->qp;
$qp->input_sock->pause_read;
my $a_records = [];
my $num_queries = 1; # queries in progress
my $mx_found = 0;
ParaDNS->new(
callback => sub {
my $mx = shift;
return if $mx =~ /^[A-Z]+$/; # error
my $addr = $mx->[0];
$mx_found = 1;
$num_queries++;
ParaDNS->new(
callback => sub { push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/; },
finished => sub { $num_queries--; $self->finish_up($qp, $a_records, $num_queries) },
host => $addr,
type => 'A',
);
if ($has_ipv6) {
$num_queries++;
ParaDNS->new(
callback => sub { push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/; },
finished => sub { $num_queries--; $self->finish_up($qp, $a_records, $num_queries) },
host => $addr,
type => 'AAAA',
);
}
},
finished => sub {
unless ($mx_found) {
$num_queries++;
ParaDNS->new(
callback => sub { push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/; },
finished => sub { $num_queries--; $self->finish_up($qp, $a_records, $num_queries) },
host => $host,
type => 'A',
);
if ($has_ipv6) {
$num_queries++;
ParaDNS->new(
callback => sub { push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/; },
finished => sub { $num_queries--; $self->finish_up($qp, $a_records, $num_queries) },
host => $host,
type => 'AAAA',
);
}
}
$num_queries--;
$self->finish_up($qp, $a_records, $num_queries);
},
host => $host,
type => 'MX',
) or $qp->input_sock->continue_read, return;
return 1;
}
sub finish_up {
my ($self, $qp, $a_records, $num_queries) = @_;
return if defined $qp->transaction->notes('resolvable_fromhost');
foreach my $addr (@$a_records) {
if (is_valid($addr)) {
$qp->transaction->notes('resolvable_fromhost', 1);
$qp->input_sock->continue_read;
$qp->run_continuation;
return;
}
}
unless ($num_queries) {
# all queries returned no valid response
$qp->transaction->notes('resolvable_fromhost', 0);
$qp->input_sock->continue_read;
$qp->run_continuation;
}
}
sub is_valid {
my $ip = shift;
my ( $net, $mask );
foreach $net ( keys %invalid ) {
$mask = $invalid{$net};
$mask = pack "B32", "1" x ($mask) . "0" x ( 32 - $mask );
return 0
if join( ".", unpack( "C4", inet_aton($ip) & $mask ) ) eq $net;
}
return 1;
}

92
plugins/async/rhsbl Normal file
View File

@ -0,0 +1,92 @@
#!perl -w
use Qpsmtpd::Plugin::Async::DNSBLBase;
sub init {
my $self = shift;
my $class = ref $self;
no strict 'refs';
push @{"${class}::ISA"}, 'Qpsmtpd::Plugin::Async::DNSBLBase';
}
sub hook_mail {
my ($self, $transaction, $sender) = @_;
my $class = ref $self;
return DECLINED if $sender->format eq '<>';
my %rhsbl_zones =
map { (split /\s+/, $_, 2)[0, 1] } $self->qp->config('rhsbl_zones');
return DECLINED unless %rhsbl_zones;
my $sender_host = $sender->host;
my @A_zones = grep { defined($rhsbl_zones{$_}) } keys %rhsbl_zones;
my @TXT_zones = grep { !defined($rhsbl_zones{$_}) } keys %rhsbl_zones;
if (@A_zones) {
# message templates for responding to the client
$transaction->notes(rhsbl_templates =>
{map { +"$sender_host.$_" => $rhsbl_zones{$_} } @A_zones});
}
return DECLINED
unless $class->lookup($self->qp,
[map { "$sender_host.$_" } @A_zones],
[map { "$sender_host.$_" } @TXT_zones],
);
return YIELD;
}
sub process_a_result {
my ($class, $qp, $result, $query) = @_;
my $transaction = $qp->transaction;
$transaction->notes('rhsbl',
$transaction->notes('rhsbl_templates')->{$query})
unless $transaction->notes('rhsbl');
}
sub process_txt_result {
my ($class, $qp, $result, $query) = @_;
my $transaction = $qp->transaction;
$transaction->notes('rhsbl', $result) unless $transaction->notes('rhsbl');
}
sub hook_rcpt {
my ($self, $transaction, $rcpt) = @_;
my $host = $transaction->sender->host;
my $note = $transaction->notes('rhsbl');
return (DENY, "Mail from $host rejected because it $note") if $note;
return DECLINED;
}
=head1 NAME
rhsbl - handle RHSBL lookups
=head1 DESCRIPTION
Pluging that checks the host part of the sender's address against a
configurable set of RBL services.
=head1 CONFIGURATION
This plugin reads the lists to use from the rhsbl_zones configuration
file. Normal domain based dns blocking lists ("RBLs") which contain TXT
records are specified simply as:
dsn.rfc-ignorant.org
To configure RBL services which do not contain TXT records in the DNS,
but only A records, specify, after a whitespace, your own error message
to return in the SMTP conversation e.g.
abuse.rfc-ignorant.org does not support abuse@domain
=cut

142
plugins/async/uribl Normal file
View File

@ -0,0 +1,142 @@
#!perl -w
use Qpsmtpd::Plugin::Async::DNSBLBase;
use strict;
use warnings;
sub init {
my ($self, $qp, %args) = @_;
my $class = ref $self;
$self->isa_plugin("uribl");
{
no strict 'refs';
push @{"${class}::ISA"}, 'Qpsmtpd::Plugin::Async::DNSBLBase';
}
$self->SUPER::init($qp, %args);
}
sub register {
my $self = shift;
$self->register_hook('data_post', 'start_data_post');
$self->register_hook('data_post', 'finish_data_post');
}
sub start_data_post {
my ($self, $transaction) = @_;
my $class = ref $self;
my @names;
my $queries = $self->lookup_start($transaction, sub {
my ($self, $name) = @_;
push @names, $name;
});
my @hosts;
foreach my $z (keys %{$self->{uribl_zones}}) {
push @hosts, map { "$_.$z" } @names;
}
$transaction->notes(uribl_results => {});
$transaction->notes(uribl_zones => $self->{uribl_zones});
return DECLINED
unless @hosts && $class->lookup($self->qp, [ @hosts ], [ @hosts ]);
return YIELD;
}
sub finish_data_post {
my ($self, $transaction) = @_;
my $matches = $self->collect_results($transaction);
for (@$matches) {
$self->log(LOGWARN, $_->{desc});
if ($_->{action} eq 'add-header') {
$transaction->header->add('X-URIBL-Match', $_->{desc});
} elsif ($_->{action} eq 'deny') {
return (DENY, $_->{desc});
} elsif ($_->{action} eq 'denysoft') {
return (DENYSOFT, $_->{desc});
}
}
return DECLINED;
}
sub init_resolver { }
sub process_a_result {
my ($class, $qp, $result, $query) = @_;
my $transaction = $qp->transaction;
my $results = $transaction->notes('uribl_results');
my $zones = $transaction->notes('uribl_zones');
foreach my $z (keys %$zones) {
if ($query =~ /^(.*)\.$z$/) {
my $name = $1;
$results->{$z}->{$name}->{a} = $result;
}
}
}
sub process_txt_result {
my ($class, $qp, $result, $query) = @_;
my $transaction = $qp->transaction;
my $results = $transaction->notes('uribl_results');
my $zones = $transaction->notes('uribl_zones');
foreach my $z (keys %$zones) {
if ($query =~ /^(.*)\.$z$/) {
my $name = $1;
$results->{$z}->{$name}->{txt} = $result;
}
}
}
sub collect_results {
my ($self, $transaction) = @_;
my $results = $transaction->notes('uribl_results');
my @matches;
foreach my $z (keys %$results) {
foreach my $n (keys %{$results->{$z}}) {
if (exists $results->{$z}->{$n}->{a}) {
if ($self->evaluate($z, $results->{$z}->{$n}->{a})) {
$self->log(LOGDEBUG, "match $n in $z");
push @matches, {
action => $self->{uribl_zones}->{$z}->{action},
desc => "$n in $z: " .
($results->{$z}->{$n}->{txt} || $results->{$z}->{$n}->{a}),
};
}
}
}
}
return \@matches;
}
=head1 NAME
uribl - URIBL blocking plugin for qpsmtpd
=head1 DESCRIPTION
This plugin implements DNSBL lookups for URIs found in spam, such as that
implemented by SURBL (see E<lt>http://surbl.org/E<gt>). Incoming messages are
scanned for URIs, which are then checked against one or more URIBLs in a
fashion similar to DNSBL systems.
=head1 CONFIGURATION
See the documentation of the non-async version. The timeout config option is
ignored, the ParaDNS timeout is used instead.
=cut

192
plugins/auth/auth_checkpassword Normal file
View File

@ -0,0 +1,192 @@
#!perl -w
=head1 NAME
auth_checkpassword - Authenticate against a DJB style checkpassword program
=head1 DESCRIPTION
This plugin authenticates users against a DJB style checkpassword
program. Unlike previous checkpassword implementations, this plugin
expects qpsmtpd to be running as the qpsmtpd user. Privilege
escalation can be attained by running the checkpassword binary setuid
or with sudo.
=head1 CONFIGURATION
Configure the path to your checkpassword binary. You can configure this in
config/plugins by defining the checkpw and true arguments as follows:
auth/auth_checkpassword checkpw /usr/local/vpopmail/bin/vchkpw true /bin/true
or by editing the config file config/smtpauth-checkpassword:
echo "/usr/local/vpopmail/bin/vchkpw /bin/true" > ~qpsmtpd/config/smtpauth-checkpassword
vchkpw is the checkpassword program provided by vpopmail. Substitute
your own checkpassword app as appropriate.
If you are using vchkpw and this plugin is being executed by a user ID
other than 89 or 0 (as is the default), and the vchkpw binary is not
setuid (as is the default), this plugin will automatically prepend the
vchkpw command with sudo. If that is the case, you must configure sudo
by adding these two lines to your sudoers file:
Defaults:qpsmtpd closefrom_override
qpsmtpd ALL = (ALL) NOPASSWD: /usr/local/vpopmail/bin/vchkpw
The closefrom_override option is necessary because, by default, sudo
appropriates the first 3 file descriptors. Those descriptors are
necessary to communicate with the checkpassword program. If you run
qpsmtpd as some other user, adjust the sudo lines approriately.
Using sudo is preferable to enabling setuid on the vchkpw binary. If
you reinstall vpopmail and the setuid bit is lost, this plugin will be
broken.
=head1 SEE ALSO
If you are using this plugin with vpopmail, please read the VPOPMAIL
section in docs/authentication.pod
=head1 DIAGNOSTICS
Is the path in the config/smtpauth-checkpassword correct?
Is the path to true in config/smtpauth-checkpassword correct?
Is qpsmtpd running as the qpsmtpd user? If not, did you adjust the
sudo configuration appropriately?
If you are not using sudo, did you remember to make the vchkpw binary
setuid (chmod 4711 ~vpopmail/bin/vchkpw)?
While writing this plugin, I first wrote myself a little test script,
which helped me identify the sudo closefrom_override issue. Here is
that script:
#!/usr/bin/perl
use strict;
my $sudo = "/usr/local/bin/sudo";
$sudo .= " -C4 -u vpopmail";
my $vchkpw = "/usr/local/vpopmail/bin/vchkpw";
my $true = "/bin/true";
open(CPW,"|$sudo $vchkpw $true 3<&0");
printf(CPW "%s\0%s\0Y123456\0",'user@example.com','pa55word');
close(CPW);
my $status = $?;
print "FAIL\n" and exit if ( $status != 0 );
print "OK\n";
Save that script to vchkpw.pl and then run it as the same user that
qpsmtpd runs as:
setuidgid qpsmtpd perl vchkpw.pl
If you aren't using sudo, then remove $sudo from the open line.
=head1 ACKNOWLEDGEMENTS
based upon authcheckpassword by Michael Holzt
and adapted by Johan Almqvist 2006-01-18
=head1 AUTHOR
Matt Simerson <msimerson@cpan.org>
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2010 Matt Simerson
This plugin is licensed under the same terms as the qpsmtpd package itself.
Please see the LICENSE file included with qpsmtpd for details.
=cut
sub register {
my ($self, $qp, %args ) = @_;
my ($checkpw, $true) = $self->get_checkpw( \%args );
return DECLINED if ! $checkpw || ! $true;
$self->connection->notes('auth_checkpassword_bin', $checkpw);
$self->connection->notes('auth_checkpassword_true', $true);
$self->register_hook('auth-plain', 'auth_checkpassword');
$self->register_hook('auth-login', 'auth_checkpassword');
}
sub auth_checkpassword {
my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) =
@_;
my $binary = $self->connection->notes('auth_checkpassword_bin');
my $true = $self->connection->notes('auth_checkpassword_true');
chomp ($binary, $true);
my $sudo = get_sudo($binary);
$self->log(LOGDEBUG, "auth_checkpassword: $sudo $binary $true 3<&0");
open(CPW, "|$sudo $binary $true 3<&0");
printf(CPW "%s\0%s\0Y123456\0", $user, $passClear);
close(CPW);
my $status = $?;
if ($status != 0) {
$self->log(LOGNOTICE, "authentication failed ($status)");
return (DECLINED);
};
$self->connection->notes('authuser', $user);
return (OK, "auth_checkpassword");
}
sub get_checkpw {
my ($self, $args) = @_;
my ($checkpw) = $args->{checkpw} =~ /^(.*)$/ if $args->{checkpw}; # untaint
my ($true) = $args->{true} =~ /^(.*)$/ if $args->{true}; # untaint
return ( $checkpw, $true )
if ( $checkpw && $true && -x $checkpw && -x $true );
my $missing_config = "disabled due to invalid configuration. See 'perldoc plugins/auth/auth_checkpassword' for how to configure.";
if ( ! $self->qp->config('smtpauth-checkpassword') ) {
$self->log(LOGERROR, $missing_config );
return;
};
$self->log(LOGNOTICE, "reading config from smtpauth-checkpassword");
my $config = $self->qp->config("smtpauth-checkpassword");
($checkpw, $true) = $config =~ /^(\S+)\s+(\S+)\s*$/;
if ( ! $checkpw || ! $true || ! -x $checkpw || ! -x $true ) {
$self->log(LOGERROR, $missing_config );
return;
};
return ($checkpw, $true);
};
sub get_sudo {
my $binary = shift;
return '' if $> == 0; # running as root
return '' if $> == 89 && $binary =~ /vchkpw$/; # running as vpopmail
my $mode = (stat($binary))[2];
$mode = sprintf "%lo", $mode & 07777;
return '' if $mode eq '4711'; # $binary is setuid
my $sudo = `which sudo` || '/usr/local/bin/sudo';
return '' if ! -x $sudo;
$sudo .= ' -C4'; # prevent sudo from clobbering file descriptor 3
return $sudo if $binary !~ /vchkpw$/;
return "$sudo -u vpopmail";
}

130
plugins/auth/auth_cvm_unix_local Normal file
View File

@ -0,0 +1,130 @@
#!perl -w
=head1 NAME
auth_cvm_unix_local - SMTP AUTH LOGIN module using
Bruce Guenther's Credential Validation Module (CVM)
http://untroubled.org/cvm/
=head1 SYNOPSIS
In config/plugins:
auth/auth_cvm_unix_local \
cvm_socket /var/lib/cvm/cvm-unix-local.socket \
enable_smtp no \
enable_ssmtp yes
=head1 BUGS
- Should probably handle auth-cram-md5 as well. However, this requires
access to the plain text password. We could store a separate database
of passwords purely for SMTP AUTH, for example as an optional
SMTPAuthPassword property of an account in the esmith::AccountsDB;
=head1 DESCRIPTION
This plugin implements an authentication plugin using Bruce Guenther's
Credential Validation Module (http://untroubled.org/cvm).
=head1 AUTHOR
Copyright 2005 Gordon Rowell <gordonr@gormand.com.au>
This software is free software and may be distributed under the same
terms as qpsmtpd itself.
=head1 VERSION
Version $Id: auth_cvm_unix_local,v 1.1 2005/06/09 22:50:06 gordonr Exp gordonr $
=cut
use strict;
use warnings;
use Qpsmtpd::Constants;
use Socket;
use constant SMTP_PORT => getservbyname("smtp", "tcp") || 25;
use constant SSMTP_PORT => getservbyname("ssmtp", "tcp") || 465;
sub register {
my ( $self, $qp, %arg ) = @_;
unless ($arg{cvm_socket}) {
$self->log(LOGERROR, "skip: requires cvm_socket argument");
return 0;
};
$self->{_args} = { %arg };
$self->{_enable_smtp} = $arg{enable_smtp} || 'no';
$self->{_enable_ssmtp} = $arg{enable_ssmtp} || 'yes';
my $port = $ENV{PORT} || SMTP_PORT;
return 0 if ($port == SMTP_PORT && $arg{enable_smtp} ne 'yes');
return 0 if ($port == SSMTP_PORT && $arg{enable_ssmtp} ne 'yes');
if ($arg{cvm_socket} =~ /^([\w\/.-]+)$/) {
$self->{_cvm_socket} = $1;
}
unless (-S $self->{_cvm_socket}) {
$self->log(LOGERROR, "skip: cvm_socket missing or not usable");
return 0;
}
$self->register_hook("auth-plain", "authcvm_plain");
$self->register_hook("auth-login", "authcvm_plain");
# $self->register_hook("auth-cram-md5", "authcvm_hash");
}
sub authcvm_plain {
my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) =
@_;
socket(SOCK, PF_UNIX, SOCK_STREAM, 0) or do {
$self->log(LOGERROR, "skip: socket creation attempt for: $user");
return (DENY, "authcvm");
};
# DENY, really? Should this plugin return a DENY when it cannot connect
# to the cvs socket? I'd expect such a failure to return DECLINED, so
# any other auth plugins could take a stab at authenticating the user
connect(SOCK, sockaddr_un($self->{_cvm_socket})) or do {
$self->log(LOGERROR, "skip: socket connection attempt for: $user");
return (DENY, "authcvm");
};
my $o = select(SOCK); $| = 1; select($o);
my ($u, $host) = split(/\@/, $user);
$host ||= "localhost";
print SOCK "\001$u\000$host\000$passClear\000\000";
shutdown SOCK, 1; # tell remote we're finished
my $ret = <SOCK>;
my ($s) = unpack ("C", $ret);
if ( ! defined $s ) {
$self->log(LOGERROR, "skip: no response from cvm for $user");
return (DECLINED);
};
if ( $s == 0 ) {
$self->log(LOGINFO, "pass: authentication for: $user");
return (OK, "auth success for $user");
};
if ( $s == 100 ) {
$self->log(LOGINFO, "fail: authentication failure for: $user");
return (DENY, 'auth failure (100)');
};
$self->log(LOGERROR, "skip: unknown response from cvm for $user");
return (DECLINED, "unknown result code ($s)");
}

83
plugins/auth/auth_flat_file Normal file
View File

@ -0,0 +1,83 @@
#!perl -w
=head1 NAME
auth_flat_file - simple CRAM MD5 auth plugin using a flat password file
=head1 SYNOPSIS
in config/plugins:
auth/auth_flat_file
in config/flat_auth_pw
username1:password1
username2:password2
...
=head1 DESCRIPTION
This plugin implements a very simple authentication plugin using a flat password
file containing username and password separated by colons.
Note that this plugin enforces the use of a full email address (including
@domain) as the username. There's no particular reason for this so feel free
to modify the code to suit your setup.
The password is stored on disk unencrypted, however authentication uses a HMAC
algorithm so no password is transfered in the clear.
=cut
use strict;
use warnings;
use Qpsmtpd::Auth;
use Qpsmtpd::Constants;
sub register {
my ( $self, $qp ) = @_;
$self->register_hook('auth-plain', 'auth_flat_file');
$self->register_hook('auth-login', 'auth_flat_file');
$self->register_hook('auth-cram-md5', 'auth_flat_file');
}
sub auth_flat_file {
my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) =
@_;
if ( ! defined $passClear && ! defined $passHash ) {
$self->log(LOGINFO, "fail: missing password");
return ( DENY, "authflat - missing password" );
}
my ( $pw_name, $pw_domain ) = split '@', lc($user);
unless ( defined $pw_domain ) {
$self->log(LOGINFO, "fail: missing domain");
return DECLINED;
}
my ($auth_line) = grep {/^$pw_name\@$pw_domain:/} $self->qp->config('flat_auth_pw');
if ( ! defined $auth_line) {
$self->log(LOGINFO, "fail: no such user: $user");
return DECLINED;
}
my ($auth_user, $auth_pass) = split(/:/, $auth_line, 2);
# at this point we can assume the user name matched
return Qpsmtpd::Auth::validate_password( $self,
src_clear => $auth_pass,
src_crypt => undef,
attempt_clear => $passClear,
attempt_hash => $passHash,
method => $method,
ticket => $ticket,
deny => DENY,
);
}

197
plugins/auth/auth_ldap_bind Normal file
View File

@ -0,0 +1,197 @@
#!perl -w
=head1 NAME
auth_ldap_bind - Authenticate user via an LDAP bind
=head1 DESCRIPTION
This plugin authenticates users against an LDAP Directory. The plugin
first performs a lookup for an entry matching the connecting user. This
lookup uses the 'ldap_auth_filter_attr' attribute to match the connecting
user to their LDAP DN. Once the plugin has found the user's DN, the plugin
will attempt to bind to the Directory as that DN with the password that has
been supplied.
=head1 CONFIGURATION
Configuration items can be held in either the 'ldap' configuration file, or as
arguments to the plugin.
Configuration items in the 'ldap' configuration file
are set one per line, starting the line with the configuration item key,
followed by a space, then the values associated with the configuration item.
Configuration items given as arguments to the plugin are keys and values
separated by spaces. Be sure to quote any values that have spaces in them.
The only configuration item which is required is 'ldap_base'. This tells the
plugin what your base DN is. The plugin will not work until it has been
configured.
The configuration items 'ldap_host' and 'ldap_port' specify the host and port
at which your Directory server may be contacted. If these are not specified,
the plugin will use port '389' on 'localhost'.
The configuration item 'ldap_timeout' specifies how long the plugin should
wait for a response from your Directory server. By default, the value is 5
seconds.
The configuration item 'ldap_auth_filter_attr' specifies how the plugin should
find the user in your Directory. By default, the plugin will look up the user
based on the 'uid' attribute.
=head1 NOTES
Each auth requires an initial lookup to find the user's DN. Ideally, the
plugin would simply bind as the user without the need for this lookup (see
FUTURE DIRECTION below).
This plugin requires that the Directory allow anonymous bind (see FUTURE
DIRECTION below).
=head1 FUTURE DIRECTION
A configurable LDAP filter should be made available, to account for users
who are over quota, have had their accounts disabled, or whatever other
arbitrary requirements.
A configurable DN template (uid=$USER,ou=$DOMAIN,$BASE). This would prevent
the need of the initial user lookup, as the DN is created from the template.
A configurable bind DN, for Directories that do not allow anonymous bind.
Another plugin ('ldap_auth_cleartext'?), to allow retrieval of plain-text
passwords from the Directory, permitting CRAM-MD5 or other hash algorithm
authentication.
=head1 AUTHOR
Elliot Foster <elliotf@gratuitous.net>
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2005 Elliot Foster
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 Net::LDAP qw(:all);
use Qpsmtpd::Constants;
sub register {
my ($self, $qp, @args) = @_;
$self->register_hook("auth-plain", "authldap");
$self->register_hook("auth-login", "authldap");
# pull config defaults in from file
%{$self->{"ldconf"}} =
map { (split /\s+/, $_, 2)[0, 1] } $self->qp->config('ldap');
# override ldap config defaults with plugin args
for my $ldap_arg (@args) {
%{$self->{"ldconf"}} = map { (split /\s+/, $_, 2)[0, 1] } $ldap_arg;
}
# do light validation of ldap_host and ldap_port to satisfy -T
my $ldhost = $self->{"ldconf"}->{'ldap_host'};
my $ldport = $self->{"ldconf"}->{'ldap_port'};
if (($ldhost) && ($ldhost =~ m/^(([a-z0-9]+\.?)+)$/)) {
$self->{"ldconf"}->{'ldap_host'} = $1;
}
else {
undef $self->{"ldconf"}->{'ldap_host'};
}
if (($ldport) && ($ldport =~ m/^(\d+)$/)) {
$self->{"ldconf"}->{'ldap_port'} = $1;
}
else {
undef $self->{"ldconf"}->{'ldap_port'};
}
# set any values that are not already
$self->{"ldconf"}->{"ldap_host"} ||= "127.0.0.1";
$self->{"ldconf"}->{"ldap_port"} ||= 389;
$self->{"ldconf"}->{"ldap_timeout"} ||= 5;
$self->{"ldconf"}->{"ldap_auth_filter_attr"} ||= "uid";
}
sub authldap {
my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) =
@_;
my ($ldhost, $ldport, $ldwait, $ldbase, $ldmattr, $lduserdn, $ldh, $mesg);
# pull values in from config
$ldhost = $self->{"ldconf"}->{"ldap_host"};
$ldport = $self->{"ldconf"}->{"ldap_port"};
$ldbase = $self->{"ldconf"}->{"ldap_base"};
# log error here and DECLINE if no baseDN, because a custom baseDN is required:
unless ($ldbase) {
$self->log(LOGERROR, "skip: please configure ldap_base");
return (DECLINED, "authldap - temporary auth error");
};
$ldwait = $self->{"ldconf"}->{'ldap_timeout'};
$ldmattr = $self->{"ldconf"}->{'ldap_auth_filter_attr'};
my ($pw_name, $pw_domain) = split "@", lc($user);
# find dn of user matching supplied username
$ldh = Net::LDAP->new($ldhost, port => $ldport, timeout => $ldwait) or do {
$self->log(LOGALERT, "skip: error in initial conn");
return (DECLINED, "authldap - temporary auth error");
};
# find the user's DN
$mesg = $ldh->search( base => $ldbase,
scope => 'sub',
filter => "$ldmattr=$pw_name",
attrs => ['uid'],
timeout => $ldwait,
sizelimit => '1'
) or do {
$self->log(LOGALERT, "skip: err in search for user");
return (DECLINED, "authldap - temporary auth error");
};
# deal with errors if they exist
if ($mesg->code) {
$self->log(LOGALERT, "skip: err " . $mesg->code . " in search for user");
return (DECLINED, "authldap - temporary auth error");
}
# unbind, so as to allow a rebind below
$ldh->unbind if $ldh;
# bind against directory as user with password supplied
if ( ! $mesg->count || $lduserdn = $mesg->entry->dn ) {
$self->log(LOGALERT, "fail: user not found");
return (DECLINED, "authldap - wrong username or password");
};
$ldh = Net::LDAP->new($ldhost, port => $ldport, timeout => $ldwait) or do {
$self->log(LOGALERT, "skip: err in user conn");
return (DECLINED, "authldap - temporary auth error");
};
# here's the whole reason for the script
$mesg = $ldh->bind($lduserdn, password => $passClear, timeout => $ldwait);
$ldh->unbind if $ldh;
# deal with errors if they exist, or allow success
if ($mesg->code) {
$self->log(LOGALERT, "fail: error in user bind");
return (DECLINED, "authldap - wrong username or password");
}
$self->log(LOGINFO, "pass: $user auth success");
$self->log(LOGDEBUG, "user: $user, pass: $passClear");
return (OK, "authldap");
}

101
plugins/auth/auth_vpopmail Normal file
View File

@ -0,0 +1,101 @@
#!perl -w
=head1 NAME
auth_vpopmail - Authenticate against libvpopmail.a
=head1 DESCRIPTION
This plugin authenticates vpopmail users using p5-vpopmail.
Using CRAM-MD5 requires that vpopmail be built with the
'--enable-clear-passwd=y' option.
=head1 CONFIGURATION
This module will only work if qpsmtpd is running as the 'vpopmail' user.
CRAM-MD5 authentication will only work with p5-vpopmail 0.09 or higher.
http://github.com/sscanlon/vpopmail
Decide which authentication methods you are willing to support and uncomment
the lines in the register() sub. See the POD for Qspmtpd::Auth for more
details on the ramifications of supporting various authentication methods.
=head1 SEE ALSO
For an overview of the vpopmail authentication plugins and their merits,
please read the VPOPMAIL section in docs/authentication.pod
=head1 AUTHOR
Matt Simerson <msimerson@cpan.org>
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2010 Matt Simerson
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 Qpsmtpd::Auth;
use Qpsmtpd::Constants;
#use vpopmail; # we eval this in $test_vpopmail_module
sub register {
my ($self, $qp) = @_;
return (DECLINED) if ! $self->test_vpopmail_module();
$self->register_hook("auth-plain", "auth_vpopmail" );
$self->register_hook("auth-login", "auth_vpopmail" );
$self->register_hook("auth-cram-md5", "auth_vpopmail");
}
sub auth_vpopmail {
my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) =
@_;
my $pw = vauth_getpw( split '@', lc($user) );
my $pw_clear_passwd = $pw->{pw_clear_passwd};
my $pw_passwd = $pw->{pw_passwd};
if (!$pw || (!$pw_clear_passwd && !$pw_passwd)) {
$self->log(LOGINFO, "fail: invalid user $user");
return (DENY, "auth_vpopmail - invalid user");
# change DENY to DECLINED to support multiple auth plugins
}
return Qpsmtpd::Auth::validate_password( $self,
src_clear => $pw->{pw_clear_passwd},
src_crypt => $pw->{pw_passwd},
attempt_clear => $passClear,
attempt_hash => $passHash,
method => $method,
ticket => $ticket,
deny => DENY,
);
}
sub test_vpopmail_module {
my $self = shift;
# vpopmail will not allow vauth_getpw to succeed unless the requesting user is vpopmail or root.
# by default, qpsmtpd runs as the user 'qpsmtpd' and does not have permission.
eval 'use vpopmail';
if ( $@ ) {
$self->log(LOGERROR, "skip: is vpopmail perl module installed?");
return;
};
my ($domain) = vpopmail::vlistdomains();
my $r = vauth_getpw('postmaster', $domain) or do {
$self->log(LOGERROR, "skip: could not query vpopmail");
return;
};
return 1;
}

156
plugins/auth/auth_vpopmail_sql Normal file
View File

@ -0,0 +1,156 @@
#!perl -w
=head1 NAME
auth_vpopmail_sql - Authenticate to vpopmail via MySQL
=head1 DESCRIPTION
This plugin authenticates vpopmail users directly against a standard
vpopmail MySQL database. It makes the not-unreasonable assumption that
both pw_name and pw_domain are lowercase only (qmail doesn't actually care).
If you are using CRAM-MD5, it also requires that vpopmail be built with the
recommended '--enable-clear-passwd=y' option, because there is no way
to compare the crypted password.
=head1 CONFIGURATION
echo "dbi:mysql:dbname=vpopmail;host=127.0.0.1" > config/vpopmail_mysql_dsn
echo "vpopmailuser" > config/vpopmail_mysql_user
echo "vpoppasswd" > config/vpopmail_mysql_pass
This can be a read-only database user since the plugin does not update the
last accessed time (yet, see below).
This module supports PLAIN, LOGIN, and CRAM-MD5 authentication methods. You
can disable undesired methods by editing this module and uncommenting
the lines in the register() sub. See the POD for Qspmtpd::Auth for more
details on the ramifications of supporting various authentication methods.
The remote user must login with a fully qualified e-mail address (i.e. both
account name and domain), even if they don't normally need to. This is
because the vpopmail table has a unique index on pw_name/pw_domain, and this
module requires that only a single record be returned from the database.
=head1 LIMITATIONS
This authentication modules does not recognize domain aliases. So, if you have
the domain example.com, with domain aliases for example.org and example.net,
smtp-auth will only work for $user@example.com. If you have domain aliases,
consider using another plugin (see SEE ALSO).
=head1 FUTURE DIRECTION
The default MySQL configuration for vpopmail includes a table to log access,
lastauth, which could conceivably be updated upon sucessful authentication.
The addition of this feature is left as an exercise for someone who cares. ;)
=head1 SEE ALSO
For an overview of the vpopmail authentication plugins and their merits,
please read the VPOPMAIL section in docs/authentication.pod
=head1 AUTHOR
John Peacock <jpeacock@cpan.org>
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2004 John Peacock
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 Qpsmtpd::Auth;
use Qpsmtpd::Constants;
#use DBI; # done in ->register
sub register {
my ( $self, $qp ) = @_;
eval 'use DBI';
if ( $@ ) {
warn "plugin disabled. is DBI installed?\n";
$self->log(LOGERROR, "skip: plugin disabled. is DBI installed?\n");
return;
};
$self->register_hook('auth-plain', 'auth_vmysql');
$self->register_hook('auth-login', 'auth_vmysql');
$self->register_hook('auth-cram-md5', 'auth_vmysql');
}
sub get_db_handle {
my $self = shift;
my $dsn = $self->qp->config("vpopmail_mysql_dsn") || "dbi:mysql:dbname=vpopmail;host=127.0.0.1";
my $dbuser = $self->qp->config("vpopmail_mysql_user") || "vpopmailuser";
my $dbpass = $self->qp->config("vpopmail_mysql_pass") || "vpoppasswd";
my $dbh = DBI->connect( $dsn, $dbuser, $dbpass ) or do {
$self->log(LOGERROR, "skip: db connection failed");
return;
};
$dbh->{ShowErrorStatement} = 1;
return $dbh;
};
sub get_vpopmail_user {
my ( $self, $dbh, $user ) = @_;
my ( $pw_name, $pw_domain ) = split '@', lc($user);
if ( ! defined $pw_domain ) {
$self->log(LOGINFO, "skip: missing domain: " . lc $user );
return;
};
$self->log(LOGDEBUG, "auth_vpopmail_sql: $user");
my $query = "SELECT pw_passwd,pw_clear_passwd
FROM vpopmail
WHERE pw_name = ?
AND pw_domain = ?";
my $sth = $dbh->prepare( $query );
$sth->execute( $pw_name, $pw_domain );
my $userd_ref = $sth->fetchrow_hashref;
$sth->finish;
$dbh->disconnect;
return $userd_ref;
};
sub auth_vmysql {
my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) = @_;
my $dbh = $self->get_db_handle() or return DECLINED;
my $u = $self->get_vpopmail_user($dbh, $user) or return DECLINED;
# if vpopmail was not built with '--enable-clear-passwd=y'
# then pw_clear_passwd may not even exist
# my $pw_clear_passwd = $db_user->{'pw_clear_passwd'};
if ( ! $u->{pw_passwd} && ! $u->{pw_clear_passwd} ) {
$self->log(LOGINFO, "fail: no such user");
return ( DENY, "auth_vmysql - no such user" );
};
# at this point, the user name has matched
return Qpsmtpd::Auth::validate_password( $self,
src_clear => $u->{pw_clear_passwd},
src_crypt => $u->{pw_passwd},
attempt_clear => $passClear,
attempt_hash => $passHash,
method => $method,
ticket => $ticket,
deny => DENY,
);
}

120
plugins/auth/auth_vpopmaild Normal file
View File

@ -0,0 +1,120 @@
#!perl -w
use strict;
use warnings;
use Qpsmtpd::Constants;
use IO::Socket;
use version;
my $VERSION = qv('1.0.3');
sub register {
my ($self, $qp, %args) = @_;
$self->{_vpopmaild_host} = $args{host} || 'localhost';
$self->{_vpopmaild_port} = $args{port} || '89';
$self->register_hook('auth-plain', 'auth_vpopmaild');
$self->register_hook('auth-login', 'auth_vpopmaild');
#$self->register_hook('auth-cram-md5', 'auth_vpopmaild'); # not supported
}
sub auth_vpopmaild {
my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) = @_;
if ( ! $passClear ) {
$self->log(LOGINFO, "skip: vpopmaild does not support cram-md5");
return DECLINED;
}
# create socket
my $vpopmaild_socket = IO::Socket::INET->new(
PeerAddr => $self->{_vpopmaild_host},
PeerPort => $self->{_vpopmaild_port},
Proto => 'tcp',
Type => SOCK_STREAM
) or do {
$self->log(LOGERROR, "skip: socket connection to vpopmaild failed");
return DECLINED;
};
$self->log(LOGDEBUG, "attempting $method");
# Get server greeting (+OK)
my $connect_response = <$vpopmaild_socket>;
if ( ! $connect_response ) {
$self->log(LOGERROR, "skip: no connection response");
close($vpopmaild_socket);
return DECLINED;
};
if ( $connect_response !~ /^\+OK/ ) {
$self->log(LOGERROR, "skip: bad connection response: $connect_response");
close($vpopmaild_socket);
return DECLINED;
};
print $vpopmaild_socket "login $user $passClear\n\r"; # send login details
my $login_response = <$vpopmaild_socket>; # get response from server
close($vpopmaild_socket);
if ( ! $login_response ) {
$self->log(LOGERROR, "skip: no login response");
return DECLINED;
};
# check for successful login (single line (+OK) or multiline (+OK+))
if ( $login_response =~ /^\+OK/ ) {
$self->log(LOGINFO, "pass: clear");
return (OK, 'auth_vpopmaild');
};
chomp $login_response;
$self->log(LOGNOTICE, "fail: $login_response");
return DECLINED;
}
__END__
=head1 NAME
auth_vpopmaild - Authenticate to vpopmaild
=head1 DESCRIPTION
Authenticates the user against against vpopmaild [1] daemon.
=head1 CONFIGURATION
Add a line to C<config/plugins> as follows:
auth_vpopmaild
By default, the plugin connects to localhot on port 89. If your vpopmaild
daemon is running on a different host or port, specify as follows:
auth_vpopmaild host [host] port [port]
=head1 SEE ALSO
For an overview of the vpopmail authentication plugins and their merits,
please read the VPOPMAIL section in doc/authentication.pod
=head1 LINKS
[1] http://www.qmailwiki.org/Vpopmaild
=head1 AUTHOR
Robin Bowes <robin.bowes@yo61.com>
Matt Simerson (updated response parsing, added logging)
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2010 Robin Bowes
This plugin is licensed under the same terms as the qpsmtpd package itself.
Please see the LICENSE file included with qpsmtpd for details.
=cut

23
plugins/auth/authdeny Normal file
View File

@ -0,0 +1,23 @@
#!perl -w
=head1 NAME
authdeny
=head1 SYNOPSIS
This plugin doesn't actually check anything and will fail any
user no matter what they type. It is strictly a proof of concept for
the Qpsmtpd::Auth module. Don't run this in production!!!
=cut
sub hook_auth {
my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) =
@_;
$self->log( LOGWARN, "fail: cannot authenticate" );
return ( DECLINED, "$user is not free to abuse my relay" );
}

159
plugins/check_badmailfrom Normal file
View File

@ -0,0 +1,159 @@
#!perl -w
=head1 NAME
check_badmailfrom - checks the badmailfrom config, with per-line reasons
=head1 DESCRIPTION
Reads the "badmailfrom" configuration like qmail-smtpd does. From the
qmail-smtpd docs:
"Unacceptable envelope sender addresses. qmail-smtpd will reject every
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 include an optional message after the sender address (leave a space),
to be used when rejecting the sender.
=head1 CONFIGURATION
=head2 reject
badmailfrom reject [ 0 | 1 | naughty ]
I<0> will not reject any connections.
I<1> will reject naughty senders.
I<connect> is the most efficient setting. It's also the default.
To reject at any other connection hook, use the I<naughty> setting and the
B<naughty> plugin.
=head1 PATTERNS
This plugin also supports regular expression matches. This allows
special patterns to be denied (e.g. FQDN-VERP, percent hack, bangs,
double ats).
Patterns are stored in the format pattern(\s+)response, where pattern
is a Perl pattern expression. Don't forget to anchor the pattern
(front ^ and back $) if you want to restrict it from matching
anywhere in the string.
^streamsendbouncer@.*\.mailengine1\.com$ Your right-hand side VERP doesn't fool me
^return.*@.*\.pidplate\.biz$ I don' want it regardless of subdomain
^admin.*\.ppoonn400\.com$
=head1 NOTES
According to the SMTP protocol, we can't reject until after the RCPT
stage, so store it until later.
=head1 AUTHORS
2002 - Jim Winstead - initial author of badmailfrom
2010 - Johan Almqvist <johan-qpsmtpd@almqvist.net> - pattern matching plugin
2012 - Matt Simerson - merging of the two and plugin tests
=cut
sub register {
my ($self,$qp) = shift, shift;
$self->{_args} = { @_ };
# preserve legacy "reject during rcpt" behavior
$self->{_args}{reject} = 1 if ! defined $self->{_args}{reject};
return if ! $self->{_args}{reject}; # reject 0, log only
return if $self->{_args}{reject} eq 'naughty'; # naughty will reject
$self->register_hook('rcpt', 'rcpt_handler');
};
sub hook_mail {
my ($self, $transaction, $sender, %param) = @_;
return DECLINED if $self->is_immune();
my @badmailfrom = $self->qp->config('badmailfrom');
if ( defined $self->{_badmailfrom_config} ) { # testing
@badmailfrom = @{$self->{_badmailfrom_config}};
};
return DECLINED if $self->is_immune_sender( $sender, \@badmailfrom );
my $host = lc $sender->host;
my $from = lc($sender->user) . '@' . $host;
for my $config (@badmailfrom) {
$config =~ s/^\s+//g; # trim leading whitespace
my ($bad, $reason) = split /\s+/, $config, 2;
next unless $bad;
next unless $self->is_match( $from, $bad, $host );
$reason ||= "Your envelope sender is in my badmailfrom list";
$self->connection->notes('naughty', $reason);
}
if ( ! $self->connection->notes('naughty') ) {
$self->log(LOGINFO, "pass");
};
return DECLINED;
}
sub is_match {
my ( $self, $from, $bad, $host ) = @_;
if ( $bad =~ /[\/\^\$\*\+]/ ) { # it's a regexp
$self->log(LOGDEBUG, "badmailfrom pattern ($bad) match for $from");
return 1 if $from =~ /$bad/;
return;
};
$bad = lc $bad;
if ( $bad !~ m/\@/ ) {
$self->log(LOGWARN, "badmailfrom: bad config: no \@ sign in $bad");
return;
};
if ( substr($bad,0,1) eq '@' ) {
return 1 if $bad eq "\@$host";
return;
};
return if $bad ne $from;
return 1;
};
sub rcpt_handler {
my ($self, $transaction, $rcpt, %param) = @_;
my $note = $self->connection->notes('naughty') or return (DECLINED);
$self->log(LOGINFO, "fail, $note");
return (DENY, $note);
}
sub is_immune_sender {
my ($self, $sender, $badmf ) = @_;
if ( ! scalar @$badmf ) {
$self->log(LOGDEBUG, 'skip: empty list');
return 1;
};
if ( ! $sender || $sender->format eq '<>' ) {
$self->log(LOGDEBUG, 'skip: null sender');
return 1;
};
if ( ! $sender->host || ! $sender->user ) {
$self->log(LOGDEBUG, 'skip: missing user or host');
return 1;
};
return;
};

83
plugins/check_badmailfromto Normal file
View File

@ -0,0 +1,83 @@
#!perl -w
=head1 NAME
check_badmailfromto - checks the badmailfromto config
=head1 DESCRIPTION
Much like the similar check_badmailfrom, this plugin references both the
FROM: and TO: lines, and if they both are present in the badmailfromto
config file (a tab delimited list of FROM/TO pairs), then the message is
blocked as if the recipient (TO) didn't exist. This is specifically designed
to not give the impression that the sender is blocked (good for cases of
harassment).
Based heavily on check_badmailfrom.
=cut
use strict;
use Qpsmtpd::Constants;
sub hook_mail {
my ($self, $transaction, $sender, %param) = @_;
my @badmailfromto = $self->qp->config("badmailfromto");
return DECLINED if $self->is_sender_immune( $sender, \@badmailfromto );
my $host = lc $sender->host;
my $from = lc($sender->user) . '@' . $host;
for my $bad (@badmailfromto) {
$bad =~ s/^\s*(\S+).*/$1/;
next unless $bad;
$bad = lc $bad;
if ( $bad !~ m/\@/ ) {
$self->log(LOGWARN, 'badmailfromto: bad config, no @ sign in '. $bad);
next;
};
if ( $bad eq $from || (substr($bad,0,1) eq '@' && $bad eq "\@$host") ) {
$transaction->notes('badmailfromto', $bad);
};
}
return (DECLINED);
}
sub hook_rcpt {
my ($self, $transaction, $rcpt, %param) = @_;
my $recipient = lc($rcpt->user) . '@' . lc($rcpt->host);
my $sender = $transaction->notes('badmailfromto') or do {
$self->log(LOGDEBUG, "pass: sender not listed");
return (DECLINED);
};
foreach ( $self->qp->config("badmailfromto") ) {
my ($from, $to) = m/^\s*(\S+)\t(\S+).*/;
return (DENY, "mail to $recipient not accepted here")
if lc($from) eq $sender && lc($to) eq $recipient;
}
$self->log(LOGDEBUG, "pass: recipient not listed");
return (DECLINED);
}
sub is_sender_immune {
my ($self, $sender, $badmf ) = @_;
if ( ! scalar @$badmf ) {
$self->log(LOGDEBUG, 'skip: empty list');
return 1;
};
if ( ! $sender || $sender->format eq '<>' ) {
$self->log(LOGDEBUG, 'skip: null sender');
return 1;
};
if ( ! $sender->host || ! $sender->user ) {
$self->log(LOGDEBUG, 'skip: missing user or host');
return 1;
};
return;
};

129
plugins/check_badrcptto Normal file
View File

@ -0,0 +1,129 @@
#!perl -w
=head1 SYNOPSIS
deny connections to recipients in the I<badrcptto> file
like badmailfrom, but for recipient address rather than sender
=head1 CONFIG
Recipients are matched against entries in I<config/badrcptto>. Entries can be
a complete email address, a host entry that starts with an @ symbol, or a
regular expression. For regexp pattern matches, see PATTERNS.
=head1 PATTERNS
This allows special patterns to be denied (e.g. percent hack, bangs,
double ats).
Patterns are stored in the format pattern\sresponse, where pattern
is a Perl pattern expression. Don't forget to anchor the pattern if
you want to restrict it from matching anywhere in the string.
qpsmtpd already ensures that the address contains an @, with something
to the left and right of the @.
=head1 AUTHOR
2002 - original badrcptto plugin - apparently Jim Winstead
https://github.com/smtpd/qpsmtpd/commits/master/plugins/check_badrcptto
2005 - pattern feature, (c) Gordon Rowell <gordonr@gormand.com.au>
2012 - merged the two, refactored, added tests - Matt Simerson
=head1 LICENSE
This software is free software and may be distributed under the same
terms as qpsmtpd itself.
=cut
use strict;
use warnings;
use Qpsmtpd::Constants;
use Qpsmtpd::DSN;
sub hook_rcpt {
my ($self, $transaction, $recipient, %param) = @_;
return (DECLINED) if $self->is_immune();
my ($host, $to) = $self->get_host_and_to( $recipient )
or return (DECLINED);
my @badrcptto = $self->qp->config("badrcptto") or do {
$self->log(LOGINFO, "skip: empty config");
return (DECLINED);
};
for my $line (@badrcptto) {
$line =~ s/^\s+//g; # trim leading whitespace
my ($bad, $reason) = split /\s+/, $line, 2;
next if ! $bad;
if ( $self->is_match( $to, lc($bad), $host ) ) {
if ( $reason ) {
return (DENY, "mail to $bad not accepted here");
}
else {
return Qpsmtpd::DSN->no_such_user("mail to $bad not accepted here");
}
};
}
$self->log(LOGINFO, 'pass');
return (DECLINED);
}
sub is_match {
my ( $self, $to, $bad, $host ) = @_;
if ( $bad =~ /[\/\^\$\*\+\!\%]/ ) { # it's a regexp
$self->log(LOGDEBUG, "badmailfrom pattern ($bad) match for $to");
if ( $to =~ /$bad/i ) {
$self->log(LOGINFO, 'fail: pattern match');
return 1;
};
return;
};
if ( $bad !~ m/\@/ ) {
$self->log(LOGERROR, "badrcptto: bad config: no \@ sign in $bad");
return;
};
$bad = lc $bad;
$to = lc $to;
if ( substr($bad,0,1) eq '@' ) {
if ( $bad eq "\@$host" ) {
$self->log(LOGINFO, 'fail: host match');
return 1;
};
return;
};
if ( $bad eq $to ) {
$self->log(LOGINFO, 'fail: rcpt match');
return 1;
}
return;
};
sub get_host_and_to {
my ( $self, $recipient ) = @_;
if ( ! $recipient ) {
$self->log(LOGERROR, 'skip: no recipient!');
return;
};
if ( ! $recipient->host || ! $recipient->user ) {
$self->log(LOGINFO, 'skip: missing host or user');
return;
};
my $host = lc $recipient->host;
return ( $host, lc($recipient->user) . '@' . $host );
};

48
plugins/check_badrcptto_patterns Normal file
View File

@ -0,0 +1,48 @@
#!perl -w
=pod
=head1 SYNOPSIS
This plugin checks the badrcptto_patterns config. This allows
special patterns to be denied (e.g. percent hack, bangs,
double ats).
=head1 CONFIG
config/badrcptto_patterns
Patterns are stored in the format pattern\sresponse, where pattern
is a Perl pattern expression. Don't forget to anchor the pattern if
you want to restrict it from matching anywhere in the string.
qpsmtpd already ensures that the address contains an @, with something
to the left and right of the @.
=head1 AUTHOR
Copyright 2005 Gordon Rowell <gordonr@gormand.com.au>
This software is free software and may be distributed under the same
terms as qpsmtpd itself.
=cut
sub hook_rcpt
{
my ($self, $transaction, $recipient) = @_;
return (DECLINED) if $self->qp->connection->relay_client();
my @badrcptto = $self->qp->config("badrcptto_patterns") or return (DECLINED);
my $host = lc $recipient->host;
my $to = lc($recipient->user) . '@' . $host;
for (@badrcptto)
{
my ($pattern, $response) = split /\s+/, $_, 2;
return (DENY, $response) if ($to =~ /$pattern/);
}
return (DECLINED);
}

162
plugins/check_basicheaders Normal file
View File

@ -0,0 +1,162 @@
#!perl -w
=head1 NAME
check_basicheaders
=head1 DESCRIPTION
Checks for missing or empty values in the From or Date headers.
Optionally test if the Date header is too many days in the past or future. If
I<future> or I<past> are not defined, they are not tested.
If the remote IP is whitelisted, header validation is skipped.
=head1 CONFIGURATION
The following optional settings exist:
=head2 future
The number of days in the future beyond which messages are invalid.
check_basicheaders [ future 1 ]
=head2 past
The number of days in the past beyond which a message is invalid. The Date header is added by the MUA, so there are many valid reasons a message may have an older date in the header. It could have been delayed by the client, the sending server, connectivity problems, recipient server problem, recipient server configuration, etc. The I<past> setting should take those factors into consideration.
I would be surprised if a valid message ever had a date header older than a week.
check_basicheaders [ past 5 ]
=head2 reject
Determine if the connection is denied. Use the I<reject 0> option when first enabling the plugin, and then watch your logs to see what would have been rejected. When you are no longer concerned that valid messages will be rejected, enable with I<reject 1>.
check_basicheaders reject [ 0 | 1 ]
Default: 1
=head2 reject_type
Whether to issue a permanent or temporary rejection. The default is permanent.
check_basicheaders reject_type [ temp | perm ]
Using a temporary rejection is a cautious way to enable rejections. It allows an administrator to watch for a trial period and assure no valid messages are rejected. If a deferral of valid mail is noticed, I<reject 0> can be set to permit the deferred message to be delivered.
Default: perm
=head2 loglevel
Adjust the quantity of logging for this plugin. See docs/logging.pod
=head1 AUTHOR
2004 - Written by Jim Winstead Jr.
2012 - added logging, named arguments, reject_type, tests - Matt Simerson
- deprecate days for I<past> & I<future>. Improved POD
=head1 LICENSE
Released to the public domain, 26 March 2004.
=cut
use strict;
use warnings;
use Qpsmtpd::Constants;
use Date::Parse qw(str2time);
sub register {
my ($self, $qp, @args) = @_;
if ( @args == 1 ) {
$self->{_args}{days} = $args[0];
}
elsif ( @args % 2 ) {
$self->log(LOGWARN, "invalid arguments");
}
else {
$self->{_args} = { @args };
};
# provide backwards compatibility with the previous unnamed 'days' argument
if ( $self->{_args}{days} ) {
if ( ! defined $self->{_args}{future} ) {
$self->{_args}{future} = $self->{_args}{days};
};
if ( ! defined $self->{_args}{past} ) {
$self->{_args}{past} = $self->{_args}{days};
};
};
# set explicit defaults
$self->{_args}{reject_type} ||= 'perm';
if ( ! defined $self->{_args}{reject} ) {
$self->{_args}{reject} = 1;
};
}
sub hook_data_post {
my ($self, $transaction) = @_;
my $type = $self->get_reject_type();
if ( $transaction->data_size == 0 ) {
$self->log(LOGINFO, "fail: no data");
return ($type, "You must send some data first");
};
my $header = $transaction->header or do {
$self->log(LOGINFO, "fail: no headers");
return ($type, "missing header");
};
return (DECLINED, "immune") if $self->is_immune();
if ( ! $header->get('From') ) {
$self->log(LOGINFO, "fail: no from");
return ($type, "We require a valid From header");
};
my $date = $header->get('Date') or do {
$self->log(LOGINFO, "fail: no date");
return ($type, "We require a valid Date header");
};
chomp $date;
my $err_msg = $self->invalid_date_range($date);
if ( $err_msg ) {
return ($type, $err_msg );
};
return (DECLINED);
};
sub invalid_date_range {
my ($self, $date) = @_;
my $ts = str2time($date) or do {
$self->log(LOGINFO, "skip: date not parseable ($date)");
return;
};
my $past = $self->{_args}{past};
if ( $past && $ts < time - ($past*24*3600) ) {
$self->log(LOGINFO, "fail: date too old ($date)");
return "The Date header is too far in the past";
};
my $future = $self->{_args}{future};
if ( $future && $ts > time + ($future*24*3600) ) {
$self->log(LOGINFO, "fail: date in future ($date)");
return "The Date header is too far in the future";
};
$self->log(LOGINFO, "pass");
return;
}

126
plugins/check_bogus_bounce Normal file
View File

@ -0,0 +1,126 @@
#!perl -w
=head1 NAME
check_bogus_bounce - Check that a bounce message isn't bogus
=head1 DESCRIPTION
This plugin is designed to reject bogus bounce messages.
In our case a bogus bounce message is defined as a bounce message
which has more than a single recipient.
=head1 CONFIGURATION
Only a single argument is recognized and is assumed to be the default
action. Valid settings are:
=over 8
=item log
Merely log the receipt of the bogus bounce (the default behaviour).
=item deny
Deny with a hard error code.
=item denysoft
Deny with a soft error code.
=back
=cut
=head1 AUTHOR
Steve Kemp
--
http://steve.org.uk/Software/qpsmtpd/
=cut
=begin doc
Look for our single expected argument and configure "action" appropriately.
=end doc
=cut
sub register {
my ($self, $qp, $arg, @nop) = (@_);
#
# Default behaviour is to merely log.
#
$self->{_action} = "log";
#
# Unless one was specified
#
if ($arg) {
if ($arg =~ /^(log|deny|denysoft)$/i) {
$self->{_action} = $arg;
}
else {
die "Invalid argument '$arg' - use one of : log, deny, denysoft";
}
}
}
=begin doc
Handle the detection of bounces here.
If we find a match then we'll react with our expected action.
=end doc
=cut
sub hook_data_post {
my ($self, $transaction) = (@_);
#
# Find the sender, and return unless it wasn't a bounce.
#
my $sender = $transaction->sender->address || undef;
return DECLINED unless ($sender eq "<>");
#
# Get the recipients.
#
my @to = $transaction->recipients || ();
return DECLINED unless (scalar @to > 1);
#
# OK at this point we know:
#
# 1. It is a bounce, via the null-envelope.
# 2. It is a bogus bounce, because there are more than one recipients.
#
if (lc $self->{_action} eq "log") {
$self->log(LOGWARN,
$self->plugin_name() . " bogus bounce for :" . join(",", @to));
}
elsif (lc $self->{_action} eq "deny") {
return (DENY,
$self->plugin_name() . " determined this to be a bogus bounce");
}
elsif (lc $self->{_action} eq "denysoft") {
return (DENYSOFT,
$self->plugin_name() . " determined this to be a bogus bounce");
}
else {
$self->log(LOGWARN,
$self->plugin_name() . " failed to determine action. bug?");
}
#
# All done; allow this to proceed
#
return DECLINED;
}

Some files were not shown because too many files have changed in this diff Show More