[svn:qpsmtpd] r615 - branches/0.3x branches/0.3x/lib tags/0.32rc1 tags/0.32rc1/config.sample tags/0.32rc1/lib tags/0.32rc1/lib/Apache tags/0.32rc1/lib/Qpsmtpd tags/0.32rc1/log tags/0.32rc1/plugins tags/0.32rc1/plugins/auth tags/0.32rc1/plugins/ident tags/0.32rc1/plugins/logging tags/0.32rc1/plugins/queue tags/0.32rc1/plugins/virus tags/0.32rc1/t tags/0.32rc1/t/Test tags/0.32rc1/t/Test/Qpsmtpd tags/0.32rc1/t/plugin_tests
[email protected] 17 Feb 2006 19:02:02 -0000
| Newsgroups | perl.cvs.qpsmtpd |
|---|---|
| Message-ID | <[email protected]> |
Author: ask
Date: Fri Feb 17 11:02:02 2006
New Revision: 615
Added:
tags/0.32rc1/ (props changed)
tags/0.32rc1/.perltidyrc
tags/0.32rc1/CREDITS (contents, props changed)
tags/0.32rc1/Changes (contents, props changed)
tags/0.32rc1/LICENSE (contents, props changed)
tags/0.32rc1/MANIFEST (contents, props changed)
tags/0.32rc1/MANIFEST.SKIP (contents, props changed)
tags/0.32rc1/Makefile.PL (contents, props changed)
tags/0.32rc1/README (contents, props changed)
tags/0.32rc1/README.logging
tags/0.32rc1/README.plugins (contents, props changed)
tags/0.32rc1/STATUS (contents, props changed)
tags/0.32rc1/config.sample/
tags/0.32rc1/config.sample/IP (contents, props changed)
tags/0.32rc1/config.sample/badhelo (contents, props changed)
tags/0.32rc1/config.sample/badrcptto_patterns
tags/0.32rc1/config.sample/dnsbl_zones (contents, props changed)
tags/0.32rc1/config.sample/invalid_resolvable_fromhost
tags/0.32rc1/config.sample/logging
tags/0.32rc1/config.sample/loglevel (contents, props changed)
tags/0.32rc1/config.sample/plugins (contents, props changed)
tags/0.32rc1/config.sample/relayclients (contents, props changed)
tags/0.32rc1/config.sample/require_resolvable_fromhost (contents, props changed)
tags/0.32rc1/config.sample/rhsbl_zones (contents, props changed)
tags/0.32rc1/config.sample/size_threshold
tags/0.32rc1/lib/
tags/0.32rc1/lib/Apache/
tags/0.32rc1/lib/Apache/Qpsmtpd.pm (contents, props changed)
tags/0.32rc1/lib/Qpsmtpd/
tags/0.32rc1/lib/Qpsmtpd.pm (contents, props changed)
tags/0.32rc1/lib/Qpsmtpd/Address.pm (contents, props changed)
tags/0.32rc1/lib/Qpsmtpd/Auth.pm (contents, props changed)
tags/0.32rc1/lib/Qpsmtpd/Connection.pm (contents, props changed)
tags/0.32rc1/lib/Qpsmtpd/Constants.pm (contents, props changed)
tags/0.32rc1/lib/Qpsmtpd/DSN.pm
tags/0.32rc1/lib/Qpsmtpd/Plugin.pm (contents, props changed)
tags/0.32rc1/lib/Qpsmtpd/Postfix.pm (contents, props changed)
tags/0.32rc1/lib/Qpsmtpd/SMTP.pm (contents, props changed)
tags/0.32rc1/lib/Qpsmtpd/SelectServer.pm (contents, props changed)
tags/0.32rc1/lib/Qpsmtpd/TcpServer.pm (contents, props changed)
tags/0.32rc1/lib/Qpsmtpd/Transaction.pm (contents, props changed)
tags/0.32rc1/lib/Qpsmtpd/Utils.pm (contents, props changed)
tags/0.32rc1/log/ (props changed)
tags/0.32rc1/log/.cvsignore (contents, props changed)
tags/0.32rc1/log/run (contents, props changed)
tags/0.32rc1/plugins/
tags/0.32rc1/plugins/auth/
tags/0.32rc1/plugins/auth/auth_cvm_unix_local
tags/0.32rc1/plugins/auth/auth_flat_file
tags/0.32rc1/plugins/auth/auth_ldap_bind
tags/0.32rc1/plugins/auth/auth_vpopmail_sql (contents, props changed)
tags/0.32rc1/plugins/auth/authdeny (contents, props changed)
tags/0.32rc1/plugins/auth/authnull (contents, props changed)
tags/0.32rc1/plugins/check_badmailfrom (contents, props changed)
tags/0.32rc1/plugins/check_badmailfromto (contents, props changed)
tags/0.32rc1/plugins/check_badrcptto (contents, props changed)
tags/0.32rc1/plugins/check_badrcptto_patterns
tags/0.32rc1/plugins/check_basicheaders (contents, props changed)
tags/0.32rc1/plugins/check_earlytalker (contents, props changed)
tags/0.32rc1/plugins/check_loop
tags/0.32rc1/plugins/check_norelay
tags/0.32rc1/plugins/check_relay (contents, props changed)
tags/0.32rc1/plugins/check_spamhelo (contents, props changed)
tags/0.32rc1/plugins/content_log (contents, props changed)
tags/0.32rc1/plugins/count_unrecognized_commands (contents, props changed)
tags/0.32rc1/plugins/dns_whitelist_soft (contents, props changed)
tags/0.32rc1/plugins/dnsbl (contents, props changed)
tags/0.32rc1/plugins/greylisting (contents, props changed)
tags/0.32rc1/plugins/hosts_allow
tags/0.32rc1/plugins/http_config (contents, props changed)
tags/0.32rc1/plugins/ident/
tags/0.32rc1/plugins/ident/geoip (contents, props changed)
tags/0.32rc1/plugins/ident/p0f (contents, props changed)
tags/0.32rc1/plugins/logging/
tags/0.32rc1/plugins/logging/adaptive
tags/0.32rc1/plugins/logging/devnull
tags/0.32rc1/plugins/logging/file
tags/0.32rc1/plugins/logging/syslog
tags/0.32rc1/plugins/logging/warn
tags/0.32rc1/plugins/milter (contents, props changed)
tags/0.32rc1/plugins/queue/
tags/0.32rc1/plugins/queue/exim-bsmtp (contents, props changed)
tags/0.32rc1/plugins/queue/maildir (contents, props changed)
tags/0.32rc1/plugins/queue/postfix-queue (contents, props changed)
tags/0.32rc1/plugins/queue/qmail-queue (contents, props changed)
tags/0.32rc1/plugins/queue/smtp-forward (contents, props changed)
tags/0.32rc1/plugins/quit_fortune (contents, props changed)
tags/0.32rc1/plugins/rcpt_ok (contents, props changed)
tags/0.32rc1/plugins/require_resolvable_fromhost (contents, props changed)
tags/0.32rc1/plugins/rhsbl (contents, props changed)
tags/0.32rc1/plugins/sender_permitted_from (contents, props changed)
tags/0.32rc1/plugins/spamassassin (contents, props changed)
tags/0.32rc1/plugins/tls
tags/0.32rc1/plugins/tls_cert (contents, props changed)
tags/0.32rc1/plugins/virus/
tags/0.32rc1/plugins/virus/aveclient (contents, props changed)
tags/0.32rc1/plugins/virus/bitdefender (contents, props changed)
tags/0.32rc1/plugins/virus/check_for_hi_virus (contents, props changed)
tags/0.32rc1/plugins/virus/clamav (contents, props changed)
tags/0.32rc1/plugins/virus/clamdscan (contents, props changed)
tags/0.32rc1/plugins/virus/hbedv (contents, props changed)
tags/0.32rc1/plugins/virus/kavscanner (contents, props changed)
tags/0.32rc1/plugins/virus/klez_filter (contents, props changed)
tags/0.32rc1/plugins/virus/sophie
tags/0.32rc1/plugins/virus/uvscan (contents, props changed)
tags/0.32rc1/qpsmtpd (contents, props changed)
tags/0.32rc1/qpsmtpd-forkserver (contents, props changed)
tags/0.32rc1/qpsmtpd-server (contents, props changed)
tags/0.32rc1/run (contents, props changed)
tags/0.32rc1/t/
tags/0.32rc1/t/Test/
tags/0.32rc1/t/Test/Qpsmtpd/
tags/0.32rc1/t/Test/Qpsmtpd.pm (contents, props changed)
tags/0.32rc1/t/Test/Qpsmtpd/Plugin.pm (contents, props changed)
tags/0.32rc1/t/addresses.t (contents, props changed)
tags/0.32rc1/t/helo.t (contents, props changed)
tags/0.32rc1/t/plugin_tests/
tags/0.32rc1/t/plugin_tests.t (contents, props changed)
tags/0.32rc1/t/plugin_tests/check_badrcptto (contents, props changed)
tags/0.32rc1/t/plugin_tests/dnsbl (contents, props changed)
tags/0.32rc1/t/qpsmtpd-address.t (contents, props changed)
tags/0.32rc1/t/tempstuff.t (contents, props changed)
Modified:
/ (props changed)
branches/0.3x/Changes
branches/0.3x/lib/Qpsmtpd.pm
Log:
r4445@g5: ask | 2006-02-17 11:00:12 -0800
prepare for 0.32 -- plan release for next thursday
r4446@g5: ask | 2006-02-17 11:00:48 -0800
tag 0.32rc1
Modified: branches/0.3x/Changes
==============================================================================
--- branches/0.3x/Changes (original)
+++ branches/0.3x/Changes Fri Feb 17 11:02:02 2006
@@ -1,4 +1,4 @@
-0.32 -
+0.32 - 2006/02/23
Add logging/file plugin for simple logging to a file (Devin Carraway and
Peter J. Holzer).
@@ -11,7 +11,7 @@
Add plugins/tls_cert to generate appropriately shaped self-signed certs for
TLS support. Add explicit use of CA used to sign cert. Abstract clone()ing
- of connection information when switching to TLS. Fix Qpsmtpd::Auth to work
+ of connection information when switching to TLS. Fix the AUTH code to work
correctly with TLS.
Add hosts_allow plugin to support pre- and post-connection hooks as well
@@ -20,6 +20,13 @@
Improve postfix-queue plugin to support the known processing flags (Hanno
Hecker).
+ Drop root privileges before loading plugins, rather than after.
+
+ A few fixes to the clamdscan plugin (Dave Rolsky)
+
+ Various minor fixes and improvements
+
+
0.31.1 - 2005/11/18
Add missing files to the distribution, oops... (Thanks Budi Ang!)
Modified: branches/0.3x/lib/Qpsmtpd.pm
==============================================================================
--- branches/0.3x/lib/Qpsmtpd.pm (original)
+++ branches/0.3x/lib/Qpsmtpd.pm Fri Feb 17 11:02:02 2006
@@ -5,7 +5,7 @@ use vars qw($VERSION $Logger $TraceLevel
use Sys::Hostname;
use Qpsmtpd::Constants;
-$VERSION = "0.31.1";
+$VERSION = "0.32";
sub version { $VERSION };
Added: tags/0.32rc1/.perltidyrc
==============================================================================
--- (empty file)
+++ tags/0.32rc1/.perltidyrc Fri Feb 17 11:02:02 2006
@@ -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)
+
+
+
Added: tags/0.32rc1/CREDITS
==============================================================================
--- (empty file)
+++ tags/0.32rc1/CREDITS Fri Feb 17 11:02:02 2006
@@ -0,0 +1,36 @@
+Jim Winstead <[email protected]>: the core "command dispatch"
+system in qpsmtpd is taken from his colobus nntp server. The
+check_badmailfrom and check_mailrcptto plugins.
+
+John Peacock <[email protected]>: More changes, fixes and vast
+improvements for me to ever catch up on here.
+
+Matt Sergeant <[email protected]>: 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 <[email protected]>: 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 <[email protected]>: fixing the maximum message size
+(databytes) stuff.
+
+Marius Kjeldahl <[email protected]>, Zukka Zitting
+<[email protected]>: Patches for supporting $ENV{RELAYCLIENT}
+
+Robert Spier <[email protected]>: Klez filter.
+
+Rasjid Wilcox <[email protected]>: Lots of patches as per the
+Changes file.
+
+Kee Hinckley <[email protected]>: Sent me the correct strftime
+format for the dates in the "Received" headers.
+
+Gergely Risko <[email protected]>: 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 subversion logs and
+ mailing list archives. Thanks everyone!
Added: tags/0.32rc1/Changes
==============================================================================
--- (empty file)
+++ tags/0.32rc1/Changes Fri Feb 17 11:02:02 2006
@@ -0,0 +1,617 @@
+0.32 - 2006/02/23
+
+ Add logging/file plugin for simple logging to a file (Devin Carraway and
+ Peter J. Holzer).
+
+ Add logging/syslog plugin for logging via the syslog facility (Devin
+ Carrway)
+
+ Add Qpsmtpd::DSN to return extended SMTP status codes from RFC-1893 and
+ patch existing plugins to use it when appropriate (Hanno Hecker).
+
+ Add plugins/tls_cert to generate appropriately shaped self-signed certs for
+ TLS support. Add explicit use of CA used to sign cert. Abstract clone()ing
+ of connection information when switching to TLS. Fix the AUTH code to work
+ correctly with TLS.
+
+ Add hosts_allow plugin to support pre- and post-connection hooks as well
+ as move --max-from-ip tests out of core (Hanno Hecker).
+
+ Improve postfix-queue plugin to support the known processing flags (Hanno
+ Hecker).
+
+ Drop root privileges before loading plugins, rather than after.
+
+ A few fixes to the clamdscan plugin (Dave Rolsky)
+
+ Various minor fixes and improvements
+
+
+0.31.1 - 2005/11/18
+
+ Add missing files to the distribution, oops... (Thanks Budi Ang!)
+ (exim plugin, tls plugin, various sample configuration files)
+
+
+0.31 - 2005/11/16
+
+ STARTTLS support (see plugins/tls)
+
+ Added queue/exim-bsmtp plugin to spool accepted mail into an Exim
+ backend via BSMTP. (Devin Carraway)
+
+ New plugin inheritance system, see the bottom of README.plugins for
+ more information
+
+ qpsmtpd-forkserver: --listen-address may now be given more than once, to
+ request listening on multiple local addresses (Devin Carraway)
+ (also: no more signal problems making qpsmtpd-forkserver crash/loop
+ when forking).
+
+ qpsmtpd-forkserver: add an option for writing a PID file (pjh)
+
+ qpsmtpd-forkserver: set auxiliary groups (this is needed for the
+ postfix backend, which expects to have write permission to a fifo
+ which usually belongs to group postdrop). (pjh)
+
+ qpsmtpd-forkserver: if -d or --detach is given on the commandline,
+ forkserver will detach from the controlling terminal and daemonize
+ itself (Devin Carraway)
+
+ replace some fun smtp comments with boring ones.
+
+ example patterns for badrcptto plugin - Gordon Rowell
+
+ Extend require_resolvable_fromhost to include a configurable list of
+ "impossible" addresses to combat spammer forging. (Hanno Hecker)
+
+ Use qmail/control/smtpdgreeting if it exists, otherwise
+ show the original qpsmtpd greeting (with version information).
+
+ Apply slight variation on patch from Peter Holzer to allow specification of
+ an explicit $QPSMTPD_CONFIG variable to specify where the config lives,
+ overriding $QMAIL/control and /var/qmail/control if set. The usual
+ "last location with the file wins" rule still applies.
+
+ Refactor Qpsmtpd::Address
+
+ when disconncting with a temporary failure, return 421 rather than
+ 450 or 451. (Peter J. Holzer)
+
+ The unrecognized_command hook now uses DENY_DISCONNECT return
+ for disconnecting the user.
+
+ If the environment variable $QPSMTPD_CONFIG is set, qpsmtpd will look
+ for its config files in the directory given therein, in addition to (and
+ in preference to) other locations. (Peter J. Holzer)
+
+ Updated documentation
+
+ Various minor cleanups
+
+
+0.30 - 2005/07/05
+
+ Add plugable logging support include sample plugin which replicates
+ the existing core code. Add OK hook.
+
+ Add new logging plugin, logging/adaptive, which logs at different
+ levels depending on whether the message was accepted/rejected.
+
+ (See README.logging for information about the new logging system by
+ John Peacock)
+
+ plugins/auth/auth_ldap_bind - New plugin to authenticate against an
+ LDAP database. Thanks to Elliot Foster <[email protected]>
+
+ new plugin: plugins/auth/auth_flat_file - flat file auth plugin
+
+ new plugin: plugins/auth/auth_cvm_unix_local - Only DENY if the
+ credentials were accepted but incorrect (bad password?). Interfaces
+ with Bruce Guenther's Credential Validation Module (CVM)
+
+ Revamp Qpsmtpd::Constants so it is possible to retrieve the text
+ representation from the numeric (for logging purposes).
+
+ new plugin: plugins/check_badrcptto_patterns - Match bad RCPTO
+ address with regex (Gordon Rowell)
+
+ new plugin: plugins/check_norelay - Carve out holes from larger
+ relay blocks (Also Gordon Rowell)
+
+ new plugin: plugins/virus/sophie - Uses SOPHOS Antivirus via Sophie
+ resident daemon.
+
+ Store mail in memory up to a certain threshold (default 10k).
+
+ Remove needless restriction on temp_file() to allow the spool
+ directory path to include dots (as in ../)
+
+ Fix off-by-one line numbers in warnings from plugins (thanks to
+ Brian Grossman).
+
+ Don't check the HELO host for rfc-ignorant compliance
+
+ body_write patches from Brian Grossman
+
+ Fix for corruption problem under Apache
+
+ Update Apache::Qpsmtpd to work with the latest Apache/mod_perl 2.0
+ API. Fix various bucket issues.
+
+ Replace $ENV{RELAYCLIENT} with $connection->relay_client in last plugin.
+
+ Fix typo in qpsmtpd-forkserver commandline help
+
+0.29 - 2005/03/03
+
+ Store entire incoming message in spool file (so that scanners can read
+ the complete message) and ignore old headers before adding lines and
+ queuing for delivery.
+
+ New anti-virus scanners: hbedv (Hanno Hecker), bitdefender, and clamdscan
+ (John Peacock). Update clamav plugin to directly scan the spool file.
+
+ New temp_file() and temp_dir() methods; when used by plugins, they create
+ a filename or directory which will last only as long as the current
+ transaction. Also created a spool_dir() method which checks/creates the
+ spool_dir when the application starts up. All three methods are also
+ available in the base class where the temp_* objects are not automatically
+ limited to the transaction's lifetime. (John Peacock)
+
+ Added Gavin Carr's greylisting plugin
+
+ Renamed config/ to config.sample/
+
+ Qpsmtpd::Auth - document $mechanism option, improve fallback to generic
+ hooks, document that auth-login works now, stash auth user and method for
+ later use by Qpsmtpd::SMTP to generate authentication header.
+ (Michael Toren)
+
+ Qpsmtpd::SMTP - "MAIL FROM: <#@[]>" now works like qmail (null sender),
+ add LOGIN to default auth mechanisms, display auth user and method in
+ Received: line instead of X-Qpsmtpd-Auth header.
+ (Michael Toren)
+
+ check_badmailfromto - NEW PLUGIN - like check_badmailfrom except matches
+ both FROM: and TO:, and effectively makes it seem like the recipient
+ no longer exists for that sender (great for harassment cases).
+ (John Peacock)
+
+ check_earlytalker and require_resolvable_fromhost - short circuit test if
+ whitelistclient is set. (Michael Toren)
+
+ check_badmailfrom - Do not say why a given message is denied.
+ (Michael Toren)
+
+ dns_whitelist_soft - NEW PLUGIN - dns-based whitelist override for
+ other qpsmtpd plugins. Add suuport for whitelisthost to dnsbl.
+ (John Peacock)
+
+ auth/auth_vpopmail_sql - Support CRAM-MD5 (requires clear_passwd)
+ (John Peacock)
+
+ plugins/queue/qmail-queue - Added a timestamp and the qmail-queue qp
+ identifier to the "Queued!" message, for compatibility with qmail-smtpd
+ (Michael Toren)
+
+ Support qmail-smtpd's timeoutsmtpd config file
+
+ Many improvements to the forking server (qpsmtpd-forkserver)
+
+ Plugin testing framework (Matt)
+
+ Added Apache::Qpsmtpd (Apache/mod_perl 2.0 connection handler)
+
+ Allow for multiple instances of a single plugin by using plugin:0
+ notation (Robert)
+
+ Fix CDB support so the server can work without it
+
+ VRFY plugin support (Robert Spier)
+
+ Added Makefile.PL etc to make it easier to build a package (Matt).
+
+ Added Apache::Qpsmtpd to the distro.
+
+ Make the distro follow the CPAN module style (Makefile.PL, MANIFEST, etc)
+
+ Make the rhsbl plugin do DNS lookups in the background. (Mark Powell)
+
+ Fix warning in count_unrecognized_commands plugin (thanks to spaze
+ and Roger Walker)
+
+ Improve error messages from the Postfix module (Erik I. Bolsø,
+ <knan at mo.himolde.no>)
+
+ make the maildir plugin record who the message was to (with a bit of improvements
+ this could make a decent local delivery plugin)
+
+ Pass extra "stuff" to HELO/EHLO callbacks (to make it easier to
+ support SMTP extensions)
+
+ Renamed the *HARD return codes to DENY_DISCONNECT and
+ DENYSOFT_DISCONNECT (DENYSOFT_DISCONNECT is new)
+
+ Mail::Address does RFC822 addresses, we need SMTP addresses.
+ Replace Mail::Address with Peter J. Holzer's Qpsmtpd::Address module.
+
+ Don't keep adding ip addresses to the process status line ($0) when
+ running under PPerl.
+
+ Include the date and time the session started in the process status line.
+
+ Add "plugin/virus/uvscan" - McAfee commandline virus scanner
+
+ Inbound connections logged as soon as the remote host address is known
+ when running under tcpserver.
+
+ Add Qpsmtpd::Auth (authentication handlers! See plugins/auth/) (John Peacock)
+
+ Add a plugin hook for the DATA command
+
+ check_earlytalker -
+ + optionally react to an earlytalker by denying all MAIL-FROM commands
+ rather than issuing a 4xx/5xx greeting and disconnecting. (Mark
+ Powell)
+ + initial "awkward silence" period now configurable (Mark Powell)
+ + DENY/DENYSOFT now configurable
+
+ Move relay flag to connection object (John Peacock):
+ + add relay_client() method to Connection.pm
+ + Remove $transaction->relaying() completely (due to popular demand)
+
+ Split check_relay plugin into two plugins (John Peacock):
+ + check_relay now fires on connect and sets relay_client() flag
+ + rcpt_ok runs last of rcpt plugins and performs final OK/DENY
+ + change default config/plugins to reflect new order
+
+0.28 - 2004/06/05
+
+ Don't keep adding ip addresses to the process status line ($0) when running under PPerl.
+
+ Include the date and time the session started in the process status line.
+
+ Added a "queue/maildir" plugin for writing incoming mails to a maildir.
+
+ Create temp files with permissions 0600 (thanks to Robert James Kaes again)
+
+ Fix warning in check_badrcptto plugin (Thanks to Robert James Kaes)
+
+ Proper "Log levels" with a configuration option
+
+ $Include feature in config/plugins
+
+
+0.27.1 - 2004/03/11
+
+ SpamAssassin plugin Outlook compatibility fix (Thanks to Gergely Risko)
+
+
+0.27 - 2004/03/10
+
+ Support for unix sockets in the spamassassin plugin (requires SA
+ 2.60 or higher). Thanks to John Peacock!
+
+ Modified the dnsbl plugin to better support both A and TXT records and
+ support all of the RBLSMTPD functionality. (Thanks to Mark Powell)
+
+ reject bare carriage-returns in addition to the bare line-feeds
+ (based on a patch from Robert James Kaes, thanks!)
+
+ Bugfix to the count_unrecognized_commands plugin so it works
+ under PPerl (it wasn't resetting the count properly).
+
+ reset_transaction is called after disconnect plugins are called so
+ the Transaction objects DESTROY method is called. (Thanks to Robert
+ James Kaes <[email protected]>)
+
+ Made the SpamAssassin plugin work with SA 2.6+ (thanks to numerous
+ contributors, thanks everyone!). Note that for now it's not
+ including the Spam: headers with the score explained. For that use
+ the spamassassin_spamc plugin from http://projects.bluefeet.net/
+ (for now).
+
+ Added Postfix queue plugin thanks to Peter J Holzer!
+
+ Took out the last "exit" call from the SMTP object; the "transport"
+ module ("TcpServer", "SelectServer") needs to do the right thing in
+ it's disconnect method.
+
+ Update the SPF plugin (Philip Gladstone, [email protected]):
+ * Integrated with Mail::SPF::Query 1.991
+ * Don't do SPF processing when you are acting as a relay system
+ * Remove the MX changes as they are now inside Mail::SPF::Query
+
+ Take out Data::Dumper to save a few bytes of memory
+
+ Say Received: ... via ESMTP instead of via SMTP when the client
+ speaks ESMTP. (Hoping this can be a useful SpamAssassin rule).
+
+ Take out the X-SMTPD header.
+
+ Add pod documentation and sanity checking of the config to
+ check_badmailfrom
+
+ Use $ENV{QMAIL} to override /var/qmail for where to find the
+ control/ directory.
+
+ Enable "check_earlytalker" in the default plugins config
+
+ Added a milter plugin to allow use of sendmail milters
+
+ Don't store the Qpsmtpd object in the Plugin object any more (this
+ caused a circular reference)
+
+ Added a new qpsmtpd-server - a select() based server for qpsmtpd
+
+ Allow a config/relayclients and config/morerelayclients files to
+ define who can relay (useful with the select() server)
+
+ Fixed qpsmtpd unfolding all header lines
+
+ Speed up persistent qpsmtpd's by checking for plugin functions after
+ munging the name (the main breakage was with queue/qmail-queue)
+
+ Use dup2() instead of perl open("<&") style. POSIX seems to work better.
+
+ Added SPF, sender permitted from, plugin
+
+ More minor changes and probably a few big ones that we missed adding here :-)
+
+
+0.26 - 2003/06/11
+
+ Add queue/smtp-forward plugin (Matt Sergeant)
+
+ Add documentation to Qpsmtpd::Transaction (Matt Sergeant)
+
+ Fix bug in dnsbl that made it sometimes ignore "hits" (thanks to
+ James H. Thompson <[email protected]>)
+
+ Fix bug hiding the error message when an existing configuration file
+ isn't readable.
+
+ If a plugin running the ehlo hook add something to the ARRAY
+ reference $self->transaction->notes('capabilities') then it will be
+ added to the EHLO response.
+
+ Add command_counter method to the SMTP object. Plugins can use this
+ to catch (or not) consecutive commands. In particular useful with
+ the unrecognized_command hook.
+
+ Filter out all uncommon characters from the remote_host
+ setting. (thanks to Frank Denis / Jedi/Sector One for the hint).
+
+ Added a check for the spool_dir having mode 0700.
+
+ Don't break under taint mode on OpenBSD. (thanks to Frank Denis /
+ Jedi/Sector One)
+
+ Have the qmail-queue plugin add the message-id to the "Queued!"
+ message we send back to the client (to help those odd sendmail using
+ people debug their logs)
+
+ Set the process name to "qpsmtpd [1.2.3.4 : host.name.tld]"
+
+ Fixed timeout bug when the client sent DATA and then stopped before
+ sending the next line. (Gergely Risko <[email protected]>)
+
+ unrecognized_command hook and a count_unrecognized_commands
+ plugin. (Rasjid Wilcox)
+
+ check_earlytalker plugin. Deny the connection if the client talks
+ before we show our SMTP banner. (From Devin Carraway)
+
+ Patch Qpsmtpd::SMTP to allow connect plugins to give DENY and
+ DENYSOFT return codes. Based on patch from Devin Carraway.
+
+ Support morercpthosts.cdb
+
+ config now takes an extra "type" parameter. If it's "map" then a
+ reference to a tied hash will be returned.
+
+
+0.25 - 2003/03/18
+
+ Use the proper RFC2822 date format in the Received headers. (Somehow
+ I had convinced myself that ISO8601 dates were okay). Thanks to
+ Kee Hinckley <[email protected]>.
+
+ Print the date in the local timezone instead of in -0000. (Not
+ entirely convinced this is a good idea)
+
+ Lots of changes from Rasjid Wilcox <[email protected]>:
+
+ Fix error handling in queue/qmail-queue. (Rasjid)
+
+ Add option to queue/qmail-queue to specify an alternate qmail-queue
+ location. (Rasjid)
+
+ Add support for the QMAILQUEUE environment variable. (Rasjid)
+
+ PPerl compatibility (yay!) (Rasjid)
+
+ Allow mail to <abuse> and <postmaster> to go through. (Rasjid)
+
+ Add "deny" hook that gets called when another hook returns DENY or
+ DENYSOFT. (Rasjid)
+
+ Add list of required modules to the README. Thanks to Skaag Argonius
+ <[email protected]>.
+
+ Fix dnsbl plugin to give us all the results. (Patch from Matt
+ Sergeant <[email protected]>)
+
+ Disable identd lookups by passing -R to tcpserver. (Thanks to Matt)
+
+ add plugin hooks for HELO and EHLO (Devin Carraway
+ <[email protected]>)
+
+ check_spamhelo plugin to deny mail from claimed senders from the
+ list specified in F<badhelo>. (For example aol.com or yahoo.com)
+ (Devin Carraway)
+
+
+0.20 - 2002/12/09
+
+ Fix the "too many dots in the beginning of the line" bug.
+
+ Add munge_subject_threshold and reject_threshold options to the
+ spamassassin plugin. Add documentation to the spamassassin plugin.
+
+ Add -p to mkdir in log/run (Rasjid Wilcox <[email protected]>)
+
+ clamav plugin, thanks to Matt Sergeant, [email protected].
+ Enabling this might require you to increase your "softlimit" in
+ the run file. http://www.clamav.org/
+
+ Make the spamassassin plugin not stop the next content plugins from
+ running.
+
+ Store hooks runtime config globally so they will work within the
+ transaction objects too.
+
+ content_log plugin - log the content of all mails for
+ debugging. Robert Spier <[email protected]>.
+
+ http_config plugin - get configuration via http
+
+ plugins can take arguments via their line in the "plugins" file
+
+ make the quit_fortune plugin check that the fortune program exists
+
+
+0.12 - 2002/10/17
+
+ Better error messages when a plugin fails
+
+ Remove some debug messages in the log
+
+ Fix NOOP command with perl 5.6.
+
+ Better installation instructions and error message when no plugin
+ allowed or denied relaying (thanks to Lars Rander
+ <[email protected]>).
+
+ Use /usr/bin/perl instead of the non-standard /home/perl/bin/perl
+
+
+0.11 - 2002/10/09
+
+ Make a "queue" plugin hook and move the qmail-queue functionality
+ to plugins/queue/qmail-queue. This allows you to make qpsmtpd
+ delivery mail via smtp or lmtp or into a database or whatever you want.
+
+ Reorganize most of Qpsmtpd.pm into Qpsmtpd/SMTP.pm.
+
+ Add spool_dir option (thanks to Ross Mueller <[email protected]>)
+
+ Add plugin name to the "hooks" data structure, so we can log plugin
+ module had an error when we run a hook.
+
+ Make klez filter run for mails bigger than 220KB; they are sometimes
+ bigger than that.
+
+ Avoid "use of uninitialized variable" warning when the "MAIL" or the
+ "RCPT" command is executed without a parameter.
+
+ Compatibility with perl 5.5.3.
+
+ Fix "Could not print" error message in the TcpServer object. (Thanks
+ to Ross Mueller <[email protected]>)
+
+ dnsbl plugin queues lookups in the background upon connect but
+ doesn't block for the results until they are needed, greatly
+ speeding up connection times. Also fix a typo in the dnsbl plugin
+ so it'll actually work(!).
+
+ check_badmailfrom and check_badrcptto plugins (Jim Winstead
+ <[email protected]>)
+
+ Better RFC conformance. (Reset transactions after the DATA command and
+ when the MAIL command is being done)
+
+
+0.10 - 2002/09/08
+
+ New object oriented internals
+
+ Very flexible plugin
+
+ All functionality not core to SMTP moved to plugins
+
+ Can accept mails as large as your file system will allow (instead of
+ up to as much memory you would allow qpsmtpd to eat).
+
+2002/09/08
+ Add klez_filter plugin
+
+ Support more return codes for data_post
+
+ Document data_post
+
+ Add plugin name to the log entries when plugins use log()
+
+ Add plugin_name method to the default plugin object.
+
+ Improve error handling in the spamassassin plugin
+
+
+2002/08/06
+ Spool message bodies to a tmp file so we can support HUGE messages
+
+ API to read the message body (undocumented, subject to change)
+
+ data_post hook (undocumented)
+
+ SpamAssassin plugin (connects to spamd on localhost), see
+ plugins/spamassassin
+
+
+2002/07/15
+ DNS RBL and RHSBL support via plugins.
+
+ More hooks.
+
+2002/07/03
+ First (non functional) version of the new object oriented mail engine (0.10).
+
+
+Changes on the old v0.0x branch:
+
+2002/05/09
+ Klez filter (thanks to Robert Spier)
+
+2002/04/20
+ Bumped version number to 0.07
+
+ Support comments in configuration files (prefix the line with #)
+
+ Support RELAYCLIENT like qmail-smtpd (thanks to Marius Kjeldahl
+ <[email protected]> and Zukka Zitting <[email protected]>)
+
+ If the connection fails while in DATA we would just accept the
+ message. Ouch! Thanks to Devin Carraway <[email protected]> for the
+ patch.
+
+
+2002/01/26
+ Allow [1.2.3.4] for the hostname when checking if the dns resolves
+
+
+2002/01/21
+ assorted fixes; getting dnsbl's to actually work
+
+ fixing the maximum message size (databytes) stuff (thanks for the
+ spot to Andrew Pam <[email protected]>)
+
+ support and enable taint checking (thanks to Devin Carraway
+ <[email protected]>)
+
+ Make the MAIL FROM host dns check configurable. (thanks to Devin
+ Carraway).
+
+ Add more documentation to the README file.
+
+
Added: tags/0.32rc1/LICENSE
==============================================================================
--- (empty file)
+++ tags/0.32rc1/LICENSE Fri Feb 17 11:02:02 2006
@@ -0,0 +1,19 @@
+Copyright (C) 2001-2005 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.
Added: tags/0.32rc1/MANIFEST
==============================================================================
--- (empty file)
+++ tags/0.32rc1/MANIFEST Fri Feb 17 11:02:02 2006
@@ -0,0 +1,100 @@
+Changes
+config.sample/badhelo
+config.sample/badrcptto_patterns
+config.sample/dnsbl_zones
+config.sample/invalid_resolvable_fromhost
+config.sample/IP
+config.sample/logging
+config.sample/loglevel
+config.sample/plugins
+config.sample/relayclients
+config.sample/require_resolvable_fromhost
+config.sample/rhsbl_zones
+config.sample/size_threshold
+CREDITS
+lib/Apache/Qpsmtpd.pm
+lib/Qpsmtpd.pm
+lib/Qpsmtpd/Address.pm
+lib/Qpsmtpd/Auth.pm
+lib/Qpsmtpd/Connection.pm
+lib/Qpsmtpd/Constants.pm
+lib/Qpsmtpd/Plugin.pm
+lib/Qpsmtpd/Postfix.pm
+lib/Qpsmtpd/SelectServer.pm
+lib/Qpsmtpd/SMTP.pm
+lib/Qpsmtpd/TcpServer.pm
+lib/Qpsmtpd/Transaction.pm
+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/auth/auth_cvm_unix_local
+plugins/auth/auth_flat_file
+plugins/auth/auth_ldap_bind
+plugins/auth/auth_vpopmail_sql
+plugins/auth/authdeny
+plugins/auth/authnull
+plugins/check_badmailfrom
+plugins/check_badmailfromto
+plugins/check_badrcptto
+plugins/check_badrcptto_patterns
+plugins/check_basicheaders
+plugins/check_earlytalker
+plugins/check_loop
+plugins/check_norelay
+plugins/check_relay
+plugins/check_spamhelo
+plugins/content_log
+plugins/count_unrecognized_commands
+plugins/dns_whitelist_soft
+plugins/dnsbl
+plugins/greylisting
+plugins/http_config
+plugins/ident/geoip
+plugins/ident/p0f
+plugins/logging/adaptive
+plugins/logging/devnull
+plugins/logging/warn
+plugins/milter
+plugins/queue/exim-bsmtp
+plugins/queue/maildir
+plugins/queue/postfix-queue
+plugins/queue/qmail-queue
+plugins/queue/smtp-forward
+plugins/quit_fortune
+plugins/rcpt_ok
+plugins/require_resolvable_fromhost
+plugins/rhsbl
+plugins/sender_permitted_from
+plugins/spamassassin
+plugins/tls
+plugins/virus/aveclient
+plugins/virus/bitdefender
+plugins/virus/check_for_hi_virus
+plugins/virus/clamav
+plugins/virus/clamdscan
+plugins/virus/hbedv
+plugins/virus/kavscanner
+plugins/virus/klez_filter
+plugins/virus/sophie
+plugins/virus/uvscan
+qpsmtpd
+qpsmtpd-forkserver
+qpsmtpd-server
+README
+README.logging
+README.plugins
+run
+STATUS
+t/addresses.t
+t/helo.t
+t/plugin_tests.t
+t/plugin_tests/check_badrcptto
+t/plugin_tests/dnsbl
+t/qpsmtpd-address.t
+t/tempstuff.t
+t/Test/Qpsmtpd.pm
+t/Test/Qpsmtpd/Plugin.pm
Added: tags/0.32rc1/MANIFEST.SKIP
==============================================================================
--- (empty file)
+++ tags/0.32rc1/MANIFEST.SKIP Fri Feb 17 11:02:02 2006
@@ -0,0 +1,27 @@
+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
Added: tags/0.32rc1/Makefile.PL
==============================================================================
--- (empty file)
+++ tags/0.32rc1/Makefile.PL Fri Feb 17 11:02:02 2006
@@ -0,0 +1,27 @@
+#!/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,
+ },
+ ABSTRACT_FROM => 'README',
+ AUTHOR => 'Ask Bjorn Hansen <[email protected]>',
+ EXE_FILES => [qw(qpsmtpd qpsmtpd-forkserver)],
+);
+
+sub MY::libscan {
+ my $path = $_[1];
+ return '' if $path =~ /\B\.svn\b/;
+ return $path;
+}
+
Added: tags/0.32rc1/README
==============================================================================
--- (empty file)
+++ tags/0.32rc1/README Fri Feb 17 11:02:02 2006
@@ -0,0 +1,206 @@
+#
+# this file is best read with `perldoc README`
+#
+
+=head1 NAME
+
+Qpsmtpd - qmail perl simple mail transfer protocol daemon
+
+web:
+ http://smtpd.develooper.com/
+
+mailinglist:
+ [email protected]
+
+
+=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 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 Subversion you can just do
+run the following command in the /home/smtpd/ directory.
+
+ svn co http://svn.perl.org/qpsmtpd/trunk .
+
+Beware that the trunk might be unstable and unsuitable for anything but development, so you might want to get a specific release, for example:
+
+ svn co http://svn.perl.org/qpsmtpd/tags/0.31 .
+
+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 now!
+Just symlink /home/smtpd/qpsmtpd into your /services (or /var/services
+or /var/svscan or whatever) directory. Remember to shutdown
+qmail-smtpd if you are replacing it with qpsmtpd.
+
+If you don't use supervise, then you need to run the ./run script in
+some other way.
+
+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.
+
+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
[email protected].
+
+
+=head1 Better Performance
+
+As of version 0.21 qpsmtpd supports "PPerl"
+http://search.cpan.org/search?dist=PPerl
+
+"PPerl turns ordinary perl scripts into long running daemons, making
+subsequent executions extremely fast. It forks several processes for
+each script, allowing many processes to call the script at once."
+
+Running under PPerl is easy - just change your "run" file to contain
+the following command:
+
+ pperl -Tw -- --prefork=$MAXCLIENTS --maxclients=$MAXCLIENTS \
+ --no-cleanup ./qpsmtpd 2>&1
+
+As an alternative to PPerl (some users find PPerl unstable) we recommend using
+the forkserver. This forks for every connection, but pre-loads all the plugins
+to reduce the overhead.
+
+=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 "check_relay" plugin is the standard plugin for
+this. Other plugins provides 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 includes:
+
+=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 doesnt exist, it
+will default to use $ENV{HOME}/tmp/. This directory should be set with
+a mode of 700 and owned by the smtpd user.
+
+
+=item 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 first check the logfile.
+
+As default it goes into log/main/current. Qpsmtpd can log a lot of
+debug information. You can get more or less by adjusting $TRACE_LEVEL
+in lib/Qpsmtpd.pm (sorry, no easy switch for that yet). Something
+between 1 and 3 should give you just a little bit. If you set it to
+10 or higher you will get lots of information in the logs.
+
+If the logfile doesn't give away the problem, then post to the
+mailinglist (subscription instructions above). If possibly then put
+the logfile on a webserver and include a reference to it in the mail.
+
+
+
+
Added: tags/0.32rc1/README.logging
==============================================================================
--- (empty file)
+++ tags/0.32rc1/README.logging Fri Feb 17 11:02:02 2006
@@ -0,0 +1,74 @@
+#
+# read this with 'perldoc README.logging' ...
+#
+
+=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.
+
Added: tags/0.32rc1/README.plugins
==============================================================================
--- (empty file)
+++ tags/0.32rc1/README.plugins Fri Feb 17 11:02:02 2006
@@ -0,0 +1,351 @@
+#
+# read this with 'perldoc README.plugins' ...
+#
+
+=head1 qpsmtpd plugin system; developer documentation
+
+See the examples in plugins/ and ask questions on the qpsmtpd
+mailinglist; subscribe by sending mail to [email protected].
+
+=head1 General return codes
+
+Each plugin must return an allowed constant for the hook and (usually)
+optionally a "message".
+
+Generally all plugins for a hook are processed until one returns
+something other than "DECLINED".
+
+Plugins are run in the order they are listed in the "plugins"
+configuration.
+
+=over 4
+
+=item OK
+
+Action allowed
+
+=item DENY
+
+Action denied
+
+=item DENYSOFT
+
+Action denied; return a temporary rejection code (say 450 instead of 550).
+
+=item 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.
+
+=item DECLINED
+
+Plugin declined work; proceed as usual. This return code is _always_
+_allowed_ unless noted otherwise.
+
+=item DONE
+
+Finishing processing of the request. Usually used when the plugin
+sent the response to the client.
+
+=back
+
+See more detailed description for each hook below.
+
+=head1 Hooks
+
+=head2 pre-connection
+
+Called by a controlling process (e.g. forkserver or Apache::Qpsmtpd) after
+accepting the remote server, but before beginning a new instance. Useful for
+load-management and rereading large config files at some frequency less than
+once per session. The hook doesn't have a predefined additional input value,
+but one can be passed as a hash of name/value pairs.
+
+=head2 post-connection
+
+Like pre-connection only it can be called after an instance has been
+completely finished (e.g. after the child process has ended in forkserver).
+The hook doesn't have a predefined additional input value, but one can be
+passed as a hash of name/value pairs.
+
+
+=head2 connect
+
+Allowed return codes:
+
+ OK - Stop processing plugins, give the default response
+ DECLINED - Process the next plugin
+ DONE - Stop processing plugins and don't give the default response
+ DENY - Return hard failure code and disconnect
+ DENYSOFT - Return soft failure code and disconnect
+
+Note: DENY_DISCONNECT and DENYSOFT_DISCONNECT are not supported here due to
+them having no meaning beyond what DENY and DENYSOFT already do.
+
+
+=head2 helo
+
+Called on "helo" from the client.
+
+ DENY - Return a 550 code
+ DENYSOFT - Return a 450 code
+ DENY_DISCONNECT & DENYSOFT_DISCONNECT - as above but with disconnect
+ DONE - Qpsmtpd won't do anything; the plugin sent the message
+ DECLINED - Qpsmtpd will send the standard HELO message
+
+
+=head2 ehlo
+
+Called on "ehlo" from the client.
+
+ DENY - Return a 550 code
+ DENYSOFT - Return a 450 code
+ DENY_DISCONNECT & DENYSOFT_DISCONNECT - as above but with disconnect
+ DONE - Qpsmtpd won't do anything; the plugin sent the message
+ DECLINED - Qpsmtpd will send the standard HELO message
+
+
+=head2 mail
+
+Called right after the envelope sender address is passed. The plugin
+gets passed a Mail::Address object. Default is to allow the
+recipient.
+
+Allowed return codes
+
+ OK - sender allowed
+ DENY - Return a hard failure code
+ DENYSOFT - Return a soft failure code
+ DENY_DISCONNECT & DENYSOFT_DISCONNECT - as above but with disconnect
+ DONE - skip further processing
+
+
+=head2 rcpt
+
+Hook for the "rcpt" command. Defaults to deny the mail with a soft
+error code.
+
+Allowed return codes
+
+ OK - recipient allowed
+ DENY - Return a hard failure code
+ DENYSOFT - Return a soft failure code
+ DENY_DISCONNECT & DENYSOFT_DISCONNECT - as above but with disconnect
+ DONE - skip further processing
+
+
+=head2 data
+
+Hook for the "data" command. Defaults to '354, "go ahead"'.
+
+ DENY - Return a hard failure code
+ DENYSOFT - Return a soft failure code
+ DENY_DISCONNECT & DENYSOFT_DISCONNECT - as above but with disconnect
+ DONE - Plugin took care of receiving data and calling the queue (not
+ recommended)
+
+
+=head2 data_post
+
+Hook after receiving all data; just before the message is queued.
+
+ DENY - Return a hard failure code
+ DENYSOFT - Return a soft failure code
+ DENY_DISCONNECT & DENYSOFT_DISCONNECT - as above but with disconnect
+ DONE - skip further processing (message will not be queued)
+
+All other codes and the message will be queued normally
+
+
+=head2 queue
+
+Called on completion of the DATA command, after the data_post hook.
+
+ DONE - skip further processing (plugin gave response code)
+ OK - Return success message
+ DENY - Return hard failure code
+ DENYSOFT - Return soft failure code
+
+Any other code will return a soft failure code.
+
+
+=head2 quit
+
+Called on the "quit" command.
+
+Allowed return codes:
+
+ DONE
+
+Works like the "connect" hook.
+
+
+=head2 unrecognized_command
+
+Called when we get a command that isn't recognized.
+
+ DENY_DISCONNECT - Return 521 and disconnect the client
+ DENY - Return 500
+ DONE - Qpsmtpd won't do anything; the plugin responded
+ Anything else - Return '500 Unrecognized command'
+
+=head2 disconnect
+
+Called just before we shutdown a connection.
+
+The return code is ignored. If a plugin returns anything but DECLINED
+the following plugins will not be run (like with all other hooks).
+
+=head2 deny
+
+Called when another hook returns DENY or DENYSOFT. First parameter is
+the previous hook return code; the second parameter the message the
+hook returned.
+
+Returning DONE or OK will stop the next deny hook from being run.
+DECLINED will make qpsmtpd run the remaining configured deny hooks.
+
+=head2 vrfy
+
+Hook for the "VRFY" command. Defaults to returning a message telling
+the user to just try sending the message.
+
+Allowed return codes:
+
+ OK - Recipient Exists
+ DENY - Return a hard failure code
+ DONE - Return nothing and move on
+ Anything Else - Return a 252
+
+=head1 Return Values and Notes
+
+Insert stuff here about how:
+
+ - 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.
+
+
+=head1 Include Files
+
+(put more about how the $Include stuff works here)
+
+With the $Include stuff you order using the filename of the plugin.d
+file. So if you have a plugin called xyz but want it to come early on,
+you call it's config file 00_xyz, but that file still refers to the
+plugin called xyz.
+
+=head1 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 $self->qp->temp_dir() which takes a single
+parameter for the permissions requested (see L<mkdir> for details). A
+directory created like this will B<not> be deleted when the transaction is
+ended.
+
+=item spool_dir()
+
+Returns the configured system-wide spool directory.
+
+=back
+
+=head1 Naming Conventions
+
+Plugins should be written using standard named hook subroutines. This
+allows them to be overloaded and extended easily.
+
+Because some of our callback names have characters invalid in
+subroutine names, they must be translated. The current translation
+routine is: C< s/\W/_/g; >
+
+=head2 Naming Map
+
+ 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
+
+=head1 Register
+
+If you choose not to use the default naming convention, you need to
+register the hooks in your plugin. You do this with the C< register >
+method call on the plugin object.
+
+ sub register {
+ my ($self, $qp) = @_;
+
+ $self->register_hook('mail', 'mail_handler');
+ $self->register_hook('rcpt', 'rcpt_handler');
+ $self->register_hook('disconnect', 'disconnect_handler');
+ }
+
+ sub mail_handler { ... }
+ sub rcpt_handler { ... }
+ sub disconnect_handler { ... }
+
+A single plugin can register as many hooks as it wants, and can
+register a hook multiple times.
+
+The C< register > method is also often used for initialization and
+reading configuration.
+
+=head1 Init
+
+The 'init' method is the first method called after a plugin is
+loaded. It's mostly for inheritance, below.
+
+=head1 Inheritance
+
+Instead of modifying @ISA directly in your plugin, use the
+C< isa_plugin > method from the init subroutine.
+
+ # rcpt_ok_child
+ sub init {
+ my ($self, $qp) = @_;
+ $self->isa_plugin('rcpt_ok');
+ }
+
+ sub hook_rcpt {
+ my ($self, $transaction, $recipient) = @_;
+ # do something special here...
+ $self->SUPER::hook_rcpt( $transaction, $recipient );
+ }
+
+
+
Added: tags/0.32rc1/STATUS
==============================================================================
--- (empty file)
+++ tags/0.32rc1/STATUS Fri Feb 17 11:02:02 2006
@@ -0,0 +1,110 @@
+
+New Name Suggestions
+====================
+ignite
+flare(mta)
+quench
+pez (or pezmail)
+
+
+Near term roadmap
+=================
+
+0.32:
+ - Bugfixes
+ - add module requirements to the META.yml file
+
+0.40:
+ - Add user configuration plugin
+ - Add plugin API for checking if a local email address is valid
+ - use keyword "ESMTPA" in Received header in case of authentication to comply with RFC 3848.
+
+
+0.50:
+ Include the popular check_delivery[1] functionality via the 0.30 API
+ [1] until then get it from
+ http://www.openminddev.net/files/qpsmtpd/plugins/check_delivery/
+
+ Add API to reject individual recipients after the RCPT has been
+ accepted and generate individual bounce messages.
+
+0.51: bugfixes
+
+0.60: merge with the highperf branch?
+
+1.0bN: bugfixes (repeat until we run out of bugs to fix)
+1.0.0: it just might happen!
+1.1.0: new development
+
+
+Issues
+======
+
+Before next release
+-------------------
+
+update clamav plugin config to support the latest version properly
+
+
+Some day...
+-----------
+
+Understand "extension parameters" to the MAIL FROM and RCPT TO
+parameters (and make the plugin hooks able to get at them).
+
+plugins/queue/qmail-queue is still calling exit inappropriately
+(should call disconnect or some such)
+
+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
+
+plugin to reject mails from <> if it has multiple recipients.
+
+localiphost - support foo@[a.b.c.d] addresses
+
+support smtpgreeting (?)
+
+
+
+TRACE in Constants.pm is not actually being used. Should it be?
+
+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
+
Added: tags/0.32rc1/config.sample/IP
==============================================================================
--- (empty file)
+++ tags/0.32rc1/config.sample/IP Fri Feb 17 11:02:02 2006
@@ -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.
Added: tags/0.32rc1/config.sample/badhelo
==============================================================================
--- (empty file)
+++ tags/0.32rc1/config.sample/badhelo Fri Feb 17 11:02:02 2006
@@ -0,0 +1,4 @@
+# these domains never uses their domain when greeting us, so reject transactions
+aol.com
+yahoo.com
+
Added: tags/0.32rc1/config.sample/badrcptto_patterns
==============================================================================
--- (empty file)
+++ tags/0.32rc1/config.sample/badrcptto_patterns Fri Feb 17 11:02:02 2006
@@ -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
Added: tags/0.32rc1/config.sample/dnsbl_zones
==============================================================================
--- (empty file)
+++ tags/0.32rc1/config.sample/dnsbl_zones Fri Feb 17 11:02:02 2006
@@ -0,0 +1,4 @@
+rbl.mail-abuse.org
+spamsources.fabel.dk
+relays.ordb.org
+sbl.spamhaus.org
Added: tags/0.32rc1/config.sample/invalid_resolvable_fromhost
==============================================================================
--- (empty file)
+++ tags/0.32rc1/config.sample/invalid_resolvable_fromhost Fri Feb 17 11:02:02 2006
@@ -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
Added: tags/0.32rc1/config.sample/logging
==============================================================================
--- (empty file)
+++ tags/0.32rc1/config.sample/logging Fri Feb 17 11:02:02 2006
@@ -0,0 +1 @@
+logging/warn 9
Added: tags/0.32rc1/config.sample/loglevel
==============================================================================
--- (empty file)
+++ tags/0.32rc1/config.sample/loglevel Fri Feb 17 11:02:02 2006
@@ -0,0 +1,10 @@
+# Log levels
+# LOGDEBUG = 7
+# LOGINFO = 6
+# LOGNOTICE = 5
+# LOGWARN = 4
+# LOGERROR = 3
+# LOGCRIT = 2
+# LOGALERT = 1
+# LOGEMERG = 0
+4
Added: tags/0.32rc1/config.sample/plugins
==============================================================================
--- (empty file)
+++ tags/0.32rc1/config.sample/plugins Fri Feb 17 11:02:02 2006
@@ -0,0 +1,60 @@
+#
+# 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=
+
+# 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
+
+quit_fortune
+
+check_earlytalker
+count_unrecognized_commands 4
+check_relay
+
+require_resolvable_fromhost
+
+rhsbl
+dnsbl
+check_badmailfrom
+check_badrcptto
+check_spamhelo
+
+# sender_permitted_from
+
+# this plugin needs to run after all other "rcpt" plugins
+rcpt_ok
+
+# 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
+
+
+# run the clamav virus checking plugin
+# virus/clamav
+
+# 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
+# check_relay
+# check_relay:0 somearg
+# check_relay:1 someotherarg
Added: tags/0.32rc1/config.sample/relayclients
==============================================================================
--- (empty file)
+++ tags/0.32rc1/config.sample/relayclients Fri Feb 17 11:02:02 2006
@@ -0,0 +1,4 @@
+# Format is IP, or IP part with trailing dot
+# e.g. "127.0.0.1", or "192.168."
+127.0.0.1
+192.168.
Added: tags/0.32rc1/config.sample/require_resolvable_fromhost
==============================================================================
--- (empty file)
+++ tags/0.32rc1/config.sample/require_resolvable_fromhost Fri Feb 17 11:02:02 2006
@@ -0,0 +1,3 @@
+1
+
+# use 0 to disable; anything else to enable.
\ No newline at end of file
Added: tags/0.32rc1/config.sample/rhsbl_zones
==============================================================================
--- (empty file)
+++ tags/0.32rc1/config.sample/rhsbl_zones Fri Feb 17 11:02:02 2006
@@ -0,0 +1,5 @@
+dsn.rfc-ignorant.org does not accept bounces. This violates RFC 821/2505/2821 http://www.rfc-ignorant.org/
+
+
+
+
Added: tags/0.32rc1/config.sample/size_threshold
==============================================================================
--- (empty file)
+++ tags/0.32rc1/config.sample/size_threshold Fri Feb 17 11:02:02 2006
@@ -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
Added: tags/0.32rc1/lib/Apache/Qpsmtpd.pm
==============================================================================
--- (empty file)
+++ tags/0.32rc1/lib/Apache/Qpsmtpd.pm Fri Feb 17 11:02:02 2006
@@ -0,0 +1,220 @@
+# $Id$
+
+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);
+
+ my $qpsmtpd = Qpsmtpd::Apache->new();
+ $qpsmtpd->start_connection(
+ ip => $c->remote_ip,
+ host => $c->remote_host,
+ info => undef,
+ dir => $c->base_server->dir_config('QpsmtpdDir'),
+ conn => $c,
+ );
+
+ $qpsmtpd->run($c);
+
+ return Apache2::Const::OK;
+}
+
+package Qpsmtpd::Apache;
+
+use Qpsmtpd::Constants;
+use base qw(Qpsmtpd::SMTP);
+
+sub start_connection {
+ my $self = shift;
+ my %opts = @_;
+
+ $self->{qpdir} = $opts{dir};
+ $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,
+ @_);
+}
+
+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 config_dir {
+ my ($self, $config) = @_;
+ -e "$_/$config" and return $_
+ for "$self->{qpdir}/config";
+ return "/var/qmail/control";
+}
+
+
+sub plugin_dir {
+ my $self = shift;
+ return "$self->{qpdir}/plugins";
+}
+
+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->log(LOGDEBUG, "dispatching $data");
+ defined $self->dispatch(split / +/, $data)
+ 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
+
+ LoadModule perl_module modules/mod_perl.so
+
+ <Perl>
+ use lib qw( /path/to/qpsmtpd/lib );
+ use Apache::Qpsmtpd;
+ </Perl>
+
+ <VirtualHost _default_:25>
+ PerlSetVar QpsmtpdDir /path/to/qpsmtpd
+ PerlModule Apache::Qpsmtpd
+ PerlProcessConnectionHandler Apache::Qpsmtpd
+ PerlSetVar qpsmtpd.loglevel 4
+ </VirtualHost>
+
+=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
+
+Currently the F<check_early_talker> plugin will not work because it
+relies on being able to do C<select()> on F<STDIN> which does not
+work here. It should be possible with the next release of mod_perl
+to do a C<poll()> on the socket though, so we can hopefully get
+that working in the future.
+
+Other operations that perform directly on the STDIN/STDOUT filehandles
+will not work.
+
+=head1 AUTHOR
+
+Matt Sergeant, <[email protected]>
+
+Some credit goes to <[email protected]> for Apache::SMTP which gave
+me the inspiration to do this.
+
+=cut
Added: tags/0.32rc1/lib/Qpsmtpd.pm
==============================================================================
--- (empty file)
+++ tags/0.32rc1/lib/Qpsmtpd.pm Fri Feb 17 11:02:02 2006
@@ -0,0 +1,456 @@
+package Qpsmtpd;
+use strict;
+use vars qw($VERSION $Logger $TraceLevel $Spool_dir $Size_threshold);
+
+use Sys::Hostname;
+use Qpsmtpd::Constants;
+
+$VERSION = "0.32";
+
+sub version { $VERSION };
+
+sub TRACE_LEVEL { $TraceLevel }; # leave for plugin compatibility
+
+sub load_logging {
+ # need to do this differently that other plugins so as to
+ # not trigger logging activity
+ my $self = shift;
+ return if $self->{hooks}->{"logging"};
+ my $configdir = $self->config_dir("logging");
+ my $configfile = "$configdir/logging";
+ my @loggers = $self->_config_from_file($configfile,'logging');
+ my $dir = $self->plugin_dir;
+
+ $self->_load_plugins($dir, @loggers);
+
+ foreach my $logger (@loggers) {
+ $self->log(LOGINFO, "Loaded $logger");
+ }
+
+ return @loggers;
+}
+
+sub trace_level {
+ my $self = shift;
+ return $TraceLevel if $TraceLevel;
+
+ my $configdir = $self->config_dir("loglevel");
+ my $configfile = "$configdir/loglevel";
+ $TraceLevel = $self->_config_from_file($configfile,'loglevel');
+
+ unless (defined($TraceLevel) and $TraceLevel =~ /^\d+$/) {
+ $TraceLevel = LOGWARN; # Default if no loglevel file found.
+ }
+
+ 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 already don't have this loaded yet
+
+ my ($rc) = $self->run_hooks("logging", $trace, $hook, $plugin, @log);
+
+ unless ( $rc and $rc == DECLINED or $rc == OK ) {
+ # no logging plugins registered so fall back to STDERR
+ warn join(" ", $$ .
+ (defined $plugin ? " $plugin plugin:" :
+ defined $hook ? " running plugin ($hook):" : ""),
+ @log), "\n"
+ if $trace <= $self->trace_level();
+ }
+}
+
+#
+# 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) = @_;
+
+ #warn "SELF->config($c) ", ref $self;
+
+ my %defaults = (
+ me => hostname,
+ timeout => 1200,
+ );
+
+ my ($rc, @config) = $self->run_hooks("config", $c);
+ @config = () unless $rc == OK;
+
+ if (wantarray) {
+ @config = $self->get_qmail_config($c, $type) unless @config;
+ @config = $defaults{$c} if (!@config and $defaults{$c});
+ return @config;
+ }
+ else {
+ return ($config[0] || $self->get_qmail_config($c, $type) || $defaults{$c});
+ }
+}
+
+sub config_dir {
+ my ($self, $config) = @_;
+ my $configdir = ($ENV{QMAIL} || '/var/qmail') . '/control';
+ my ($name) = ($0 =~ m!(.*?)/([^/]+)$!);
+ $configdir = "$name/config" if (-e "$name/config/$config");
+ if (exists $ENV{QPSMTPD_CONFIG}) {
+ $ENV{QPSMTPD_CONFIG} =~ /^(.*)$/; # detaint
+ $configdir = $1 if -e "$1/$config";
+ }
+ return $configdir;
+}
+
+sub plugin_dir {
+ my ($name) = ($0 =~ m!(.*?)/([^/]+)$!);
+ my $dir = "$name/plugins";
+}
+
+sub get_qmail_config {
+ my ($self, $config, $type) = @_;
+ $self->log(LOGDEBUG, "trying to get config for $config");
+ if ($self->{_config_cache}->{$config}) {
+ return wantarray ? @{$self->{_config_cache}->{$config}} : $self->{_config_cache}->{$config}->[0];
+ }
+ my $configdir = $self->config_dir($config);
+
+ my $configfile = "$configdir/$config";
+
+ if ($type and $type eq "map") {
+ return +{} unless -e $configfile . ".cdb";
+ 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 +{};
+ }
+ #warn Data::Dumper->Dump([\%h], [qw(h)]);
+ # should we cache this?
+ return \%h;
+ }
+
+ return $self->_config_from_file($configfile, $config);
+}
+
+sub _config_from_file {
+ my ($self, $configfile, $config, $visited) = @_;
+ return unless -e $configfile;
+
+ $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/} @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++;
+ }
+ }
+
+ $self->{_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 !/^\./ } 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;
+
+ $self->log(LOGWARN, "Plugins already loaded") if $self->{hooks};
+ $self->{hooks} = {};
+
+ my @plugins = $self->config('plugins');
+
+ my $dir = $self->plugin_dir;
+ $self->log(LOGNOTICE, "loading plugins from $dir");
+
+ @plugins = $self->_load_plugins($dir, @plugins);
+
+ return @plugins;
+}
+
+sub _load_plugins {
+ my $self = shift;
+ my ($dir, @plugins) = @_;
+
+ my @ret;
+ for my $plugin_line (@plugins) {
+ my ($plugin, @args) = split ' ', $plugin_line;
+
+ 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;
+
+ my $package = "Qpsmtpd::Plugin::$plugin_name";
+
+ # don't reload plugins if they are already loaded
+ unless ( defined &{"${package}::plugin_name"} ) {
+ Qpsmtpd::Plugin->compile($plugin_name,
+ $package, "$dir/$plugin", $self->{_test_mode});
+ $self->log(LOGDEBUG, "Loading $plugin_line")
+ unless $plugin_line =~ /logging/;
+ }
+
+ my $plug = $package->new();
+ push @ret, $plug;
+ $plug->_register($self, @args);
+
+ }
+
+ return @ret;
+}
+
+sub transaction {
+ return {}; # base class implements empty transaction
+}
+
+sub run_hooks {
+ my ($self, $hook) = (shift, shift);
+ my $hooks = $self->{hooks};
+ if ($hooks->{$hook}) {
+ my @r;
+ for my $code (@{$hooks->{$hook}}) {
+ if ( $hook eq 'logging' ) { # without calling $self->log()
+ eval { (@r) = $code->{code}->($self, $self->transaction, @_); };
+ $@ and warn("FATAL LOGGING PLUGIN ERROR: ", $@) and next;
+ }
+ else {
+ $self->varlog(LOGINFO, $hook, $code->{name});
+ eval { (@r) = $code->{code}->($self, $self->transaction, @_); };
+ $@ and $self->log(LOGCRIT, "FATAL PLUGIN ERROR: ", $@) and next;
+
+ !defined $r[0]
+ and $self->log(LOGERROR, "plugin ".$code->{name}
+ ." running the $hook hook returned undef!")
+ and next;
+
+ if ($self->transaction) {
+ my $tnotes = $self->transaction->notes( $code->{name} );
+ $tnotes->{"hook_$hook"}->{'return'} = $r[0]
+ if (!defined $tnotes || ref $tnotes eq "HASH");
+ } else {
+ my $cnotes = $self->connection->notes( $code->{name} );
+ $cnotes->{"hook_$hook"}->{'return'} = $r[0]
+ if (!defined $cnotes || ref $cnotes eq "HASH");
+ }
+
+ # should we have a hook for "OK" too?
+ if ($r[0] == DENY or $r[0] == DENYSOFT or
+ $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("deny", $code->{name}, $r[0], $r[1]) unless ($hook eq "deny");
+ } else {
+ $r[1] = "" if not defined $r[1];
+ $self->log(LOGDEBUG, "Plugin ".$code->{name}.
+ ", hook $hook returned ".return_code($r[0]).", $r[1]");
+ $self->run_hooks("ok", $code->{name}, $r[0], $r[1]) unless ($hook eq "ok");
+ }
+
+ }
+
+ last unless $r[0] == DECLINED;
+ }
+ $r[0] = DECLINED if not defined $r[0];
+ return @r;
+ }
+ return (0, '');
+}
+
+sub _register_hook {
+ my $self = shift;
+ my ($hook, $code, $unshift) = @_;
+
+ my $hooks = $self->{hooks};
+ 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(LOGINFO, "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
+
+ # Make sure the spool dir has appropriate rights
+ if (-e $Spool_dir) {
+ my $mode = (stat($Spool_dir))[2];
+ $self->log(LOGWARN,
+ "Permissions on spool_dir $Spool_dir are not 0700")
+ if $mode & 07077;
+ }
+
+ # And finally, create it if it doesn't already exist
+ -d $Spool_dir or mkdir($Spool_dir, 0700)
+ or die "Could not create spool_dir $Spool_dir: $!";
+ }
+
+ 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 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
+
+=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-2005 Ask Bjoern Hansen, Develooper LLC. See the
+LICENSE file for more information.
+
+
+
Added: tags/0.32rc1/lib/Qpsmtpd/Address.pm
==============================================================================
--- (empty file)
+++ tags/0.32rc1/lib/Qpsmtpd/Address.pm Fri Feb 17 11:02:02 2006
@@ -0,0 +1,328 @@
+#!/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 protected]>');
+
+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('<[email protected]>')
+
+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)
+ }
+ 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
+
+sub canonify {
+ my ($dummy, $path) = @_;
+ my $atom = '[a-zA-Z0-9!#\$\%\&\x27\*\+\x2D\/=\?\^_`{\|}~]+';
+ my $address_literal =
+'(?:\[(?:\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}|IPv6:[0-9A-Fa-f:.]+)\])';
+ my $subdomain = '(?:[a-zA-Z0-9](?:[-a-zA-Z0-9]*[a-zA-Z0-9])?)';
+ my $domain = "(?:$address_literal|$subdomain(?:\.$subdomain)*)";
+ my $qtext = '[\x01-\x08\x0B\x0C\x0E-\x1F\x21\x23-\x5B\x5D-\x7F]';
+ my $text = '[\x01-\x09\x0B\x0C\x0E-\x7F]';
+
+
+ # strip delimiters
+ return undef unless ($path =~ /^<(.*)>$/);
+ $path = $1;
+
+ # 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 eq "postmaster";
+
+ my ($localpart, $domainpart) = ($path =~ /^(.*)\@($domain)$/);
+ return (undef) unless defined $localpart;
+
+ if ($localpart =~ /^$atom(\.$atom)*/) {
+ # simple case, we are done
+ return ($localpart, $domainpart);
+ }
+ if ($localpart =~ /^"(($qtext|\\$text)*)"$/) {
+ $localpart = $1;
+ $localpart =~ s/\\($text)/$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()
+
+Returns the "localpart" of the address, per RFC-2821, or the portion
+before the '@' sign.
+
+=cut
+
+sub user {
+ my ($self) = @_;
+ return $self->{_user};
+}
+
+=head2 host()
+
+Returns the "domain" part of the address, per RFC-2821, or the portion
+after the '@' sign.
+
+=cut
+
+sub host {
+ my ($self) = @_;
+ return $self->{_host};
+}
+
+sub _addr_cmp {
+ require UNIVERSAL;
+ my ($left, $right, $swap) = @_;
+ my $class = ref($left);
+
+ unless ( UNIVERSAL::isa($right, $class) ) {
+ $right = $class->new($right);
+ }
+
+ #invert the address so we can sort by domain then user
+ ($left = 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;
Added: tags/0.32rc1/lib/Qpsmtpd/Auth.pm
==============================================================================
--- (empty file)
+++ tags/0.32rc1/lib/Qpsmtpd/Auth.pm Fri Feb 17 11:02:02 2006
@@ -0,0 +1,330 @@
+#!/usr/bin/perl -w
+
+=head1 NAME
+
+Qpsmtpd::Auth - 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 module 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 * register()
+
+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 register {
+ 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 AUTHOR
+
+John Peacock <[email protected]>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2004 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
+
+package Qpsmtpd::Auth;
+use Qpsmtpd::Constants;
+use MIME::Base64;
+
+sub e64
+{
+ my ($arg) = @_;
+ my $res = encode_base64($arg);
+ chomp($res);
+ return($res);
+}
+
+sub SASL {
+
+ # $DB::single = 1;
+ my ( $session, $mechanism, $prekey ) = @_;
+ my ( $user, $passClear, $passHash, $ticket );
+ $mechanism = lc($mechanism);
+
+ if ( $mechanism eq "plain" ) {
+ if (!$prekey) {
+ $session->respond( 334, "Please continue" );
+ $prekey= <STDIN>;
+ }
+ ( $passHash, $user, $passClear ) = split /\x0/,
+ decode_base64($prekey);
+
+ }
+ elsif ($mechanism eq "login") {
+
+ if ( $prekey ) {
+ ($passHash, $user, $passClear) = split /\x0/, decode_base64($prekey);
+ }
+ else {
+
+ $session->respond(334, e64("Username:"));
+ $user = decode_base64(<STDIN>);
+ #warn("Debug: User: '$user'");
+ if ($user eq '*') {
+ $session->respond(501, "Authentification canceled");
+ return DECLINED;
+ }
+
+ $session->respond(334, e64("Password:"));
+ $passClear = <STDIN>;
+ $passClear = decode_base64($passClear);
+ #warn("Debug: Pass: '$pass'");
+ if ($passClear eq '*') {
+ $session->respond(501, "Authentification canceled");
+ return DECLINED;
+ }
+ }
+ }
+ elsif ( $mechanism eq "cram-md5" ) {
+
+ # rand() is not cryptographic, but we only need to generate a globally
+ # unique number. The rand() is there in case the user logs in more than
+ # once in the same second, of if the clock is skewed.
+ $ticket = sprintf( "<%x.%x\@" . $session->config("me") . ">",
+ rand(1000000), time() );
+
+ # We send the ticket encoded in Base64
+ $session->respond( 334, encode_base64( $ticket, "" ) );
+ my $line = <STDIN>;
+
+ if ( $line eq '*' ) {
+ $session->respond( 501, "Authentification canceled" );
+ return DECLINED;
+ }
+
+ ( $user, $passHash ) = split( ' ', decode_base64($line) );
+ }
+ else {
+ $session->respond( 500, "Unrecognized authentification mechanism" );
+ return DECLINED;
+ }
+
+ # try running the specific hooks first
+ my ( $rc, $msg ) =
+ $session->run_hooks( "auth-$mechanism", $mechanism, $user, $passClear,
+ $passHash, $ticket );
+
+ # try running the polymorphous hooks next
+ if ( !$rc || $rc == DECLINED ) {
+ ( $rc, $msg ) =
+ $session->run_hooks( "auth", $mechanism, $user, $passClear,
+ $passHash, $ticket );
+ }
+
+ if ( $rc == OK ) {
+ $msg = "Authentication successful for $user" .
+ ( defined $msg ? " - " . $msg : "" );
+ $session->respond( 235, $msg );
+ $session->connection->relay_client(1);
+ $session->log( LOGINFO, $msg );
+
+ $session->{_auth_user} = $user;
+ $session->{_auth_mechanism} = $mechanism;
+ s/[\r\n].*//s for ($session->{_auth_user}, $session->{_auth_mechanism});
+
+ return OK;
+ }
+ else {
+ $msg = "Authentication failed for $user" .
+ ( defined $msg ? " - " . $msg : "" );
+ $session->respond( 535, $msg );
+ $session->log( LOGERROR, $msg );
+ return DENY;
+ }
+}
+
+# tag: qpsmtpd plugin that sets RELAYCLIENT when the user authentifies
+
+1;
Added: tags/0.32rc1/lib/Qpsmtpd/Connection.pm
==============================================================================
--- (empty file)
+++ tags/0.32rc1/lib/Qpsmtpd/Connection.pm Fri Feb 17 11:02:02 2006
@@ -0,0 +1,171 @@
+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 $new = $self->new();
+ foreach my $f ( @parameters ) {
+ $new->$f($self->$f()) if $self->$f();
+ }
+ 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 = shift;
+ my $key = shift;
+ @_ and $self->{_notes}->{$key} = shift;
+ $self->{_notes}->{$key};
+}
+
+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 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_info( )
+
+If your server does an ident lookup on the remote host, this is the
+identity of the remote client.
+
+=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])
+
+Connection-wide notes, used for passing data between plugins.
+
+=cut
Added: tags/0.32rc1/lib/Qpsmtpd/Constants.pm
==============================================================================
--- (empty file)
+++ tags/0.32rc1/lib/Qpsmtpd/Constants.pm Fri Feb 17 11:02:02 2006
@@ -0,0 +1,108 @@
+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,
+);
+
+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
Added: tags/0.32rc1/lib/Qpsmtpd/DSN.pm
==============================================================================
--- (empty file)
+++ tags/0.32rc1/lib/Qpsmtpd/DSN.pm Fri Feb 17 11:02:02 2006
@@ -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
Added: tags/0.32rc1/lib/Qpsmtpd/Plugin.pm
==============================================================================
--- (empty file)
+++ tags/0.32rc1/lib/Qpsmtpd/Plugin.pm Fri Feb 17 11:02:02 2006
@@ -0,0 +1,176 @@
+package Qpsmtpd::Plugin;
+use Qpsmtpd::Constants;
+use strict;
+
+our @hooks = qw(
+ logging config queue data data_post quit rcpt mail ehlo helo
+ auth auth-plain auth-login auth-cram-md5
+ connect reset_transaction unrecognized_command disconnect
+ deny ok pre-connection post-connection
+);
+our %hooks = map { $_ => 1 } @hooks;
+
+sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ bless ({}, $class);
+}
+
+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;
+ $self->qp->varlog(shift, $self->hook_name, $self->plugin_name, @_)
+ unless defined $self->hook_name and $self->hook_name eq 'logging';
+}
+
+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"};
+
+ $self->compile($self->plugin_name . "_isa_$cleanParent",
+ $newPackage,
+ "plugins/$parent"); # assumes Cwd is qpsmtpd root
+ 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) = @_;
+
+ 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/$plugin")) {
+ local $/ = undef;
+ $sub .= "#line 1 t/plugin_tests/$plugin\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] }",
+ "sub hook_name { return shift->{_hook}; }",
+ $line,
+ $sub,
+ "\n", # last line comment without newline?
+ );
+
+ #warn "eval: $eval";
+
+ $eval =~ m/(.*)/s;
+ $eval = $1;
+
+ eval $eval;
+ die "eval $@" if $@;
+}
+
+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;
Added: tags/0.32rc1/lib/Qpsmtpd/Postfix.pm
==============================================================================
--- (empty file)
+++ tags/0.32rc1/lib/Qpsmtpd/Postfix.pm Fri Feb 17 11:02:02 2006
@@ -0,0 +1,202 @@
+package Qpsmtpd::Postfix;
+
+=head1 NAME
+
+Qpsmtpd::Postfix
+
+=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 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) = @_;
+ my $self = IO::Socket::UNIX->new(Type => SOCK_STREAM,
+ Peer => "/var/spool/postfix/public/cleanup");
+ die qq[Couldn't open unix socket "/var/spool/postfix/public/cleanup": $!] unless ref $self;
+ 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 $strm = $class->open_cleanup();
+
+ 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
Added: tags/0.32rc1/lib/Qpsmtpd/SMTP.pm
==============================================================================
--- (empty file)
+++ tags/0.32rc1/lib/Qpsmtpd/SMTP.pm Fri Feb 17 11:02:02 2006
@@ -0,0 +1,602 @@
+package Qpsmtpd::SMTP;
+use Qpsmtpd;
+@ISA = qw(Qpsmtpd);
+
+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 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;
+}
+
+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}) {
+ my ($rc, $msg) = $self->run_hooks("unrecognized_command", $cmd, @_);
+ if ($rc == DENY_DISCONNECT) {
+ $self->respond(521, $msg);
+ $self->disconnect;
+ }
+ elsif ($rc == DENY) {
+ $self->respond(500, $msg);
+ }
+ elsif ($rc == DONE) {
+ 1;
+ }
+ else {
+ $self->respond(500, "Unrecognized command");
+ }
+ return 1
+ }
+ $cmd = $1;
+
+ if (1 or $self->{_commands}->{$cmd} and $self->can($cmd)) {
+ my ($result) = eval { $self->$cmd(@_) };
+ $self->log(LOGERROR, "XX: $@") if $@;
+ return $result if defined $result;
+ return $self->fault("command '$cmd' failed unexpectedly");
+ }
+
+ return;
+}
+
+sub fault {
+ my $self = shift;
+ my ($msg) = shift || "program fault - command not performed";
+ print STDERR "$0[$$]: $msg ($!)\n";
+ return $self->respond(451, "Internal error - try again later - " . $msg);
+}
+
+
+sub start_conversation {
+ my $self = shift;
+ # this should maybe be called something else than "connect", see
+ # lib/Qpsmtpd/TcpServer.pm for more confusion.
+ my ($rc, $msg) = $self->run_hooks("connect");
+ if ($rc == DENY) {
+ $self->respond(550, ($msg || 'Connection from you denied, bye bye.'));
+ return $rc;
+ }
+ elsif ($rc == DENYSOFT) {
+ $self->respond(450, ($msg || 'Connection from you temporarily denied, bye bye.'));
+ return $rc;
+ }
+ elsif ($rc == DONE) {
+ return $rc;
+ }
+ elsif ($rc != DONE) {
+ my $greets = $self->config('smtpgreeting');
+ if ( $greets ) {
+ $greets .= " ESMTP";
+ }
+ else {
+ $greets = $self->config('me')
+ . " ESMTP qpsmtpd "
+ . $self->version
+ . " ready; send us your mail, but not your spam.";
+ }
+
+ $self->respond(220, $greets);
+ return DONE;
+ }
+}
+
+sub transaction {
+ my $self = shift;
+ return $self->{_transaction} || $self->reset_transaction();
+}
+
+sub reset_transaction {
+ my $self = shift;
+ $self->run_hooks("reset_transaction") if $self->{_transaction};
+ return $self->{_transaction} = Qpsmtpd::Transaction->new();
+}
+
+
+sub connection {
+ my $self = shift;
+ @_ and $self->{_connection} = shift;
+ return $self->{_connection} || ($self->{_connection} = Qpsmtpd::Connection->new());
+}
+
+
+sub helo {
+ my ($self, $hello_host, @stuff) = @_;
+ return $self->respond (501,
+ "helo requires domain/address - see RFC-2821 4.1.1.1") unless $hello_host;
+ my $conn = $self->connection;
+ return $self->respond (503, "but you already said HELO ...") if $conn->hello;
+
+ my ($rc, $msg) = $self->run_hooks("helo", $hello_host, @stuff);
+ if ($rc == DONE) {
+ # do nothing
+ } elsif ($rc == DENY) {
+ $self->respond(550, $msg);
+ } elsif ($rc == DENYSOFT) {
+ $self->respond(450, $msg);
+ } elsif ($rc == DENY_DISCONNECT) {
+ $self->respond(550, $msg);
+ $self->disconnect;
+ } elsif ($rc == DENYSOFT_DISCONNECT) {
+ $self->respond(450, $msg);
+ $self->disconnect;
+ } else {
+ $conn->hello("helo");
+ $conn->hello_host($hello_host);
+ $self->transaction;
+ $self->respond(250, $self->config('me') ." Hi " . $conn->remote_info . " [" . $conn->remote_ip ."]; I am so happy to meet you.");
+ }
+}
+
+sub ehlo {
+ my ($self, $hello_host, @stuff) = @_;
+ return $self->respond (501,
+ "ehlo requires domain/address - see RFC-2821 4.1.1.1") unless $hello_host;
+ my $conn = $self->connection;
+ return $self->respond (503, "but you already said HELO ...") if $conn->hello;
+
+ my ($rc, $msg) = $self->run_hooks("ehlo", $hello_host, @stuff);
+ if ($rc == DONE) {
+ # do nothing
+ } elsif ($rc == DENY) {
+ $self->respond(550, $msg);
+ } elsif ($rc == DENYSOFT) {
+ $self->respond(450, $msg);
+ } elsif ($rc == DENY_DISCONNECT) {
+ $self->respond(550, $msg);
+ $self->disconnect;
+ } elsif ($rc == DENYSOFT_DISCONNECT) {
+ $self->respond(450, $msg);
+ $self->disconnect;
+ } else {
+ $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
+ my %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;
+ }
+ }
+ }
+
+ if ( %auth_mechanisms ) {
+ 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, $arg, @stuff ) = @_;
+
+ #they AUTH'd once already
+ return $self->respond( 503, "but you already said AUTH ..." )
+ if ( defined $self->{_auth}
+ and $self->{_auth} == OK );
+ return $self->respond( 503, "AUTH not defined for HELO" )
+ if ( $self->connection->hello eq "helo" );
+
+ return $self->{_auth} = Qpsmtpd::Auth::SASL( $self, $arg, @stuff );
+}
+
+sub mail {
+ my $self = shift;
+ return $self->respond(501, "syntax error in parameters") if !$_[0] or $_[0] !~ m/^from:/i;
+
+ # -> 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 {
+ my $from_parameter = join " ", @_;
+ $self->log(LOGINFO, "full from_parameter: $from_parameter");
+
+ my ($from) = ($from_parameter =~ m/^from:\s*(<[^>]*>)/i)[0];
+
+ # support addresses without <> ... maybe we shouldn't?
+ ($from) = "<" . ($from_parameter =~ m/^from:\s*(\S+)/i)[0] . ">"
+ unless $from;
+
+ $self->log(LOGALERT, "from email address : [$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;
+
+ my ($rc, $msg) = $self->run_hooks("mail", $from);
+ if ($rc == DONE) {
+ return 1;
+ }
+ elsif ($rc == DENY) {
+ $msg ||= $from->format . ', denied';
+ $self->log(LOGINFO, "deny mail from " . $from->format . " ($msg)");
+ $self->respond(550, $msg);
+ }
+ elsif ($rc == DENYSOFT) {
+ $msg ||= $from->format . ', temporarily denied';
+ $self->log(LOGINFO, "denysoft mail from " . $from->format . " ($msg)");
+ $self->respond(450, $msg);
+ }
+ elsif ($rc == DENY_DISCONNECT) {
+ $msg ||= $from->format . ', denied';
+ $self->log(LOGINFO, "deny mail from " . $from->format . " ($msg)");
+ $self->respond(550, $msg);
+ $self->disconnect;
+ }
+ elsif ($rc == DENYSOFT_DISCONNECT) {
+ $msg ||= $from->format . ', temporarily denied';
+ $self->log(LOGINFO, "denysoft mail from " . $from->format . " ($msg)");
+ $self->respond(421, $msg);
+ $self->disconnect;
+ }
+ else { # includes OK
+ $self->log(LOGINFO, "getting mail from ".$from->format);
+ $self->respond(250, $from->format . ", sender OK - how exciting to get mail from you!");
+ $self->transaction->sender($from);
+ }
+ }
+}
+
+sub rcpt {
+ my $self = shift;
+ return $self->respond(501, "syntax error in parameters") unless $_[0] and $_[0] =~ m/^to:/i;
+ return $self->respond(503, "Use MAIL before RCPT") unless $self->transaction->sender;
+
+ my ($rcpt) = ($_[0] =~ m/to:(.*)/i)[0];
+ $rcpt = $_[1] unless $rcpt;
+ $self->log(LOGALERT, "to email address : [$rcpt]");
+ $rcpt = (Qpsmtpd::Address->parse($rcpt))[0];
+
+ return $self->respond(501, "could not parse recipient") unless $rcpt;
+
+ my ($rc, $msg) = $self->run_hooks("rcpt", $rcpt);
+ if ($rc == DONE) {
+ return 1;
+ }
+ elsif ($rc == DENY) {
+ $msg ||= 'relaying denied';
+ $self->respond(550, $msg);
+ }
+ elsif ($rc == DENYSOFT) {
+ $msg ||= 'relaying denied';
+ return $self->respond(450, $msg);
+ }
+ elsif ($rc == DENY_DISCONNECT) {
+ $msg ||= 'delivery denied';
+ $self->log(LOGINFO, "delivery denied ($msg)");
+ $self->respond(550, $msg);
+ $self->disconnect;
+ }
+ elsif ($rc == DENYSOFT_DISCONNECT) {
+ $msg ||= 'relaying denied';
+ $self->log(LOGINFO, "delivery denied ($msg)");
+ $self->respond(421, $msg);
+ $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 = shift;
+ $self->respond(214,
+ "This is qpsmtpd " .
+ $self->config('smtpgreeting') ? '' : $self->version,
+ "See http://smtpd.develooper.com/",
+ 'To report bugs or send comments, mail to <[email protected]>.');
+}
+
+sub noop {
+ my $self = shift;
+ $self->respond(250, "OK");
+}
+
+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.
+
+ my ($rc, $msg) = $self->run_hooks("vrfy");
+ if ($rc == DONE) {
+ return 1;
+ }
+ elsif ($rc == DENY) {
+ $self->respond(554, $msg || "Access Denied");
+ $self->reset_transaction();
+ return 1;
+ }
+ elsif ($rc == OK) {
+ $self->respond(250, $msg || "User OK");
+ 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;
+ my ($rc, $msg) = $self->run_hooks("quit");
+ if ($rc != DONE) {
+ $self->respond(221, $self->config('me') . " closing connection. Have a wonderful day.");
+ }
+ $self->disconnect();
+}
+
+sub disconnect {
+ my $self = shift;
+ $self->run_hooks("disconnect");
+ $self->reset_transaction;
+}
+
+sub data {
+ my $self = shift;
+ my ($rc, $msg) = $self->run_hooks("data");
+ if ($rc == DONE) {
+ return 1;
+ }
+ elsif ($rc == DENY) {
+ $self->respond(554, $msg || "Message denied");
+ $self->reset_transaction();
+ return 1;
+ }
+ elsif ($rc == DENYSOFT) {
+ $self->respond(451, $msg || "Message denied temporarily");
+ $self->reset_transaction();
+ return 1;
+ }
+ elsif ($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;
+ }
+ $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/^\s*$/) {
+ $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 = "";
+
+ # 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();
+
+ }
+
+ # 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");
+
+ $self->transaction->header($header);
+
+ my $smtp = $self->connection->hello eq "ehlo" ? "ESMTP" : "SMTP";
+ my $authheader = (defined $self->{_auth} and $self->{_auth} == OK) ?
+ "(smtp-auth username $self->{_auth_user}, mechanism $self->{_auth_mechanism})\n" : "";
+
+ $header->add("Received", "from ".$self->connection->remote_info
+ ." (HELO ".$self->connection->hello_host . ") (".$self->connection->remote_ip
+ . ")\n $authheader by ".$self->config('me')." (qpsmtpd/".$self->version
+ .") with $smtp; ". (strftime('%a, %d %b %Y %H:%M:%S %z', localtime)),
+ 0);
+
+ # if we get here without seeing a terminator, the connection is
+ # probably dead.
+ $self->respond(451, "Incomplete DATA"), return 1 unless $complete;
+
+ #$self->respond(550, $self->transaction->blocked),return 1 if ($self->transaction->blocked);
+ $self->respond(552, "Message too big!"),return 1 if $max_size and $size > $max_size;
+
+ ($rc, $msg) = $self->run_hooks("data_post");
+ if ($rc == DONE) {
+ return 1;
+ }
+ elsif ($rc == DENY) {
+ $self->respond(552, $msg || "Message denied");
+ }
+ elsif ($rc == DENYSOFT) {
+ $self->respond(452, $msg || "Message denied temporarily");
+ }
+ else {
+ $self->queue($self->transaction);
+ }
+
+ # DATA is always the end of a "transaction"
+ return $self->reset_transaction;
+
+}
+
+sub getline {
+ my ($self, $timeout) = @_;
+
+ alarm $timeout;
+ my $line = <STDIN>; # default implementation
+ alarm 0;
+ return $line;
+}
+
+sub queue {
+ my ($self, $transaction) = @_;
+
+ my ($rc, $msg) = $self->run_hooks("queue");
+ if ($rc == DONE) {
+ return 1;
+ }
+ elsif ($rc == OK) {
+ $self->respond(250, ($msg || 'Queued'));
+ }
+ elsif ($rc == DENY) {
+ $self->respond(552, $msg || "Message denied");
+ }
+ elsif ($rc == DENYSOFT) {
+ $self->respond(452, $msg || "Message denied temporarily");
+ }
+ else {
+ $self->respond(451, $msg || "Queuing declined or disabled; try again later" );
+ }
+
+
+}
+
+
+1;
Added: tags/0.32rc1/lib/Qpsmtpd/SelectServer.pm
==============================================================================
--- (empty file)
+++ tags/0.32rc1/lib/Qpsmtpd/SelectServer.pm Fri Feb 17 11:02:02 2006
@@ -0,0 +1,320 @@
+package Qpsmtpd::SelectServer;
+use Qpsmtpd::SMTP;
+use Qpsmtpd::Constants;
+use IO::Socket;
+use IO::Select;
+use POSIX qw(strftime);
+use Socket qw(CRLF);
+use Fcntl;
+use Tie::RefHash;
+use Net::DNS;
+
+@ISA = qw(Qpsmtpd::SMTP);
+use strict;
+
+our %inbuffer = ();
+our %outbuffer = ();
+our %ready = ();
+our %lookup = ();
+our %qp = ();
+our %indata = ();
+
+tie %ready, 'Tie::RefHash';
+my $server;
+my $select;
+
+our $QUIT = 0;
+
+$SIG{INT} = $SIG{TERM} = sub { $QUIT++ };
+
+sub log {
+ my ($self, $trace, @log) = @_;
+ my $level = Qpsmtpd::TRACE_LEVEL();
+ $level = $self->init_logger unless defined $level;
+ warn join(" ", fileno($self->client), @log), "\n"
+ if $trace <= $level;
+}
+
+sub main {
+ my $class = shift;
+ my %opts = (LocalPort => 25, Reuse => 1, Listen => SOMAXCONN, @_);
+ $server = IO::Socket::INET->new(%opts) or die "Server: $@";
+ print "Listening on $opts{LocalPort}\n";
+
+ nonblock($server);
+
+ $select = IO::Select->new($server);
+ my $res = Net::DNS::Resolver->new;
+
+ # TODO - make this more graceful - let all current SMTP sessions finish
+ # before quitting!
+ while (!$QUIT) {
+ foreach my $client ($select->can_read(1)) {
+ #print "Reading $client\n";
+ if ($client == $server) {
+ my $client_addr;
+ $client = $server->accept();
+ next unless $client;
+ my $ip = $client->peerhost;
+ my $bgsock = $res->bgsend($ip);
+ $select->add($bgsock);
+ $lookup{$bgsock} = $client;
+ }
+ elsif (my $qpclient = $lookup{$client}) {
+ my $packet = $res->bgread($client);
+ my $ip = $qpclient->peerhost;
+ my $hostname = $ip;
+ if ($packet) {
+ foreach my $rr ($packet->answer) {
+ if ($rr->type eq 'PTR') {
+ $hostname = $rr->rdatastr;
+ }
+ }
+ }
+ # $packet->print;
+ $select->remove($client);
+ delete($lookup{$client});
+ my $qp = Qpsmtpd::SelectServer->new();
+ $qp->client($qpclient);
+ $qp{$qpclient} = $qp;
+ $qp->log(LOGINFO, "Connection number " . keys(%qp));
+ $inbuffer{$qpclient} = '';
+ $outbuffer{$qpclient} = '';
+ $ready{$qpclient} = [];
+ $qp->start_connection($ip, $hostname);
+ $qp->load_plugins;
+ my $rc = $qp->start_conversation;
+ if ($rc != DONE) {
+ close($client);
+ next;
+ }
+ $select->add($qpclient);
+ nonblock($qpclient);
+ }
+ else {
+ my $data = '';
+ my $rv = $client->recv($data, POSIX::BUFSIZ(), 0);
+
+ unless (defined($rv) && length($data)) {
+ freeclient($client)
+ unless ($! == POSIX::EWOULDBLOCK() ||
+ $! == POSIX::EINPROGRESS() ||
+ $! == POSIX::EINTR());
+ next;
+ }
+ $inbuffer{$client} .= $data;
+
+ while ($inbuffer{$client} =~ s/^([^\r\n]*)\r?\n//) {
+ #print "<$1\n";
+ push @{$ready{$client}}, $1;
+ }
+ }
+ }
+
+ #print "Processing...\n";
+ foreach my $client (keys %ready) {
+ my $qp = $qp{$client};
+ #print "Processing $client = $qp\n";
+ foreach my $req (@{$ready{$client}}) {
+ if ($indata{$client}) {
+ $qp->data_line($req . CRLF);
+ }
+ else {
+ $qp->log(LOGINFO, "dispatching $req");
+ defined $qp->dispatch(split / +/, $req)
+ or $qp->respond(502, "command unrecognized: '$req'");
+ }
+ }
+ delete $ready{$client};
+ }
+
+ #print "Writing...\n";
+ foreach my $client ($select->can_write(1)) {
+ next unless $outbuffer{$client};
+ #print "Writing to $client\n";
+
+ my $rv = $client->send($outbuffer{$client}, 0);
+ unless (defined($rv)) {
+ warn("I was told to write, but I can't: $!\n");
+ next;
+ }
+ if ($rv == length($outbuffer{$client}) ||
+ $! == POSIX::EWOULDBLOCK())
+ {
+ #print "Sent all, or EWOULDBLOCK\n";
+ if ($qp{$client}->{__quitting}) {
+ freeclient($client);
+ next;
+ }
+ substr($outbuffer{$client}, 0, $rv, '');
+ delete($outbuffer{$client}) unless length($outbuffer{$client});
+ }
+ else {
+ print "Error: $!\n";
+ # Couldn't write all the data, and it wasn't because
+ # it would have blocked. Shut down and move on.
+ freeclient($client);
+ next;
+ }
+ }
+ }
+}
+
+sub freeclient {
+ my $client = shift;
+ #print "Freeing client: $client\n";
+ delete $inbuffer{$client};
+ delete $outbuffer{$client};
+ delete $ready{$client};
+ delete $qp{$client};
+ $select->remove($client);
+ close($client);
+}
+
+sub start_connection {
+ my $self = shift;
+ my $remote_ip = shift;
+ my $remote_host = shift;
+
+ $self->log(LOGNOTICE, "Connection from $remote_host [$remote_ip]");
+ my $remote_info = 'NOINFO';
+
+ # if the local dns resolver doesn't filter it out we might get
+ # ansi escape characters that could make a ps axw do "funny"
+ # things. So to be safe, cut them out.
+ $remote_host =~ tr/a-zA-Z\.\-0-9//cd;
+
+ $self->SUPER::connection->start(remote_info => $remote_info,
+ remote_ip => $remote_ip,
+ remote_host => $remote_host,
+ @_);
+}
+
+sub client {
+ my $self = shift;
+ @_ and $self->{_client} = shift;
+ $self->{_client};
+}
+
+sub nonblock {
+ my $socket = shift;
+ my $flags = fcntl($socket, F_GETFL, 0)
+ or die "Can't get flags for socket: $!";
+ fcntl($socket, F_SETFL, $flags | O_NONBLOCK)
+ or die "Can't set flags for socket: $!";
+}
+
+sub read_input {
+ my $self = shift;
+ die "read_input is disabled in SelectServer";
+}
+
+sub respond {
+ my ($self, $code, @messages) = @_;
+ my $client = $self->client || die "No client!";
+ while (my $msg = shift @messages) {
+ my $line = $code . (@messages?"-":" ").$msg;
+ $self->log(LOGINFO, ">$line");
+ $outbuffer{$client} .= "$line\r\n";
+ }
+ return 1;
+}
+
+sub disconnect {
+ my $self = shift;
+ #print "Disconnecting\n";
+ $self->{__quitting} = 1;
+ $self->SUPER::disconnect(@_);
+}
+
+sub data {
+ my $self = shift;
+ $self->respond(503, "MAIL first"), return 1 unless $self->transaction->sender;
+ $self->respond(503, "RCPT first"), return 1 unless $self->transaction->recipients;
+ $self->respond(354, "go ahead");
+ $indata{$self->client()} = 1;
+ $self->{__buffer} = '';
+ $self->{__size} = 0;
+ $self->{__blocked} = "";
+ $self->{__in_header} = 1;
+ $self->{__complete} = 0;
+ $self->{__max_size} = $self->config('databytes') || 0;
+}
+
+sub data_line {
+ my $self = shift;
+ local $_ = shift;
+
+ if ($_ eq ".\r\n") {
+ $self->log(LOGDEBUG, "max_size: $self->{__max_size} / size: $self->{__size}");
+ delete $indata{$self->client()};
+
+ my $smtp = $self->connection->hello eq "ehlo" ? "ESMTP" : "SMTP";
+
+ if (!$self->transaction->header) {
+ $self->transaction->header(Mail::Header->new(Modify => 0, MailFrom => "COERCE"));
+ }
+ $self->transaction->header->add("Received", "from ".$self->connection->remote_info
+ ." (HELO ".$self->connection->hello_host . ") (".$self->connection->remote_ip
+ . ") by ".$self->config('me')." (qpsmtpd/".$self->version
+ .") with $smtp; ". (strftime('%a, %d %b %Y %H:%M:%S %z', localtime)),
+ 0);
+
+ #$self->respond(550, $self->transaction->blocked),return 1 if ($self->transaction->blocked);
+ $self->respond(552, "Message too big!"),return 1 if $self->{__max_size} and $self->{__size} > $self->{__max_size};
+
+ my ($rc, $msg) = $self->run_hooks("data_post");
+ if ($rc == DONE) {
+ return 1;
+ }
+ elsif ($rc == DENY) {
+ $self->respond(552, $msg || "Message denied");
+ }
+ elsif ($rc == DENYSOFT) {
+ $self->respond(452, $msg || "Message denied temporarily");
+ }
+ else {
+ $self->queue($self->transaction);
+ }
+
+ # DATA is always the end of a "transaction"
+ return $self->reset_transaction;
+ }
+ elsif ($_ eq ".\n") {
+ $self->respond(451, "See http://develooper.com/code/qpsmtpd/barelf.html");
+ $self->{__quitting} = 1;
+ return;
+ }
+
+ # add a transaction->blocked check back here when we have line by line plugin access...
+ unless (($self->{__max_size} and $self->{__size} > $self->{__max_size})) {
+ s/\r\n$/\n/;
+ s/^\.\./\./;
+ if ($self->{__in_header} and m/^\s*$/) {
+ $self->{__in_header} = 0;
+ my @header = split /\n/, $self->{__buffer};
+
+ # ... need to check that we don't reformat any of the received lines.
+ #
+ # 3.8.2 Received Lines in Gatewaying
+ # When forwarding a message into or out of the Internet environment, a
+ # gateway MUST prepend a Received: line, but it MUST NOT alter in any
+ # way a Received: line that is already in the header.
+
+ my $header = Mail::Header->new(Modify => 0, MailFrom => "COERCE");
+ $header->extract(\@header);
+ $self->transaction->header($header);
+ $self->{__buffer} = "";
+ }
+
+ if ($self->{__in_header}) {
+ $self->{__buffer} .= $_;
+ }
+ else {
+ $self->transaction->body_write($_);
+ }
+ $self->{__size} += length $_;
+ }
+}
+
+1;
Added: tags/0.32rc1/lib/Qpsmtpd/TcpServer.pm
==============================================================================
--- (empty file)
+++ tags/0.32rc1/lib/Qpsmtpd/TcpServer.pm Fri Feb 17 11:02:02 2006
@@ -0,0 +1,91 @@
+package Qpsmtpd::TcpServer;
+use Qpsmtpd::SMTP;
+use Qpsmtpd::Constants;
+
+@ISA = qw(Qpsmtpd::SMTP);
+use strict;
+
+use POSIX ();
+
+my $first_0;
+
+sub start_connection {
+ my $self = shift;
+
+ die "Qpsmtpd::TcpServer must be started by tcpserver\n"
+ unless $ENV{TCPREMOTEIP};
+
+ my $remote_host = $ENV{TCPREMOTEHOST} || ( $ENV{TCPREMOTEIP} ? "[$ENV{TCPREMOTEIP}]" : "[noip!]");
+ my $remote_info = $ENV{TCPREMOTEINFO} ? "$ENV{TCPREMOTEINFO}\@$remote_host" : $remote_host;
+ my $remote_ip = $ENV{TCPREMOTEIP};
+ $self->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,
+ @_);
+}
+
+sub run {
+ my $self = shift;
+
+ # should be somewhere in Qpsmtpd.pm and not here...
+ $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(LOGDEBUG, "dispatching $_");
+ $self->connection->notes('original_string', $_);
+ defined $self->dispatch(split / +/, $_)
+ or $self->respond(502, "command unrecognized: '$_'");
+ alarm $timeout;
+ }
+ alarm(0);
+}
+
+sub respond {
+ my ($self, $code, @messages) = @_;
+ while (my $msg = shift @messages) {
+ my $line = $code . (@messages?"-":" ").$msg;
+ $self->log(LOGDEBUG, $line);
+ print "$line\r\n" or ($self->log(LOGERROR, "Could not print [$line]: $!"), return 0);
+ }
+ return 1;
+}
+
+sub disconnect {
+ my $self = shift;
+ $self->log(LOGDEBUG,"click, disconnecting");
+ $self->SUPER::disconnect(@_);
+ $self->run_hooks("post-connection");
+ exit;
+}
+
+1;
Added: tags/0.32rc1/lib/Qpsmtpd/Transaction.pm
==============================================================================
--- (empty file)
+++ tags/0.32rc1/lib/Qpsmtpd/Transaction.pm Fri Feb 17 11:02:02 2006
@@ -0,0 +1,323 @@
+package Qpsmtpd::Transaction;
+use Qpsmtpd;
+@ISA = qw(Qpsmtpd);
+use strict;
+use Qpsmtpd::Utils;
+use Qpsmtpd::Constants;
+
+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 = shift;
+ @_ and push @{$self->{_recipients}}, shift;
+}
+
+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 [email protected] if you have a reason to use it';
+# @_ and $self->{_blocked} = shift;
+# $self->{_blocked};
+#}
+
+sub notes {
+ my $self = shift;
+ my $key = shift;
+ @_ and $self->{_notes}->{$key} = shift;
+ #warn Data::Dumper->Dump([\$self->{_notes}], [qw(notes)]);
+ $self->{_notes}->{$key};
+}
+
+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 {
+ shift->{_body_size} || 0;
+}
+
+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 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 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.
+
+=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( )
+
+Get the current size of the email.
+
+=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.
+
+=head1 SEE ALSO
+
+L<Mail::Header>, L<Qpsmtpd::Address>, L<Qpsmtpd::Connection>
+
+=cut
Added: tags/0.32rc1/lib/Qpsmtpd/Utils.pm
==============================================================================
--- (empty file)
+++ tags/0.32rc1/lib/Qpsmtpd/Utils.pm Fri Feb 17 11:02:02 2006
@@ -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;
Added: tags/0.32rc1/log/.cvsignore
==============================================================================
--- (empty file)
+++ tags/0.32rc1/log/.cvsignore Fri Feb 17 11:02:02 2006
@@ -0,0 +1,2 @@
+main
+supervise
Added: tags/0.32rc1/log/run
==============================================================================
--- (empty file)
+++ tags/0.32rc1/log/run Fri Feb 17 11:02:02 2006
@@ -0,0 +1,5 @@
+#! /bin/sh
+export LOGDIR=./main
+mkdir -p $LOGDIR
+exec multilog t s1000000 n20 $LOGDIR
+
Added: tags/0.32rc1/plugins/auth/auth_cvm_unix_local
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/auth/auth_cvm_unix_local Fri Feb 17 11:02:02 2006
@@ -0,0 +1,109 @@
+#!/usr/bin/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 <[email protected]>
+
+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 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, "authcvm - requires cvm_socket argument");
+ return 0;
+ }
+
+ $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 and $self->{_enable_smtp} ne 'yes');
+ return 0 if ($port == SSMTP_PORT and $self->{_enable_ssmtp} ne 'yes');
+
+ if ($arg{cvm_socket} =~ /^([\w\/.-]+)$/)
+ {
+ $self->{_cvm_socket} = $1;
+ }
+
+ unless (-S $self->{_cvm_socket})
+ {
+ $self->log(LOGERROR, "authcvm - 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 ) =
+ @_;
+
+ $self->log(LOGINFO, "authcvm/$method authentication attempt for: $user");
+
+ socket(SOCK, PF_UNIX, SOCK_STREAM, 0)
+ or return (DENY, "authcvm/$method");
+
+ connect(SOCK, sockaddr_un($self->{_cvm_socket}))
+ or return (DENY, "authcvm/$method");
+
+ 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;
+
+ my $ret = <SOCK>;
+ my ($s) = unpack ("C", $ret);
+ return (
+ ($s ? $s == 100 ? DENY : DECLINED
+ : OK),
+ "authcvm/$method");
+}
Added: tags/0.32rc1/plugins/auth/auth_flat_file
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/auth/auth_flat_file Fri Feb 17 11:02:02 2006
@@ -0,0 +1,75 @@
+#!/usr/bin/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 Digest::HMAC_MD5 qw(hmac_md5_hex);
+
+sub register {
+ my ( $self, $qp ) = @_;
+
+ $self->register_hook("auth-cram-md5", "authsql");
+}
+
+sub authsql {
+ my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) =
+ @_;
+
+ my ( $pw_name, $pw_domain ) = split "@", lc($user);
+
+ unless ( defined $pw_domain ) {
+ return DECLINED;
+ }
+
+ $self->log(LOGINFO, "Authentication for: $pw_name\@$pw_domain");
+
+ my ($auth_line) = grep {/^$pw_name\@$pw_domain:/} $self->qp->config('flat_auth_pw');
+
+ unless (defined $auth_line) {
+ return DECLINED;
+ }
+
+ my ($auth_user, $auth_pass) = split(/:/, $auth_line, 2);
+
+ # at this point we can assume the user name matched
+ if (
+ ( defined $passClear
+ and $auth_pass eq $passClear ) or
+ ( defined $passHash
+ and $passHash eq hmac_md5_hex($ticket, $auth_pass) )
+ )
+ {
+ return ( OK, "authflat/$method" );
+ }
+ else {
+ return ( DENY, "authflat/$method - wrong password" );
+ }
+}
+
Added: tags/0.32rc1/plugins/auth/auth_ldap_bind
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/auth/auth_ldap_bind Fri Feb 17 11:02:02 2006
@@ -0,0 +1,192 @@
+#!/usr/bin/perl -Tw
+
+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 {
+ use Net::LDAP qw(:all);
+ use Qpsmtpd::Constants;
+
+ 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, "authldap/$method - please configure ldap_base" ) &&
+ return ( DECLINED, "authldap/$method - 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
+ $self->log(LOGALERT, "authldap/$method - error in initial conn" ) &&
+ return ( DECLINED, "authldap/$method - 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
+ $self->log(LOGALERT, "authldap/$method - err in search for user" ) &&
+ return ( DECLINED, "authldap/$method - temporary auth error" );
+
+ # deal with errors if they exist
+ if ( $mesg->code ) {
+ $self->log(LOGALERT, "authldap/$method - err " . $mesg->code . " in search for user" );
+ return ( DECLINED, "authldap/$method - 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)) {
+ $ldh = Net::LDAP->new($ldhost, port=>$ldport, timeout=>$ldwait ) or
+ $self->log(LOGALERT, "authldap/$method - err in user conn" ) &&
+ return ( DECLINED, "authldap/$method - 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, "authldap/$method - error in user bind" );
+ return ( DECLINED, "authldap/$method - wrong username or password" );
+ } else {
+ $self->log( LOGINFO, "authldap/$method - $user auth success" );
+ $self->log( LOGDEBUG, "authldap/$method - user: $user, pass: $passClear" );
+ return ( OK, "authldap/$method" );
+ }
+
+ # if the plugin couldn't find user's entry
+ } else {
+ $self->log(LOGALERT, "authldap/$method - user not found" ) &&
+ return ( DECLINED, "authldap/$method - wrong username or password" );
+ }
+
+ $ldh->disconnect;
+}
+
+=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 <[email protected]>
+
+=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
+
Added: tags/0.32rc1/plugins/auth/auth_vpopmail_sql
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/auth/auth_vpopmail_sql Fri Feb 17 11:02:02 2006
@@ -0,0 +1,132 @@
+#!/usr/bin/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
+
+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.
+Then, change the database information at the top of the authsql() sub so that
+the module can access the database. This can be a read-only account since
+the plugin does not update the last accessed time (yet, see below).
+
+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 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 AUTHOR
+
+John Peacock <[email protected]>
+
+=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
+
+sub register {
+ my ( $self, $qp ) = @_;
+
+ $self->register_hook("auth-plain", "authsql" );
+ $self->register_hook("auth-login", "authsql" );
+ $self->register_hook("auth-cram-md5", "authsql");
+
+}
+
+sub authsql {
+ use DBI;
+ use Qpsmtpd::Constants;
+ use Digest::HMAC_MD5 qw(hmac_md5_hex);
+
+# $DB::single = 1;
+
+ my $connect = "dbi:mysql:dbname=vpopmail";
+ my $dbuser = "vpopmailuser";
+ my $dbpasswd = "**********";
+
+ my $dbh = DBI->connect( $connect, $dbuser, $dbpasswd );
+ $dbh->{ShowErrorStatement} = 1;
+
+ my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) =
+ @_;
+ my ( $pw_name, $pw_domain ) = split "@", lc($user);
+
+ unless ( defined $pw_domain ) {
+ return DECLINED;
+ }
+
+ $self->log(LOGINFO,
+ "Authentication to vpopmail via mysql: $pw_name\@$pw_domain");
+
+ my $sth = $dbh->prepare(<<SQL);
+select *
+from vpopmail
+where pw_name = ? and pw_domain = ?
+SQL
+
+ $sth->execute( $pw_name, $pw_domain );
+
+ my $passwd_hash = $sth->fetchrow_hashref;
+
+ $sth->finish;
+ $dbh->disconnect;
+
+ # if vpopmail was not built with '--enable-clear-passwd=y'
+ # then pw_clear_passwd may not even exist
+ my $pw_clear_passwd = exists $passwd_hash->{'pw_clear_passwd'}
+ ? $passwd_hash->{'pw_clear_passwd'}
+ : undef;
+ my $pw_passwd = $passwd_hash->{'pw_passwd'}; # this is always present
+
+ if ( # clear_passwd isn't defined so we cannot support CRAM-MD5
+ ( $method =~ /CRAM-MD5/i and not defined $pw_clear_passwd )
+ or
+ # user doesn't exist in this domain
+ ( not defined $pw_passwd )
+ ) {
+ return ( DECLINED, "authsql/$method" );
+ }
+
+ # at this point we can assume the user name matched
+ if (
+ ( defined $passClear and
+ (
+ ($pw_clear_passwd eq $passClear)
+ or ($pw_passwd eq crypt( $passClear, $pw_passwd ) )
+ )
+ )
+ or ( defined $passHash
+ and $passHash eq hmac_md5_hex( $ticket, $pw_clear_passwd ) )
+ )
+ {
+
+ return ( OK, "authsql/$method" );
+ }
+ else {
+ return ( DENY, "authsql/$method - wrong password" );
+ }
+}
+
Added: tags/0.32rc1/plugins/auth/authdeny
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/auth/authdeny Fri Feb 17 11:02:02 2006
@@ -0,0 +1,18 @@
+#!/usr/bin/perl
+#
+# 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!!!
+#
+
+sub hook_auth {
+ my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) =
+ @_;
+
+ # $DB::single = 1;
+
+ $self->log( LOGWARN, "Cannot authenticate using authdeny" );
+
+ return ( DECLINED, "$user is not free to abuse my relay" );
+}
+
Added: tags/0.32rc1/plugins/auth/authnull
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/auth/authnull Fri Feb 17 11:02:02 2006
@@ -0,0 +1,17 @@
+#!/usr/bin/perl
+#
+# This plugin doesn't actually check anything and will authenticate 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!!!
+#
+
+sub hook_auth {
+ my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) =
+ @_;
+
+ # $DB::single = 1;
+ $self->log( LOGERROR, "authenticating $user using $method" );
+
+ return ( OK, "$user is free to abuse my relay" );
+}
+
Added: tags/0.32rc1/plugins/check_badmailfrom
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/check_badmailfrom Fri Feb 17 11:02:02 2006
@@ -0,0 +1,54 @@
+# -*- perl -*-
+=head1 NAME
+
+check_badmailfrom - checks the standard badmailfrom config
+
+=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."
+
+=head1 NOTES
+
+According to the SMTP protocol, we can't reject until after the RCPT
+stage, so store it until later.
+
+=cut
+
+sub hook_mail {
+ my ($self, $transaction, $sender) = @_;
+
+ my @badmailfrom = $self->qp->config("badmailfrom")
+ or return (DECLINED);
+
+ return (DECLINED) unless ($sender->format ne "<>"
+ and $sender->host && $sender->user);
+
+ my $host = lc $sender->host;
+ my $from = lc($sender->user) . '@' . $host;
+
+ for my $bad (@badmailfrom) {
+ $bad =~ s/^\s*(\S+).*/$1/;
+ next unless $bad;
+ $bad = lc $bad;
+ $self->log(LOGWARN, "Bad badmailfrom config: No \@ sign in $bad") and next unless $bad =~ m/\@/;
+ $transaction->notes('badmailfrom', "sorry, your envelope sender is in my badmailfrom list")
+ if ($bad eq $from) || (substr($bad,0,1) eq '@' && $bad eq "\@$host");
+ }
+ return (DECLINED);
+}
+
+sub hook_rcpt {
+ my ($self, $transaction, $rcpt) = @_;
+ my $note = $transaction->notes('badmailfrom');
+ if ($note) {
+ $self->log(LOGINFO, $note);
+ return (DENY, $note);
+ }
+ return (DECLINED);
+}
Added: tags/0.32rc1/plugins/check_badmailfromto
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/check_badmailfromto Fri Feb 17 11:02:02 2006
@@ -0,0 +1,58 @@
+#! perl
+=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
+
+sub hook_mail {
+ my ($self, $transaction, $sender) = @_;
+
+ my @badmailfromto = $self->qp->config("badmailfromto")
+ or return (DECLINED);
+
+ return (DECLINED) unless ($sender->format ne "<>"
+ and $sender->host && $sender->user);
+
+ 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;
+ $self->log(LOGWARN, "Bad badmailfromto config: No \@ sign in $bad") and next unless $bad =~ m/\@/;
+ $transaction->notes('badmailfromto', "$bad")
+ if ($bad eq $from)
+ || (substr($bad,0,1) eq '@' && $bad eq "\@$host");
+ }
+ return (DECLINED);
+}
+
+sub hook_rcpt {
+ my ($self, $transaction, $rcpt) = @_;
+ my $recipient = lc($rcpt->user) . '@' . lc($rcpt->host);
+ my $sender = $transaction->notes('badmailfromto');
+ if ($sender) {
+ my @badmailfromto = $self->qp->config("badmailfromto")
+ or return (DECLINED);
+
+ foreach (@badmailfromto) {
+ my ($from, $to) = m/^\s*(\S+)\t(\S+).*/;
+ return (DENY, "mail to $recipient not accepted here")
+ if lc($from) eq $sender and lc($to) eq $recipient;
+ }
+ }
+ return (DECLINED);
+}
Added: tags/0.32rc1/plugins/check_badrcptto
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/check_badrcptto Fri Feb 17 11:02:02 2006
@@ -0,0 +1,19 @@
+# this plugin checks the badrcptto config (like badmailfrom for rcpt address)
+use Qpsmtpd::DSN;
+
+sub hook_rcpt {
+ my ($self, $transaction, $recipient) = @_;
+ my @badrcptto = $self->qp->config("badrcptto") or return (DECLINED);
+ return (DECLINED) unless $recipient->host && $recipient->user;
+ my $host = lc $recipient->host;
+ my $from = lc($recipient->user) . '@' . $host;
+ for my $bad (@badrcptto) {
+ $bad = lc $bad;
+ $bad =~ s/^\s*(\S+)/$1/;
+ return Qpsmtpd::DSN->no_such_user("mail to $bad not accepted here")
+ if $bad eq $from;
+ return Qpsmtpd::DSN->no_such_user("mail to $bad not accepted here")
+ if substr($bad,0,1) eq '@' && $bad eq "\@$host";
+ }
+ return (DECLINED);
+}
Added: tags/0.32rc1/plugins/check_badrcptto_patterns
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/check_badrcptto_patterns Fri Feb 17 11:02:02 2006
@@ -0,0 +1,47 @@
+=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 <[email protected]>
+
+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);
+}
Added: tags/0.32rc1/plugins/check_basicheaders
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/check_basicheaders Fri Feb 17 11:02:02 2006
@@ -0,0 +1,70 @@
+#!/usr/bin/perl
+
+=head1 NAME
+
+check_basicheaders - Make sure both From and Date headers are present, and
+do optional range checking on the Date header
+
+=head1 DESCRIPTION
+
+Rejects messages that do not have a From or Date header or are completely
+empty.
+
+Can also reject messages where the date in the Date header is more than
+some number of the days in the past or future.
+
+=head1 CONFIGURATION
+
+Takes one optional parameter, the number of days in the future or past
+beyond which to reject messages. (The default is to not reject messages
+based on the date.)
+
+=head1 AUTHOR
+
+Written by Jim Winstead Jr.
+
+=head1 LICENSE
+
+Released to the public domain, 26 March 2004.
+
+=cut
+
+use Date::Parse qw(str2time);
+
+sub register {
+ my ($self, $qp, @args) = @_;
+
+ if (@args > 0) {
+ $self->{_days} = $args[0];
+ $self->log(LOGWARN, "WARNING: Ignoring additional arguments.") if (@args > 1);
+ }
+}
+
+sub hook_data_post {
+ my ($self, $transaction) = @_;
+
+ return (DENY, "You have to send some data first")
+ if $transaction->body_size == 0;
+
+ return (DENY, "Mail with no From header not accepted here")
+ unless $transaction->header->get('From');
+
+ my $date = $transaction->header->get('Date');
+
+ return (DENY, "Mail with no Date header not accepted here")
+ unless $date;
+
+ return (DECLINED) unless defined $self->{_days};
+
+ my $ts = str2time($date);
+
+ return (DECLINED) unless $ts;
+
+ return (DENY, "The Date in the header was too far in the past")
+ if $ts < time - ($self->{_days}*24*3600);
+
+ return (DENY, "The Date in the header was too far in the future")
+ if $ts > time + ($self->{_days}*24*3600);
+
+ return (DECLINED);
+}
Added: tags/0.32rc1/plugins/check_earlytalker
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/check_earlytalker Fri Feb 17 11:02:02 2006
@@ -0,0 +1,145 @@
+=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.
+
+=back
+
+=cut
+
+use IO::Select;
+
+use warnings;
+use strict;
+
+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,
+ @args,
+ };
+ if ($qp->{conn} && $qp->{conn}->isa('Apache2::Connection')) {
+ require APR::Const;
+ APR::Const->import(qw(POLLIN SUCCESS));
+ $self->register_hook('connect', 'apr_connect_handler');
+ }
+ else {
+ $self->register_hook('connect', 'connect_handler');
+ }
+ $self->register_hook('mail', 'mail_handler')
+ if $self->{_args}->{'defer-reject'};
+ 1;
+}
+
+sub apr_connect_handler {
+ my ($self, $transaction) = @_;
+
+ return DECLINED if ($self->qp->connection->notes('whitelistclient'));
+ my $ip = $self->qp->connection->remote_ip;
+
+ my $c = $self->qp->{conn};
+ my $socket = $c->client_socket;
+ my $timeout = $self->{_args}->{'wait'} * 1_000_000;
+
+ my $rc = $socket->poll($c->pool, $timeout, APR::Const::POLLIN());
+ if ($rc == APR::Const::SUCCESS()) {
+ $self->log(LOGNOTICE, "remote host started talking before we said hello [$ip]");
+ if ($self->{_args}->{'defer-reject'}) {
+ $self->qp->connection->notes('earlytalker', 1);
+ }
+ else {
+ my $msg = 'Connecting host started transmitting before SMTP greeting';
+ return (DENY,$msg) if $self->{_args}->{'action'} eq 'deny';
+ return (DENYSOFT,$msg) if $self->{_args}->{'action'} eq 'denysoft';
+ }
+ }
+ else {
+ $self->log(LOGINFO, "remote host said nothing spontaneous, proceeding");
+ }
+}
+
+sub connect_handler {
+ my ($self, $transaction) = @_;
+ my $in = new IO::Select;
+ my $ip = $self->qp->connection->remote_ip;
+
+ return DECLINED
+ if ($self->qp->connection->notes('whitelistclient'));
+
+ $in->add(\*STDIN) || return DECLINED;
+ if ($in->can_read($self->{_args}->{'wait'})) {
+ $self->log(LOGNOTICE, "remote host started talking before we said hello [$ip]");
+ if ($self->{_args}->{'defer-reject'}) {
+ $self->qp->connection->notes('earlytalker', 1);
+ } else {
+ my $msg = 'Connecting host started transmitting before SMTP greeting';
+ return (DENY,$msg) if $self->{_args}->{'action'} eq 'deny';
+ return (DENYSOFT,$msg) if $self->{_args}->{'action'} eq 'denysoft';
+ }
+ } else {
+ $self->log(LOGINFO, 'remote host said nothing spontaneous, proceeding');
+ }
+ return DECLINED;
+}
+
+sub mail_handler {
+ my ($self, $txn) = @_;
+ my $msg = 'Connecting host started transmitting before SMTP greeting';
+
+ return DECLINED unless $self->qp->connection->notes('earlytalker');
+ return (DENY,$msg) if $self->{_args}->{'action'} eq 'deny';
+ return (DENYSOFT,$msg) if $self->{_args}->{'action'} eq 'denysoft';
+ return DECLINED;
+}
+
+
+1;
+
Added: tags/0.32rc1/plugins/check_loop
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/check_loop Fri Feb 17 11:02:02 2006
@@ -0,0 +1,54 @@
+#!/usr/bin/perl
+
+=head1 NAME
+
+check_loop - Detect mail loops
+
+=head1 DESCRIPTION
+
+This plugin detects loops by counting "Received" and "Delivered-To"
+header lines. It's a kluge but it duplicates what qmail-smtpd does,
+and it does at least prevent messages from looping forever.
+
+=head1 CONFIGURATION
+
+Takes one optional parameter, the maximum number of "hops" ("Received"
+and lines plus "Delivered-To" lines) allowed. The default is 100, the
+same as in qmail-smtpd.
+
+=head1 AUTHOR
+
+Written by Keith C. Ivey
+
+=head1 LICENSE
+
+Released to the public domain, 17 June 2005.
+
+=cut
+use Qpsmtpd::DSN;
+
+sub init {
+ my ($self, $qp, @args) = @_;
+
+ $self->{_max_hops} = $args[0] || 100;
+
+ if ( $self->{_max_hops} !~ /^\d+$/ ) {
+ $self->log(LOGWARN, "Invalid max_hops value -- using default");
+ }
+ $self->log(LOGWARN, "Ignoring additional arguments") if @args > 1;
+}
+
+sub hook_data_post {
+ my ($self, $transaction) = @_;
+
+ my $hops = 0;
+ $hops++ for $transaction->header->get('Received'),
+ $transaction->header->get('Delivered-To');
+
+ if ( $hops >= $self->{_max_hops} ) {
+ # default of too_many_hops is DENY, see comment in POD of Qpsmtpd::DSN
+ return Qpsmtpd::DSN->too_many_hops();
+ }
+
+ return DECLINED;
+}
Added: tags/0.32rc1/plugins/check_norelay
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/check_norelay Fri Feb 17 11:02:02 2006
@@ -0,0 +1,57 @@
+=pod
+
+=head1 SYNOPSIS
+
+This plugin checks the norelayclients config file to see if
+relaying is denied.
+
+This allows specific clients, such as the gateway, to be denied
+relaying, even though they would be allowed relaying by the
+relayclients file.
+
+=head1 CONFIG
+
+config/norelayclients
+
+Each line is:
+- a full IP address
+- partial IP address terminated by a dot for matching whole networks
+ e.g. 192.168.42.
+
+=head1 BUGS AND LIMITATIONS
+
+This plugin does not have a more_norelayclients map equivalent
+of the more_relayclients map of the check_relay plugin.
+
+=head1 AUTHOR
+
+Based on check_relay plugin from the qpsmtpd distribution.
+
+Copyright 2005 Gordon Rowell <[email protected]>
+
+This software is free software and may be distributed under the same
+terms as qpsmtpd itself.
+
+=cut
+
+sub hook_connect {
+ my ($self, $transaction) = @_;
+ my $connection = $self->qp->connection;
+
+ # Check if this IP is not allowed to relay
+ my @no_relay_clients = $self->qp->config("norelayclients");
+ my %no_relay_clients = map { $_ => 1 } @no_relay_clients;
+ my $client_ip = $self->qp->connection->remote_ip;
+ while ($client_ip) {
+ if ( exists($no_relay_clients{$client_ip}) )
+ {
+ $connection->relay_client(0);
+ delete $ENV{RELAYCLIENT};
+ $self->log(LOGNOTICE, "check_norelay: $client_ip denied relaying");
+ last;
+ }
+ $client_ip =~ s/\d+\.?$//; # strip off another 8 bits
+ }
+
+ return (DECLINED);
+}
Added: tags/0.32rc1/plugins/check_relay
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/check_relay Fri Feb 17 11:02:02 2006
@@ -0,0 +1,26 @@
+# this plugin checks the relayclients config file and
+# $ENV{RELAYCLIENT} to see if relaying is allowed.
+#
+
+sub hook_connect {
+ my ($self, $transaction) = @_;
+ my $connection = $self->qp->connection;
+
+ # Check if this IP is allowed to relay
+ my @relay_clients = $self->qp->config("relayclients");
+ my $more_relay_clients = $self->qp->config("morerelayclients", "map");
+ my %relay_clients = map { $_ => 1 } @relay_clients;
+ my $client_ip = $self->qp->connection->remote_ip;
+ while ($client_ip) {
+ if (exists($ENV{RELAYCLIENT}) or
+ exists($relay_clients{$client_ip}) or
+ exists($more_relay_clients->{$client_ip}))
+ {
+ $connection->relay_client(1);
+ last;
+ }
+ $client_ip =~ s/\d+\.?$//; # strip off another 8 bits
+ }
+
+ return (DECLINED);
+}
Added: tags/0.32rc1/plugins/check_spamhelo
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/check_spamhelo Fri Feb 17 11:02:02 2006
@@ -0,0 +1,33 @@
+=head1 NAME
+
+check_spamhelo - Check a HELO message delivered from a connecting host.
+
+=head1 DESCRIPTION
+
+Check a HELO message delivered from a connecting host. Reject any
+that appear in the badhelo config -- e.g. yahoo.com and aol.com, which
+neither the real Yahoo or the real AOL use, but which spammers use
+rather a lot.
+
+=head1 CONFIGURATION
+
+Add domains or hostnames to the F<badhelo> configuration file; one
+per line.
+
+=cut
+
+sub hook_helo {
+ my ($self, $transaction, $host) = @_;
+ ($host = lc $host) or return DECLINED;
+
+ for my $bad ($self->qp->config('badhelo')) {
+ if ($host eq lc $bad) {
+ $self->log(LOGDEBUG, "Denying HELO from host claiming to be $bad");
+ return (DENY, "Sorry, I don't believe that you are $host.");
+ }
+ }
+ return DECLINED;
+}
+
+# also support EHLO
+*hook_ehlo = \&hook_helo;
Added: tags/0.32rc1/plugins/content_log
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/content_log Fri Feb 17 11:02:02 2006
@@ -0,0 +1,26 @@
+# -*- perl -*-
+# $Id$
+#
+# A simple example of a plugin that logs all incoming mail to a file.
+# Useful for debugging other plugins or keeping an archive of things.
+
+use POSIX qw:strftime:;
+
+sub hook_data_post {
+ my ($self, $transaction) = @_;
+
+ # as a decent default, log on a per-day-basis
+ my $date = strftime("%Y%m%d",localtime(time));
+ open(my $out,">>mail/$date")
+ or return(DECLINED,"Could not open log file.. continuing anyway");
+
+ $transaction->header->print($out);
+ $transaction->body_resetpos;
+ while (my $line = $transaction->body_getline) {
+ print $out $line;
+ }
+
+ close $out;
+
+ return (DECLINED, "successfully saved message.. continuing");
+}
Added: tags/0.32rc1/plugins/count_unrecognized_commands
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/count_unrecognized_commands Fri Feb 17 11:02:02 2006
@@ -0,0 +1,49 @@
+# -*- perl -*-
+=head1 NAME
+
+count_unrecognized_commands - Count unrecognized commands and disconnect when we have too many
+
+=head1 DESCRIPTION
+
+Disconnect the client if it sends too many unrecognized commands.
+Good for rejecting spam sent through open HTTP proxies.
+
+=head1 CONFIGURATION
+
+Takes one parameter, the number of allowed unrecognized commands
+before we disconnect the client. Defaults to 4.
+
+=cut
+
+sub register {
+ my ($self, $qp, @args) = @_;
+
+ if (@args > 0) {
+ $self->{_unrec_cmd_max} = $args[0];
+ $self->log(LOGWARN, "WARNING: Ignoring additional arguments.") if (@args > 1);
+ } else {
+ $self->{_unrec_cmd_max} = 4;
+ }
+
+ $qp->connection->notes('unrec_cmd_count', 0);
+
+}
+
+sub hook_unrecognized_command {
+ my ($self, $cmd) = @_[0,2];
+
+ $self->log(LOGINFO, "Unrecognized command '$cmd'");
+
+ my $badcmdcount =
+ $self->qp->connection->notes( 'unrec_cmd_count',
+ ($self->qp->connection->notes('unrec_cmd_count') || 0) + 1
+ );
+
+ if ($badcmdcount >= $self->{_unrec_cmd_max}) {
+ $self->log(LOGINFO, "Closing connection. Too many unrecognized commands.");
+ return (DENY_DISCONNECT, "Closing connection. $badcmdcount unrecognized commands. Perhaps you should read RFC 2821?");
+ }
+
+ return DECLINED;
+}
+
Added: tags/0.32rc1/plugins/dns_whitelist_soft
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/dns_whitelist_soft Fri Feb 17 11:02:02 2006
@@ -0,0 +1,151 @@
+=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 strongly based on the original
+dnsbl plugin as well as Gavin Carr's original whitelist_soft plugin. 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 is means that the
+remote HOST address can be selectively exempted at other stages by plugins
+testing for a 'whitelisthost' connection note.
+
+NOTE: other 'connect' hooks will continue to fire (e.g. dnsbl), since the DNS
+queries happen in the background. This plugin's 'rcpt_handler' retrieves
+the results of the query and sets the connection note if found.
+
+=head1 AUTHOR
+
+John Peacock <[email protected]>
+
+Based on the 'whitelist_soft' plugin by Gavin Carr <[email protected]>,
+based on the 'whitelist' plugin by Devin Carraway <[email protected]>.
+
+=cut
+
+sub hook_connect {
+ my ($self, $transaction) = @_;
+
+ my $remote_ip = $self->qp->connection->remote_ip;
+
+ my %whitelist_zones = map { (split /\s+/, $_, 2)[0,1] }
+ $self->qp->config('whitelist_zones');
+
+ return DECLINED unless %whitelist_zones;
+
+ my $reversed_ip = join(".", reverse(split(/\./, $remote_ip)));
+
+ # we queue these lookups in the background and just fetch the
+ # results in the first rcpt handler
+
+ my $res = new Net::DNS::Resolver;
+ my $sel = IO::Select->new();
+
+ for my $dnsbl (keys %whitelist_zones) {
+ $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl in the background");
+ $sel->add($res->bgsend("$reversed_ip.$dnsbl", "TXT"));
+ }
+
+ $self->qp->connection->notes('whitelist_sockets', $sel);
+
+ return DECLINED;
+}
+
+sub process_sockets {
+ my ($self) = @_;
+
+ my $conn = $self->qp->connection;
+
+ return $conn->notes('whitelisthost')
+ if $conn->notes('whitelisthost');
+
+ my $res = new Net::DNS::Resolver;
+ my $sel = $conn->notes('whitelist_sockets') or return "";
+
+ my $result;
+
+ $self->log(LOGDEBUG, "waiting for whitelist dns");
+
+ # don't wait more than 4 seconds here
+ my @ready = $sel->can_read(4);
+
+ $self->log(LOGDEBUG, "DONE waiting for whitelist dns, got ",
+ scalar @ready, " answers ...") ;
+ return '' unless @ready;
+
+ for my $socket (@ready) {
+ my $query = $res->bgread($socket);
+ $sel->remove($socket);
+ undef $socket;
+
+ my $whitelist;
+
+ if ($query) {
+ my $a_record = 0;
+ foreach my $rr ($query->answer) {
+ $a_record = 1 if $rr->type eq "A";
+ my $name = $rr->name;
+ ($whitelist) = ($name =~ m/(?:\d+\.){4}(.*)/) unless $whitelist;
+ $whitelist = $name unless $whitelist;
+ $self->log(LOGDEBUG, "name ", $rr->name);
+ next unless $rr->type eq "TXT";
+ $self->log(LOGDEBUG, "got txt record");
+ $result = $rr->txtdata and last;
+ }
+ $a_record and $result = "Blocked by $whitelist";
+ }
+ else {
+ $self->log(LOGERROR, "$whitelist query failed: ", $res->errorstring)
+ unless $res->errorstring eq "NXDOMAIN";
+ }
+
+ if ($result) {
+ #kill any other pending I/O
+ $conn->notes('whitelist_sockets', undef);
+ return $conn->notes('whitelisthost', $result);
+ }
+ }
+
+ if ($sel->count) {
+ # loop around if we have dns blacklists left to see results from
+ return $self->process_sockets();
+ }
+
+ # er, the following code doesn't make much sense anymore...
+
+ # if there was more to read; then forget it
+ $conn->notes('whitelist_sockets', undef);
+
+ return $conn->notes('whitelisthost', $result);
+
+}
+
+sub hook_rcpt {
+ my ($self, $transaction, $rcpt) = @_;
+ my $ip = $self->qp->connection->remote_ip || return (DECLINED);
+ my $note = $self->process_sockets;
+ if ( $note ) {
+ $self->log(LOGNOTICE,"Host $ip is whitelisted: $note");
+ }
+ return DECLINED;
+}
+
+1;
Added: tags/0.32rc1/plugins/dnsbl
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/dnsbl Fri Feb 17 11:02:02 2006
@@ -0,0 +1,307 @@
+#!perl -w
+
+sub register {
+ my ($self, $qp, $denial ) = @_;
+ if ( defined $denial and $denial =~ /^disconnect$/i ) {
+ $self->{_dnsbl}->{DENY} = DENY_DISCONNECT;
+ }
+ else {
+ $self->{_dnsbl}->{DENY} = DENY;
+ }
+
+}
+
+sub hook_connect {
+ my ($self, $transaction) = @_;
+
+ my $remote_ip = $self->qp->connection->remote_ip;
+
+ # perform RBLSMTPD checks to mimic Dan Bernstein's rblsmtpd
+ if (defined($ENV{'RBLSMTPD'})) {
+ if ($ENV{'RBLSMTPD'} ne '') {
+ $self->log(LOGINFO, "RBLSMTPD=\"$ENV{'RBLSMTPD'}\" for $remote_ip");
+ return DECLINED;
+ } else {
+ $self->log(LOGINFO, "RBLSMTPD set, but empty for $remote_ip");
+ return DECLINED;
+ }
+ } else {
+ $self->log(LOGDEBUG, "RBLSMTPD not set for $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)));
+
+ # we should queue these lookups in the background and just fetch the
+ # results in the first rcpt handler ... oh well.
+
+ my $res = new Net::DNS::Resolver;
+ $res->tcp_timeout(30);
+ $res->udp_timeout(30);
+
+ my $sel = IO::Select->new();
+
+ for my $dnsbl (keys %dnsbl_zones) {
+ # fix to find A records, if the dnsbl_zones line has a second field 20/1/04 ++msp
+ if (defined($dnsbl_zones{$dnsbl})) {
+ $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for A record in the background");
+ $sel->add($res->bgsend("$reversed_ip.$dnsbl"));
+ } else {
+ $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for TXT record in the background");
+ $sel->add($res->bgsend("$reversed_ip.$dnsbl", "TXT"));
+ }
+ }
+
+ $self->qp->connection->notes('dnsbl_sockets', $sel);
+
+ return DECLINED;
+}
+
+sub process_sockets {
+ my ($self) = @_;
+
+ my $conn = $self->qp->connection;
+
+ return $conn->notes('dnsbl')
+ if $conn->notes('dnsbl');
+
+ my %dnsbl_zones = map { (split /:/, $_, 2)[0,1] } $self->qp->config('dnsbl_zones');
+
+ my $res = new Net::DNS::Resolver;
+ $res->tcp_timeout(30);
+ $res->udp_timeout(30);
+
+ my $sel = $conn->notes('dnsbl_sockets') or return "";
+ my $remote_ip = $self->qp->connection->remote_ip;
+
+ my $result;
+
+ $self->log(LOGDEBUG, "waiting for dnsbl dns");
+
+ # don't wait more than 8 seconds here
+ my @ready = $sel->can_read(8);
+
+ $self->log(LOGDEBUG, "DONE waiting for dnsbl dns, got " , scalar @ready, " answers ...") ;
+ return '' unless @ready;
+
+ for my $socket (@ready) {
+ my $query = $res->bgread($socket);
+ $sel->remove($socket);
+ undef $socket;
+
+ my $dnsbl;
+
+ if ($query) {
+ my $a_record = 0;
+ foreach my $rr ($query->answer) {
+ $a_record = 1 if $rr->type eq "A";
+ my $name = $rr->name;
+ ($dnsbl) = ($name =~ m/(?:\d+\.){4}(.*)/) unless $dnsbl;
+ $dnsbl = $name unless $dnsbl;
+ $self->log(LOGDEBUG, "name ", $rr->name);
+ next unless $rr->type eq "TXT";
+ $self->log(LOGDEBUG, "got txt record");
+ $result = $rr->txtdata and last;
+ }
+ #$a_record and $result = "Blocked by $dnsbl";
+
+ if ($a_record) {
+ if (defined $dnsbl_zones{$dnsbl}) {
+ $result = $dnsbl_zones{$dnsbl};
+ #$result =~ s/%IP%/$ENV{'TCPREMOTEIP'}/g;
+ $result =~ s/%IP%/$remote_ip/g;
+ } else {
+ # shouldn't get here?
+ $result = "Blocked by $dnsbl";
+ }
+ }
+ }
+ else {
+ $self->log(LOGERROR, "$dnsbl query failed: ", $res->errorstring)
+ unless $res->errorstring eq "NXDOMAIN";
+ }
+
+ if ($result) {
+ #kill any other pending I/O
+ $conn->notes('dnsbl_sockets', undef);
+ $result = join("\n", $self->qp->config('dnsbl_rejectmsg'), $result);
+ return $conn->notes('dnsbl', $result);
+ }
+ }
+
+ if ($sel->count) {
+ # loop around if we have dns blacklists left to see results from
+ return $self->process_sockets();
+ }
+
+ # er, the following code doesn't make much sense anymore...
+
+ # if there was more to read; then forget it
+ $conn->notes('dnsbl_sockets', undef);
+
+ return $conn->notes('dnsbl', $result);
+
+}
+
+sub hook_rcpt {
+ my ($self, $transaction, $rcpt) = @_;
+ my $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 = $connection->remote_ip;
+ $result =~ s/%IP%/$remote_ip/g;
+ return ($self->{_dnsbl}->{DENY},
+ join(" ", $self->qp->config('dnsbl_rejectmsg'), $result));
+ }
+
+ my $note = $self->process_sockets;
+ my $whitelist = $connection->notes('whitelisthost');
+ if ( $note ) {
+ if ( $rcpt->user =~ /^(?:postmaster|abuse|mailer-daemon|root)$/i ) {
+ $self->log(LOGWARN, "Don't blacklist special account: ".$rcpt->user);
+ }
+ elsif ( $whitelist ) {
+ $self->log(LOGWARN, "Whitelist overrode blacklist: $whitelist");
+ }
+ elsif ( $connection->relay_client() ) {
+ $self->log(LOGWARN, "Don't blacklist relay/auth clients");
+ }
+ else {
+ return ($self->{_dnsbl}->{DENY}, $note);
+ }
+ }
+ return DECLINED;
+
+}
+
+sub hook_disconnect {
+ my ($self, $transaction) = @_;
+
+ $self->qp->connection->notes('dnsbl_sockets', undef);
+
+ return DECLINED;
+}
+
+1;
+
+=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 Usage
+
+Add the following line to the config/plugins file:
+
+ dnsbl [disconnect]
+
+If you want to immediately drop the connection (since some blacklisted
+servers attempt multiple sends per session), add the optional keyword
+"disconnect" (case insensitive) to the config line. In most cases, an
+IP address that is listed should not be given the opportunity to begin
+a new transaction, since even the most volatile blacklists will return
+the same answer for a short period of time (the minimum DNS cache period).
+
+=head1 Configuration files
+
+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
Added: tags/0.32rc1/plugins/greylisting
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/greylisting Fri Feb 17 11:02:02 2006
@@ -0,0 +1,271 @@
+=head1 NAME
+
+denysoft_greylist
+
+=head1 DESCRIPTION
+
+Plugin to implement the 'greylisting' algorithm proposed by Evan
+Harris in http://projects.puremagic.com/greylisting/. Greylisting is
+a form of denysoft filter, where unrecognised new connections are
+temporarily denied for some initial period, to foil spammers using
+fire-and-forget spamware, http_proxies, etc.
+
+Greylisting adds two main features: it tracks incoming connections
+using a triplet of remote IP address, sender, and recipient, rather
+than just using the remote IP; and it uses a set of timeout periods
+(black/grey/white) to control whether connections are allowed, instead
+of using connection counts or rates.
+
+This plugin allows connection tracking on any or all of IP address,
+sender, and recipient (but uses IP address only, by default), with
+configurable greylist timeout periods. A simple dbm database is used
+for tracking connections, and relayclients are always allowed
+through. The plugin supports whitelisting using the whitelist_soft
+plugin (optional).
+
+
+=head1 CONFIG
+
+The following parameters can be passed to denysoft_greylist:
+
+=over 4
+
+=item remote_ip <bool>
+
+Whether to include the remote ip address in tracking connections.
+Default: 1.
+
+=item sender <bool>
+
+Whether to include the sender in tracking connections. Default: 0.
+
+=item recipient <bool>
+
+Whether to include the recipient in tracking connections. Default: 0.
+
+=item deny_late <bool>
+
+Whether to defer denials during the 'mail' hook until 'data_post'
+e.g. to allow per-recipient logging. Default: 0.
+
+=item black_timeout <timeout_seconds>
+
+The initial period, in seconds, for which we issue DENYSOFTs for
+connections from an unknown (or timed out) IP address and/or sender
+and/or recipient (a 'connection triplet'). Default: 50 minutes.
+
+=item grey_timeout <timeout_seconds>
+
+The subsequent 'grey' period, after the initial black blocking period,
+when we will accept a delivery from a formerly-unknown connection
+triplet. If a new connection is received during this time, we will
+record a successful delivery against this IP address, which whitelists
+it for future deliveries (see following). Default: 3 hours 20 minutes.
+
+=item white_timeout <timeout_seconds>
+
+The period after which a known connection triplet will be considered
+stale, and we will issue DENYSOFTs again. New deliveries reset the
+timestamp on the address and renew this timeout. Default: 36 days.
+
+=item mode ( denysoft | testonly | off )
+
+Operating mode. In 'denysoft' mode we log and track connections and
+issue DENYSOFTs for black connections; in 'testonly' mode we log and
+track connections as normal, but never actually issue DENYSOFTs
+(useful for seeding the database and testing without impacting
+deliveries); in 'off' mode we do nothing (useful for turning
+greylisting off globally if using per_recipient configs).
+Default: denysoft.
+
+=item per_recipient <bool>
+
+Flag to indicate whether to use per-recipient configs.
+
+=item per_recipient_db <bool>
+
+Flag to indicate whether to use per-recipient greylisting
+databases (default is to use a shared database).
+
+=back
+
+=head1 BUGS
+
+Database locking is implemented using flock, which may not work on
+network filesystems e.g. NFS. If this is a problem, you may want to
+use something like File::NFSLock instead.
+
+=head1 AUTHOR
+
+Written by Gavin Carr <[email protected]>.
+
+=cut
+
+BEGIN { @AnyDBM_File::ISA = qw(DB_File GDBM_File NDBM_File) }
+use AnyDBM_File;
+use Fcntl qw(:DEFAULT :flock);
+use strict;
+
+my $VERSION = '0.07';
+
+my $DENYMSG = "This mail is temporarily denied";
+my ($QPHOME) = ($0 =~ m!(.*?)/([^/]+)$!);
+my $DB = "denysoft_greylist.dbm";
+my %ARGS = map { $_ => 1 } qw(per_recipient remote_ip sender recipient
+ black_timeout grey_timeout white_timeout deny_late mode);
+my %DEFAULTS = (
+ remote_ip => 1,
+ sender => 0,
+ recipient => 0,
+ black_timeout => 50 * 60,
+ grey_timeout => 3 * 3600 + 20 * 60,
+ white_timeout => 36 * 24 * 3600,
+ mode => 'denysoft',
+);
+
+sub register {
+ my ($self, $qp, %arg) = @_;
+ my $config = { %DEFAULTS,
+ map { split /\s+/, $_, 2 } $self->qp->config('denysoft_greylist'),
+ %arg };
+ if (my @bad = grep { ! exists $ARGS{$_} } sort keys %$config) {
+ $self->log(LOGALERT, "invalid parameter(s): " . join(',',@bad));
+ }
+ $self->{_greylist_config} = $config;
+ unless ($config->{recipient} || $config->{per_recipient}) {
+ $self->register_hook("mail", "mail_handler");
+ } else {
+ $self->register_hook("rcpt", "rcpt_handler");
+ }
+}
+
+sub mail_handler {
+ my ($self, $transaction, $sender) = @_;
+ my ($status, $msg) = $self->denysoft_greylist($transaction, $sender, undef);
+ if ($status == DENYSOFT) {
+ my $config = $self->{_greylist_config};
+ return DENYSOFT, $msg unless $config->{deny_late};
+ $transaction->notes('denysoft_greylist', $msg)
+ }
+ return DECLINED;
+}
+
+sub rcpt_handler {
+ my ($self, $transaction, $rcpt) = @_;
+ # Load per_recipient configs
+ my $config = { %{$self->{_greylist_config}},
+ map { split /\s+/, $_, 2 } $self->qp->config('denysoft_greylist', { rcpt => $rcpt }) };
+ # Check greylisting
+ my $sender = $transaction->sender;
+ my ($status, $msg) = $self->denysoft_greylist($transaction, $sender, $rcpt, $config);
+ if ($status == DENYSOFT) {
+ # Deny here (per-rcpt) unless this is a <> sender, for smtp probes
+ return DENYSOFT, $msg if $sender->address;
+ $transaction->notes('denysoft_greylist', $msg);
+ }
+ return DECLINED;
+}
+
+sub hook_data {
+ my ($self, $transaction) = @_;
+ my $note = $transaction->notes('denysoft_greylist');
+ return DECLINED unless $note;
+ # Decline if ALL recipients are whitelisted
+ if (($transaction->notes('whitelistrcpt')||0) == scalar($transaction->recipients)) {
+ $self->log(LOGWARN,"all recipients whitelisted - skipping");
+ return DECLINED;
+ }
+ return DENYSOFT, $note;
+}
+
+sub denysoft_greylist {
+ my ($self, $transaction, $sender, $rcpt, $config) = @_;
+ $config ||= $self->{_greylist_config};
+ $self->log(LOGDEBUG, "config: " . join(',',map { $_ . '=' . $config->{$_} } sort keys %$config));
+
+ # Always allow relayclients and whitelisted hosts/senders
+ return DECLINED if $self->qp->connection->relay_client();
+ return DECLINED if $self->qp->connection->notes('whitelisthost');
+ return DECLINED if $transaction->notes('whitelistsender');
+
+ # Setup database location
+ my $dbdir = $transaction->notes('per_rcpt_configdir')
+ if $config->{per_recipient_db};
+ $dbdir ||= -d "$QPHOME/var/db" ? "$QPHOME/var/db" : "$QPHOME/config";
+ my $db = "$dbdir/$DB";
+ $self->log(LOGINFO,"using $db as greylisting database");
+
+ my $remote_ip = $self->qp->connection->remote_ip;
+ my $fmt = "%s:%d:%d:%d";
+
+ # Check denysoft db
+ unless (open LOCK, ">$db.lock") {
+ $self->log(LOGCRIT, "opening lockfile failed: $!");
+ return DECLINED;
+ }
+ unless (flock LOCK, LOCK_EX) {
+ $self->log(LOGCRIT, "flock of lockfile failed: $!");
+ close LOCK;
+ return DECLINED;
+ }
+ my %db = ();
+ unless (tie %db, 'AnyDBM_File', $db, O_CREAT|O_RDWR, 0600) {
+ $self->log(LOGCRIT, "tie to database $db failed: $!");
+ close LOCK;
+ return DECLINED;
+ }
+ my @key;
+ push @key, $remote_ip if $config->{remote_ip};
+ push @key, $sender->address || '' if $config->{sender};
+ push @key, $rcpt->address if $rcpt && $config->{recipient};
+ my $key = join ':', @key;
+ my ($ts, $new, $black, $white) = (0,0,0,0);
+ if ($db{$key}) {
+ ($ts, $new, $black, $white) = split /:/, $db{$key};
+ $self->log(LOGERROR, "ts: " . localtime($ts) . ", now: " . localtime);
+ if (! $white) {
+ # Black IP - deny, but don't update timestamp
+ if (time - $ts < $config->{black_timeout}) {
+ $db{$key} = sprintf $fmt, $ts, $new, ++$black, 0;
+ $self->log(LOGCRIT, "key $key black DENYSOFT - $black failed connections");
+ untie %db;
+ close LOCK;
+ return $config->{mode} eq 'testonly' ? DECLINED : DENYSOFT, $DENYMSG;
+ }
+ # Grey IP - accept unless timed out
+ elsif (time - $ts < $config->{grey_timeout}) {
+ $db{$key} = sprintf $fmt, time, $new, $black, 1;
+ $self->log(LOGCRIT, "key $key updated grey->white");
+ untie %db;
+ close LOCK;
+ return DECLINED;
+ }
+ else {
+ $self->log(LOGERROR, "key $key has timed out (grey)");
+ }
+ }
+ # White IP - accept unless timed out
+ else {
+ if (time - $ts < $config->{white_timeout}) {
+ $db{$key} = sprintf $fmt, time, $new, $black, ++$white;
+ $self->log(LOGCRIT, "key $key is white, $white deliveries");
+ untie %db;
+ close LOCK;
+ return DECLINED;
+ }
+ else {
+ $self->log(LOGERROR, "key $key has timed out (white)");
+ }
+ }
+ }
+
+ # New ip or entry timed out - record new and return DENYSOFT
+ $db{$key} = sprintf $fmt, time, ++$new, $black, 0;
+ $self->log(LOGCRIT, "key $key initial DENYSOFT, unknown");
+ untie %db;
+ close LOCK;
+ return $config->{mode} eq 'testonly' ? DECLINED : DENYSOFT, $DENYMSG;
+}
+
+# arch-tag: 6ef5919e-404b-4c87-bcfe-7e9f383f3901
+
Added: tags/0.32rc1/plugins/hosts_allow
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/hosts_allow Fri Feb 17 11:02:02 2006
@@ -0,0 +1,80 @@
+
+=head1 NAME
+
+hosts_allow - decide if a host is allowed to send mail
+
+=head1 DESCRIPTION
+
+The B<hosts_allow> module decides before the SMTP-Greeting if a host is
+allowed to connect. It checks for too many (running) connections from one
+host (see -m/--max-from-ip options in qpsmtpd-forkserver) and the config
+file I<hosts_allow>.
+The plugin takes no arguments.
+
+=head1 CONFIG
+
+The config file contains lines with two or three items. The first is either
+an IP address or a network/mask pair. The second is a (valid) return code
+from Qpsmtpd::Constants. The last is a comment which will be returned to the
+connecting client if the return code is DENY or DENYSOFT (and of course
+DENY_DISCONNECT and DENYSOFT_DISCONNECT).
+Example:
+
+ 192.168.3.4 DECLINED
+ 192.168.3.0/24 DENY Sorry, known spam only source
+
+This would exclude 192.168.3.4 from the DENY of 192.168.3.0/24.
+
+=cut
+
+use Qpsmtpd::Constants;
+use Socket;
+
+sub hook_pre_connection {
+ my ($self,$transaction,%args) = @_;
+
+ # remote_ip => inet_ntoa($iaddr),
+ # remote_port => $port,
+ # local_ip => inet_ntoa($laddr),
+ # local_port => $lport,
+ # max_conn_ip => $MAXCONNIP,
+ # child_addrs => [values %childstatus],
+
+ my $remote = $args{remote_ip};
+
+ if ($args{max_conn_ip}) {
+ my $num_conn = 1; # seed with current value
+ my $raddr = inet_aton($remote);
+ foreach my $rip (@{$args{child_addrs}}) {
+ ++$num_conn if (defined $rip && $rip eq $raddr);
+ }
+ if ($num_conn > $args{max_conn_ip}) {
+ $self->log(LOGINFO,
+ "Too many connections from $remote: "
+ . "$num_conn > " . $args{max_conn_ip}
+ . "Denying connection.");
+ return (DENYSOFT, "Sorry, too many connections from $remote, "
+ ."try again later");
+ }
+ }
+
+ foreach ($self->qp->config("hosts_allow")) {
+ s/^\s*//;
+ my ($ipmask, $const, $message) = split /\s+/, $_, 3;
+ next unless defined $const;
+
+ my ($net,$mask) = split '/', $ipmask, 2;
+ if (!defined $mask) {
+ $mask = 32;
+ }
+ $mask = pack "B32", "1"x($mask)."0"x(32-$mask);
+ if (join(".", unpack("C4", inet_aton($remote) & $mask)) eq $net) {
+ $const = Qpsmtpd::Constants::return_code($const) || DECLINED;
+ return($const, $message);
+ }
+ }
+
+ return (DECLINED);
+}
+
+# vim: sw=4 ts=4 expandtab syn=perl
Added: tags/0.32rc1/plugins/http_config
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/http_config Fri Feb 17 11:02:02 2006
@@ -0,0 +1,49 @@
+=head1 NAME
+
+http_config
+
+=head1 DESCRIPTION
+
+Example config plugin. Gets configuration data via http requests.
+
+=head1 CONFIG
+
+http_config is configured at plugin loading time via the plugins
+config. Load the plugin with a list of urls like the following (on one line)
+
+ http_config http://localhost/~smtpd/config/ http://www.example.com/cgi-bin/qp?config=
+
+Looking to config "me", qpsmtpd will try loading
+http://localhost/~smtpd/config/me and if failing that try
+http://www.example.com/cgi-bin/qp?config=me
+
+=head1 BUGS
+
+http_config doesn't do any caching. It should do some simple caching
+to be used in production.
+
+=cut
+
+use LWP::Simple qw(get);
+
+my @urls;
+
+sub register {
+ my ($self, $qp, @args) = @_;
+ @urls = @args;
+}
+
+sub hook_config {
+ my ($self, $transaction, $config) = @_;
+ $self->log(LOGNOTICE, "http_config called with $config");
+ for my $url (@urls) {
+ $self->log(LOGDEBUG, "http_config loading from $url");
+ my @config = split /[\r\n]+/, (get "$url$config" || "");
+ chomp @config;
+ @config = grep { $_ and $_ !~ m/^\s*#/ and $_ =~ m/\S/ } @config;
+ close CF;
+ # $self->log(LOGNOTICE, "returning http_config for $config ",Data::Dumper->Dump([\@config], [qw(config)]));
+ return (OK, @config) if @config;
+ }
+ return DECLINED;
+}
Added: tags/0.32rc1/plugins/ident/geoip
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/ident/geoip Fri Feb 17 11:02:02 2006
@@ -0,0 +1,30 @@
+# -*- perl -*-
+
+=pod
+
+This plugin uses MaxMind's GeoIP service and the Geo::IP perl module to
+do a lookup on incoming connections and record the country of origin.
+
+Thats all it does.
+
+It logs the country to the connection notes 'geoip_country'. Another
+plugin can use that value to do things to the connection, like reject,
+or greylist.
+
+=cut
+
+use Geo::IP;
+
+my $geoip = Geo::IP->new(GEOIP_STANDARD);
+
+sub hook_connect {
+ my ($self) = @_;
+
+ my $country =
+ $geoip->country_code_by_addr( $self->qp->connection->remote_ip );
+
+ $self->qp->connection->notes('geoip_country', $country);
+ $self->log(LOGNOTICE, "GeoIP Country: $country");
+
+ return DECLINED;
+}
Added: tags/0.32rc1/plugins/ident/p0f
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/ident/p0f Fri Feb 17 11:02:02 2006
@@ -0,0 +1,99 @@
+# -*- perl -*-
+
+=pod
+
+An Identification Plugin
+
+ ./p0f -u qpsmtpd -d -q -Q /tmp/.p0f_socket 'dst port 25' -o /dev/null && \
+ chown qpsmtpd /tmp/.p0f_socket
+
+and add
+
+ ident/p0f /tmp/.p0f_socket
+
+to config/plugins
+
+it puts things into the 'p0f' connection notes so other plugins can do
+things based on source OS.
+
+=cut
+
+use IO::Socket;
+use Net::IP;
+
+sub register {
+ my ($self, $qp, $p0f_socket) = @_;
+
+ $p0f_socket =~ /(.*)/; # untaint
+ $self->{_args}->{p0f_socket} = $1;
+}
+
+sub hook_connect {
+ my($self, $qp) = @_;
+
+ eval {
+ my $p0f;
+ $p0f = p0fq( $self->{_args}->{p0f_socket},
+ $self->qp->connection->remote_ip,
+ $self->qp->connection->remote_port,
+ $self->qp->connection->local_ip,
+ $self->qp->connection->local_port,
+ );
+ $self->qp->connection->notes('p0f',$p0f);
+ $self->log(LOGNOTICE, "Results: ".$p0f->{genre}." (".$p0f->{detail}.")");
+ };
+ $self->log(LOGERROR,"error: $@") if $@;
+
+ return DECLINED;
+}
+
+
+
+=pod
+
+Heavily based on p0fq.pl from the p0f districution, and is marked as:
+ Copyright (C) 2004 by Aurelien Jacobs <[email protected]>
+
+It says:
+# If you want to query p0f from a production application, just
+# implement the same functionality in your code. It's perhaps 10
+# lines.
+
+=cut
+
+my $QUERY_MAGIC = 0x0defaced;
+sub p0fq {
+ my ($p0f_socket,$srcip,$srcport,$destip,$destport) = @_;
+
+ # Convert the IPs and pack the request message
+ my $src = new Net::IP ($srcip) or die (Net::IP::Error());
+ my $dst = new Net::IP ($destip) or die (Net::IP::Error());
+ my $query = pack("L L N N S S", $QUERY_MAGIC, 0x12345678,
+ $src->intip(), $dst->intip(), $srcport, $destport);
+
+ # Open the connection to p0f
+ my $sock = new IO::Socket::UNIX (Peer => $p0f_socket,
+ Type => SOCK_STREAM);
+ die "Could not create socket: $!\n" unless $sock;
+
+ # Ask p0f
+ print $sock $query;
+ my $response = <$sock>;
+ close $sock;
+
+ # Extract the response from p0f
+ my ($magic, $id, $type, $genre, $detail, $dist, $link, $tos, $fw,
+ $nat, $real, $score, $mflags, $uptime) =
+ unpack ("L L C Z20 Z40 c Z30 Z30 C C C s S N", $response);
+ die "Bad response magic.\n" if $magic != $QUERY_MAGIC;
+ die "P0f did not honor our query.\n" if $type == 1;
+ die "This connection is not (no longer?) in the cache.\n" if $type == 2;
+
+ return ({ genre => $genre,
+ detail => $detail,
+ distance => $dist,
+ link => $link,
+ uptime => $uptime,
+ }
+ );
+}
Added: tags/0.32rc1/plugins/logging/adaptive
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/logging/adaptive Fri Feb 17 11:02:02 2006
@@ -0,0 +1,187 @@
+#!perl
+# Adaptive logging plugin - logs at one level for successful messages and
+# one level for DENY'd messages
+
+sub register {
+ my ( $self, $qp, %args ) = @_;
+
+ $self->{_minlevel} = LOGERROR;
+ if ( defined( $args{accept} ) ) {
+ if ( $args{accept} =~ /^\d+$/ ) {
+ $self->{_minlevel} = $args{accept};
+ }
+ else {
+ $self->{_minlevel} = log_level( $args{accept} );
+ }
+ }
+
+ $self->{_maxlevel} = LOGWARN;
+ if ( defined( $args{reject} ) ) {
+ if ( $args{reject} =~ /^\d+$/ ) {
+ $self->{_maxlevel} = $args{reject};
+ }
+ else {
+ $self->{_maxlevel} = log_level( $args{reject} );
+ }
+ }
+
+ $self->{_prefix} = '`';
+ if ( defined $args{prefix} and $args{prefix} =~ /^(.+)$/ ) {
+ $self->{_prefix} = $1;
+ }
+
+ # If you want to capture this log entry with this plugin, you need to
+ # wait until after you register the plugin
+ $self->log( LOGINFO, 'Initializing logging::adaptive plugin' );
+}
+
+sub hook_logging { # wlog
+ my ( $self, $transaction, $trace, $hook, $plugin, @log ) = @_;
+
+ # Don't log your own log entries! If this is the only logging plugin
+ # then these lines will not be logged at all. You can safely comment
+ # out this line and it will not cause an infinite loop.
+ return DECLINED if defined $plugin and $plugin eq $self->plugin_name;
+
+ if ( defined $self->{_maxlevel} && $trace <= $self->{_maxlevel} ) {
+ warn join(
+ " ", $$.
+ (
+ defined $plugin ? " $plugin plugin:"
+ : defined $hook ? " running plugin ($hook):"
+ : ""
+ ),
+ @log
+ ),
+ "\n"
+ unless $log[0] =~ /logging::adaptive/;
+ push @{ $transaction->{_log} }, [ $trace, $hook, $plugin, @log ]
+ if ( defined $self->{_minlevel} && $trace <= $self->{_minlevel} );
+ }
+
+ return DECLINED;
+}
+
+sub hook_deny { # dlog
+ my ( $self, $transaction, $prev_hook, $return, $return_text ) = @_;
+ $self->{_denied} = 1;
+}
+
+sub hook_reset_transaction { # slog
+
+ # fires when a message is accepted
+ my ( $self, $transaction, @args ) = @_;
+
+ return DECLINED if $self->{_denied};
+
+ foreach my $row ( @{ $transaction->{_log} } ) {
+ next unless scalar @$row; # skip over empty log lines
+ my ( $trace, $hook, $plugin, @log ) = @$row;
+ warn join(
+ " ", $$,
+ $self->{_prefix}.
+ (
+ defined $plugin ? " $plugin plugin:"
+ : defined $hook ? " running plugin ($hook):"
+ : ""
+ ),
+ @log
+ ),
+ "\n"
+ if ( $trace <= $self->{_minlevel} );
+ }
+
+ return DECLINED;
+}
+
+=cut
+
+
+=head1 NAME
+
+adaptive - An adaptive logging plugin for qpsmtpd
+
+=head1 DESCRIPTION
+
+A qpsmtpd plugin for logging at different levels depending on success or
+failure of any given message.
+
+=head1 INSTALL AND CONFIG
+
+Place this plugin in the plugin/logging directory beneath the standard
+qpsmtpd installation. Edit the config/logging file and add a line like
+this:
+
+ logging/adaptive [accept minlevel] [reject maxlevel] [prefix char]
+
+where the optional parameters are:
+
+=over 4
+
+=item B<accept>
+
+This is the level at which messages which are accepted will be logged. You
+can use either the loglevel number (as shown in config.sample/loglevels) or
+you can use the text form (from the same file). Typically, you would set
+this to LOGERROR (4) so that the FROM and TO lines would be logged (with the
+default installation). If absent, it will be set to LOGERROR (4).
+
+=item B<reject>
+
+This is the level which messages which are rejected for any reason will be
+logged. This would typically be set as high as reasonable, to document why a
+message may have been rejected. If absent, it defaults to LOGWARN (5), which
+is probably not high enough for most sites.
+
+=item B<prefix>
+
+In order to visually distinguish the accepted from rejected lines, all
+log lines from a accepted message will be prefixed with the character
+listed here (directly after the PID). You can use anything you want as
+a prefix, but it is recommended that it be short (preferably just a single
+character) to minimize the amount of bloat in the log file. If absent, the
+prefix defaults to the left single quote (`).
+
+=back
+
+=head1 TYPICAL USAGE
+
+If you are using multilog to handle your logging, you can replace the system
+provided log/run file with something like this:
+
+ #! /bin/sh
+ export LOGDIR=./main
+ mkdir -p $LOGDIR/failed
+ exec multilog t n10 \
+ '-*` *' $LOGDIR/detailed \
+ '-*' '+*` *' $LOGDIR/accepted
+
+which will have the following effects:
+
+=over 4
+
+=item 1. All lines will be logged into the ./mail/detailed folder
+
+=item 2. Log lines for messages that are accepted will go to ./main/accepted
+
+=back
+
+You may want to use the s####### option to multilog to ensure that the log
+files are large enough to maintain a proper amount of history. Depending on
+your site load, it is useful to have at least a week and preferrably three
+weeks of accepted messages. You can also use the n## option to have more
+log history files maintained.
+
+=head1 AUTHOR
+
+John Peacock <[email protected]>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2005 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
+
Added: tags/0.32rc1/plugins/logging/devnull
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/logging/devnull Fri Feb 17 11:02:02 2006
@@ -0,0 +1,7 @@
+#!/usr/bin/perl
+# this is a simple 'drop packets on the floor' plugin
+
+sub hook_logging {
+ return DECLINED;
+}
+
Added: tags/0.32rc1/plugins/logging/file
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/logging/file Fri Feb 17 11:02:02 2006
@@ -0,0 +1,267 @@
+#!/usr/bin/perl
+# $Id$
+
+=head1 NAME
+
+file - Simple log-to-file logging for qpsmtpd
+
+=head1 DESCRIPTION
+
+The 'file' logging plugin for qpsmtpd records qpsmtpd log messages into a
+file (or a named pipe, if you prefer.)
+
+=head1 CONFIGURATION
+
+To enable the logging plugin, add a line of this form to the qpsmtpd plugins
+configuration file:
+
+=over
+
+logging/file [loglevel I<level>] [reopen] [nosplit] I<path>
+
+For example:
+
+logging/file loglevel LOGINFO /var/log/qpsmtpd.log
+logging/file /var/log/qpsmtpd.log.%Y-%m-%d
+logging/file loglevel LOGCRIT reopen |/usr/local/sbin/page-sysadmin
+
+=back
+
+Multiple instances of the plugin can be configured by appending :I<N> for any
+integer(s) I<N>, to log to multiple files simultaneously, e.g. to log critical
+errors and normally verbose logs elsewhere.
+
+The filename or command given can include strftime conversion specifiers,
+which can be used to substitute time and date information into the logfile.
+The file will be reopened whenever this output changes (for example, with a
+format of qpsmtpd.log.%Y-%m-%d-%h, the log would be reopened once per hour).
+
+The list of supported conversion specifiers depends on the strftime()
+implementation of your C library. See strftime(3) for details. Additionally,
+%i will be expanded to a (hopefully) unique session-id; if %i is used, a new
+logfile will be started for each SMTP connection.
+
+The following optional configuration setting can be supplied:
+
+=over
+
+=item nosplit
+
+If specified, the output file or pipe will be reopened at once once per
+connection, and only prior to the first log output. This prevents logs for
+sessions that span log intervals being split across multiple logfiles.
+Without this option, the log will be reopened only when its output filename
+changes; if strftime specifiers are not used, the log will not be reopened
+at all.
+
+=item reopen
+
+Forces the log output to be reopened once per connection, as soon as something
+is available to be logged. This can be combined with a high log severity (see
+I<loglevel> below) to facilitate SMTP service alarms with Nagios or a similar
+monitoring agent.
+
+=item loglevel I<loglevel>
+
+The internal log level below which messages will be logged. The I<loglevel>
+given should be chosen from the list below. Priorities count downward (for
+example, if LOGWARN were selected, LOGERROR, LOGCRIT and LOGEMERG messages
+would be logged as well).
+
+=over
+
+=item B<LOGDEBUG>
+
+=item B<LOGINFO>
+
+=item B<LOGNOTICE>
+
+=item B<LOGWARN>
+
+=item B<LOGERROR>
+
+=item B<LOGCRIT>
+
+=item B<LOGALERT>
+
+=item B<LOGEMERG>
+
+=back
+
+=back
+
+
+The chosen I<path> should be writable by the user running qpsmtpd; it will be
+created it did not already exist, and appended to otherwise.
+
+=head1 AUTHORS
+
+Devin Carraway <[email protected]>, with contributions by Peter J.
+Holzer <[email protected]>.
+
+=head1 LICENSE
+
+Copyright (c) 2005-2006, Devin Carraway
+Copyright (c) 2006, Peter J. Holzer.
+
+This plugin is licensed under the same terms as the qpsmtpd package itself.
+Please see the LICENSE file included with qpsmtpd for details.
+
+=cut
+
+use strict;
+use warnings;
+
+use IO::File;
+use Sys::Hostname;
+use POSIX qw(strftime);
+
+sub register {
+ my ($self, $qp, @args) = @_;
+ my %args;
+
+ $self->{_loglevel} = LOGWARN;
+
+ while (1) {
+ last if !@args;
+ if (lc $args[0] eq 'loglevel') {
+ shift @args;
+ my $ll = shift @args;
+ if (!defined $ll) {
+ warn "Malformed arguments to logging/file plugin";
+ return;
+ }
+ if ($ll =~ /^(\d+)$/) {
+ $self->{_loglevel} = $1;
+ }
+ elsif ($ll =~ /^(LOG\w+)$/) {
+ $self->{_loglevel} = log_level($1);
+ defined $self->{_loglevel} or $self->{_loglevel} = LOGWARN;
+ }
+ }
+ elsif (lc $args[0] eq 'nosplit') {
+ shift @args;
+ $self->{_nosplit} = 1;
+ }
+ elsif (lc $args[0] eq 'reopen') {
+ shift @args;
+ $self->{_reopen} = 1;
+ }
+ else { last }
+ }
+
+ unless (@args && $args[0]) {
+ warn "Malformed arguments to syslog plugin";
+ return;
+ }
+
+ my $output = join(' ', @args);
+
+ if ($output =~ /^\s*\|(.*)/) {
+ $self->{_log_pipe} = 1;
+ $self->{_log_format} = $1;
+ } else {
+ $output =~ /^(.*)/; # detaint
+ $self->{_log_format} = $1;
+ }
+ $self->{_current_output} = '';
+ $self->{_session_counter} = 0;
+ 1;
+}
+
+sub log_output {
+ my ($self, $txn) = @_;
+ my $output = $self->{_log_format};
+ $output =~ s/%i/($txn->notes('logging-session-id') || 'parent')/ge;
+ $output = strftime $output, localtime;
+ $output;
+}
+
+sub open_log {
+ my ($self,$output,$qp) = @_;
+
+ if ($self->{_log_pipe}) {
+ unless ($self->{_f} = new IO::File "|$output") {
+ warn "Error opening log output to command $output: $!";
+ return undef;
+ }
+ } else {
+ unless ($self->{_f} = new IO::File ">>$output") {
+ warn "Error opening log output to path $output: $!";
+ return undef;
+ }
+ }
+ $self->{_current_output} = $output;
+ $self->{_f}->autoflush(1);
+ 1;
+}
+
+
+# Reopen the output iff the interpolated output filename has changed
+# from the one currently open, or if reopening was selected and we haven't
+# yet done so during this session.
+#
+# Returns true if the file was reopened, zero if not, undef on error.
+sub maybe_reopen {
+ my ($self, $txn) = @_;
+
+ my $new_output = $self->log_output($txn);
+ if (!$self->{_current_output} ||
+ $self->{_current_output} ne $new_output ||
+ ($self->{_reopen} &&
+ !$txn->notes('file-reopened-this-session'))) {
+ unless ($self->open_log($new_output, $txn)) {
+ return undef;
+ }
+ $txn->notes('file-reopened-this-session', 1);
+ return 1;
+ }
+ return 0;
+}
+
+sub hook_connect {
+ my ($self, $txn) = @_;
+
+ $txn->notes('file-logged-this-session', 0);
+ $txn->notes('file-reopened-this-session', 0);
+ $txn->notes('logging-session-id',
+ sprintf("%08d-%04d-%d",
+ scalar time, $$, ++$self->{_session_counter}));
+ return DECLINED;
+}
+
+sub hook_disconnect {
+ my ($self) = @_;
+
+ if ($self->{reopen_} && $self->{_f}) {
+ $self->{_f} = undef;
+ }
+ return DECLINED;
+}
+
+sub hook_logging {
+ my ($self, $txn, $trace, $hook, $plugin, @log) = @_;
+
+ return DECLINED if !defined $self->{_loglevel} or
+ $trace > $self->{_loglevel};
+ return DECLINED if defined $plugin and $plugin eq $self->plugin_name;
+
+ # Possibly reopen the log iff:
+ # - It's not already open
+ # - We're allowed to split sessions across logfiles
+ # - We haven't logged anything yet this session
+ if (!$self->{_f} ||
+ !$self->{_nosplit} ||
+ !$txn->notes('file-logged-this-session')) {
+ unless (defined $self->maybe_reopen($txn)) {
+ return DECLINED;
+ }
+ $txn->notes('file-logged-this-session', 1);
+ }
+
+ my $f = $self->{_f};
+ print $f scalar localtime, ' ', hostname(), '[', $$, ']: ', @log, "\n";
+ return DECLINED;
+}
+
+# vi: tabstop=4 shiftwidth=4 expandtab:
Added: tags/0.32rc1/plugins/logging/syslog
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/logging/syslog Fri Feb 17 11:02:02 2006
@@ -0,0 +1,166 @@
+#!/usr/bin/perl
+# $Id$
+
+=head1 NAME
+
+syslog - Syslog logging plugin for qpsmtpd
+
+=head1 DESCRIPTION
+
+The syslog plugin for qpsmtpd passes qpsmtpd log messages into the standard
+UNIX syslog facility, mapping qpsmtpd priorities to syslog priorities.
+
+=head1 CONFIGURATION
+
+To enable the logging plugin, add a line of this form to the qpsmtpd plugins
+configuration file:
+
+=over
+
+logging/syslog [loglevel l] [priority p] [ident str] [facility f]
+
+For example:
+
+logging/syslog loglevel LOGINFO priority LOG_NOTICE
+
+=back
+
+The following optional configuration settings can be supplied:
+
+=over
+
+=item B<loglevel>
+
+The internal log level below which messages will be logged. Priorities count
+downward as follows:
+
+=over
+
+=item B<LOGDEBUG>
+
+=item B<LOGINFO>
+
+=item B<LOGNOTICE>
+
+=item B<LOGWARN>
+
+=item B<LOGERROR>
+
+=item B<LOGCRIT>
+
+=item B<LOGALERT>
+
+=item B<LOGEMERG>
+
+=back
+
+
+=item B<priority>
+
+Normally, log messages will be mapped from the above log levels into the
+syslog(3) log levels of their corresponding names. This will cause various
+messages to appear or not in syslog outputs according to your syslogd
+configuration (typically /etc/syslog.conf). However, if the B<priority>
+setting is used, all messages will be logged at that priority regardless of
+what the original priority might have been.
+
+=item B<ident>
+
+The ident string that will be attached to messages logged via this plugin.
+The default is 'qpsmtpd'.
+
+=item B<facility>
+
+The syslog facility to which logged mesages will be directed. See syslog(3)
+for details. The default is LOG_MAIL.
+
+=back
+
+=head1 AUTHOR
+
+Devin Carraway <[email protected]>
+
+=head1 LICENSE
+
+Copyright (c) 2005, Devin Carraway.
+
+This plugin is licensed under the same terms as the qpsmtpd package itself.
+Please see the LICENSE file included with qpsmtpd for details.
+
+=cut
+
+use strict;
+use warnings;
+
+use Sys::Syslog;
+
+sub register {
+ my ($self, $qp, @args) = @_;
+ my %args;
+
+ if (@args % 2 == 0) {
+ %args = @args;
+ } else {
+ warn "Malformed arguments to syslog plugin";
+ return;
+ }
+
+ my $ident = 'qpsmtpd';
+ my $logopt = 'pid';
+ my $facility = 'LOG_MAIL';
+
+ $self->{_loglevel} = LOGWARN;
+
+ if ($args{loglevel}) {
+ if ($args{loglevel} =~ /^(\d+)$/) {
+ $self->{_loglevel} = $1;
+ }
+ elsif ($args{loglevel} =~ /^(LOG\w+)$/) {
+ $self->{_loglevel} = log_level($1) || LOGWARN;
+ }
+ }
+
+ if ($args{priority}) {
+ if ($args{priority} =~ /^(\d+|LOG\w+)$/) {
+ $self->{_priority} = $1;
+ }
+ }
+
+ if ($args{ident} && $args{ident} =~ /^([\w\-.]+)$/) {
+ $ident = $1;
+ }
+ if ($args{facility} && $args{facility} =~ /^(\w+)$/) {
+ $facility = $1;
+ }
+
+ unless (openlog $ident, $logopt, $facility) {
+ warn "Error opening syslog output";
+ return;
+ }
+}
+
+my %priorities_ = (
+ 0 => 'LOG_EMERG',
+ 1 => 'LOG_ALERT',
+ 2 => 'LOG_CRIT',
+ 3 => 'LOG_ERR',
+ 4 => 'LOG_WARNING',
+ 5 => 'LOG_NOTICE',
+ 6 => 'LOG_INFO',
+ 7 => 'LOG_DEBUG',
+);
+
+sub hook_logging {
+ my ($self, $txn, $trace, $hook, $plugin, @log) = @_;
+
+ return DECLINED if $trace > $self->{_loglevel};
+ return DECLINED if defined $plugin and $plugin eq $self->plugin_name;
+
+ my $priority = $self->{_priority} ?
+ $self->{_priority} : $priorities_{$trace};
+
+ syslog $priority, '%s', join(' ', @log);
+ return DECLINED;
+}
+
+# vi: tabstop=4 shiftwidth=4 expandtab
Added: tags/0.32rc1/plugins/logging/warn
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/logging/warn Fri Feb 17 11:02:02 2006
@@ -0,0 +1,78 @@
+#!/usr/bin/perl
+# this is a simple 'warn' plugin like the default builtin logging
+#
+# It demonstrates that a logging plugin can call ->log itself as well
+# as how to ignore log entries from itself
+
+sub register {
+ my ($self, $qp, $loglevel) = @_;
+
+ $self->{_level} = LOGWARN;
+ if ( defined($loglevel) ) {
+ if ($loglevel =~ /^\d+$/) {
+ $self->{_level} = $loglevel;
+ }
+ else {
+ $self->{_level} = log_level($loglevel);
+ }
+ }
+
+ # If you want to capture this log entry with this plugin, you need to
+ # wait until after you register the plugin
+ $self->log(LOGINFO,'Initializing logging::warn plugin');
+}
+
+sub hook_logging {
+ my ($self, $transaction, $trace, $hook, $plugin, @log) = @_;
+
+ # Don't log your own log entries! If this is the only logging plugin
+ # then these lines will not be logged at all. You can safely comment
+ # out this line and it will not cause an infinite loop.
+ return DECLINED if defined $plugin and $plugin eq $self->plugin_name;
+
+ warn
+ join(" ", $$ .
+ (defined $plugin ? " $plugin plugin:" :
+ defined $hook ? " running plugin ($hook):" : ""),
+ @log), "\n"
+ if ($trace <= $self->{_level});
+
+ return DECLINED;
+}
+
+=cut
+
+=head1 NAME
+
+warn - Default logging plugin for qpsmtpd
+
+=head1 DESCRIPTION
+
+A qpsmtpd plugin which replicates the built in logging functionality, which
+is to send all logging messages to STDERR below a specific log level.
+
+=head1 INSTALL AND CONFIG
+
+Place this plugin in the plugin/logging directory beneath the standard
+qpsmtpd installation. Edit the config/logging file and add a line like
+this:
+
+ logging/warn [loglevel]
+
+where the optional parameters C<loglevel> is either the numeric or text
+representation of the maximum log level, as shown in the
+L<config.sample/loglevel> file.
+
+=head1 AUTHOR
+
+John Peacock <[email protected]>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2005 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
+
Added: tags/0.32rc1/plugins/milter
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/milter Fri Feb 17 11:02:02 2006
@@ -0,0 +1,235 @@
+=head1 NAME
+
+milter
+
+=head1 DESCRIPTION
+
+This plugin allows you to attach to milter filters (yes, those written for
+sendmail) as though they were qpsmtpd plugins.
+
+In order to do this you need the C<Net::Milter> module from CPAN.
+
+=head1 CONFIG
+
+It takes two required parameters - a milter name (for logging) and the port
+to connect to on the localhost. This can also contain a hostname if
+the filter is on another machine:
+
+ milter Brightmail 5513
+
+or
+
+ milter Brightmail bmcluster:5513
+
+This plugin has so far only been tested with Brightmail's milter module.
+
+=cut
+
+use Net::Milter;
+no warnings;
+
+sub register {
+ my ($self, $qp, @args) = @_;
+
+ die "Invalid milter setup args: '@args'" unless @args > 1;
+ my ($name, $port) = @args;
+ my $host = '127.0.0.1';
+ if ($port =~ s/^(.*)://) {
+ $host = $1;
+ }
+
+ $self->{name} = $name;
+ $self->{host} = $host;
+ $self->{port} = $port;
+
+}
+
+sub hook_disconnect {
+ my ($self) = @_;
+
+ my $milter = $self->qp->connection->notes('milter') || return DECLINED;
+ $milter->send_quit();
+
+ $self->qp->connection->notes('spam', undef);
+ $self->qp->connection->notes('milter', undef);
+
+ return DECLINED;
+}
+
+sub check_results {
+ my ($self, $transaction, $where, @results) = @_;
+ foreach my $result (@results) {
+ next if $result->{action} eq 'continue';
+ $self->log(LOGINFO, "milter $self->{name} result action: $result->{action}");
+ if ($result->{action} eq 'reject') {
+ die("Rejected at $where by $self->{name} milter ($result->{explanation})");
+ }
+ elsif ($result->{action} eq 'add') {
+ if ($result->{header} eq 'body') {
+ $transaction->body_write($result->{value});
+ }
+ else {
+ push @{$transaction->notes('milter_header_changes')->{add}},
+ [$result->{header}, $result->{value}];
+ }
+ }
+ elsif ($result->{action} eq 'delete') {
+ push @{$transaction->notes('milter_header_changes')->{delete}},
+ $result->{header};
+ }
+ elsif ($result->{action} eq 'accept') {
+ # TODO - figure out what this is used for
+ }
+ elsif ($result->{action} eq 'replace') {
+ push @{$transaction->notes('milter_header_changes')->{replace}},
+ [$result->{header}, $result->{value}];
+ }
+ }
+}
+
+sub hook_connect {
+ my ($self, $transaction) = @_;
+
+ $self->log(LOGDEBUG, "milter $self->{name} opening connection to milter backend");
+ my $milter = Net::Milter->new();
+ $milter->open($self->{host}, $self->{port}, 'tcp');
+ $milter->protocol_negotiation();
+
+ $self->qp->connection->notes(milter => $milter);
+
+ $self->qp->connection->notes(
+ milter_header_changes => { add => [], delete => [], replace => [], }
+ );
+ my $remote_ip = $self->qp->connection->remote_ip;
+ my $remote_host = $self->qp->connection->remote_host;
+ $self->log(LOGDEBUG, "milter $self->{name} checking connect from $remote_host\[$remote_ip\]");
+
+ eval {
+ $self->check_results($transaction, "connection",
+ $milter->send_connect($remote_host, 'tcp4', 0, $remote_ip));
+ };
+ $self->qp->connection->notes('spam', $@) if $@;
+
+ return DECLINED;
+}
+
+sub hook_helo {
+ my ($self, $transaction) = @_;
+
+ if (my $txt = $self->qp->connection->notes('spam')) {
+ return DENY, $txt;
+ }
+
+ my $milter = $self->qp->connection->notes('milter');
+
+ my $helo = $self->qp->connection->hello;
+ my $host = $self->qp->connection->hello_host;
+
+ $self->log(LOGDEBUG, "milter $self->{name} checking HELO $host");
+
+ eval { $self->check_results($transaction, "HELO",
+ $milter->send_helo($host)) };
+ return(DENY, $@) if $@;
+
+ return DECLINED;
+}
+
+sub hook_mail {
+ my ($self, $transaction, $address) = @_;
+
+ my $milter = $self->qp->connection->notes('milter');
+
+ $self->log(LOGDEBUG, "milter $self->{name} checking MAIL FROM " . $address->format);
+ eval { $self->check_results($transaction, "MAIL FROM",
+ $milter->send_mail_from($address->format)) };
+ return(DENY, $@) if $@;
+
+ return DECLINED;
+}
+
+sub hook_rcpt {
+ my ($self, $transaction, $address) = @_;
+
+ my $milter = $self->qp->connection->notes('milter');
+
+ $self->log(LOGDEBUG, "milter $self->{name} checking RCPT TO " . $address->format);
+
+ eval { $self->check_results($transaction, "RCPT TO",
+ $milter->send_rcpt_to($address->format)) };
+ return(DENY, $@) if $@;
+
+ return DECLINED;
+}
+
+sub hook_data_post {
+ my ($self, $transaction) = @_;
+
+ my $milter = $self->qp->connection->notes('milter');
+
+ $self->log(LOGDEBUG, "milter $self->{name} checking headers");
+
+ my $headers = $transaction->header(); # Mail::Header object
+ foreach my $h ($headers->tags) {
+ # munge these headers because milters prefer them this way
+ $h =~ s/\b(\w)/\U$1/g;
+ $h =~ s/\bid\b/ID/g;
+ foreach my $val ($headers->get($h)) {
+ # $self->log(LOGDEBUG, "milter $self->{name} checking header: $h: $val");
+ eval { $self->check_results($transaction, "header $h",
+ $milter->send_header($h, $val)) };
+ return(DENY, $@) if $@;
+ }
+ }
+
+ eval { $self->check_results($transaction, "end headers",
+ $milter->send_end_headers()) };
+ return(DENY, $@) if $@;
+
+ $transaction->body_resetpos;
+
+ # skip past headers
+ while (my $line = $transaction->body_getline) {
+ $line =~ s/\r?\n//;
+ $line =~ s/\s*$//;
+ last unless length($line);
+ }
+
+ $self->log(LOGDEBUG, "milter $self->{name} checking body");
+
+ my $data = '';
+ while (my $line = $transaction->body_getline) {
+ $data .= $line;
+ if (length($data) > 60000) {
+ eval { $self->check_results($transaction, "body",
+ $milter->send_body($data)) };
+ return(DENY, $@) if $@;
+ $data = '';
+ }
+ }
+
+ if (length($data)) {
+ eval { $self->check_results($transaction, "body",
+ $milter->send_body($data)) };
+ return(DENY, $@) if $@;
+ $data = '';
+ }
+
+ eval { $self->check_results($transaction, "end of DATA",
+ $milter->send_end_body()) };
+ return(DENY, $@) if $@;
+
+ my $milter_header_changes = $transaction->notes('milter_header_changes');
+
+ foreach my $add (@{$milter_header_changes->{add}}) {
+ $headers->add($add->[0], $add->[1]);
+ }
+ foreach my $del (@{$milter_header_changes->{'delete'}}) {
+ $headers->delete($del);
+ }
+ foreach my $repl (@{$milter_header_changes->{replace}}) {
+ $headers->replace($repl->[0], $repl->[1]);
+ }
+
+ return DECLINED;
+}
+
Added: tags/0.32rc1/plugins/queue/exim-bsmtp
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/queue/exim-bsmtp Fri Feb 17 11:02:02 2006
@@ -0,0 +1,138 @@
+=head1 NAME
+
+exim-bsmtp
+
+$Id$
+
+=head1 DESCRIPTION
+
+This plugin enqueues mail from qpsmtpd into Exim via BSMTP
+
+=head1 INSTALLATION
+
+The qpsmtpd user B<must> be configured in the I<trusted_users> setting
+in your Exim configuration. If it is not, queueing will still work,
+but sender addresses will not be honored by exim, which will make all
+mail appear to originate from the smtpd user itself.
+
+=head1 CONFIGURATION
+
+The plugin accepts configuration settings in space-delimited name/value
+pairs. For example:
+
+ queue/exim-bsmtp exim_path /usr/sbin/exim4
+
+=over 4
+
+=item exim_path I<path>
+
+The path to use to execute the Exim BSMTP receiver; by default this is
+I</usr/sbin/rsmtp>. The commandline switch '-bS' will be added (this is
+actually redundant with rsmtp, but harmless).
+
+=cut
+
+=head1 LICENSE
+
+Copyright (c) 2004 by Devin Carraway <[email protected]>
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
+
+=cut
+
+use strict;
+use warnings;
+
+use IO::File;
+use Sys::Hostname qw(hostname);
+use File::Temp qw(tempfile);
+
+sub register {
+ my ($self, $qp, %args) = @_;
+
+ $self->{_exim_path} = $args{exim_path} || '/usr/sbin/rsmtp';
+ $self->{_exim_path} = $1 if $self->{_exim_path} =~ /(.*)/;
+ unless (-x $self->{_exim_path}) {
+ $self->log(LOGERROR, "Could not find exim at $self->{_exim_path};".
+ " please set exim_path in config/plugins");
+ return undef;
+ }
+}
+
+sub hook_queue {
+ my ($self, $txn) = @_;
+
+ my $tmp_dir = $self->qp->config('spool_dir') || '/tmp';
+ $tmp_dir = $1 if ($tmp_dir =~ /(.*)/);
+ my ($tmp, $tmpfn) = tempfile("exim-bsmtp.$$.XXXXXX", DIR => $tmp_dir);
+ unless ($tmp && $tmpfn) {
+ $self->log(LOGERROR, "Couldn't create tempfile: $!");
+ return (DECLINED, 'Internal error enqueueing mail');
+ }
+
+ print $tmp "HELO ", hostname(), "\n",
+ "MAIL FROM:<", ($txn->sender->address || ''), ">\n";
+ print $tmp "RCPT TO:<", ($_->address || ''), ">\n"
+ for $txn->recipients;
+ print $tmp "DATA\n",
+ $txn->header->as_string, "\n";
+ $txn->body_resetpos;
+ while (my $line = $txn->body_getline) {
+ $line =~ s/^\./../;
+ print $tmp $line;
+ }
+ print $tmp ".\nQUIT\n";
+ close $tmp;
+
+ my $cmd = "$self->{_exim_path} -bS < $tmpfn";
+ $self->log(LOGDEBUG, "executing cmd $cmd");
+ my $exim = new IO::File "$cmd|";
+ unless ($exim) {
+ $self->log(LOGERROR, "Could not execute $self->{_exim_path}: $!");
+ unlink $tmpfn or $self->log(LOGERROR, "unlink: $tmpfn: $!");
+ return (DECLINED, "Internal error enqueuing mail");
+ }
+ # Normally exim produces no output in BSMTP mode; anything that
+ # does come out is an error worth logging.
+ my $start = time;
+ while (<$exim>) {
+ chomp;
+ $self->log(LOGERROR, "exim: $_");
+ }
+ $self->log(LOGDEBUG, "BSMTP finished (".(time - $start)." sec)");
+ $exim->close;
+ my $exit = $?;
+ unlink $tmpfn or $self->log(LOGERROR, "unlink: $tmpfn: $!");
+
+ $self->log(LOGDEBUG, "Exitcode from exim: $exit");
+ if (($exit >> 8) != 0) {
+ $self->log(LOGERROR, 'BSMTP enqueue failed; exitcode '.($exit >> 8).
+ " from $self->{_exim_path} -bS");
+ return (DECLINED, 'Internal error enqueuing mail');
+ }
+
+ $self->log(LOGINFO, "Enqueued to exim via BSMTP");
+ return (OK, "Queued!");
+}
+
+
+1;
+
+# vi: ts=4 sw=4 expandtab syn=perl
+
Added: tags/0.32rc1/plugins/queue/maildir
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/queue/maildir Fri Feb 17 11:02:02 2006
@@ -0,0 +1,82 @@
+=head1 NAME
+
+queue/maildir
+
+=head1 DESCRIPTION
+
+This plugin delivers mails to a maildir spool.
+
+=head1 CONFIG
+
+It takes one required parameter, the location of the maildir.
+
+=cut
+
+use File::Path qw(mkpath);
+use Sys::Hostname qw(hostname);
+use Time::HiRes qw(gettimeofday);
+
+sub register {
+ my ($self, $qp, @args) = @_;
+
+ # TODO: support per user/domain/? maildirs
+
+ if (@args > 0) {
+ ($self->{_maildir}) = ($args[0] =~ m!([/\w\.]+)!);
+ }
+
+ unless ($self->{_maildir}) {
+ $self->log(LOGWARN, "WARNING: maildir directory not specified");
+ return 0;
+ }
+
+ map { my $d = $self->{_maildir} . "/$_"; -e $d or mkpath $d, 0, 0700 } qw(cur tmp new);
+
+ my $hostname = (hostname =~ m/([\w\._\-]+)/)[0];
+ $self->{_hostname} = $hostname;
+
+}
+
+my $maildir_counter = 0;
+
+sub hook_queue {
+ my ($self, $transaction) = @_;
+
+ my ($time, $microseconds) = gettimeofday;
+
+ $time = ($time =~ m/(\d+)/)[0];
+ $microseconds =~ s/\D//g;
+
+ my $unique = "P$$" . "M$microseconds" . "Q" . $maildir_counter++;
+ my $file = join ".", $time, $unique, $self->{_hostname};
+ my $maildir = $self->{_maildir};
+
+ # TODO: deliver the mail once per recipient instead
+ $transaction->header->add('Delivered-To', $_->address, 0)
+ for $transaction->recipients;
+
+ open (MF, ">$maildir/tmp/$file") or
+ $self->log(LOGWARN, "could not open $maildir/tmp/$file: $!"),
+ return(DECLINED, "queue error (open)");
+
+ $transaction->header->print(\*MF);
+ $transaction->body_resetpos;
+ while (my $line = $transaction->body_getline) {
+ print MF $line;
+ }
+
+ close MF or
+ $self->log(LOGWARN, "could not close $maildir/tmp/$file: $!")
+ and return(DECLINED, "queue error (close)");
+
+ link "$maildir/tmp/$file", "$maildir/new/$file" or
+ $self->log(LOGWARN, "could not link $maildir/tmp/$file to $maildir/new/$file: $!")
+ and return(DECLINED, "queue error (link)");
+
+ unlink "$maildir/tmp/$file";
+
+ my $msg_id = $transaction->header->get('Message-Id') || '';
+ $msg_id =~ s/[\r\n].*//s;
+
+ return (OK, "Queued! $msg_id");
+}
Added: tags/0.32rc1/plugins/queue/postfix-queue
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/queue/postfix-queue Fri Feb 17 11:02:02 2006
@@ -0,0 +1,96 @@
+
+=head1 NAME
+
+postfix-queue
+
+=head1 DESCRIPTION
+
+This plugin passes mails on to the postfix cleanup daemon.
+
+=head1 CONFIG
+
+The first optional parameter is the location of the cleanup socket. If it does
+not start with a ``/'', it is treated as a flag for cleanup (see below).
+If set, the environment variable POSTFIXQUEUE overrides this setting.
+
+All other parameters are flags for cleanup, no flags are enabled by default.
+Known flags are:
+
+=over 3
+
+=item FLAG_FILTER
+
+Set the CLEANUP_FLAG_FILTER for cleanup. This enables the use of
+I<header_filter>, I<body_filter> or I<content_filter> in postfix' main.cf.
+
+=item FLAG_BCC_OK
+
+Setting this flag enables (for example) the I<recipient_bcc_maps> parameter
+
+=item FLAG_MAP_OK
+
+This flag enables the use of other recipient mappings (e.g.
+I<virtual_alias_maps>) in postfix' cleanup.
+
+=back
+
+=cut
+
+use Qpsmtpd::Postfix;
+
+#
+# postfix' cleanup flags:
+use constant CLEANUP_FLAG_FILTER => (1 << 1); # /* Enable content filter */
+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 */
+
+sub register {
+ my ($self, $qp, @args) = @_;
+
+ $self->{_queue_flags} = 0;
+ if (@args > 0) {
+ if ($args[0] =~ m#^/#) {
+ $self->{_queue_socket} = shift @args;
+ }
+ else {
+ $self->{_queue_socket} = "/var/spool/postfix/public/cleanup";
+ }
+
+ foreach (@args) {
+ if ($_ eq 'FLAG_FILTER') {
+ $self->{_queue_flags} |= CLEANUP_FLAG_FILTER;
+ }
+ elsif ($_ eq 'FLAG_BCC_OK') {
+ $self->{_queue_flags} |= CLEANUP_FLAG_BCC_OK;
+ }
+ elsif ($_ eq 'FLAG_MAP_OK') {
+ $self->{_queue_flags} |= CLEANUP_FLAG_MAP_OK;
+ }
+
+ else {
+ $self->log(LOGWARN, "Ignoring unkown cleanup flag $_");
+ }
+ }
+ }
+ else {
+ $self->{_queue_socket} = "/var/spool/postfix/public/cleanup";
+ }
+
+ $self->{_queue_socket} = $ENV{POSTFIXQUEUE} if $ENV{POSTFIXQUEUE};
+
+}
+
+sub hook_queue {
+ my ($self, $transaction) = @_;
+ $transaction->notes('postfix-queue-flags', $self->{_queue_flags});
+
+# $self->log(LOGDEBUG, "queue-flags=".$transaction->notes('postfix-queue-flags'));
+ my ($status, $qid, $reason) = Qpsmtpd::Postfix->inject_mail($transaction);
+ $status and return (DECLINED, "Unable to queue message ($status, $reason)");
+
+ my $msg_id = $transaction->header->get('Message-Id') || '';
+ $msg_id =~ s/[\r\n].*//s; # don't allow newlines in the Message-Id here
+ return (OK, "Queued! $msg_id (Queue-Id: $qid)");
+}
+
+#vim: sw=2 ts=8
Added: tags/0.32rc1/plugins/queue/qmail-queue
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/queue/qmail-queue Fri Feb 17 11:02:02 2006
@@ -0,0 +1,114 @@
+# -*- perl -*-
+=head1 NAME
+
+qmail-queue
+
+=head1 DESCRIPTION
+
+This is the most common plugin used to queue incoming mails. A
+variation of this plugin would maybe forward the mail via smtp.
+
+=head1 CONFIG
+
+It takes one optional parameter, the location of qmail-queue. This
+makes it easy to use a qmail-queue replacement.
+
+ queue/qmail-queue /var/qmail/bin/another-qmail-queue
+
+If set the environment variable QMAILQUEUE overrides this setting.
+
+=cut
+
+use POSIX ();
+
+sub register {
+ my ($self, $qp, @args) = @_;
+
+ if (@args > 0) {
+ $self->{_queue_exec} = $args[0];
+ $self->log(LOGWARN, "WARNING: Ignoring additional arguments.") if (@args > 1);
+ }
+ else {
+ $self->{_queue_exec} = ($ENV{QMAIL} || '/var/qmail') . "/bin/qmail-queue";
+ }
+
+ $self->{_queue_exec} = $ENV{QMAILQUEUE} if $ENV{QMAILQUEUE};
+}
+
+sub hook_queue {
+ my ($self, $transaction) = @_;
+
+ # these bits inspired by Peter Samuels "qmail-queue wrapper"
+ pipe(MESSAGE_READER, MESSAGE_WRITER) or die("Could not create message pipe");
+ pipe(ENVELOPE_READER, ENVELOPE_WRITER) or die("Could not create envelope pipe");
+
+ local $SIG{PIPE} = sub { die "SIGPIPE" };
+ my $child = fork();
+
+ not defined $child and die("Could not fork");
+
+ if ($child) {
+ # Parent
+ my $oldfh = select(MESSAGE_WRITER); $| = 1;
+ select(ENVELOPE_WRITER); $| = 1;
+ select($oldfh);
+
+ close MESSAGE_READER or die("close msg reader fault");
+ close ENVELOPE_READER or die("close envelope reader fault");
+
+ $transaction->header->print(\*MESSAGE_WRITER);
+ $transaction->body_resetpos;
+ while (my $line = $transaction->body_getline) {
+ print MESSAGE_WRITER $line;
+ }
+ close MESSAGE_WRITER;
+
+ my @rcpt = map { "T" . $_->address } $transaction->recipients;
+ my $from = "F".($transaction->sender->address|| "" );
+ print ENVELOPE_WRITER "$from\0", join("\0",@rcpt), "\0\0"
+ or return(DECLINED,"Could not print addresses to queue");
+
+ close ENVELOPE_WRITER;
+ waitpid($child, 0);
+ my $exit_code = $? >> 8;
+ $exit_code and return(DECLINED, "Unable to queue message ($exit_code)");
+
+ my $msg_id = $transaction->header->get('Message-Id') || '';
+ $msg_id =~ s/[\r\n].*//s; # don't allow newlines in the Message-Id here
+ $msg_id = "<$msg_id>" unless $msg_id =~ /^<.*>$/; # surround in <>'s
+ return (OK, "Queued! " . time . " qp $child $msg_id");
+ }
+ elsif (defined $child) {
+ # Child
+ close MESSAGE_WRITER or exit 1;
+ close ENVELOPE_WRITER or exit 2;
+
+ # Untaint $self->{_queue_exec}
+ my $queue_exec = $self->{_queue_exec};
+ if ($queue_exec =~ /^(\/[\/\-\_\.a-z0-9A-Z]*)$/) {
+ $queue_exec = $1;
+ } else {
+ $self->log(LOGERROR, "FATAL ERROR: Unexpected characters in qmail-queue plugin argument");
+ # This exit is ok as we're exiting a forked child process.
+ exit 3;
+ }
+
+ # save the original STDIN and STDOUT in case exec() fails below
+ open(SAVE_STDIN, "<&STDIN");
+ open(SAVE_STDOUT, ">&STDOUT");
+
+ POSIX::dup2(fileno(MESSAGE_READER), 0) or die "Unable to dup MESSAGE_READER: $!";
+ POSIX::dup2(fileno(ENVELOPE_READER), 1) or die "Unable to dup ENVELOPE_READER: $!";
+
+ my $ppid = getppid();
+ $self->log(LOGNOTICE, "(for $ppid ) Queuing qp $$ to $queue_exec");
+
+ my $rc = exec $queue_exec;
+
+ # close the pipe
+ close(MESSAGE_READER);
+ close(MESSAGE_WRITER);
+
+ exit 6; # we'll only get here if the exec fails
+ }
+}
Added: tags/0.32rc1/plugins/queue/smtp-forward
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/queue/smtp-forward Fri Feb 17 11:02:02 2006
@@ -0,0 +1,69 @@
+=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.
+
+ queue/smtp-forward 10.2.2.2
+
+Optionally you can also add a port:
+
+ queue/smtp-forward 10.2.2.2 9025
+
+=cut
+
+use Net::SMTP;
+
+sub register {
+ 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 hook_queue {
+ my ($self, $transaction) = @_;
+
+ $self->log(LOGINFO, "forwarding to $self->{_smtp_server}:$self->{_smtp_port}");
+ my $smtp = Net::SMTP->new(
+ $self->{_smtp_server},
+ Port => $self->{_smtp_port},
+ Timeout => 60,
+ Hello => $self->qp->config("me"),
+ ) || die $!;
+ $smtp->mail( $transaction->sender->address || "" ) or return(DECLINED, "Unable to queue message ($!)");
+ for ($transaction->recipients) {
+ $smtp->to($_->address) or return(DECLINED, "Unable to queue message ($!)");
+ }
+ $smtp->data() or return(DECLINED, "Unable to queue message ($!)");
+ $smtp->datasend($transaction->header->as_string) or return(DECLINED, "Unable to queue message ($!)");
+ $transaction->body_resetpos;
+ while (my $line = $transaction->body_getline) {
+ $smtp->datasend($line) or return(DECLINED, "Unable to queue message ($!)");
+ }
+ $smtp->dataend() or return(DECLINED, "Unable to queue message ($!)");
+ $smtp->quit() or return(DECLINED, "Unable to queue message ($!)");
+ $self->log(LOGINFO, "finished queueing");
+ return (OK, "Queued!");
+}
Added: tags/0.32rc1/plugins/quit_fortune
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/quit_fortune Fri Feb 17 11:02:02 2006
@@ -0,0 +1,18 @@
+
+sub hook_quit {
+ my $qp = shift->qp;
+
+ # if she talks EHLO she is probably too sophisticated to enjoy the
+ # fun, so skip it.
+ return (DECLINED) if ($qp->connection->hello || '') eq "ehlo";
+
+ my $fortune = '/usr/games/fortune';
+ return DECLINED unless -e $fortune;
+
+ # local %ENV = ();
+
+ my @fortune = `$fortune -s`;
+ @fortune = map { chop; s/^/ \/ /; $_ } @fortune;
+ $qp->respond(221, $qp->config('me') . " closing connection.", @fortune);
+ return DONE;
+}
Added: tags/0.32rc1/plugins/rcpt_ok
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/rcpt_ok Fri Feb 17 11:02:02 2006
@@ -0,0 +1,38 @@
+# this plugin checks the standard rcpthosts config
+#
+# It should be configured to be run _LAST_!
+#
+use Qpsmtpd::DSN;
+
+sub hook_rcpt {
+ my ($self, $transaction, $recipient) = @_;
+ my $host = lc $recipient->host;
+
+ my @rcpt_hosts = ($self->qp->config("me"), $self->qp->config("rcpthosts"));
+
+ # Allow 'no @' addresses for 'postmaster' and 'abuse'
+ # qmail-smtpd will do this for all users without a domain, but we'll
+ # be a bit more picky. Maybe that's a bad idea.
+ my $user = $recipient->user;
+ $host = $self->qp->config("me")
+ if ($host eq "" && (lc $user eq "postmaster" || lc $user eq "abuse"));
+
+ # Check if this recipient host is allowed
+ for my $allowed (@rcpt_hosts) {
+ $allowed =~ s/^\s*(\S+)/$1/;
+ return (OK) if $host eq lc $allowed;
+ return (OK) if substr($allowed,0,1) eq "." and $host =~ m/\Q$allowed\E$/i;
+ }
+
+ my $more_rcpt_hosts = $self->qp->config('morercpthosts', 'map');
+ return (OK) if exists $more_rcpt_hosts->{$host};
+
+ if ( $self->qp->connection->relay_client ) { # failsafe
+ return (OK);
+ }
+ else {
+ # default of relaying_denied is obviously DENY,
+ # we use the default "Relaying denied" message...
+ return Qpsmtpd::DSN->relaying_denied();
+ }
+}
Added: tags/0.32rc1/plugins/require_resolvable_fromhost
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/require_resolvable_fromhost Fri Feb 17 11:02:02 2006
@@ -0,0 +1,105 @@
+use Qpsmtpd::DSN;
+use Net::DNS qw(mx);
+use Socket;
+
+my %invalid = ();
+
+sub hook_mail {
+ my ($self, $transaction, $sender) = @_;
+
+ return DECLINED
+ if ($self->qp->connection->notes('whitelistclient'));
+
+ foreach my $i ($self->qp->config("invalid_resolvable_fromhost")) {
+ $i =~ s/^\s*//;
+ $i =~ s/\s*$//;
+ if ($i =~ m#^((\d{1,3}\.){3}\d{1,3})/(\d\d?)#) {
+ $invalid{$1} = $3;
+ }
+ }
+
+ if ($sender ne "<>"
+ and $self->qp->config("require_resolvable_fromhost")
+ and !$self->check_dns($sender->host)) {
+ if ($sender->host) {
+ # default of temp_resolver_failed is DENYSOFT
+ return Qpsmtpd::DSN->temp_resolver_failed("Could not resolve " . $sender->host);
+ }
+ else {
+ # default of addr_bad_from_system is DENY, we use DENYSOFT here to
+ # get the same behaviour as without Qpsmtpd::DSN...
+ return Qpsmtpd::DSN->addr_bad_from_system(DENYSOFT,
+ "FQDN required in the envelope sender");
+ }
+ }
+ return DECLINED;
+
+}
+
+sub check_dns {
+ my ($self, $host) = @_;
+
+ # for stuff where we can't even parse a hostname out of the address
+ return 0 unless $host;
+
+ return 1 if $host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/;
+
+ my $res = new Net::DNS::Resolver;
+ $res->tcp_timeout(30);
+ $res->udp_timeout(30);
+ my @mx = mx($res, $host);
+ foreach my $mx (@mx) {
+ return mx_valid($self, $mx->exchange, $host);
+ }
+ my $query = $res->search($host);
+ if ($query) {
+ foreach my $rr ($query->answer) {
+ if ($rr->type eq "A") {
+ return is_valid($rr->address);
+ }
+ elsif ($rr->type eq "MX") {
+ return mx_valid($self, $rr->exchange, $host);
+ }
+ }
+ }
+ else {
+ $self->log(LOGWARN, "$$ query for $host failed: ", $res->errorstring)
+ unless $res->errorstring eq "NXDOMAIN";
+ }
+ return 0;
+}
+
+sub is_valid {
+ my $ip = shift;
+ my ($net,$mask);
+ ### while (($net,$mask) = each %invalid) {
+ ### ... does NOT reset to beginning, will start on
+ ### 2nd invocation after where it denied the first time..., so
+ ### 2nd time the same "MAIL FROM" would be accepted!
+ foreach $net (keys %invalid) {
+ $mask = $invalid{$net};
+ $mask = pack "B32", "1"x($mask)."0"x(32-$mask);
+ return 0
+ if join(".", unpack("C4", inet_aton($ip) & $mask)) eq $net;
+ }
+ return 1;
+}
+
+sub mx_valid {
+ my ($self, $name, $host) = @_;
+ my $res = new Net::DNS::Resolver;
+ my $query = $res->search($name);
+ if ($query) {
+ foreach my $rr ($query->answer) {
+ next unless $rr->type eq "A";
+ return is_valid($rr->address);
+ }
+ }
+ else {
+ $self->log(LOGWARN, "$$ query for $host failed: ", $res->errorstring)
+ unless $res->errorstring eq "NXDOMAIN";
+ }
+ return 0;
+}
+
+# vim: ts=2 sw=2 expandtab syn=perl
Added: tags/0.32rc1/plugins/rhsbl
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/rhsbl Fri Feb 17 11:02:02 2006
@@ -0,0 +1,112 @@
+
+sub hook_mail {
+ my ($self, $transaction, $sender) = @_;
+
+ my $res = new Net::DNS::Resolver;
+ my $sel = IO::Select->new();
+ my %rhsbl_zones_map = ();
+
+ # Perform any RHS lookups in the background. We just send the query packets here
+ # and pick up any results in the RCPT handler.
+ # MTAs gets confused when you reject mail during MAIL FROM:
+
+ my %rhsbl_zones = map { (split /\s+/, $_, 2)[0,1] } $self->qp->config('rhsbl_zones');
+
+ if ($sender->format ne '<>' and %rhsbl_zones) {
+ push(my @hosts, $sender->host);
+ #my $helo = $self->qp->connection->hello_host;
+ #push(@hosts, $helo) if $helo && $helo ne $sender->host;
+ for my $host (@hosts) {
+ for my $rhsbl (keys %rhsbl_zones) {
+ $self->log(LOGDEBUG, "Checking $host.$rhsbl for A record in the background");
+ $sel->add($res->bgsend("$host.$rhsbl"));
+ $rhsbl_zones_map{"$host.$rhsbl"} = $rhsbl_zones{$rhsbl};
+ }
+ }
+
+ %{$self->{_rhsbl_zones_map}} = %rhsbl_zones_map;
+ $transaction->notes('rhsbl_sockets', $sel);
+ } else {
+ $self->log(LOGDEBUG, 'no RHS checks necessary');
+ }
+
+ return DECLINED;
+}
+
+sub hook_rcpt {
+ my ($self, $transaction, $rcpt) = @_;
+ my $host = $transaction->sender->host;
+ my $hello = $self->qp->connection->hello_host;
+
+ my $result = $self->process_sockets;
+ if ($result && defined($self->{_rhsbl_zones_map}{$result})) {
+ if ($result =~ /^$host\./ ) {
+ return (DENY, "Mail from $host rejected because it " . $self->{_rhsbl_zones_map}{$result});
+ } else {
+ return (DENY, "Mail from HELO $hello rejected because it " . $self->{_rhsbl_zones_map}{$result});
+ }
+ }
+ return (DENY, $result) if $result;
+ return DECLINED;
+}
+
+sub process_sockets {
+ my ($self) = @_;
+ my $trans = $self->transaction;
+ my $result = '';
+
+ return $trans->notes('rhsbl') if $trans->notes('rhsbl');
+
+ my $res = new Net::DNS::Resolver;
+ my $sel = $trans->notes('rhsbl_sockets') or return '';
+
+ $self->log(LOGDEBUG, 'waiting for rhsbl dns');
+
+ # don't wait more than 8 seconds here
+ my @ready = $sel->can_read(8);
+
+ $self->log(LOGDEBUG, 'DONE waiting for rhsbl dns, got ' , scalar @ready, ' answers ...') ;
+ return '' unless @ready;
+
+ for my $socket (@ready) {
+ my $query = $res->bgread($socket);
+ $sel->remove($socket);
+ undef $socket;
+
+ if ($query) {
+ foreach my $rr ($query->answer) {
+ $self->log(LOGDEBUG, 'got an ' . $rr->type . ' record ' . $rr->name);
+ if ($rr->type eq 'A') {
+ $result = $rr->name;
+ $self->log(LOGDEBUG, "A record found for $result with IP " . $rr->address);
+ last;
+ }
+ }
+ } else {
+ $self->log(LOGCRIT, "query failed: ", $res->errorstring) unless $res->errorstring eq 'NXDOMAIN';
+ }
+
+ if ($result) {
+ #kill any other pending I/O
+ $trans->notes('rhsbl_sockets', undef);
+ return $trans->notes('rhsbl', $result);
+ }
+ }
+
+ if ($sel->count) {
+ # loop around if we have dns results left
+ return $self->process_sockets();
+ }
+
+ # if there was more to read; then forget it
+ $trans->notes('rhsbl_sockets', undef);
+
+ return $trans->notes('rhsbl', $result);
+}
+
+sub hook_disconnect {
+ my ($self, $transaction) = @_;
+
+ $transaction->notes('rhsbl_sockets', undef);
+ return DECLINED;
+}
Added: tags/0.32rc1/plugins/sender_permitted_from
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/sender_permitted_from Fri Feb 17 11:02:02 2006
@@ -0,0 +1,123 @@
+
+=head1 NAME
+
+SPF - plugin to implement Sender Permitted From
+
+=head1 SYNOPSIS
+
+ # in config/plugins
+ sender_permitted_from
+
+Or if you wish to issue 5xx on SPF fail:
+
+ sender_permitted_from spf_deny 1
+
+Other arguments are 'trust 0' and 'guess 0'. These turn off processing of
+spf.trusted-forwarders.org and the best_guess functionality. It is unlikely
+that you want to turn these off.
+
+Adding 'spf_deny 2' will also issue a 5xx on a softfail response.
+
+You can also specify local SPF policy with
+
+ include '<spf mechanism list>'
+
+See also http://spf.pobox.com/
+
+=cut
+
+use Mail::SPF::Query 1.991;
+
+sub register {
+ my ($self, $qp, @args) = @_;
+ %{$self->{_args}} = @args;
+}
+
+sub hook_mail {
+ my ($self, $transaction, $sender) = @_;
+
+ return (DECLINED) unless ($sender->format ne "<>"
+ and $sender->host && $sender->user);
+
+ # If we are receving from a relay permitted host, then we are probably
+ # not the delivery system, and so we shouldn't check
+
+ return (DECLINED) if $self->qp->connection->relay_client();
+ my @relay_clients = $self->qp->config("relayclients");
+ my $more_relay_clients = $self->qp->config("morerelayclients", "map");
+ my %relay_clients = map { $_ => 1 } @relay_clients;
+ my $client_ip = $self->qp->connection->remote_ip;
+ while ($client_ip) {
+ return (DECLINED) if exists $relay_clients{$client_ip};
+ return (DECLINED) if exists $more_relay_clients->{$client_ip};
+ $client_ip =~ s/\d+\.?$//; # strip off another 8 bits
+ }
+
+ my $host = lc $sender->host;
+ my $from = $sender->user . '@' . $host;
+
+ my $ip = $self->qp->connection->remote_ip;
+ my $helo = $self->qp->connection->hello_host;
+
+ my $query = Mail::SPF::Query->new(ip => $ip, sender => $from, helo => $helo,
+ sanitize => 1,
+ local => $self->{_args}{local},
+ guess => defined($self->{_args}{guess}) ? $self->{_args}{guess} : 1,
+ trusted => defined($self->{_args}{trust}) ? $self->{_args}{trust} : 1)
+ || die "Couldn't construct Mail::SPF::Query object";
+ $transaction->notes('spfquery', $query);
+
+ return (DECLINED);
+}
+
+sub hook_rcpt {
+ my ($self, $transaction, $rcpt) = @_;
+
+ # special addresses don't get SPF-tested.
+ return DECLINED if $rcpt and $rcpt->user and $rcpt->user =~ /^(?:postmaster|abuse|mailer-daemon|root)$/i;
+
+ my $query = $transaction->notes('spfquery');
+
+ return DECLINED if !$query;
+ my ($result, $smtp_comment, $comment) = $query->result2($rcpt->address);
+
+ if ($result eq "error") {
+ return (DENYSOFT, "SPF error: $smtp_comment");
+ }
+
+ if ($result eq "fail" and $self->{_args}{spf_deny}) {
+ return (DENY, "SPF forgery: $smtp_comment");
+ }
+
+ if ($result eq "softfail" and $self->{_args}{spf_deny} > 1) {
+ return (DENY, "SPF probable forgery: $smtp_comment");
+ }
+
+ if ($result eq 'fail' or $result eq 'softfail') {
+ $self->log(LOGDEBUG, "result for $rcpt->address was $result: $comment");
+ }
+
+ return DECLINED;
+}
+
+sub _uri_escape {
+ my $str = shift;
+ $str =~ s/([^A-Za-z0-9\-_.!~*\'()])/sprintf "%%%X", ord($1)/eg;
+ return $str;
+}
+
+sub hook_data_post {
+ my ($self, $transaction) = @_;
+
+ my $query = $transaction->notes('spfquery');
+ return DECLINED if !$query;
+
+ my ($result, $smtp_comment, $comment) = $query->message_result2();
+
+ $self->log(LOGDEBUG, "result was $result: $comment") if ($result);
+
+ $transaction->header->add('Received-SPF' => "$result ($comment)", 0);
+
+ return DECLINED;
+}
+
Added: tags/0.32rc1/plugins/spamassassin
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/spamassassin Fri Feb 17 11:02:02 2006
@@ -0,0 +1,255 @@
+=head1 NAME
+
+spamassassin - SpamAssassin integration for qpsmtpd
+
+=head1 DESCRIPTION
+
+Plugin that checks if the mail is spam by using the "spamd" daemon
+from the SpamAssassin package. F<http://www.spamassassin.org>
+
+SpamAssassin 2.6 or newer is required.
+
+=head1 CONFIG
+
+Configured in the plugins file without any parameters, the
+spamassassin plugin will add relevant headers from the spamd
+(X-Spam-Status etc).
+
+The format goes like
+
+ spamassassin option value [option value]
+
+Options being those listed below and the values being parameters to
+the options. Confused yet? :-)
+
+=over 4
+
+=item reject_threshold [threshold]
+
+Set the threshold over which the plugin will reject the mail. Some
+mail servers are so useless that they ignore 55x responses not coming
+after RCPT TO, so they might just keep retrying and retrying and
+retrying until the mail expires from their queue.
+
+I like to configure this with 15 or 20 as the threshold.
+
+The default is to never reject mail based on the SpamAssassin score.
+
+=item munge_subject_threshold [threshold]
+
+Set the threshold over which we will prefix the subject with
+'***SPAM***'. A messed up subject is easier to filter on than the
+other headers for many people with not so clever mail clients. You
+might want to make another plugin that does this on a per user basis.
+
+The default is to never munge the subject based on the SpamAssassin score.
+
+=item spamd_socket [/path/to/socket]
+
+Beginning with Mail::SpamAssassin 2.60, it is possible to use Unix
+domain sockets for spamd. This is faster and more secure than using
+a TCP connection.
+
+=item leave_old_headers [drop|rename|keep]
+
+Another mail server before might have checked this mail already and may have
+added X-Spam-Status, X-Spam-Flag and X-Spam-Check-By lines. Normally you can
+not trust such headers and should either rename them to X-Old-... (default,
+parameter 'rename') or have them removed (parameter 'drop'). If you know
+what you are doing, you can also leave them intact (parameter 'keep').
+
+=back
+
+With both of the first options the configuration line will look like the following
+
+ spamasssasin reject_threshold 18 munge_subject_threshold 8
+
+=head1 TODO
+
+Make the "subject munge string" configurable
+
+=cut
+
+
+use Qpsmtpd::DSN;
+use Socket qw(:DEFAULT :crlf);
+use IO::Handle;
+
+sub register {
+ my ($self, $qp, @args) = @_;
+
+ $self->log(LOGERROR, "Bad parameters for the spamassassin plugin")
+ if @_ % 2;
+
+ %{$self->{_args}} = @args;
+
+ $self->register_hook("data_post", "check_spam_reject")
+ if $self->{_args}->{reject_threshold};
+
+ $self->register_hook("data_post", "check_spam_munge_subject")
+ if $self->{_args}->{munge_subject_threshold};
+
+}
+
+sub hook_data_post { # check_spam
+ my ($self, $transaction) = @_;
+
+ $self->log(LOGDEBUG, "check_spam");
+ return (DECLINED) if $transaction->body_size > 500_000;
+
+ my $leave_old_headers = lc($self->{_args}->{leave_old_headers}) || 'rename';
+
+ my $remote = 'localhost';
+ my $port = 783;
+ if ($port =~ /\D/) { $port = getservbyname($port, 'tcp') }
+ die "No port" unless $port;
+ my $iaddr = inet_aton($remote) or
+ $self->log(LOGERROR, "Could not resolve host: $remote") and return (DECLINED);
+ my $paddr = sockaddr_in($port, $iaddr);
+
+ my $proto = getprotobyname('tcp');
+ if ($self->{_args}->{spamd_socket} and
+ $self->{_args}->{spamd_socket} =~ /^([\w\/.-]+)$/ ) { # connect to Unix Domain Socket
+ my $spamd_socket = $1;
+
+ socket(SPAMD, PF_UNIX, SOCK_STREAM, 0)
+ or $self->log(LOGERROR, "Could not open socket: $!") and return (DECLINED);
+
+ $paddr = sockaddr_un($spamd_socket);
+ }
+ else {
+ socket(SPAMD, PF_INET, SOCK_STREAM, $proto)
+ or $self->log(LOGERROR, "Could not open socket: $!") and return (DECLINED);
+ }
+
+ connect(SPAMD, $paddr)
+ or $self->log(LOGERROR, "Could not connect to spamassassin daemon: $!") and return DECLINED;
+ $self->log(LOGDEBUG, "check_spam: connected to spamd");
+
+ SPAMD->autoflush(1);
+
+ $transaction->body_resetpos;
+ my $username = getpwuid($>);
+
+ print SPAMD "SYMBOLS SPAMC/1.3" . CRLF;
+ print SPAMD "User: $username" . CRLF;
+ # Content-Length:
+ print SPAMD CRLF;
+ # or CHECK or REPORT or SYMBOLS
+
+ print SPAMD "X-Envelope-From: ", $transaction->sender->format, CRLF
+ or $self->log(LOGWARN, "Could not print to spamd: $!");
+
+ print SPAMD join CRLF, split /\n/, $transaction->header->as_string
+ or $self->log(LOGWARN, "Could not print to spamd: $!");
+
+ print SPAMD CRLF
+ or $self->log(LOGWARN, "Could not print to spamd: $!");
+
+ while (my $line = $transaction->body_getline) {
+ chomp $line;
+ print SPAMD $line, CRLF
+ or $self->log(LOGWARN, "Could not print to spamd: $!");
+ }
+
+ print SPAMD CRLF;
+ shutdown(SPAMD, 1);
+ $self->log(LOGDEBUG, "check_spam: finished sending to spamd");
+ my $line0 = <SPAMD>; # get the first protocol lines out
+ if ($line0) {
+ $self->log(LOGDEBUG, "check_spam: spamd: $line0");
+
+ if ( $leave_old_headers eq 'rename' )
+ {
+ foreach my $header ( $transaction->header->get('X-Spam-Check-By') )
+ {
+ $transaction->header->add('X-Old-Spam-Check-By', $header);
+ }
+ }
+
+ if ( $leave_old_headers eq 'drop' || $leave_old_headers eq 'rename' )
+ {
+ $transaction->header->delete('X-Spam-Check-By');
+ }
+
+ $transaction->header->add("X-Spam-Check-By", $self->qp->config('me'), 0);
+ }
+
+ my ($flag, $hits, $required);
+ while (<SPAMD>) {
+ $self->log(LOGDEBUG, "check_spam: spamd: $_");
+ #warn "GOT FROM SPAMD1: $_";
+ last unless m/\S/;
+ if (m{Spam: (True|False) ; (-?\d+\.\d) / (-?\d+\.\d)}) {
+ ($flag, $hits, $required) = ($1, $2, $3);
+ }
+
+ }
+ my $tests = <SPAMD>;
+ $tests =~ s/\015//; # hack for outlook
+ $flag = $flag eq 'True' ? 'Yes' : 'No';
+ $self->log(LOGDEBUG, "check_spam: finished reading from spamd");
+
+ if ( $leave_old_headers eq 'rename' )
+ {
+ foreach my $header ( $transaction->header->get('X-Spam-Flag') )
+ {
+ $transaction->header->add('X-Old-Spam-Flag', $header);
+ }
+
+ foreach my $header ( $transaction->header->get('X-Spam-Status') )
+ {
+ $transaction->header->add('X-Old-Spam-Status', $header);
+ }
+ }
+
+ if ( $leave_old_headers eq 'drop' || $leave_old_headers eq 'rename' )
+ {
+ $transaction->header->delete('X-Spam-Flag');
+ $transaction->header->delete('X-Spam-Status');
+ }
+
+ $transaction->header->add('X-Spam-Flag', 'YES', 0) if ($flag eq 'Yes');
+ $transaction->header->add('X-Spam-Status',
+ "$flag, hits=$hits required=$required\n" .
+ "\ttests=$tests", 0);
+ $self->log(LOGNOTICE, "check_spam: $flag, hits=$hits, required=$required, " .
+ "tests=$tests");
+
+ return (DECLINED);
+}
+
+sub check_spam_reject {
+ my ($self, $transaction) = @_;
+
+ $self->log(LOGDEBUG, "check_spam_reject: reject_threshold=" . $self->{_args}->{reject_threshold});
+ my $score = $self->get_spam_score($transaction) or return DECLINED;
+ $self->log(LOGDEBUG, "check_spam_reject: score=$score");
+
+ # default of media_unsupported is DENY, so just change the message
+ return Qpsmtpd::DSN->media_unsupported("spam score exceeded threshold")
+ if $score >= $self->{_args}->{reject_threshold};
+
+ $self->log(LOGDEBUG, "check_spam_reject: passed");
+ return DECLINED;
+}
+
+
+sub check_spam_munge_subject {
+ my ($self, $transaction) = @_;
+ my $score = $self->get_spam_score($transaction) or return DECLINED;
+
+ return DECLINED unless $score >= $self->{_args}->{munge_subject_threshold};
+
+ my $subject = $transaction->header->get('Subject') || '';
+ $transaction->header->replace('Subject', "***SPAM*** $subject");
+
+ return DECLINED;
+}
+
+sub get_spam_score {
+ my ($self, $transaction) = @_;
+ my $status = $transaction->header->get('X-Spam-Status') or return;
+ my ($score) = ($status =~ m/hits=(-?\d+\.\d+)/)[0];
+ return $score;
+}
Added: tags/0.32rc1/plugins/tls
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/tls Fri Feb 17 11:02:02 2006
@@ -0,0 +1,160 @@
+#!perl -w
+
+=head1 NAME
+
+tls - plugin to support STARTTLS
+
+=head1 SYNOPSIS
+
+# in config/plugins
+
+ tls ssl/cert.pem ssl/privkey.pem ssl/ca.pem
+
+=head1 DESCRIPTION
+
+This plugin implements basic TLS support.
+
+If TLS is successfully negotiated then the C<tls_enabled> field in the
+Connection notes is set. If you wish to make TLS mandatory you should check
+that field and take appropriate action. Note that you can only do that from
+MAIL FROM onwards.
+
+Use the script C<plugins/tls_cert> to automatically generate a self-signed
+certificate with the appropriate characteristics. Otherwise, you should
+give absolute pathnames to the certificate, key, and the CA root cert
+used to sign that certificate.
+
+=cut
+
+use IO::Socket::SSL;# qw(debug1 debug2 debug3 debug4);
+
+sub init {
+ my ($self, $qp, $cert, $key, $ca) = @_;
+ $cert ||= 'ssl/qpsmtpd-server.crt';
+ $key ||= 'ssl/qpsmtpd-server.key';
+ $ca ||= 'ssl/qpsmtpd-ca.crt';
+ unless ( -f $cert && -f $key && -f $ca ) {
+ $self->log(LOGERROR, "Cannot locate cert/key! Run plugins/tls_cert to generate");
+ return;
+ }
+ $self->tls_cert($cert);
+ $self->tls_key($key);
+ $self->tls_ca($ca);
+
+ local $^W; # this bit is very noisy...
+ my $ssl_ctx = IO::Socket::SSL::SSL_Context->new(
+ SSL_use_cert => 1,
+ SSL_cert_file => $self->tls_cert,
+ SSL_key_file => $self->tls_key,
+ SSL_ca_file => $self->tls_ca,
+ SSL_cipher_list => 'HIGH',
+ SSL_server => 1
+ ) or die "Could not create SSL context: $!";
+ # now extract the password...
+
+ $self->ssl_context($ssl_ctx);
+
+ # Check for possible AUTH mechanisms
+HOOK: foreach my $hook ( keys %{$qp->{hooks}} ) {
+ no strict 'refs';
+ if ( $hook =~ m/^auth-?(.+)?$/ ) {
+ if ( defined $1 ) {
+ my $hooksub = "hook_$hook";
+ $hooksub =~ s/\W/_/g;
+ *$hooksub = \&bad_ssl_hook;
+ }
+ else { # at least one polymorphous auth provider
+ *hook_auth = \&bad_ssl_hook;
+ }
+ }
+ }
+
+}
+
+sub hook_ehlo {
+ my ($self, $transaction) = @_;
+ return DECLINED unless $self->can_do_tls;
+ return DECLINED if $self->connection->notes('tls_enabled');
+ return DENY, "Command refused due to lack of security" if $transaction->notes('ssl_failed');
+ my $cap = $transaction->notes('capabilities');
+ $cap ||= [];
+ push @$cap, 'STARTTLS';
+ $transaction->notes('tls_enabled', 1);
+ $transaction->notes('capabilities', $cap);
+ return DECLINED;
+}
+
+sub hook_unrecognized_command {
+ my ($self, $transaction, $cmd, @args) = @_;
+ return DECLINED unless $cmd eq 'starttls';
+ return DECLINED unless $transaction->notes('tls_enabled');
+ return DENY, "Syntax error (no parameters allowed)" if @args;
+
+ # OK, now we setup TLS
+ $self->qp->respond (220, "Go ahead with TLS");
+
+ eval {
+ my $tlssocket = IO::Socket::SSL->new_from_fd(
+ fileno(STDIN), '+>',
+ SSL_use_cert => 1,
+ SSL_cert_file => $self->tls_cert,
+ SSL_key_file => $self->tls_key,
+ SSL_ca_file => $self->tls_ca,
+ SSL_cipher_list => 'HIGH',
+ SSL_server => 1,
+ SSL_reuse_ctx => $self->ssl_context,
+ ) or die "Could not create SSL socket: $!";
+
+ # Clone connection object (without data received from client)
+ $self->qp->connection($self->connection->clone());
+ $self->qp->reset_transaction;
+ *STDIN = *STDOUT = $self->connection->notes('tls_socket', $tlssocket);
+ $self->connection->notes('tls_enabled', 1);
+ };
+ if ($@) {
+ # SSL setup failed. Now we must respond to every command with 5XX
+ warn("TLS failed: $@\n");
+ $transaction->notes('ssl_failed', 1);
+ return DENY, "TLS Negotiation Failed";
+ }
+
+ $self->log(LOGWARN, "TLS setup returning");
+ return DONE;
+}
+
+sub can_do_tls {
+ my ($self) = @_;
+ $self->tls_cert && -r $self->tls_cert;
+}
+
+sub tls_cert {
+ my $self = shift;
+ @_ and $self->{_tls_cert} = shift;
+ $self->{_tls_cert};
+}
+
+sub tls_key {
+ my $self = shift;
+ @_ and $self->{_tls_key} = shift;
+ $self->{_tls_key};
+}
+
+sub tls_ca {
+ my $self = shift;
+ @_ and $self->{_tls_ca} = shift;
+ $self->{_tls_ca};
+}
+
+sub ssl_context {
+ my $self = shift;
+ @_ and $self->{_ssl_ctx} = shift;
+ $self->{_ssl_ctx};
+}
+
+# Fulfill RFC 2487 secn 5.1
+sub bad_ssl_hook {
+ my ($self, $transaction) = @_;
+ return DENY, "Command refused due to lack of security" if $transaction->notes('ssl_failed');
+ return DECLINED;
+}
+*hook_helo = *hook_data = *hook_rcpt = *hook_mail = \&bad_ssl_hook;
Added: tags/0.32rc1/plugins/tls_cert
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/tls_cert Fri Feb 17 11:02:02 2006
@@ -0,0 +1,138 @@
+#!/usr/bin/perl -w
+# Very basic script to create TLS certificates for qpsmtpd
+use File::Temp qw/ tempfile tempdir /;
+use Getopt::Long;
+
+my %opts = ();
+chomp (my $hostname = `hostname --fqdn`);
+my %defaults = (
+ C => 'XY',
+ ST => 'unknown',
+ L => 'unknown',
+ O => 'QSMTPD',
+ OU => 'Server',
+ CN => $hostname,
+);
+
+GetOptions(\%opts,
+ 'C|Country:s',
+ 'ST|State:s',
+ 'L|Locality|City:s',
+ 'O|Organization:s',
+ 'OU|OrganizationalUnit|U:s',
+ 'CN|CommonName|N:s',
+ 'emailAddress|email|E:s',
+ 'help|H',
+);
+
+usage() if $opts{help};
+
+# initialize defaults
+foreach my $key ( keys %defaults ) {
+ $opts{$key} = $defaults{$key} unless $opts{$key}
+}
+$opts{emailAddress} = 'postmaster@'.$opts{CN};
+
+mkdir('ssl') unless -d 'ssl';
+
+my $CA_key = 'ssl/qpsmtpd-ca.key';
+my $CA_crt = 'ssl/qpsmtpd-ca.crt';
+my $CA_serial = 'ssl/.cert.serial';
+
+my ($CA, $CAfilename) = tempfile( $template, DIR => "ssl", UNLINK => 1);
+
+print ${CA} return_cfg('CA');
+close ${CA};
+
+system('openssl', 'genrsa', '-out', $CA_key, 2048) == 0
+ or die "Cannot create CA key: $?";
+
+system('openssl', 'req', '-config', $CAfilename, '-new', '-x509',
+ '-days', (365*6), '-key', $CA_key,
+ '-out', $CA_crt) == 0
+ or die "Cannot create CA cert: $?";
+
+my $SERVER_key = 'ssl/qpsmtpd-server.key';
+my $SERVER_csr = 'ssl/qpsmtpd-server.csr';
+my $SERVER_crt = 'ssl/qpsmtpd-server.crt';
+
+my ($SERVER, $SERVERfilename) = tempfile( $template, DIR => "ssl", UNLINK => 1);
+print ${SERVER} return_cfg($opts{OU});
+close ${SERVER};
+
+system('openssl', 'genrsa', '-out', $SERVER_key, 1024) == 0
+ or die "Cannot create server key: $?";
+
+system('openssl', 'req', '-config', $SERVERfilename, '-new',
+ '-key', $SERVER_key, '-out', $SERVER_csr) == 0
+ or die "Cannot create server cert: $?";
+
+my ($SIGN, $SIGNfilename) = tempfile( $template, DIR => "ssl", UNLINK => 1);
+print ${SIGN} <<"EOT";
+extensions = x509v3
+[ x509v3 ]
+subjectAltName = email:copy
+nsComment = tls certificate
+nsCertType = server
+EOT
+close ${SIGN};
+
+open my $SERIAL, '>', $CA_serial;
+print ${SERIAL} "01\n";
+close ${SERIAL};
+
+system('openssl', 'x509', '-extfile', $SIGNfilename, '-days', (365*2),
+ '-CAserial', $CA_serial, '-CA', $CA_crt,
+ '-CAkey', $CA_key, '-in', $SERVER_csr,
+ '-req', '-out', $SERVER_crt) == 0
+ or die "Cannot sign cert: $?";
+
+exit(0);
+
+sub return_cfg {
+ my $OU = shift;
+ my $RANDOM = int(rand(1000)).'RAN'.int(rand(1000)).'DOM';
+ my $cfg = <<"EOT";
+[ req ]
+default_bits = 1024
+default_keyfile = keyfile.pem
+distinguished_name = req_distinguished_name
+attributes = req_attributes
+prompt = no
+output_password = mypass
+
+[ req_distinguished_name ]
+C = $opts{C}
+ST = $opts{ST}
+L = $opts{L}
+O = $opts{O}
+OU = $OU
+CN = $opts{CN}
+emailAddress = $opts{emailAddress}
+
+[ req_attributes ]
+challengePassword = $RANDOM challenge password
+EOT
+ return $cfg;
+}
+
+sub usage {
+ print STDERR <<"EOT";
+
+ $0 will generate a TLS certificate "the quick way",
+ i.e. without interaction. You can change some defaults however.
+
+ These options are recognized: Default:
+
+ --C Country (two letters, e.g. DE) $defaults{C}
+ --ST State (spelled out) $defaults{ST}
+ --L City $defaults{L}
+ --O Organization $defaults{O}
+ --OU Organizational Unit $defaults{OU}
+ --CN Common name $defaults{CN}
+ --email Email address of postmaster postmaster\@CN
+ --help Show usage
+
+EOT
+ exit(1);
+}
Added: tags/0.32rc1/plugins/virus/aveclient
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/virus/aveclient Fri Feb 17 11:02:02 2006
@@ -0,0 +1,180 @@
+#!/usr/bin/perl -w
+=head1 NAME
+
+aveclient
+
+=head1 DESCRIPTION
+
+This qpsmtpd plugin uses the aveclient of a kaspersky 5.x server-suite. The original kaspersky
+aveclient is called within this plugin to connect to the local socket of the aveserver.
+The aveserver runs as a daemon with all virusdefinitions already loaded, what makes scanning veeery
+quick and performant without much load.
+
+When a virus is detected, the mail is blocked and the connection is denied! Further configuration
+is simple to be added.
+
+=head1 INSTALL AND CONFIG
+
+Place this plugin in the default plugin directory of your qpsmtpd installation. Normaly you can use
+it with default options (nothing specified):
+
+=over 4
+
+=item B<aveclient>
+
+Optional you may set the path to original aveclient and/or the socket:
+
+=over 4
+
+=item avclient_bin I</path/to/ave/binary>
+
+Set the path to the original aveclient of kaspersky 5.x server-suite.
+Default: /opt/kav/bin/aveclient
+
+=item avdaemon_sock I</path/to/socket>
+
+Set the path to the unix socket of the original aveserver of kaspersky 5.x server-suite.
+Default: /var/run/aveserver
+
+=item blockonerror I<(1|0)>
+
+Whether to block mails on scanning errors or to accept connections.
+Default: 0 (No)
+
+=back
+
+=back
+
+=head1 EXIT CODES OF aveclient (taken from man aveclient)
+
+When launched with the -s option, aveclient returns one of the following codes (if several files to be scanned are indicated in the
+command line, the return code corresponds to the results of scanning the last file):
+
+0 no viruses have been detected.
+
+1 unable to connect to aveserver.
+
+2 objects with an unknown viral code have been found.
+
+3 suspicious objects have been found.
+
+4 infected objects have been detected.
+
+5 all infected objects have been disinfected.
+
+6 scan results are unavailable: encrypted or password protected file.
+
+7 system error launching the application (file not found, unable to read the file).
+
+8 scan results are unavailable: file is corrupted or input/output error.
+
+9 some of the required parameters are missing from the command line.
+
+=head1 VERSION
+
+0.1rc first proof of concept.
+How is load and performance on larger systems? This is tested whith aprox. 900 Clients
+on a small RH-System (AMD, 768 Mhz, 512 MB) MAXCLIENTS set to 40.
+
+=head1 AUTHOR
+
+Adopted by Marcus Spiegel <[email protected]> from kavscanner plugin of Hanno Hecker.
+
+THIS SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
+
+=cut
+
+use File::Temp qw(tempfile);
+use Mail::Address;
+
+sub register {
+ my ($self, $qp, @args) = @_;
+
+ # defaults to be used
+ $self->{_avclient_bin} = "/opt/kav/bin/aveclient";
+ $self->{_avdaemon_sock} = "/var/run/aveserver";
+ $self->{_blockonerror} = 0;
+
+ # parse optional arguments
+ my %args = @args;
+ foreach my $key (keys %args) {
+ my $arg = $key;
+ $key =~ s/^/_/;
+ $self->{$key} = $args{$arg};
+ }
+
+ # Untaint client location
+ # socket will be tested during scan (response-code)
+ if (exists $self->{_avclient_bin} && $self->{_avclient_bin} =~ /^(\/[\/\-\_\.a-z0-9A-Z]*)$/) {
+ $self->{_avclient_bin} = $1;
+ } else {
+ $self->log(LOGALERT, "FATAL ERROR: No binary aveclient found: '".$self->{_avclient_bin}."'");
+ exit 3;
+ }
+}
+
+sub hook_data_post {
+ my ($self, $transaction) = @_;
+ my ($temp_fh, $filename) = tempfile();
+ my $description = 'clean';
+
+ # a temporary file is needed to be scanned
+ print $temp_fh $transaction->header->as_string;
+ print $temp_fh "\n";
+
+ $transaction->body_resetpos;
+
+ while (my $line = $transaction->body_getline) {
+ print $temp_fh $line;
+ }
+ seek($temp_fh, 0, 0);
+
+ # Now scan this file
+ my $cmd = $self->{_avclient_bin}." -p ".$self->{_avdaemon_sock}." -s $filename 2>&1";
+
+ my @output = `$cmd`;
+ chomp(@output);
+
+ my $result = ($? >> 8);
+ my $signal = ($? & 127);
+
+ # tidy up a bit
+ unlink($filename);
+ close $temp_fh;
+
+ # check if something went wrong
+ if ($signal) {
+ $self->log(LOGERROR, "kavscanner exited with signal: $signal");
+ return (DECLINED);
+ }
+
+ # either we found a virus or something went wrong
+ if ($result > 0) {
+ if ($result =~ /^(2|3|4|6|8)$/) {
+
+ # ok a somewhat virus was found
+ shift @output;
+ $description = "REPORT: ".join(", ",@output);
+ $self->log(LOGWARN, "Virus found! ($description)");
+
+ # we don't want to be disturbed be these, so block mail and DENY connection
+ return(DENY, "Virus found: $description");
+
+ } else {
+ $self->log(LOGCRIT, "aveserver: no viruses have been detected.") if($result =~ /^0$/);
+ $self->log(LOGCRIT, "aveserver: system error launching the application (file not found, unable to read the file).") if($result =~ /^0$/);
+ $self->log(LOGCRIT, "aveserver: some of the required parameters are missing from the command line.") if($result =~ /^9$/);
+ return(DENY, "Unable to scan for virus, please contact admin of ".$self->qp->config("me").", if you feel this is an error!") if $self->{_blockonerror};
+ }
+ }
+
+ $self->log(LOGINFO, "kavscanner results: $description");
+ $transaction->header->add('X-Virus-Checked', 'Checked by Kaspersky on '.$self->qp->config("me"));
+ return (DECLINED);
+}
Added: tags/0.32rc1/plugins/virus/bitdefender
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/virus/bitdefender Fri Feb 17 11:02:02 2006
@@ -0,0 +1,133 @@
+#!/usr/bin/perl -Tw
+
+=head1 NAME
+
+bitdefender -- BitDefender Linux Edition antivirus plugin for qpsmtpd
+
+=head1 DESCRIPTION
+
+This plugin scans incoming mail with the BitDefender Linux Edition scanner,
+and can at your option reject or flag infected messages.
+
+=head1 CONFIGURATION
+
+=over 4
+
+=item B<bitdefender_location>
+
+Full path to the BitDefender binary and all signature files; defaults to
+/opt/bdc/bdc.
+
+=item B<deny_viruses>
+
+Whether the scanner will automatically delete messages which have viruses.
+Takes either 'yes' or 'no' (defaults to 'yes').
+
+=item B<max_size>
+
+Maximum size in kilobytes for messages which will be scanned; defaults to 128k;
+
+=back
+
+=head1 DEPENDENCIES
+
+=over 4
+
+=item B<BitDefender>
+
+The BitDefender Linux Edition is available to use, free of charge, from
+this link:
+
+ <http://www.bitdefender.com/bd/site/products.php?p_id=16>
+
+Please read the documentation for configuring automatic updates of the
+virus profiles.
+
+=back
+
+=head1 AUTHOR
+
+John Peacock <[email protected]>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2004 John Peacock
+
+Based lightly on the clamav plugin
+
+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 File::Path;
+
+use strict;
+use warnings;
+
+sub register {
+ my ( $self, $qp, @args ) = @_;
+
+ while (@args) {
+ $self->{"_bitd"}->{ pop @args } = pop @args;
+ }
+ $self->{"_bitd"}->{"bitdefender_location"} ||= "/opt/bdc/bdc";
+ $self->{"_bitd"}->{"deny_viruses"} ||= "yes";
+ $self->{"_bitd"}->{"max_size"} ||= 128;
+ $self->{"_bitd"}->{"max_size"} *= 1024;
+}
+
+sub hook_data_post {
+ my ( $self, $transaction ) = @_;
+
+ if ( $transaction->body_size > $self->{"_bitd"}->{"max_size"} ) {
+ $self->log( LOGWARN,
+ 'Mail too large to scan ('
+ . $transaction->body_size . " vs "
+ . $self->{"_bitd"}->{"max_size"}
+ . ")" );
+ return (DECLINED);
+ }
+
+ # Ignore non-multipart emails
+ my $content_type = $transaction->header->get('Content-Type');
+ $content_type =~ s/\s/ /g if defined $content_type;
+ unless ( $content_type
+ && $content_type =~ m!\bmultipart/.*\bboundary="?([^"]+)!i )
+ {
+ $self->log( LOGERROR, "non-multipart mail - skipping" );
+ return DECLINED;
+ }
+
+ my $filename = $transaction->body_filename;
+ unless (defined $filename) {
+ $self->log(LOGERROR, "didn't get a filename");
+ return DECLINED;
+ }
+
+ # Now do the actual scanning!
+ open my $bdc, "-|",
+ $self->{"_bitd"}->{"bitdefender_location"}
+ . " --mail --all --arc $filename";
+
+ my $output;
+ while (<$bdc>) {
+ if (/infected: (.+)$/) {
+ $output = $1;
+ last;
+ }
+ }
+ close $bdc;
+
+ if ($output) {
+ $self->log( LOGINFO, "Virus(es) found: $output" );
+ if ( $self->{"_bitd"}->{"deny_viruses"} eq "yes" ) {
+ return ( DENY, "Virus Found: $output" );
+ }
+ }
+
+ return (DECLINED);
+}
+
+1;
+
Added: tags/0.32rc1/plugins/virus/check_for_hi_virus
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/virus/check_for_hi_virus Fri Feb 17 11:02:02 2006
@@ -0,0 +1,39 @@
+#!/usr/bin/perl -w
+
+sub hook_data_post {
+ my ($self, $transaction) = @_;
+
+ # make sure we read from the beginning;
+ $transaction->body_resetpos;
+
+ my $line_number = 0;
+ my $seen_file = 0;
+ my $ct_filename = '';
+ my $cd_filename = '';
+
+ while ($_ = $transaction->body_getline) {
+ last if $line_number++ > 40;
+ if (/^Content-Type: (.*)/) {
+ my $val = $1;
+ if ($val =~ /name="(.*)"/) {
+ $seen_file = 1;
+ $ct_filename = $1;
+ }
+ }
+ if (/^Content-Disposition: (.*)/) {
+ my $val = $1;
+ if ($val =~ /filename="(.*)"/) {
+ $seen_file = 1;
+ $cd_filename = $1;
+ }
+ }
+ }
+
+ if ($seen_file and $ct_filename and $cd_filename) {
+ if ($ct_filename ne $cd_filename) {
+ return (DENY, "Probably the 'Hi' virus");
+ }
+ }
+
+ return DECLINED;
+}
Added: tags/0.32rc1/plugins/virus/clamav
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/virus/clamav Fri Feb 17 11:02:02 2006
@@ -0,0 +1,210 @@
+#!/usr/bin/perl -Tw
+
+=head1 NAME
+
+clamav -- ClamAV antivirus plugin for qpsmtpd
+
+$Id$
+
+=head1 DESCRIPTION
+
+This plugin scans incoming mail with the clamav A/V scanner, and can at your
+option reject or flag infected messages.
+
+=head1 CONFIGURATION
+
+Arguments to clamav should be specified in the form of name=value pairs,
+separated by whitespace. For sake of backwards compatibility, a single
+leading argument containing only alphanumerics, -, _, . and slashes will
+be tolerated, and interpreted as the path to clamscan/clamdscan. All
+new installations should use the name=value form as follows:
+
+=over 4
+
+=item clamscan_path=I<path> (e.g. I<clamscan_path=/usr/bin/clamdscan>)
+
+Path to the clamav commandline scanner. Mail will be passed to the clamav
+scanner in Berkeley mbox format (that is, with a "From " line). See the
+discussion below on which commandline scanner to use.
+
+=item action=E<lt>I<add-header> | I<reject>E<gt> (e.g. I<action=reject>)
+
+Selects an action to take when an inbound message is found to be infected.
+Valid arguments are 'add-header' and 'reject'. All rejections are hard
+5xx-code rejects; the SMTP error will contain an explanation of the virus
+found in the mail (for example, '552 Virus Found: Worm.SomeFool.P').
+
+The default action is 'add-header'.
+
+=item max_size=I<bytes> (e.g. I<max_size=1048576>)
+
+Specifies the maximum size, in bytes, for mail to be scanned. Any mail
+exceeding this size will be left alone. This is recommended, as large mail
+can take an exceedingly long time to scan. The default is 524288, or 512k.
+
+=item tmp_dir=I<path> (e.g. I<max_size=/tmp>)
+
+Specify an alternate temporary directory. If not specified, the qpsmtpd
+I<spool_dir> will be used. If neither is available, I<~/tmp/> will be tried,
+and if that that fails the plugin will gracefully fail.
+
+=item back_compat
+
+If you are using a version of ClamAV prior to 0.80, you need to set this
+variable to include a couple of now deprecated options.
+
+=back
+
+=head2 CLAMAV COMMAND LINE SCANNER
+
+You can use either clamscan or clamdscan, but the latter is recommended for
+sake of performance. However, in this case, the user executing clamd
+requires access to the qpsmtpd spool directory, which usually means either
+running clamd as the same user as qpsmtpd does (by far the easiest method)
+or by doing the following:
+
+=over 4
+
+=item * Change the group ownership of the spool directory to be a group
+of which clamav is a member or add clamav to the same group as the qpsmtpd
+user.
+
+=item * Enable the "AllowSupplementaryGroups" option in clamd.conf.
+
+=item * Change the permissions of the qpsmtpd spool directory to 0750 (this
+will emit a warning when the qpsmtpd service starts up, but can be safely
+ignored).
+
+=item * Make sure that all directories above the spool directory (to the
+root) are g+x so that the group has directory traversal rights; it is not
+necessary for the group to have any read rights except to the spool
+directory itself.
+
+=back
+
+It may be helpful to temporary grant the clamav user a shell and test to
+make sure you can cd into the spool directory and read files located there.
+Remember to remove the shell from the clamav user when you are done
+testing.
+
+
+=head2 CLAMAV CONFIGURATION
+
+At the least, you should have 'ScanMail' supplied in your clamav.conf file.
+It is recommended that you also have sane limits on ArchiveMaxRecursion and
+StreamMaxLength also.
+
+=head1 LICENSE
+
+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;
+
+sub register {
+ my ($self, $qp, @args) = @_;
+ my %args;
+
+ if ($args[0] && $args[0] =~ /^(\/[\/\-\_\.a-z0-9A-Z]*)$/ && -x $1) {
+ $self->{_clamscan_loc} = $1;
+ shift @args;
+ }
+
+ for (@args) {
+ if (/^max_size=(\d+)$/) {
+ $self->{_max_size} = $1;
+ }
+ elsif (/^clamscan_path=(\/[\/\-\_\.a-z0-9A-Z]*)$/) {
+ $self->{_clamscan_loc} = $1;
+ }
+ elsif (/^tmp_dir=(\/[\/\-\_\.a-z0-9A-Z]*)$/) {
+ $self->{_spool_dir} = $1;
+ }
+ elsif (/^action=(add-header|reject)$/) {
+ $self->{_action} = $1;
+ }
+ elsif (/back_compat/) {
+ $self->{_back_compat} = '-i --max-recursion=50';
+ }
+ else {
+ $self->log(LOGERROR, "Unrecognized argument '$_' to clamav plugin");
+ return undef;
+ }
+ }
+
+ $self->{_max_size} ||= 512 * 1024;
+ $self->{_spool_dir} ||= $self->spool_dir();
+ $self->{_back_compat} ||= ''; # make sure something is set
+
+ unless ($self->{_spool_dir}) {
+ $self->log(LOGERROR, "No spool dir configuration found");
+ return undef;
+ }
+ unless (-d $self->{_spool_dir}) {
+ $self->log(LOGERROR, "Spool dir $self->{_spool_dir} does not exist");
+ return undef;
+ }
+
+}
+
+sub hook_data_post {
+ my ($self, $transaction) = @_;
+
+ if ($transaction->body_size > $self->{_max_size}) {
+ $self->log(LOGWARN, 'Mail too large to scan ('.
+ $transaction->body_size . " vs $self->{_max_size})" );
+ return (DECLINED);
+ }
+
+ my $filename = $transaction->body_filename;
+ unless (defined $filename) {
+ $self->log(LOGWARN, "didn't get a filename");
+ return DECLINED;
+ }
+ my $mode = (stat($self->{_spool_dir}))[2];
+ if ( $mode & 07077 ) { # must be sharing spool directory with external app
+ $self->log(LOGWARN,
+ "Changing permissions on file to permit scanner access");
+ chmod $mode, $filename;
+ }
+
+ # Now do the actual scanning!
+ my $cmd = $self->{_clamscan_loc}." --stdout "
+ .$self->{_back_compat}
+ ." --disable-summary $filename 2>&1";
+ $self->log(LOGDEBUG, "Running: $cmd");
+ my $output = `$cmd`;
+
+ my $result = ($? >> 8);
+ my $signal = ($? & 127);
+
+ chomp($output);
+
+ $output =~ s/^.* (.*) FOUND$/$1 /mg;
+
+ $self->log(LOGINFO, "clamscan results: $output");
+
+ if ($signal) {
+ $self->log(LOGINFO, "clamscan exited with signal: $signal");
+ return (DECLINED);
+ }
+ if ($result == 1) {
+ $self->log(LOGINFO, "Virus(es) found: $output");
+ if ($self->{_action} eq 'add-header') {
+ $transaction->header->add('X-Virus-Found', 'Yes');
+ $transaction->header->add('X-Virus-Details', $output);
+ } else {
+ return (DENY, "Virus Found: $output");
+ }
+ }
+ elsif ($result) {
+ $self->log(LOGERROR, "ClamAV error: $cmd: $result\n");
+ }
+ return (DECLINED);
+}
+
+1;
+
Added: tags/0.32rc1/plugins/virus/clamdscan
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/virus/clamdscan Fri Feb 17 11:02:02 2006
@@ -0,0 +1,182 @@
+#!/usr/bin/perl -w
+
+=head1 NAME
+
+clamdscan
+
+=head1 DESCRIPTION
+
+A qpsmtpd plugin for virus scanning using the ClamAV scan daemon, clamd.
+
+=head1 RESTRICTIONS
+
+The ClamAV scan daemon, clamd, must have at least read access to the
+qpsmtpd spool directory in order to sucessfully scan the messages. You can
+ensure this by running clamd as the same user as qpsmtpd does (by far the
+easiest method) or by doing the following:
+
+=over 4
+
+=item * Change the group ownership of the spool directory to be a group
+of which clamav is a member or add clamav to the same group as the qpsmtpd
+user.
+
+=item * Enable the "AllowSupplementaryGroups" option in clamd.conf.
+
+=item * Change the permissions of the qpsmtpd spool directory to 0750 (this
+will emit a warning when the qpsmtpd service starts up, but can be safely
+ignored).
+
+=item * Make sure that all directories above the spool directory (to the
+root) are g+x so that the group has directory traversal rights; it is not
+necessary for the group to have any read rights except to the spool
+directory itself.
+
+=back
+
+It may be helpful to temporary grant the clamav user a shell and test to
+make sure you can cd into the spool directory and read files located there.
+Remember to remove the shell from the clamav user when you are done
+testing.
+
+=head1 INSTALL AND CONFIG
+
+Place this plugin in the plugin/virus directory beneath the standard
+qpsmtpd installation. If you installed clamd with the default path, you
+can use this plugin with default options (nothing specified):
+
+=over 4
+
+=item B<clamd_socket>
+
+Full path to the clamd socket (the recommended mode); defaults to
+/tmp/clamd and is the default method.
+
+=item B<clamd_port>
+
+If present, must be the TCP port where the clamd service is running,
+typically 3310; default disabled. If present, overrides the clamd_socket.
+
+=item B<deny_viruses>
+
+Whether the scanner will automatically delete messages which have viruses.
+Takes either 'yes' or 'no' (defaults to 'yes'). If set to 'no' it will add
+a header to the message with the virus results.
+
+=item B<max_size>
+
+The maximum size, in kilobytes, of messages to scan; defaults to 128k.
+
+=back
+
+=head1 REQUIREMENTS
+
+This module requires the Clamd module, found on CPAN here:
+
+L<http://search.cpan.org/author/MSERGEANT/Clamd-1.04>
+
+=head1 AUTHOR
+
+John Peacock <[email protected]>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2005 John Peacock
+
+Based heavily on the clamav plugin
+
+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 Clamd;
+
+sub register {
+ my ( $self, $qp, @args ) = @_;
+
+ %{ $self->{"_clamd"} } = @args;
+
+ # Set some sensible defaults
+ $self->{"_clamd"}->{"clamd_socket"} ||= "/tmp/clamd";
+ $self->{"_clamd"}->{"deny_viruses"} ||= "yes";
+ $self->{"_clamd"}->{"max_size"} ||= 128;
+}
+
+sub hook_data_post {
+ my ( $self, $transaction ) = @_;
+ $DB::single = 1;
+
+ if ( $transaction->body_size > $self->{"_clamd"}->{"max_size"} * 1024 ) {
+ $self->log( LOGNOTICE, "Declining due to body_size" );
+ return (DECLINED);
+ }
+
+ # Ignore non-multipart emails
+ my $content_type = $transaction->header->get('Content-Type');
+ $content_type =~ s/\s/ /g if defined $content_type;
+ unless ( $content_type
+ && $content_type =~ m!\bmultipart/.*\bboundary="?([^"]+)!i )
+ {
+ $self->log( LOGNOTICE, "non-multipart mail - skipping" );
+ return DECLINED;
+ }
+
+ my $filename = $transaction->body_filename;
+ unless ($filename) {
+ $self->log( LOGWARN, "Cannot process due to lack of filename" );
+ return (DECLINED); # unless $filename;
+ }
+
+ my $mode = ( stat( $self->spool_dir() ) )[2];
+ if ( $mode & 07077 ) { # must be sharing spool directory with external app
+ $self->log( LOGWARN,
+ "Changing permissions on file to permit scanner access" );
+ chmod $mode, $filename;
+ }
+
+ my $clamd;
+
+ if (
+ (
+ $self->{"_clamd"}->{"clamd_port"}
+ and $self->{"_clamd"}->{"clamd_port"} =~ /(\d+)/
+ )
+ or ( $self->{"_clamd"}->{"clamd_socket"}
+ and $self->{"_clamd"}->{"clamd_socket"} =~ /([\w\/.]+)/ )
+ )
+ {
+ my $port = $1;
+ $clamd = Clamd->new( port => $port );
+ }
+ else {
+ $clamd = Clamd->new(); # default unix domain socket
+ }
+
+ unless ( $clamd->ping() ) {
+ $self->log( LOGERROR, "Cannot ping clamd server - did you provide the correct clamd port or socket?" );
+ return DECLINED;
+ }
+
+ if ( my %found = $clamd->scan($filename) ) {
+ my $viruses = join( ",", values(%found) );
+ $self->log( LOGERROR, "One or more virus(es) found: $viruses" );
+
+ if ( lc( $self->{"_clamd"}->{"deny_viruses"} ) eq "yes" ) {
+ return ( DENY,
+ "Virus"
+ . ( $viruses =~ /,/ ? "es " : " " )
+ . "Found: $viruses" );
+ }
+ else {
+ $transaction->header->add( 'X-Virus-Found', 'Yes' );
+ $transaction->header->add( 'X-Virus-Details', $viruses );
+ return (DECLINED);
+ }
+ }
+
+ $transaction->header->add( 'X-Virus-Checked',
+ "Checked by ClamAV on " . $self->qp->config("me") );
+
+ return (DECLINED);
+}
Added: tags/0.32rc1/plugins/virus/hbedv
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/virus/hbedv Fri Feb 17 11:02:02 2006
@@ -0,0 +1,159 @@
+#!/usr/bin/perl -w
+# H+B EDV-AV plugin.
+#
+
+=head1 NAME
+
+hbedv - plugin for qpsmtpd which calls the H+BEDV anti virus scanner
+
+=head1 DESCRIPTION
+
+The B<hbedv> plugin checks a mail for viruses with the H+BEDV anti virus
+scanner (see L<http://www.antivir.de/> for info). It can deny mails if a
+virus was found with a configurable deny list.
+
+=head1 VERSION
+
+this is B<hbedv> version 1.1
+
+=head1 CONFIGURATION
+
+Add (perl-)regexps to the F<hbedv_deny> configuration file, one per line for the
+virii you want to block, e.g.:
+
+ Worm\/Sober\..*
+ Worm\/NetSky\..*
+
+or just
+
+ .*
+
+to block any virus ;)
+
+Set the location of the binary with
+
+ hbedv hbedvscanner /path/to/antivir
+
+in the plugin config if qpsmtpd, the location defaults to I</usr/bin/antivir>.
+
+=head1 NOTES
+
+If the hbedv_deny config file is empty or could not be found, any virus
+will be blocked.
+
+This plugin started life as a copy of the B<clamav> plugin.
+
+=head1 LICENCE
+
+Written by Hanno Hecker E<lt>[email protected]<gt>.
+
+The B<hbedv> plugin is published under the same licence as qpsmtpd itself.
+
+=cut
+
+sub register {
+ my ($self, $qp, @args) = @_;
+
+ if (@args % 2) {
+ $self->log(LOGERROR, "FATAL ERROR: odd number of arguments");
+ exit 3;
+ }
+ my %args = @args;
+ if (!exists $args{hbedvscanner}) {
+ $self->{_hbedvscan_loc} = "/usr/bin/antivir";
+ } else {
+ if ($args{hbedvscanner} =~ /^(\/[\/\-\_\.a-z0-9A-Z]*)$/) {
+ $self->{_hbedvscan_loc} = $1;
+ } else {
+ $self->log(LOGERROR, "FATAL ERROR: Unexpected characters in hbedvscanner argument");
+ exit 3;
+ }
+ }
+}
+
+sub hook_data_post {
+ my ($self, $transaction) = @_;
+
+ my $filename = $transaction->body_filename;
+ unless (defined $filename) {
+ $self->log(LOGWARN, "didn't get a file name");
+ return (DECLINED);
+ }
+
+ # Now do the actual scanning!
+ my $cmd = $self->{_hbedvscan_loc}." --archive-max-recursion=50 --alltypes -z -noboot -nombr -rs $filename 2>&1";
+ $self->log(LOGDEBUG, "Running: $cmd");
+ my @output = `$cmd`;
+
+ my $result = ($? >> 8);
+ my $signal = ($? & 127);
+
+ chomp(@output);
+ my @virii = ();
+ foreach my $line (@output) {
+ next unless $line =~ /^ALERT: \[([^\]]+)\s+(\w+)?\]/; # $2 =~ /^(virus|worm)$/;
+ push @virii, $1;
+ }
+ @virii = unique(@virii);
+
+ $self->log(LOGDEBUG, "results: ".join("//",@output));
+
+ if ($signal) {
+ $self->log(LOGWARN, "scanner exited with signal: $signal");
+ return (DECLINED);
+ }
+ my $output = join(", ", @virii);
+ $output = substr($output, 0, 60);
+ if ($result == 1 || $result == 3) {
+ $self->log(LOGWARN, "Virus(es) found: $output");
+ # return (DENY, "Virus Found: $output");
+ # $transaction->header->add('X-Virus-Found', 'Yes', 0);
+ # $transaction->header->add('X-Virus-Details', $output, 0);
+ $transaction->header->add('X-H+BEDV-Virus-Found', 'Yes', 0);
+ $transaction->header->add('X-H+BEDV-Virus-Details', $output, 0);
+ }
+ elsif ($result == 200) {
+ $self->log(LOGWARN, "Program aborted, not enough memory available");
+ }
+ elsif ($result == 211) {
+ $self->log(LOGWARN, "Programm aborted, because the self check failed");
+ }
+ elsif ($result == 214) {
+ $self->log(LOGWARN, "License key not found");
+ }
+ elsif ($result) {
+ $self->log(LOGWARN, "Error: $result, look for exit codes in the output of '"
+ .$self->{_hbedvscan_loc}." --help' for more info\n");
+ }
+
+ # $transaction->header->add('X-Virus-Checked', 'Checked', 0);
+ $transaction->header->add('X-H+BEDV-Virus-Checked', 'Checked', 0);
+ return (DECLINED) unless $result;
+
+ if (@virii) {
+ return(DENY, "Virus found: $output")
+ unless $self->qp->config("hbedv_deny");
+ foreach my $d ($self->qp->config("hbedv_deny")) {
+ foreach my $v (@virii) {
+ if ($v =~ /^$d$/i) {
+ $self->log(LOGWARN, "Denying mail with virus '$v'");
+ return(DENY, "Virus found: $output");
+ }
+ }
+ }
+ }
+ return (DECLINED);
+}
+
+sub unique {
+ ## This is the short version, I haven't tried if any warnings
+ ## are generated by perl if you use just this... if you need
+ ## every cpu cycle, try this:
+ ## my %h;foreach (@_) { ++$h{$_}; }; return keys(%h);
+ my @list = @_;
+ my %hash;
+ foreach my $item (@list) {
+ exists $hash{$item} || ($hash{$item} = 1);
+ }
+ return keys(%hash)
+}
Added: tags/0.32rc1/plugins/virus/kavscanner
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/virus/kavscanner Fri Feb 17 11:02:02 2006
@@ -0,0 +1,177 @@
+#!/usr/bin/perl -w
+# Kasperski-AV plugin.
+
+=head1 NAME
+
+kavscanner - plugin for qpsmtpd which calls the Kasperski anti virus scanner
+
+=head1 DESCRIPTION
+
+Check a mail with the B<kavscanner> and deny if it matches a configured virus
+list.
+
+=head1 VERSION
+
+this is B<kavscanner> version 1.0
+
+=head1 CONFIGURATION
+
+Add (perl-)regexps to the F<kav_deny> configuration file, one per line for the
+virii you want to block, e.g.:
+
+ I-Worm\.Sober\..*
+ I-Worm\.NetSky\..*
+
+NOTE: untested and disabled currently, need volunteers :-)
+
+If this list does not match the virus found in the mail, you may set
+I<bcc_virusadmin [email protected]> in the plugin config to send a
+B<Bcc:> to the given mail address, i.e. the line
+
+ kavscanner bcc_virusadmin [email protected]
+
+in the F<config/plugin> file instead of just
+
+ kavscanner
+
+Set the location of the binary with
+
+ kavscanner kavscanner_bin /path/to/kavscanner
+
+(default: F</opt/AVP/kavscanner>), NOTE: this may be broken, you want to
+set B<kavscanner_bin> explicitly ;-)
+
+=head1 NOTES
+
+This is a merge of the clam_av plugin for qpsmtpd and qmail-scanner-queue.pl
+L<http://qmail-scanner.sourceforge.net/> with my own improvements ;-)
+Only tested with kavscanner 4.0.x, and bcc_virusadmin untested, as we have no
+use for it currently. I wait for an official change in Qpsmtpd::Transaction
+(reset/set the RCPT TO list) to activate and test the currently disabled
+B<to_virusadmin> option.
+
+=cut
+
+use File::Temp qw(tempfile);
+use Mail::Address;
+
+sub register {
+ my ($self, $qp, @args) = @_;
+
+ if (@args % 2) {
+ $self->log(LOGWARN, "kavscanner: Wrong number of arguments");
+ $self->{_kavscanner_bin} = "/opt/AVP/kavscanner";
+ } else {
+ my %args = @args;
+ foreach my $key (keys %args) {
+ my $arg = $key;
+ $key =~ s/^/_/;
+ $self->{$key} = $args{$arg};
+ }
+ # Untaint scanner location
+ if (exists $self->{_kavscanner_bin} &&
+ $self->{_kavscanner_bin} =~ /^(\/[\/\-\_\.a-z0-9A-Z]*)$/) {
+ $self->{_kavscanner_bin} = $1;
+ } else {
+ $self->log(LOGALERT, "FATAL ERROR: Unexpected characters in kavscanner argument");
+ exit 3;
+ }
+ }
+}
+
+sub hook_data_post {
+ my ($self, $transaction) = @_;
+
+ my ($temp_fh, $filename) = tempfile();
+ print $temp_fh $transaction->header->as_string;
+ print $temp_fh "\n";
+ $transaction->body_resetpos;
+ while (my $line = $transaction->body_getline) {
+ print $temp_fh $line;
+ }
+ seek($temp_fh, 0, 0);
+
+ # Now do the actual scanning!
+ my $cmd = $self->{_kavscanner_bin}." -Y -P -B -MP -MD -* $filename 2>&1";
+ $self->log(LOGNOTICE, "Running: $cmd");
+ my @output = `$cmd`;
+ chomp(@output);
+
+ my $result = ($? >> 8);
+ my $signal = ($? & 127);
+
+ unlink($filename);
+ close $temp_fh;
+
+ if ($signal) {
+ $self->log(LOGWARN, "kavscanner exited with signal: $signal");
+ return (DECLINED);
+ }
+
+ my $description = 'clean';
+ my @infected = ();
+ my @suspicious = ();
+ if ($result > 0) {
+ if ($result =~ /^(2|3|4|8)$/) {
+ foreach (@output) {
+ if (/^.* infected: (.*)$/) {
+ # This covers the specific
+ push @infected, $1;
+ } elsif (/^\s*.* suspicion: (.*)$/) {
+ # This covers the potential viruses
+ push @suspicious, $1;
+ }
+ }
+ $description = "infected by: ".join(", ",@infected)."; "
+ ."suspicions: ".join(", ", @suspicious);
+ # else we may get a veeeery long X-Virus-Details: line or log entry
+ $description = substr($description,0,60);
+ $self->log(LOGWARN, "There be a virus! ($description)");
+ ### Untested by now, need volunteers ;-)
+ #if ($self->qp->config("kav_deny")) {
+ # foreach my $d (keys %{$self->qp->config("kav_deny", "map")}) {
+ # foreach my $v (@infected) {
+ # return(DENY, "Virus found: $description")
+ # if ($v =~ /^$d$/i);
+ # }
+ # foreach my $s (@suspicious) {
+ # return(DENY, "Virus found: $description")
+ # if ($s =~ /^$d$/i);
+ # }
+ # }
+ #}
+ $transaction->header->add('X-Virus-Found', 'Yes');
+ $transaction->header->add('X-Virus-Details', $description);
+ ### maybe the spamassassin plugin can skip this mail if a virus
+ ### was found (and $transaction->notes('virus_flag') exists :))
+ ### ...ok, works with our spamassassin plugin version
+ ### -- hah
+ $transaction->notes('virus', $description);
+ $transaction->notes('virus_flag', 'Yes');
+
+ #### requires modification of Qpsmtpd/Transaction.pm:
+ # if ($self->{_to_virusadmin}) {
+ # my @addrs = ();
+ # foreach (@{$transaction->recipients}) {
+ # push @addr, $_->address;
+ # }
+ # $transaction->header->add('X-Virus-Orig-RcptTo', join(", ", @addrs));
+ # $transaction->set_recipients(@{ Mail::Address->parse($self->{_to_virusadmin}) });
+ # } elsif ($self->{_bcc_virusadmin}) {
+ if ($self->{_bcc_virusadmin}) {
+ foreach ( @{ Mail::Address->parse($self->{_bcc_virusadmin}) } ) {
+ $transaction->add_recipient($_->address);
+ }
+ }
+ } else {
+ $self->log(LOGEMERG, "corrupt or unknown Kaspersky scanner/resource problems - exit status $result");
+ }
+ }
+
+ $self->log(LOGINFO, "kavscanner results: $description");
+
+ $transaction->header->add('X-Virus-Checked', 'Checked by '.$self->qp->config("me"));
+ return (DECLINED);
+}
+
+# vim: ts=2 sw=2 expandtab
Added: tags/0.32rc1/plugins/virus/klez_filter
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/virus/klez_filter Fri Feb 17 11:02:02 2006
@@ -0,0 +1,33 @@
+
+sub hook_data_post {
+ my ($self, $transaction) = @_;
+
+ # klez files are always sorta big .. how big? Dunno.
+ return (DECLINED)
+ if $transaction->body_size < 60_000;
+ # 220k was too little, so let's just disable the "big size check"
+ # or $transaction->body_size > 1_000_000;
+
+ # maybe it would be worthwhile to add a check for
+ # Content-Type: multipart/alternative; here?
+
+ # make sure we read from the beginning;
+ $transaction->body_resetpos;
+
+ my $line_number = 0;
+ my $seen_klez_signature = 0;
+
+ while ($_ = $transaction->body_getline) {
+ last if $line_number++ > 40;
+
+ m/^Content-type:.*(?:audio|application)/i
+ and ++$seen_klez_signature and next;
+
+ return (DENY, "Klez Virus Detected")
+ if $seen_klez_signature
+ and m!^TVqQAAMAAAAEAAAA//8AALgAAAAAAAAAQA!;
+
+ }
+
+ return (DECLINED);
+}
Added: tags/0.32rc1/plugins/virus/sophie
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/virus/sophie Fri Feb 17 11:02:02 2006
@@ -0,0 +1,198 @@
+#!/usr/bin/perl -w
+use IO::Socket;
+
+sub register {
+ my ( $self, $qp, @args ) = @_;
+
+ %{ $self->{"_sophie"} } = @args;
+
+ # Set some sensible defaults
+ $self->{"_sophie"}->{"sophie_socket"} ||= "/var/run/sophie";
+ $self->{"_sophie"}->{"deny_viruses"} ||= "yes";
+ $self->{"_sophie"}->{"max_size"} ||= 128;
+}
+
+sub hook_data_post {
+ my ( $self, $transaction ) = @_;
+ $DB::single = 1;
+
+ if ( $transaction->body_size > $self->{"_sophie"}->{"max_size"} * 1024 ) {
+ $self->log( LOGNOTICE, "Declining due to body_size" );
+ return (DECLINED);
+ }
+
+ # Ignore non-multipart emails
+ my $content_type = $transaction->header->get('Content-Type');
+ $content_type =~ s/\s/ /g if defined $content_type;
+ unless ( $content_type
+ && $content_type =~ m!\bmultipart/.*\bboundary="?([^"]+)!i )
+ {
+ $self->log( LOGWARN, "non-multipart mail - skipping" );
+ return DECLINED;
+ }
+
+ my $filename = $transaction->body_filename;
+ unless ($filename) {
+ $self->log( LOGWARN, "Cannot process due to lack of filename" );
+ return (DECLINED); # unless $filename;
+ }
+
+ my $mode = ( stat( $self->spool_dir() ) )[2];
+ if ( $mode & 07077 ) { # must be sharing spool directory with external app
+ $self->log( LOGWARN,
+ "Changing permissions on file to permit scanner access" );
+ chmod $mode, $filename;
+ }
+
+ my ($SOPHIE, $response);
+ socket(\*SOPHIE, AF_UNIX, SOCK_STREAM, 0)
+ || die "Couldn't create socket ($!)\n";
+
+ connect(\*SOPHIE, pack_sockaddr_un $self->{"_sophie"}->{"sophie_socket"})
+ || die "Couldn't connect() to the socket ($!)\n";
+
+ syswrite(\*SOPHIE, $filename."\n", length($filename)+1);
+ sysread(\*SOPHIE, $response, 256);
+ close (\*SOPHIE);
+
+ my $virus;
+
+ if ( ($virus) = ( $response =~ m/^1:?(.*)?$/ ) ) {
+ $self->log( LOGERROR, "One or more virus(es) found: $virus" );
+
+ if ( lc( $self->{"_sophie"}->{"deny_viruses"} ) eq "yes" ) {
+ return ( DENY,
+ "Virus"
+ . ( $virus =~ /,/ ? "es " : " " )
+ . "Found: $virus" );
+ }
+ else {
+ $transaction->header->add( 'X-Virus-Found', 'Yes' );
+ $transaction->header->add( 'X-Virus-Details', $virus );
+ return (DECLINED);
+ }
+ }
+
+ $transaction->header->add( 'X-Virus-Checked',
+ "Checked by SOPHIE on " . $self->qp->config("me") );
+
+ return (DECLINED);
+}
+
+=head1 NAME
+
+sophie scanner
+
+=head1 DESCRIPTION
+
+A qpsmtpd plugin for virus scanning using the SOPHOS scan daemon, Sophie.
+
+=head1 RESTRICTIONS
+
+The Sophie scan daemon must have at least read access to the qpsmtpd spool
+directory in order to sucessfully scan the messages. You can ensure this
+by running Sophie as the same user as qpsmtpd does (by far the easiest
+method) or by doing the following:
+
+=over 4
+
+=item * Change the group ownership of the spool directory to be a group
+of which the Sophie user is a member or add the Sophie user to the same group
+as the qpsmtpd user.
+
+=item * Change the permissions of the qpsmtpd spool directory to 0750 (this
+will emit a warning when the qpsmtpd service starts up, but can be safely
+ignored).
+
+=item * Make sure that all directories above the spool directory (to the
+root) are g+x so that the group has directory traversal rights; it is not
+necessary for the group to have any read rights except to the spool
+directory itself.
+
+=back
+
+It may be helpful to temporary grant the Sophie user a shell and test to
+make sure you can cd into the spool directory and read files located there.
+Remember to remove the shell from the Sophieav user when you are done
+testing.
+
+Note also that the contents of config/spool_dir must be the full path to the
+spool directory (not a relative path) in order for the scanner to locate the
+file.
+
+=head1 INSTALL AND CONFIG
+
+Place this plugin in the plugin/virus directory beneath the standard
+qpsmtpd installation. If you installed Sophie with the default path, you
+can use this plugin with default options (nothing specified):
+
+=over 4
+
+=item B<Sophie_socket>
+
+Full path to the Sophie socket defaults to /var/run/Sophie.
+
+=item B<deny_viruses>
+
+Whether the scanner will automatically delete messages which have viruses.
+Takes either 'yes' or 'no' (defaults to 'yes'). If set to 'no' it will add
+a header to the message with the virus results.
+
+=item B<max_size>
+
+The maximum size, in kilobytes, of messages to scan; defaults to 128k.
+
+=back
+
+=head1 REQUIREMENTS
+
+This module requires the Sophie daemon, available here:
+
+L<http://www.clanfield.info/sophie/>
+
+which in turn requires the libsavi.so library (available with the Sophos
+Anti-Virus for Linux or Unix).
+
+The following changes to F</etc/sophie.cfg> B<should> be made:
+
+=over 4
+
+=item user: qmaild
+
+Change the "user" parameter to match the qpsmtpd user.
+
+=item group: nofiles
+
+Change the "group" parameter to match the qpsmtpd group.
+
+=item umask: 0001
+
+If you don't change the umask, only the above user/group will be able to scan.
+
+=back
+
+The following changes to F</etc/sophie.savi> B<must> be made:
+
+=over 4
+
+=item Mime: 1
+
+This option will permit the SAVI engine to directly scan e-mail messages.
+
+=back
+
+=head1 AUTHOR
+
+John Peacock <[email protected]>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2005 John Peacock
+
+Based heavily on the clamav plugin
+
+This plugin is licensed under the same terms as the qpsmtpd package itself.
+Please see the LICENSE file included with qpsmtpd for details.
+
+=cut
+
Added: tags/0.32rc1/plugins/virus/uvscan
==============================================================================
--- (empty file)
+++ tags/0.32rc1/plugins/virus/uvscan Fri Feb 17 11:02:02 2006
@@ -0,0 +1,133 @@
+#!/usr/bin/perl -w
+=head1 NAME
+
+uvscan
+
+=head1 DESCRIPTION
+
+A qpsmtpd plugin for the McAfee commandline virus scanner, uvscan.
+
+=head1 INSTALL AND CONFIG
+
+Place this plugin in the plugin/virus directory beneath the standard
+qpsmtpd installation. If you installed uvscan with the default path, you
+can use this plugin with default options (nothing specified):
+
+=over 4
+
+=item B<uvscan_location>
+
+Full path to the uvscan binary and all signature files; defaults to
+/usr/local/bin/uvscan.
+
+=item B<deny_viruses>
+
+Whether the scanner will automatically delete messages which have viruses.
+Takes either 'yes' or 'no' (defaults to 'yes').
+
+=back
+
+=head1 AUTHOR
+
+John Peacock <[email protected]>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2004 John Peacock
+
+Based heavily on the clamav plugin
+
+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) = @_;
+
+ while (@args) {
+ $self->{"_uvscan"}->{pop @args}=pop @args;
+ }
+ $self->{"_uvscan"}->{"uvscan_location"}||="/usr/local/bin/uvscan";
+}
+
+sub hook_data_post {
+ my ($self, $transaction) = @_;
+
+ return (DECLINED)
+ if $transaction->body_size > 250_000;
+
+ # Ignore non-multipart emails
+ my $content_type = $transaction->header->get('Content-Type');
+ $content_type =~ s/\s/ /g if defined $content_type;
+ unless ( $content_type
+ && $content_type =~ m!\bmultipart/.*\bboundary="?([^"]+)!i )
+ {
+ $self->log( LOGWARN, "non-multipart mail - skipping" );
+ return DECLINED;
+ }
+
+ my $filename = $transaction->body_filename;
+ return (DECLINED) unless $filename;
+
+ # Now do the actual scanning!
+ my @cmd =($self->{"_uvscan"}->{"uvscan_location"},
+ '--mime', '--unzip', '--secure', '--noboot',
+ $filename, '2>&1 |');
+ $self->log(LOGINFO, "Running: ",join(' ', @cmd));
+ open(FILE, join(' ', @cmd)); #perl 5.6 doesn't properly support the pipe
+ # mode list form of open, but this is basically the same thing. This form
+ # of exec is safe(ish).
+ my $output;
+ while (<FILE>) { $output.=$_; }
+ close FILE;
+
+ my $result = ($? >> 8);
+ my $signal = ($? & 127);
+
+ my $virus;
+ if ($output && $output =~ m/.*\W+Found (.*)\n/m) {
+ $virus=$1;
+ }
+ if ($output && $output =~ m/password-protected/m) {
+ return (DENY, 'We do not accept password-protected zip files!');
+ }
+
+ if ($signal) {
+ $self->log(LOGWARN, "uvscan exited with signal: $signal");
+ return (DECLINED);
+ }
+ if ($result == 2) {
+ $self->log(LOGERROR, "Integrity check for a DAT file failed.");
+ return (DECLINED);
+ } elsif ($result == 6) {
+ $self->log(LOGERROR, "A general problem has occurred.");
+ return (DECLINED);
+ } elsif ($result == 8) {
+ $self->log(LOGERROR, "The program could not find a DAT file.");
+ return (DECLINED);
+ } elsif ($result == 15) {
+ $self->log(LOGERROR, "The program self-check failed");
+ return (DECLINED);
+ } elsif ( $result ) { # all of the possible virus returns
+ if ($result == 12) {
+ $self->log(LOGERROR, "The program tried to clean a file but failed.");
+ } elsif ($result == 13) {
+ $self->log(LOGERROR, "One or more virus(es) found");
+ } elsif ($result == 19) {
+ $self->log(LOGERROR, "Successfully cleaned the file");
+ }
+
+ if (lc($self->{"_uvscan"}->{"deny_viruses"}) eq "yes") {
+ return (DENY, "Virus Found: $virus");
+ }
+ $transaction->header->add('X-Virus-Found', 'Yes');
+ $transaction->header->add('X-Virus-Details', $virus);
+ return (DECLINED);
+ }
+
+ $transaction->header->add('X-Virus-Checked',
+ "Checked by McAfee uvscan on ".$self->qp->config("me"));
+
+ return (DECLINED);
+}
Added: tags/0.32rc1/qpsmtpd
==============================================================================
--- (empty file)
+++ tags/0.32rc1/qpsmtpd Fri Feb 17 11:02:02 2006
@@ -0,0 +1,31 @@
+#!/usr/bin/perl -Tw
+# Copyright (c) 2001 Ask Bjoern Hansen. See the LICENSE file for details.
+# The "command dispatch" system is taken from colobus - http://trainedmonkey.com/colobus/
+#
+# this is designed to be run under tcpserver (http://cr.yp.to/ucspi-tcp.html)
+# or inetd if you're into that sort of thing
+#
+#
+# For more information see http://develooper.com/code/qpsmtpd/
+#
+#
+
+use lib 'lib';
+use Qpsmtpd::TcpServer;
+use strict;
+$| = 1;
+
+delete $ENV{ENV};
+$ENV{PATH} = '/bin:/usr/bin:/var/qmail/bin';
+
+my $qpsmtpd = Qpsmtpd::TcpServer->new();
+$qpsmtpd->load_plugins();
+$qpsmtpd->start_connection();
+$qpsmtpd->run();
+
+__END__
+
+
+
+
+1;
Added: tags/0.32rc1/qpsmtpd-forkserver
==============================================================================
--- (empty file)
+++ tags/0.32rc1/qpsmtpd-forkserver Fri Feb 17 11:02:02 2006
@@ -0,0 +1,316 @@
+#!/usr/bin/perl -Tw
+# Copyright (c) 2001 Ask Bjoern Hansen. See the LICENSE file for details.
+# The "command dispatch" system is taken from colobus - http://trainedmonkey.com/colobus/
+#
+# For more information see http://develooper.com/code/qpsmtpd/
+#
+#
+
+use lib 'lib';
+use Qpsmtpd::TcpServer;
+use Qpsmtpd::Constants;
+use IO::Socket;
+use IO::Select;
+use Socket;
+use Getopt::Long;
+use POSIX qw(:sys_wait_h :errno_h :signal_h);
+use strict;
+$| = 1;
+
+# Configuration
+my $MAXCONN = 15; # max simultaneous connections
+my $PORT = 2525; # port number
+my @LOCALADDR; # ip address(es) to bind to
+my $USER = 'smtpd'; # user to suid to
+my $MAXCONNIP = 5; # max simultaneous connections from one IP
+my $PID_FILE = '';
+my $DETACH; # daemonize on startup
+
+sub usage {
+ print <<"EOT";
+usage: qpsmtpd-forkserver [ options ]
+ -l, --listen-address addr : listen on specific address(es); can be specified
+ multiple times for multiple bindings. Default is
+ 0.0.0.0 (all interfaces).
+ -p, --port P : listen on a specific port; default 2525
+ -c, --limit-connections N : limit concurrent connections to N; default 15
+ -u, --user U : run as a particular user (default 'smtpd')
+ -m, --max-from-ip M : limit connections from a single IP; default 5
+ --pid-file P : print main servers PID to file P
+ -d, --detach : detach from controlling terminal (daemonize)
+EOT
+ exit 0;
+}
+
+GetOptions('h|help' => \&usage,
+ 'l|listen-address=s' => \@LOCALADDR,
+ 'c|limit-connections=i' => \$MAXCONN,
+ 'm|max-from-ip=i' => \$MAXCONNIP,
+ 'p|port=i' => \$PORT,
+ 'u|user=s' => \$USER,
+ 'pid-file=s' => \$PID_FILE,
+ 'd|detach' => \$DETACH,
+ ) || &usage;
+
+# detaint the commandline
+if ($PORT =~ /^(\d+)$/) { $PORT = $1 } else { &usage }
+@LOCALADDR = ( '0.0.0.0' ) if !@LOCALADDR;
+for (0..$#LOCALADDR) {
+ if ($LOCALADDR[$_] =~ /^([\d\w\-.]+)$/) {
+ $LOCALADDR[$_] = $1;
+ } else {
+ &usage;
+ }
+}
+if ($USER =~ /^([\w\-]+)$/) { $USER = $1 } else { &usage }
+if ($MAXCONN =~ /^(\d+)$/) { $MAXCONN = $1 } else { &usage }
+
+delete $ENV{ENV};
+$ENV{PATH} = '/bin:/usr/bin:/var/qmail/bin';
+
+my %childstatus = ();
+
+sub REAPER {
+ while ( defined(my $chld = waitpid(-1, WNOHANG)) ){
+ last unless $chld > 0;
+ ::log(LOGINFO,"cleaning up after $chld");
+ delete $childstatus{$chld};
+ }
+}
+
+sub HUNTSMAN {
+ $SIG{CHLD} = 'DEFAULT';
+ kill 'INT' => keys %childstatus;
+ if ($PID_FILE && -e $PID_FILE) {
+ unlink $PID_FILE or ::log(LOGERROR, "unlink: $PID_FILE: $!");
+ }
+ exit(0);
+}
+
+$SIG{INT} = \&HUNTSMAN;
+$SIG{TERM} = \&HUNTSMAN;
+
+my $select = new IO::Select;
+
+# establish SERVER socket(s), bind and listen.
+for my $listen_addr (@LOCALADDR) {
+ my $server = IO::Socket::INET->new(LocalPort => $PORT,
+ LocalAddr => $listen_addr,
+ Proto => 'tcp',
+ Reuse => 1,
+ Blocking => 0,
+ Listen => SOMAXCONN )
+ or die "Creating TCP socket $listen_addr:$PORT: $!\n";
+ IO::Handle::blocking($server, 0);
+ $select->add($server);
+}
+
+if ($PID_FILE) {
+ if ($PID_FILE =~ m#^(/[\w\d/\-.]+)$#) { $PID_FILE = $1 } else { &usage }
+ if (-e $PID_FILE) {
+ open PID, "+<$PID_FILE"
+ or die "open pid_file: $!\n";
+ my $running_pid = <PID> || ''; chomp $running_pid;
+ if ($running_pid =~ /(\d+)/) {
+ $running_pid = $1;
+ if (kill 0, $running_pid) {
+ die "Found an already running qpsmtpd with pid $running_pid.\n";
+ }
+ }
+ seek PID, 0, 0
+ or die "Could not seek back to beginning of $PID_FILE: $!\n";
+ truncate PID, 0
+ or die "Could not truncate $PID_FILE at 0: $!";
+ } else {
+ open PID, ">$PID_FILE"
+ or die "open pid_file: $!\n";
+ }
+}
+
+# Load plugins here
+my $qpsmtpd = Qpsmtpd::TcpServer->new();
+
+# Drop privileges
+my (undef, undef, $quid, $qgid) = getpwnam $USER or
+ die "unable to determine uid/gid for $USER\n";
+my $groups = "$qgid $qgid";
+while (my ($name,$passwd,$gid,$members) = getgrent()) {
+ my @m = split(/ /, $members);
+ if (grep {$_ eq $USER} @m) {
+ $groups .= " $gid";
+ }
+}
+$) = $groups;
+POSIX::setgid($qgid) or
+ die "unable to change gid: $!\n";
+POSIX::setuid($quid) or
+ die "unable to change uid: $!\n";
+$> = $quid;
+
+$qpsmtpd->load_plugins;
+
+::log(LOGINFO,"Listening on port $PORT");
+::log(LOGINFO, 'Running as user '.
+ (getpwuid($>) || $>) .
+ ', group '.
+ (getgrgid($)) || $)));
+
+if ($DETACH) {
+ open STDIN, '/dev/null' or die "/dev/null: $!";
+ open STDOUT, '>/dev/null' or die "/dev/null: $!";
+ open STDERR, '>&STDOUT' or die "open(stderr): $!";
+ defined (my $pid = fork) or die "fork: $!";
+ exit 0 if $pid;
+ POSIX::setsid or die "setsid: $!";
+}
+
+if ($PID_FILE) {
+ print PID $$,"\n";
+ close PID;
+}
+
+# Populate class cached variables
+$qpsmtpd->spool_dir;
+$qpsmtpd->size_threshold;
+
+while (1) {
+ REAPER();
+ my $running = scalar keys %childstatus;
+ if ($running >= $MAXCONN) {
+ ::log(LOGINFO,"Too many connections: $running >= $MAXCONN. Waiting one second.");
+ sleep(1);
+ next;
+ }
+ my @ready = $select->can_read(1);
+ next if !@ready;
+ while (my $server = shift @ready) {
+ my ($client, $hisaddr) = $server->accept;
+
+ if (!$hisaddr) {
+ # possible something condition...
+ next;
+ }
+ IO::Handle::blocking($client, 1);
+ my ($port, $iaddr) = sockaddr_in($hisaddr);
+ my $localsockaddr = getsockname($client);
+ my ($lport, $laddr) = sockaddr_in($localsockaddr);
+
+ my ($rc, @msg) = $qpsmtpd->run_hooks("pre-connection",
+ remote_ip => inet_ntoa($iaddr),
+ remote_port => $port,
+ local_ip => inet_ntoa($laddr),
+ local_port => $lport,
+ max_conn_ip => $MAXCONNIP,
+ child_addrs => [values %childstatus],
+ );
+ if ($rc == DENYSOFT || $rc == DENYSOFT_DISCONNECT) {
+ unless ($msg[0]) {
+ @msg = ("Sorry, try again later");
+ }
+ &respond_client($client, 451, @msg);
+ close $client;
+ next;
+ }
+ elsif ($rc == DENY || $rc == DENY_DISCONNECT) {
+ unless ($msg[0]) {
+ @msg = ("Sorry, service not available for you");
+ }
+ &respond_client($client, 550, @msg);
+ close $client;
+ next;
+ }
+
+ my $pid = safe_fork();
+ if ($pid) {
+ # parent
+ $childstatus{$pid} = $iaddr; # add to table
+ # $childstatus{$pid} = 1; # add to table
+ $running++;
+ close($client);
+ next;
+ }
+ # otherwise child
+
+ # all children should have different seeds, to prevent conflicts
+ srand( time ^ ($$ + ($$ << 15)) );
+
+ close($server);
+
+ $SIG{$_} = 'DEFAULT' for keys %SIG;
+ $SIG{ALRM} = sub {
+ print $client "421 Connection Timed Out\n";
+ ::log(LOGINFO, "Connection Timed Out");
+ exit; };
+
+ $ENV{TCPLOCALIP} = inet_ntoa($laddr);
+ # my ($port, $iaddr) = sockaddr_in($hisaddr);
+ $ENV{TCPREMOTEIP} = inet_ntoa($iaddr);
+ $ENV{TCPREMOTEHOST} = gethostbyaddr($iaddr, AF_INET) || "Unknown";
+
+ # don't do this!
+ #$0 = "qpsmtpd-forkserver: $ENV{TCPREMOTEIP} / $ENV{TCPREMOTEHOST}";
+
+ ::log(LOGINFO, "Accepted connection $running/$MAXCONN from $ENV{TCPREMOTEIP} / $ENV{TCPREMOTEHOST}");
+
+ # dup to STDIN/STDOUT
+ POSIX::dup2(fileno($client), 0);
+ POSIX::dup2(fileno($client), 1);
+
+ $qpsmtpd->start_connection
+ (
+ local_ip => $ENV{TCPLOCALIP},
+ local_port => $lport,
+ remote_ip => $ENV{TCPREMOTEIP},
+ remote_port => $port,
+ );
+ $qpsmtpd->run();
+
+ $qpsmtpd->run_hooks("post-connection");
+ exit; # child leaves
+ }
+}
+
+sub log {
+ my ($level,$message) = @_;
+ $qpsmtpd->log($level,$message);
+}
+
+sub respond_client {
+ my ($client, $code, @message) = @_;
+ $client->autoflush(1);
+ while (my $msg = shift @message) {
+ my $line = $code . (@message?"-":" ").$msg;
+ ::log(LOGDEBUG, $line);
+ print $client "$line\r\n"
+ or (::log(LOGERROR, "Could not print [$line]: $!"), return 0);
+ }
+ return 1;
+}
+
+### routine to protect process during fork
+sub safe_fork {
+
+ ### block signal for fork
+ my $sigset = POSIX::SigSet->new(SIGINT);
+ POSIX::sigprocmask(SIG_BLOCK, $sigset)
+ or die "Can't block SIGINT for fork: [$!]\n";
+
+ ### fork off a child
+ my $pid = fork;
+ unless( defined $pid ){
+ die "Couldn't fork: [$!]\n";
+ }
+
+ ### make SIGINT kill us as it did before
+ $SIG{INT} = 'DEFAULT';
+
+ ### put back to normal
+ POSIX::sigprocmask(SIG_UNBLOCK, $sigset)
+ or die "Can't unblock SIGINT for fork: [$!]\n";
+
+ return $pid;
+}
+
+__END__
+
+1;
Added: tags/0.32rc1/qpsmtpd-server
==============================================================================
--- (empty file)
+++ tags/0.32rc1/qpsmtpd-server Fri Feb 17 11:02:02 2006
@@ -0,0 +1,28 @@
+#!/usr/bin/perl -Tw
+# Copyright (c) 2001 Ask Bjoern Hansen. See the LICENSE file for details.
+# The "command dispatch" system is taken from colobus - http://trainedmonkey.com/colobus/
+#
+# this is designed to be run under tcpserver (http://cr.yp.to/ucspi-tcp.html)
+# or inetd if you're into that sort of thing
+#
+#
+# For more information see http://develooper.com/code/qpsmtpd/
+#
+#
+
+use lib 'lib';
+use Qpsmtpd::SelectServer;
+use strict;
+$| = 1;
+
+delete $ENV{ENV};
+$ENV{PATH} = '/bin:/usr/bin:/var/qmail/bin';
+
+Qpsmtpd::SelectServer->main();
+
+__END__
+
+
+
+
+1;
Added: tags/0.32rc1/run
==============================================================================
--- (empty file)
+++ tags/0.32rc1/run Fri Feb 17 11:02:02 2006
@@ -0,0 +1,8 @@
+#!/bin/sh
+QMAILDUID=`id -u smtpd`
+NOFILESGID=`id -g smtpd`
+exec /usr/local/bin/softlimit -m 25000000 \
+ /usr/local/bin/tcpserver -c 10 -v -R -p \
+ -u $QMAILDUID -g $NOFILESGID `head -1 config/IP` smtp \
+ ./qpsmtpd 2>&1
+
Added: tags/0.32rc1/t/Test/Qpsmtpd.pm
==============================================================================
--- (empty file)
+++ tags/0.32rc1/t/Test/Qpsmtpd.pm Fri Feb 17 11:02:02 2006
@@ -0,0 +1,115 @@
+package Test::Qpsmtpd;
+use strict;
+use Carp qw(croak);
+use base qw(Qpsmtpd::SMTP);
+use Test::More;
+use Qpsmtpd::Constants;
+use Test::Qpsmtpd::Plugin;
+
+sub new_conn {
+ ok(my $smtpd = __PACKAGE__->new(), "new");
+ ok(my $conn = $smtpd->start_connection(remote_host => 'localhost',
+ remote_ip => '127.0.0.1'), "start_connection");
+ is(($smtpd->response)[0], "220", "greetings");
+ ($smtpd, $conn);
+}
+
+sub start_connection {
+ my $self = shift;
+ my %args = @_;
+
+ my $remote_host = $args{remote_host} or croak "no remote_host parameter";
+ my $remote_info = "test\@$remote_host";
+ my $remote_ip = $args{remote_ip} or croak "no remote_ip parameter";
+
+ my $conn = $self->SUPER::connection->start(remote_info => $remote_info,
+ remote_ip => $remote_ip,
+ remote_host => $remote_host,
+ @_);
+
+
+ $self->load_plugins;
+
+ my $rc = $self->start_conversation;
+ return if $rc != DONE;
+
+ $conn;
+}
+
+sub respond {
+ my $self = shift;
+ $self->{_response} = [@_];
+}
+
+sub response {
+ my $self = shift;
+ $self->{_response} ? (@{ delete $self->{_response} }) : ();
+}
+
+sub command {
+ my ($self, $command) = @_;
+ $self->input($command);
+ $self->response;
+}
+
+sub input {
+ my $self = shift;
+ my $command = shift;
+
+ my $timeout = $self->config('timeout');
+ alarm $timeout;
+
+ $command =~ s/\r?\n$//s; # advanced chomp
+ $self->log(LOGDEBUG, "dispatching $command");
+ defined $self->dispatch(split / +/, $command, 2)
+ or $self->respond(502, "command unrecognized: '$command'");
+ alarm $timeout;
+}
+
+sub config_dir {
+ './config.sample';
+}
+
+sub plugin_dir {
+ './plugins';
+}
+
+sub log {
+ my ($self, $trace, @log) = @_;
+ my $level = Qpsmtpd::TRACE_LEVEL();
+ $level = $self->init_logger unless defined $level;
+ print("# " . join(" ", $$, @log) . "\n") if $trace <= $level;
+}
+
+sub varlog {
+ shift->log(@_);
+}
+
+# sub run
+# sub disconnect
+
+sub run_plugin_tests {
+ my $self = shift;
+ $self->{_test_mode} = 1;
+ my @plugins = $self->load_plugins();
+ # First count test number
+ my $num_tests = 0;
+ foreach my $plugin (@plugins) {
+ $plugin->register_tests();
+ $num_tests += $plugin->total_tests();
+ }
+
+ require Test::Builder;
+ my $Test = Test::Builder->new();
+
+ $Test->plan( tests => $num_tests );
+
+ # Now run them
+
+ foreach my $plugin (@plugins) {
+ $plugin->run_tests($self);
+ }
+}
+
+1;
+
Added: tags/0.32rc1/t/Test/Qpsmtpd/Plugin.pm
==============================================================================
--- (empty file)
+++ tags/0.32rc1/t/Test/Qpsmtpd/Plugin.pm Fri Feb 17 11:02:02 2006
@@ -0,0 +1,42 @@
+# $Id$
+
+package Test::Qpsmtpd::Plugin;
+1;
+
+# Additional plugin methods used during testing
+package Qpsmtpd::Plugin;
+
+use Test::More;
+use strict;
+
+sub register_tests {
+ # Virtual base method - implement in plugin
+}
+
+sub register_test {
+ my ($plugin, $test, $num_tests) = @_;
+ $num_tests = 1 unless defined($num_tests);
+ # print STDERR "Registering test $test ($num_tests)\n";
+ push @{$plugin->{_tests}}, { name => $test, num => $num_tests };
+}
+
+sub total_tests {
+ my ($plugin) = @_;
+ my $total = 0;
+ foreach my $t (@{$plugin->{_tests}}) {
+ $total += $t->{num};
+ }
+ return $total;
+}
+
+sub run_tests {
+ my ($plugin, $qp) = @_;
+ foreach my $t (@{$plugin->{_tests}}) {
+ my $method = $t->{name};
+ print "# Running $method tests for plugin " . $plugin->plugin_name . "\n";
+ local $plugin->{_qp} = $qp;
+ $plugin->$method();
+ }
+}
+
+1;
Added: tags/0.32rc1/t/addresses.t
==============================================================================
--- (empty file)
+++ tags/0.32rc1/t/addresses.t Fri Feb 17 11:02:02 2006
@@ -0,0 +1,30 @@
+use Test::More qw(no_plan);
+use strict;
+use lib 't';
+use_ok('Test::Qpsmtpd');
+
+ok(my ($smtpd, $conn) = Test::Qpsmtpd->new_conn(), "get new connection");
+is(($smtpd->command('EHLO localhost'))[0], 250, 'EHLO localhost');
+
+is(($smtpd->command('MAIL FROM:<[email protected]>'))[0], 250, 'MAIL FROM:<[email protected]>');
+is($smtpd->transaction->sender->address, '[email protected]', 'got the right sender');
+
+is(($smtpd->command('MAIL FROM:<ask @perl.org>'))[0], 250, 'MAIL FROM:<ask @perl.org>');
+is($smtpd->transaction->sender->address, 'ask @perl.org', 'got the right sender');
+
+is(($smtpd->command('MAIL FROM:[email protected]'))[0], 250, 'MAIL FROM:[email protected]');
+is($smtpd->transaction->sender->format, '<[email protected]>', 'got the right sender');
+
+my $command = 'MAIL FROM:<[email protected]> SIZE=1230';
+is(($smtpd->command($command))[0], 250, $command);
+is($smtpd->transaction->sender->format, '<[email protected]>', 'got the right sender');
+
+$command = 'MAIL FROM:<>';
+is(($smtpd->command($command))[0], 250, $command);
+is($smtpd->transaction->sender->format, '<>', 'got the right sender');
+
+$command = 'MAIL FROM:<[email protected]> SIZE=1230';
+is(($smtpd->command($command))[0], 250, $command);
+is($smtpd->transaction->sender->format, '<[email protected]>', 'got the right sender');
+
+
Added: tags/0.32rc1/t/helo.t
==============================================================================
--- (empty file)
+++ tags/0.32rc1/t/helo.t Fri Feb 17 11:02:02 2006
@@ -0,0 +1,12 @@
+use Test::More qw(no_plan);
+use strict;
+use lib 't';
+use_ok('Test::Qpsmtpd');
+
+ok(my ($smtpd, $conn) = Test::Qpsmtpd->new_conn(), "get new connection");
+is(($smtpd->command('HELO localhost'))[0], 250, 'HELO localhost');
+is(($smtpd->command('EHLO localhost'))[0], 503, 'EHLO localhost (duplicate!)');
+
+ok(($smtpd, $conn) = Test::Qpsmtpd->new_conn(), "get new connection");
+is(($smtpd->command('EHLO localhost'))[0], 250, 'EHLO localhost');
+
Added: tags/0.32rc1/t/plugin_tests.t
==============================================================================
--- (empty file)
+++ tags/0.32rc1/t/plugin_tests.t Fri Feb 17 11:02:02 2006
@@ -0,0 +1,9 @@
+#!/usr/bin/perl -w
+use strict;
+use lib 't';
+use Test::Qpsmtpd;
+
+my $qp = Test::Qpsmtpd->new();
+
+$qp->run_plugin_tests();
+
Added: tags/0.32rc1/t/plugin_tests/check_badrcptto
==============================================================================
--- (empty file)
+++ tags/0.32rc1/t/plugin_tests/check_badrcptto Fri Feb 17 11:02:02 2006
@@ -0,0 +1,9 @@
+
+sub register_tests {
+ my $self = shift;
+ $self->register_test("foo", 1);
+}
+
+sub foo {
+ ok(1);
+}
Added: tags/0.32rc1/t/plugin_tests/dnsbl
==============================================================================
--- (empty file)
+++ tags/0.32rc1/t/plugin_tests/dnsbl Fri Feb 17 11:02:02 2006
@@ -0,0 +1,27 @@
+
+sub register_tests {
+ my $self = shift;
+ $self->register_test("test_local", 1);
+ $self->register_test("test_returnval", 1);
+}
+
+sub test_local {
+ my $self = shift;
+
+ my $connection = $self->qp->connection;
+ $connection->remote_ip('127.0.0.2'); # standard dnsbl test value
+
+ $self->hook_connect($self->qp->transaction);
+
+ ok($self->qp->connection->notes('dnsbl_sockets'));
+}
+
+sub test_returnval {
+ my $self = shift;
+
+ my $address = Qpsmtpd::Address->parse('<[email protected]>');
+ my ($ret, $note) = $self->hook_rcpt($self->qp->transaction,
+ $address);
+ is($ret, DENY, "Check we got a DENY");
+ print("# dnsbl result: $note\n");
+}
Added: tags/0.32rc1/t/qpsmtpd-address.t
==============================================================================
--- (empty file)
+++ tags/0.32rc1/t/qpsmtpd-address.t Fri Feb 17 11:02:02 2006
@@ -0,0 +1,103 @@
+#!/usr/bin/perl
+use strict;
+$^W = 1;
+
+use Test::More tests => 29;
+
+BEGIN {
+ use_ok('Qpsmtpd::Address');
+}
+
+my $as;
+my $ao;
+
+$as = '<>';
+$ao = Qpsmtpd::Address->parse($as);
+ok ($ao, "parse $as");
+is ($ao->format, $as, "format $as");
+
+$as = '<postmaster>';
+$ao = Qpsmtpd::Address->parse($as);
+ok ($ao, "parse $as");
+is ($ao->format, $as, "format $as");
+
+$as = '<[email protected]>';
+$ao = Qpsmtpd::Address->parse($as);
+ok ($ao, "parse $as");
+is ($ao->format, $as, "format $as");
+
+is ($ao->user, 'foo', 'user');
+is ($ao->host, 'example.com', 'host');
+
+# the \ before the @ in the local part is not required, but
+# allowed. For simplicity we add a backslash before all characters
+# which are not allowed in a dot-string.
+$as = '<"[email protected]"@wifo.ac.at>';
+$ao = Qpsmtpd::Address->parse($as);
+ok ($ao, "parse $as");
+is ($ao->format, '<"musa_ibrah\@caramail.comandrea.luger"@wifo.ac.at>', "format $as");
+
+# email addresses with spaces
+$as = '<foo [email protected]>';
+$ao = Qpsmtpd::Address->parse($as);
+ok ($ao, "parse $as");
+is ($ao->format, '<"foo\ bar"@example.com>', "format $as");
+
+$as = '[email protected]';
+$ao = Qpsmtpd::Address->new($as);
+ok ($ao, "new $as");
+is ($ao->address, $as, "address $as");
+
+$as = '<[email protected]>';
+$ao = Qpsmtpd::Address->new($as);
+ok ($ao, "new $as");
+is ($ao->address, '[email protected]', "address $as");
+
+$as = '<[email protected]>';
+$ao = Qpsmtpd::Address->new($as);
+ok ($ao, "new $as");
+is ($ao->format, $as, "format $as");
+
+$as = '[email protected]';
+ok ($ao = Qpsmtpd::Address->parse('<'.$as.'>'), "parse $as");
+is ($ao && $ao->address, $as, "address $as");
+
+# Not sure why we can change the address like this, but we can so test it ...
+is ($ao && $ao->address('[email protected]'), '[email protected]', 'address([email protected])');
+
+$as = '<[email protected]>';
+$ao = Qpsmtpd::Address->new($as);
+ok ($ao, "new $as");
+is ($ao->format, $as, "format $as");
+is ("$ao", $as, "overloaded stringify $as");
+
+$as = '[email protected]';
+ok ($ao = Qpsmtpd::Address->parse("<$as>"), "parse <$as>");
+is ($ao && $ao->address, $as, "address $as");
+ok ($ao eq $as, "overloaded 'cmp' operator");
+
+my @unsorted_list = map { Qpsmtpd::Address->new($_) }
+ qw(
+ "[email protected]"@wifo.ac.at
+ [email protected]
+ [email protected]
+ [email protected]
+ [email protected]
+ [email protected]
+ );
+
+# NOTE that this is sorted by _host_ not by _domain_
+my @sorted_list = map { Qpsmtpd::Address->new($_) }
+ qw(
+ [email protected]
+ [email protected]
+ [email protected]
+ [email protected]
+ [email protected]
+ "[email protected]"@wifo.ac.at
+ );
+
+my @test_list = sort @unsorted_list;
+
+is_deeply( \@test_list, \@sorted_list, "sort via overloaded 'cmp' operator");
+
Added: tags/0.32rc1/t/tempstuff.t
==============================================================================
--- (empty file)
+++ tags/0.32rc1/t/tempstuff.t Fri Feb 17 11:02:02 2006
@@ -0,0 +1,27 @@
+#!/usr/bin/perl -w
+use Test::More qw(no_plan);
+use File::Path;
+use strict;
+use lib 't';
+use_ok('Test::Qpsmtpd');
+
+BEGIN { # need this to happen before anything else
+ my $cwd = `pwd`;
+ chomp($cwd);
+ open my $spooldir, '>', "./config.sample/spool_dir";
+ print $spooldir "$cwd/t/tmp";
+ close $spooldir;
+}
+
+ok(my ($smtpd, $conn) = Test::Qpsmtpd->new_conn(), "get new connection");
+
+my ($spool_dir,$tempfile,$tempdir) = ( $smtpd->spool_dir,
+$smtpd->temp_file(), $smtpd->temp_dir() );
+
+ok( $spool_dir =~ m!t/tmp/$!, "Located the spool directory");
+ok( $tempfile =~ /^$spool_dir/, "Temporary filename" );
+ok( $tempdir =~ /^$spool_dir/, "Temporary directory" );
+ok( -d $tempdir, "And that directory exists" );
+
+unlink "./config.sample/spool_dir";
+rmtree($spool_dir);