qpsmtpd-0.84/000755 000765 000024 00000000000 11357265152 013065 5ustar00askstaff000000 000000 qpsmtpd-0.84/.gitignore000644 000765 000024 00000000401 11335434375 015051 0ustar00askstaff000000 000000 /config /config/ /pm_to_blib /blib/ # only ignore top-level Makefile; we need the one in packaging/rpm! /Makefile Makefile.[a-z]* # ignore file produced by rpm build process /packaging/rpm/qpsmtpd.spec packaging/rpm/build/ *~ *.bak /cover_db/ *.tar.gz qpsmtpd-0.84/Changes000644 000765 000024 00000075714 11357265141 014374 0ustar00askstaff000000 000000 0.84 April 7, 2010 uribl: fix scan-headers option (Jost Krieger, Robert Spier) exim: Use BSMTP response codes, various cleanups (Devin Carraway) config: cache returned values from config plugins (Peter J. Holzer) AUTH PLAIN bug with Alpine (Rick Richard) require_resolvable_fromhost: Moved DENYSOFT for temp_resolver_failed to the RCPT TO hook. (Larry Nedry) Note Net::IP dependency (Larry Nedry) Various minor spelling cleanups and such (Steve Kemp, Devin Carraway) rpm: create .rpm files from the packaging/rpm directory (Peter J. Holzer, Robin Bowes, Filippo Carletti, Richard Siddell) spamassasin: Custom spam tag subject munging (Jonathan Martens, Robert Spier) clamav: Fix typo in name of default configuration file (Filippo Carletti) 0.83 September 15, 2009 plugins/queue/maildir: Allow hyphens in the maildir path (Hinrik Örn Sigurðsson) Modify plugins/virus/clamav no-summary option for ClamAV 0.95 (Jonathan Martens) Temporary deny if clamd is not running (Shad L. Lords) Fix spamassassin plugin log noise if spam score is 0.0 Fix spool_dir configuration documentation and README update (Tomas Lee) Disconnect host in rhsbl (Charlie Brady) POD cleanups (Steve Kemp) check_badmailfrom: Fix parsing of reason messages etc (Robert Spier, Tomas Lee) check_spamhelo disconnects after denying a 'helo' (Filippo Carletti) Log even when aren't in a transaction (Jared Johnson) prefork: More robust child spawning (Peter Samuelson) Add dup_body_fh method to return a dup'd body FH (Jared Johnson) 0.82 - June 2, 2009 prefork: Fix problem with processes sometimes being "left behind" (Charlie Brady) prefork: Fix startup when no interface addresses are specified (Devin Carraway) prefork: add multi-address support The clamdscan virus-scanning plugin now requires the ClamAV::Client perl module instead of the older, deprecated Clamd module (Devin Carraway) prefork: support --listen-address for consistency with forkserver prefork: Sanitize the shell environment before loading modules 0.81 - April 2, 2009 Close spamd socket after reading the result back (Jared Johnson) p0f plugin updates (Tom Callahan) Change transaction->add_recipient to skip adding "null" rcpt if passed Add logging/apache plugin for logging to the apache error log Add connection_time plugin Add git information to version number when running from a git clone Add rcpt_regexp plugin (Hanno Hecker) Add notes method to Qpsmtpd::Address objects (Jared Johnson) Add remove_recipient method to the transaction object (Jared Johnson) 0.80 - February 27, 2009 moved development to git repository! reorganized plugin author documentation added End of headers hook: data_headers_end added "random error plugin" improve logging of plugins generating fatal errors (Steve Kemp) async: added $connection->local_ip, $connection->local_port async: Fix bug where the body_file/body_filename wouldn't have headers lower log level of rcpt/from addresses prefork: improve shutdown of parent (and children) on very busy systems (Diego d'Ambra) prefork: exit codes cleanup (based on patch by Diego d'Ambra) prefork: detect and reset locked shared memory (based on patch by Diego d'Ambra) prefork: untaint the value of the --interface option (reported by Diego d'Ambra) prefork: the children pool size was sometimes not adjusted immediately after the exit of children (reported by Diego d'Ambra) async, prefork: detach and daemonize only after reading the configuration and loading the plugins, to give the init scripts a chance to detect failed startups due to broken configuration or plugins (Diego d'Ambra) plugins/tls: close the file descriptor for the SSL socket plugins/queue/maildir: multi user / multi domain support added set the Return-Path header when queuing into maildir mailboxes plugins/require_resolvable_fromhost: check all MX hosts, not just the first remove outdated virus/check_for_hi_virus plugin prefork, forkserver: restart on SIGHUP (reload all modules, with register() or init() phase). prefork: add --detach option to daemonize like forkserver use user/group switching from forkserver to support secondary groups (needed with plugins/queue/postfix-queue) --pid-file now works apache: add post-connection hook, connection->reset Create async version of dns_whitelist_soft, rhsbl and uribl plugins. async: added pre- and post-connection hooks improve handling of inetd/xinetd connections (Hanno Hecker) Qpsmtpd::Connection->notes are now reset on end of connection (currently not in Apache). The workaround plugins/tls for -prefork is no longer needed now. keep the square brackets around the IP as "remote_host" if the reverse lookup failed (Hanno Hecker) async: Dereference the DATA deny message before sending it to the client Change async/require_resolvable_fromhost to match the logic of the non-async version and other MTAs async: Handle End-of-data marker split across packets Allow plugins to use the post-fork hook Add qpsmtpd-prefork to the install targets (Robin Bowes) Address definitions are now package vars and can be overriden for sites that wish to change the definition of an email address. (Jared Johnson) http://groups.google.com/group/perl.qpsmtpd/browse_thread/thread/35e3a187d8e75cbe New config option "spool_perms" to set permissions of spool_dir (Jared Johnson) leading/trailing whitespace in config files is ignored (Henry Baragar) 0.43 - February 5, 2008 - Never offically released; oops. (This release was mostly done by Matt Sergeant and Hanno Hecker) Allow qpsmtpd-async to detatch (Chris Lewis). plugins/tls: work-around for failed connections in -prefork after STARTTLS connection (Stefan Priebe, Hanno Hecker) Make the cleanup socket location parameter in the postfix plugin work (ulr...@topfen.net) Implement config caching properly (for async). Hook/plugin caching Remove the connection / transaction id feature (never released) Option to clamdscan to scan all messages, even if there are no attachments add new clamd_user parameter that sets the user we pass to clamd async: Support for HUPing the server to clear the cache. Wake-one child support. async: Don't listen for readiness in the parent any more - breaks under high load. Made user() and host() setters as well as getters in Qpsmtpd::Address. Suggested by mpelzer@gmail.com. Pluggable "help", based on patch by Jose Luis Martinez. Updated plugin documentation. 0.42 - October 1, 2007 - Never released Pluggable hook "noop" Pluggable hook "help" (based on patch by Jose Luis Martinez) async: better config caching (of flat files, not results from hook_config or .cdb files), send SIGHUP to clear cache New docs/plugins.pod documentation! Add X-Spam-Level header in spamassassin plugin (idea from Werner Fleck) prefork: support two or more parallel running instances (on different ports; the first 4 digits of the port number must be different for each instance - see IPC::Sharable). prefork: Fix sporadic bug showing itself after millions of connections (S. Priebe) Remove the auth/authnull sample plugin (there are plenty proper examples now so we don't have to include this insecure plugin) POD syntax cleanup (Steve Kemp) Fix Qpsmtpd::Plugins::isa_plugin() with multiple plugin dirs (Gavin Carr) Fix false positives in check_for_hi_virus plugin (Jerry D. Hedden) Make connection->local_ip available from the Apache transport (Peter Eisch) Support checking for early talkers at DATA Make the documented DENY{,SOFT}_DISCONNECT work in the data-post hook Allow buffered writes in Postfix plugin (from Joe Schaefer) Cleanup spamassassin plugin code a little Fix bug which breaks queue plugins that implement continuations Fix false positives in check_for_hi_virus plugin (Jerry D. Hedden) Unrecognized command fix (issue #16) Updated documentation (Apache 2.2, more) Add uribl plugin (Devin Carraway) 0.40 - June 11, 2007 Add async server - uses epoll/kqueue/poll where available. (Matt Sergeant) Add preforking qpsmtp server (Lars Roland) Support SMTPS (John Peacock) Support "module" plugins ("My::Plugin" in the config/plugins file) Added IPv6 support. (Mike Williams) Added tests for the rcpt_ok plugin (Guy Hulbert, issue #4) Fix logging when dropping a mail due to size (m. allan noah / kitno455, issue #13) Don't drop privileges in forkserver if we don't have to. greylisting: fix db_dir configuration option so it actually works (kitno455, issue #6) Correct header parsing of "space only" lines (Joerg Meyer, issue #11) Update the sample configuration to use zen.spamhaus.org Make the badmailfrom plugin support (optional) rejection messages after the rejection pattern (Robin Hugh Johnson) The ill-named $transaction->body_size() is depreceated now, use $transaction->data_size() instead. Check your logs for LOGWARN messages about "body_size" and fix your plugins. (Hanno Hecker) Support pluggable Received headers (Matt Sergeant) RFC3848 support for ESMTP. (Nick Leverton) Updated the list of DNSBLs in the default config Instead of failing with cryptic message, ignore lines in config/plugins for uninstalled plugins. (John Peacock) Clean up some of the logging (hjp) Patch to prefork code to make it run (Leonardo Helman). Add --pretty option to qpsmtpd-prefork to change $0 for child processes (John Peacock). Add support for multiple plugin directories, whose paths are given by the 'plugin_dirs' configuration. (Devin Carraway, Nick Leverton) Greylisting DBs may now be stored in a configured location, and are looked for by default in /var/lib/qpsmtpd/greylisting in addition to the previous locations relative to the qpsmtpd binary. (Devin Carraway) New Qpsmtpd::Postfix::Constants to encapsulate all of the current return codes from Postfix, plus script to generate it. (Hanno Hecker) Add ability to specific socket for syslog (Peter Eisch) Do the right thing for unimplemented AUTH mechanisms (Brian Szymanski) relay_only plugin for smart relay host. (John Peacock) Enhance the spamassassin plugin to support connecting to a remote spamd process (Kjetil Kjernsmo). Add domainkeys plugin (John Peacock) Add SSL encryption method to header to mirror other qmail/SSL patches. Add tls_before_auth to suppress AUTH unless TLS has already been established (Robin Johnson). Fix "help" command when there's no "smtpgreeting" configured (the default) (Thanks to Thomas Ogrisegg) Move the Qpsmtpd::Auth POD to a top-level README to be more obvious. Add Qpsmtpd::Command to gather all parsing logic in one place (Hanno Hecker) Support multiline responses from plugins (Charlie Brady) Added queue_pre and queue_post hooks (John Peacock) Implement multiple host/port listening for qpsmtpd-forkserver (Devin Carraway) Fix a spurious newline at the start of messages queued via exim (Devin Carraway) Make the clamdscan plugin temporarily deny mail if if can't talk to clamd (Filippo Carletti) Improve Qpsmtpd::Transaction documentation (Fred Moyer) 0.32 - 2006/02/26 Add logging/file plugin for simple logging to a file (Devin Carraway and Peter J. Holzer). Add logging/syslog plugin for logging via the syslog facility (Devin Carrway) Add Qpsmtpd::DSN to return extended SMTP status codes from RFC-1893 and patch existing plugins to use it when appropriate (Hanno Hecker). Add plugins/tls_cert to generate appropriately shaped self-signed certs for TLS support. Add explicit use of CA used to sign cert. Abstract clone()ing of connection information when switching to TLS. Fix the AUTH code to work correctly with TLS. Add hosts_allow plugin to support pre- and post-connection hooks as well as move --max-from-ip tests out of core (Hanno Hecker). Improve postfix-queue plugin to support the known processing flags (Hanno Hecker). Drop root privileges before loading plugins, rather than after. A few fixes to the clamdscan plugin (Dave Rolsky) Various minor fixes and improvements 0.31.1 - 2005/11/18 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 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ø, ) 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 ) 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, philip@gladstonefamily.net): * 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 ) 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 ) 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 . 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 : 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 and 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 . Fix dnsbl plugin to give us all the results. (Patch from Matt Sergeant ) Disable identd lookups by passing -R to tcpserver. (Thanks to Matt) add plugin hooks for HELO and EHLO (Devin Carraway ) check_spamhelo plugin to deny mail from claimed senders from the list specified in F. (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 ) clamav plugin, thanks to Matt Sergeant, matt@sergeant.org. 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 . 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 ). 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 ) 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 ) 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 ) 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 and Zukka Zitting ) If the connection fails while in DATA we would just accept the message. Ouch! Thanks to Devin Carraway 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 ) support and enable taint checking (thanks to Devin Carraway ) Make the MAIL FROM host dns check configurable. (thanks to Devin Carraway). Add more documentation to the README file. qpsmtpd-0.84/config.sample/000755 000765 000024 00000000000 11357265152 015612 5ustar00askstaff000000 000000 qpsmtpd-0.84/CREDITS000644 000765 000024 00000002722 11165321461 014101 0ustar00askstaff000000 000000 Jim Winstead : the core "command dispatch" system in qpsmtpd is taken from his colobus nntp server. The check_badmailfrom and check_mailrcptto plugins. John Peacock : More changes, fixes and vast improvements for me to ever catch up on here. Matt Sergeant : 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 : 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 : fixing the maximum message size (databytes) stuff. Marius Kjeldahl , Zukka Zitting : Patches for supporting $ENV{RELAYCLIENT} Robert Spier : Klez filter. Rasjid Wilcox : Lots of patches as per the Changes file. Kee Hinckley : Sent me the correct strftime format for the dates in the "Received" headers. Gergely Risko : 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! qpsmtpd-0.84/docs/000755 000765 000024 00000000000 11357265152 014015 5ustar00askstaff000000 000000 qpsmtpd-0.84/lib/000755 000765 000024 00000000000 11357265152 013633 5ustar00askstaff000000 000000 qpsmtpd-0.84/LICENSE000644 000765 000024 00000002072 11357264701 014072 0ustar00askstaff000000 000000 Copyright (C) 2001-2010 Ask Bjoern Hansen, Develooper LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. qpsmtpd-0.84/log/000755 000765 000024 00000000000 11357265152 013646 5ustar00askstaff000000 000000 qpsmtpd-0.84/Makefile.PL000644 000765 000024 00000001503 11357260223 015030 0ustar00askstaff000000 000000 #!/usr/bin/perl -w use strict; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'qpsmtpd', VERSION_FROM => 'lib/Qpsmtpd.pm', PREREQ_PM => { 'Mail::Header' => 0, 'MIME::Base64' => 0, 'Net::DNS' => 0.39, 'Data::Dumper' => 0, 'File::Temp' => 0, 'Time::HiRes' => 0, 'Net::IP' => 0, }, ABSTRACT => 'Flexible smtpd daemon written in Perl', AUTHOR => 'Ask Bjoern Hansen ', EXE_FILES => [qw(qpsmtpd qpsmtpd-forkserver qpsmtpd-prefork qpsmtpd-async)], ); sub MY::libscan { my $path = $_[1]; return '' if $path =~ /\B\.svn\b/; return $path; } sub MY::postamble { qq[ testcover : \t cover -delete && \\ HARNESS_PERL_SWITCHES=-MDevel::Cover \$(MAKE) test && \\ cover ] } qpsmtpd-0.84/MANIFEST000644 000765 000024 00000006571 11335434344 014224 0ustar00askstaff000000 000000 .gitignore Changes config.sample/badhelo config.sample/badmailfrom config.sample/badrcptto_patterns config.sample/dnsbl_zones config.sample/flat_auth_pw config.sample/invalid_resolvable_fromhost config.sample/IP config.sample/logging config.sample/loglevel config.sample/plugins config.sample/rcpthosts config.sample/relayclients config.sample/require_resolvable_fromhost config.sample/rhsbl_zones config.sample/size_threshold config.sample/tls_before_auth config.sample/tls_ciphers CREDITS docs/advanced.pod docs/authentication.pod docs/config.pod docs/development.pod docs/hooks.pod docs/logging.pod docs/plugins.pod docs/writing.pod lib/Apache/Qpsmtpd.pm lib/Danga/Client.pm lib/Danga/TimeoutSocket.pm lib/Qpsmtpd.pm lib/Qpsmtpd/Address.pm lib/Qpsmtpd/Auth.pm lib/Qpsmtpd/Command.pm lib/Qpsmtpd/ConfigServer.pm lib/Qpsmtpd/Connection.pm lib/Qpsmtpd/Constants.pm lib/Qpsmtpd/DSN.pm lib/Qpsmtpd/Plugin.pm lib/Qpsmtpd/Plugin/Async/DNSBLBase.pm lib/Qpsmtpd/PollServer.pm lib/Qpsmtpd/Postfix.pm lib/Qpsmtpd/Postfix/Constants.pm lib/Qpsmtpd/Postfix/pf2qp.pl lib/Qpsmtpd/SMTP.pm lib/Qpsmtpd/SMTP/Prefork.pm lib/Qpsmtpd/TcpServer.pm lib/Qpsmtpd/TcpServer/Prefork.pm lib/Qpsmtpd/Transaction.pm lib/Qpsmtpd/Utils.pm LICENSE log/run Makefile.PL MANIFEST This list of files MANIFEST.SKIP META.yml Module meta-data (added by MakeMaker) plugins/async/check_earlytalker plugins/async/dns_whitelist_soft plugins/async/dnsbl plugins/async/queue/smtp-forward plugins/async/require_resolvable_fromhost plugins/async/rhsbl plugins/async/uribl plugins/auth/auth_cvm_unix_local plugins/auth/auth_flat_file plugins/auth/auth_ldap_bind plugins/auth/auth_vpopmail_sql plugins/auth/authdeny 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/connection_time plugins/content_log plugins/count_unrecognized_commands plugins/dns_whitelist_soft plugins/dnsbl plugins/domainkeys plugins/dont_require_anglebrackets plugins/greylisting plugins/help plugins/hosts_allow plugins/http_config plugins/ident/geoip plugins/ident/p0f plugins/logging/adaptive plugins/logging/apache plugins/logging/connection_id plugins/logging/devnull plugins/logging/file plugins/logging/syslog plugins/logging/transaction_id plugins/logging/warn plugins/milter plugins/noop_counter plugins/parse_addr_withhelo plugins/queue/exim-bsmtp plugins/queue/maildir plugins/queue/postfix-queue plugins/queue/qmail-queue plugins/queue/smtp-forward plugins/quit_fortune plugins/random_error plugins/rcpt_ok plugins/rcpt_regexp plugins/relay_only plugins/require_resolvable_fromhost plugins/rhsbl plugins/sender_permitted_from plugins/spamassassin plugins/tls plugins/tls_cert plugins/uribl plugins/virus/aveclient plugins/virus/bitdefender plugins/virus/clamav plugins/virus/clamdscan plugins/virus/hbedv plugins/virus/kavscanner plugins/virus/klez_filter plugins/virus/sophie plugins/virus/uvscan qpsmtpd qpsmtpd-async qpsmtpd-forkserver qpsmtpd-prefork README README.plugins run STATUS t/addresses.t t/config.t t/helo.t t/misc.t t/plugin_tests.t t/plugin_tests/auth/auth_flat_file t/plugin_tests/auth/authdeny t/plugin_tests/auth/authnull t/plugin_tests/check_badrcptto t/plugin_tests/dnsbl t/plugin_tests/rcpt_ok t/qpsmtpd-address.t t/rset.t t/tempstuff.t t/Test/Qpsmtpd.pm t/Test/Qpsmtpd/Plugin.pm qpsmtpd-0.84/MANIFEST.SKIP000644 000765 000024 00000000445 11335434344 014763 0ustar00askstaff000000 000000 CVS/.* \.cvsignore$ \.bak$ \.sw[a-z]$ \.tar$ \.tgz$ \.tar\.gz$ \.o$ \.xsi$ \.bs$ output/.* \.# ^mess/ ^sqlite/ ^output/ ^tmp/ ^blib/ ^blibdirs$ ^Makefile$ ^Makefile\.[a-z]+$ ^pm_to_blib$ ~$ ^MANIFEST\.bak ^tv\.log$ ^MakeMaker-\d \#$ \B\.svn\b ^\.perltidyrc$ ^\.git/.* ^cover_db/ \.(orig|rej)$ qpsmtpd-0.84/META.yml000644 000765 000024 00000001260 11357265152 014335 0ustar00askstaff000000 000000 --- #YAML:1.0 name: qpsmtpd version: 0.84 abstract: Flexible smtpd daemon written in Perl author: - Ask Bjoern Hansen license: unknown distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: Data::Dumper: 0 File::Temp: 0 Mail::Header: 0 MIME::Base64: 0 Net::DNS: 0.39 Net::IP: 0 Time::HiRes: 0 no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.56 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 qpsmtpd-0.84/plugins/000755 000765 000024 00000000000 11357265152 014546 5ustar00askstaff000000 000000 qpsmtpd-0.84/qpsmtpd000755 000765 000024 00000001744 11357264724 014515 0ustar00askstaff000000 000000 #!/usr/bin/perl -Tw # Copyright (c) 2001-2010 Ask Bjoern Hansen. See the LICENSE file for details. # The "command dispatch" system was 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://smtpd.develooper.com/ # # 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(\*STDIN); # pass the "socket" like -prefork/-forkserver $qpsmtpd->run_hooks("post-connection"); $qpsmtpd->connection->reset; # needed for Qpsmtpd::TcpServer::check_socket(): # emulate IO::Socket::connected on STDIN. STDIN was used instead of STDOUT # because the other code also calls getpeername(STDIN). sub IO::Handle::connected { return getpeername(shift) } __END__ 1; qpsmtpd-0.84/qpsmtpd-async000755 000765 000024 00000026657 11165321462 015630 0ustar00askstaff000000 000000 #!/usr/bin/perl use lib "./lib"; BEGIN { delete $ENV{ENV}; delete $ENV{BASH_ENV}; $ENV{PATH} = '/bin:/usr/bin:/var/qmail/bin:/usr/local/bin'; } # Profiling - requires Devel::Profiler 0.05 #BEGIN { $Devel::Profiler::NO_INIT = 1; } #use Devel::Profiler; use strict; use vars qw($DEBUG); use FindBin qw(); # TODO: need to make this taint friendly use lib "$FindBin::Bin/lib"; use Danga::Socket; use Danga::Client; use Qpsmtpd::PollServer; use Qpsmtpd::ConfigServer; use Qpsmtpd::Constants; use IO::Socket; use Carp; use POSIX qw(WNOHANG); use Getopt::Long; use List::Util qw(shuffle); $|++; use Socket qw(SOMAXCONN IPPROTO_TCP SO_KEEPALIVE TCP_NODELAY SOL_SOCKET AF_UNIX SOCK_STREAM PF_UNSPEC); $SIG{'PIPE'} = "IGNORE"; # handled manually $DEBUG = 0; my $CONFIG_PORT = 20025; my $CONFIG_LOCALADDR = '127.0.0.1'; my $PORT = 2525; my $LOCALADDR = '0.0.0.0'; my $PROCS = 1; my $USER = (getpwuid $>)[0]; # user to suid to $USER = "smtpd" if $USER eq "root"; my $PAUSED = 0; my $NUMACCEPT = 20; my $PID_FILE = ''; my $ACCEPT_RSET; my $DETACH; # daemonize on startup # make sure we don't spend forever doing accept() use constant ACCEPT_MAX => 1000; sub reset_num_accept { $NUMACCEPT = 20; } sub help { print < \$PORT, 'l|listen-address=s' => \$LOCALADDR, 'j|procs=i' => \$PROCS, 'v|verbose+' => \$DEBUG, 'u|user=s' => \$USER, 'pid-file=s' => \$PID_FILE, 'd|detach' => \$DETACH, 'h|help' => \&help, 'config-port=i' => \$CONFIG_PORT, ) || help(); # detaint the commandline if ($PORT =~ /^(\d+)$/) { $PORT = $1 } else { &help } if ($LOCALADDR =~ /^([\d\w\-.]+)$/) { $LOCALADDR = $1 } else { &help } if ($USER =~ /^([\w\-]+)$/) { $USER = $1 } else { &help } if ($PROCS =~ /^(\d+)$/) { $PROCS = $1 } else { &help } sub force_poll { $Danga::Socket::HaveEpoll = 0; $Danga::Socket::HaveKQueue = 0; } my $POLL = "with " . ($Danga::Socket::HaveEpoll ? "epoll()" : $Danga::Socket::HaveKQueue ? "kqueue()" : "poll()"); my $SERVER; my $CONFIG_SERVER; use constant READY => 1; use constant ACCEPTING => 2; use constant RESTARTING => 999; my %childstatus = (); if ($PID_FILE && -r $PID_FILE) { open PID, "<$PID_FILE" or die "open_pidfile $PID_FILE: $!\n"; my $running_pid = || ''; chomp $running_pid; if ($running_pid =~ /^(\d+)/) { if (kill 0, $running_pid) { die "Found an already running qpsmtpd with pid $running_pid.\n"; } } close(PID); } run_as_server(); exit(0); sub _fork { my $pid = fork; if (!defined($pid)) { die "Cannot fork: $!" } return $pid if $pid; # Fixup Net::DNS randomness after fork srand($$ ^ time); local $^W; delete $INC{'Net/DNS/Header.pm'}; require Net::DNS::Header; # cope with different versions of Net::DNS eval { $Net::DNS::Resolver::global{id} = 1; $Net::DNS::Resolver::global{id} = int(rand(Net::DNS::Resolver::MAX_ID())); # print "Next DNS ID: $Net::DNS::Resolver::global{id}\n"; }; if ($@) { # print "Next DNS ID: " . Net::DNS::Header::nextid() . "\n"; } # Fixup lost kqueue after fork $Danga::Socket::HaveKQueue = undef; } sub spawn_child { my $plugin_loader = shift || Qpsmtpd::SMTP->new; socketpair(my $reader, my $writer, AF_UNIX, SOCK_STREAM, PF_UNSPEC) || die "Unable to create a pipe"; $writer->autoflush(1); $reader->autoflush(1); if (my $pid = _fork) { $childstatus{$pid} = $writer; return $pid; } $SIG{CHLD} = $SIG{INT} = $SIG{TERM} = 'DEFAULT'; $SIG{PIPE} = 'IGNORE'; $SIG{HUP} = 'IGNORE'; close $CONFIG_SERVER; Qpsmtpd::PollServer->Reset; Qpsmtpd::PollServer->OtherFds( fileno($reader) => sub { command_handler($reader) }, fileno($SERVER) => \&accept_handler, ); $ACCEPT_RSET = Danga::Socket->AddTimer(30, \&reset_num_accept); $plugin_loader->run_hooks('post-fork'); Qpsmtpd::PollServer->EventLoop(); exit; } # Note this is broken on KQueue because it requires that it handle signals itself or it breaks the event loop. sub sig_hup { for my $writer (values %childstatus) { print $writer "hup\n"; } } sub sig_chld { my $spawn_count = 0; while ( (my $child = waitpid(-1,WNOHANG)) > 0) { if (!defined $childstatus{$child}) { next; } last unless $child > 0; print "SIGCHLD: child $child died\n"; delete $childstatus{$child}; $spawn_count++; } if ($spawn_count) { for (1..$spawn_count) { # restart a new child if in poll server mode my $pid = spawn_child(); } } $SIG{CHLD} = \&sig_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); } sub run_as_server { # establish SERVER socket, bind and listen. $SERVER = IO::Socket::INET->new(LocalPort => $PORT, LocalAddr => $LOCALADDR, Type => SOCK_STREAM, Proto => IPPROTO_TCP, Blocking => 0, Reuse => 1, Listen => SOMAXCONN ) or die "Error creating server $LOCALADDR:$PORT : $@\n"; IO::Handle::blocking($SERVER, 0); binmode($SERVER, ':raw'); $CONFIG_SERVER = IO::Socket::INET->new(LocalPort => $CONFIG_PORT, LocalAddr => $CONFIG_LOCALADDR, Type => SOCK_STREAM, Proto => IPPROTO_TCP, Blocking => 0, Reuse => 1, Listen => 1 ) or die "Error creating server $CONFIG_LOCALADDR:$CONFIG_PORT : $@\n"; IO::Handle::blocking($CONFIG_SERVER, 0); binmode($CONFIG_SERVER, ':raw'); # Drop priviledges my (undef, undef, $quid, $qgid) = getpwnam $USER or die "unable to determine uid/gid for $USER\n"; my $groups = "$qgid $qgid"; while (my (undef, undef, $gid, $members) = getgrent) { my @m = split(/ /, $members); if (grep { $_ eq $USER } @m) { $groups .= " $gid"; } } endgrent; $) = $groups; POSIX::setgid($qgid) or die "unable to change gid: $!\n"; POSIX::setuid($quid) or die "unable to change uid: $!\n"; $> = $quid; # Load plugins here my $plugin_loader = Qpsmtpd::SMTP->new(); $plugin_loader->load_plugins; 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) { open PID, ">$PID_FILE" || die "$PID_FILE: $!"; print PID $$,"\n"; close PID; } $plugin_loader->log(LOGINFO, 'Running as user '. (getpwuid($>) || $>) . ', group '. (getgrgid($)) || $))); $SIG{INT} = $SIG{TERM} = \&HUNTSMAN; ###################### # more Profiling code =pod $plugin_loader->run_hooks('post-fork'); Devel::Profiler->set_options( bad_subs => [qw(Danga::Socket::EventLoop)], sub_filter => sub { my ($pkg, $sub) = @_; return 0 if $sub eq 'AUTOLOAD'; return 0 if $pkg =~ /ParaDNS::XS/; return 1; }, ); Devel::Profiler->init(); Qpsmtpd::PollServer->OtherFds( fileno($SERVER) => \&accept_handler, fileno($CONFIG_SERVER) => \&config_handler, ); Qpsmtpd::PollServer->EventLoop; exit; =cut ##################### for (1..$PROCS) { my $pid = spawn_child($plugin_loader); } $plugin_loader->log(LOGDEBUG, "Listening on $PORT with $PROCS children $POLL"); $SIG{CHLD} = \&sig_chld; $SIG{HUP} = \&sig_hup; Qpsmtpd::PollServer->OtherFds( fileno($CONFIG_SERVER) => \&config_handler, ); Qpsmtpd::PollServer->EventLoop; exit; } sub config_handler { my $csock = $CONFIG_SERVER->accept(); if (!$csock) { # warn("accept failed on config server: $!"); return; } binmode($csock, ':raw'); printf("Config server connection\n") if $DEBUG; IO::Handle::blocking($csock, 0); setsockopt($csock, IPPROTO_TCP, TCP_NODELAY, pack("l", 1)) or die; my $client = Qpsmtpd::ConfigServer->new($csock); $client->watch_read(1); return; } sub command_handler { my $reader = shift; chomp(my $command = <$reader>); #print "Got command: $command\n"; my $real_command = "cmd_$command"; no strict 'refs'; $real_command->(); } sub cmd_hup { # clear cache print "Clearing cache\n"; Qpsmtpd::clear_config_cache(); # should also reload modules... but can't do that yet. } # Accept all new connections sub accept_handler { for (1 .. $NUMACCEPT) { return unless _accept_handler(); } # got here because we have accept's left. # So double the number we accept next time. $NUMACCEPT *= 2; $NUMACCEPT = ACCEPT_MAX if $NUMACCEPT > ACCEPT_MAX; $ACCEPT_RSET->cancel if defined $ACCEPT_RSET; $ACCEPT_RSET = Danga::Socket->AddTimer(30, \&reset_num_accept); } use Errno qw(EAGAIN EWOULDBLOCK); sub _accept_handler { my $csock = $SERVER->accept(); if (!$csock) { # warn("accept() failed: $!"); return; } binmode($csock, ':raw'); printf("Listen child making a Qpsmtpd::PollServer for %d.\n", fileno($csock)) if $DEBUG; IO::Handle::blocking($csock, 0); #setsockopt($csock, IPPROTO_TCP, TCP_NODELAY, pack("l", 1)) or die; #print "Got connection\n"; my $client = Qpsmtpd::PollServer->new($csock); if ($PAUSED) { $client->write("451 Sorry, this server is currently paused\r\n"); $client->close; return 1; } $client->process_line("Connect\n"); $client->watch_read(1); $client->pause_read(); return 1; } ######################################################################## sub log { my ($level,$message) = @_; # $level not used yet. this is reimplemented from elsewhere anyway warn("$$ fd:? $message\n"); } sub pause { my ($pause) = @_; $PAUSED = $pause; } qpsmtpd-0.84/qpsmtpd-forkserver000755 000765 000024 00000024545 11357264720 016703 0ustar00askstaff000000 000000 #!/usr/bin/perl -Tw # Copyright (c) 2001-2010 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://smtpd.develooper.com/ # # use lib 'lib'; use Qpsmtpd::TcpServer; use Qpsmtpd::Constants; use IO::Socket; use IO::Select; use Socket; use Getopt::Long qw(:config no_ignore_case); use POSIX qw(:sys_wait_h :errno_h :signal_h); use Net::DNS::Header; use strict; $| = 1; my $has_ipv6 = Qpsmtpd::TcpServer::has_ipv6; if ($has_ipv6) { eval 'use Socket6'; } # Configuration my $MAXCONN = 15; # max simultaneous connections my @PORT; # port number(s) my @LOCALADDR; # ip address(es) to bind to my $MAXCONNIP = 5; # max simultaneous connections from one IP my $PID_FILE = ''; my $DETACH; # daemonize on startup my $NORDNS; my $USER = (getpwuid $>)[0]; # user to suid to $USER = "smtpd" if $USER eq "root"; 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. IPv6 addresses must be inside square brackets [], and don't need to be zero padded. Default is [::] (if has_ipv6) or 0.0.0.0 (if not) -p, --port P : listen on a specific port; default 2525; can be specified multiple times for multiple bindings. -c, --limit-connections N : limit concurrent connections to N; default 15 -u, --user U : run as a particular user (default '$USER') -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) -H, --no-rdns : don't perform reverse DNS lookups 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=s' => \@PORT, 'u|user=s' => \$USER, 'pid-file=s' => \$PID_FILE, 'd|detach' => \$DETACH, 'H|no-rdns' => \$NORDNS, ) || &usage; # detaint the commandline if ($has_ipv6) { @LOCALADDR = ( '[::]' ) if !@LOCALADDR; } else { @LOCALADDR = ( '0.0.0.0' ) if !@LOCALADDR; } @PORT = ( 2525 ) if !@PORT; my @LISTENADDR; for (0..$#LOCALADDR) { if ($LOCALADDR[$_] =~ /^(\[.*\]|[\d\w\-.]+)(?::(\d+))?$/) { if ( defined $2 ) { push @LISTENADDR, { 'addr' => $1, 'port' => $2 }; } else { my $addr = $1; for (0..$#PORT) { if ( $PORT[$_] =~ /^(\d+)$/ ) { push @LISTENADDR, { 'addr' => $addr, 'port' => $1 }; } else { &usage; } } } } else { &usage; } } if ($USER =~ /^([\w\-]+)$/) { $USER = $1 } else { &usage } if ($MAXCONN =~ /^(\d+)$/) { $MAXCONN = $1 } else { &usage } delete $ENV{ENV}; $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; my $server; # establish SERVER socket(s), bind and listen. for my $listen_addr (@LISTENADDR) { my @Socket_opts = (LocalPort => $listen_addr->{'port'}, LocalAddr => $listen_addr->{'addr'}, Proto => 'tcp', Reuse => 1, Blocking => 0, Listen => SOMAXCONN); if ($has_ipv6) { $server = IO::Socket::INET6->new(@Socket_opts) or die "Creating TCP socket $listen_addr->{'addr'}:$listen_addr->{'port'}: $!\n"; } else { $server = IO::Socket::INET->new(@Socket_opts) or die "Creating TCP socket $listen_addr->{'addr'}:$listen_addr->{'port'}: $!\n"; } IO::Handle::blocking($server, 0); $select->add($server); } 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 = || ''; 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"; } } endgrent; $) = $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; foreach my $listen_addr ( @LISTENADDR ) { ::log(LOGINFO,"Listening on $listen_addr->{'addr'}:$listen_addr->{'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; $SIG{HUP} = sub { $qpsmtpd = Qpsmtpd::TcpServer->new('restart' => 1); $qpsmtpd->load_plugins; $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); # get local/remote hostname, port and ip address my ($port, $iaddr, $lport, $laddr, $nto_iaddr, $nto_laddr) = Qpsmtpd::TcpServer::lrpip($server, $client, $hisaddr); my ($rc, @msg) = $qpsmtpd->run_hooks("pre-connection", remote_ip => $nto_iaddr, remote_port => $port, local_ip => $nto_laddr, local_port => $lport, max_conn_ip => $MAXCONNIP, child_addrs => [values %childstatus], ); if ($rc == DENYSOFT || $rc == DENYSOFT_DISCONNECT) { unless ($msg[0]) { @msg = ("Sorry, try again later"); } &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(); for (0 .. rand(65536)) { Net::DNS::Header::nextid(); } close $_ for $select->handles; $SIG{$_} = 'DEFAULT' for keys %SIG; $SIG{ALRM} = sub { print $client "421 Connection Timed Out\n"; ::log(LOGINFO, "Connection Timed Out"); exit; }; # set enviroment variables ($ENV{TCPLOCALIP}, $ENV{TCPREMOTEIP}, $ENV{TCPREMOTEHOST}) = Qpsmtpd::TcpServer::tcpenv($nto_laddr, $nto_iaddr); # 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($client); $qpsmtpd->run_hooks("post-connection"); $qpsmtpd->connection->reset; close $client; 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; qpsmtpd-0.84/qpsmtpd-prefork000755 000765 000024 00000054443 11335434344 016160 0ustar00askstaff000000 000000 #!/usr/bin/perl -Tw # High performance pre-forking qpsmtpd daemon, Copyright (C) 2006 SoftScan # http://www.softscan.co.uk # # Based on qpsmtpd-forkserver Copyright (C) 2001 Ask Bjoern Hansen # See the LICENSE file for details. # # For more information see http://smtpd.develooper.com/ # safety guards use strict; BEGIN { # secure shell $ENV{'PATH'} = '/bin:/usr/bin'; delete @ENV{qw(IFS CDPATH ENV BASH_ENV)}; } # includes use IO::Socket; use IO::Select; use POSIX; use IPC::Shareable(':all'); use lib 'lib'; use Qpsmtpd::TcpServer::Prefork; use Qpsmtpd::Constants; use Getopt::Long; use Config; defined $Config{sig_name} || die "No signals?"; my $has_ipv6 = Qpsmtpd::TcpServer::has_ipv6; if ($has_ipv6) { use Socket6; } #use Time::HiRes qw(gettimeofday tv_interval); #get available signals my %sig_num; my $i = 0; foreach my $sig_name ( split( /\s/, $Config{sig_name} ) ) { $sig_num{$sig_name} = $i++; } # version my $VERSION = "1.0"; # qpsmtpd instances my ($qpsmtpd, $qpsmtpd_base); # cmd's needed by IPC my $ipcrm = '/usr/bin/ipcrm'; my $ipcs = '/usr/bin/ipcs'; my $xargs = '/usr/bin/xargs'; # vars we need my $chld_shmem; # shared mem to keep track of children (and their connections) my %children; my $chld_pool; my $chld_busy; my @children_term; # terminated children, their death pending processing # by the main loop my $select = new IO::Select; # socket(s) # default settings my $pid_file; my $d_port = 25; my @d_addr; # default applied after getopt call my $debug = 0; my $max_children = 15; # max number of child processes to spawn my $idle_children = 5; # number of idle child processes to spawn my $maxconnip = 10; my $child_lifetime = 100; # number of times a child may be reused my $loop_sleep = 15; # seconds main_loop sleeps before checking children my $re_nice = 5; # substracted from parents current nice level my $d_start = 0; my $quiet = 0; my $status = 0; my $signal = ''; my $pretty = 0; my $detach = 0; my $user; # help text sub usage { print <<"EOT"; Usage: qpsmtpd-prefork [ options ] --quiet : Be quiet (even errors are suppressed) --version : Show version information --debug : Enable debug output --listen-address addr: Listen for connections on the address 'addr' (either an IP address or ip:port pair). Listens on all interfaces by default; may be specified multiple times. --port int : TCP port daemon should listen on (default: $d_port) --max-from-ip int : Limit number of connections from single IP (default: $maxconnip, 0 to disable) --children int : Max number of children that can be spawned (default: $max_children) --idle-children int : Number of idle children to spawn (default: $idle_children, 0 to disable) --pretty-child : Change child process name (default: 0) --user username : User the daemon should run as --pid-file path : Path to pid file --renice-parent int : Subtract value from parent process nice level (default: $re_nice) --detach : detach from controlling terminal (daemonize) --help : This message EOT exit 0; } # get arguments GetOptions( 'quiet' => \$quiet, 'version' => sub { print "Qpsmtpd Daemon - version $VERSION\n"; exit 0; }, 'debug' => \$debug, 'interface|listen-address=s' => \@d_addr, 'port=i' => \$d_port, 'max-from-ip=i' => \$maxconnip, 'children=i' => \$max_children, 'idle-children=i' => \$idle_children, 'pretty-child' => \$pretty, 'user=s' => \$user, 'renice-parent=i' => \$re_nice, 'detach' => \$detach, 'pid-file=s' => \$pid_file, 'help' => \&usage, ) || &usage; if ($user && $user =~ /^([\w\-]+)$/) { $user = $1 } else { &usage } if (@d_addr) { for my $i (0..$#d_addr) { if ($d_addr[$i] =~ /^(\[.*\]|[\d\w\-.]+)(?::(\d+))?$/) { $d_addr[$i] = { 'addr' => $1, 'port' => $2 || $d_port }; } else { print STDERR "Malformed listen address '$d_addr[$i]'\n"; &usage; } } } else { @d_addr = ( { addr => $has_ipv6 ? "[::]" : "0.0.0.0", port => $d_port } ); } # set max from ip to max number of children if option is set to disabled $maxconnip = $max_children if ($maxconnip == 0); #to fix limit counter error in plugin $maxconnip++; #ensure that idle_children matches value given to max_children $idle_children = $max_children if (!$idle_children || $idle_children > $max_children || $idle_children < -1); $chld_pool = $idle_children; 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 = || ''; chomp $running_pid; if ($running_pid =~ /(\d+)/) { $running_pid = $1; die "Found an already running qpsmtpd with pid $running_pid.\n" if (kill 0, $running_pid); } 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"; } } run(); #start daemon sub run { # get UUID/GUID my ($quid, $qgid, $groups); if ($user) { (undef, undef, $quid, $qgid) = getpwnam $user or die "unable to determine uid/gid for $user\n"; $groups = "$qgid $qgid"; while (my ($name,$passwd,$gid,$members) = getgrent()) { my @m = split(/ /, $members); if (grep {$_ eq $user} @m) { $groups .= " $gid"; } } endgrent; } for my $addr (@d_addr) { my @Socket_opts = ( LocalPort => $addr->{port}, LocalAddr => $addr->{addr}, Proto => 'tcp', Listen => SOMAXCONN, Reuse => 1, ); # create new socket (used by clients to communicate with daemon) my $s; if ($has_ipv6) { $s = IO::Socket::INET6->new(@Socket_opts); } else { $s = IO::Socket::INET->new(@Socket_opts); } die "FATAL: Failed to open socket on $addr->{addr}:$addr->{port} ($@)" . "\nIt may be necessary to wait 20 secs before starting daemon" . " again." unless $s; $select->add($s); } info("qpsmtpd-prefork daemon, version: $VERSION, staring on host: " . join(', ', map { "$_->{addr}:$_->{port}"} @d_addr) . " (user: $user [$<])"); # reset priority my $old_nice = getpriority(0, 0); my $new_nice = $old_nice - $re_nice; if ($new_nice < 20 && $new_nice > -20) { setpriority(0, 0, $1) if ($new_nice =~ /(\-?\d+)/); info("parent daemon nice level: $1"); } else { die "FATAL: new nice level: $new_nice is not between -19 and 19 " . "(old level = $old_nice, renice value = $re_nice)"; } if ($user) { # change UUID/UGID $) = $groups; POSIX::setgid($qgid) or die "unable to change gid: $!\n"; POSIX::setuid($quid) or die "unable to change uid: $!\n"; $> = $quid; die "FATAL: failed to setuid to user: $user, uid: $quid\n" if ($> != $quid and $> != ($quid - 2**32)); } # setup shared memory $chld_shmem = shmem($d_port."qpsmtpd", 1); untie $chld_shmem; # Interrupt handler $SIG{INT} = $SIG{TERM} = sub { # terminate daemon (and children) my $sig = shift; # prevent another signal and disable reaper $SIG{$sig} = $SIG{CHLD} = $SIG{HUP} = 'IGNORE'; # a notice, before the sleep below info("shutting down"); # close socket(s) $_->close for $select->handles; # send signal to process group kill -$sig_num{$sig} => $$; # cleanup IPC::Shareable->clean_up; unlink($pid_file) if $pid_file; info("shutdown of daemon"); exit; }; # Hup handler $SIG{HUP} = sub { # reload qpmstpd plugins $qpsmtpd = $qpsmtpd_base = qpsmtpd_instance('restart' => 1); # reload plugins... $qpsmtpd->load_plugins; kill 'HUP' => keys %children; info("reload daemon requested"); }; # setup qpsmtpd_instance(s), _base is for resetting to a known state # after each connection $qpsmtpd = $qpsmtpd_base = qpsmtpd_instance(); 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; } # child reaper $SIG{CHLD} = \&reaper; spawn_children(); main_loop(); exit; } # initialize children (only done at daemon startup) sub spawn_children { # block signals while new children are being spawned my $sigset = block_signal(SIGCHLD); for (1 .. $chld_pool) { new_child(); } # reset block signals unblock_signal($sigset); } # cleanup after child dies sub reaper { my $stiff; while (($stiff = waitpid(-1, &WNOHANG)) > 0) { my $res = WEXITSTATUS($?); info("child terminated, pid: $stiff (status $?, res: $res)"); delete $children{$stiff}; # delete pid from children # add pid to array so it later can be removed from shared memory push @children_term, $stiff; } $SIG{CHLD} = \&reaper; } #main_loop: main loop. Either processes children that have exited or # periodically scans the shared memory for children that are not longer # alive. Spawns new children when necessary. #arg0: void #ret0: void sub main_loop { my $created_children = $idle_children; while (1) { # if there is no child death to process, then sleep EXPR seconds # or until signal (i.e. child death) is received sleep $loop_sleep / ($created_children * 2 + 1) unless @children_term; # block CHLD signals to avoid race my $sigset = block_signal(SIGCHLD); # get number of busy children if (@children_term) { # remove dead children info from shared memory $chld_busy = shmem_opt(undef, \@children_term, undef, undef); @children_term = (); } else { # just check the shared memory $chld_busy = shmem_opt(undef, undef, undef, undef, 1); } # calculate children in pool (if valid busy children number) if (defined($chld_busy)) { info("busy children: $chld_busy"); $chld_pool = $chld_busy + $idle_children; # ensure pool limit is max_children $chld_pool = $max_children if ($chld_pool > $max_children); info( "children pool: $chld_pool, spawned: " . scalar(keys %children) . ", busy: $chld_busy"); } else { # reset shared memory warn("unable to access shared memory - resetting it"); IPC::Shareable->clean_up; my $shmem = shmem($d_port . "qpsmtpd", 1); untie $shmem; } # spawn children $created_children = $chld_pool - keys %children; $created_children = 0 if $created_children < 0; new_child() for 1..$created_children; # unblock signals unblock_signal($sigset); } } # block_signal: block signals # arg0..n: int with signal(s) to block # ret0: ref str with sigset (used to later unblock signal) sub block_signal { my @signal = @_; #arg0..n my ($sigset, $blockset); $sigset = POSIX::SigSet->new(); $blockset = POSIX::SigSet->new(@signal); sigprocmask(SIG_BLOCK, $blockset, $sigset) or die "Could not block @signal signals: $!\n"; return ($sigset); } # unblock_signal: unblock/reset and receive pending signals # arg0: ref str with sigset # ret0: void sub unblock_signal { my $sigset = shift; # arg0 sigprocmask(SIG_SETMASK, $sigset) or die "Could not restore signals: $!\n"; } # new_child: initialize new child # arg0: void # ret0: void sub new_child { # daemonize away from the parent process my $pid; die "Cannot fork child: $!\n" unless defined($pid = fork); if ($pid) { # in parent $children{$pid} = 1; info("new child, pid: $pid"); return; } # in child # reset priority setpriority 0, 0, getpriority(0, 0) + $re_nice; # reset signals my $sigset = POSIX::SigSet->new(); my $blockset = POSIX::SigSet->new(SIGCHLD); sigprocmask(SIG_UNBLOCK, $blockset, $sigset) or die "Could not unblock SIGCHLD signal: $!\n"; $SIG{CHLD} = $SIG{INT} = $SIG{TERM} = $SIG{ALRM} = 'DEFAULT'; # child should exit if it receives HUP signal (note: blocked while child # is busy, but restored once done) $SIG{HUP} = sub { info("signal HUP received, going to exit"); exit; }; # continue to accept connections until "old age" is reached for (my $i = 0 ; $i < $child_lifetime ; $i++) { # accept a connection if ( $pretty ) { $ENV{PROCESS} = $0 if not defined $ENV{PROCESS}; # 1st time only $0 = 'qpsmtpd child'; # set pretty child name in process listing } my @ready = $select->can_read(); next unless @ready; my $socket = $ready[0]; my ($client, $iinfo) = $socket->accept() or die "failed to create new object - $!"; # wait here until client connects info("connect from: " . $client->peerhost . ":" . $client->peerport); # clear a previously running instance by cloning the base: $qpsmtpd = $qpsmtpd_base; # set STDIN/STDOUT and autoflush # ... no longer use POSIX::dup2: it failes after a few # million connections close(STDIN); open(STDIN, "+<&".fileno($client)) or die "unable to duplicate filehandle to STDIN - $!"; close(STDOUT); open(STDOUT, "+>&".fileno($client)) or die "unable to duplicate filehandle to STDOUT - $!"; select(STDOUT); $| = 1; # connection recieved, block signals my $sigset = block_signal(SIGHUP); # start a session if connection looks valid qpsmtpd_session($socket, $client, $iinfo, $qpsmtpd) if ($iinfo); # close connection and cleanup $client->shutdown(2); # unset block and receive pending signals unblock_signal($sigset); } exit; # this child has reached its end-of-life } # respond to client # arg0: ref to socket object (client) # arg1: int with SMTP reply code # arg2: arr with message # ret0: int 0|1 (0 = failure, 1 = success) sub respond_client { my ($client, $code, @message) = @_; $client->autoflush(1); while (my $msg = shift @message) { my $line = $code . (@message ? "-" : " ") . $msg; info("reply to client: <$line>"); print $client "$line\r\n" or (info("Could not print [$line]: $!"), return 0); } return 1; } # qpsmtpd_instance: setup qpsmtpd instance # arg0: void # ret0: ref to qpsmtpd_instance sub qpsmtpd_instance { my %args = @_; my $qpsmtpd = Qpsmtpd::TcpServer::Prefork->new(%args); $qpsmtpd->load_plugins; $qpsmtpd->spool_dir; $qpsmtpd->size_threshold; return ($qpsmtpd); } # shmem: tie to shared memory hash # arg0: str with glue # arg1: int 0|1 (0 = don't create shmem, 1 = create shmem) # ret0: ref to shared hash sub shmem { my $glue = shift; #arg0 my $create = shift || 0; #arg1 my %options = ( create => $create, exclusive => 0, mode => 0640, destroy => 0, ); my %shmem_hash; eval { tie %shmem_hash, 'IPC::Shareable', $glue, {%options} || die "unable to tie to shared memory - $!"; }; if ($@) { info("$@"); return; } return (\%shmem_hash); } # shmem_opt: connect to shared memory and perform options # arg0: ref to hash where shared memory should be copied to # arg1: ref to arr with pid(s) to delete # arg2: int with pid to add (key) # arg3: str with packed iaddr to add (value) # arg4: int 0|1 check and cleanup shared memory (0 = no, 1 = yes - default 0) # ret0: int with number of busy children (undef if error) sub shmem_opt { my $ref_shmem = shift; #arg0 my $ref_pid_del = shift; #arg1 my $pid_add_key = shift; #arg2 my $pid_add_value = shift; #arg3 my $check = shift || 0; #arg4 # check arguments if ( (defined($pid_add_key) && !defined($pid_add_value)) || (!defined($pid_add_key) && defined($pid_add_value))) { return; } my ($chld_shmem, $chld_busy); eval { $chld_shmem = &shmem($d_port."qpsmtpd", 0); #connect to shared memory hash if (tied %{$chld_shmem}) { # lock shared memory eval { # ensure that hung shared memory is noticed local $SIG{ALRM} = sub { die "locking timed out\n"; }; alarm 15; (tied %{$chld_shmem})->shlock(LOCK_EX); alarm 0; }; die $@ if $@; # delete if ($ref_pid_del) { foreach my $pid_del (@{$ref_pid_del}) { delete $$chld_shmem{$pid_del}; } } # add $$chld_shmem{$pid_add_key} = $pid_add_value if ($pid_add_key); # copy %{$ref_shmem} = %{$chld_shmem} if ($ref_shmem); # check if ($check) { # loop through pid list and delete orphaned processes foreach my $pid (keys %{$chld_shmem}) { if (!kill 0, $pid) { delete $$chld_shmem{$pid}; warn("orphaned child, pid: $pid removed from memory"); } } } # number of busy children $chld_busy = scalar(keys %{$chld_shmem}); # unlock shared memory (tied %{$chld_shmem})->shunlock; # untie from shared memory untie $chld_shmem || die "unable to untie from shared memory"; } else { die "failed to connect to shared memory"; } }; # check for error if ($@) { undef($chld_busy); warn("$@"); } return ($chld_busy); } # info: write info # arg0: str with debug text sub info { my $text = shift; #arg0 return if (!$debug); my ($sec, $min, $hour, $mday, $mon, $year) = localtime(time); my $nowtime = sprintf "%02d/%02d/%02d %02d:%02d:%02d", $mday, $mon + 1, $year + 1900, $hour, $min, $sec; chomp($text); print STDERR "$nowtime:$$: $text\n"; } # start qpmstpd session # arg0: ref to socket object # arg1: ref to socket object # arg2: ref to qpsmtpd instance # ret0: void sub qpsmtpd_session { my $socket = shift; #arg0 my $client = shift; #arg1 my $iinfo = shift; #arg2 my $qpsmtpd = shift; #arg3 # get local/remote hostname, port and ip address my ($port, $iaddr, $lport, $laddr, $nto_iaddr, $nto_laddr) = Qpsmtpd::TcpServer::lrpip($socket, $client, $iinfo); # get current connected ip addresses (from shared memory) my %children; shmem_opt(\%children, undef, $$, $iaddr); my ($rc, @msg) = $qpsmtpd->run_hooks( "pre-connection", remote_ip => $nto_iaddr, remote_port => $port, local_ip => $nto_laddr, local_port => $lport, max_conn_ip => $maxconnip, child_addrs => [values %children], ); if ( $rc == DENYSOFT || $rc == DENYSOFT_DISCONNECT || $rc == DENY || $rc == DENY_DISCONNECT) { #smtp return code to reply client with (seed with soft deny) my $rc_reply = 451; unless ($msg[0]) { if ($rc == DENYSOFT || $rc == DENYSOFT_DISCONNECT) { @msg = ("Sorry, try again later"); } else { @msg = ("Sorry, service not available to you"); $rc_reply = 550; } } respond_client($client, $rc_reply, @msg); # remove pid from shared memory shmem_opt(undef, [$$], undef, undef); # retur so child can be reused return; } # all children should have different seeds, to prevent conflicts srand(time ^ ($$ + ($$ << 15))); # ALRM handler $SIG{ALRM} = sub { print $client "421 Connection Timed Out\n"; info("Connection Timed Out"); # child terminates exit; }; # set enviroment variables ($ENV{TCPLOCALIP}, $ENV{TCPREMOTEIP}, $ENV{TCPREMOTEHOST}) = Qpsmtpd::TcpServer::tcpenv($nto_laddr, $nto_iaddr); # run qpmsptd functions $SIG{__DIE__} = 'DEFAULT'; eval { $qpsmtpd->start_connection( local_ip => $ENV{TCPLOCALIP}, local_port => $lport, remote_ip => $ENV{TCPREMOTEIP}, remote_port => $client->peerport, ); $qpsmtpd->run($client); $qpsmtpd->run_hooks("post-connection"); $qpsmtpd->connection->reset; }; if ($@ !~ /^(disconnect_tcpserver|died while reading from STDIN)/) { warn("$@"); } # child is now idle again info("disconnect from: $nto_iaddr:$port"); # remove pid from shared memory unless (defined(shmem_opt(undef, [$$], undef, undef))) { # exit because parent is down or shared memory is corrupted info("parent seems to be down, going to exit"); exit 1; } } qpsmtpd-0.84/README000644 000765 000024 00000013604 11217543600 013741 0ustar00askstaff000000 000000 # # this file is best read with `perldoc README` # =head1 NAME Qpsmtpd - qmail perl simple mail transfer protocol daemon web: http://smtpd.develooper.com/ mailinglist: qpsmtpd-subscribe@perl.org =head1 DESCRIPTION What is Qpsmtpd? Qpsmtpd is an extensible smtp engine written in Perl. No, make that easily extensible! See plugins/quit_fortune for a very useful, er, cute example. =head2 License Qpsmtpd is licensed under the MIT License; see the LICENSE file for more information. =head2 What's new in this release? See the Changes file! :-) =head1 Installation =head2 Required Perl Modules The following Perl modules are required: Net::DNS MIME::Base64 Mail::Header (part of the MailTools distribution) If you use a version of Perl older than 5.8.0 you will also need Data::Dumper File::Temp Time::HiRes The easiest way to install modules from CPAN is with the CPAN shell. Run it with perl -MCPAN -e shell =head2 qpsmtpd installation Make a new user and a directory where you'll install qpsmtpd. I usually use "smtpd" for the user and /home/smtpd/qpsmtpd/ for the directory. Put the files there. If you install from Subversion you can just do run the following command in the /home/smtpd/ directory. git clone git://github.com/abh/qpsmtpd.git Beware that the master branch might be unstable and unsuitable for anything but development, so you might want to get a specific release, for example (after running git clone): git checkout -b local_branch v0.40 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 and permissions can be set with "spool_perms". As per version 0.25 the distributed ./run script runs tcpserver with the -R flag to disable identd lookups. Remove the -R flag if that's not what you want. =head2 Configuration Configuration files can go into either /var/qmail/control or into the config subdirectory of the qpsmtpd installation. Configuration should be compatible with qmail-smtpd making qpsmtpd a drop-in replacement. If qmail is installed in a nonstandard location you should set the $QMAIL environment variable to that location in your "./run" file. If there is anything missing, then please send a patch (or just information about what's missing) to the mailinglist or to ask@develooper.com. =head1 Better Performance For better performance we recommend using "qpsmtpd-forkserver" or running qpsmtpd under Apache 2.x. If you need extremely high concurrency and all your plugins are compatible, you might want to try the "qpsmtpd-async" model. =head1 Plugins The qpsmtpd core only implements the SMTP protocol. No useful function can be done by qpsmtpd without loading plugins. Plugins are loaded on startup where each of them register their interest in various "hooks" provided by the qpsmtpd core engine. At least one plugin MUST allow or deny the RCPT command to enable receiving mail. The "rcpt_ok" is one basic plugin that does this. Other plugins 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 tls_before_auth If this file contains anything except a 0 on the first noncomment line, then AUTH will not be offered unless TLS/SSL are in place, either with STARTTLS, or SMTP-SSL on port 465. =item everything (?) that qmail-smtpd supports. In my test qpsmtpd installation I have a "config/me" file containing the hostname I use for testing qpsmtpd (so it doesn't introduce itself with the normal name of the server). =back =head1 Problems In case of problems always 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. qpsmtpd-0.84/README.plugins000644 000765 000024 00000000453 11165321461 015420 0ustar00askstaff000000 000000 # # read this with 'perldoc README.plugins' ... # =head1 qpsmtpd plugin system; developer documentation Plugin documentation is now in F. See the examples in plugins/ and ask questions on the qpsmtpd mailinglist; subscribe by sending mail to qpsmtpd-subscribe@perl.org. =cut qpsmtpd-0.84/run000755 000765 000024 00000000346 11165321462 013614 0ustar00askstaff000000 000000 #!/bin/sh QMAILDUID=`id -u smtpd` NOFILESGID=`id -g smtpd` LANG=C exec /usr/local/bin/softlimit -m 50000000 \ /usr/local/bin/tcpserver -c 10 -v -R -p \ -u $QMAILDUID -g $NOFILESGID `head -1 config/IP` smtp \ ./qpsmtpd 2>&1 qpsmtpd-0.84/STATUS000644 000765 000024 00000004257 11165321461 014034 0ustar00askstaff000000 000000 New Name Suggestions ==================== ignite flare(mta) quench pez (or pezmail) Roadmap ======= - http://code.google.com/p/smtpd/issues - Bugfixes - qpsmtpd is extremely stable (in production since 2001), but there are always more things to fix. - Add user configuration plugin infrastructure - Add plugin API for checking if a local email address is valid - Include the popular check_delivery[1] functionality via the user 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. Issues ====== See http://code.google.com/p/smtpd/issues/list ------ The rest of the list here might be outdated. ------ ------ Patches to remove things are welcome. ------ add whitelist support to the dnsbl plugin (and maybe to the rhsbl plugin too). Preferably both supporting DNS based whitelists and filebased (CDB) ones. plugin support; allow plugins to return multiple response lines (does it have to join them to one for SMTP?) support plugins for the rest of the commands. specify a priority in register_hook. ("LAST", "FIRST", "MIDDLE", or maybe a number) plugin access to the data line by line during the DATA phase (instead of just after) if qmail-queue can't be loaded we still return 250 ?! Make a system for configuring the plugins per user/domain/... support databytes per user / domain plugin to reject mails from <> if it has multiple recipients. localiphost - support foo@[a.b.c.d] addresses Move dispatch() etc from SMTP.pm to Qpsmtpd.pm to allow other similar protocols to use the qpsmtpd framework. Future Ideas ============ Methods to create a bounce message easily; partly so we can accept a mail for one user but bounce it right away for another RCPT'er. The data_post hook should be able to put in the notes what addresses should go through, bounce and get rejected respectively, and qpsmtpd should just do the right thing. See also http://nntp.perl.org/group/perl.qpsmtpd/170 David Carraway has some thoughts for "user filters" http://nntp.perl.org/group/perl.qpsmtpd/2 qpsmtpd-0.84/t/000755 000765 000024 00000000000 11357265152 013330 5ustar00askstaff000000 000000 qpsmtpd-0.84/t/addresses.t000644 000765 000024 00000003277 11165323312 015471 0ustar00askstaff000000 000000 use Test::More tests => 23; 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:'))[0], 250, 'MAIL FROM:'); is($smtpd->transaction->sender->address, 'ask@perl.org', 'got the right sender'); is(($smtpd->command('MAIL FROM:'))[0], 250, 'MAIL FROM:'); is($smtpd->transaction->sender->address, 'ask @perl.org', 'got the right sender'); is(($smtpd->command('MAIL FROM:ask@perl.org'))[0], 250, 'MAIL FROM:ask@perl.org'); is($smtpd->transaction->sender->format, '', 'got the right sender'); is(($smtpd->command('MAIL FROM:ask@[1.2.3.4]'))[0], 250, 'MAIL FROM:ask@[1.2.3.4]'); is($smtpd->transaction->sender->format, '', 'got the right sender'); my $command = 'MAIL FROM: SIZE=1230'; is(($smtpd->command($command))[0], 250, $command); is($smtpd->transaction->sender->format, '', '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: SIZE=1230'; is(($smtpd->command($command))[0], 250, $command); is($smtpd->transaction->sender->format, '', 'got the right sender'); $command = 'MAIL FROM: SIZE=1230 CORRECT-WITHOUT-ARG'; is(($smtpd->command($command))[0], 250, $command); $command = 'MAIL FROM:'; is(($smtpd->command($command))[0], 250, $command); is($smtpd->transaction->sender->format, '<>', 'got the right sender'); qpsmtpd-0.84/t/config.t000644 000765 000024 00000001333 11165321462 014754 0ustar00askstaff000000 000000 #!/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 $me_config, '>', "./config.sample/me"; print $me_config "some.host.example.org"; close $me_config; } ok(my ($smtpd, $conn) = Test::Qpsmtpd->new_conn(), "get new connection"); is($smtpd->config('me'), 'some.host.example.org', 'config("me")'); # test for ignoring leading/trailing whitespace (relayclients has a # line with both) my $relayclients = join ",", sort $smtpd->config('relayclients'); is($relayclients, '127.0.0.1,192.168.', 'config("relayclients") are trimmed'); unlink "./config.sample/me"; qpsmtpd-0.84/t/helo.t000644 000765 000024 00000000671 11165323361 014442 0ustar00askstaff000000 000000 use Test::More tests => 12; 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'); qpsmtpd-0.84/t/misc.t000644 000765 000024 00000001552 11165325633 014451 0ustar00askstaff000000 000000 use Test::More tests => 14; use strict; use lib 't'; use_ok('Test::Qpsmtpd'); ok(my ($smtpd, $conn) = Test::Qpsmtpd->new_conn(), "get new connection"); # check_spamhelo plugin is(($smtpd->command('HELO yahoo.com'))[0], 550, 'HELO yahoo.com'); # fault method is(($smtpd->command('HELO localhost'))[0], 250, 'HELO localhost'); is(($smtpd->fault)->[0], 451, 'fault returns 451'); is(($smtpd->fault("test message"))->[1], "Internal error - try again later - test message", 'returns the input message' ); # vrfy command is(($smtpd->command('VRFY '))[0], 252, 'VRFY command'); # plugins/count_unrecognized_commands is(($smtpd->command('nonsense'))[0], 500, 'bad command 1'); is(($smtpd->command('nonsense'))[0], 500, 'bad command 2'); is(($smtpd->command('nonsense'))[0], 500, 'bad command 3'); is(($smtpd->command('nonsense'))[0], 521, 'bad command 4'); qpsmtpd-0.84/t/plugin_tests/000755 000765 000024 00000000000 11357265152 016050 5ustar00askstaff000000 000000 qpsmtpd-0.84/t/plugin_tests.t000644 000765 000024 00000000172 11165321462 016227 0ustar00askstaff000000 000000 #!/usr/bin/perl -w use strict; use lib 't'; use Test::Qpsmtpd; my $qp = Test::Qpsmtpd->new(); $qp->run_plugin_tests(); qpsmtpd-0.84/t/qpsmtpd-address.t000644 000765 000024 00000005571 11165321462 016632 0ustar00askstaff000000 000000 #!/usr/bin/perl use strict; $^W = 1; use Test::More qw/no_plan/; 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 = ''; $ao = Qpsmtpd::Address->parse($as); ok ($ao, "parse $as"); is ($ao->format, $as, "format $as"); $as = ''; $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 = '<"musa_ibrah@caramail.comandrea.luger"@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 = ''; $ao = Qpsmtpd::Address->parse($as); ok ($ao, "parse $as"); is ($ao->format, '<"foo\ bar"@example.com>', "format $as"); $as = 'foo@example.com'; $ao = Qpsmtpd::Address->new($as); ok ($ao, "new $as"); is ($ao->address, $as, "address $as"); $as = ''; $ao = Qpsmtpd::Address->new($as); ok ($ao, "new $as"); is ($ao->address, 'foo@example.com', "address $as"); $as = ''; $ao = Qpsmtpd::Address->new($as); ok ($ao, "new $as"); is ($ao->format, $as, "format $as"); $as = 'foo@foo.x.example.com'; 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('test@example.com'), 'test@example.com', 'address(test@example.com)'); $as = ''; $ao = Qpsmtpd::Address->new($as); ok ($ao, "new $as"); is ($ao->format, $as, "format $as"); is ("$ao", $as, "overloaded stringify $as"); $as = 'foo@foo.x.example.com'; 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( "musa_ibrah@caramail.comandrea.luger"@wifo.ac.at foo@example.com ask@perl.org foo@foo.x.example.com jpeacock@cpan.org test@example.com ); # NOTE that this is sorted by _host_ not by _domain_ my @sorted_list = map { Qpsmtpd::Address->new($_) } qw( jpeacock@cpan.org foo@example.com test@example.com foo@foo.x.example.com ask@perl.org "musa_ibrah@caramail.comandrea.luger"@wifo.ac.at ); my @test_list = sort @unsorted_list; is_deeply( \@test_list, \@sorted_list, "sort via overloaded 'cmp' operator"); # RT#38746 - non-RFC compliant address should return undef $as=''; $ao = Qpsmtpd::Address->new($as); is ($ao, undef, "illegal $as"); qpsmtpd-0.84/t/rset.t000644 000765 000024 00000000775 11165324632 014477 0ustar00askstaff000000 000000 use Test::More tests => 10; 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:'))[0], 250, 'MAIL FROM:'); is($smtpd->transaction->sender->address, 'ask@perl.org', 'got the right sender'); is(($smtpd->command('RSET'))[0], 250, 'RSET'); is($smtpd->transaction->sender, undef, 'No sender stored after rset'); qpsmtpd-0.84/t/tempstuff.t000644 000765 000024 00000001406 11165321462 015525 0ustar00askstaff000000 000000 #!/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); qpsmtpd-0.84/t/Test/000755 000765 000024 00000000000 11357265152 014247 5ustar00askstaff000000 000000 qpsmtpd-0.84/t/Test/Qpsmtpd/000755 000765 000024 00000000000 11357265152 015677 5ustar00askstaff000000 000000 qpsmtpd-0.84/t/Test/Qpsmtpd.pm000644 000765 000024 00000005044 11165321462 016232 0ustar00askstaff000000 000000 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_dirs { ('./plugins'); } sub log { my ($self, $trace, $hook, $plugin, @log) = @_; my $level = Qpsmtpd::TRACE_LEVEL() || 5; $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; qpsmtpd-0.84/t/Test/Qpsmtpd/Plugin.pm000644 000765 000024 00000001602 11165321346 017465 0ustar00askstaff000000 000000 # $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; qpsmtpd-0.84/t/plugin_tests/auth/000755 000765 000024 00000000000 11357265152 017011 5ustar00askstaff000000 000000 qpsmtpd-0.84/t/plugin_tests/check_badrcptto000644 000765 000024 00000000152 11165321346 021103 0ustar00askstaff000000 000000 sub register_tests { my $self = shift; $self->register_test("foo", 1); } sub foo { ok(1); } qpsmtpd-0.84/t/plugin_tests/dnsbl000644 000765 000024 00000001254 11165321462 017071 0ustar00askstaff000000 000000 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(''); my ($ret, $note) = $self->hook_rcpt($self->qp->transaction, $address); is($ret, DENY, "Check we got a DENY"); print("# dnsbl result: $note\n"); } qpsmtpd-0.84/t/plugin_tests/rcpt_ok000644 000765 000024 00000001166 11165321462 017432 0ustar00askstaff000000 000000 sub register_tests { my $self = shift; $self->register_test("test_returnval", 2); $self->register_test("foo", 1); } sub test_returnval { my $self = shift; my $address = Qpsmtpd::Address->parse(''); my ($ret, $note) = $self->hook_rcpt($self->qp->transaction, $address); is($ret, DENY, "Check we got a DENY"); print("# rcpt_ok result: $note\n"); $address = Qpsmtpd::Address->parse(''); ($ret, $note) = $self->hook_rcpt($self->qp->transaction, $address); is($ret, OK, "Check we got a OK"); # print("# rcpt_ok result: $note\n"); } sub foo { ok(1); } qpsmtpd-0.84/t/plugin_tests/auth/auth_flat_file000644 000765 000024 00000001256 11165321462 021700 0ustar00askstaff000000 000000 # -*-perl-*- [emacs] sub register_tests { my $self = shift; $self->register_test("test_authsql", 3); } my @u_list = qw ( good bad none ); my %u_data = ( good => [ 'good@example.com', OK, 'good_pass' ], bad => [ 'bad@example.com', DENY, 'not_bad_pass' ], none => [ 'none@example.com', DECLINED, '' ], ); sub test_authsql { my $self = shift; my ($tran, $ret, $note, $u, $r, $p, $a ); $tran = $self->qp->transaction; for $u ( @u_list ) { ( $a,$r,$p ) = @{$u_data{$u}}; ($ret, $note) = $self->authsql($tran,'CRAMMD5',$a,$p); defined $note or $note='No-Message'; is ($ret, $r, $note); # - for debugging. # warn "$note\n"; } } qpsmtpd-0.84/t/plugin_tests/auth/authdeny000644 000765 000024 00000000606 11165321462 020551 0ustar00askstaff000000 000000 # -*-perl-*- [emacs] sub register_tests { my $self = shift; $self->register_test("test_authdeny", 1); } sub test_authdeny { my $self = shift; my $address = Qpsmtpd::Address->parse(''); my ($ret, $note) = $self->hook_auth($self->qp->transaction, 'bogus_method', 'bogus_user'); is ($ret, DECLINED, "bogus_user is not free to abuse my relay"); } qpsmtpd-0.84/t/plugin_tests/auth/authnull000644 000765 000024 00000000574 11165321462 020570 0ustar00askstaff000000 000000 # -*-perl-*- [emacs] sub register_tests { my $self = shift; $self->register_test("test_authnull", 1); } sub test_authnull { my $self = shift; my $address = Qpsmtpd::Address->parse(''); my ($ret, $note) = $self->hook_auth($self->qp->transaction, 'bogus_method', 'bogus_user'); is ($ret, OK, "bogus_user is free to abuse my relay"); } qpsmtpd-0.84/plugins/async/000755 000765 000024 00000000000 11357265152 015663 5ustar00askstaff000000 000000 qpsmtpd-0.84/plugins/auth/000755 000765 000024 00000000000 11357265152 015507 5ustar00askstaff000000 000000 qpsmtpd-0.84/plugins/check_badmailfrom000644 000765 000024 00000003412 11231107355 020072 0ustar00askstaff000000 000000 # -*- perl -*- =head1 NAME check_badmailfrom - checks the badmailfrom config, with per-line reasons =head1 DESCRIPTION Reads the "badmailfrom" configuration like qmail-smtpd does. From the qmail-smtpd docs: "Unacceptable envelope sender addresses. qmail-smtpd will reject every recipient address for a message if the envelope sender address is listed in badmailfrom. A line in badmailfrom may be of the form @host, meaning every address at host." You may optionally include a message after the sender address (leave a space), which is used when rejecting the sender. =head1 NOTES According to the SMTP protocol, we can't reject until after the RCPT stage, so store it until later. =cut # TODO: add the ability to provide a custom default rejection reason sub hook_mail { my ($self, $transaction, $sender, %param) = @_; 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 $config (@badmailfrom) { my ($bad, $reason) = $config =~ /^\s*(\S+)(?:\s*(.*))?$/; $reason = "sorry, your envelope sender is in my badmailfrom list" unless $reason; next unless $bad; $bad = lc $bad; $self->log(LOGWARN, "Bad badmailfrom config: No \@ sign in $bad") and next unless $bad =~ m/\@/; $transaction->notes('badmailfrom', $reason) if ($bad eq $from) || (substr($bad,0,1) eq '@' && $bad eq "\@$host"); } return (DECLINED); } sub hook_rcpt { my ($self, $transaction, $rcpt, %param) = @_; my $note = $transaction->notes('badmailfrom'); if ($note) { $self->log(LOGINFO, $note); return (DENY, $note); } return (DECLINED); } qpsmtpd-0.84/plugins/check_badmailfromto000644 000765 000024 00000003277 11165321461 020450 0ustar00askstaff000000 000000 #! 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, %param) = @_; 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, %param) = @_; 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); } qpsmtpd-0.84/plugins/check_badrcptto000644 000765 000024 00000001347 11165321461 017606 0ustar00askstaff000000 000000 # this plugin checks the badrcptto config (like badmailfrom, but for rcpt address # rather than sender address) use Qpsmtpd::DSN; sub hook_rcpt { my ($self, $transaction, $recipient, %param) = @_; my @badrcptto = $self->qp->config("badrcptto") or return (DECLINED); return (DECLINED) unless $recipient->host && $recipient->user; my $host = lc $recipient->host; my $to = 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 $to; return Qpsmtpd::DSN->no_such_user("mail to $bad not accepted here") if substr($bad,0,1) eq '@' && $bad eq "\@$host"; } return (DECLINED); } qpsmtpd-0.84/plugins/check_badrcptto_patterns000644 000765 000024 00000002137 11165321462 021525 0ustar00askstaff000000 000000 =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 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); } qpsmtpd-0.84/plugins/check_basicheaders000644 000765 000024 00000003151 11165321462 020235 0ustar00askstaff000000 000000 #!/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->data_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); } qpsmtpd-0.84/plugins/check_earlytalker000644 000765 000024 00000015422 11165321462 020143 0ustar00askstaff000000 000000 =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, I or I. If I is specified, the connection will be allowed to proceed as normal, and only a warning will be logged. The default is I. =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). The default is to react at the SMTP greeting stage by issuing the apropriate response code and terminating the SMTP connection. =item check-at [ CONNECT | DATA ] Specifies when to check for early talkers. You can specify this option multiple times to check more than once. The default is I only. =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; } my %check_at; for (0..$#args) { next if $_ % 2; if (lc($args[$_]) eq 'check-at') { my $val = $args[$_ + 1]; $check_at{uc($val)}++; } } if (!%check_at) { $check_at{CONNECT} = 1; } $self->{_args} = { 'wait' => 1, 'action' => 'denysoft', 'defer-reject' => 0, @args, 'check-at' => \%check_at, }; if ( $qp->{conn} && $qp->{conn}->isa('Apache2::Connection')) { require APR::Const; APR::Const->import(qw(POLLIN SUCCESS)); $self->register_hook('connect', 'apr_connect_handler'); $self->register_hook('data', 'apr_data_handler'); } else { $self->register_hook('connect', 'connect_handler'); $self->register_hook('data', 'data_handler'); } $self->register_hook('mail', 'mail_handler') if $self->{_args}->{'defer-reject'}; 1; } sub apr_connect_handler { my ($self, $transaction) = @_; return DECLINED unless $self->{_args}{'check-at'}{CONNECT}; return DECLINED if ($self->qp->connection->notes('whitelisthost')); 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 apr_data_handler { my ($self, $transaction) = @_; return DECLINED unless $self->{_args}{'check-at'}{DATA}; return DECLINED if ($self->qp->connection->notes('whitelisthost')); 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]"); 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 unless $self->{_args}{'check-at'}{CONNECT}; return DECLINED if ($self->qp->connection->notes('whitelisthost')); $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 data_handler { my ($self, $transaction) = @_; my $in = new IO::Select; my $ip = $self->qp->connection->remote_ip; return DECLINED unless $self->{_args}{'check-at'}{DATA}; return DECLINED if ($self->qp->connection->notes('whitelisthost')); $in->add(\*STDIN) || return DECLINED; if ($in->can_read($self->{_args}->{'wait'})) { $self->log(LOGNOTICE, "remote host started talking before we said hello [$ip]"); 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, $transaction) = @_; 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; qpsmtpd-0.84/plugins/check_loop000644 000765 000024 00000002304 11165321462 016570 0ustar00askstaff000000 000000 #!/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; } qpsmtpd-0.84/plugins/check_norelay000644 000765 000024 00000002630 11165321462 017272 0ustar00askstaff000000 000000 =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 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); } qpsmtpd-0.84/plugins/check_relay000644 000765 000024 00000004362 11165321462 016741 0ustar00askstaff000000 000000 # this plugin checks the relayclients config file and # $ENV{RELAYCLIENT} to see if relaying is allowed. # use Net::IP qw(:PROC); sub hook_connect { my ($self, $transaction) = @_; my $connection = $self->qp->connection; # Check if this IP is allowed to relay my $client_ip = $self->qp->connection->remote_ip; # @crelay... for comparing, @srelay... for stripping my (@crelay_clients, @srelay_clients); my @relay_clients = $self->qp->config("relayclients"); for (@relay_clients) { my ($range_ip, $range_prefix) = ip_splitprefix($_); if($range_prefix){ # has a prefix, so due for comparing push @crelay_clients, $_; } else { # has no prefix, so due for splitting push @srelay_clients, $_; } } if (@crelay_clients){ my ($range_ip, $range_prefix, $rversion, $begin, $end, $bin_client_ip); my $cversion = ip_get_version($client_ip); for (@crelay_clients) { # Get just the IP from the CIDR range, to get the IP version, so we can # get the start and end of the range ($range_ip, $range_prefix) = ip_splitprefix($_); $rversion = ip_get_version($range_ip); ($begin, $end) = ip_normalize($_, $rversion); # expand the client address (zero pad it) before converting to binary $bin_client_ip = ip_iptobin(ip_expand_address($client_ip, $cversion), $cversion); if (ip_bincomp($bin_client_ip, 'gt', ip_iptobin($begin, $rversion)) && ip_bincomp($bin_client_ip, 'lt', ip_iptobin($end, $rversion))) { $connection->relay_client(1); last; } } } # If relay_client is already set, no point checking again if (@srelay_clients && !$connection->relay_client) { my $more_relay_clients = $self->qp->config("morerelayclients", "map"); my %srelay_clients = map { $_ => 1 } @srelay_clients; $client_ip =~ s/::/:/; ($connection->relay_client(1) && undef($client_ip)) if $client_ip eq ":1"; while ($client_ip) { if (exists($ENV{RELAYCLIENT}) or exists($srelay_clients{$client_ip}) or exists($more_relay_clients->{$client_ip})) { $connection->relay_client(1); last; } $client_ip =~ s/(\d|\w)+(:|\.)?$//; # strip off another 8 bits } } return (DECLINED); } qpsmtpd-0.84/plugins/check_spamhelo000644 000765 000024 00000001505 11216622401 017423 0ustar00askstaff000000 000000 =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 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_DISCONNECT, "Sorry, I don't believe that you are $host."); } } return DECLINED; } # also support EHLO *hook_ehlo = \&hook_helo; qpsmtpd-0.84/plugins/connection_time000644 000765 000024 00000003174 11165321462 017645 0ustar00askstaff000000 000000 =head1 NAME connection_time - log the duration of a connection =head1 DESCRIPTION The B plugin records the time of a connection between the first and the last possible hook in qpsmtpd (I and I) and writes a C (default, see below) line to the log. =head1 CONFIG One optional argument: the name of the log level (e.g. C, C, ...) the message should be logged with. Defaults to C. =cut use Time::HiRes qw(gettimeofday tv_interval); use Qpsmtpd::Constants; sub register { my ($self, $qp, @args) = @_; die "too many arguments" if @args > 1; $self->{_level} = shift @args; $self->{_level} = 'LOGNOTICE' unless defined $self->{_level}; $self->{_level} = Qpsmtpd::Constants::log_level($self->{_level}); $self->{_level} = LOGNOTICE unless defined $self->{_level}; } sub hook_pre_connection { my ($self, @foo) = @_; $self->{_connection_start} = [gettimeofday]; return (DECLINED); } sub hook_post_connection { my ($self, @foo) = @_; if ($self->{_connection_start}) { my $remote = $self->connection->remote_ip; my $elapsed = sprintf( "%.3f", tv_interval( $self->{_connection_start}, [gettimeofday] ) ); $self->log($self->{_level}, "Connection time from $remote: $elapsed sec."); } return (DECLINED); } # vim: ts=4 sw=4 expandtab syn=perl qpsmtpd-0.84/plugins/content_log000644 000765 000024 00000001237 11165321462 017001 0ustar00askstaff000000 000000 # -*- 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"); } qpsmtpd-0.84/plugins/count_unrecognized_commands000644 000765 000024 00000002461 11165321462 022253 0ustar00askstaff000000 000000 # -*- 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; } } sub hook_connect { my ($self, $transaction) = @_; $self->qp->connection->notes('unrec_cmd_count', 0); return DECLINED; } 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; } qpsmtpd-0.84/plugins/dns_whitelist_soft000644 000765 000024 00000010640 11165321462 020377 0ustar00askstaff000000 000000 =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 means that the remote HOST address can be selectively exempted at other stages by plugins testing for a 'whitelisthost' connection note. =back 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. If you switch to qpsmtpd-async and to the async version of this plugin, then the 'whitelisthost' connection note will be available to the other 'connect' hooks, see the documentation of the async plugin. =head1 AUTHOR John Peacock Based on the 'whitelist_soft' plugin by Gavin Carr , based on the 'whitelist' plugin by Devin Carraway . =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, %param) = @_; 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; qpsmtpd-0.84/plugins/dnsbl000644 000765 000024 00000021471 11165321462 015572 0ustar00askstaff000000 000000 #!perl -w =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. =cut 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(); my $dom; for my $dnsbl (keys %dnsbl_zones) { # fix to find A records, if the dnsbl_zones line has a second field 20/1/04 ++msp $dom->{"$reversed_ip.$dnsbl"} = 1; if (defined($dnsbl_zones{$dnsbl})) { $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for A record in the background"); $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); $self->qp->connection->notes('dnsbl_domains', $dom); 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 $dom = $conn->notes('dnsbl_domains'); my $remote_ip = $self->qp->connection->remote_ip; my $result; $self->log(LOGDEBUG, "waiting for dnsbl dns"); # don't wait more than 8 seconds here my @ready = $sel->can_read(8); $self->log(LOGDEBUG, "DONE waiting for dnsbl dns, got " , scalar @ready, " answers ...") ; return '' unless @ready; for my $socket (@ready) { my $query = $res->bgread($socket); $sel->remove($socket); undef $socket; my $dnsbl; if ($query) { my $a_record = 0; foreach my $rr ($query->answer) { my $name = $rr->name; $self->log(LOGDEBUG, "name $name"); next unless $dom->{$name}; $self->log(LOGDEBUG, "name $name was queried"); $a_record = 1 if $rr->type eq "A"; ($dnsbl) = ($name =~ m/(?:\d+\.){4}(.*)/) unless $dnsbl; $dnsbl = $name unless $dnsbl; next unless $rr->type eq "TXT"; $self->log(LOGDEBUG, "got txt record"); $result = $rr->txtdata and last; } #$a_record and $result = "Blocked by $dnsbl"; if ($a_record) { if (defined $dnsbl_zones{$dnsbl}) { $result = $dnsbl_zones{$dnsbl}; #$result =~ s/%IP%/$ENV{'TCPREMOTEIP'}/g; $result =~ s/%IP%/$remote_ip/g; } else { # shouldn't get here? $result = "Blocked by $dnsbl"; } } } else { $self->log(LOGERROR, "$dnsbl query failed: ", $res->errorstring) unless $res->errorstring eq "NXDOMAIN"; } 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, %param) = @_; my $connection = $self->qp->connection; # RBLSMTPD being non-empty means it contains the failure message to return if (defined ($ENV{'RBLSMTPD'}) && $ENV{'RBLSMTPD'} ne '') { my $result = $ENV{'RBLSMTPD'}; my $remote_ip = $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 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 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 qpsmtpd-0.84/plugins/domainkeys000644 000765 000024 00000005267 11165321462 016640 0ustar00askstaff000000 000000 sub init { my ($self, $qp, %args) = @_; foreach my $key ( %args ) { $self->{$key} = $args{$key}; } } sub hook_data_post { use Mail::DomainKeys::Message; use Mail::DomainKeys::Policy; my ($self, $transaction) = @_; # if this isn't signed, just move along return DECLINED unless $transaction->header->get('DomainKey-Signature'); my @body; $transaction->body_resetpos; $transaction->body_getline; # \r\n seperator is NOT part of the body while (my $line = $transaction->body_getline) { push @body, $line; } my $message = load Mail::DomainKeys::Message( HeadString => $transaction->header->as_string, BodyReference => \@body) or $self->log(LOGWARN, "unable to load message"), return DECLINED; # no sender domain means no verification $message->senderdomain or return DECLINED; my $status; # key testing if ( $message->testing ) { # Don't do anything else $status = "testing"; } elsif ( $message->signed and $message->verify ) { # verified: add good header $status = $message->signature->status; } else { # not signed or not verified my $policy = fetch Mail::DomainKeys::Policy( Protocol => "dns", Domain => $message->senderdomain ); if ( $policy ) { if ( $policy->testing ) { # Don't do anything else $status = "testing"; } elsif ( $policy->signall ) { # if policy requires all mail to be signed $status = undef; } else { # $policy->signsome # not signed and domain doesn't sign all $status = "no signature"; } } else { $status = $message->signed ? "non-participant" : "no signature"; } } if ( defined $status ) { $transaction->header->replace("DomainKey-Status", $status); $self->log(LOGWARN, "DomainKeys-Status: $status"); return DECLINED; } else { $self->log(LOGERROR, "DomainKeys signature failed to verify"); if ( $self->{warn_only} ) { return DECLINED; } else { return (DENY, "DomainKeys signature failed to verify"); } } } =cut =head1 NAME domainkeys: validate a DomainKeys signature on an incoming mail =head1 SYNOPSIS domainkeys [warn_only 1] Performs a DomainKeys validation on the message. Takes a single configuration warn_only 1 which means that messages which are not correctly signed (i.e. signed but modified or deliberately forged) will not be DENY'd, but an error will still be issued to the logfile. =head1 COPYRIGHT Copyright (C) 2005-2006 John Peacock. Portions Copyright (C) 2004 Anthony D. Urso. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. qpsmtpd-0.84/plugins/dont_require_anglebrackets000644 000765 000024 00000000661 11165321462 022053 0ustar00askstaff000000 000000 # # dont_require_anglebrackets - accept addresses in MAIL FROM:/RCPT TO: # commands without surrounding <> # sub hook_mail_pre { my ($self,$transaction, $addr) = @_; unless ($addr =~ /^<.*>$/) { $addr = "<".$addr.">"; } return (OK, $addr); } sub hook_rcpt_pre { my ($self,$transaction, $addr) = @_; unless ($addr =~ /^<.*>$/) { $addr = "<".$addr.">"; } return (OK, $addr); } qpsmtpd-0.84/plugins/greylisting000644 000765 000024 00000022753 11165321462 017034 0ustar00askstaff000000 000000 =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 Whether to include the remote ip address in tracking connections. Default: 1. =item sender Whether to include the sender in tracking connections. Default: 0. =item recipient Whether to include the recipient in tracking connections. Default: 0. =item deny_late Whether to defer denials during the 'mail' hook until 'data_post' e.g. to allow per-recipient logging. Default: 0. =item black_timeout 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 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 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 db_dir Path to a directory in which the greylisting DB will be stored. This directory must be writable by the qpsmtpd user. By default, the first usable directory from the following list will be used: =over 4 =item /var/lib/qpsmtpd/greylisting =item I/var/db (where BINDIR is the location of the qpsmtpd binary) =item I/config =back =item per_recipient Flag to indicate whether to use per-recipient configs. =item per_recipient_db Flag to indicate whether to use per-recipient greylisting databases (default is to use a shared database). Per-recipient configuration directories, if determined, supercede I. =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 . =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 %PERMITTED_ARGS = map { $_ => 1 } qw(per_recipient remote_ip sender recipient black_timeout grey_timeout white_timeout deny_late mode db_dir); 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 $PERMITTED_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'); if ($config->{db_dir} && $config->{db_dir} =~ m{^([-a-zA-Z0-9./_]+)$}) { $config->{db_dir} = $1; } # Setup database location my $dbdir = $transaction->notes('per_rcpt_configdir') if $config->{per_recipient_db}; for my $d ($dbdir, $config->{db_dir}, "/var/lib/qpsmtpd/greylisting", "$QPHOME/var/db", "$QPHOME/config") { last if $dbdir ||= $d && -d $d && $d; } my $db = "$dbdir/$DB"; $self->log(LOGINFO,"using $db as greylisting database"); 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 qpsmtpd-0.84/plugins/help000644 000765 000024 00000007516 11165321462 015424 0ustar00askstaff000000 000000 # # # =head1 NAME help - default help plugin for qpsmtpd =head1 DESCRIPTION The B plugin gives the answers for the help command. It can be configured to return C<502 Not implemented>. Without any arguments, the C is set to F<./help/>. =head1 OPTIONS =over 4 =item not_implemented (1|0) If this option is set (and the next argument is true), the plugin answers, that the B command is not implemented =item help_dir /path/to/help/files/ When a client requests help for C the file F is dumped to the client if it exists. =item COMMAND HELPFILE Any other argument pair is treated as command / help file pair. The file is expexted in the F sub directory. If the client calls C the contents of HELPFILE are dumped to him. =back =head1 NOTES The hard coded F path should be changed. =cut my %config = (); sub register { my ($self,$qp,%args) = @_; my ($file, $cmd); unless (%args) { $config{help_dir} = './help/'; } foreach (keys %args) { /^(\w+)$/ or $self->log(LOGWARN, "Invalid argument for the 'help' plugin $_"), next; $cmd = $1; if ($cmd eq 'not_implemented') { $config{'not_implemented'} = $args{'not_implemented'}; } elsif ($cmd eq 'help_dir') { $file = $args{$cmd}; $file =~ m#^([\w\.\-/]+)$# or $self->log(LOGERROR, "Invalid charachters in filename for command $cmd"), next; $config{'help_dir'} = $1; } else { $file = $args{$cmd}; $file =~ m#^([\w\.\-/]+)$# or $self->log(LOGERROR, "Invalid charachters in filename for command $cmd"), next; $file = $1; if ($file =~ m#/#) { -e $file or $self->log(LOGWARN, "No help file for command '$cmd'"), next; } else { $file = "help/$file"; if (-e "help/$file") { ## FIXME: path $file = "help/$file"; } else { $self->log(LOGWARN, "No help file for command '$cmd'"); next; } } $config{lc $cmd} = $file; } } return DECLINED; } sub hook_help { my ($self, $transaction, @args) = @_; my ($help, $cmd); if ($config{not_implemented}) { $self->qp->respond(502, "Not implemented."); return DONE; } return OK, "Try 'HELP COMMAND' for getting help on COMMAND" unless $args[0]; $cmd = lc $args[0]; unless ($cmd =~ /^(\w+)$/) { # else someone could request # "HELP ../../../../../../../../etc/passwd" $self->qp->respond(502, "Invalid command name"); return DONE; } $cmd = $1; if (exists $config{$cmd}) { $help = read_helpfile($config{$cmd}, $cmd) or $self->log(LOGERROR, "failed to open help file for $cmd: $!"), return OK, "No help available for SMTP command: $cmd"; } elsif (exists $config{'help_dir'} && -e $config{'help_dir'}."/$cmd") { $help = read_helpfile($config{help_dir}."/$cmd", $cmd) or $self->log(LOGERROR, "failed to open help file for $cmd: $!"), return OK, "No help available for SMTP command: $cmd"; } $help = "No help available for SMTP command: $cmd" # empty file unless $help; return OK, split(/\n/, $help); } sub read_helpfile { my ($file,$cmd) = @_; my $help; open HELP, $file or return undef; { local $/ = undef; $help = ; }; close HELP; return $help; } # vim: ts=4 sw=4 expandtab syn=perl qpsmtpd-0.84/plugins/hosts_allow000644 000765 000024 00000004665 11165321462 017034 0ustar00askstaff000000 000000 =head1 NAME hosts_allow - decide if a host is allowed to send mail =head1 DESCRIPTION The B 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. 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 qpsmtpd-0.84/plugins/http_config000644 000765 000024 00000002374 11165321462 016775 0ustar00askstaff000000 000000 =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; } qpsmtpd-0.84/plugins/ident/000755 000765 000024 00000000000 11357265152 015651 5ustar00askstaff000000 000000 qpsmtpd-0.84/plugins/logging/000755 000765 000024 00000000000 11357265152 016174 5ustar00askstaff000000 000000 qpsmtpd-0.84/plugins/milter000644 000765 000024 00000015461 11165321462 015766 0ustar00askstaff000000 000000 =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 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, %param) = @_; 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, %param) = @_; 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; } qpsmtpd-0.84/plugins/noop_counter000644 000765 000024 00000003300 11165321462 017171 0ustar00askstaff000000 000000 # # # =head1 NAME noop_counter - disconnect after too many consecutive NOOPs, example plugin for the hook_noop() =head1 DESCRIPTION The B counts the number of consecutive C commands given by a client and disconnects after a given number. Any other command than a C resets the counter. One argument may be given: the number of Cs after which the client will be disconnected. =head1 NOTE This plugin should be loaded early to be able to reset the counter on any other command. =cut sub register { my ($self, $qp, @args) = @_; $self->{_noop_count} = 0; $self->{_max_noop} = 3; if ($args[0] && $args[0] =~ /^\d+$/) { $self->{_max_noop} = shift @args; } } sub hook_noop { my ($self, $transaction, @args) = @_; ++$self->{_noop_count}; ### the following block is not used, RFC 2821 says we SHOULD ignore ### any arguments... so we MAY return an error if we want to :-) # return (DENY, "Syntax error, NOOP does not take any arguments") # if $args[0]; if ($self->{_noop_count} >= $self->{_max_noop}) { return (DENY_DISCONNECT, "Stop wasting my time, too many consecutive NOOPs"); } return (DECLINED); } sub reset_noop_counter { $_[0]->{_noop_count} = 0; return (DECLINED); } # and bind the counter reset to the hooks, QUIT not useful here: *hook_helo = *hook_ehlo = # HELO / EHLO *hook_mail = # MAIL FROM: *hook_rcpt = # RCPT TO: *hook_data = # DATA *hook_reset_transaction = # RSET *hook_vrfy = # VRFY *hook_help = # HELP \&reset_noop_counter; # vim: ts=4 sw=4 expandtab syn=perl qpsmtpd-0.84/plugins/parse_addr_withhelo000644 000765 000024 00000003057 11165321462 020477 0ustar00askstaff000000 000000 # parse_addr_withhelo # # strict RFC 821 forbids parameters after the # MAIL FROM: # and # RCPT TO: # # load this plugin to enforce, else the default EHLO parsing with # parameters is done. # sub hook_mail_parse { my $self = shift; return (OK, \&_parse) if ($self->qp->connection->hello eq 'helo'); return (DECLINED); } sub hook_rcpt_parse { my $self = shift; return (OK, \&_parse) if ($self->qp->connection->hello eq 'helo'); return (DECLINED); } sub _parse { my ($self,$cmd,$line) = @_; $self->log(LOGDEBUG, "_parse() cmd=[$cmd], line=[$line]"); if ($cmd eq 'mail') { return(DENY, "Syntax error in command") unless ($line =~ s/^from:\s*//i); } else { # cmd eq 'rcpt' return(DENY, "Syntax error in command") unless ($line =~ s/^to:\s*//i); } if ($line =~ s/^(<.*>)\s*//) { my $addr = $1; return (DENY, "No parameters allowed in ".uc($cmd)) if ($line =~ /^\S/); return (OK, $addr, ()); } ## now, no <> are given $line =~ s/\s*$//; if ($line =~ /\@/) { return (DENY, "No parameters allowed in ".uc($cmd)) if ($line =~ /\@\S+\s+\S/); return (OK, $line, ()); } if ($cmd eq "mail") { return (OK, "<>") unless $line; # 'MAIL FROM:' -> 'MAIL FROM:<>' return (DENY, "Could not parse your MAIL FROM command"); } else { return (DENY, "Could not parse your RCPT TO command") unless $line =~ /^(postmaster|abuse)$/i; } } qpsmtpd-0.84/plugins/queue/000755 000765 000024 00000000000 11357265152 015672 5ustar00askstaff000000 000000 qpsmtpd-0.84/plugins/quit_fortune000644 000765 000024 00000000700 11165321462 017204 0ustar00askstaff000000 000000 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; my @fortune = `$fortune -s`; @fortune = map { chop; s/^/ \/ /; $_ } @fortune; $qp->respond(221, $qp->config('me') . " closing connection.", @fortune); return DONE; } qpsmtpd-0.84/plugins/random_error000644 000765 000024 00000003313 11165321462 017154 0ustar00askstaff000000 000000 =head1 NAME random_error =head1 DESCRIPTION This plugin randomly disconnects and issues DENYSOFTs. =head1 CONFIG one parameter is allowed, which is how often to error, as a percentage of messages. The default is 1. Use a negative number to disable. 2/5 of failures are DENYSOFT_DISOCNNECT, 3/5 simply DENYSOFT. For use with other plugins, scribble the revised failure rate to $self->qp->connection->notes('random_fail_%'); =cut sub register { my ($self, $qp, @args) = @_; die "Invalid args: '@args'" unless @args < 2; ($self->{__PACKAGE__.'_how'}) = $args[0] || 1; } sub NEXT() { DECLINED } sub random_fail { my $fpct = $_[0]->qp->connection->notes('random_fail_%'); =head calculating the probability of failure There are six tests a message must pass to reach the queueing stage, and we wish to provide random failure for each one, with the combined probability being out configuration argument. So we want to solve this equation: (1-x) ** 6 = ( 1 - input_number ) or x = 1 - ( (1 - input_number ) ** (1/6) ) =cut my $successp = 1 - ($fpct / 100); $_[0]->log(LOGINFO, "to fail, rand(1) must be more than ". ($successp ** (1 / 6)) ); rand(1) < ($successp ** (1 / 6)) and return NEXT; rand(5) < 2 and return (DENYSOFT_DISCONNECT, "random failure"); return (DENYSOFT, "random failure"); } sub hook_connect { $_[0]->qp->connection->notes('random_fail_%', $_[0]->{__PACKAGE__.'_how'}); goto &random_fail } sub hook_helo { goto &random_fail } sub hook_ehlo { goto &random_fail } sub hook_mail { goto &random_fail } sub hook_rcpt { goto &random_fail } sub hook_data { goto &random_fail } sub hook_data_post { goto &random_fail } qpsmtpd-0.84/plugins/rcpt_ok000644 000765 000024 00000002310 11165321462 016120 0ustar00askstaff000000 000000 # 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, %param) = @_; 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(); } } qpsmtpd-0.84/plugins/rcpt_regexp000644 000765 000024 00000006061 11165321462 017010 0ustar00askstaff000000 000000 =head1 NAME rcpt_regexp - check recipients against a list of regular expressions =head1 DESCRIPTION B reads a list of regular expressions, return codes and comments from the I config file. If the regular expression does NOT match I, it is used as a string which is compared with I. The recipient addresses are checked against this list, and if the first matches, the return code from that line and the comment are returned to qpsmtpd. Return code can be any valid plugin return code from L. Matching is always done case insenstive. =head1 CONFIG FILE The config file I contains lines with a perl RE, including the "/"s, a return code and a comment, which will be returned to the sender, if the code is not OK or DECLINED. Example: # rcpt_regexp - config for rcpt_regexp plugin me@myhost.org OK Accepting mail /^user\d+\@doma\.in$/ OK Accepting mail info@myhost.com DENY User not found. /^unused\@.*/ DENY User not found. /^.*$/ DECLINED Fall through to next rcpt plugin =head1 NOTE The C config file should be writeable by trusted users only: the regexes are compiled with I. =head1 COPYRIGHT AND LICENSE Copyright (c) 2005 Hanno Hecker 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 Qpsmtpd::Constants; sub hook_rcpt { my ($self, $transaction, $recipient) = @_; return (DECLINED) unless $recipient->host && $recipient->user; my $rcpt = lc $recipient->user . '@' . $recipient->host; my ($re, $const, $comment, $str, $ok, $err); foreach ($self->qp->config("rcpt_regexp")) { s/^\s*//; ($re, $const, $comment) = split /\s+/, $_, 3; $str = undef; if ($re =~ m#^/(.*)/$#) { $re = $1; $ok = eval { $re = qr/$re/i; }; if ($@) { ($err = $@) =~ s/\s*at \S+ line \d+\.\s*$//; $self->log(LOGWARN, "REGEXP '$re' not valid: $err"); next; } $re = $ok; } else { $str = lc $re; } unless (defined $const) { $self->(LOGWARN, "rcpt_regexp - no return code"); next; } $ok = $const; $const = Qpsmtpd::Constants::return_code($const); unless (defined $const) { $self->log(LOGWARN, "rcpt_regexp - '$ok' is not a valid " . "constant, ignoring this line" ); next; } if (defined $str) { next unless $str eq $rcpt; $self->log(LOGDEBUG, "String $str matched $rcpt, returning $ok"); } else { next unless $rcpt =~ $re; $self->log(LOGDEBUG, "RE $re matched $rcpt, returning $ok"); } return ($const, $comment); } return (DECLINED); } # vim: ts=4 sw=4 expandtab syn=perl qpsmtpd-0.84/plugins/relay_only000644 000765 000024 00000001274 11165321462 016644 0ustar00askstaff000000 000000 #!/usr/bin/perl -w =head1 NAME relay_only - this plugin only permits relaying =head1 SYNOPSIS # in config/plugins check_relay relay_only # other rcpt hooks go here =head1 DESCRIPTION This plugin can be used for the case where a server is used as the smart relay host for internal users and external/authenticated users, but should not be considered a normal inbound MX server It should be configured to be run _AFTER_ check_relay and before other RCPT hooks! Only clients that have authenticated or are listed in the relayclient file will be allowed to send mail. =cut sub hook_rcpt { if ( shift->qp->connection->relay_client ) { return (OK); } else { return (DENY); } } qpsmtpd-0.84/plugins/require_resolvable_fromhost000644 000765 000024 00000007564 11335702065 022313 0ustar00askstaff000000 000000 use Qpsmtpd::DSN; use Net::DNS qw(mx); use Socket; use Net::IP qw(:PROC); use Qpsmtpd::TcpServer; my %invalid = (); my $has_ipv6 = Qpsmtpd::TcpServer::has_ipv6(); sub hook_mail { my ($self, $transaction, $sender, %param) = @_; return DECLINED if ($self->qp->connection->notes('whitelisthost')); 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) { $transaction->notes('temp_resolver_failed', $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 hook_rcpt { my ($self, $transaction, $recipient, %args) = @_; if (my $host = $self->qp->connection->notes('temp_resolver_failed')) { # default of temp_resolver_failed is DENYSOFT return Qpsmtpd::DSN->temp_resolver_failed("Could not resolve " . $host); } return DECLINED; } sub check_dns { my ($self, $host) = @_; my @host_answers; # 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) { # if any MX is valid, then we consider the domain # resolvable return 1 if mx_valid($self, $mx->exchange, $host); } # if there are MX records, and we got here, # then none of them are valid return 0 if (@mx > 0); my $query = $res->search($host); if ($query) { foreach my $rrA ($query->answer) { push(@host_answers, $rrA); } } if ($has_ipv6) { my $query = $res->search($host, 'AAAA'); if ($query) { foreach my $rrAAAA ($query->answer) { push(@host_answers, $rrAAAA); } } } if (@host_answers) { foreach my $rr (@host_answers) { return is_valid($rr->address) if $rr->type eq "A" or $rr->type eq "AAAA"; return mx_valid($self, $rr->exchange, $host) if $rr->type eq "MX"; } } else { $self->log(LOGWARN, "$$ query for $host failed: ", $res->errorstring) unless $res->errorstring eq "NXDOMAIN"; } return 0; } sub is_valid { my $ip = shift; my ($net,$mask); ### while (($net,$mask) = each %invalid) { ### ... does NOT reset to beginning, will start on ### 2nd invocation after where it denied the first time..., so ### 2nd time the same "MAIL FROM" would be accepted! foreach $net (keys %invalid) { $mask = $invalid{$net}; $mask = pack "B32", "1"x($mask)."0"x(32-$mask); return 0 if join(".", unpack("C4", inet_aton($ip) & $mask)) eq $net; } return 1; } sub mx_valid { my ($self, $name, $host) = @_; my $res = new Net::DNS::Resolver; # IP in MX return is_valid($name) if ip_is_ipv4($name) or ip_is_ipv6($name); my @mx_answers; my $query = $res->search($name, 'A'); if ($query) { foreach my $rrA ($query->answer) { push(@mx_answers, $rrA); } } if ($has_ipv6) { my $query = $res->search($name, 'AAAA'); if ($query) { foreach my $rrAAAA ($query->answer) { push(@mx_answers, $rrAAAA); } } } if (@mx_answers) { foreach my $rr (@mx_answers) { next unless $rr->type eq "A" or $rr->type eq "AAAA"; return is_valid($rr->address); } } else { $self->log(LOGWARN, "$$ query for $host failed: ", $res->errorstring) unless $res->errorstring eq "NXDOMAIN"; } return 0; } # vim: ts=2 sw=2 expandtab syn=perlqpsmtpd-0.84/plugins/rhsbl000644 000765 000024 00000011021 11231107361 015562 0ustar00askstaff000000 000000 #!perl -w sub register { my ($self, $qp, $denial ) = @_; if ( defined $denial and $denial =~ /^disconnect$/i ) { $self->{_rhsbl}->{DENY} = DENY_DISCONNECT; } else { $self->{_rhsbl}->{DENY} = DENY; } } sub hook_mail { my ($self, $transaction, $sender, %param) = @_; my $res = new Net::DNS::Resolver; my $sel = IO::Select->new(); my %rhsbl_zones_map = (); # Perform any RHS lookups in the background. We just send the query packets # here and pick up any results in the RCPT handler. # 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) { # fix to find TXT records, if the rhsbl_zones line doesn't have second field if (defined($rhsbl_zones{$rhsbl})) { $self->log(LOGDEBUG, "Checking $host.$rhsbl for A record in the background"); $sel->add($res->bgsend("$host.$rhsbl")); } else { $self->log(LOGDEBUG, "Checking $host.$rhsbl for TXT record in the background"); $sel->add($res->bgsend("$host.$rhsbl", "TXT")); } $rhsbl_zones_map{"$host.$rhsbl"} = $rhsbl_zones{$rhsbl}; } } %{$self->{_rhsbl_zones_map}} = %rhsbl_zones_map; $transaction->notes('rhsbl_sockets', $sel); } else { $self->log(LOGDEBUG, 'no RHS checks necessary'); } 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 ($self->{_rhsbl}->{DENY}, "Mail from $host rejected because it " . $self->{_rhsbl_zones_map}{$result}); } else { return ($self->{_rhsbl}->{DENY}, "Mail from HELO $hello rejected because it " . $self->{_rhsbl_zones_map}{$result}); } } return ($self->{_rhsbl}->{DENY}, $result) if $result; return DECLINED; } sub process_sockets { my ($self) = @_; my $trans = $self->transaction; my $result = ''; return $trans->notes('rhsbl') if $trans->notes('rhsbl'); my $res = new Net::DNS::Resolver; my $sel = $trans->notes('rhsbl_sockets') or return ''; $self->log(LOGDEBUG, 'waiting for rhsbl dns'); # don't wait more than 8 seconds here my @ready = $sel->can_read(8); $self->log(LOGDEBUG, 'DONE waiting for rhsbl dns, got ' , scalar @ready, ' answers ...') ; return '' unless @ready; for my $socket (@ready) { my $query = $res->bgread($socket); $sel->remove($socket); undef $socket; if ($query) { foreach my $rr ($query->answer) { $self->log(LOGDEBUG, 'got an ' . $rr->type . ' record ' . $rr->name); if ($rr->type eq 'A') { $result = $rr->name; $self->log(LOGDEBUG, "A record found for $result with IP " . $rr->address); last; } elsif ($rr->type eq 'TXT') { $result = $rr->txtdata; $self->log(LOGDEBUG, "TXT record found: " . $rr->txtdata); last; } } } else { $self->log(LOGCRIT, "query failed: ", $res->errorstring) unless $res->errorstring eq 'NXDOMAIN'; } if ($result) { #kill any other pending I/O $trans->notes('rhsbl_sockets', undef); return $trans->notes('rhsbl', $result); } } if ($sel->count) { # loop around if we have dns results left return $self->process_sockets(); } # if there was more to read; then forget it $trans->notes('rhsbl_sockets', undef); return $trans->notes('rhsbl', $result); } sub hook_disconnect { my ($self, $transaction) = @_; $transaction->notes('rhsbl_sockets', undef); return DECLINED; } 1; =head1 NAME rhsbl - handle RHSBL lookups =head1 DESCRIPTION Pluging that checks the host part of the sender's address against a configurable set of RBL services. =head1 CONFIGURATION This plugin reads the lists to use from the rhsbl_zones configuration file. Normal domain based dns blocking lists ("RBLs") which contain TXT records are specified simply as: dsn.rfc-ignorant.org To configure RBL services which do not contain TXT records in the DNS, but only A records, specify, after a whitespace, your own error message to return in the SMTP conversation e.g. abuse.rfc-ignorant.org does not support abuse@domain =cut qpsmtpd-0.84/plugins/sender_permitted_from000644 000765 000024 00000006557 11165321462 021060 0ustar00askstaff000000 000000 =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 '' 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, %param) = @_; 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, %param) = @_; # 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; } qpsmtpd-0.84/plugins/spamassassin000644 000765 000024 00000020756 11335434344 017205 0ustar00askstaff000000 000000 #!perl -w =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 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? :-) It looks like this in practice: spamassassin reject_threshold 7 leave_old_headers keep =over 4 =item reject_threshold [threshold] Set the threshold where 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. Depending on your spamassassin configuration a reasonable setting is typically somewhere between 12 to 20. The default is to never reject mail based on the SpamAssassin score. =item munge_subject_threshold [threshold] Set the threshold where the plugin will prefix the subject with the value of C. A modified 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 subject_prefix [prefix] What to prefix the subject with if the message is detected as spam (i.e. if score is greater than C. Defaults to C<*** SPAM ***> =item spamd_socket [/path/to/socket|spamd.host:port] Beginning with Mail::SpamAssassin 2.60, it is possible to use Unix domain sockets for spamd. This is faster and more secure than using a TCP connection, but if you run spamd on a remote machine, you need to use 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'). =item spamd_user [username] The username to pass to spamd, if different from the user qpsmtpd runs as. =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->data_size > 500_000; my $remote = 'localhost'; my $port = 783; if (defined $self->{_args}->{spamd_socket} && $self->{_args}->{spamd_socket} =~ /^([\w.-]+):(\d+)$/) { $remote = $1; $port = $2; } if ($port =~ /\D/) { $port = getservbyname($port, 'tcp') } die "No port" unless $port; my $iaddr = inet_aton($remote) or $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 = $self->{_args}->{spamd_user} || 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 = ; # get the first protocol lines out if ($line0) { $line0 =~ s/\r?\n$//; $self->log(LOGDEBUG, "check_spam: spamd: $line0"); $self->_cleanup_spam_header($transaction, 'X-Spam-Check-By'); $transaction->header->add("X-Spam-Check-By", $self->qp->config('me'), 0); } my ($flag, $hits, $required); while () { s/\r?\n$//; $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 = || ''; close SPAMD; $tests =~ s/\015//; # hack for outlook $flag = $flag eq 'True' ? 'Yes' : 'No'; $self->log(LOGDEBUG, "check_spam: finished reading from spamd"); $self->_cleanup_spam_header($transaction, 'X-Spam-Flag'); $self->_cleanup_spam_header($transaction, 'X-Spam-Status'); $self->_cleanup_spam_header($transaction, 'X-Spam-Level'); $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); my $length = int($hits); $length = 1 if $length < 1; $length = 50 if $length > 50; $transaction->header->add('X-Spam-Level', '*' x $length, 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_prefix = $self->qp->config('subject_prefix') || '*** SPAM ***'; my $subject = $transaction->header->get('Subject') || ''; $transaction->header->replace('Subject', "$subject_prefix $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; sub _cleanup_spam_header { my ($self, $transaction, $header_name) = @_; my $action = lc($self->{_args}->{leave_old_headers}) || 'rename'; return unless $action eq 'drop' or $action eq 'rename'; my $old_header_name = $header_name; $old_header_name = ($old_header_name =~ s/^X-//) ? "X-Old-$old_header_name" : "Old-$old_header_name"; for my $header ( $transaction->header->get($header_name) ) { $transaction->header->add($old_header_name, $header) if $action eq 'rename'; $transaction->header->delete($header_name); } } } qpsmtpd-0.84/plugins/tls000644 000765 000024 00000022127 11165321462 015271 0ustar00askstaff000000 000000 #!perl -w =head1 NAME tls - plugin to support STARTTLS =head1 SYNOPSIS # in config/plugins tls [B] =over indentlevel =item B Path to the server certificate file. Default: I =item B Path to the private key file. Default: I =item B Path to the certificate authority file. Default: I =back =head1 DESCRIPTION This plugin implements basic TLS support. It can also be used to support port 465 (SMTP over SSL), but only with qpsmtpd-forkserver. In this case, be sure to load plugins/tls before any other connect plugins and start qpsmtpd like this: qpsmtpd-forkserver --port 25 --port 465 You can also specify multiple --listen-address options as well; see the help for qpsmtpd-forkserver for more details. If TLS is successfully negotiated then the C 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 to automatically generate a self-signed certificate with the appropriate characteristics. Otherwise, you should give absolute pathnames to the certificate, key, and the CA root cert used to sign that certificate. =head1 CIPHERS and COMPATIBILITY By default, we use only the plugins that openssl considers to be "high security". If you need to tweak the available ciphers for some broken client (such as Versamail 3.x), have a look at the available ciphers at L, and put a suitable string in config/tls_ciphers (e.g. "DEFAULT" or "HIGH:MEDIUM") =cut use IO::Socket::SSL 0.98; # 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); $self->tls_ciphers($self->qp->config('tls_ciphers') || 'HIGH'); $self->log(LOGINFO, "ciphers: ".$self->tls_ciphers); local $^W; # this bit is very noisy... my $ssl_ctx = IO::Socket::SSL::SSL_Context->new( SSL_use_cert => 1, SSL_cert_file => $self->tls_cert, SSL_key_file => $self->tls_key, SSL_ca_file => $self->tls_ca, SSL_cipher_list => $self->tls_ciphers, SSL_server => 1 ) or die "Could not create SSL context: $!"; # now extract the password... $self->ssl_context($ssl_ctx); # Check for possible AUTH mechanisms HOOK: foreach my $hook ( keys %{$qp->hooks} ) { no strict 'refs'; if ( $hook =~ m/^auth-?(.+)?$/ ) { if ( defined $1 ) { my $hooksub = "hook_$hook"; $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"); unless ( _convert_to_ssl($self) ) { # SSL setup failed. Now we must respond to every command with 5XX warn("TLS failed: $@\n"); $transaction->notes('ssl_failed', 1); return DENY, "TLS Negotiation Failed"; } $self->log(LOGWARN, "TLS setup returning"); return DONE; } sub hook_connect { my ($self, $transaction) = @_; my $local_port = $self->qp->connection->local_port; return DECLINED unless $local_port == 465; # SMTPS unless ( _convert_to_ssl($self) ) { return (DENY_DISCONNECT, "Cannot establish SSL session"); } $self->log(LOGWARN, "Connected via SMTPS"); return DECLINED; } sub hook_post_connection { my ($self, $transaction) = @_; my $tls_socket = $self->connection->notes('tls_socket'); if (defined $tls_socket && $self->connection->notes('tls_socket_is_duped')) { $tls_socket->close; $self->connection->notes('tls_socket', undef); $self->connection->notes('tls_socked_is_duped', 0); } return DECLINED; } sub _convert_to_ssl { my ($self) = @_; if ($self->qp->isa('Qpsmtpd::PollServer')) { return _convert_to_ssl_async($self); } eval { my $tlssocket = IO::Socket::SSL->new_from_fd( fileno(STDIN), '+>', SSL_use_cert => 1, SSL_cert_file => $self->tls_cert, SSL_key_file => $self->tls_key, SSL_ca_file => $self->tls_ca, SSL_cipher_list => $self->tls_ciphers, SSL_server => 1, SSL_reuse_ctx => $self->ssl_context, ) or die "Could not create SSL socket: $!"; # Clone connection object (without data received from client) $self->qp->connection($self->connection->clone()); $self->qp->reset_transaction; *STDIN = *STDOUT = $self->connection->notes('tls_socket', $tlssocket); $self->connection->notes('tls_socket_is_duped', 1); $self->connection->notes('tls_enabled', 1); }; if ($@) { return 0; } else { return 1; } } sub _convert_to_ssl_async { my ($self) = @_; my $upgrader = $self->connection ->notes( 'tls_upgrader', UpgradeClientSSL->new($self) ); $upgrader->upgrade_socket(); return 1; } 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 tls_ciphers { my $self = shift; @_ and $self->{_tls_ciphers} = shift; $self->{_tls_ciphers}; } 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; package UpgradeClientSSL; # borrowed heavily from Perlbal::SocketSSL use strict; use warnings; no warnings qw(deprecated); use IO::Socket::SSL 0.98; use Errno qw( EAGAIN ); use fields qw( _stashed_qp _stashed_plugin _ssl_started ); sub new { my UpgradeClientSSL $self = shift; $self = fields::new($self) unless ref $self; $self->{_stashed_plugin} = shift; $self->{_stashed_qp} = $self->{_stashed_plugin}->qp; return $self; } sub upgrade_socket { my UpgradeClientSSL $self = shift; unless ( $self->{_ssl_started} ) { IO::Socket::SSL->start_SSL( $self->{_stashed_qp}->{sock}, { SSL_use_cert => 1, SSL_cert_file => $self->{_stashed_plugin}->tls_cert, SSL_key_file => $self->{_stashed_plugin}->tls_key, SSL_ca_file => $self->{_stashed_plugin}->tls_ca, SSL_cipher_list => $self->{_stashed_plugin}->tls_ciphers, SSL_startHandshake => 0, SSL_server => 1, SSL_reuse_ctx => $self->{_stashed_plugin}->ssl_context, } ) or die "Could not upgrade socket to SSL: $!"; $self->{_ssl_started} = 1; } $self->event_read($self->{_stashed_qp}); } sub event_read { my UpgradeClientSSL $self = shift; my $qp = shift; $qp->watch_read( 0 ); my $sock = $qp->{sock}->accept_SSL; if (defined $sock) { $qp->connection( $qp->connection->clone ); $qp->reset_transaction; $qp->connection->notes('tls_socket', $sock); $qp->connection->notes('tls_enabled', 1); $qp->watch_read(1); return 1; } # nope, let's see if we can continue the process if ($! == EAGAIN) { $qp->set_reader_object($self); if ($SSL_ERROR == SSL_WANT_READ) { $qp->watch_read(1); } elsif ($SSL_ERROR == SSL_WANT_WRITE) { $qp->watch_write(1); } else { $qp->disconnect(); } } else { $qp->disconnect(); } } 1; qpsmtpd-0.84/plugins/tls_cert000755 000765 000024 00000007313 11165321462 016311 0ustar00askstaff000000 000000 #!/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`); if ($?) { chomp($hostname = `hostname`); } print "Using hostname: $hostname\n"; 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); } qpsmtpd-0.84/plugins/uribl000644 000765 000024 00000037675 11357260076 015630 0ustar00askstaff000000 000000 #!/usr/bin/perl -w =head1 NAME uribl - URIBL blocking plugin for qpsmtpd $Id$ =head1 DESCRIPTION This plugin implements DNSBL lookups for URIs found in spam, such as that implemented by SURBL (see Ehttp://surbl.org/E). Incoming messages are scanned for URIs, which are then checked against one or more URIBLs in a fashion similar to DNSBL systems. =head1 CONFIGURATION To enable the plugin, add it to I<~qpsmtpd/config/plugins>. The list of URIBLs to check should be placed in I in the config directory (typically I<~qpsmtpd/config>). The format of the I file is a list of URIBL DNS zones, one per line, consisting of one or more columns separated by whitespace. The first column (the only mandatoy one) should consist of the URIBL zone. The second column may contain a comma-delimited list of integers selecting mask values to be applied to the A record(s) returned from a URIBL. This enables the use of composite DNSBLs, such as multi.surbl.org, where several lists are combined so they may be accessed with a single query; any returns are checked against the mask of lists you're interested in. If unspecified, or if a negative number is given, all lists in a composite URIBL will be checked. URIBL operators prefer that you use the composite lists to reduce their own query load, and it's more efficient for qpsmtpd as well. The third column specifies an action, which overrides the default action configured with the I setting discussed below. For example: =over 4 multi.surbl.org 2,8 deny ob.surbl.org 1 add-header =back You may specify the following config option(s) in the I file: =over 4 =item action Specifies what to do when a URI is matched in a URIBL. Available options are I (the default) I and I. If set to add-header, an X-URIBL-Match: header will be added explaining the URIBL entry found. If set to 'deny,' the delivery will be declined with a hard failure. If set to denysoft, the delivery will be soft failed (this is probably not a good idea.) =item timeout Timeout for DNS requests, in seconds. The default is 30 seconds. DNS requests are issued asynchronously and in parallel for all hosts found in URIs in the mail; the same timeout will apply to each; see the Net::DNS documentation for details. =item scan-headers If set true, any headers found in the URIs will be checked as well. Disabled by default. =back =head1 CAUTIONS When used in I or I mode, a URIBL check can block not only the original spam containing a listed URI, but mail unintentionally carrying that URI, such as forwarded complaints. The uribl checks should only be used in these modes if you know what you're doing. The URI scanner used by the uribl plugin is quite aggressive, and attempts to detect all forms of URIs supported by typical MUAs (even those that lack a protocol specification, for example.) However, it does not attempt to detect URIs that have been mangled beyond programmatic reconstruction. Even so, it may issue spurious lookups on unintended URIs, especially those in non-text sections of the mail. =head1 COPYRIGHT uribl is copyright 2004-2007 by Devin Carraway Eqpsmtpd@devin.comE. It may be used and redistributed under the same terms as qpsmtpd itself. =cut use Net::DNS::Resolver; use Time::HiRes qw(time); use IO::Select; use Qpsmtpd::Constants; use strict; use warnings; # ccTLDs that allocate domain names within a strict two-level hierarchy, # as in *.co.uk my %strict_twolevel_cctlds = ( 'ac' => 1, 'ae' => 1, 'uk' => 1, 'ai' => 1, 'ar' => 1, 'at' => 1, 'au' => 1, 'az' => 1, 'bb' => 1, 'bh' => 1, 'bm' => 1, 'br' => 1, 'bs' => 1, 'ca' => 1, 'ck' => 1, 'cn' => 1, 'co' => 1, 'cr' => 1, 'cu' => 1, 'cy' => 1, 'do' => 1, 'et' => 1, 'ge' => 1, 'hk' => 1, 'id' => 1, 'il' => 1, 'jp' => 1, 'kr' => 1, 'kw' => 1, 'lv' => 1, 'sg' => 1, 'za' => 1, ); # async version: OK sub init { my ($self, $qp, %args) = @_; $self->{action} = $args{action} || 'add-header'; $self->{timeout} = $args{timeout} || 30; # scan-headers was the originally documented name for this option, while # check-headers actually implements it, so tolerate both. $self->{check_headers} = $args{'check-headers'} || $args{'scan-headers'}; $args{mask} ||= 0x00ffffff; $self->{mask} = 0; my @zones = $self->qp->config('uribl_zones'); for (@zones) { chomp; next if !$_ or /^\s*#/; my @z = split (/\s+/, $_); next unless $z[0]; my $mask = 0; $z[1] ||= 0x00ffffff; for (split /,/, $z[1]) { unless (/^(-?\d+)$/) { $self->log(LOGERROR, "Malformed mask $_ for $z[0]"); return undef; } $mask |= $1 >= 0 ? $1 : 0x00ffffff; } my $action = $z[2] || $self->{action}; unless ($action =~ /^(add-header|deny|denysoft|log)$/) { $self->log(LOGERROR, "Unknown action $action for $z[0]"); return undef; } $self->{uribl_zones}->{$z[0]} = { mask => $mask, action => $action, }; } keys %{$self->{uribl_zones}} or return 0; my @whitelist = $self->qp->config('uribl_whitelist_domains'); $self->{whitelist_zones} = { ( map { ($_ => 1) } @whitelist ) }; $self->init_resolver; } # async version: not used sub register { my $self = shift; $self->register_hook('data_post', 'data_handler'); } # async version: not used sub send_query { my $self = shift; my $name = shift || return undef; my $count = 0; $self->{socket_select} ||= new IO::Select or return undef; for my $z (keys %{$self->{uribl_zones}}) { my ($s, $s1); my $index = { zone => $z, name => $name, }; next unless $z; next if exists $self->{sockets}->{$z}->{$name}; $s = $self->{resolver}->bgsend("$name.$z", 'A'); if (defined $s) { $self->{sockets}->{$z}->{$name}->{'a'} = $s; $self->{socket_select}->add($s); $self->{socket_idx}->{"$s"} = $index; $count++; } else { $self->log(LOGERROR, "Couldn't open socket for A record '$name.$z': ". ($self->{resolver}->errorstring || 'unknown error')); } $s1 = $self->{resolver}->bgsend("$name.$z", 'TXT'); if (defined $s1) { $self->{sockets}->{$z}->{$name}->{'txt'} = $s1; $self->{socket_select}->add($s1); $self->{socket_idx}->{"$s1"} = $index; $count++; } else { $self->log(LOGERROR, "Couldn't open socket for TXT record '$name.$z': ". ($self->{resolver}->errorstring || 'unknown error')); } $self->{sockets}->{$z}->{$name} = {}; } $count; } # async version: not used sub lookup_finish { my $self = shift; $self->{socket_idx} = {}; $self->{sockets} = {}; undef $self->{socket_select}; } # async version: OK sub evaluate { my $self = shift; my $zone = shift || return undef; my $a = shift || return undef; my $mask = $self->{uribl_zones}->{$zone}->{mask} || $self->{mask}; $a =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/ or return undef; my $v = (($1 & 0xff) << 24) | (($2 & 0xff) << 16) | (($3 & 0xff) << 8) | ($4 & 0xff); return ($v & $mask); } # async version: OK sub lookup_start { my ($self, $transaction, $start_query) = @_; my $l; my $queries = 0; my %pending; my @qp_continuations; $transaction->body_resetpos; # if we're not looking for URIs in the headers, read past that point # before starting to actually look for any while (!$self->{check_headers} and $l = $transaction->body_getline) { chomp $l; last if !$l; } while ($l = $transaction->body_getline) { chomp $l; if ($l =~ /(.*)=$/) { push @qp_continuations, $1; } elsif (@qp_continuations) { $l = join('', @qp_continuations, $l); @qp_continuations = (); } # Undo URI escape munging $l =~ s/[=%]([0-9A-Fa-f]{2,2})/chr(hex($1))/ge; # Undo HTML entity munging (e.g. in parameterized redirects) $l =~ s/&#(\d{2,3});?/chr($1)/ge; # Dodge inserted-semicolon munging $l =~ tr/;//d; while ($l =~ m{ \w{3,16}:/+ # protocol (?:\S+@)? # user/pass (\d{7,}) # raw-numeric IP (?::\d*)?([/?\s]|$) # port, slash # or EOL }gx) { my @octets = ( (($1 >> 24) & 0xff), (($1 >> 16) & 0xff), (($1 >> 8) & 0xff), ($1 & 0xff) ); my $fwd = join('.', @octets); my $rev = join('.', reverse @octets); $self->log(LOGDEBUG, "uribl: matched pure-integer ipaddr $1 ($fwd)"); unless (exists $pending{$rev}) { $queries += $start_query->($self, $rev); $pending{$rev} = 1; } } while ($l =~ m{ \w{3,16}:/+ # protocol (?:\S+@)? # user/pass (\d+|0[xX][0-9A-Fa-f]+)\. # IP address (\d+|0[xX][0-9A-Fa-f]+)\. (\d+|0[xX][0-9A-Fa-f]+)\. (\d+|0[xX][0-9A-Fa-f]+) }gx) { my @octets = ($1,$2,$3,$4); # return any octal/hex octets in the IP addr back # to decimal form (e.g. http://0x7f.0.0.00001) for (0..$#octets) { $octets[$_] =~ s/^0([0-7]+)$/oct($1)/e; $octets[$_] =~ s/^0x([0-9a-fA-F]+)$/hex($1)/e; } my $fwd = join('.', @octets); my $rev = join('.', reverse @octets); $self->log(LOGDEBUG, "uribl: matched URI ipaddr $fwd"); unless (exists $pending{$rev}) { $queries += $start_query->($self, $rev); $pending{$rev} = 1; } } while ($l =~ m{ ((?:www\.)? # www? [a-zA-Z0-9][a-zA-Z0-9\-.]+\. # hostname (?:aero|arpa|asia|biz|cat|com|coop| # tld edu|gov|info|int|jobs|mil|mobi| museum|name|net|org|pro|tel|travel| [a-zA-Z]{2}) )(?!\w) }gix) { my $host = lc $1; my @host_domains = split /\./, $host; $self->log(LOGDEBUG, "uribl: matched 'www.' hostname $host"); my $cutoff = exists $strict_twolevel_cctlds{$host_domains[$#host_domains]} ? 3 : 2; if (exists $self->{whitelist_zones}->{ join('.', @host_domains[($#host_domains-$cutoff+1)..$#host_domains])}) { $self->log(LOGINFO, "Skipping whitelist URI domain '$host'"); } else { while (@host_domains >= $cutoff) { my $subhost = join('.', @host_domains); unless (exists $pending{$subhost}) { $self->log(LOGINFO, "URIBL: checking sub-host $subhost"); $queries += $start_query->($self, $subhost); $pending{$subhost} = 1; } shift @host_domains; } } } while ($l =~ m{ \w{3,16}:/+ # protocol (?:\S+@)? # user/pass ( [a-zA-Z0-9][a-zA-Z0-9\-.]+\. # hostname (?:aero|arpa|asia|biz|cat|com|coop| # tld edu|gov|info|int|jobs|mil|mobi| museum|name|net|org|pro|tel|travel| [a-zA-Z]{2}) ) }gix) { my $host = lc $1; my @host_domains = split /\./, $host; $self->log(LOGDEBUG, "uribl: matched full URI hostname $host"); my $cutoff = exists $strict_twolevel_cctlds{$host_domains[$#host_domains]} ? 3 : 2; if (exists $self->{whitelist_zones}->{ join('.', @host_domains[($cutoff-1)..$#host_domains])}) { $self->log(LOGINFO, "Skipping whitelist URI domain '$host'"); } else { while (@host_domains >= $cutoff) { my $subhost = join('.', @host_domains); unless (exists $pending{$subhost}) { $self->log(LOGINFO, "URIBL: checking sub-host $subhost"); $queries += $start_query->($self, $subhost); $pending{$subhost} = 1; } shift @host_domains; } } } } $transaction->body_resetpos; return $queries; } # async version: not used sub collect_results { my ($self, $transaction) = @_; my $matches = 0; my $complete = 0; my $start_time = time; while ($self->{socket_select}->handles) { my $timeout = ($start_time + $self->{timeout}) - time; last if $timeout <= 0; my @ready = $self->{socket_select}->can_read($timeout); SOCK: for my $s (@ready) { $self->{socket_select}->remove($s); my $r = $self->{socket_idx}->{"$s"} or next SOCK; $self->log(LOGDEBUG, "from $r: socket $s: ". join(', ', map { "$_=$r->{$_}" } keys %{$r})); my $zone = $r->{zone}; my $name = $r->{name}; my $h = $self->{sockets}->{$zone}->{$name}; my $packet = $self->{resolver}->bgread($s) or next SOCK; for my $a ($packet->answer) { if ($a->type eq 'TXT') { $h->{txt} = $a->txtdata; } elsif ($a->type eq 'A') { $h->{a} = $a->address; if ($self->evaluate($zone, $h->{a})) { $self->log(LOGDEBUG, "match in $zone"); $h->{match} = 1; $matches++; } } } $complete++; } } my $elapsed = time - $start_time; $self->log(LOGINFO, sprintf("$complete lookup%s finished in %.2f sec (%d match%s)", $complete == 1 ? '' : 's', $elapsed, $matches, $matches == 1 ? '' : 'es')); my @matches = (); for my $z (keys %{$self->{sockets}}) { for my $n (keys %{$self->{sockets}->{$z}}) { my $h = $self->{sockets}->{$z}->{$n}; next unless $h->{match}; push @matches, { action => $self->{uribl_zones}->{$z}->{action}, desc => "$n in $z: ". ($h->{txt} || $h->{a}), }; } } $self->lookup_finish; return \@matches; } # async version: not used sub data_handler { my ($self, $transaction) = @_; my $queries = $self->lookup_start($transaction, sub { my ($self, $name) = @_; return $self->send_query($name); }); unless ($queries) { $self->log(LOGINFO, "No URIs found in mail"); return DECLINED; } my $matches = $self->collect_results($transaction); for (@$matches) { $self->log(LOGWARN, $_->{desc}); if ($_->{action} eq 'add-header') { $transaction->header->add('X-URIBL-Match', $_->{desc}); } elsif ($_->{action} eq 'deny') { return (DENY, $_->{desc}); } elsif ($_->{action} eq 'denysoft') { return (DENYSOFT, $_->{desc}); } } return DECLINED; } # async version: not used sub init_resolver { my $self = shift; $self->{resolver} = new Net::DNS::Resolver or return undef; $self->{resolver}->udp_timeout($self->{timeout}); } 1; # vi: ts=4 sw=4 expandtab syn=perl qpsmtpd-0.84/plugins/virus/000755 000765 000024 00000000000 11357265152 015716 5ustar00askstaff000000 000000 qpsmtpd-0.84/plugins/virus/aveclient000644 000765 000024 00000012575 11165321462 017617 0ustar00askstaff000000 000000 #!/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 Optional you may set the path to original aveclient and/or the socket: =over 4 =item avclient_bin I Set the path to the original aveclient of kaspersky 5.x server-suite. Default: /opt/kav/bin/aveclient =item avdaemon_sock I 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 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); } qpsmtpd-0.84/plugins/virus/bitdefender000644 000765 000024 00000005751 11165321462 020116 0ustar00askstaff000000 000000 #!/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 Full path to the BitDefender binary and all signature files; defaults to /opt/bdc/bdc. =item B Whether the scanner will automatically delete messages which have viruses. Takes either 'yes' or 'no' (defaults to 'yes'). =item B Maximum size in kilobytes for messages which will be scanned; defaults to 128k; =back =head1 DEPENDENCIES =over 4 =item B The BitDefender Linux Edition is available to use, free of charge, from this link: Please read the documentation for configuring automatic updates of the virus profiles. =back =head1 AUTHOR John Peacock =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->data_size > $self->{"_bitd"}->{"max_size"} ) { $self->log( LOGWARN, 'Mail too large to scan (' . $transaction->data_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; qpsmtpd-0.84/plugins/virus/clamav000644 000765 000024 00000015774 11335434344 017117 0ustar00askstaff000000 000000 #!/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 (e.g. I) Path to the clamav commandline scanner. Mail will be passed to the clamav scanner in Berkeley mbox format (that is, with a "From " line). See the discussion below on which commandline scanner to use. =item clamd_conf=I (e.g. I) Path to the clamd configuration file. Passed as an argument to the command-line scanner (--config-file=I). The default value is '/etc/clamd.conf'. =item action=EI | IE (e.g. I) 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 (e.g. I) 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 (e.g. I) Specify an alternate temporary directory. If not specified, the qpsmtpd I 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 (/^clamd_conf=(\/[\/\-\_\.a-z0-9A-Z]*)$/) { $self->{_clamd_conf} = "$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'; } elsif (/declined_on_fail/) { $self->{_declined_on_fail} = 1; } 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 $self->{_clamd_conf} ||= '/etc/clamd.conf'; # make sure something is set $self->{_declined_on_fail} ||= 0; # decline the message on clamav failure 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->data_size > $self->{_max_size}) { $self->log(LOGWARN, 'Mail too large to scan ('. $transaction->data_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} . " --config-file=" . $self->{_clamd_conf} . " --no-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 (DENYSOFT) if (!$self->{_declined_on_fail}); 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 (DENYSOFT) if (!$self->{_declined_on_fail}); } else { $transaction->header->add( 'X-Virus-Checked', "Checked by ClamAV on " . $self->qp->config("me") ); } return (DECLINED); } 1; qpsmtpd-0.84/plugins/virus/clamdscan000644 000765 000024 00000016142 11175341544 017570 0ustar00askstaff000000 000000 #!/usr/bin/perl -w # $Id$ =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 execute 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, 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 * Add group-execute permissions to the qpsmtpd spool directory. =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. =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): You must have the ClamAV::Client module installed to use the plugin. =over 4 =item B Full path to the clamd socket (the recommended mode), if different from the ClamAV::Client defaults. =item B 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 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 Whether to defer the mail (with a soft-failure error, which will incur a retry) if an unrecoverable error occurs during the scan. The default is to accept the mail under these conditions. This can permit viruses to be accepted when the clamd daemon is malfunctioning or unreadable, but will not allow mail to backlog or be lost if the condition persists. =item B The maximum size, in kilobytes, of messages to scan; defaults to 128k. =item B Scan all messages, even if there are no attachments =back =head1 REQUIREMENTS This module requires the ClamAV::Client module, found on CPAN here: L =head1 AUTHOR Originally written for the Clamd module by John Peacock ; adjusted for ClamAV::Client by Devin Carraway . =head1 COPYRIGHT AND LICENSE Copyright (c) 2005 John Peacock, Copyright (c) 2007 Devin Carraway 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 ClamAV::Client; use strict; use warnings; sub register { my ( $self, $qp, @args ) = @_; %{ $self->{"_clamd"} } = @args; # Set some sensible defaults $self->{"_clamd"}->{"deny_viruses"} ||= "yes"; $self->{"_clamd"}->{"max_size"} ||= 128; $self->{"_clamd"}->{"scan_all"} ||= 0; for my $setting ('deny_viruses', 'defer_on_error') { next unless $self->{"_clamd"}->{$setting}; $self->{"_clamd"}->{$setting} = 0 if lc $self->{"_clamd"}->{$setting} eq 'no'; } } sub hook_data_post { my ( $self, $transaction ) = @_; $DB::single = 1; if ( $transaction->data_size > $self->{"_clamd"}->{"max_size"} * 1024 ) { $self->log( LOGNOTICE, "Declining due to data_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 ( $self->{"_clamd"}->{"scan_all"} || $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; } # the spool directory must be readable and executable by the scanner; # this generally means either group or world exec; if # neither of these is set, issue a warning but try to proceed anyway my $mode = ( stat( $self->spool_dir() ) )[2]; if ( $mode & 0010 || $mode & 0001 ) { # match the spool file mode with the mode of the directory -- add # the read bit for group, world, or both, depending on what the # spool dir had, and strip all other bits, especially the sticky bit my $fmode = ($mode & 0044) | ($mode & 0010 ? 0040 : 0) | ($mode & 0001 ? 0004 : 0); unless ( chmod $fmode, $filename ) { $self->log( LOGERROR, "chmod: $filename: $!" ); return DECLINED; } } else { $self->log( LOGWARN, "Permission on spool directory do not permit scanner access" ); } my $clamd; if ( ($self->{"_clamd"}->{"clamd_port"} || '') =~ /^(\d+)/ ) { $clamd = new ClamAV::Client( socket_host => $self->{_clamd}->{clamd_host}, socket_port => $1 ); } elsif ( ($self->{"_clamd"}->{"clamd_socket"} || '') =~ /([\w\/.]+)/ ) { $clamd = new ClamAV::Client( socket_name => $1 ); } else { $clamd = new ClamAV::Client; } unless ( $clamd ) { $self->log( LOGERROR, "Cannot instantiate ClamAV::Client" ); return (DENYSOFT, "Unable to scan for viruses") if $self->{"_clamd"}->{"defer_on_error"}; return DECLINED; } unless ( eval { $clamd->ping() } ) { $self->log( LOGERROR, "Cannot ping clamd server: $@" ); return (DENYSOFT, "Unable to scan for viruses") if $self->{"_clamd"}->{"defer_on_error"}; return DECLINED; } my ( $path, $found ) = eval { $clamd->scan_path( $filename ) }; if ($@) { $self->log( LOGERROR, "Error scanning mail: $@" ); return (DENYSOFT, "Unable to scan for viruses") if $self->{"_clamd"}->{"defer_on_error"}; return DECLINED; } elsif ( $found ) { $self->log( LOGERROR, "Virus found: $found" ); if ( $self->{"_clamd"}->{"deny_viruses"} ) { return ( DENY, "Virus found: $found" ); } else { $transaction->header->add( 'X-Virus-Found', 'Yes' ); $transaction->header->add( 'X-Virus-Details', $found ); return (DECLINED); } } else { $self->log( LOGINFO, "ClamAV scan reports clean"); } $transaction->header->add( 'X-Virus-Checked', "Checked by ClamAV on " . $self->qp->config("me") ); return (DECLINED); } # vi: set ts=4 sw=4 et: qpsmtpd-0.84/plugins/virus/hbedv000644 000765 000024 00000010300 11165321462 016715 0ustar00askstaff000000 000000 #!/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 plugin checks a mail for viruses with the H+BEDV anti virus scanner (see L for info). It can deny mails if a virus was found with a configurable deny list. =head1 VERSION this is B version 1.1 =head1 CONFIGURATION Add (perl-)regexps to the F 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. =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 plugin. =head1 LICENCE Written by Hanno Hecker Ehah@uu-x.deE. The B 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) } qpsmtpd-0.84/plugins/virus/kavscanner000644 000765 000024 00000012475 11165321462 017777 0ustar00askstaff000000 000000 #!/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 and deny if it matches a configured virus list. =head1 VERSION this is B version 1.0 =head1 CONFIGURATION Add (perl-)regexps to the F 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 in the plugin config to send a B to the given mail address, i.e. the line kavscanner bcc_virusadmin viradm@your.company.com in the F file instead of just kavscanner Set the location of the binary with kavscanner kavscanner_bin /path/to/kavscanner (default: F), NOTE: this may be broken, you want to set B explicitly ;-) =head1 NOTES This is a merge of the clam_av plugin for qpsmtpd and qmail-scanner-queue.pl L 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 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($_); } } } 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 qpsmtpd-0.84/plugins/virus/klez_filter000644 000765 000024 00000001507 11165321462 020150 0ustar00askstaff000000 000000 sub hook_data_post { my ($self, $transaction) = @_; # klez files are always sorta big .. how big? Dunno. return (DECLINED) if $transaction->data_size < 60_000; # 220k was too little, so let's just disable the "big size check" # or $transaction->data_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); } qpsmtpd-0.84/plugins/virus/sophie000644 000765 000024 00000012643 11165321462 017130 0ustar00askstaff000000 000000 #!/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->data_size > $self->{"_sophie"}->{"max_size"} * 1024 ) { $self->log( LOGNOTICE, "Declining due to data_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 Full path to the Sophie socket defaults to /var/run/Sophie. =item B 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 The maximum size, in kilobytes, of messages to scan; defaults to 128k. =back =head1 REQUIREMENTS This module requires the Sophie daemon, available here: L which in turn requires the libsavi.so library (available with the Sophos Anti-Virus for Linux or Unix). The following changes to F B 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 B 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 =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 qpsmtpd-0.84/plugins/virus/uvscan000644 000765 000024 00000007153 11165321462 017140 0ustar00askstaff000000 000000 #!/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 Full path to the uvscan binary and all signature files; defaults to /usr/local/bin/uvscan. =item B Whether the scanner will automatically delete messages which have viruses. Takes either 'yes' or 'no' (defaults to 'yes'). =back =head1 AUTHOR John Peacock =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->data_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 () { $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); } qpsmtpd-0.84/plugins/queue/exim-bsmtp000644 000765 000024 00000011607 11335434344 017704 0ustar00askstaff000000 000000 =head1 NAME exim-bsmtp $Id$ =head1 DESCRIPTION This plugin enqueues mail from qpsmtpd into Exim via BSMTP =head1 INSTALLATION The qpsmtpd user B be configured in the I 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 The path to use to execute the Exim BSMTP receiver; by default this is I. The commandline switch '-bS' will be added (this is actually redundant with rsmtp, but harmless). =back =cut =head1 LICENSE Copyright (c) 2004 by Devin Carraway 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, $transaction) = @_; unless ($transaction->header) { $self->log(LOGERROR, "No header parsed for transaction; can't enqueue"); return (DENY, 'Mail unqueuable'); } 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:<", ($transaction->sender->address || ''), ">\n"; print $tmp "RCPT TO:<", ($_->address || ''), ">\n" for $transaction->recipients; print $tmp "DATA\n", $transaction->header->as_string; $transaction->body_resetpos; while (my $line = $transaction->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; my ($bsmtp_error, $bsmtp_msg); while (<$exim>) { chomp; $self->log(LOGERROR, "exim: $_"); if (/(\d\d\d)\s(\S.*)/) { ($bsmtp_error, $bsmtp_msg) = ($1, $2); } } $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 ($bsmtp_error && $bsmtp_error >= 400 && $bsmtp_error < 600) { $self->log(LOGERROR, "BSMTP enqueue failed; response $bsmtp_error". " ($bsmtp_msg)"); return ($bsmtp_error < 400 ? DECLINED : DENY, $bsmtp_msg); } elsif (($exit >> 8) != 0 || $bsmtp_error) { $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: qpsmtpd-0.84/plugins/queue/maildir000644 000765 000024 00000013135 11335434344 017236 0ustar00askstaff000000 000000 #!perl =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. A second optional parameter delivers the mail into a sub directory named by the recipient of the mail B. Some substituions take place. Before replacing the parts descibed below, any character of the recipient address, which is not one of C<-A-Za-z0-9+_.,@=> is set to a C<_>. If a third parameter is given, it will be used as octal (!) permisson of the newly created files and directories, any execute bits will be stripped for files: Use C<770> to create group writable directories and files with mode C<0660>. =head2 Maildir spool directory substitutions =over 4 =item %l Replaced by the local part of the address (i.e. the username) =item %d Replaced by the domain part of the address (i.e. the domain name) =item %u Replaced by the full address. =cut # =item %% # # Replaced by a single percent sign (%) # # =cut =back Examples: if the plugin is loaded with the parameters queue/maildir /var/spool/qpdeliver %d/%l and the recipient is C the mails will be written to the C sub directory of C. With queue/maildir /var/spool/qpdeliver %u and a recipient of C the mail goes to C. =head1 NOTES Names of the substitution parameters and the replaced charachters are the same L supports, for more info see the C<--virtual-config-dir> option of L. When called with more than one parameter, this plugin is probably not usable with qpsmtpd-async. With the the second parameter being C<%d> it will still deliver one message for each recipient: With the two recpients C and C you get two messages in the C directory. =cut use File::Path qw(mkpath); use Sys::Hostname qw(hostname); use Time::HiRes qw(gettimeofday); sub register { my ($self, $qp, @args) = @_; if (@args > 0) { ($self->{_maildir}) = ($args[0] =~ m!([-/\w\.]+)!); } if (@args > 1) { ($self->{_subdirs}) = ($args[1] =~ m#^(.*\%[ldu].*)$#); unless ($self->{_subdirs}) { $self->log(LOGWARN, "WARNING: sub directory does not contain a " ."substitution parameter"); return 0; } } if (@args > 2) { ($self->{_perms}) = ($args[2] =~ /^([0-7]{3})$/); unless ($self->{_perms}) { # 000 is unfortunately true ;-) $self->log(LOGWARN, "WARNING: mode is not an octal number"); return 0; } $self->{_perms} = oct($self->{_perms}); } $self->{_perms} = 0700 unless $self->{_perms}; unless ($self->{_maildir}) { $self->log(LOGWARN, "WARNING: maildir directory not specified"); return 0; } unless ($self->{_subdirs}) { # mkpath is influenced by umask... my $old_umask = umask 000; map { my $d = $self->{_maildir} . "/$_"; -e $d or mkpath $d, 0, $self->{_perms} } qw(cur tmp new); umask $old_umask; } my $hostname = (hostname =~ m/([\w\._\-]+)/)[0]; $self->{_hostname} = $hostname; } my $maildir_counter = 0; sub hook_queue { my ($self, $transaction) = @_; my ($rc, @msg); my $old_umask = umask($self->{_perms} ^ 0777); if ($self->{_subdirs}) { foreach my $addr ($transaction->recipients) { ($rc, @msg) = $self->deliver_user($transaction, $addr); unless($rc == OK) { umask $old_umask; return ($rc, @msg); } } umask $old_umask; return (OK, @msg); # last @msg is the same like any other before... } $transaction->header->add('Delivered-To', $_->address, 0) for $transaction->recipients; ($rc, @msg) = $self->write_file($transaction, $self->{_maildir}); umask $old_umask; return ($rc, @msg); } sub write_file { my ($self, $transaction, $maildir, $addr) = @_; 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}; open (MF, ">$maildir/tmp/$file") or $self->log(LOGWARN, "could not open $maildir/tmp/$file: $!"), return(DECLINED, "queue error (open)"); print MF "Return-Path: ", $transaction->sender->format , "\n"; print MF "Delivered-To: ",$addr->address,"\n" if $addr; # else it had been added before... $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"); } sub deliver_user { my ($self, $transaction, $addr) = @_; my $user = $addr->user; $user =~ tr/-A-Za-z0-9+_.,@=/_/c; my $host = $addr->host; $host =~ tr/-A-Za-z0-9+_.,@=/_/c; my $rcpt = $user.'@'.$host; my $subdir = $self->{_subdirs}; $subdir =~ s/\%l/$user/g; $subdir =~ s/\%d/$host/g; $subdir =~ s/\%u/$rcpt/g; # $subdir =~ s/\%%/%/g; my $maildir = $self->{_maildir}."/$subdir"; my $old_umask = umask 000; map { my $d = $maildir . "/$_"; -e $d or mkpath $d, 0, $self->{_perms} } qw(cur tmp new); umask $old_umask; return $self->write_file($transaction, $maildir, $addr); } qpsmtpd-0.84/plugins/queue/postfix-queue000644 000765 000024 00000013734 11165321462 020435 0ustar00askstaff000000 000000 =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. See below in ``POSTFIX COMPATIBILITY'' for flags understood by your postfix version. Supported by all postfix versions E= 2.1 are: =over 4 =item FLAG_FILTER Set the CLEANUP_FLAG_FILTER for cleanup. This enables the use of I, I or I in postfix' main.cf. =item FLAG_BCC_OK Setting this flag enables (for example) the I parameter =item FLAG_MAP_OK This flag enables the use of other recipient mappings (e.g. I) in postfix' cleanup. =item FLAG_MASK_EXTERNAL This flag mask combines FLAG_FILTER, FLAG_MILTER (only in postfix >= 2.3) FLAG_BCC_OK and FLAG_MAP_OK and is used by postfix for external messages. This is probably what you want to use. =back For more flags see below in ``POSTFIX COMPATIBILITY'', your postfix version (grep _FLAG_ src/global/cleanup_user.h) and/or lib/Qpsmtpd/Postfix/Constants.pm =head1 POSTFIX COMPATIBILITY The first version of this plugin was written for postfix 1.x. The next step for Postfix 2.1 (and later) was to add the FLAG_FILTER, FLAG_BCC_OK and FLAG_MAP_OK flags for submission to the cleanup deamon. This version can use all flags found in Postfix 2.x (up to 2.4 currently). Unknown flags are ignored by the cleanup daemon (just tested with postfix 2.1), so it should be safe to set flags just understood by later versions of postfix/cleanup. Even if all known flags can be set, some are not that useful when feeding the message from qpsmtpd, e.g. =head2 FLAG_NONE no effect =head2 FLAG_DISCARD DON'T USE, use another plugin which hooks the I and returns B just for the messages you want to drop. As long as this plugin does not support setting queue flags on the fly from other modules, this flag would drop ALL messages. Don't use! =head2 FLAG_BOUNCE Qpsmtpd should be configured not to accept bad messages... =head2 FLAG_HOLD Not useful in production setup, maybe in testing environment (untested, what real effects this has). =over 4 =item Flags known by postfix 1.1: FLAG_NONE - No special features FLAG_BOUNCE - Bounce bad messages FLAG_FILTER - Enable content filter =item Flags known by postfix 2.1, 2.2 all flags from postfix 1.1, plus the following: FLAG_HOLD - Place message on hold FLAG_DISCARD - Discard message silently FLAG_BCC_OK - Ok to add auto-BCC addresses FLAG_MAP_OK - Ok to map addresses FLAG_MASK_INTERNAL - alias for FLAG_MAP_OK FLAG_MASK_EXTERNAL - FILTER, BCC_OK and MAP_OK =item Flags known by postfix 2.3 all flags from postfix 2.1, up to FLAG_MASK_INTERNAL. New or changed: FLAG_MILTER - Enable Milter applications FLAG_FILTER_ALL - FILTER and MILTER FLAG_MASK_EXTERNAL - FILTER_ALL, BCC_OK, MAP_OK =item Flags known by postfix 2.4 currently (postfix-2.4-20061019) the same as 2.3 =back =head1 MAYBE IN FUTURE Settings the (additional) queue flags from another plugin. Currently at the beginning of I all flags are reset to the flags given as plugin parameters. =cut use Qpsmtpd::Postfix; use Qpsmtpd::Postfix::Constants; sub register { my ($self, $qp, @args) = @_; $self->log(LOGDEBUG, "using constants generated from Postfix" ."v$postfix_version"); $self->{_queue_flags} = 0; if (@args > 0) { if ($args[0] =~ m#^(/.+)#) { # untaint socket path $self->{_queue_socket} = $1; shift @args; } else { $self->{_queue_socket} = "/var/spool/postfix/public/cleanup"; } foreach (@args) { if ($self->can("CLEANUP_".$_) and /^(FLAG_[A-Z0-9_]+)$/) { $_ = $1; $self->{_queue_flags} |= (eval "CLEANUP_$_;" || 0); #print STDERR "queue flag: $_: ".$self->{_queue_flags}."\n"; } else { $self->log(LOGWARN, "Ignoring unkown cleanup flag $_"); } } } else { $self->{_queue_socket} = "/var/spool/postfix/public/cleanup"; } $self->{_queue_socket} = $ENV{POSTFIXQUEUE} if $ENV{POSTFIXQUEUE}; } sub hook_queue { my ($self, $transaction) = @_; $transaction->notes('postfix-queue-flags', $self->{_queue_flags}); $transaction->notes('postfix-queue-socket', $self->{_queue_socket}); # $self->log(LOGDEBUG, "queue-flags=".$transaction->notes('postfix-queue-flags')); my ($status, $qid, $reason) = Qpsmtpd::Postfix->inject_mail($transaction); if ($status) { # this split is needed, because if cleanup returns # CLEANUP_STAT_MASK_INCOMPLETE we might return DENY (CLEANUP_STAT_SIZE) # instead of DENYSOFT (CLEANUP_STAT_WRITE, CLEANUP_STAT_BAD, # CLEANUP_STAT_DEFER) ... n.b. this is the behaviour of 667. foreach my $key (keys %cleanup_soft) { my $stat = eval $key # keys have the same names as the constants or next; if ($status & $stat) { return (DENYSOFT, $reason || $cleanup_soft{$key}); } } foreach my $key (keys %cleanup_hard) { my $stat = eval $key # keys have the same names as the constants or next; if ($status & $stat) { return (DENY, $reason || $cleanup_hard{$key}); } } # we have no idea why we're here. return (DECLINED, $reason || "Unable to queue message ($status, $reason)"); } my $msg_id = $transaction->header->get('Message-Id') || ''; $msg_id =~ s/[\r\n].*//s; # don't allow newlines in the Message-Id here return (OK, "Queued! $msg_id (Queue-Id: $qid)"); } # vim: sw=2 ts=8 syn=perl qpsmtpd-0.84/plugins/queue/qmail-queue000644 000765 000024 00000006551 11165321462 020043 0ustar00askstaff000000 000000 # -*- 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 } } qpsmtpd-0.84/plugins/queue/smtp-forward000644 000765 000024 00000003773 11165321462 020246 0ustar00askstaff000000 000000 =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 init { my ($self, $qp, @args) = @_; if (@args > 0) { if ($args[0] =~ /^([\.\w_-]+)$/) { $self->{_smtp_server} = $1; } else { die "Bad data in smtp server: $args[0]"; } $self->{_smtp_port} = 25; if (@args > 1 and $args[1] =~ /^(\d+)$/) { $self->{_smtp_port} = $1; } $self->log(LOGWARN, "WARNING: Ignoring additional arguments.") if (@args > 2); } else { die("No SMTP server specified in smtp-forward config"); } } sub 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!"); } qpsmtpd-0.84/plugins/logging/adaptive000644 000765 000024 00000012535 11165321462 017714 0ustar00askstaff000000 000000 #!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 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 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 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 =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 qpsmtpd-0.84/plugins/logging/apache000644 000765 000024 00000006106 11165321462 017335 0ustar00askstaff000000 000000 =head1 NAME logging/apache - logging plugin for qpsmtpd which logs to the apache error log =cut # more POD at the end use strict; use warnings FATAL => 'all'; use Apache2::Log; use Apache2::RequestUtil (); use Qpsmtpd::Constants; sub register { my ($self, $qp) = @_; die "Not running under Apache::Qpsmtpd" unless ($qp->{conn} && $qp->{conn}->isa('Apache2::Connection')); my $rr = Apache2::RequestRec->new($self->qp->{conn}); $self->{_log} = $rr->log if $rr; $self->log(LOGINFO, 'Initializing logging::apache 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; unless ($self->{_log}) { my $rr = Apache2::RequestRec->new($self->qp->{conn}); unless ($rr) { warn "no Apache2::RequestRec?... logmsg was: ", join(" ", @log); return DECLINED; } $self->{_log} = $rr->log; } # luckily apache uses the same log levels as qpsmtpd... ($trace = lc Qpsmtpd::Constants::log_level($trace)) =~ s/^log//; $trace = 'emerg' # ... well, nearly... if $trace eq 'radar'; my $log = $self->{_log}; unless ($log->can($trace)) { # ... but you never know if it changes $log->emerg("Can't log with level '$trace', logmsg was: ", join(" ", @log)); return DECLINED; } $log->$trace( join( " ", $$ . ( defined $plugin ? " $plugin plugin:" : defined $hook ? " running plugin ($hook):" : "" ), @log ) ); # no \n at the end! return DECLINED; } =cut =head1 DESCRIPTION The logging/apache plugin uses the apache logging mechanism to write its messages to the apache error log. =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/apache To change what is shown in the logs, change the I directive in the virtual host config for Qpsmtpd and maybe change the I log file: PerlSetVar QpsmtpdDir /path/to/qpsmtpd PerlModule Apache::Qpsmtpd PerlProcessConnectionHandler Apache::Qpsmtpd LogLevel debug ErrorLog /var/log/apache2/qpsmtpd.log =head1 AUTHOR Hanno Hecker =head1 COPYRIGHT AND LICENSE Copyright (c) 2007 Hanno Hecker This plugin is licensed under the same terms as the qpsmtpd package itself. Please see the LICENSE file included with qpsmtpd for details. =cut # vim: ts=4 sw=4 expandtab syn=perl qpsmtpd-0.84/plugins/logging/connection_id000644 000765 000024 00000004601 11165321462 020725 0ustar00askstaff000000 000000 #!/usr/bin/perl # this is a simple 'connection_id' 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) = @_; die "The connection ID feature is currently unsupported"; $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::connection_id 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; my $connection = $self->qp && $self->qp->connection; # warn "connection = $connection\n"; warn join(" ", ($connection ? $connection->id : "???") . (defined $plugin ? " $plugin plugin:" : defined $hook ? " running plugin ($hook):" : ""), @log), "\n" if ($trace <= $self->{_level}); return DECLINED; } =cut =head1 NAME connection_id - plugin to demo use of the connection id =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. This plugin differs from logging/warn only by using the connection id instead of the pid to demonstrate the effect of different algorithms. =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/connection_id [loglevel] where the optional parameters C is either the numeric or text representation of the maximum log level, as shown in the L file. =head1 AUTHOR John Peacock =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 qpsmtpd-0.84/plugins/logging/devnull000644 000765 000024 00000000160 11165321462 017557 0ustar00askstaff000000 000000 #!/usr/bin/perl # this is a simple 'drop packets on the floor' plugin sub hook_logging { return DECLINED; } qpsmtpd-0.84/plugins/logging/file000644 000765 000024 00000017277 11335434344 017051 0ustar00askstaff000000 000000 #!/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] [reopen] [nosplit] [tsformat I] I 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 logging/file loglevel LOGDEBUG tsformat %FT%T /var/log/qpsmtpd.log =back Multiple instances of the plugin can be configured by appending :I for any integer(s) I, 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 below) to facilitate SMTP service alarms with Nagios or a similar monitoring agent. =item loglevel I The internal log level below which messages will be logged. The I 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). =item tsformat I By default qpsmtpd will prepend log items with the date and time as given in the format by perl's C function. If you prefer another format then you can specify a tsformat parameter. =over =item B =item B =item B =item B =item B =item B =item B =item B =back =back The chosen I 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 , with contributions by Peter J. Holzer . =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; $self->{_tsformat} = '%a %b %d %T %Y'; # same as scalar localtime 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; } elsif (lc $args[0] eq 'tsformat') { shift @args; my $format = shift @args; $self->{_tsformat} = $format; } 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, $transaction) = @_; my $output = $self->{_log_format}; $output =~ s/%i/($transaction->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, $transaction) = @_; my $new_output = $self->log_output($transaction); if (!$self->{_current_output} || $self->{_current_output} ne $new_output || ($self->{_reopen} && !$transaction->notes('file-reopened-this-session'))) { unless ($self->open_log($new_output, $transaction)) { return undef; } $transaction->notes('file-reopened-this-session', 1); return 1; } return 0; } sub hook_connect { my ($self, $transaction) = @_; $transaction->notes('file-logged-this-session', 0); $transaction->notes('file-reopened-this-session', 0); $transaction->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, $transaction, $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 # - We aren't in a session if (!$self->{_f} || !$self->{_nosplit} || !$transaction || !$transaction->notes('file-logged-this-session')) { unless (defined $self->maybe_reopen($transaction)) { return DECLINED; } $transaction->notes('file-logged-this-session', 1) if $transaction; } my $f = $self->{_f}; print $f strftime($self->{_tsformat}, localtime), ' ', hostname(), '[', $$, ']: ', @log, "\n"; return DECLINED; } # vi: tabstop=4 shiftwidth=4 expandtab: qpsmtpd-0.84/plugins/logging/syslog000644 000765 000024 00000007723 11165321462 017442 0ustar00askstaff000000 000000 #!/usr/bin/perl # $Id$ =head1 NAME syslog - Syslog logging plugin for qpsmtpd =head1 DESCRIPTION The syslog plugin for qpsmtpd passes qpsmtpd log messages into the standard UNIX syslog facility, mapping qpsmtpd priorities to syslog priorities. =head1 CONFIGURATION To enable the logging plugin, add a line of this form to the qpsmtpd plugins configuration file: =over logging/syslog [loglevel l] [priority p] [ident str] [facility f] [logsock t] For example: logging/syslog loglevel LOGINFO priority LOG_NOTICE =back The following optional configuration settings can be supplied: =over =item B The internal log level below which messages will be logged. Priorities count downward as follows: =over =item B =item B =item B =item B =item B =item B =item B =item B =back =item B 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 setting is used, all messages will be logged at that priority regardless of what the original priority might have been. =item B The ident string that will be attached to messages logged via this plugin. The default is 'qpsmtpd'. =item B The syslog facility to which logged mesages will be directed. See syslog(3) for details. The default is LOG_MAIL. =item B The syslog socket where messages should be sent via syslogsock(). The valid options are 'udp', 'tcp', 'unix', 'stream' and 'console'. Not all are available on all systems. See Sys::Syslog for details. The default is the above list in that order. To select specific sockets, use a comma to separate the types. =over logsock udp,unix logsock stream =back =back =head1 AUTHOR Devin Carraway Peter Eisch (logsock support) =head1 LICENSE Copyright (c) 2005, Devin Carraway. This plugin is licensed under the same terms as the qpsmtpd package itself. Please see the LICENSE file included with qpsmtpd for details. =cut use strict; use warnings; use Sys::Syslog qw(:DEFAULT setlogsock); sub register { my ($self, $qp, @args) = @_; my %args; if (@args % 2 == 0) { %args = @args; } else { warn "Malformed arguments to syslog plugin"; return; } my $ident = 'qpsmtpd'; my $logopt = 'pid'; my $facility = 'LOG_MAIL'; $self->{_loglevel} = LOGWARN; if ($args{loglevel}) { if ($args{loglevel} =~ /^(\d+)$/) { $self->{_loglevel} = $1; } elsif ($args{loglevel} =~ /^(LOG\w+)$/) { $self->{_loglevel} = log_level($1) || LOGWARN; } } if ($args{priority}) { if ($args{priority} =~ /^(\d+|LOG\w+)$/) { $self->{_priority} = $1; } } if ($args{ident} && $args{ident} =~ /^([\w\-.]+)$/) { $ident = $1; } if ($args{facility} && $args{facility} =~ /^(\w+)$/) { $facility = $1; } if ($args{logsock}) { my @logopt = split(/,/, $args{logsock}); setlogsock(@logopt); } unless (openlog $ident, $logopt, $facility) { warn "Error opening syslog output"; return; } } my %priorities_ = ( 0 => 'LOG_EMERG', 1 => 'LOG_ALERT', 2 => 'LOG_CRIT', 3 => 'LOG_ERR', 4 => 'LOG_WARNING', 5 => 'LOG_NOTICE', 6 => 'LOG_INFO', 7 => 'LOG_DEBUG', ); sub hook_logging { my ($self, $transaction, $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 qpsmtpd-0.84/plugins/logging/transaction_id000644 000765 000024 00000004455 11165321462 021122 0ustar00askstaff000000 000000 #!/usr/bin/perl # this is a simple 'transaction_id' 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) = @_; die "The transaction ID feature is currently unsupported"; $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::transaction_id 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(" ", ($transaction ? $transaction->id : "???") . (defined $plugin ? " $plugin plugin:" : defined $hook ? " running plugin ($hook):" : ""), @log), "\n" if ($trace <= $self->{_level}); return DECLINED; } =cut =head1 NAME transaction_id - plugin to demo use of the transaction id =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. This plugin differs from logging/warn only by using the transaction id instead of the pid to demonstrate the effect of different algorithms. =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/transaction_id [loglevel] where the optional parameters C is either the numeric or text representation of the maximum log level, as shown in the L file. =head1 AUTHOR John Peacock =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 qpsmtpd-0.84/plugins/logging/warn000644 000765 000024 00000004015 11165321462 017060 0ustar00askstaff000000 000000 #!/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 is either the numeric or text representation of the maximum log level, as shown in the L file. =head1 AUTHOR John Peacock =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 qpsmtpd-0.84/plugins/ident/geoip000644 000765 000024 00000001230 11165321462 016665 0ustar00askstaff000000 000000 # -*- 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; sub hook_connect { my ($self) = @_; my $geoip = Geo::IP->new(GEOIP_STANDARD); 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; } qpsmtpd-0.84/plugins/ident/p0f000644 000765 000024 00000005244 11165321462 016260 0ustar00askstaff000000 000000 # -*- 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. All code heavily based upon the p0fq.pl included with the p0f distribution. =cut use IO::Socket; use Net::IP; my $QUERY_MAGIC = 0x0defaced; sub register { my ($self, $qp, $p0f_socket) = @_; $p0f_socket =~ /(.*)/; # untaint $self->{_args}->{p0f_socket} = $1; } sub hook_connect { my($self, $qp) = @_; my $p0f_socket = $self->{_args}->{p0f_socket}; my $srcport = my $destport = $self->qp->connection->local_port; my $src = new Net::IP ($self->qp->connection->remote_ip) or $self->log(LOGERROR, "p0f: ".Net::IP::Error()), return (DECLINED); my $dst = new Net::IP ($self->qp->connection->local_ip) or $self->log(LOGERROR, "p0f: ".NET::IP::Error()), return (DECLINED); my $query = pack("L L L N N S S", $QUERY_MAGIC, 1, rand ^ 42 ^ time, $src->intip(), $dst->intip(), $self->qp->connection->remote_port, $self->qp->connection->local_port); # Open the connection to p0f socket(SOCK, PF_UNIX, SOCK_STREAM, 0) or $self->log(LOGERROR, "p0f: socket: $!"), return (DECLINED); connect(SOCK, sockaddr_un($p0f_socket)) or $self->log(LOGERROR, "p0f: connect: $!"), return (DECLINED); defined syswrite SOCK, $query or $self->log(LOGERROR, "p0f: write: $!"), close SOCK, return (DECLINED); my $response; defined sysread SOCK, $response, 1024 or $self->log(LOGERROR, "p0f: read: $!"), close SOCK, return (DECLINED); 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); if ($magic != $QUERY_MAGIC) { $self->log(LOGERROR, "p0f: Bad response magic."); return (DECLINED); } if ($type == 1) { $self->log(LOGERROR, "p0f: P0f did not honor our query"); return (DECLINED); } if ($type == 2) { $self->log(LOGWARN, "p0f: This connection is no longer in the cache"); return (DECLINED); } my $p0f = { genre => $genre, detail => $detail, distance => $dist, link => $link, uptime => $uptime, }; $self->qp->connection->notes('p0f', $p0f); $self->log(LOGINFO, "Results: ".$p0f->{genre}." (".$p0f->{detail}.")"); $self->log(LOGERROR,"error: $@") if $@; return DECLINED; } qpsmtpd-0.84/plugins/auth/auth_cvm_unix_local000644 000765 000024 00000005321 11165321461 021447 0ustar00askstaff000000 000000 #!/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 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 = ; my ($s) = unpack ("C", $ret); return ( ($s ? $s == 100 ? DENY : DECLINED : OK), "authcvm/$method"); } qpsmtpd-0.84/plugins/auth/auth_flat_file000644 000765 000024 00000003366 11165321461 020401 0ustar00askstaff000000 000000 #!/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" ); } } qpsmtpd-0.84/plugins/auth/auth_ldap_bind000644 000765 000024 00000015555 11165321461 020373 0ustar00askstaff000000 000000 #!/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 =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 qpsmtpd-0.84/plugins/auth/auth_vpopmail_sql000644 000765 000024 00000007555 11165321461 021166 0ustar00askstaff000000 000000 #!/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 =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 = "vpoppasswd"; 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(<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" ); } } qpsmtpd-0.84/plugins/auth/authdeny000644 000765 000024 00000000747 11165321461 017254 0ustar00askstaff000000 000000 #!/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" ); } qpsmtpd-0.84/plugins/async/check_earlytalker000644 000765 000024 00000007764 11165321461 021271 0ustar00askstaff000000 000000 #!/usr/bin/perl -w =head1 NAME check_earlytalker - Check that the client doesn't talk before we send the SMTP banner =head1 DESCRIPTION Checks to see if the remote host starts talking before we've issued a 2xx greeting. If so, we're likely looking at a direct-to-MX spam agent which pipelines its entire SMTP conversation, and will happily dump an entire spam into our mail log even if later tests deny acceptance. Depending on configuration, clients which behave in this way are either immediately disconnected with a deny or denysoft code, or else are issued this on all mail/rcpt commands in the transaction. =head1 CONFIGURATION =over 4 =item wait [integer] The number of seconds to delay the initial greeting to see if the connecting host speaks first. The default is 1. Do not select a value that is too high, or you may be unable to receive mail from MTAs with short SMTP connect or greeting timeouts -- these are known to range as low as 30 seconds, and may in some cases be configured lower by mailserver admins. Network transit time must also be allowed for. =item action [string: deny, denysoft, log] What to do when matching an early-talker -- the options are I, I or I. If I is specified, the connection will be allowed to proceed as normal, and only a warning will be logged. The default is I. =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). The default is to react at the SMTP greeting stage by issuing the apropriate response code and terminating the SMTP connection. =item check-at [string: connect, data] Defines when to check for early talkers, either at connect time (pre-greet pause) or at DATA time (pause before sending "354 go ahead"). The default is I. Note that defer-reject has no meaning if check-at is I. =back =cut my $MSG = 'Connecting host started transmitting before SMTP greeting'; sub register { my ($self, $qp, @args) = @_; if (@args % 2) { $self->log(LOGERROR, "Unrecognized/mismatched arguments"); return undef; } $self->{_args} = { 'wait' => 1, 'action' => 'denysoft', 'defer-reject' => 0, 'check-at' => 'connect', @args, }; print STDERR "Check at: ", $self->{_args}{'check-at'}, "\n"; $self->register_hook($self->{_args}->{'check-at'}, 'check_talker_poll'); $self->register_hook($self->{_args}->{'check-at'}, 'check_talker_post'); if ($self->{_args}{'check-at'} eq 'connect') { $self->register_hook('mail', 'hook_mail') if $self->{_args}->{'defer-reject'}; } 1; } sub check_talker_poll { my ($self, $transaction) = @_; my $qp = $self->qp; my $conn = $qp->connection; my $check_until = time + $self->{_args}{'wait'}; $qp->AddTimer(1, sub { read_now($qp, $conn, $check_until, $self->{_args}{'check-at'}) }); return YIELD; } sub read_now { my ($qp, $conn, $until, $phase) = @_; if ($qp->has_data) { $qp->log(LOGNOTICE, 'remote host started talking after $phase before we responded'); $qp->clear_data if $phase eq 'data'; $conn->notes('earlytalker', 1); $qp->run_continuation; } elsif (time >= $until) { # no early talking $qp->run_continuation; } else { $qp->AddTimer(1, sub { read_now($qp, $conn, $until, $phase) }); } } sub check_talker_post { my ($self, $transaction) = @_; my $conn = $self->qp->connection; return DECLINED unless $conn->notes('earlytalker'); return DECLINED if $self->{'defer-reject'}; return (DENY,$MSG) if $self->{_args}->{'action'} eq 'deny'; return (DENYSOFT,$MSG) if $self->{_args}->{'action'} eq 'denysoft'; return DECLINED; # assume action eq 'log' } sub hook_mail { my ($self, $transaction) = @_; return DECLINED unless $self->connection->notes('earlytalker'); return (DENY,$MSG) if $self->{_args}->{'action'} eq 'deny'; return (DENYSOFT,$MSG) if $self->{_args}->{'action'} eq 'denysoft'; return DECLINED; } 1; qpsmtpd-0.84/plugins/async/dns_whitelist_soft000644 000765 000024 00000004641 11165321461 021517 0ustar00askstaff000000 000000 #!perl -w use Qpsmtpd::Plugin::Async::DNSBLBase; sub init { my $self = shift; my $class = ref $self; no strict 'refs'; push @{"${class}::ISA"}, 'Qpsmtpd::Plugin::Async::DNSBLBase'; } sub hook_connect { my ($self, $transaction) = @_; my $class = ref $self; my %whitelist_zones = map { (split /\s+/, $_, 2)[0, 1] } $self->qp->config('whitelist_zones'); return DECLINED unless %whitelist_zones; my $remote_ip = $self->connection->remote_ip; my $reversed_ip = join(".", reverse(split(/\./, $remote_ip))); # type TXT lookup only return DECLINED unless $class->lookup($self->qp, [], [map { "$reversed_ip.$_" } keys %whitelist_zones], ); return YIELD; } sub process_txt_result { my ($class, $qp, $result, $query) = @_; my $connection = $qp->connection; $connection->notes('whitelisthost', $result) unless $connection->notes('whitelisthost'); } sub hook_rcpt { my ($self, $transaction, $rcpt) = @_; my $connection = $self->qp->connection; if (my $note = $connection->notes('whitelisthost')) { my $ip = $connection->remote_ip; $self->log(LOGNOTICE, "Host $ip is whitelisted: $note"); } return DECLINED; } 1; =head1 NAME dns_whitelist_soft - dns-based whitelist override for other qpsmtpd plugins =head1 DESCRIPTION The dns_whitelist_soft plugin allows selected host to be whitelisted as exceptions to later plugin processing. It is most suitable for multisite installations, so that the whitelist is stored in one location and available from all. =head1 CONFIGURATION To enable the plugin, add it to the ~qpsmtpd/config/plugins file as usual. It should precede any plugins whose rejections you wish to override. You may have to alter those plugins to check the appropriate notes field. Several configuration files are supported, corresponding to different parts of the SMTP conversation: =over 4 =item whitelist_zones Any IP address listed in the whitelist_zones file is queried using the connecting MTA's IP address. Any A or TXT answer means that the remote HOST address can be selectively exempted at other stages by plugins testing for a 'whitelisthost' connection note. =back NOTE: in contrast to the non-async version, the other 'connect' hooks fired after the 'connect' hook of this plugin will see the 'whitelisthost' connection note, if set by this plugin. =cut qpsmtpd-0.84/plugins/async/dnsbl000644 000765 000024 00000013010 11165321461 016674 0ustar00askstaff000000 000000 #!/usr/bin/perl -w use Qpsmtpd::Plugin::Async::DNSBLBase; sub init { my ($self, $qp, $denial) = @_; my $class = ref $self; { no strict 'refs'; push @{"${class}::ISA"}, 'Qpsmtpd::Plugin::Async::DNSBLBase'; } if (defined $denial and $denial =~ /^disconnect$/i) { $self->{_dnsbl}->{DENY} = DENY_DISCONNECT; } else { $self->{_dnsbl}->{DENY} = DENY; } } sub hook_connect { my ($self, $transaction) = @_; my $class = ref $self; my $remote_ip = $self->connection->remote_ip; my $allow = grep { s/\.?$/./; $_ eq substr($remote_ip . '.', 0, length $_) } $self->qp->config('dnsbl_allow'); return DECLINED if $allow; my %dnsbl_zones = map { (split /:/, $_, 2)[0, 1] } $self->qp->config('dnsbl_zones'); return DECLINED unless %dnsbl_zones; my $reversed_ip = join(".", reverse(split(/\./, $remote_ip))); my @A_zones = grep { defined($dnsbl_zones{$_}) } keys %dnsbl_zones; my @TXT_zones = grep { !defined($dnsbl_zones{$_}) } keys %dnsbl_zones; if (@A_zones) { # message templates for responding to the client $self->connection->notes( dnsbl_templates => { map { +"$reversed_ip.$_" => $dnsbl_zones{$_} } @A_zones } ); } return DECLINED unless $class->lookup($self->qp, [map { "$reversed_ip.$_" } @A_zones], [map { "$reversed_ip.$_" } @TXT_zones], ); return YIELD; } sub process_a_result { my ($class, $qp, $result, $query) = @_; my $conn = $qp->connection; return if $conn->notes('dnsbl'); my $templates = $conn->notes('dnsbl_templates'); my $ip = $conn->remote_ip; my $template = $templates->{$query}; $template =~ s/%IP%/$ip/g; $conn->notes('dnsbl', $template); } sub process_txt_result { my ($class, $qp, $result, $query) = @_; my $conn = $qp->connection; $conn->notes('dnsbl', $result) unless $conn->notes('dnsbl'); } sub hook_rcpt { my ($self, $transaction, $rcpt) = @_; my $connection = $self->qp->connection; # RBLSMTPD being non-empty means it contains the failure message to return if (defined($ENV{'RBLSMTPD'}) && $ENV{'RBLSMTPD'} ne '') { my $result = $ENV{'RBLSMTPD'}; my $remote_ip = $self->connection->remote_ip; $result =~ s/%IP%/$remote_ip/g; return (DENY, join(" ", $self->qp->config('dnsbl_rejectmsg'), $result)); } my $note = $self->connection->notes('dnsbl'); return (DENY, $note) if $note; return DECLINED; } 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 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 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 qpsmtpd-0.84/plugins/async/queue/000755 000765 000024 00000000000 11357265152 017007 5ustar00askstaff000000 000000 qpsmtpd-0.84/plugins/async/require_resolvable_fromhost000644 000765 000024 00000011537 11165321461 023421 0ustar00askstaff000000 000000 #!/usr/bin/perl -w use Qpsmtpd::DSN; use ParaDNS; use Socket; use Qpsmtpd::TcpServer; my %invalid = (); my $has_ipv6 = Qpsmtpd::TcpServer::has_ipv6(); sub register { my ( $self, $qp ) = @_; foreach my $i ( $self->qp->config("invalid_resolvable_fromhost") ) { $i =~ s/^\s*//; $i =~ s/\s*$//; if ( $i =~ m#^((\d{1,3}\.){3}\d{1,3})/(\d\d?)# ) { $invalid{$1} = $3; } } $self->register_hook( mail => 'hook_mail_start' ); $self->register_hook( mail => 'hook_mail_done' ); } sub hook_mail_start { my ( $self, $transaction, $sender ) = @_; return DECLINED if ( $self->qp->connection->notes('whitelisthost') ); if ( $sender ne "<>" ) { unless ( $sender->host ) { # default of addr_bad_from_system is DENY, we use DENYSOFT here to # get the same behaviour as without Qpsmtpd::DSN... return Qpsmtpd::DSN->addr_bad_from_system( DENYSOFT, "FQDN required in the envelope sender" ); } return DECLINED if $sender->host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/; unless ($self->check_dns( $sender->host )) { return Qpsmtpd::DSN->temp_resolver_failed( "Could not resolve " . $sender->host ); } return YIELD; } return DECLINED; } sub hook_mail_done { my ( $self, $transaction, $sender ) = @_; return DECLINED if ( $self->qp->connection->notes('whitelisthost') ); if ( $sender ne "<>" && !$transaction->notes('resolvable_fromhost') ) { # default of temp_resolver_failed is DENYSOFT return Qpsmtpd::DSN->temp_resolver_failed( "Could not resolve " . $sender->host ); } return DECLINED; } sub check_dns { my ( $self, $host ) = @_; my @host_answers; my $qp = $self->qp; $qp->input_sock->pause_read; my $a_records = []; my $num_queries = 1; # queries in progress my $mx_found = 0; ParaDNS->new( callback => sub { my $mx = shift; return if $mx =~ /^[A-Z]+$/; # error my $addr = $mx->[0]; $mx_found = 1; $num_queries++; ParaDNS->new( callback => sub { push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/; }, finished => sub { $num_queries--; $self->finish_up($qp, $a_records, $num_queries) }, host => $addr, type => 'A', ); if ($has_ipv6) { $num_queries++; ParaDNS->new( callback => sub { push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/; }, finished => sub { $num_queries--; $self->finish_up($qp, $a_records, $num_queries) }, host => $addr, type => 'AAAA', ); } }, finished => sub { unless ($mx_found) { $num_queries++; ParaDNS->new( callback => sub { push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/; }, finished => sub { $num_queries--; $self->finish_up($qp, $a_records, $num_queries) }, host => $host, type => 'A', ); if ($has_ipv6) { $num_queries++; ParaDNS->new( callback => sub { push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/; }, finished => sub { $num_queries--; $self->finish_up($qp, $a_records, $num_queries) }, host => $host, type => 'AAAA', ); } } $num_queries--; $self->finish_up($qp, $a_records, $num_queries); }, host => $host, type => 'MX', ) or $qp->input_sock->continue_read, return; return 1; } sub finish_up { my ($self, $qp, $a_records, $num_queries) = @_; return if defined $qp->transaction->notes('resolvable_fromhost'); foreach my $addr (@$a_records) { if (is_valid($addr)) { $qp->transaction->notes('resolvable_fromhost', 1); $qp->input_sock->continue_read; $qp->run_continuation; return; } } unless ($num_queries) { # all queries returned no valid response $qp->transaction->notes('resolvable_fromhost', 0); $qp->input_sock->continue_read; $qp->run_continuation; } } sub is_valid { my $ip = shift; my ( $net, $mask ); foreach $net ( keys %invalid ) { $mask = $invalid{$net}; $mask = pack "B32", "1" x ($mask) . "0" x ( 32 - $mask ); return 0 if join( ".", unpack( "C4", inet_aton($ip) & $mask ) ) eq $net; } return 1; } # vim: ts=4 sw=4 expandtab syn=perl qpsmtpd-0.84/plugins/async/rhsbl000644 000765 000024 00000004633 11165321461 016717 0ustar00askstaff000000 000000 #!perl -w use Qpsmtpd::Plugin::Async::DNSBLBase; sub init { my $self = shift; my $class = ref $self; no strict 'refs'; push @{"${class}::ISA"}, 'Qpsmtpd::Plugin::Async::DNSBLBase'; } sub hook_mail { my ($self, $transaction, $sender) = @_; my $class = ref $self; return DECLINED if $sender->format eq '<>'; my %rhsbl_zones = map { (split /\s+/, $_, 2)[0, 1] } $self->qp->config('rhsbl_zones'); return DECLINED unless %rhsbl_zones; my $sender_host = $sender->host; my @A_zones = grep { defined($rhsbl_zones{$_}) } keys %rhsbl_zones; my @TXT_zones = grep { !defined($rhsbl_zones{$_}) } keys %rhsbl_zones; if (@A_zones) { # message templates for responding to the client $transaction->notes(rhsbl_templates => {map { +"$sender_host.$_" => $rhsbl_zones{$_} } @A_zones}); } return DECLINED unless $class->lookup($self->qp, [map { "$sender_host.$_" } @A_zones], [map { "$sender_host.$_" } @TXT_zones], ); return YIELD; } sub process_a_result { my ($class, $qp, $result, $query) = @_; my $transaction = $qp->transaction; $transaction->notes('rhsbl', $transaction->notes('rhsbl_templates')->{$query}) unless $transaction->notes('rhsbl'); } sub process_txt_result { my ($class, $qp, $result, $query) = @_; my $transaction = $qp->transaction; $transaction->notes('rhsbl', $result) unless $transaction->notes('rhsbl'); } sub hook_rcpt { my ($self, $transaction, $rcpt) = @_; my $host = $transaction->sender->host; my $note = $transaction->notes('rhsbl'); return (DENY, "Mail from $host rejected because it $note") if $note; return DECLINED; } 1; =head1 NAME rhsbl - handle RHSBL lookups =head1 DESCRIPTION Pluging that checks the host part of the sender's address against a configurable set of RBL services. =head1 CONFIGURATION This plugin reads the lists to use from the rhsbl_zones configuration file. Normal domain based dns blocking lists ("RBLs") which contain TXT records are specified simply as: dsn.rfc-ignorant.org To configure RBL services which do not contain TXT records in the DNS, but only A records, specify, after a whitespace, your own error message to return in the SMTP conversation e.g. abuse.rfc-ignorant.org does not support abuse@domain =cut qpsmtpd-0.84/plugins/async/uribl000644 000765 000024 00000007030 11165321461 016714 0ustar00askstaff000000 000000 #!/usr/bin/perl -w use Qpsmtpd::Plugin::Async::DNSBLBase; use strict; use warnings; sub init { my ($self, $qp, %args) = @_; my $class = ref $self; $self->isa_plugin("uribl"); { no strict 'refs'; push @{"${class}::ISA"}, 'Qpsmtpd::Plugin::Async::DNSBLBase'; } $self->SUPER::init($qp, %args); } sub register { my $self = shift; $self->register_hook('data_post', 'start_data_post'); $self->register_hook('data_post', 'finish_data_post'); } sub start_data_post { my ($self, $transaction) = @_; my $class = ref $self; my @names; my $queries = $self->lookup_start($transaction, sub { my ($self, $name) = @_; push @names, $name; }); my @hosts; foreach my $z (keys %{$self->{uribl_zones}}) { push @hosts, map { "$_.$z" } @names; } $transaction->notes(uribl_results => {}); $transaction->notes(uribl_zones => $self->{uribl_zones}); return DECLINED unless @hosts && $class->lookup($self->qp, [ @hosts ], [ @hosts ]); return YIELD; } sub finish_data_post { my ($self, $transaction) = @_; my $matches = $self->collect_results($transaction); for (@$matches) { $self->log(LOGWARN, $_->{desc}); if ($_->{action} eq 'add-header') { $transaction->header->add('X-URIBL-Match', $_->{desc}); } elsif ($_->{action} eq 'deny') { return (DENY, $_->{desc}); } elsif ($_->{action} eq 'denysoft') { return (DENYSOFT, $_->{desc}); } } return DECLINED; } sub init_resolver { } sub process_a_result { my ($class, $qp, $result, $query) = @_; my $transaction = $qp->transaction; my $results = $transaction->notes('uribl_results'); my $zones = $transaction->notes('uribl_zones'); foreach my $z (keys %$zones) { if ($query =~ /^(.*)\.$z$/) { my $name = $1; $results->{$z}->{$name}->{a} = $result; } } } sub process_txt_result { my ($class, $qp, $result, $query) = @_; my $transaction = $qp->transaction; my $results = $transaction->notes('uribl_results'); my $zones = $transaction->notes('uribl_zones'); foreach my $z (keys %$zones) { if ($query =~ /^(.*)\.$z$/) { my $name = $1; $results->{$z}->{$name}->{txt} = $result; } } } sub collect_results { my ($self, $transaction) = @_; my $results = $transaction->notes('uribl_results'); my @matches; foreach my $z (keys %$results) { foreach my $n (keys %{$results->{$z}}) { if (exists $results->{$z}->{$n}->{a}) { if ($self->evaluate($z, $results->{$z}->{$n}->{a})) { $self->log(LOGDEBUG, "match $n in $z"); push @matches, { action => $self->{uribl_zones}->{$z}->{action}, desc => "$n in $z: " . ($results->{$z}->{$n}->{txt} || $results->{$z}->{$n}->{a}), }; } } } } return \@matches; } 1; =head1 NAME uribl - URIBL blocking plugin for qpsmtpd =head1 DESCRIPTION This plugin implements DNSBL lookups for URIs found in spam, such as that implemented by SURBL (see Ehttp://surbl.org/E). Incoming messages are scanned for URIs, which are then checked against one or more URIBLs in a fashion similar to DNSBL systems. =head1 CONFIGURATION See the documentation of the non-async version. The timeout config option is ignored, the ParaDNS timeout is used instead. =cut qpsmtpd-0.84/plugins/async/queue/smtp-forward000644 000765 000024 00000022240 11165321461 021350 0ustar00askstaff000000 000000 #!/usr/bin/perl -w =head1 NAME smtp-forward =head1 DESCRIPTION This plugin forwards the mail via SMTP to a specified server, rather than delivering the email locally. =head1 CONFIG It takes one required parameter, the IP address or hostname to forward to. async/queue/smtp-forward 10.2.2.2 Optionally you can also add a port: async/queue/smtp-forward 10.2.2.2 9025 =cut use Qpsmtpd::Constants; sub register { my ($self, $qp) = @_; $self->register_hook(queue => "start_queue"); $self->register_hook(queue => "finish_queue"); } sub init { my ($self, $qp, @args) = @_; if (@args > 0) { if ($args[0] =~ /^([\.\w_-]+)$/) { $self->{_smtp_server} = $1; } else { die "Bad data in smtp server: $args[0]"; } $self->{_smtp_port} = 25; if (@args > 1 and $args[1] =~ /^(\d+)$/) { $self->{_smtp_port} = $1; } $self->log(LOGWARN, "WARNING: Ignoring additional arguments.") if (@args > 2); } else { die("No SMTP server specified in smtp-forward config"); } } sub start_queue { my ($self, $transaction) = @_; my $qp = $self->qp; my $SERVER = $self->{_smtp_server}; my $PORT = $self->{_smtp_port}; $self->log(LOGINFO, "forwarding to $SERVER:$PORT"); $transaction->notes('async_sender', AsyncSMTPSender->new($SERVER, $PORT, $qp, $self, $transaction) ); return YIELD; } sub finish_queue { my ($self, $transaction) = @_; my $sender = $transaction->notes('async_sender'); $transaction->notes('async_sender', undef); my ($rc, $msg) = $sender->results; return $rc, $msg; } package AsyncSMTPSender; use IO::Socket; use base qw(Danga::Socket); use fields qw( qp pkg tran state rcode rmsg buf command resp to ); use constant ST_CONNECTING => 0; use constant ST_CONNECTED => 1; use constant ST_COMMANDS => 2; use constant ST_DATA => 3; use Qpsmtpd::Constants; sub new { my ($self, $server, $port, $qp, $pkg, $transaction) = @_; $self = fields::new($self) unless ref $self; my $sock = IO::Socket::INET->new( PeerAddr => $server, PeerPort => $port, Blocking => 0, ) or die "Error connecting to server $server:$port : $!\n"; IO::Handle::blocking($sock, 0); binmode($sock, ':raw'); $self->{qp} = $qp; $self->{pkg} = $pkg; $self->{tran} = $transaction; $self->{state} = ST_CONNECTING; $self->{rcode} = DECLINED; $self->{command} = 'connect'; $self->{buf} = ''; $self->{resp} = []; # copy the recipients so we can pop them off one by one $self->{to} = [ $transaction->recipients ]; $self->SUPER::new($sock); # Watch for write first, this is when the TCP session is established. $self->watch_write(1); return $self; } sub results { my AsyncSMTPSender $self = shift; return ( $self->{rcode}, $self->{rmsg} ); } sub log { my AsyncSMTPSender $self = shift; $self->{qp}->log(@_); } sub cont { my AsyncSMTPSender $self = shift; $self->{qp}->run_continuation; } sub command { my AsyncSMTPSender $self = shift; my ($command, $params) = @_; $params ||= ''; $self->log(LOGDEBUG, ">> $command $params"); $self->write(($command =~ m/ / ? "$command:" : $command) . ($params ? " $params" : "") . "\r\n"); $self->watch_read(1); $self->{command} = ($command =~ /(\S+)/)[0]; } sub handle_response { my AsyncSMTPSender $self = shift; my $method = "cmd_" . lc($self->{command}); $self->$method(@_); } sub cmd_connect { my AsyncSMTPSender $self = shift; my ($code, $response) = @_; if ($code != 220) { $self->{rmsg} = "Error on connect: @$response"; $self->close; $self->cont; } else { my $host = $self->{qp}->config('me'); print "HELOing with $host\n"; $self->command((join '', @$response) =~ m/ ESMTP/ ? "EHLO" : "HELO", $host); } } sub cmd_helo { my AsyncSMTPSender $self = shift; my ($code, $response) = @_; if ($code != 250) { $self->{rmsg} = "Error on HELO: @$response"; $self->close; $self->cont; } else { $self->command("MAIL", "FROM:" . $self->{tran}->sender->format); } } sub cmd_ehlo { my AsyncSMTPSender $self = shift; my ($code, $response) = @_; if ($code != 250) { $self->{rmsg} = "Error on EHLO: @$response"; $self->close; $self->cont; } else { $self->command("MAIL", "FROM:" . $self->{tran}->sender->format); } } sub cmd_mail { my AsyncSMTPSender $self = shift; my ($code, $response) = @_; if ($code != 250) { $self->{rmsg} = "Error on MAIL FROM: @$response"; $self->close; $self->cont; } else { $self->command("RCPT", "TO:" . shift(@{$self->{to}})->format); } } sub cmd_rcpt { my AsyncSMTPSender $self = shift; my ($code, $response) = @_; if ($code != 250) { $self->{rmsg} = "Error on RCPT TO: @$response"; $self->close; $self->cont; } else { if (@{$self->{to}}) { $self->command("RCPT", "TO:" . shift(@{$self->{to}})->format); } else { $self->command("DATA"); } } } sub cmd_data { my AsyncSMTPSender $self = shift; my ($code, $response) = @_; if ($code != 354) { $self->{rmsg} = "Error on DATA: @$response"; $self->close; $self->cont; } else { # $self->{state} = ST_DATA; $self->datasend($self->{tran}->header->as_string); $self->{tran}->body_resetpos; my $write_buf = ''; while (my $line = $self->{tran}->body_getline) { $line =~ s/\r?\n/\r\n/; $write_buf .= $line; if (length($write_buf) >= 131072) { # 128KB, arbitrary value $self->log(LOGDEBUG, ">> $write_buf"); $self->datasend($write_buf); $write_buf = ''; } } if (length($write_buf)) { $self->log(LOGDEBUG, ">> $write_buf"); $self->datasend($write_buf); } $self->write(".\r\n"); $self->{command} = "DATAEND"; } } sub cmd_dataend { my AsyncSMTPSender $self = shift; my ($code, $response) = @_; if ($code != 250) { $self->{rmsg} = "Error after DATA: @$response"; $self->close; $self->cont; } else { $self->command("QUIT"); } } sub cmd_quit { my AsyncSMTPSender $self = shift; my ($code, $response) = @_; $self->{rcode} = OK; $self->{rmsg} = "Queued!"; $self->close; $self->cont; } sub datasend { my AsyncSMTPSender $self = shift; my ($data) = @_; $data =~ s/^\./../mg; $self->write(\$data); } sub event_read { my AsyncSMTPSender $self = shift; if ($self->{state} == ST_CONNECTED) { $self->{state} = ST_COMMANDS; } if ($self->{state} == ST_COMMANDS) { my $in = $self->read(1024); if (!$in) { # XXX: connection closed $self->close("lost connection"); return; } my @lines = split /\r?\n/, $self->{buf} . $$in, -1; $self->{buf} = delete $lines[-1]; for(@lines) { if (my ($code, $cont, $rest) = /^([0-9]{3})([ -])(.*)/) { $self->log(LOGDEBUG, "<< $code$cont$rest"); push @{$self->{resp}}, $rest; if($cont eq ' ') { $self->handle_response($code, $self->{resp}); $self->{resp} = []; } } else { $self->log(LOGERROR, "Unrecognised SMTP response line: $_"); $self->{rmsg} = "Error from upstream SMTP server"; $self->close; $self->cont; } } } else { $self->log(LOGERROR, "SMTP Session occurred out of order"); $self->close; $self->cont; } } sub event_write { my AsyncSMTPSender $self = shift; if ($self->{state} == ST_CONNECTING) { $self->watch_write(0); $self->{state} = ST_CONNECTED; $self->watch_read(1); } elsif (0 && $self->{state} == ST_DATA) { # send more data if (my $line = $self->{tran}->body_getline) { $self->log(LOGDEBUG, ">> $line"); $line =~ s/\r?\n/\r\n/; $self->datasend($line); } else { # no more data. $self->log(LOGINFO, "No more data"); $self->watch_write(0); $self->{state} = ST_COMMANDS; } } else { $self->write(undef); } } sub event_err { my ($self) = @_; eval { $self->read(1); }; # gives us the correct error in errno $self->{rmsg} = "Read error from remote server: $!"; #print "lost connection: $!\n"; $self->close; $self->cont; } sub event_hup { my ($self) = @_; eval { $self->read(1); }; # gives us the correct error in errno $self->{rmsg} = "HUP error from remote server: $!"; #print "lost connection: $!\n"; $self->close; $self->cont; } qpsmtpd-0.84/log/run000755 000765 000024 00000000127 11144617464 014401 0ustar00askstaff000000 000000 #! /bin/sh export LOGDIR=./main mkdir -p $LOGDIR exec multilog t s1000000 n20 $LOGDIR qpsmtpd-0.84/lib/Apache/000755 000765 000024 00000000000 11357265152 015014 5ustar00askstaff000000 000000 qpsmtpd-0.84/lib/Danga/000755 000765 000024 00000000000 11357265152 014645 5ustar00askstaff000000 000000 qpsmtpd-0.84/lib/Qpsmtpd/000755 000765 000024 00000000000 11357265152 015263 5ustar00askstaff000000 000000 qpsmtpd-0.84/lib/Qpsmtpd.pm000644 000765 000024 00000043241 11357264740 015627 0ustar00askstaff000000 000000 package Qpsmtpd; use strict; use vars qw($VERSION $TraceLevel $Spool_dir $Size_threshold); use Sys::Hostname; use Qpsmtpd::Constants; #use DashProfiler; $VERSION = "0.84"; my $git; if (-e ".git") { local $ENV{PATH} = "/usr/bin:/usr/local/bin:/opt/local/bin/"; $git = `git describe`; $git && chomp $git; } my $hooks = {}; my %defaults = ( me => hostname, timeout => 1200, ); my $_config_cache = {}; my %config_dir_memo; #DashProfiler->add_profile("qpsmtpd"); #my $SAMPLER = DashProfiler->prepare("qpsmtpd"); my $LOGGING_LOADED = 0; sub _restart { my $self = shift; my %args = @_; if ($args{restart}) { # reset all global vars to defaults $self->clear_config_cache; $hooks = {}; $LOGGING_LOADED = 0; %config_dir_memo = (); $TraceLevel = LOGWARN; $Spool_dir = undef; $Size_threshold = undef; } } sub DESTROY { #warn $_ for DashProfiler->profile_as_text("qpsmtpd"); } sub version { $VERSION . ($git ? "/$git" : "") }; sub TRACE_LEVEL { $TraceLevel }; # leave for plugin compatibility sub hooks { $hooks; } sub load_logging { # need to do this differently that other plugins so as to # not trigger logging activity return if $LOGGING_LOADED; my $self = shift; return if $hooks->{"logging"}; my $configdir = $self->config_dir("logging"); my $configfile = "$configdir/logging"; my @loggers = $self->_config_from_file($configfile,'logging'); $configdir = $self->config_dir('plugin_dirs'); $configfile = "$configdir/plugin_dirs"; my @plugin_dirs = $self->_config_from_file($configfile,'plugin_dirs'); unless (@plugin_dirs) { my ($name) = ($0 =~ m!(.*?)/([^/]+)$!); @plugin_dirs = ( "$name/plugins" ); } my @loaded; for my $logger (@loggers) { push @loaded, $self->_load_plugin($logger, @plugin_dirs); } foreach my $logger (@loaded) { $self->log(LOGINFO, "Loaded $logger"); } $configdir = $self->config_dir("loglevel"); $configfile = "$configdir/loglevel"; $TraceLevel = $self->_config_from_file($configfile,'loglevel'); unless (defined($TraceLevel) and $TraceLevel =~ /^\d+$/) { $TraceLevel = LOGWARN; # Default if no loglevel file found. } $LOGGING_LOADED = 1; return @loggers; } sub trace_level { my $self = shift; return $TraceLevel; } sub init_logger { # needed for compatibility purposes shift->trace_level(); } sub log { my ($self, $trace, @log) = @_; $self->varlog($trace,join(" ",@log)); } sub varlog { my ($self, $trace) = (shift,shift); my ($hook, $plugin, @log); if ( $#_ == 0 ) { # log itself (@log) = @_; } elsif ( $#_ == 1 ) { # plus the hook ($hook, @log) = @_; } else { # called from plugin ($hook, $plugin, @log) = @_; } $self->load_logging; # in case we already don't have this loaded yet my ($rc) = $self->run_hooks_no_respond("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 ($hook):" : defined $hook ? " running plugin ($hook):" : ""), @log), "\n" if $trace <= $TraceLevel; } } sub clear_config_cache { $_config_cache = {}; } # # method to get the configuration. It just calls get_qmail_config by # default, but it could be overwritten to look configuration up in a # database or whatever. # sub config { my ($self, $c, $type) = @_; $self->log(LOGDEBUG, "in config($c)"); # first try the cache # XXX - is this always the right thing to do? what if a config hook # can return different values on subsequent calls? if ($_config_cache->{$c}) { $self->log(LOGDEBUG, "config($c) returning (@{$_config_cache->{$c}}) from cache"); return wantarray ? @{$_config_cache->{$c}} : $_config_cache->{$c}->[0]; } # then run the hooks my ($rc, @config) = $self->run_hooks_no_respond("config", $c); $self->log(LOGDEBUG, "config($c): hook returned ($rc, @config) "); if ($rc == OK) { $self->log(LOGDEBUG, "setting _config_cache for $c to [@config] from hooks and returning it"); $_config_cache->{$c} = \@config; return wantarray ? @{$_config_cache->{$c}} : $_config_cache->{$c}->[0]; } # and then get_qmail_config @config = $self->get_qmail_config($c, $type); if (@config) { $self->log(LOGDEBUG, "setting _config_cache for $c to [@config] from get_qmail_config and returning it"); $_config_cache->{$c} = \@config; return wantarray ? @{$_config_cache->{$c}} : $_config_cache->{$c}->[0]; } # finally we use the default if there is any: if (exists($defaults{$c})) { $self->log(LOGDEBUG, "setting _config_cache for $c to @{[$defaults{$c}]} from defaults and returning it"); $_config_cache->{$c} = [$defaults{$c}]; return wantarray ? @{$_config_cache->{$c}} : $_config_cache->{$c}->[0]; } return; } sub config_dir { my ($self, $config) = @_; if (exists $config_dir_memo{$config}) { return $config_dir_memo{$config}; } my $configdir = ($ENV{QMAIL} || '/var/qmail') . '/control'; my ($path) = ($ENV{PROCESS} ? $ENV{PROCESS} : $0) =~ m!(.*?)/([^/]+)$!; $configdir = "$path/config" if (-e "$path/config/$config"); if (exists $ENV{QPSMTPD_CONFIG}) { $ENV{QPSMTPD_CONFIG} =~ /^(.*)$/; # detaint $configdir = $1 if -e "$1/$config"; } return $config_dir_memo{$config} = $configdir; } sub plugin_dirs { my $self = shift; my @plugin_dirs = $self->config('plugin_dirs'); unless (@plugin_dirs) { my ($path) = ($ENV{PROCESS} ? $ENV{PROCESS} : $0) =~ m!(.*?)/([^/]+)$!; @plugin_dirs = ( "$path/plugins" ); } return @plugin_dirs; } sub get_qmail_config { my ($self, $config, $type) = @_; $self->log(LOGDEBUG, "trying to get config for $config"); my $configdir = $self->config_dir($config); my $configfile = "$configdir/$config"; # CDB config support really should be moved to a plugin if ($type and $type eq "map") { unless (-e $configfile . ".cdb") { $_config_cache->{$config} ||= []; return +{}; } eval { require CDB_File }; if ($@) { $self->log(LOGERROR, "No CDB Support! Did NOT read $configfile.cdb, could not load CDB_File module: $@"); return +{}; } my %h; unless (tie(%h, 'CDB_File', "$configfile.cdb")) { $self->log(LOGERROR, "tie of $configfile.cdb failed: $!"); return +{}; } # We explicitly don't cache cdb entries. The assumption is that # the data is in a CDB file in the first place because there's # lots of data and the cache hit ratio would be low. return \%h; } return $self->_config_from_file($configfile, $config); } sub _config_from_file { my ($self, $configfile, $config, $visited) = @_; unless (-e $configfile) { $_config_cache->{$config} ||= []; return; } $visited ||= []; push @{$visited}, $configfile; open CF, "<$configfile" or warn "$$ could not open configfile $configfile: $!" and return; my @config = ; chomp @config; @config = grep { length($_) and $_ !~ m/^\s*#/ and $_ =~ m/\S/} map {s/^\s+//; s/\s+$//; $_;} # trim leading/trailing whitespace @config; close CF; my $pos = 0; while ($pos < @config) { # recursively pursue an $include reference, if found. An inclusion which # begins with a leading slash is interpreted as a path to a file and will # supercede the usual config path resolution. Otherwise, the normal # config_dir() lookup is employed (the location in which the inclusion # appeared receives no special precedence; possibly it should, but it'd # be complicated beyond justifiability for so simple a config system. if ($config[$pos] =~ /^\s*\$include\s+(\S+)\s*$/) { my ($includedir, $inclusion) = ('', $1); splice @config, $pos, 1; # remove the $include line if ($inclusion !~ /^\//) { $includedir = $self->config_dir($inclusion); $inclusion = "$includedir/$inclusion"; } if (grep($_ eq $inclusion, @{$visited})) { $self->log(LOGERROR, "Circular \$include reference in config $config:"); $self->log(LOGERROR, "From $visited->[0]:"); $self->log(LOGERROR, " includes $_") for (@{$visited}[1..$#{$visited}], $inclusion); return wantarray ? () : undef; } push @{$visited}, $inclusion; for my $inc ($self->expand_inclusion_($inclusion, $configfile)) { my @insertion = $self->_config_from_file($inc, $config, $visited); splice @config, $pos, 0, @insertion; # insert the inclusion $pos += @insertion; } } else { $pos++; } } $_config_cache->{$config} = \@config; return wantarray ? @config : $config[0]; } sub expand_inclusion_ { my $self = shift; my $inclusion = shift; my $context = shift; my @includes; if (-d $inclusion) { $self->log(LOGDEBUG, "inclusion of directory $inclusion from $context"); if (opendir(INCD, $inclusion)) { @includes = map { "$inclusion/$_" } (grep { -f "$inclusion/$_" and !/^\./ } sort readdir INCD); closedir INCD; } else { $self->log(LOGERROR, "Couldn't open directory $inclusion,". " referenced from $context ($!)"); } } else { $self->log(LOGDEBUG, "inclusion of file $inclusion from $context"); @includes = ( $inclusion ); } return @includes; } sub load_plugins { my $self = shift; my @plugins = $self->config('plugins'); my @loaded; if ($hooks->{queue}) { #$self->log(LOGWARN, "Plugins already loaded"); return @plugins; } for my $plugin_line (@plugins) { my $this_plugin = $self->_load_plugin($plugin_line, $self->plugin_dirs); push @loaded, $this_plugin if $this_plugin; } return @loaded; } sub _load_plugin { my $self = shift; my ($plugin_line, @plugin_dirs) = @_; my ($plugin, @args) = split ' ', $plugin_line; my $package; if ($plugin =~ m/::/) { # "full" package plugin (My::Plugin) $package = $plugin; $package =~ s/[^_a-z0-9:]+//gi; my $eval = qq[require $package;\n] .qq[sub ${plugin}::plugin_name { '$plugin' }]; $eval =~ m/(.*)/s; $eval = $1; eval $eval; die "Failed loading $package - eval $@" if $@; $self->log(LOGDEBUG, "Loading $package ($plugin_line)") unless $plugin_line =~ /logging/; } else { # regular plugins/$plugin plugin my $plugin_name = $plugin; $plugin =~ s/:\d+$//; # after this point, only used for filename # Escape everything into valid perl identifiers $plugin_name =~ s/([^A-Za-z0-9_\/])/sprintf("_%2x",unpack("C",$1))/eg; # second pass cares for slashes and words starting with a digit $plugin_name =~ s{ (/+) # directory (\d?) # package's first character }[ "::" . (length $2 ? sprintf("_%2x",unpack("C",$2)) : "") ]egx; $package = "Qpsmtpd::Plugin::$plugin_name"; # don't reload plugins if they are already loaded unless ( defined &{"${package}::plugin_name"} ) { PLUGIN_DIR: for my $dir (@plugin_dirs) { if (-e "$dir/$plugin") { Qpsmtpd::Plugin->compile($plugin_name, $package, "$dir/$plugin", $self->{_test_mode}, $plugin); $self->log(LOGDEBUG, "Loading $plugin_line from $dir/$plugin") unless $plugin_line =~ /logging/; last PLUGIN_DIR; } } die "Plugin $plugin_name not found in our plugin dirs (", join(", ", @plugin_dirs),")" unless defined &{"${package}::plugin_name"}; } } my $plug = $package->new(); $plug->_register($self, @args); return $plug; } sub transaction { return {}; # base class implements empty transaction } sub run_hooks { my ($self, $hook) = (shift, shift); if ($hooks->{$hook}) { my @r; my @local_hooks = @{$hooks->{$hook}}; $self->{_continuation} = [$hook, [@_], @local_hooks]; return $self->run_continuation(); } return $self->hook_responder($hook, [0, ''], [@_]); } sub run_hooks_no_respond { my ($self, $hook) = (shift, shift); if ($hooks->{$hook}) { my @r; for my $code (@{$hooks->{$hook}}) { eval { (@r) = $code->{code}->($self, $self->transaction, @_); }; $@ and warn("FATAL PLUGIN ERROR [" . $code->{name} . "]: ", $@) and next; if ($r[0] == YIELD) { die "YIELD not valid from $hook hook"; } last unless $r[0] == DECLINED; } $r[0] = DECLINED if not defined $r[0]; return @r; } return (0, ''); } sub continue_read {} # subclassed in -async sub pause_read { die "Continuations only work in qpsmtpd-async" } sub run_continuation { my $self = shift; #my $t1 = $SAMPLER->("run_hooks", undef, 1); die "No continuation in progress" unless $self->{_continuation}; $self->continue_read(); my $todo = $self->{_continuation}; $self->{_continuation} = undef; my $hook = shift @$todo || die "No hook in the continuation"; my $args = shift @$todo || die "No hook args in the continuation"; my @r; while (@$todo) { my $code = shift @$todo; #my $t2 = $SAMPLER->($hook . "_" . $code->{name}, undef, 1); #warn("Got sampler called: ${hook}_$code->{name}\n"); $self->varlog(LOGDEBUG, $hook, $code->{name}); my $tran = $self->transaction; eval { (@r) = $code->{code}->($self, $tran, @$args); }; $@ and $self->log(LOGCRIT, "FATAL PLUGIN ERROR [" . $code->{name} . "]: ", $@) and next; !defined $r[0] and $self->log(LOGERROR, "plugin ".$code->{name} ." running the $hook hook returned undef!") and next; # note this is wrong as $tran is always true in the # current code... if ($tran) { my $tnotes = $tran->notes( $code->{name} ); $tnotes->{"hook_$hook"}->{'return'} = $r[0] if (!defined $tnotes || ref $tnotes eq "HASH"); } else { my $cnotes = $self->connection->notes( $code->{name} ); $cnotes->{"hook_$hook"}->{'return'} = $r[0] if (!defined $cnotes || ref $cnotes eq "HASH"); } if ($r[0] == YIELD) { $self->pause_read(); $self->{_continuation} = [$hook, $args, @$todo]; return @r; } elsif ($r[0] == DENY or $r[0] == DENYSOFT or $r[0] == DENY_DISCONNECT or $r[0] == DENYSOFT_DISCONNECT) { $r[1] = "" if not defined $r[1]; $self->log(LOGDEBUG, "Plugin ".$code->{name}. ", hook $hook returned ".return_code($r[0]).", $r[1]"); $self->run_hooks_no_respond("deny", $code->{name}, $r[0], $r[1]) unless ($hook eq "deny"); } else { $r[1] = "" if not defined $r[1]; $self->log(LOGDEBUG, "Plugin ".$code->{name}. ", hook $hook returned ".return_code($r[0]).", $r[1]"); $self->run_hooks_no_respond("ok", $code->{name}, $r[0], $r[1]) unless ($hook eq "ok"); } last unless $r[0] == DECLINED; } $r[0] = DECLINED if not defined $r[0]; # hook_*_parse() may return a CODE ref.. # ... which breaks when splitting as string: @r = map { split /\n/ } @r unless (ref($r[1]) eq "CODE"); return $self->hook_responder($hook, \@r, $args); } sub hook_responder { my ($self, $hook, $msg, $args) = @_; #my $t1 = $SAMPLER->("hook_responder", undef, 1); my $code = shift @$msg; my $responder = $hook . '_respond'; if (my $meth = $self->can($responder)) { return $meth->($self, $code, $msg, $args); } return $code, @$msg; } sub _register_hook { my $self = shift; my ($hook, $code, $unshift) = @_; if ($unshift) { unshift @{$hooks->{$hook}}, $code; } else { push @{$hooks->{$hook}}, $code; } } sub spool_dir { my $self = shift; unless ( $Spool_dir ) { # first time through $self->log(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 my $Spool_perms = $self->config('spool_perms') || '0700'; if (-d $Spool_dir) { # Make sure the spool dir has appropriate rights $self->log(LOGWARN, "Permissions on spool_dir $Spool_dir are not $Spool_perms") unless ((stat $Spool_dir)[2] & 07777) == oct($Spool_perms); } else { # Or create it if it doesn't already exist mkdir($Spool_dir,oct($Spool_perms)) 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 authenticated { my $self = shift; return (defined $self->{_auth} ? $self->{_auth} : "" ); } sub auth_user { my $self = shift; return (defined $self->{_auth_user} ? $self->{_auth_user} : "" ); } sub auth_mechanism { my $self = shift; return (defined $self->{_auth_mechanism} ? $self->{_auth_mechanism} : "" ); } 1; __END__ =head1 NAME Qpsmtpd - base class for the qpsmtpd mail server =head1 DESCRIPTION This is the base class for the qpsmtpd mail server. See L and the I file for more information. =head1 COPYRIGHT Copyright 2001-2010 Ask Bjørn Hansen, Develooper LLC. See the LICENSE file for more information. qpsmtpd-0.84/lib/Qpsmtpd/Address.pm000644 000765 000024 00000024544 11165321461 017210 0ustar00askstaff000000 000000 #!/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(''); 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('') 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 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 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 "" or indeed for the bounce address "<>". =back The resulting objects can be stored in arrays or used in plugins to test for equality (like in badmailfrom). =cut sub new { my ($class, $user, $host) = @_; my $self = {}; if ($user =~ /^<(.*)>$/ ) { ($user, $host) = $class->canonify($user); return undef unless defined $user; } elsif ( not defined $host ) { my $address = $user; ($user, $host) = $address =~ m/(.*)(?:\@(.*))/; } $self->{_user} = $user; $self->{_host} = $host; return bless $self, $class; } # Definition of an address ("path") from RFC 2821: # # Path = "<" [ A-d-l ":" ] Mailbox ">" # # A-d-l = At-domain *( "," A-d-l ) # ; Note that this form, the so-called "source route", # ; MUST BE accepted, SHOULD NOT be generated, and SHOULD be # ; ignored. # # At-domain = "@" domain # # Mailbox = Local-part "@" Domain # # Local-part = Dot-string / Quoted-string # ; MAY be case-sensitive # # Dot-string = Atom *("." Atom) # # Atom = 1*atext # # Quoted-string = DQUOTE *qcontent DQUOTE # # Domain = (sub-domain 1*("." sub-domain)) / address-literal # sub-domain = Let-dig [Ldh-str] # # address-literal = "[" IPv4-address-literal / # IPv6-address-literal / # General-address-literal "]" # # IPv4-address-literal = Snum 3("." Snum) # IPv6-address-literal = "IPv6:" IPv6-addr # General-address-literal = Standardized-tag ":" 1*dcontent # Standardized-tag = Ldh-str # ; MUST be specified in a standards-track RFC # ; and registered with IANA # # Snum = 1*3DIGIT ; representing a decimal integer # ; value in the range 0 through 255 # Let-dig = ALPHA / DIGIT # Ldh-str = *( ALPHA / DIGIT / "-" ) Let-dig # # IPv6-addr = IPv6-full / IPv6-comp / IPv6v4-full / IPv6v4-comp # IPv6-hex = 1*4HEXDIG # IPv6-full = IPv6-hex 7(":" IPv6-hex) # IPv6-comp = [IPv6-hex *5(":" IPv6-hex)] "::" [IPv6-hex *5(":" # IPv6-hex)] # ; The "::" represents at least 2 16-bit groups of zeros # ; No more than 6 groups in addition to the "::" may be # ; present # IPv6v4-full = IPv6-hex 5(":" IPv6-hex) ":" IPv4-address-literal # IPv6v4-comp = [IPv6-hex *3(":" IPv6-hex)] "::" # [IPv6-hex *3(":" IPv6-hex) ":"] IPv4-address-literal # ; The "::" represents at least 2 16-bit groups of zeros # ; No more than 4 groups in addition to the "::" and # ; IPv4-address-literal may be present # # # # atext and qcontent are not defined in RFC 2821. # From RFC 2822: # # atext = ALPHA / DIGIT / ; Any character except controls, # "!" / "#" / ; SP, and specials. # "$" / "%" / ; Used for atoms # "&" / "'" / # "*" / "+" / # "-" / "/" / # "=" / "?" / # "^" / "_" / # "`" / "{" / # "|" / "}" / # "~" # qtext = NO-WS-CTL / ; Non white space controls # # %d33 / ; The rest of the US-ASCII # %d35-91 / ; characters not including "\" # %d93-126 ; or the quote character # # qcontent = qtext / quoted-pair # # NO-WS-CTL = %d1-8 / ; US-ASCII control characters # %d11 / ; that do not include the # %d12 / ; carriage return, line feed, # %d14-31 / ; and white space characters # %d127 # # quoted-pair = ("\" text) / obs-qp # # text = %d1-9 / ; Characters excluding CR and LF # %d11 / # %d12 / # %d14-127 / # obs-text # # # (We ignore all obs forms) =head2 canonify() Primarily an internal method, it is used only on the path portion of an e-mail message, as defined in RFC-2821 (this is the part inside the angle brackets and does not include the "human readable" portion of an address). It returns a list of (local-part, domain). =cut # address components are defined as package variables so that they can # be overriden (in hook_pre_connection, for example) if people have # different needs. our $atom_expr = '[a-zA-Z0-9!#%&*+=?^_`{|}~\$\x27\x2D\/]+'; our $address_literal_expr = '(?:\[(?:\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}|IPv6:[0-9A-Fa-f:.]+)\])'; our $subdomain_expr = '(?:[a-zA-Z0-9](?:[-a-zA-Z0-9]*[a-zA-Z0-9])?)'; our $domain_expr; our $qtext_expr = '[\x01-\x08\x0B\x0C\x0E-\x1F\x21\x23-\x5B\x5D-\x7F]'; our $text_expr = '[\x01-\x09\x0B\x0C\x0E-\x7F]'; sub canonify { my ($dummy, $path) = @_; # strip delimiters return undef unless ($path =~ /^<(.*)>$/); $path = $1; my $domain = $domain_expr ? $domain_expr : "$subdomain_expr(?:\.$subdomain_expr)*"; # it is possible for $address_literal_expr to be empty, if a site # doesn't want to allow them $domain = "(?:$address_literal_expr|$domain)" if !$domain_expr and $address_literal_expr; # strip source route $path =~ s/^\@$domain(?:,\@$domain)*://; # empty path is ok return "" if $path eq ""; # bare postmaster is permissible, perl RFC-2821 (4.5.1) return ("postmaster", undef) if $path =~ m/^postmaster$/i; my ($localpart, $domainpart) = ($path =~ /^(.*)\@($domain)$/); return (undef) unless defined $localpart; if ($localpart =~ /^$atom_expr(\.$atom_expr)*/) { # simple case, we are done return ($localpart, $domainpart); } if ($localpart =~ /^"(($qtext_expr|\\$text_expr)*)"$/) { $localpart = $1; $localpart =~ s/\\($text_expr)/$1/g; return ($localpart, $domainpart); } return (undef); } =head2 parse() Retained as a compatibility method, it is completely equivalent to new() called with a single parameter. =cut sub parse { # retain for compatibility only return shift->new(shift); } =head2 address() Can be used to reset the value of an existing Q::A object, in which case it takes a parameter with or without the angle brackets. Returns the stringified representation of the address. NOTE: does not escape any of the characters that need escaping, nor does it include the surrounding angle brackets. For that purpose, see L. =cut sub address { my ($self, $val) = @_; if ( defined($val) ) { $val = "<$val>" unless $val =~ /^<.+>$/; my ($user, $host) = $self->canonify($val); $self->{_user} = $user; $self->{_host} = $host; } return ( defined $self->{_user} ? $self->{_user} : '' ) . ( defined $self->{_host} ? '@'.$self->{_host} : '' ); } =head2 format() Returns the canonical stringified representation of the address. It does escape any characters requiring it (per RFC-2821/2822) and it does include the surrounding angle brackets. It is also the default stringification operator, so the following are equivalent: print $rcpt->format(); print $rcpt; =cut sub format { my ($self) = @_; my $qchar = '[^a-zA-Z0-9!#\$\%\&\x27\*\+\x2D\/=\?\^_`{\|}~.]'; return '<>' unless defined $self->{_user}; if ( ( my $user = $self->{_user}) =~ s/($qchar)/\\$1/g) { return qq(<"$user") . ( defined $self->{_host} ? '@'.$self->{_host} : '' ). ">"; } return "<".$self->address().">"; } =head2 user([$user]) Returns the "localpart" of the address, per RFC-2821, or the portion before the '@' sign. If called with one parameter, the localpart is set and the new value is returned. =cut sub user { my ($self, $user) = @_; $self->{_user} = $user if defined $user; return $self->{_user}; } =head2 host([$host]) Returns the "domain" part of the address, per RFC-2821, or the portion after the '@' sign. If called with one parameter, the domain is set and the new value is returned. =cut sub host { my ($self, $host) = @_; $self->{_host} = $host if defined $host; return $self->{_host}; } =head2 notes($key[,$value]) Get or set a note on the address. This is a piece of data that you wish to attach to the address and read somewhere else. For example you can use this to pass data between plugins. =cut sub notes { my ($self,$key) = (shift,shift); # Check for any additional arguments passed by the caller -- including undef return $self->{_notes}->{$key} unless @_; return $self->{_notes}->{$key} = shift; } sub _addr_cmp { require UNIVERSAL; my ($left, $right, $swap) = @_; my $class = ref($left); unless ( UNIVERSAL::isa($right, $class) ) { $right = $class->new($right); } #invert the address so we can sort by domain then user ($left = join( '=', reverse( split('@', $left->format))) ) =~ tr/[<>]//d; ($right = join( '=', reverse( split('@',$right->format))) ) =~ tr/[<>]//d; if ( $swap ) { ($right, $left) = ($left, $right); } return ($left cmp $right); } =head1 COPYRIGHT Copyright 2004-2005 Peter J. Holzer. See the LICENSE file for more information. =cut 1; qpsmtpd-0.84/lib/Qpsmtpd/Auth.pm000644 000765 000024 00000007167 11335434344 016532 0ustar00askstaff000000 000000 # See the documentation in 'perldoc README.authentication' package Qpsmtpd::Auth; use Qpsmtpd::Constants; use MIME::Base64; sub e64 { my ($arg) = @_; my $res = encode_base64($arg); chomp($res); return($res); } sub SASL { # $DB::single = 1; my ( $session, $mechanism, $prekey ) = @_; my ( $user, $passClear, $passHash, $ticket, $loginas ); if ( $mechanism eq "plain" ) { if (!$prekey) { $session->respond( 334, " " ); $prekey= ; } ( $loginas, $user, $passClear ) = split /\x0/, decode_base64($prekey); # Authorization ID must not be different from # Authentication ID if ( $loginas ne '' && $loginas ne $user ) { $session->respond(535, "Authentication invalid"); return DECLINED; } } elsif ($mechanism eq "login") { if ( $prekey ) { $user = decode_base64($prekey); } else { $session->respond(334, e64("Username:")); $user = decode_base64(); if ($user eq '*') { $session->respond(501, "Authentication canceled"); return DECLINED; } } $session->respond(334, e64("Password:")); $passClear = ; $passClear = decode_base64($passClear); if ($passClear eq '*') { $session->respond(501, "Authentication 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@%s>', rand(1000000), time(), $session->config("me") ); # We send the ticket encoded in Base64 $session->respond( 334, encode_base64( $ticket, "" ) ); my $line = ; if ( $line eq '*' ) { $session->respond( 501, "Authentication canceled" ); return DECLINED; } ( $user, $passHash ) = split( ' ', decode_base64($line) ); } else { #this error is now caught in SMTP.pm's sub auth $session->respond( 500, "Internal server error" ); return DECLINED; } # Make sure that we have enough information to proceed unless ( $user && ($passClear || $passHash) ) { $session->respond(504, "Invalid authentication string"); return DECLINED; } # try running the specific hooks first my ( $rc, $msg ) = $session->run_hooks( "auth-$mechanism", $mechanism, $user, $passClear, $passHash, $ticket ); # try running the polymorphous hooks next if ( !$rc || $rc == DECLINED ) { ( $rc, $msg ) = $session->run_hooks( "auth", $mechanism, $user, $passClear, $passHash, $ticket ); } if ( $rc == OK ) { $msg = "Authentication successful for $user" . ( defined $msg ? " - " . $msg : "" ); $session->respond( 235, $msg ); $session->connection->relay_client(1); $session->log( LOGINFO, $msg ); $session->{_auth_user} = $user; $session->{_auth_mechanism} = $mechanism; s/[\r\n].*//s for ($session->{_auth_user}, $session->{_auth_mechanism}); return OK; } else { $msg = "Authentication failed for $user" . ( defined $msg ? " - " . $msg : "" ); $session->respond( 535, $msg ); $session->log( LOGERROR, $msg ); return DENY; } } # tag: qpsmtpd plugin that sets RELAYCLIENT when the user authentifies 1; qpsmtpd-0.84/lib/Qpsmtpd/Command.pm000644 000765 000024 00000012541 11165321461 017173 0ustar00askstaff000000 000000 package Qpsmtpd::Command; =head1 NAME Qpsmtpd::Command - parse arguments to SMTP commands =head1 DESCRIPTION B provides just one public sub routine: B. This sub expects two or three arguments. The first is the name of the SMTP command (such as I, I, ...). The second must be the remaining of the line the client sent. If no third argument is given (or it's not a reference to a CODE) it parses the line according to RFC 1869 (SMTP Service Extensions) for the I and I commands and splitting by spaces (" ") for all other. Any module can supply it's own parsing routine by returning a sub routine reference from a hook_*_parse. This sub will be called with I<$self>, I<$cmd> and I<$line>. On successfull parsing it MUST return B (the constant from I) success as first argument and a list of values, which will be the arguments to the hook for this command. If parsing failed, the second returned value (if any) will be returned to the client as error message. =head1 EXAMPLE Inside a plugin sub hook_unrecognized_command_parse { my ($self, $transaction, $cmd) = @_; return (OK, \&bdat_parser) if ($cmd eq 'bdat'); } sub bdat_parser { my ($self,$cmd,$line) = @_; # .. do something with $line... return (DENY, "Invalid arguments") if $some_reason_why_there_is_a_syntax_error; return (OK, @args); } sub hook_unrecognized_command { my ($self, $transaction, $cmd, @args) = @_; return (DECLINED) if ($self->qp->connection->hello eq 'helo'); return (DECLINED) unless ($cmd eq 'bdat'); .... } =cut use Qpsmtpd::Constants; use vars qw(@ISA); @ISA = qw(Qpsmtpd::SMTP); use strict; sub parse { my ($me,$cmd,$line,$sub) = @_; return (OK) unless defined $line; # trivial case my $self = {}; bless $self, $me; $cmd = lc $cmd; if ($sub and (ref($sub) eq 'CODE')) { my @ret = eval { $sub->($self, $cmd, $line); }; if ($@) { $self->log(LOGERROR, "Failed to parse command [$cmd]: $@"); return (DENY, $line, ()); } ## my @log = @ret; ## for (@log) { ## $_ ||= ""; ## } ## $self->log(LOGDEBUG, "parse($cmd) => [".join("], [", @log)."]"); return @ret; } my $parse = "parse_$cmd"; if ($self->can($parse)) { # print "CMD=$cmd,line=$line\n"; my @out = eval { $self->$parse($cmd, $line); }; if ($@) { $self->log(LOGERROR, "$parse($cmd,$line) failed: $@"); return(DENY, "Failed to parse line"); } return @out; } return(OK, split(/ +/, $line)); # default :) } sub parse_rcpt { my ($self,$cmd,$line) = @_; return (DENY, "Syntax error in command") unless $line =~ s/^to:\s*//i; return &_get_mail_params($cmd, $line); } sub parse_mail { my ($self,$cmd,$line) = @_; return (DENY, "Syntax error in command") unless $line =~ s/^from:\s*//i; return &_get_mail_params($cmd, $line); } ### RFC 1869: ## 6. MAIL FROM and RCPT TO Parameters ## [...] ## ## esmtp-cmd ::= inner-esmtp-cmd [SP esmtp-parameters] CR LF ## esmtp-parameters ::= esmtp-parameter *(SP esmtp-parameter) ## esmtp-parameter ::= esmtp-keyword ["=" esmtp-value] ## esmtp-keyword ::= (ALPHA / DIGIT) *(ALPHA / DIGIT / "-") ## ## ; syntax and values depend on esmtp-keyword ## esmtp-value ::= 1* like # MAIL FROM: user=name@example.net # or RCPT TO: postmaster # let's see if $line contains nothing and use the first value as address: if ($line) { # parameter syntax error, i.e. not all of the arguments were # stripped by the while() loop: return (DENY, "Syntax error in parameters") if ($line =~ /\@.*\s/); return (OK, $line, @params); } $line = shift @params; if ($cmd eq "mail") { return (OK, "<>") unless $line; # 'MAIL FROM:' --> 'MAIL FROM:<>' return (DENY, "Syntax error in parameters") if ($line =~ /\@.*\s/); # parameter syntax error } else { if ($line =~ /\@/) { return (DENY, "Syntax error in parameters") if ($line =~ /\@.*\s/); } else { # XXX: what about 'abuse' in Qpsmtpd::Address? return (DENY, "Syntax error in parameters") if $line =~ /\s/; return (DENY, "Syntax error in address") unless ($line =~ /^(postmaster|abuse)$/i); } } ## XXX: No: let this do a plugin, so it's not up to us to decide ## if we require <> around an address :-) ## unless ($line =~ /^<.*>$/) { $line = "<".$line.">"; } return (OK, $line, @params); } 1; qpsmtpd-0.84/lib/Qpsmtpd/ConfigServer.pm000644 000765 000024 00000016574 11165321461 020223 0ustar00askstaff000000 000000 # $Id$ package Qpsmtpd::ConfigServer; use base ('Danga::Client'); use Qpsmtpd::Constants; use strict; use fields qw( _auth _commands _config_cache _connection _transaction _test_mode _extras other_fds ); my $PROMPT = "Enter command: "; sub new { my Qpsmtpd::ConfigServer $self = shift; $self = fields::new($self) unless ref $self; $self->SUPER::new( @_ ); $self->write($PROMPT); return $self; } sub max_idle_time { 3600 } # one hour sub process_line { my $self = shift; my $line = shift || return; if ($::DEBUG > 1) { print "$$:".($self+0)."C($self->{mode}): $line"; } local $SIG{ALRM} = sub { my ($pkg, $file, $line) = caller(); die "ALARM: $pkg, $file, $line"; }; my $prev = alarm(2); # must process a command in < 2 seconds my $resp = eval { $self->_process_line($line) }; alarm($prev); if ($@) { print STDERR "Error: $@\n"; } return $resp || ''; } sub respond { my $self = shift; my (@messages) = @_; while (my $msg = shift @messages) { $self->write("$msg\r\n"); } return; } sub fault { my $self = shift; my ($msg) = shift || "program fault - command not performed"; print STDERR "$0 [$$]: $msg ($!)\n"; $self->respond("Error - " . $msg); return $PROMPT; } sub _process_line { my $self = shift; my $line = shift; $line =~ s/\r?\n//; my ($cmd, @params) = split(/ +/, $line); my $meth = "cmd_" . lc($cmd); if (my $lookup = $self->can($meth)) { my $resp = eval { $lookup->($self, @params); }; if ($@) { my $error = $@; chomp($error); Qpsmtpd->log(LOGERROR, "Command Error: $error"); return $self->fault("command '$cmd' failed unexpectedly"); } return "$resp\n$PROMPT"; } else { # No such method - i.e. unrecognized command return $self->fault("command '$cmd' unrecognised"); } } my %helptext = ( help => "HELP [CMD] - Get help on all commands or a specific command", status => "STATUS - Returns status information about current connections", list => "LIST [LIMIT] - List the connections, specify limit or negative limit to shrink list", kill => "KILL (\$IP | \$REF) - Disconnect all connections from \$IP or connection reference \$REF", pause => "PAUSE - Stop accepting new connections", continue => "CONTINUE - Resume accepting connections", reload => "RELOAD - Reload all plugins and config", quit => "QUIT - Exit the config server", ); sub cmd_help { my $self = shift; my ($subcmd) = @_; $subcmd ||= 'help'; $subcmd = lc($subcmd); if ($subcmd eq 'help') { my $txt = join("\n", map { substr($_, 0, index($_, "-")) } sort values(%helptext)); return "Available Commands:\n\n$txt\n"; } my $txt = $helptext{$subcmd} || "Unrecognised help option. Try 'help' for a full list."; return "$txt\n"; } sub cmd_quit { my $self = shift; $self->close; } sub cmd_shutdown { exit; } sub cmd_pause { my $self = shift; my $other_fds = $self->OtherFds; $self->{other_fds} = { %$other_fds }; %$other_fds = (); return "PAUSED"; } sub cmd_continue { my $self = shift; my $other_fds = $self->{other_fds}; $self->OtherFds( %$other_fds ); %$other_fds = (); return "UNPAUSED"; } sub cmd_status { my $self = shift; # Status should show: # - Total time running # - Total number of mails received # - Total number of mails rejected (5xx) # - Total number of mails tempfailed (5xx) # - Avg number of mails/minute # - Number of current connections # - Number of outstanding DNS queries my $output = "Current Status as of " . gmtime() . " GMT\n\n"; if (defined &Qpsmtpd::Plugin::stats::get_stats) { # Stats plugin is loaded $output .= Qpsmtpd::Plugin::stats->get_stats; } my $descriptors = Danga::Socket->DescriptorMap; my $current_connections = 0; my $current_dns = 0; foreach my $fd (keys %$descriptors) { my $pob = $descriptors->{$fd}; if ($pob->isa("Qpsmtpd::PollServer")) { $current_connections++; } elsif ($pob->isa("ParaDNS::Resolver")) { $current_dns = $pob->pending; } } $output .= "Curr Connections: $current_connections / $::MAXconn\n". "Curr DNS Queries: $current_dns"; return $output; } sub cmd_list { my $self = shift; my ($count) = @_; my $descriptors = Danga::Socket->DescriptorMap; my $list = "Current" . ($count ? (($count > 0) ? " Oldest $count" : " Newest ".-$count) : "") . " Connections: \n\n"; my @all; foreach my $fd (keys %$descriptors) { my $pob = $descriptors->{$fd}; if ($pob->isa("Qpsmtpd::PollServer")) { next unless $pob->connection->remote_ip; # haven't even started yet push @all, [$pob+0, $pob->connection->remote_ip, $pob->connection->remote_host, $pob->uptime]; } } @all = sort { $a->[3] <=> $b->[3] } @all; if ($count) { if ($count > 0) { @all = @all[$#all-($count-1) .. $#all]; } else { @all = @all[0..(abs($count) - 1)]; } } foreach my $item (@all) { $list .= sprintf("%x : %s [%s] Connected %0.2fs\n", map { defined()?$_:'' } @$item); } return $list; } sub cmd_kill { my $self = shift; my ($match) = @_; return "SYNTAX: KILL (\$IP | \$REF)\n" unless $match; my $descriptors = Danga::Socket->DescriptorMap; my $killed = 0; my $is_ip = (index($match, '.') >= 0); foreach my $fd (keys %$descriptors) { my $pob = $descriptors->{$fd}; if ($pob->isa("Qpsmtpd::PollServer")) { if ($is_ip) { next unless $pob->connection->remote_ip; # haven't even started yet if ($pob->connection->remote_ip eq $match) { $pob->write("550 Your connection has been killed by an administrator\r\n"); $pob->disconnect; $killed++; } } else { # match by ID if ($pob+0 == hex($match)) { $pob->write("550 Your connection has been killed by an administrator\r\n"); $pob->disconnect; $killed++; } } } } return "Killed $killed connection" . ($killed > 1 ? "s" : "") . "\n"; } sub cmd_dump { my $self = shift; my ($ref) = @_; return "SYNTAX: DUMP \$REF\n" unless $ref; require Data::Dumper; $Data::Dumper::Indent=1; my $descriptors = Danga::Socket->DescriptorMap; foreach my $fd (keys %$descriptors) { my $pob = $descriptors->{$fd}; if ($pob->isa("Qpsmtpd::PollServer")) { if ($pob+0 == hex($ref)) { return Data::Dumper::Dumper($pob); } } } return "Unable to find the connection: $ref. Try the LIST command\n"; } 1; __END__ =head1 NAME Qpsmtpd::ConfigServer - a configuration server for qpsmtpd =head1 DESCRIPTION When qpsmtpd runs in multiplex mode it also provides a config server that you can connect to. This allows you to view current connection statistics and other gumph that you probably don't care about. =cut qpsmtpd-0.84/lib/Qpsmtpd/Connection.pm000644 000765 000024 00000011316 11165321461 017713 0ustar00askstaff000000 000000 package Qpsmtpd::Connection; use strict; # All of these parameters depend only on the physical connection, # i.e. not on anything sent from the remote machine. Hence, they # are an appropriate set to use for either start() or clone(). Do # not add parameters here unless they also meet that criteria. my @parameters = qw( remote_host remote_ip remote_info remote_port local_ip local_port relay_client ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = {}; bless ($self, $class); } sub start { my $self = shift; $self = $self->new(@_) unless ref $self; my %args = @_; foreach my $f ( @parameters ) { $self->$f($args{$f}) if $args{$f}; } return $self; } sub clone { my $self = shift; my %args = @_; my $new = $self->new(); foreach my $f ( @parameters ) { $new->$f($self->$f()) if $self->$f(); } $new->{_notes} = $self->{_notes} if defined $self->{_notes}; # reset the old connection object like it's done at the end of a connection # to prevent leaks (like prefork/tls problem with the old SSL file handle # still around) $self->reset unless $args{no_reset}; # should we generate a new id here? return $new; } sub remote_host { my $self = shift; @_ and $self->{_remote_host} = shift; $self->{_remote_host}; } sub remote_ip { my $self = shift; @_ and $self->{_remote_ip} = shift; $self->{_remote_ip}; } sub remote_port { my $self = shift; @_ and $self->{_remote_port} = shift; $self->{_remote_port}; } sub local_ip { my $self = shift; @_ and $self->{_local_ip} = shift; $self->{_local_ip}; } sub local_port { my $self = shift; @_ and $self->{_local_port} = shift; $self->{_local_port}; } sub remote_info { my $self = shift; @_ and $self->{_remote_info} = shift; $self->{_remote_info}; } sub relay_client { my $self = shift; @_ and $self->{_relay_client} = shift; $self->{_relay_client}; } sub hello { my $self = shift; @_ and $self->{_hello} = shift; $self->{_hello}; } sub hello_host { my $self = shift; @_ and $self->{_hello_host} = shift; $self->{_hello_host}; } sub notes { my $self = shift; my $key = shift; @_ and $self->{_notes}->{$key} = shift; $self->{_notes}->{$key}; } sub reset { my $self = shift; $self->{_notes} = undef; $self = $self->new; } 1; __END__ =head1 NAME Qpsmtpd::Connection - A single SMTP connection =head1 SYNOPSIS my $rdns = $qp->connection->remote_host; my $ip = $qp->connection->remote_ip; =head1 DESCRIPTION This class contains details about an individual SMTP connection. A connection lasts the lifetime of a TCP connection to the SMTP server. See also L which is a class containing details about an individual SMTP transaction. A transaction lasts from C to the end of the C marker, or a C 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 object's C<< $qp->connection >> method. =head2 new ( ) Instantiates a new Qpsmtpd::Connection object. =head2 start ( %args ) Initializes the connection object with %args attribute data. =head2 remote_host( ) The remote host connecting to the server as looked up via reverse dns. =head2 remote_ip( ) The remote IP address of the connecting host. =head2 remote_port( ) The remote port. =head2 remote_info( ) If your server does an ident lookup on the remote host, this is the identity of the remote client. =head2 local_ip( ) The local ip. =head2 local_port( ) The local port. =head2 hello( ) Either C<"helo"> or C<"ehlo"> depending on how the remote client greeted your server. NOTE: This field is empty during the helo or ehlo hooks, it is only set after a successful return from those hooks. =head2 hello_host( ) The host name specified in the C or C command. NOTE: This field is empty during the helo or ehlo hooks, it is only set after a successful return from those hooks. =head2 notes($key [, $value]) Get or set a note on the connection. This is a piece of data that you wish to attach to the connection and read somewhere else. For example you can use this to pass data between plugins. =head2 clone([%args]) Returns a copy of the Qpsmtpd::Connection object. The optional args parameter may contain: =over 4 =item no_reset (1|0) If true, do not reset the original connection object, the author has to care about that: only the cloned connection object is reset at the end of the connection =back =cut =head2 relay_client( ) True if the client is allowed to relay messages. =cut qpsmtpd-0.84/lib/Qpsmtpd/Constants.pm000644 000765 000024 00000004527 11165321461 017576 0ustar00askstaff000000 000000 package Qpsmtpd::Constants; use strict; require Exporter; # log levels my %log_levels = ( LOGDEBUG => 7, LOGINFO => 6, LOGNOTICE => 5, LOGWARN => 4, LOGERROR => 3, LOGCRIT => 2, LOGALERT => 1, LOGEMERG => 0, LOGRADAR => 0, ); # return codes my %return_codes = ( OK => 900, DENY => 901, # 550 DENYSOFT => 902, # 450 DENYHARD => 903, # 550 + disconnect (deprecated in 0.29) DENY_DISCONNECT => 903, # 550 + disconnect DENYSOFT_DISCONNECT => 904, # 450 + disconnect DECLINED => 909, DONE => 910, CONTINUATION => 911, # deprecated - use YIELD YIELD => 911, ); use vars qw(@ISA @EXPORT); @ISA = qw(Exporter); @EXPORT = (keys(%return_codes), keys(%log_levels), "return_code", "log_level"); foreach (keys %return_codes ) { eval "use constant $_ => ".$return_codes{$_}; } foreach (keys %log_levels ) { eval "use constant $_ => ".$log_levels{$_}; } sub return_code { my $test = shift; if ( $test =~ /^\d+$/ ) { # need to return the textural form foreach ( keys %return_codes ) { return $_ if $return_codes{$_} =~ /$test/; } } else { # just return the numeric value return $return_codes{$test}; } } sub log_level { my $test = shift; if ( $test =~ /^\d+$/ ) { # need to return the textural form foreach ( keys %log_levels ) { return $_ if $log_levels{$_} =~ /$test/; } } else { # just return the numeric value return $log_levels{$test}; } } 1; =head1 NAME Qpsmtpd::Constants - Constants for plugins to use =head1 CONSTANTS See L for hook specific information on applicable constants. Constants available: =over 4 =item C Return this only from the queue phase to indicate the mail was queued successfully. =item C Returning this from a hook causes a 5xx error (hard failure) to be returned to the connecting client. =item C Returning this from a hook causes a 4xx error (temporary failure - try again later) to be returned to the connecting client. =item C Returning this from a hook implies success, but tells qpsmtpd to go on to the next plugin. =item C Returning this from a hook implies success, but tells qpsmtpd to skip any remaining plugins for this phase. =back =cut qpsmtpd-0.84/lib/Qpsmtpd/DSN.pm000644 000765 000024 00000032373 11165321461 016246 0ustar00askstaff000000 000000 # # 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 implements the I from RFC 1893. =head1 USAGE Any B 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 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 qpsmtpd-0.84/lib/Qpsmtpd/Plugin/000755 000765 000024 00000000000 11357265152 016521 5ustar00askstaff000000 000000 qpsmtpd-0.84/lib/Qpsmtpd/Plugin.pm000644 000765 000024 00000011003 11165321461 017043 0ustar00askstaff000000 000000 package Qpsmtpd::Plugin; use Qpsmtpd::Constants; use strict; # more or less in the order they will fire our @hooks = qw( logging config post-fork pre-connection connect ehlo_parse ehlo helo_parse helo auth_parse auth auth-plain auth-login auth-cram-md5 rcpt_parse rcpt_pre rcpt mail_parse mail mail_pre data data_headers_end data_post queue_pre queue queue_post vrfy noop quit reset_transaction disconnect post-connection unrecognized_command deny ok received_line help ); our %hooks = map { $_ => 1 } @hooks; sub new { my $proto = shift; my $class = ref($proto) || $proto; bless ({}, $class); } sub hook_name { return shift->{_hook}; } sub register_hook { my ($plugin, $hook, $method, $unshift) = @_; die $plugin->plugin_name . " : Invalid hook: $hook" unless $hooks{$hook}; $plugin->{_qp}->log(LOGDEBUG, $plugin->plugin_name, "hooking", $hook) unless $hook =~ /logging/; # can't log during load_logging() # I can't quite decide if it's better to parse this code ref or if # we should pass the plugin object and method name ... hmn. $plugin->qp->_register_hook ($hook, { code => sub { local $plugin->{_qp} = shift; local $plugin->{_hook} = $hook; $plugin->$method(@_) }, name => $plugin->plugin_name, }, $unshift, ); } sub _register { my $self = shift; my $qp = shift; local $self->{_qp} = $qp; $self->init($qp, @_) if $self->can('init'); $self->_register_standard_hooks($qp, @_); $self->register($qp, @_) if $self->can('register'); } sub qp { shift->{_qp}; } sub log { my $self = shift; $self->{_qp}->varlog(shift, $self->{_hook}, $self->plugin_name, @_) unless defined $self->{_hook} and $self->{_hook} 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"}; # find $parent in plugin_dirs my $parent_dir; for ($self->qp->plugin_dirs) { if (-e "$_/$parent") { $parent_dir = $_; last; } } die "cannot find plugin '$parent'" unless $parent_dir; $self->compile($self->plugin_name . "_isa_$cleanParent", $newPackage, "$parent_dir/$parent"); warn "---- $newPackage\n"; no strict 'refs'; push @{"${currentPackage}::ISA"}, $newPackage; } # why isn't compile private? it's only called from Plugin and Qpsmtpd. sub compile { my ($class, $plugin, $package, $file, $test_mode, $orig_name) = @_; my $sub; open F, $file or die "could not open $file: $!"; { local $/ = undef; $sub = ; } close F; my $line = "\n#line 0 $file\n"; if ($test_mode) { if (open(F, "t/plugin_tests/$orig_name")) { local $/ = undef; $sub .= "#line 1 t/plugin_tests/$orig_name\n"; $sub .= ; close F; } } my $eval = join( "\n", "package $package;", 'use Qpsmtpd::Constants;', "require Qpsmtpd::Plugin;", 'use vars qw(@ISA);', 'use strict;', '@ISA = qw(Qpsmtpd::Plugin);', ($test_mode ? 'use Test::More;' : ''), "sub plugin_name { qq[$plugin] }", $line, $sub, "\n", # last line comment without newline? ); #warn "eval: $eval"; $eval =~ m/(.*)/s; $eval = $1; eval $eval; die "eval $@" if $@; } sub _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; qpsmtpd-0.84/lib/Qpsmtpd/PollServer.pm000644 000765 000024 00000023174 11165321461 017716 0ustar00askstaff000000 000000 package Qpsmtpd::PollServer; use base ('Danga::Client', 'Qpsmtpd::SMTP'); # use fields required to be a subclass of Danga::Client. Have to include # all fields used by Qpsmtpd.pm here too. use fields qw( input_sock mode header_lines in_header data_size max_size hooks start_time cmd_timeout conn _auth _auth_mechanism _auth_state _auth_ticket _auth_user _commands _config_cache _connection _continuation _extras _test_mode _transaction ); use Qpsmtpd::Constants; use Qpsmtpd::Address; use ParaDNS; use Mail::Header; use POSIX qw(strftime); use Socket qw(inet_aton AF_INET CRLF); use Time::HiRes qw(time); use strict; sub max_idle_time { 60 } sub max_connect_time { 1200 } sub input_sock { my $self = shift; @_ and $self->{input_sock} = shift; $self->{input_sock} || $self; } sub new { my Qpsmtpd::PollServer $self = shift; $self = fields::new($self) unless ref $self; $self->SUPER::new( @_ ); $self->{cmd_timeout} = 5; $self->{start_time} = time; $self->{mode} = 'connect'; $self->load_plugins; $self->load_logging; my ($rc, @msg) = $self->run_hooks_no_respond("pre-connection"); if ($rc == DENYSOFT || $rc == DENYSOFT_DISCONNECT) { @msg = ("Sorry, try again later") unless @msg; $self->respond(451, @msg); $self->disconnect; } elsif ($rc == DENY || $rc == DENY_DISCONNECT) { @msg = ("Sorry, service not available for you") unless @msg; $self->respond(550, @msg); $self->disconnect; } return $self; } sub uptime { my Qpsmtpd::PollServer $self = shift; return (time() - $self->{start_time}); } sub reset_for_next_message { my Qpsmtpd::PollServer $self = shift; $self->SUPER::reset_for_next_message(@_); $self->{_commands} = { ehlo => 1, helo => 1, rset => 1, mail => 1, rcpt => 1, data => 1, help => 1, vrfy => 1, noop => 1, quit => 1, auth => 0, # disabled by default }; $self->{mode} = 'cmd'; $self->{_extras} = {}; } sub respond { my Qpsmtpd::PollServer $self = shift; my ($code, @messages) = @_; while (my $msg = shift @messages) { my $line = $code . (@messages ? "-" : " ") . $msg; $self->write("$line\r\n"); } return 1; } sub fault { my Qpsmtpd::PollServer $self = shift; $self->SUPER::fault(@_); return; } my %cmd_cache; sub process_line { my Qpsmtpd::PollServer $self = shift; my $line = shift || return; if ($::DEBUG > 1) { print "$$:".($self+0)."C($self->{mode}): $line"; } if ($self->{mode} eq 'cmd') { $line =~ s/\r?\n$//s; $self->connection->notes('original_string', $line); my ($cmd, @params) = split(/ +/, $line, 2); my $meth = lc($cmd); if (my $lookup = $cmd_cache{$meth} || $self->{_commands}->{$meth} && $self->can($meth)) { $cmd_cache{$meth} = $lookup; eval { $lookup->($self, @params); }; if ($@) { my $error = $@; chomp($error); $self->log(LOGERROR, "Command Error: $error"); $self->fault("command '$cmd' failed unexpectedly"); } } else { # No such method - i.e. unrecognized command my ($rc, $msg) = $self->run_hooks("unrecognized_command", $meth, @params); } } elsif ($self->{mode} eq 'connect') { $self->{mode} = 'cmd'; # I've removed an eval{} from around this. It shouldn't ever die() # but if it does we're a bit screwed... Ah well :-) $self->start_conversation; } else { die "Unknown mode"; } return; } sub disconnect { my Qpsmtpd::PollServer $self = shift; $self->SUPER::disconnect(@_); $self->close; } sub close { my Qpsmtpd::PollServer $self = shift; $self->run_hooks_no_respond("post-connection"); $self->connection->reset; $self->SUPER::close; } sub start_conversation { my Qpsmtpd::PollServer $self = shift; my $conn = $self->connection; # set remote_host, remote_ip and remote_port my ($ip, $port) = split(':', $self->peer_addr_string); return $self->close() unless $ip; $conn->remote_ip($ip); $conn->remote_port($port); $conn->remote_info("[$ip]"); my ($lip,$lport) = split(':', $self->local_addr_string); $conn->local_ip($lip); $conn->local_port($lport); ParaDNS->new( finished => sub { $self->continue_read(); $self->run_hooks("connect") }, # NB: Setting remote_info to the same as remote_host callback => sub { $conn->remote_info($conn->remote_host($_[0])) }, host => $ip, ); return; } sub data { my Qpsmtpd::PollServer $self = shift; my ($rc, $msg) = $self->run_hooks("data"); return 1; } sub data_respond { my Qpsmtpd::PollServer $self = shift; my ($rc, $msg) = @_; if ($rc == DONE) { return; } elsif ($rc == DENY) { $msg->[0] ||= "Message denied"; $self->respond(554, @$msg); $self->reset_transaction(); return; } elsif ($rc == DENYSOFT) { $msg->[0] ||= "Message denied temporarily"; $self->respond(451, @$msg); $self->reset_transaction(); return; } elsif ($rc == DENY_DISCONNECT) { $msg->[0] ||= "Message denied"; $self->respond(554, @$msg); $self->disconnect; return; } elsif ($rc == DENYSOFT_DISCONNECT) { $msg->[0] ||= "Message denied temporarily"; $self->respond(451, @$msg); $self->disconnect; return; } return $self->respond(503, "MAIL first") unless $self->transaction->sender; return $self->respond(503, "RCPT first") unless $self->transaction->recipients; $self->{header_lines} = ''; $self->{data_size} = 0; $self->{in_header} = 1; $self->{max_size} = ($self->config('databytes'))[0] || 0; $self->log(LOGDEBUG, "max_size: $self->{max_size} / size: $self->{data_size}"); $self->respond(354, "go ahead"); my $max_get = $self->{max_size} || 1048576; $self->get_chunks($max_get, sub { $self->got_data($_[0]) }); return 1; } sub got_data { my Qpsmtpd::PollServer $self = shift; my $data = shift; my $done = 0; my $remainder; if ($data =~ s/^\.\r\n(.*)\z//ms) { $remainder = $1; $done = 1; } # add a transaction->blocked check back here when we have line by line plugin access... unless (($self->{max_size} and $self->{data_size} > $self->{max_size})) { $data =~ s/\r\n/\n/mg; $data =~ s/^\.\./\./mg; if ($self->{in_header}) { $self->{header_lines} .= $data; if ($self->{header_lines} =~ s/\n(\n.*)\z/\n/ms) { $data = $1; # end of headers $self->{in_header} = 0; # ... need to check that we don't reformat any of the received lines. # # 3.8.2 Received Lines in Gatewaying # When forwarding a message into or out of the Internet environment, a # gateway MUST prepend a Received: line, but it MUST NOT alter in any # way a Received: line that is already in the header. my @header_lines = split(/^/m, $self->{header_lines}); my $header = Mail::Header->new(\@header_lines, Modify => 0, MailFrom => "COERCE"); $self->transaction->header($header); $self->transaction->body_write($self->{header_lines}); $self->{header_lines} = ''; #$header->add("X-SMTPD", "qpsmtpd/".$self->version.", http://smtpd.develooper.com/"); # FIXME - call plugins to work on just the header here; can # save us buffering the mail content. # Save the start of just the body itself $self->transaction->set_body_start(); } } $self->transaction->body_write(\$data); $self->{data_size} += length $data; } if ($done) { $self->end_of_data; $self->end_get_chunks($remainder); } } sub end_of_data { my Qpsmtpd::PollServer $self = shift; #$self->log(LOGDEBUG, "size is at $size\n") unless ($i % 300); $self->log(LOGDEBUG, "max_size: $self->{max_size} / size: $self->{data_size}"); my $header = $self->transaction->header; if (!$header) { $header = Mail::Header->new(Modify => 0, MailFrom => "COERCE"); $self->transaction->header($header); } my $smtp = $self->connection->hello eq "ehlo" ? "ESMTP" : "SMTP"; my $esmtp = substr($smtp,0,1) eq "E"; my $authheader; my $sslheader; if (defined $self->connection->notes('tls_enabled') and $self->connection->notes('tls_enabled')) { $smtp .= "S" if $esmtp; # RFC3848 $sslheader = "(".$self->connection->notes('tls_socket')->get_cipher()." encrypted) "; } if (defined $self->{_auth} and $self->{_auth} == OK) { $smtp .= "A" if $esmtp; # RFC3848 $authheader = "(smtp-auth username $self->{_auth_user}, mechanism $self->{_auth_mechanism})\n"; } $header->add("Received", $self->received_line($smtp, $authheader, $sslheader), 0); return $self->respond(552, "Message too big!") if $self->{max_size} and $self->{data_size} > $self->{max_size}; my ($rc, $msg) = $self->run_hooks("data_post"); return 1; } 1; qpsmtpd-0.84/lib/Qpsmtpd/Postfix/000755 000765 000024 00000000000 11357265152 016717 5ustar00askstaff000000 000000 qpsmtpd-0.84/lib/Qpsmtpd/Postfix.pm000644 000765 000024 00000011723 11335434344 017256 0ustar00askstaff000000 000000 package Qpsmtpd::Postfix; =head1 NAME Qpsmtpd::Postfix - postfix queueing support for qpsmtpd =head2 DESCRIPTION This package implements the protocol Postfix servers use to communicate with each other. See src/global/rec_type.h in the postfix source for details. =cut use strict; use IO::Socket::UNIX; use vars qw(@ISA); @ISA = qw(IO::Socket::UNIX); my %rec_types; sub init { my ($self) = @_; %rec_types = ( REC_TYPE_SIZE => 'C', # first record, created by cleanup REC_TYPE_TIME => 'T', # time stamp, required REC_TYPE_FULL => 'F', # full name, optional REC_TYPE_INSP => 'I', # inspector transport REC_TYPE_FILT => 'L', # loop filter transport REC_TYPE_FROM => 'S', # sender, required REC_TYPE_DONE => 'D', # delivered recipient, optional REC_TYPE_RCPT => 'R', # todo recipient, optional REC_TYPE_ORCP => 'O', # original recipient, optional REC_TYPE_WARN => 'W', # warning message time REC_TYPE_ATTR => 'A', # named attribute for extensions REC_TYPE_MESG => 'M', # start message records REC_TYPE_CONT => 'L', # long data record REC_TYPE_NORM => 'N', # normal data record REC_TYPE_XTRA => 'X', # start extracted records REC_TYPE_RRTO => 'r', # return-receipt, from headers REC_TYPE_ERTO => 'e', # errors-to, from headers REC_TYPE_PRIO => 'P', # priority REC_TYPE_VERP => 'V', # VERP delimiters REC_TYPE_END => 'E', # terminator, required ); } sub print_rec { my ($self, $type, @list) = @_; die "unknown record type" unless ($rec_types{$type}); $self->print($rec_types{$type}); # the length is a little endian base-128 number where each # byte except the last has the high bit set: my $s = "@list"; my $ln = length($s); while ($ln >= 0x80) { my $lnl = $ln & 0x7F; $ln >>= 7; $self->print(chr($lnl | 0x80)); } $self->print(chr($ln)); $self->print($s); } sub print_rec_size { my ($self, $content_size, $data_offset, $rcpt_count) = @_; my $s = sprintf("%15ld %15ld %15ld", $content_size, $data_offset, $rcpt_count); $self->print_rec('REC_TYPE_SIZE', $s); } sub print_rec_time { my ($self, $time) = @_; $time = time() unless (defined($time)); my $s = sprintf("%d", $time); $self->print_rec('REC_TYPE_TIME', $s); } sub open_cleanup { my ($class, $socket) = @_; $socket = "/var/spool/postfix/public/cleanup" unless defined $socket; my $self = IO::Socket::UNIX->new(Type => SOCK_STREAM, Peer => $socket); die qq(Couldn't open unix socket "$socket": $!) unless ref $self; # allow buffered writes $self->autoflush(0); bless ($self, $class); $self->init(); return $self; } sub print_attr { my ($self, @kv) = @_; for (@kv) { $self->print("$_\0"); } $self->print("\0"); } sub get_attr { my ($self) = @_; local $/ = "\0"; my %kv; for(;;) { my $k = $self->getline; chomp($k); last unless ($k); my $v = $self->getline; chomp($v); $kv{$k} = $v; } return %kv; } =head2 print_msg_line($line) print one line of a message to cleanup. This removes any linefeed characters from the end of the line and splits the line across several records if it is longer than 1024 chars. =cut sub print_msg_line { my ($self, $line) = @_; $line =~ s/\r?\n$//s; # split into 1k chunks. while (length($line) > 1024) { my $s = substr($line, 0, 1024); $line = substr($line, 1024); $self->print_rec('REC_TYPE_CONT', $s); } $self->print_rec('REC_TYPE_NORM', $line); } =head2 inject_mail($transaction) (class method) inject mail in $transaction into postfix queue via cleanup. $transaction is supposed to be a Qpsmtpd::Transaction object. =cut sub inject_mail { my ($class, $transaction) = @_; my $strm = $class->open_cleanup($transaction->notes('postfix-queue-socket')); 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 qpsmtpd-0.84/lib/Qpsmtpd/SMTP/000755 000765 000024 00000000000 11357265152 016046 5ustar00askstaff000000 000000 qpsmtpd-0.84/lib/Qpsmtpd/SMTP.pm000644 000765 000024 00000057734 11165325625 016423 0ustar00askstaff000000 000000 package Qpsmtpd::SMTP; use Qpsmtpd; @ISA = qw(Qpsmtpd); my %auth_mechanisms = (); package Qpsmtpd::SMTP; use strict; use Carp; use Qpsmtpd::Connection; use Qpsmtpd::Transaction; use Qpsmtpd::Plugin; use Qpsmtpd::Constants; use Qpsmtpd::Auth; use Qpsmtpd::Address (); use Qpsmtpd::Command; use Mail::Header (); #use Data::Dumper; use POSIX qw(strftime); use Net::DNS; # this is only good for forkserver # can't set these here, cause forkserver resets them #$SIG{ALRM} = sub { respond(421, "Game over pal, game over. You got a timeout; I just can't wait that long..."); exit }; #$SIG{ALRM} = sub { warn "Connection Timed Out\n"; exit; }; sub new { my $proto = shift; my $class = ref($proto) || $proto; my %args = @_; my $self = bless ({ args => \%args }, $class); my (@commands) = qw(ehlo helo rset mail rcpt data help vrfy noop quit); my (%commands); @commands{@commands} = ('') x @commands; # this list of valid commands should probably be a method or a set of methods $self->{_commands} = \%commands; $self->SUPER::_restart(%args) if $args{restart}; # calls Qpsmtpd::_restart() $self; } sub command_counter { my $self = shift; $self->{_counter} || 0; } sub dispatch { my $self = shift; my ($cmd) = lc shift; $self->{_counter}++; if ($cmd !~ /^(\w{1,12})$/ or !exists $self->{_commands}->{$1}) { $self->run_hooks("unrecognized_command", $cmd, @_); return 1 } $cmd = $1; 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 unrecognized_command_respond { my ($self, $rc, $msg) = @_; if ($rc == DENY_DISCONNECT) { $self->respond(521, @$msg); $self->disconnect; } elsif ($rc == DENY) { $self->respond(500, @$msg); } elsif ($rc != DONE) { $self->respond(500, "Unrecognized command"); } } sub fault { my $self = shift; my ($msg) = shift || "program fault - command not performed"; my ($name) = split /\s+/, $0, 2; print STDERR $name,"[$$]: $msg ($!)\n"; return $self->respond(451, "Internal error - try again later - " . $msg); } sub start_conversation { my $self = shift; # this should maybe be called something else than "connect", see # lib/Qpsmtpd/TcpServer.pm for more confusion. $self->run_hooks("connect"); return DONE; } sub connect_respond { my ($self, $rc, $msg) = @_; if ($rc == DENY || $rc == DENY_DISCONNECT) { $msg->[0] ||= 'Connection from you denied, bye bye.'; $self->respond(550, @$msg); $self->disconnect; } elsif ($rc == DENYSOFT || $rc == DENYSOFT_DISCONNECT) { $msg->[0] ||= 'Connection from you temporarily denied, bye bye.'; $self->respond(450, @$msg); $self->disconnect; } elsif ($rc != DONE) { my $greets = $self->config('smtpgreeting'); if ( $greets ) { $greets .= " ESMTP" unless $greets =~ /(^|\W)ESMTP(\W|$)/; } else { $greets = $self->config('me') . " ESMTP qpsmtpd " . $self->version . " ready; send us your mail, but not your spam."; } $self->respond(220, $greets); } } sub transaction { my $self = shift; return $self->{_transaction} || $self->reset_transaction(); } sub reset_transaction { my $self = shift; $self->run_hooks("reset_transaction") if $self->{_transaction}; return $self->{_transaction} = Qpsmtpd::Transaction->new(); } sub connection { my $self = shift; @_ and $self->{_connection} = shift; return $self->{_connection} || ($self->{_connection} = Qpsmtpd::Connection->new()); } sub helo { my ($self, $line) = @_; my ($rc, @msg) = $self->run_hooks('helo_parse'); my ($ok, $hello_host, @stuff) = Qpsmtpd::Command->parse('helo', $line, $msg[0]); return $self->respond (501, "helo requires domain/address - see RFC-2821 4.1.1.1") unless $hello_host; my $conn = $self->connection; return $self->respond (503, "but you already said HELO ...") if $conn->hello; $self->run_hooks("helo", $hello_host, @stuff); } sub helo_respond { my ($self, $rc, $msg, $args) = @_; my ($hello_host) = @$args; if ($rc == DONE) { # do nothing } elsif ($rc == DENY) { $self->respond(550, @$msg); } elsif ($rc == DENYSOFT) { $self->respond(450, @$msg); } elsif ($rc == DENY_DISCONNECT) { $self->respond(550, @$msg); $self->disconnect; } elsif ($rc == DENYSOFT_DISCONNECT) { $self->respond(450, @$msg); $self->disconnect; } else { my $conn = $self->connection; $conn->hello("helo"); $conn->hello_host($hello_host); $self->transaction; $self->respond(250, $self->config('me') ." Hi " . $conn->remote_info . " [" . $conn->remote_ip ."]; I am so happy to meet you."); } } sub ehlo { my ($self, $line) = @_; my ($rc, @msg) = $self->run_hooks('ehlo_parse'); my ($ok, $hello_host, @stuff) = Qpsmtpd::Command->parse('ehlo', $line, $msg[0]); return $self->respond (501, "ehlo requires domain/address - see RFC-2821 4.1.1.1") unless $hello_host; my $conn = $self->connection; return $self->respond (503, "but you already said HELO ...") if $conn->hello; $self->run_hooks("ehlo", $hello_host, @stuff); } sub ehlo_respond { my ($self, $rc, $msg, $args) = @_; my ($hello_host) = @$args; if ($rc == DONE) { # do nothing } elsif ($rc == DENY) { $self->respond(550, @$msg); } elsif ($rc == DENYSOFT) { $self->respond(450, @$msg); } elsif ($rc == DENY_DISCONNECT) { $self->respond(550, @$msg); $self->disconnect; } elsif ($rc == DENYSOFT_DISCONNECT) { $self->respond(450, @$msg); $self->disconnect; } else { my $conn = $self->connection; $conn->hello("ehlo"); $conn->hello_host($hello_host); $self->transaction; my @capabilities = $self->transaction->notes('capabilities') ? @{ $self->transaction->notes('capabilities') } : (); # Check for possible AUTH mechanisms HOOK: foreach my $hook ( keys %{$self->hooks} ) { if ( $hook =~ m/^auth-?(.+)?$/ ) { if ( defined $1 ) { $auth_mechanisms{uc($1)} = 1; } else { # at least one polymorphous auth provider %auth_mechanisms = map {$_,1} qw(PLAIN CRAM-MD5 LOGIN); last HOOK; } } } # Check if we should only offer AUTH after TLS is completed my $tls_before_auth = ($self->config('tls_before_auth') ? ($self->config('tls_before_auth'))[0] && $self->transaction->notes('tls_enabled') : 0); if ( %auth_mechanisms && !$tls_before_auth) { push @capabilities, 'AUTH '.join(" ",keys(%auth_mechanisms)); $self->{_commands}->{'auth'} = ""; } $self->respond(250, $self->config("me") . " Hi " . $conn->remote_info . " [" . $conn->remote_ip ."]", "PIPELINING", "8BITMIME", ($self->config('databytes') ? "SIZE ". ($self->config('databytes'))[0] : ()), @capabilities, ); } } sub auth { my ($self, $line) = @_; $self->run_hooks('auth_parse', $line); } sub auth_parse_respond { my ($self, $rc, $msg, $args) = @_; my ($line) = @$args; my ($ok, $mechanism, @stuff) = Qpsmtpd::Command->parse('auth', $line, $msg->[0]); return $self->respond(501, $mechanism || "Syntax error in command") unless ($ok == OK); $mechanism = lc($mechanism); #they AUTH'd once already return $self->respond( 503, "but you already said AUTH ..." ) if ( defined $self->{_auth} and $self->{_auth} == OK ); return $self->respond( 503, "AUTH not defined for HELO" ) if ( $self->connection->hello eq "helo" ); return $self->respond( 503, "SSL/TLS required before AUTH" ) if ( ($self->config('tls_before_auth'))[0] and $self->transaction->notes('tls_enabled') ); # if we don't have a plugin implementing this auth mechanism, 504 if( exists $auth_mechanisms{uc($mechanism)} ) { return $self->{_auth} = Qpsmtpd::Auth::SASL( $self, $mechanism, @stuff ); } else { $self->respond( 504, "Unimplemented authentification mechanism: $mechanism" ); return DENY; } } sub mail { my ($self, $line) = @_; # -> from RFC2821 # The MAIL command (or the obsolete SEND, SOML, or SAML commands) # begins a mail transaction. Once started, a mail transaction # consists of a transaction beginning command, one or more RCPT # commands, and a DATA command, in that order. A mail transaction # may be aborted by the RSET (or a new EHLO) command. There may be # zero or more transactions in a session. MAIL (or SEND, SOML, or # SAML) MUST NOT be sent if a mail transaction is already open, # i.e., it should be sent only if no mail transaction had been # started in the session, or it the previous one successfully # concluded with a successful DATA command, or if the previous one # was aborted with a RSET. # sendmail (8.11) rejects a second MAIL command. # qmail-smtpd (1.03) accepts it and just starts a new transaction. # Since we are a qmail-smtpd thing we will do the same. $self->reset_transaction; unless ($self->connection->hello) { return $self->respond(503, "please say hello first ..."); } else { $self->log(LOGINFO, "full from_parameter: $line"); $self->run_hooks("mail_parse", $line); } } sub mail_parse_respond { my ($self, $rc, $msg, $args) = @_; my ($line) = @$args; my ($ok, $from, @params) = Qpsmtpd::Command->parse('mail', $line, $msg->[0]); return $self->respond(501, $from || "Syntax error in command") unless ($ok == OK); my %param; foreach (@params) { my ($k,$v) = split /=/, $_, 2; $param{lc $k} = $v; } # to support addresses without <> we now require a plugin # hooking "mail_pre" to # return (OK, "<$from>"); # (...or anything else parseable by Qpsmtpd::Address ;-)) # see also comment in sub rcpt() $self->run_hooks("mail_pre", $from, \%param); } sub mail_pre_respond { my ($self, $rc, $msg, $args) = @_; my ($from, $param) = @$args; if ($rc == OK) { $from = shift @$msg; } $self->log(LOGDEBUG, "from email address : [$from]"); return $self->respond(501, "could not parse your mail from command") unless $from =~ /^<.*>$/; if ($from eq "<>" or $from =~ m/\[undefined\]/ or $from eq "<#@[]>") { $from = Qpsmtpd::Address->new("<>"); } else { $from = (Qpsmtpd::Address->parse($from))[0]; } return $self->respond(501, "could not parse your mail from command") unless $from; $self->run_hooks("mail", $from, %$param); } sub mail_respond { my ($self, $rc, $msg, $args) = @_; my ($from, $param) = @$args; if ($rc == DONE) { return 1; } elsif ($rc == DENY) { $msg->[0] ||= $from->format . ', denied'; $self->log(LOGINFO, "deny mail from " . $from->format . " (@$msg)"); $self->respond(550, @$msg); } elsif ($rc == DENYSOFT) { $msg->[0] ||= $from->format . ', temporarily denied'; $self->log(LOGINFO, "denysoft mail from " . $from->format . " (@$msg)"); $self->respond(450, @$msg); } elsif ($rc == DENY_DISCONNECT) { $msg->[0] ||= $from->format . ', denied'; $self->log(LOGINFO, "deny mail from " . $from->format . " (@$msg)"); $self->respond(550, @$msg); $self->disconnect; } elsif ($rc == DENYSOFT_DISCONNECT) { $msg->[0] ||= $from->format . ', temporarily denied'; $self->log(LOGINFO, "denysoft mail from " . $from->format . " (@$msg)"); $self->respond(421, @$msg); $self->disconnect; } else { # includes OK $self->log(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, $line) = @_; $self->run_hooks("rcpt_parse", $line); } sub rcpt_parse_respond { my ($self, $rc, $msg, $args) = @_; my ($line) = @$args; my ($ok, $rcpt, @param) = Qpsmtpd::Command->parse("rcpt", $line, $msg->[0]); return $self->respond(501, $rcpt || "Syntax error in command") unless ($ok == OK); return $self->respond(503, "Use MAIL before RCPT") unless $self->transaction->sender; my %param; foreach (@param) { my ($k,$v) = split /=/, $_, 2; $param{lc $k} = $v; } # to support addresses without <> we now require a plugin # hooking "rcpt_pre" to # return (OK, "<$rcpt>"); # (... or anything else parseable by Qpsmtpd::Address ;-)) # this means, a plugin can decide to (pre-)accept # addresses like or # by removing the trailing "."/" " from this example... $self->run_hooks("rcpt_pre", $rcpt, \%param); } sub rcpt_pre_respond { my ($self, $rc, $msg, $args) = @_; my ($rcpt, $param) = @$args; if ($rc == OK) { $rcpt = shift @$msg; } $self->log(LOGDEBUG, "to email address : [$rcpt]"); return $self->respond(501, "could not parse recipient") unless $rcpt =~ /^<.*>$/; $rcpt = (Qpsmtpd::Address->parse($rcpt))[0]; return $self->respond(501, "could not parse recipient") if (!$rcpt or ($rcpt->format eq '<>')); $self->run_hooks("rcpt", $rcpt, %$param); } sub rcpt_respond { my ($self, $rc, $msg, $args) = @_; my ($rcpt, $param) = @$args; if ($rc == DONE) { return 1; } elsif ($rc == DENY) { $msg->[0] ||= 'relaying denied'; $self->respond(550, @$msg); } elsif ($rc == DENYSOFT) { $msg->[0] ||= 'relaying denied'; return $self->respond(450, @$msg); } elsif ($rc == DENY_DISCONNECT) { $msg->[0] ||= 'delivery denied'; $self->log(LOGINFO, "delivery denied (@$msg)"); $self->respond(550, @$msg); $self->disconnect; } elsif ($rc == DENYSOFT_DISCONNECT) { $msg->[0] ||= 'relaying denied'; $self->log(LOGINFO, "delivery denied (@$msg)"); $self->respond(421, @$msg); $self->disconnect; } elsif ($rc == OK) { $self->respond(250, $rcpt->format . ", recipient ok"); return $self->transaction->add_recipient($rcpt); } else { return $self->respond(450, "No plugin decided if relaying is allowed"); } return 0; } sub help { my ($self, @args) = @_; $self->run_hooks("help", @args); } sub help_respond { my ($self, $rc, $msg, $args) = @_; return 1 if $rc == DONE; if ($rc == DENY) { $msg->[0] ||= "Syntax error, command not recognized"; $self->respond(500, @$msg); } else { unless ($msg->[0]) { @$msg = ( "This is qpsmtpd " . ($self->config('smtpgreeting') ? '' : $self->version), "See http://smtpd.develooper.com/", 'To report bugs or send comments, mail to .'); } $self->respond(214, @$msg); } return 1; } sub noop { my $self = shift; $self->run_hooks("noop"); } sub noop_respond { my ($self, $rc, $msg, $args) = @_; return 1 if $rc == DONE; if ($rc == DENY || $rc == DENY_DISCONNECT) { $msg->[0] ||= "Stop wasting my time."; # FIXME: better default message? $self->respond(500, @$msg); $self->disconnect if $rc == DENY_DISCONNECT; return 1; } $self->respond(250, "OK"); return 1; } sub vrfy { my $self = shift; # Note, this doesn't support the multiple ambiguous results # documented in RFC2821#3.5.1 # I also don't think it provides all the proper result codes. $self->run_hooks("vrfy"); } sub vrfy_respond { my ($self, $rc, $msg, $args) = @_; if ($rc == DONE) { return 1; } elsif ($rc == DENY) { $msg->[0] ||= "Access Denied"; $self->respond(554, @$msg); $self->reset_transaction(); return 1; } elsif ($rc == OK) { $msg->[0] ||= "User OK"; $self->respond(250, @$msg); return 1; } else { # $rc == DECLINED or anything else $self->respond(252, "Just try sending a mail and we'll see how it turns out ..."); return 1; } } sub rset { my $self = shift; $self->reset_transaction; $self->respond(250, "OK"); } sub quit { my $self = shift; $self->run_hooks("quit"); } sub quit_respond { my ($self, $rc, $msg, $args) = @_; if ($rc != DONE) { $msg->[0] ||= $self->config('me') . " closing connection. Have a wonderful day."; $self->respond(221, @$msg); } $self->disconnect(); } sub disconnect { my $self = shift; $self->run_hooks("disconnect"); $self->reset_transaction; } sub data { my $self = shift; $self->run_hooks("data"); } sub data_respond { my ($self, $rc, $msg, $args) = @_; if ($rc == DONE) { return 1; } elsif ($rc == DENY) { $msg->[0] ||= "Message denied"; $self->respond(554, @$msg); $self->reset_transaction(); return 1; } elsif ($rc == DENYSOFT) { $msg->[0] ||= "Message denied temporarily"; $self->respond(451, @$msg); $self->reset_transaction(); return 1; } elsif ($rc == DENY_DISCONNECT) { $msg->[0] ||= "Message denied"; $self->respond(554, @$msg); $self->disconnect; return 1; } elsif ($rc == DENYSOFT_DISCONNECT) { $msg->[0] ||= "Message denied temporarily"; $self->respond(421, @$msg); $self->disconnect; return 1; } $self->respond(503, "MAIL first"), return 1 unless $self->transaction->sender; $self->respond(503, "RCPT first"), return 1 unless $self->transaction->recipients; $self->respond(354, "go ahead"); my $buffer = ''; my $size = 0; my $i = 0; my $max_size = ($self->config('databytes'))[0] || 0; # this should work in scalar context my $blocked = ""; my %matches; my $in_header = 1; my $complete = 0; $self->log(LOGDEBUG, "max_size: $max_size / size: $size"); my $header = Mail::Header->new(Modify => 0, MailFrom => "COERCE"); my $timeout = $self->config('timeout'); while (defined($_ = $self->getline($timeout))) { $complete++, last if $_ eq ".\r\n"; $i++; # should probably use \012 and \015 in these checks instead of \r and \n ... # Reject messages that have either bare LF or CR. rjkaes noticed a # lot of spam that is malformed in the header. ($_ eq ".\n" or $_ eq ".\r") and $self->respond(421, "See http://smtpd.develooper.com/barelf.html") and return $self->disconnect; # add a transaction->blocked check back here when we have line by line plugin access... unless (($max_size and $size > $max_size)) { s/\r\n$/\n/; s/^\.\./\./; if ($in_header and m/^$/) { $in_header = 0; my @headers = split /^/m, $buffer; # ... need to check that we don't reformat any of the received lines. # # 3.8.2 Received Lines in Gatewaying # When forwarding a message into or out of the Internet environment, a # gateway MUST prepend a Received: line, but it MUST NOT alter in any # way a Received: line that is already in the header. $header->extract(\@headers); #$header->add("X-SMTPD", "qpsmtpd/".$self->version.", http://smtpd.develooper.com/"); $buffer = ""; $self->transaction->header($header); # NOTE: This will not work properly under async. A # data_headers_end_respond needs to be created. my ($rc, $msg) = $self->run_hooks('data_headers_end'); if ($rc == DENY_DISCONNECT) { $self->respond(554, $msg || "Message denied"); $self->disconnect; return 1; } elsif ($rc == DENYSOFT_DISCONNECT) { $self->respond(421, $msg || "Message denied temporarily"); $self->disconnect; return 1; } # Save the start of just the body itself $self->transaction->set_body_start(); } # grab a copy of all of the header lines if ($in_header) { $buffer .= $_; } # copy all lines into the spool file, including the headers # we will create a new header later before sending onwards $self->transaction->body_write($_); $size += length $_; } #$self->log(LOGDEBUG, "size is at $size\n") unless ($i % 300); } $self->log(LOGDEBUG, "max_size: $max_size / size: $size"); my $smtp = $self->connection->hello eq "ehlo" ? "ESMTP" : "SMTP"; my $esmtp = substr($smtp,0,1) eq "E"; my $authheader = ''; my $sslheader = ''; if (defined $self->connection->notes('tls_enabled') and $self->connection->notes('tls_enabled')) { $smtp .= "S" if $esmtp; # RFC3848 $sslheader = "(".$self->connection->notes('tls_socket')->get_cipher()." encrypted) "; } if (defined $self->{_auth} and $self->{_auth} == OK) { $smtp .= "A" if $esmtp; # RFC3848 $authheader = "(smtp-auth username $self->{_auth_user}, mechanism $self->{_auth_mechanism})\n"; } $header->add("Received", $self->received_line($smtp, $authheader, $sslheader), 0); # if we get here without seeing a terminator, the connection is # probably dead. unless ( $complete ) { $self->respond(451, "Incomplete DATA"); $self->reset_transaction; # clean up after ourselves return 1; } #$self->respond(550, $self->transaction->blocked),return 1 if ($self->transaction->blocked); if ($max_size and $size > $max_size) { $self->log(LOGALERT, "Message too big: size: $size (max size: $max_size)"); $self->respond(552, "Message too big!"); $self->reset_transaction; # clean up after ourselves return 1; } $self->run_hooks("data_post"); } sub received_line { my ($self, $smtp, $authheader, $sslheader) = @_; my ($rc, @received) = $self->run_hooks("received_line", $smtp, $authheader, $sslheader); if ($rc == YIELD) { die "YIELD not supported for received_line hook"; } elsif ($rc == OK) { return join("\n", @received); } else { # assume $rc == DECLINED return "from ".$self->connection->remote_info ." (HELO ".$self->connection->hello_host . ") (".$self->connection->remote_ip . ")\n $authheader by ".$self->config('me')." (qpsmtpd/".$self->version .") with $sslheader$smtp; ". (strftime('%a, %d %b %Y %H:%M:%S %z', localtime)) } } sub data_post_respond { my ($self, $rc, $msg, $args) = @_; if ($rc == DONE) { return 1; } elsif ($rc == DENY) { $msg->[0] ||= "Message denied"; $self->respond(552, @$msg); # DATA is always the end of a "transaction" return $self->reset_transaction; } elsif ($rc == DENYSOFT) { $msg->[0] ||= "Message denied temporarily"; $self->respond(452, @$msg); # DATA is always the end of a "transaction" return $self->reset_transaction; } elsif ($rc == DENY_DISCONNECT) { $msg->[0] ||= "Message denied"; $self->respond(552, @$msg); $self->disconnect; return 1; } elsif ($rc == DENYSOFT_DISCONNECT) { $msg->[0] ||= "Message denied temporarily"; $self->respond(452, @$msg); $self->disconnect; return 1; } else { $self->queue($self->transaction); } } sub getline { my ($self, $timeout) = @_; alarm $timeout; my $line = ; # default implementation alarm 0; return $line; } sub queue { my ($self, $transaction) = @_; # First fire any queue_pre hooks $self->run_hooks("queue_pre"); } sub queue_pre_respond { my ($self, $rc, $msg, $args) = @_; if ($rc == DONE) { return 1; } elsif ($rc != OK and $rc != DECLINED and $rc != 0 ) { return $self->log(LOGERROR, "pre plugin returned illegal value"); return 0; } # If we got this far, run the queue hooks $self->run_hooks("queue"); } sub queue_respond { my ($self, $rc, $msg, $args) = @_; # reset transaction if we queued the mail $self->reset_transaction; if ($rc == DONE) { return 1; } elsif ($rc == OK) { $msg->[0] ||= 'Queued'; $self->respond(250, @$msg); } elsif ($rc == DENY) { $msg->[0] ||= 'Message denied'; $self->respond(552, @$msg); } elsif ($rc == DENYSOFT) { $msg->[0] ||= 'Message denied temporarily'; $self->respond(452, @$msg); } else { $msg->[0] ||= 'Queuing declined or disabled; try again later'; $self->respond(451, @$msg); } # And finally run any queue_post hooks $self->run_hooks("queue_post"); } sub queue_post_respond { my ($self, $rc, $msg, $args) = @_; $self->log(LOGERROR, @$msg) unless ($rc == OK or $rc == 0); } 1; qpsmtpd-0.84/lib/Qpsmtpd/TcpServer/000755 000765 000024 00000000000 11357265152 017200 5ustar00askstaff000000 000000 qpsmtpd-0.84/lib/Qpsmtpd/TcpServer.pm000644 000765 000024 00000011520 11335704266 017535 0ustar00askstaff000000 000000 package Qpsmtpd::TcpServer; use Qpsmtpd::SMTP; use Qpsmtpd::Constants; use Socket; @ISA = qw(Qpsmtpd::SMTP); use strict; use POSIX (); my $has_ipv6; if ( eval {require Socket6;} && # INET6 prior to 2.01 will not work; sorry. eval {require IO::Socket::INET6; IO::Socket::INET6->VERSION("2.00");} ) { import Socket6; $has_ipv6=1; } else { $has_ipv6=0; } sub has_ipv6 { return $has_ipv6; } my $first_0; sub start_connection { my $self = shift; my ($remote_host, $remote_info, $remote_ip); if ($ENV{TCPREMOTEIP}) { # started from tcpserver (or some other superserver which # exports the TCPREMOTE* variables. $remote_ip = $ENV{TCPREMOTEIP}; $remote_host = $ENV{TCPREMOTEHOST} || "[$remote_ip]"; $remote_info = $ENV{TCPREMOTEINFO} ? "$ENV{TCPREMOTEINFO}\@$remote_host" : $remote_host; } else { # Started from inetd or similar. # get info on the remote host from the socket. # ignore ident/tap/... my $hersockaddr = getpeername(STDIN) or die "getpeername failed: $0 must be called from tcpserver, (x)inetd or a similar program which passes a socket to stdin"; my ($port, $iaddr) = sockaddr_in($hersockaddr); $remote_ip = inet_ntoa($iaddr); $remote_host = gethostbyaddr($iaddr, AF_INET) || "[$remote_ip]"; $remote_info = $remote_host; } $self->log(LOGNOTICE, "Connection from $remote_info [$remote_ip]"); # if the local dns resolver doesn't filter it out we might get # 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, $client) = @_; # Set local client_socket to passed client object for testing socket state on writes $self->{__client_socket} = $client; $self->load_plugins unless $self->{hooks}; my $rc = $self->start_conversation; return if $rc != DONE; # this should really be the loop and read_input should just get one line; I think $self->read_input; } sub read_input { my $self = shift; my $timeout = $self->config('timeoutsmtpd') # qmail smtpd control file || $self->config('timeout') # qpsmtpd control file || 1200; # default value alarm $timeout; while () { alarm 0; $_ =~ s/\r?\n$//s; # advanced chomp $self->log(LOGINFO, "dispatching $_"); $self->connection->notes('original_string', $_); defined $self->dispatch(split / +/, $_, 2) or $self->respond(502, "command unrecognized: '$_'"); alarm $timeout; } alarm(0); } sub respond { my ($self, $code, @messages) = @_; my $buf = ''; if ( !$self->check_socket() ) { $self->log(LOGERROR, "Lost connection to client, cannot send response."); return(0); } while (my $msg = shift @messages) { my $line = $code . (@messages?"-":" ").$msg; $self->log(LOGINFO, $line); $buf .= "$line\r\n"; } print $buf or ($self->log(LOGERROR, "Could not print [$buf]: $!"), return 0); return 1; } sub disconnect { my $self = shift; $self->log(LOGINFO,"click, disconnecting"); $self->SUPER::disconnect(@_); $self->run_hooks("post-connection"); $self->connection->reset; exit; } # local/remote port and ip address sub lrpip { my ($server, $client, $hisaddr) = @_; my ($port, $iaddr) = ($server->sockdomain == AF_INET) ? (sockaddr_in($hisaddr)) : (sockaddr_in6($hisaddr)); my $localsockaddr = getsockname($client); my ($lport, $laddr) = ($server->sockdomain == AF_INET) ? (sockaddr_in($localsockaddr)) : (sockaddr_in6($localsockaddr)); my $nto_iaddr = ($server->sockdomain == AF_INET) ? (inet_ntoa($iaddr)) : (inet_ntop(AF_INET6(), $iaddr)); my $nto_laddr = ($server->sockdomain == AF_INET) ? (inet_ntoa($laddr)) : (inet_ntop(AF_INET6(), $laddr)); $nto_iaddr =~ s/::ffff://; $nto_laddr =~ s/::ffff://; return ($port, $iaddr, $lport, $laddr, $nto_iaddr, $nto_laddr); } sub tcpenv { my ($nto_laddr, $nto_iaddr, $no_rdns) = @_; my $TCPLOCALIP = $nto_laddr; my $TCPREMOTEIP = $nto_iaddr; if ($no_rdns) { return ($TCPLOCALIP, $TCPREMOTEIP, $TCPREMOTEIP ? "[$ENV{TCPREMOTEIP}]" : "[noip!]"); } my $res = new Net::DNS::Resolver; $res->tcp_timeout(3); $res->udp_timeout(3); my $query = $res->query($nto_iaddr); my $TCPREMOTEHOST; if($query) { foreach my $rr ($query->answer) { next unless $rr->type eq "PTR"; $TCPREMOTEHOST = $rr->ptrdname; } } return ($TCPLOCALIP, $TCPREMOTEIP, $TCPREMOTEHOST || "Unknown"); } sub check_socket() { my $self = shift; return 1 if ( $self->{__client_socket}->connected ); return 0; } 1; qpsmtpd-0.84/lib/Qpsmtpd/Transaction.pm000644 000765 000024 00000025357 11335434344 020117 0ustar00askstaff000000 000000 package Qpsmtpd::Transaction; use Qpsmtpd; @ISA = qw(Qpsmtpd); use strict; use Qpsmtpd::Utils; use Qpsmtpd::Constants; use Socket qw(inet_aton); use Sys::Hostname; use Time::HiRes qw(gettimeofday); use IO::File qw(O_RDWR O_CREAT); sub new { start(@_) } sub start { my $proto = shift; my $class = ref($proto) || $proto; my %args = @_; my $self = { _rcpt => [], started => time, }; bless ($self, $class); return $self; } sub add_recipient { my ($self, $rcpt) = @_; push @{$self->{_recipients}}, $rcpt if $rcpt; } sub remove_recipient { my ($self,$rcpt) = @_; $self->{_recipients} = [grep {$_->address ne $rcpt->address} @{$self->{_recipients} || []}] if $rcpt; } sub recipients { my $self = shift; @_ and $self->{_recipients} = [@_]; ($self->{_recipients} ? @{$self->{_recipients}} : ()); } sub sender { my $self = shift; @_ and $self->{_sender} = shift; $self->{_sender}; } sub header { my $self = shift; @_ and $self->{_header} = shift; $self->{_header}; } # blocked() will return when we actually can do something useful with it... #sub blocked { # my $self = shift; # carp 'Use of transaction->blocked is deprecated;' # . 'tell ask@develooper.com if you have a reason to use it'; # @_ and $self->{_blocked} = shift; # $self->{_blocked}; #} sub notes { my $self = 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 { # depreceated, use data_size() instead my $self = shift; $self->log(LOGWARN, "WARNING: body_size() is depreceated, use data_size() instead"); $self->{_body_size} || 0; } sub data_size { shift->{_body_size} || 0; } sub body_length { my $self = shift; $self->{_body_size} or return 0; $self->{_header_size} or return 0; return $self->{_body_size} - $self->{_header_size}; } sub body_resetpos { my $self = shift; if ($self->{_body_file}) { my $start = $self->{_body_start} || 0; seek($self->{_body_file}, $start, 0); $self->{_body_file_writing} = 0; } else { $self->{_body_current_pos} = $self->{_body_start}; } 1; } sub body_getline { my $self = shift; if ($self->{_body_file}) { my $start = $self->{_body_start} || 0; seek($self->{_body_file}, $start,0) if $self->{_body_file_writing}; $self->{_body_file_writing} = 0; my $line = $self->{_body_file}->getline; return $line; } else { return unless $self->{_body_array}; $self->{_body_current_pos} ||= 0; my $line = $self->{_body_array}->[$self->{_body_current_pos}]; $self->{_body_current_pos}++; return $line; } } sub body_as_string { my $self = shift; $self->body_resetpos; local $/; my $str = ''; while (defined(my $line = $self->body_getline)) { $str .= $line; } return $str; } sub body_fh { my ($self) = @_; # Spool to disk if we weren't already doing so $self->body_spool() unless $self->{_filename}; return $self->{_body_file}; } sub dup_body_fh { my ($self) = @_; open(my $fh, '<&=', $self->body_fh); return $fh; } sub DESTROY { my $self = shift; # would we save some disk flushing if we unlinked the file before # closing it? undef $self->{_body_file} if $self->{_body_file}; if ($self->{_filename} and -e $self->{_filename}) { unlink $self->{_filename} or $self->log(LOGERROR, "Could not unlink ", $self->{_filename}, ": $!"); } # These may not exist if ( $self->{_temp_files} ) { $self->log(LOGDEBUG, "Cleaning up temporary transaction files"); foreach my $file ( @{$self->{_temp_files}} ) { next unless -e $file; unlink $file or $self->log(LOGERROR, "Could not unlink temporary file", $file, ": $!"); } } # Ditto if ( $self->{_temp_dirs} ) { eval {use File::Path}; $self->log(LOGDEBUG, "Cleaning up temporary directories"); foreach my $dir ( @{$self->{_temp_dirs}} ) { rmtree($dir) or $self->log(LOGERROR, "Could not unlink temporary dir", $dir, ": $!"); } } } 1; __END__ =head1 NAME Qpsmtpd::Transaction - single SMTP session transaction data =head1 SYNOPSIS foreach my $recip ($transaction->recipients) { print "T", $recip->address, "\0"; } =head1 DESCRIPTION Qpsmtpd::Transaction maintains a single SMTP session's data, including the envelope details and the mail header and body. The docs below cover using the C<$transaction> object from within plugins rather than constructing a C 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 object. See L for more details. =head2 remove_recipient($recipient) This removes a recipient (as in RCPT TO) from the envelope of the mail. The C<$recipient> is a C object. See L for more details. =head2 recipients( ) This returns a list of the current recipients in the envelope. Each recipient returned is a C 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 be C objects. =head2 sender( [ ADDRESS ] ) Get or set the sender (MAIL FROM) address in the envelope. The sender is a C object. =head2 header( [ HEADER ] ) Get or set the header of the email. The header is a 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 or after C completes, so you might want to use the notes field in the C object instead. =head2 body_filename ( ) Returns the temporary filename used to store the message contents; useful for virus scanners so that an additional copy doesn't need to be made. Calling C also forces spooling to disk. A message is not spooled to disk if it's size is smaller than I<$self-Econfig("size_threshold")>, default threshold is 0, the sample config file sets this to 10000. =head2 body_write( $data ) Write data to the end of the email. C<$data> can be either a plain scalar, or a reference to a scalar. =head2 body_size( ) B, Use I instead. =head2 data_size( ) Get the current size of the email. Note that this is not the size of the message that will be queued, it is the size of what the client sent after the C command. If you need the size that will be queued, use my $msg_len = length($transaction->header->as_string) + $transaction->body_length; The line above is of course only valid in I, as other plugins may add headers and qpsmtpd will add it's I header. =head2 body_length( ) Get the current length of the body of the email. This length includes the empty line between the headers and the body. Until the client has sent some data of the body of the message (i.e. headers are finished and client sent the empty line) this will return 0. =head2 body_resetpos( ) Resets the body filehandle to the start of the file (via C). Use this function before every time you wish to process the entire body of the email to ensure that some other plugin has not moved the file pointer. =head2 body_getline( ) Returns a single line of data from the body of the email. =head2 body_fh( ) Returns the file handle to the temporary file of the email. This will return undef if the file is not opened (yet). In I or later you can force spooling to disk by calling I<$transaction-Ebody_filename>. =head2 dup_body_fh( ) Returns a dup()'d file handle to the temporary file of the email. This can be useful if an external module may call close() on the filehandle that is passed to it. This should only be used for reads, as writing to a dup'd filehandle may have unintended consequences. =head1 SEE ALSO L, L, L =cut qpsmtpd-0.84/lib/Qpsmtpd/Utils.pm000644 000765 000024 00000000350 11144617464 016720 0ustar00askstaff000000 000000 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; qpsmtpd-0.84/lib/Qpsmtpd/TcpServer/Prefork.pm000644 000765 000024 00000003456 11165321461 021147 0ustar00askstaff000000 000000 package Qpsmtpd::TcpServer::Prefork; use Qpsmtpd::TcpServer; use Qpsmtpd::SMTP::Prefork; use Qpsmtpd::Constants; @ISA = qw(Qpsmtpd::SMTP::Prefork Qpsmtpd::TcpServer); my $first_0; sub start_connection { my $self = shift; #reset info $self->{_connection} = Qpsmtpd::Connection->new(); #reset connection $self->reset_transaction; $self->SUPER::start_connection(@_); } sub read_input { my $self = shift; my $timeout = $self->config('timeoutsmtpd') # qmail smtpd control file || $self->config('timeout') # qpsmtpd control file || 1200; # default value alarm $timeout; eval { while () { alarm 0; $_ =~ s/\r?\n$//s; # advanced chomp $self->log(LOGINFO, "dispatching $_"); $self->connection->notes('original_string', $_); defined $self->dispatch(split / +/, $_, 2) or $self->respond(502, "command unrecognized: '$_'"); alarm $timeout; } }; if ($@ =~ /^disconnect_tcpserver/) { die "disconnect_tcpserver"; } else { $self->run_hooks("post-connection"); $self->connection->reset; die "died while reading from STDIN (probably broken sender) - $@"; } alarm(0); } sub respond { my ($self, $code, @messages) = @_; if ( !$self->check_socket() ) { $self->log(LOGERROR, "Lost connection to client, cannot send response."); return(0); } while (my $msg = shift @messages) { my $line = $code . (@messages?"-":" ").$msg; $self->log(LOGINFO, $line); print "$line\r\n" or ($self->log(LOGERROR, "Could not print [$line]: $!"), return 0); } return 1; } sub disconnect { my $self = shift; $self->log(LOGINFO,"click, disconnecting"); $self->SUPER::disconnect(@_); $self->run_hooks("post-connection"); $self->connection->reset; die "disconnect_tcpserver"; } 1; qpsmtpd-0.84/lib/Qpsmtpd/SMTP/Prefork.pm000644 000765 000024 00000001311 11165321461 020001 0ustar00askstaff000000 000000 package Qpsmtpd::SMTP::Prefork; use Qpsmtpd::SMTP; use Qpsmtpd::Constants; @ISA = qw(Qpsmtpd::SMTP); sub dispatch { my $self = shift; my ($cmd) = lc shift; $self->{_counter}++; if ($cmd !~ /^(\w{1,12})$/ or !exists $self->{_commands}->{$1}) { $self->run_hooks("unrecognized_command", $cmd, @_); return 1; } $cmd = $1; if (1 or $self->{_commands}->{$cmd} and $self->can($cmd)) { my ($result) = eval { $self->$cmd(@_) }; if ($@ =~ /^disconnect_tcpserver/) { die "disconnect_tcpserver"; } elsif ($@) { $self->log(LOGERROR, "XX: $@") if $@; } return $result if defined $result; return $self->fault("command '$cmd' failed unexpectedly"); } return; } qpsmtpd-0.84/lib/Qpsmtpd/Postfix/Constants.pm000644 000765 000024 00000006321 11165321461 021224 0ustar00askstaff000000 000000 # # Qpsmtpd::Postfix::Constants # # This is a generated file, do not edit # # created by pf2qp.pl v0.1 @ Sun Oct 29 09:10:18 2006 # postfix version 2.4 # package Qpsmtpd::Postfix::Constants; use Qpsmtpd::Constants; require Exporter; use vars qw(@ISA @EXPORT %cleanup_soft %cleanup_hard $postfix_version); use strict; @ISA = qw(Exporter); @EXPORT = qw( %cleanup_soft %cleanup_hard $postfix_version CLEANUP_FLAG_NONE CLEANUP_FLAG_BOUNCE CLEANUP_FLAG_FILTER CLEANUP_FLAG_HOLD CLEANUP_FLAG_DISCARD CLEANUP_FLAG_BCC_OK CLEANUP_FLAG_MAP_OK CLEANUP_FLAG_MILTER CLEANUP_FLAG_FILTER_ALL CLEANUP_FLAG_MASK_EXTERNAL CLEANUP_FLAG_MASK_INTERNAL CLEANUP_FLAG_MASK_EXTRA CLEANUP_STAT_OK CLEANUP_STAT_BAD CLEANUP_STAT_WRITE CLEANUP_STAT_SIZE CLEANUP_STAT_CONT CLEANUP_STAT_HOPS CLEANUP_STAT_RCPT CLEANUP_STAT_PROXY CLEANUP_STAT_DEFER CLEANUP_STAT_MASK_CANT_BOUNCE CLEANUP_STAT_MASK_INCOMPLETE ); $postfix_version = "2.4"; use constant CLEANUP_FLAG_NONE => 0; # /* No special features */ use constant CLEANUP_FLAG_BOUNCE => (1<<0); # /* Bounce bad messages */ use constant CLEANUP_FLAG_FILTER => (1<<1); # /* Enable header/body checks */ use constant CLEANUP_FLAG_HOLD => (1<<2); # /* Place message on hold */ use constant CLEANUP_FLAG_DISCARD => (1<<3); # /* Discard message silently */ use constant CLEANUP_FLAG_BCC_OK => (1<<4); # /* Ok to add auto-BCC addresses */ use constant CLEANUP_FLAG_MAP_OK => (1<<5); # /* Ok to map addresses */ use constant CLEANUP_FLAG_MILTER => (1<<6); # /* Enable Milter applications */ use constant CLEANUP_FLAG_FILTER_ALL => (CLEANUP_FLAG_FILTER | CLEANUP_FLAG_MILTER); use constant CLEANUP_FLAG_MASK_EXTERNAL => (CLEANUP_FLAG_FILTER_ALL | CLEANUP_FLAG_BCC_OK | CLEANUP_FLAG_MAP_OK); use constant CLEANUP_FLAG_MASK_INTERNAL => CLEANUP_FLAG_MAP_OK; use constant CLEANUP_FLAG_MASK_EXTRA => (CLEANUP_FLAG_HOLD | CLEANUP_FLAG_DISCARD); use constant CLEANUP_STAT_OK => 0; # /* Success. */ use constant CLEANUP_STAT_BAD => (1<<0); # /* Internal protocol error */ use constant CLEANUP_STAT_WRITE => (1<<1); # /* Error writing message file */ use constant CLEANUP_STAT_SIZE => (1<<2); # /* Message file too big */ use constant CLEANUP_STAT_CONT => (1<<3); # /* Message content rejected */ use constant CLEANUP_STAT_HOPS => (1<<4); # /* Too many hops */ use constant CLEANUP_STAT_RCPT => (1<<6); # /* No recipients found */ use constant CLEANUP_STAT_PROXY => (1<<7); # /* Proxy reject */ use constant CLEANUP_STAT_DEFER => (1<<8); # /* Temporary reject */ use constant CLEANUP_STAT_MASK_CANT_BOUNCE => (CLEANUP_STAT_BAD | CLEANUP_STAT_WRITE | CLEANUP_STAT_DEFER); use constant CLEANUP_STAT_MASK_INCOMPLETE => (CLEANUP_STAT_BAD | CLEANUP_STAT_WRITE | CLEANUP_STAT_SIZE | CLEANUP_STAT_DEFER); %cleanup_soft = ( CLEANUP_STAT_DEFER => "service unavailable (#4.7.1)", CLEANUP_STAT_PROXY => "queue file write error (#4.3.0)", CLEANUP_STAT_BAD => "internal protocol error (#4.3.0)", CLEANUP_STAT_WRITE => "queue file write error (#4.3.0)", ); %cleanup_hard = ( CLEANUP_STAT_RCPT => "no recipients specified (#5.1.0)", CLEANUP_STAT_HOPS => "too many hops (#5.4.0)", CLEANUP_STAT_SIZE => "message file too big (#5.3.4)", CLEANUP_STAT_CONT => "message content rejected (#5.7.1)", ); 1; qpsmtpd-0.84/lib/Qpsmtpd/Postfix/pf2qp.pl000755 000765 000024 00000005234 11165321461 020304 0ustar00askstaff000000 000000 #/usr/bin/perl -w # # my $version = "0.1"; $0 =~ s#.*/##; my $path = $&; # sneaky way to get path back my $POSTFIX_SRC = shift || die <<"EOF"; Usage: $0 /path/to/postfix/source EOF my $header = "$POSTFIX_SRC/src/global/cleanup_user.h"; my $src = "$POSTFIX_SRC/src/global/cleanup_strerror.c"; my $pf_vers = "$POSTFIX_SRC/src/global/mail_version.h"; my $postfix_version = ""; open VERS, $pf_vers or die "Could not open $pf_vers: $!\n"; while () { next unless /^\s*#\s*define\s+MAIL_VERSION_NUMBER\s+"(.+)"\s*$/; $postfix_version = $1; last; } close VERS; $postfix_version =~ s/^(\d+\.\d+).*/$1/; if ($postfix_version < 2.3) { die "Need at least postfix v2.3"; } my $start = <<'_END'; # # Qpsmtpd::Postfix::Constants # # This is a generated file, do not edit # _END $start .= "# created by $0 v$version @ ".scalar(gmtime)."\n" ."# postfix version $postfix_version\n" ."#\n"; $start .= <<'_END'; package Qpsmtpd::Postfix::Constants; use Qpsmtpd::Constants; require Exporter; use vars qw(@ISA @EXPORT %cleanup_soft %cleanup_hard $postfix_version); use strict; @ISA = qw(Exporter); _END my @export = qw(%cleanup_soft %cleanup_hard $postfix_version); my @out = (); open HEAD, $header or die "Could not open $header: $!\n"; while () { while (s/\\\n$//) { $_ .= ; } chomp; if (/^\s*#define\s/) { s/^\s*#define\s*//; next if /^_/; s#(/\*.*\*/)##; my $comment = $1 || ""; my @words = split ' ', $_; my $const = shift @words; if ($const eq "CLEANUP_STAT_OK") { push @out, ""; } push @export, $const; push @out, "use constant $const => ". join(" ", @words). "; " .($comment ? "# $comment ": ""); } } close HEAD; open SRC, $src or die "Could not open $src: $!\n"; my $data; { local $/ = undef; $data = ; } close SRC; $data =~ s/.*cleanup_stat_map\[\]\s*=\s*{\s*\n//s; $data =~ s/};.*$//s; my @array = split "\n", $data; my (@denysoft,@denyhard); foreach (@array) { chomp; s/,/ => /; s/"(\d\.\d\.\d)",\s+"(.*)",/"$2 (#$1)",/; s!(/\*.*\*/)!# $1!; s/4\d\d,\s// && push @denysoft, $_; s/5\d\d,\s// && push @denyhard, $_; } open my $CONSTANTS, '>', "$path/Constants.pm"; print ${CONSTANTS} $start, '@EXPORT = qw(', "\n"; while (@export) { print ${CONSTANTS} "\t", shift @export, "\n"; } print ${CONSTANTS} ");\n\n", "\$postfix_version = \"$postfix_version\";\n", join("\n", @out),"\n\n"; print ${CONSTANTS} "\%cleanup_soft = (\n", join("\n", @denysoft), "\n);\n\n"; print ${CONSTANTS} "\%cleanup_hard = (\n", join("\n", @denyhard), "\n);\n\n1;\n"; close $CONSTANTS; qpsmtpd-0.84/lib/Qpsmtpd/Plugin/Async/000755 000765 000024 00000000000 11357265152 017576 5ustar00askstaff000000 000000 qpsmtpd-0.84/lib/Qpsmtpd/Plugin/Async/DNSBLBase.pm000644 000765 000024 00000004542 11165321461 021567 0ustar00askstaff000000 000000 package Qpsmtpd::Plugin::Async::DNSBLBase; # Class methods shared by the async plugins using DNS based blacklists or # whitelists. use strict; use Qpsmtpd::Constants; use ParaDNS; sub lookup { my ($class, $qp, $A_lookups, $TXT_lookups) = @_; my $total_zones = @$A_lookups + @$TXT_lookups; my ($A_pdns, $TXT_pdns); if (@$A_lookups) { $qp->log(LOGDEBUG, "Checking ", join(", ", @$A_lookups), " for A record in the background"); $A_pdns = ParaDNS->new( callback => sub { my ($result, $query) = @_; return if $result !~ /^\d+\.\d+\.\d+\.\d+$/; $qp->log(LOGDEBUG, "Result for A $query: $result"); $class->process_a_result($qp, $result, $query); }, finished => sub { $total_zones -= @$A_lookups; $class->finished($qp, $total_zones); }, hosts => [@$A_lookups], type => 'A', client => $qp->input_sock, ); return unless defined $A_pdns; } if (@$TXT_lookups) { $qp->log(LOGDEBUG, "Checking ", join(", ", @$TXT_lookups), " for TXT record in the background"); $TXT_pdns = ParaDNS->new( callback => sub { my ($result, $query) = @_; return if $result !~ /[a-z]/; $qp->log(LOGDEBUG, "Result for TXT $query: $result"); $class->process_txt_result($qp, $result, $query); }, finished => sub { $total_zones -= @$TXT_lookups; $class->finished($qp, $total_zones); }, hosts => [@$TXT_lookups], type => 'TXT', client => $qp->input_sock, ); unless (defined $TXT_pdns) { undef $A_pdns; return; } } return 1; } sub finished { my ($class, $qp, $total_zones) = @_; $qp->log(LOGDEBUG, "Finished ($total_zones)"); $qp->run_continuation unless $total_zones; } # plugins should implement the following two methods to do something # useful with the results sub process_a_result { my ($class, $qp, $result, $query) = @_; } sub process_txt_result { my ($class, $qp, $result, $query) = @_; } 1; qpsmtpd-0.84/lib/Danga/Client.pm000644 000765 000024 00000013552 11165321461 016420 0ustar00askstaff000000 000000 # $Id: Client.pm,v 1.8 2005/02/14 22:06:38 msergeant Exp $ package Danga::Client; use base 'Danga::TimeoutSocket'; use fields qw( line pause_count read_bytes data_bytes callback get_chunks reader_object ); use Time::HiRes (); use bytes; # 30 seconds max timeout! sub max_idle_time { 30 } sub max_connect_time { 1200 } sub new { my Danga::Client $self = shift; $self = fields::new($self) unless ref $self; $self->SUPER::new( @_ ); $self->reset_for_next_message; return $self; } sub reset_for_next_message { my Danga::Client $self = shift; $self->{line} = ''; $self->{pause_count} = 0; $self->{read_bytes} = 0; $self->{callback} = undef; $self->{reader_object} = undef; $self->{data_bytes} = ''; $self->{get_chunks} = 0; return $self; } sub get_bytes { my Danga::Client $self = shift; my ($bytes, $callback) = @_; if ($self->{callback}) { die "get_bytes/get_chunks currently in progress!"; } $self->{read_bytes} = $bytes; $self->{data_bytes} = $self->{line}; $self->{read_bytes} -= length($self->{data_bytes}); $self->{line} = ''; if ($self->{read_bytes} <= 0) { if ($self->{read_bytes} < 0) { $self->{line} = substr($self->{data_bytes}, $self->{read_bytes}, # negative offset 0 - $self->{read_bytes}, # to end of str ""); # truncate that substr } $callback->($self->{data_bytes}); return; } $self->{callback} = $callback; } sub process_chunk { my Danga::Client $self = shift; my $callback = shift; my $last_crlf = rindex($self->{line}, "\r\n"); if ($last_crlf != -1) { if ($last_crlf + 2 == length($self->{line})) { my $data = $self->{line}; $self->{line} = ''; $callback->($data); } else { my $data = substr($self->{line}, 0, $last_crlf + 2); $self->{line} = substr($self->{line}, $last_crlf + 2); $callback->($data); } } } sub get_chunks { my Danga::Client $self = shift; my ($bytes, $callback) = @_; if ($self->{callback}) { die "get_bytes/get_chunks currently in progress!"; } $self->{read_bytes} = $bytes; $self->process_chunk($callback) if length($self->{line}); $self->{callback} = $callback; $self->{get_chunks} = 1; } sub end_get_chunks { my Danga::Client $self = shift; my $remaining = shift; $self->{callback} = undef; $self->{get_chunks} = 0; if (defined($remaining)) { $self->process_read_buf(\$remaining); } } sub set_reader_object { my Danga::Client $self = shift; $self->{reader_object} = shift; } sub event_read { my Danga::Client $self = shift; if (my $obj = $self->{reader_object}) { $self->{reader_object} = undef; $obj->event_read($self); } elsif ($self->{callback}) { $self->{alive_time} = time; if ($self->{get_chunks}) { my $bref = $self->read($self->{read_bytes}); return $self->close($!) unless defined $bref; $self->{line} .= $$bref; $self->process_chunk($self->{callback}) if length($self->{line}); return; } if ($self->{read_bytes} > 0) { my $bref = $self->read($self->{read_bytes}); return $self->close($!) unless defined $bref; $self->{read_bytes} -= length($$bref); $self->{data_bytes} .= $$bref; } if ($self->{read_bytes} <= 0) { # print "Erk, read too much!\n" if $self->{read_bytes} < 0; my $cb = $self->{callback}; $self->{callback} = undef; $cb->($self->{data_bytes}); } } else { my $bref = $self->read(8192); return $self->close($!) unless defined $bref; $self->process_read_buf($bref); } } sub process_read_buf { my Danga::Client $self = shift; my $bref = shift; $self->{line} .= $$bref; return if $self->{pause_count} || $self->{closed}; if ($self->{line} =~ s/^(.*?\n)//) { my $line = $1; $self->{alive_time} = time; my $resp = $self->process_line($line); if ($::DEBUG > 1 and $resp) { print "$$:".($self+0)."S: $_\n" for split(/\n/, $resp) } $self->write($resp) if $resp; # $self->watch_read(0) if $self->{pause_count}; return if $self->{pause_count} || $self->{closed}; # read more in a timer, to give other clients a look in $self->AddTimer(0, sub { if (length($self->{line}) && !$self->paused) { $self->process_read_buf(\""); # " for bad syntax highlighters } }); } } sub has_data { my Danga::Client $self = shift; return length($self->{line}) ? 1 : 0; } sub clear_data { my Danga::Client $self = shift; $self->{line} = ''; } sub paused { my Danga::Client $self = shift; return 1 if $self->{pause_count}; return 1 if $self->{closed}; return 0; } sub pause_read { my Danga::Client $self = shift; $self->{pause_count}++; # $self->watch_read(0); } sub continue_read { my Danga::Client $self = shift; $self->{pause_count}--; if ($self->{pause_count} <= 0) { $self->{pause_count} = 0; $self->AddTimer(0, sub { if (length($self->{line}) && !$self->paused) { $self->process_read_buf(\""); # " for bad syntax highlighters } }); } } sub process_line { my Danga::Client $self = shift; return ''; } sub close { my Danga::Client $self = shift; print "closing @_\n" if $::DEBUG; $self->SUPER::close(@_); } sub event_err { my Danga::Client $self = shift; $self->close("Error") } sub event_hup { my Danga::Client $self = shift; $self->close("Disconnect (HUP)") } 1; qpsmtpd-0.84/lib/Danga/TimeoutSocket.pm000644 000765 000024 00000003154 11165321461 017776 0ustar00askstaff000000 000000 # $Id: TimeoutSocket.pm,v 1.2 2005/02/02 20:44:35 msergeant Exp $ package Danga::TimeoutSocket; use base 'Danga::Socket'; use fields qw(alive_time create_time); our $last_cleanup = 0; Danga::Socket->AddTimer(15, \&_do_cleanup); sub new { my Danga::TimeoutSocket $self = shift; my $sock = shift; $self = fields::new($self) unless ref($self); $self->SUPER::new($sock); my $now = time; $self->{alive_time} = $self->{create_time} = $now; return $self; } # overload these in a subclass sub max_idle_time { 0 } sub max_connect_time { 0 } sub Reset { Danga::Socket->Reset; Danga::Socket->AddTimer(15, \&_do_cleanup); } sub _do_cleanup { my $now = time; Danga::Socket->AddTimer(15, \&_do_cleanup); my $sf = __PACKAGE__->get_sock_ref; my %max_age; # classname -> max age (0 means forever) my %max_connect; # classname -> max connect time my @to_close; while (my $k = each %$sf) { my Danga::TimeoutSocket $v = $sf->{$k}; my $ref = ref $v; next unless $v->isa('Danga::TimeoutSocket'); unless (defined $max_age{$ref}) { $max_age{$ref} = $ref->max_idle_time || 0; $max_connect{$ref} = $ref->max_connect_time || 0; } if (my $t = $max_connect{$ref}) { if ($v->{create_time} < $now - $t) { push @to_close, $v; next; } } if (my $t = $max_age{$ref}) { if ($v->{alive_time} < $now - $t) { push @to_close, $v; } } } $_->close("Timeout") foreach @to_close; } 1; qpsmtpd-0.84/lib/Apache/Qpsmtpd.pm000644 000765 000024 00000013035 11165321461 016775 0ustar00askstaff000000 000000 # $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); die "\$ENV{QPSMTPD_CONFIG} must be given" unless $ENV{QPSMTPD_CONFIG}; my $qpsmtpd = Qpsmtpd::Apache->new(); $qpsmtpd->start_connection( ip => $c->remote_ip, host => $c->remote_host, info => undef, conn => $c, ); $qpsmtpd->run($c); $qpsmtpd->run_hooks("post-connection"); $qpsmtpd->connection->reset; return Apache2::Const::OK; } package Qpsmtpd::Apache; use Qpsmtpd::Constants; use base qw(Qpsmtpd::SMTP); sub start_connection { my $self = shift; my %opts = @_; $self->{conn} = $opts{conn}; $self->{conn}->client_socket->timeout_set($self->config('timeout') * 1_000_000); $self->{bb_in} = APR::Brigade->new($self->{conn}->pool, $self->{conn}->bucket_alloc); $self->{bb_out} = APR::Brigade->new($self->{conn}->pool, $self->{conn}->bucket_alloc); my $remote_host = $opts{host} || ( $opts{ip} ? "[$opts{ip}]" : "[noip!]"); my $remote_info = $opts{info} ? "$opts{info}\@$remote_host" : $remote_host; my $remote_ip = $opts{ip}; $self->log(LOGNOTICE, "Connection from $remote_info [$remote_ip]"); $self->SUPER::connection->start( remote_info => $remote_info, remote_ip => $remote_ip, remote_host => $remote_host, local_ip => $opts{conn}->local_ip, @_ ); } sub config { my $self = shift; my ($param, $type) = @_; if (!$type) { my $opt = $self->{conn}->base_server->dir_config("qpsmtpd.$param"); return $opt if defined($opt); } return $self->SUPER::config(@_); } sub run { my $self = shift; # should be somewhere in Qpsmtpd.pm and not here... $self->load_plugins; my $rc = $self->start_conversation; return if $rc != DONE; # this should really be the loop and read_input should just # get one line; I think $self->read_input(); } sub getline { my $self = shift; my $c = $self->{conn} || die "Cannot getline without a conn"; return if $c->aborted; my $bb = $self->{bb_in}; while (1) { my $rc = $c->input_filters->get_brigade($bb, Apache2::Const::MODE_GETLINE); return if $rc == APR::Const::EOF; die APR::Error::strerror($rc) unless $rc == APR::Const::SUCCESS; next unless $bb->flatten(my $data); $bb->cleanup; return $data; } return ''; } sub read_input { my $self = shift; my $c = $self->{conn}; while (defined(my $data = $self->getline)) { $data =~ s/\r?\n$//s; # advanced chomp $self->connection->notes('original_string', $data); $self->log(LOGDEBUG, "dispatching $data"); defined $self->dispatch(split / +/, $data, 2) or $self->respond(502, "command unrecognized: '$data'"); last if $self->{_quitting}; } } sub respond { my ($self, $code, @messages) = @_; my $c = $self->{conn}; while (my $msg = shift @messages) { my $bb = $self->{bb_out}; my $line = $code . (@messages?"-":" ").$msg; $self->log(LOGDEBUG, $line); my $bucket = APR::Bucket->new(($c->bucket_alloc), "$line\r\n"); $bb->insert_tail($bucket); $c->output_filters->fflush($bb); # $bucket->remove; $bb->cleanup; } return 1; } sub disconnect { my $self = shift; $self->SUPER::disconnect(@_); $self->{_quitting} = 1; $self->{conn}->client_socket->close(); } 1; __END__ =head1 NAME Apache::Qpsmtpd - a mod_perl-2 connection handler for qpsmtpd =head1 SYNOPSIS Listen 0.0.0.0:25 smtp AcceptFilter smtp none ## "smtp" and the AcceptFilter are required for Linux, FreeBSD ## with apache >= 2.1.5, for others it doesn't hurt. See also ## http://httpd.apache.org/docs/2.2/mod/core.html#acceptfilter ## and http://httpd.apache.org/docs/2.2/mod/mpm_common.html#listen LoadModule perl_module modules/mod_perl.so use lib qw( /path/to/qpsmtpd/lib ); use Apache::Qpsmtpd; $ENV{QPSMTPD_CONFIG} = "/path/to/qpsmtpd/config"; PerlModule Apache::Qpsmtpd PerlProcessConnectionHandler Apache::Qpsmtpd # can specify this in config/plugin_dirs if you wish: PerlSetVar qpsmtpd.plugin_dirs /path/to/qpsmtpd/plugins PerlSetVar qpsmtpd.loglevel 4 =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, as seen above) using C in F. This module should be considered beta software as it is not yet widely tested. However it is currently the fastest way to run Qpsmtpd, so if performance is important to you then consider this module. =head1 BUGS Probably a few. Make sure you test your plugins carefully. The Apache scoreboard (/server-status/) mostly works and shows connections, but could do with some enhancements specific to SMTP. =head1 AUTHOR Matt Sergeant, Some credit goes to for Apache::SMTP which gave me the inspiration to do this. =cut qpsmtpd-0.84/docs/advanced.pod000644 000765 000024 00000005463 11211430037 016257 0ustar00askstaff000000 000000 # # This file is best read with ``perldoc advanced.pod'' # ### # Conventions: # plugin names: F, F # constants: I # smtp commands, answers: B, B<250 Queued!> # # Notes: # * due to restrictions of some POD parsers, no C<<$object->method()>> # are allowed, use C<$object-Emethod()> # =head1 Advanced Playground =head2 Discarding messages If you want to make the client think a message has been regularily accepted, but in real you delete it or send it to F, ..., use something like the following plugin and load it before your default queue plugin. sub hook_queue { my ($self, $transaction) = @_; if ($transaction->notes('discard_mail')) { my $msg_id = $transaction->header->get('Message-Id') || ''; $msg_id =~ s/[\r\n].*//s; return(OK, "Queued! $msg_id"); } return(DECLINED); } =head2 Changing return values This is an example how to use the C method. The B plugin wraps the B plugin. The B plugin checks the F and F config files for domains, which we accept mail for. If not found it tells the client that relaying is not allowed. Clients which are marked as C are excluded from this rule. This plugin counts the number of unsuccessfull relaying attempts and drops the connection if too many were made. The optional parameter I configures this plugin to drop the connection after I unsuccessful relaying attempts. Set to C<0> to disable, default is C<5>. Note: Do not load both (B and B). This plugin should be configured to run I, like B. use Qpsmtpd::DSN; sub init { my ($self, $qp, @args) = @_; die "too many arguments" if @args > 1; $self->{_count_relay_max} = defined $args[0] ? $args[0] : 5; $self->isa_plugin("rcpt_ok"); } sub hook_rcpt { my ($self, $transaction, $recipient) = @_; my ($rc, @msg) = $self->SUPER::hook_rcpt($transaction, $recipient); return ($rc, @msg) unless (($rc == DENY) and $self->{_count_relay_max}); my $count = ($self->qp->connection->notes('count_relay_attempts') || 0) + 1; $self->qp->connection->notes('count_relay_attempts', $count); return ($rc, @msg) unless ($count > $self->{_count_relay_max}); return Qpsmtpd::DSN->relaying_denied(DENY_DISCONNECT, "Too many relaying attempts"); } =head2 Results of other hooks B just copied from README.plugins If we're in a transaction, the results of a callback are stored in $self->transaction->notes( $code->{name})->{"hook_$hook"}->{return} If we're in a connection, store things in the connection notes instead. B: does the above (regarding connection notes) work? =cut # vim: ts=2 sw=2 expandtab qpsmtpd-0.84/docs/authentication.pod000644 000765 000024 00000016113 11165321461 017533 0ustar00askstaff000000 000000 # # read this with 'perldoc authentication.pod' ... # =head1 NAME Authentication framework for qpsmtpd =head1 DESCRIPTION Provides support for SMTP AUTH within qpsmtpd transactions, see L L for more details. =head1 USAGE This code is automatically loaded by Qpsmtpd::SMTP only if a plugin providing one of the defined L 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 for more details. All plugins must provide two functions: =over 4 =item * init() This is the standard function which is called by qpsmtpd for any plugin listed in config/plugins. Typically, an auth plugin should register at least one hook, like this: sub init { my ($self, $qp) = @_; $self->register_hook("auth", "authfunction"); } where in this case "auth" means this plugin expects to support any of the defined authentication methods. =item * authfunction() The plugin must provide an authentication function which is part of the register_hook call. That function will receive the following six parameters when called: =over 4 =item $self A Qpsmtpd::Plugin object, which can be used, for example, to emit log entries or to send responses to the remote SMTP client. =item $transaction A Qpsmtpd::Transaction object which can be used to examine information about the current SMTP session like the remote IP address. =item $mechanism The lower-case name of the authentication mechanism requested by the client; either "plain", "login", or "cram-md5". =item $user Whatever the remote SMTP client sent to identify the user (may be bare name or fully qualified e-mail address). =item $clearPassword If the particular authentication method supports unencrypted passwords (currently PLAIN and LOGIN), which will be the plaintext password sent by the remote SMTP client. =item $hashPassword An encrypted form of the remote user's password, using the MD-5 algorithm (see also the $ticket parameter). =item $ticket This is the cryptographic challenge which was sent to the client as part of a CRAM-MD5 transaction. Since the MD-5 algorithm is one-way, the same $ticket value must be used on the backend to compare with the encrypted password sent in $hashPassword. =back =back Plugins should perform whatever checking they want and then return one of the following values (taken from Qpsmtpd::Constants): =over 4 =item OK If the authentication has succeeded, the plugin can return this value and all subsequently registered hooks will be skipped. =item DECLINED If the authentication has failed, but any additional plugins should be run, this value will be returned. If none of the registered plugins succeed, the overall authentication will fail. Normally an auth plugin should return this value for all cases which do not succeed (so that another auth plugin can have a chance to authenticate the user). =item DENY If the authentication has failed, and the plugin wishes this to short circuit any further testing, it should return this value. For example, a plugin could register the L 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 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 =head1 COPYRIGHT AND LICENSE Copyright (c) 2004-2006 John Peacock Portions based on original code by Ask Bjoern Hansen and Guillaume Filion This plugin is licensed under the same terms as the qpsmtpd package itself. Please see the LICENSE file included with qpsmtpd for details. =cut qpsmtpd-0.84/docs/config.pod000644 000765 000024 00000011516 11217543405 015765 0ustar00askstaff000000 000000 =head1 Qpsmtpd configuration The default way of setting config values is placing files with the name of the config variable in the config directory F, like qmail's F directory. NB: F (or F<$ENV{QMAIL}/control>) is used if a file does not exist in C. The location of the C directory can be set via the I environment variable and defaults to the current working directory. Any empty line or lines starting with C<#> are ignored. You may use a plugin which hooks the C hook to store the settings in some other way. See L and L for more info on this. Some settings still have to go in files, because they are loaded before any plugin can return something via the C hook: C, C, C and of course C. B =head2 Core settings These settings are used by the qpsmtpd core. Any other setting is (hopefully) documented by the corresponding plugin. Some settings of important plugins are shown below in L. =over 4 =item plugins The main config file, where all used plugins and their arguments are listed. =item me Sets the hostname which is used all over the place: in the greeting message, the Iheader, ... Default is whatever Sys::Hostname's hostname() returns. =item plugin_dirs Where to search for plugins (one directory per line), defaults to F<./plugins>. =item logging Sets the primary logging destination, see F. Format is the same as it's used for the F config file. B only the first non empty line is used (lines starting with C<#> are counted as empty). =item loglevel This is not used anymore, I if no F plugin is in use. Use a logging plugin. =item databytes Maximum size a message may be. Without this setting, there is no limit on the size. Should be something less than the backend MTA has set as it's maximum message size (if there is one). =item size_threshold When a message is greater than the size given in this config file, it will be spooled to disk. You probably want to enable spooling to disk for most virus scanner plugins and F. =item smtpgreeting Override the default SMTP greeting with this string. =item spool_dir Where temporary files are stored, defaults to F<~/tmp/>. =item spool_perms Permissions of the I, default is C<0700>. You probably have to change the defaults for some scanners (e.g. the F plugin). =item timeout =item timeoutsmtpd Set the timeout for the clients, C is the qmail smtpd control file, C the qpsmtpd file. Default is 1200 seconds. =item tls_before_auth If set to a true value, clients will have to initiate an SSL secured connection before any auth succeeds, defaults to C<0>. =back =head2 Plugin settings =over 4 =item rcpthosts, morercpthosts Plugin: I Domains listed in these files will be accepted as valid local domains, anything else is rejected with a C message. If an entry in the C file starts with a C<.>, mails to anything ending with this string will be accepted, e.g.: example.com .example.com will accept mails for C and C. The C file is just checked for exact (case insensitive) matches. =item hosts_allow Plugin: F. Don't use this config file. The plugin itself is required to set the maximum number of concurrent connections. This config setting should only be used for some extremly rude clients: if list is too big it will slow down accepting new connections. =item relayclients =item morerelayclients Plugin: F Allow relaying for hosts listed in this file. The C file accepts IPs and CIDR entries. The C file accepts IPs and C like C<192.168.2.> (note the trailing dot!). With the given example any host which IP starts with C<192.168.2.> may relay via us. =item dnsbl_zones Plugin: F This file specifies the RBL zones list, used by the dnsbl plugin. Ihe IP address of each connecting host will be checked against each zone given. A few sample DNSBLs are listed in the sample config file, but you should evaluate the efficacy and listing policies of a DNSBL before using it. See also C and C in the documentation of the C plugin =item require_resolvable_fromhost Plugin: F Reject sender addresses where the MX is unresolvable, i.e. a boolean value is the only value in this file. If the MX resolves to something, reject the sender address if it resolves to something listed in the F config file. The I expects IP addresses or CIDR (i.e. C values) one per line, IPv4 only currenlty. =back =cut qpsmtpd-0.84/docs/development.pod000644 000765 000024 00000007676 11211430037 017044 0ustar00askstaff000000 000000 =head1 Developing Qpsmtpd =head2 Mailing List All qpsmtpd development happens on the qpsmtpd mailing list. Subscribe by sending mail to qpsmtpd-subscribe@perl.org =head2 Git We use git for version control. Ask owns the master repository at git://github.com/abh/qpsmtpd.git We suggest using github to host your repository -- it makes your changes easily accessible for pulling into the master. After you create a github account, go to http://github.com/abh/qpsmtpd/tree/master and click on the "fork" button to get your own repository. =head3 Making a working Copy git clone git@github.com:username/qpsmtpd.git qpsmtpd will check out your copy into a directory called qpsmtpd =head3 Making a branch for your change As a general rule, you'll be better off if you do your changes on a branch - preferably a branch per unrelated change. You can use the C command to see which branch you are on. The easiest way to make a new branch is git checkout -b topic/my-great-change This will create a new branch with the name "topic/my-great-change" (and your current commit as the starting point). =head3 Committing a change Edit the appropriate files, and be sure to run the test suite. emacs lib/Qpsmtpd.pm # for example perl Makefile.PL make test When you're ready to check it in... git add lib/Qpsmtpd.pm # to let git know you changed the file git add --patch plugin/tls # interactive choose which changes to add git diff --cached # review changes added git commit git log -p # review your commit a last time git push origin # to send to github =head3 Submit patches by mail The best way to submit patches to the project is to send them to the mailing list for review. Use the C command to generate patches ready to be mailed. For example: git format-patch HEAD~3 will put each of the last three changes in files ready to be mailed with the C tool (it might be a good idea to send them to yourself first as a test). Sending patches to the mailing list is the most effective way to submit changes, although it helps if you at the same time also commit them to a git repository (for example on github). =head3 Merging changes back in from the master repository Tell git about the master repository. We're going to call it 'abh' for now, but you could call it anything you want. You only have to do this once. git remote add abh git://github.com/abh/qpsmtpd.git Pull in data from all remote branches git remote update Forward-port local commits to the updated upstream head git rebase abh/master If you have a change that conflicts with an upstream change (git will let you know) you have two options. Manually fix the conflict and then do git add some/file git commit Or if the conflicting upstream commit did the same logical change then you might want to just skip the local change: git rebase --skip Be sure to decide whether you're going to skip before you merge, or you might get yourself into an odd situation. Conflicts happen because upstream committers may make minor tweaks to your change before applying it. =head3 Throwing away changes If you get your working copy into a state you don't like, you can always revert to the last commit: git reset --hard HEAD Or throw away your most recent commit: git reset --hard HEAD^ If you make a mistake with this, git is pretty good about keeping your commits around even as you merge, rebase and reset away. This log of your git changes is called with "git reflog". =head3 Applying other peoples changes If you get a change in an email with the patch, one easy way to apply other peoples changes is to use C. That will go ahead and commit the change. To modify it, you can use C. If the changes are in a repository, you can add that repository with "git remote add" and then either merge them in with "git merge" or pick just the relevant commits with "git cherry-pick". qpsmtpd-0.84/docs/hooks.pod000644 000765 000024 00000051541 11211430037 015633 0ustar00askstaff000000 000000 # # This file is best read with ``perldoc plugins.pod'' # ### # Conventions: # plugin names: F, F # constants: I # smtp commands, answers: B, B<250 Queued!> # # Notes: # * due to restrictions of some POD parsers, no C<<$object->method()>> # are allowed, use C<$object-Emethod()> # =head1 SMTP hooks This section covers the hooks, which are run in a normal SMTP connection. The order of these hooks is like you will (probably) see them, while a mail is received. Every hook receives a C object of the currently running plugin as the first argument. A C object is the second argument of the current transaction in the most hooks, exceptions are noted in the description of the hook. If you need examples how the hook can be used, see the source of the plugins, which are given as example plugins. B: for some hooks (post-fork, post-connection, disconnect, deny, ok) the return values are ignored. This does B mean you can return anything you want. It just means the return value is discarded and you can not disconnect a client with I. The rule to return I to run the next plugin for this hook (or return I / I to stop processing) still applies. =head2 hook_pre_connection Called by a controlling process (e.g. forkserver or prefork) after accepting the remote server, but before beginning a new instance (or handing the connection to the worker process). Useful for load-management and rereading large config files at some frequency less than once per session. This hook is available in the F, F and F flavours. =cut NOT FOR: apache, -server and inetd/pperl =pod B You should not use this hook to do major work and / or use lookup methods which (I) take some time, like DNS lookups. This will slow down B incoming connections, no other connection will be accepted while this hook is running! Arguments this hook receives are (B: currently no C<%args> for F): my ($self,$transaction,%args) = @_; # %args is: # %args = ( remote_ip => inet_ntoa($iaddr), # remote_port => $port, # local_ip => inet_ntoa($laddr), # local_port => $lport, # max_conn_ip => $MAXCONNIP, # child_addrs => [values %childstatus], # ); B the C<$transaction> is of course C at this time. Allowed return codes are =over 4 =item DENY / DENY_DISCONNECT returns a B<550> to the client and ends the connection =item DENYSOFT / DENYSOFT_DISCONNECT returns a B<451> to the client and ends the connection =back Anything else is ignored. Example plugins are F and F. =head2 hook_connect It is called at the start of a connection before the greeting is sent to the connecting client. Arguments for this hook are my $self = shift; B in fact you get passed two more arguments, which are C at this early stage of the connection, so ignore them. Allowed return codes are =over 4 =item OK Stop processing plugins, give the default response =item DECLINED Process the next plugin =item DONE Stop processing plugins and dont give the default response, i.e. the plugin gave the response =item DENY Return hard failure code and disconnect =item DENYSOFT Return soft failure code and disconnect =back Example plugin for this hook is the F plugin. =head2 hook_helo / hook_ehlo It is called after the client sent B (hook_ehlo) or B (hook_helo) Allowed return codes are =over 4 =item DENY Return a 550 code =item DENYSOFT Return a B<450> code =item DENY_DISCONNECT / DENYSOFT_DISCONNECT as above but with disconnect =item DONE Qpsmtpd wont do anything, the plugin sent the message =item DECLINED Qpsmtpd will send the standard B/B answer, of course only if all plugins hooking I return I. =back Arguments of this hook are my ($self, $transaction, $host) = @_; # $host: the name the client sent in the # (EH|HE)LO line B C<$transaction> is C at this point. =head2 hook_mail_pre After the B line sent by the client is broken into pieces by the C, this hook recieves the results. This hook may be used to pre-accept adresses without the surrounding IE> (by adding them) or addresses like Iuser@example.com.E> or Iuser@example.com E> by removing the trailing I<"."> / C<" ">. Expected return values are I and an address which must be parseable by Cparse()> on success or any other constant to indicate failure. Arguments are my ($self, $transaction, $addr) = @_; =head2 hook_mail Called right after the envelope sender line is parsed (the B command). The plugin gets passed a C object, which means the parsing and verifying the syntax of the address (and just the syntax, no other checks) is already done. Default is to allow the sender address. The remaining arguments are the extensions defined in RFC 1869 (if sent by the client). B According to the SMTP protocol, you can not reject an invalid sender until after the B stage (except for protocol errors, i.e. syntax errors in address). So store it in an C<$transaction-Enote()> and process it later in an rcpt hook. Allowed return codes are =over 4 =item OK sender allowed =item DENY Return a hard failure code =item DENYSOFT Return a soft failure code =item DENY_DISCONNECT / DENYSOFT_DISCONNECT as above but with disconnect =item DECLINED next plugin (if any) =item DONE skip further processing, plugin sent response =back Arguments for this hook are my ($self,$transaction, $sender, %args) = @_; # $sender: an Qpsmtpd::Address object for # sender of the message Example plugins for the C are F and F. =head2 hook_rcpt_pre See C, s/MAIL FROM:/RCPT TO:/. =head2 hook_rcpt This hook is called after the client sent an I command (after parsing the line). The given argument is parsed by C, then this hook is called. Default is to deny the mail with a soft error code. The remaining arguments are the extensions defined in RFC 1869 (if sent by the client). Allowed return codes =over 4 =item OK recipient allowed =item DENY Return a hard failure code, for example for an I message. =item DENYSOFT Return a soft failure code, for example if the connect to a user lookup database failed =item DENY_DISCONNECT / DENYSOFT_DISCONNECT as above but with disconnect =item DONE skip further processing, plugin sent response =back Arguments are my ($self, $transaction, $recipient, %args) = @_; # $rcpt = Qpsmtpd::Address object with # the given recipient address Example plugin is F. =head2 hook_data After the client sent the B command, before any data of the message was sent, this hook is called. B This hook, like B, B, B, B, is an endpoint of a pipelined command group (see RFC 1854) and may be used to detect ``early talkers''. Since svn revision 758 the F plugin may be configured to check at this hook for ``early talkers''. Allowed return codes are =over 4 =item DENY Return a hard failure code =item DENYSOFT Return a soft failure code =item DENY_DISCONNECT / DENYSOFT_DISCONNECT as above but with disconnect =item DONE Plugin took care of receiving data and calling the queue (not recommended) B The only real use for I is implementing other ways of receiving the message, than the default... for example the CHUNKING SMTP extension (RFC 1869, 1830/3030) ... a plugin for this exists at http://svn.perl.org/qpsmtpd/contrib/vetinari/experimental/chunking, but it was never tested ``in the wild''. =back Arguments: my ($self, $transaction) = @_; Example plugin is F. =head2 hook_received_line If you wish to provide your own Received header line, do it here. You can use or discard any of the given arguments (see below). Allowed return codes: =over 4 =item OK, $string use this string for the Received header. =item anything else use the default Received header =back Arguments are my ($self, $transaction, $smtp, $auth, $sslinfo) = @_; # $smtp - the SMTP type used (e.g. "SMTP" or "ESMTP"). # $auth - the Auth header additionals. # $sslinfo - information about SSL for the header. =head2 data_headers_end This hook fires after all header lines of the message data has been received. Defaults to doing nothing, just continue processing. At this step, the sender is not waiting for a reply, but we can try and prevent him from sending the entire message by disconnecting immediately. (Although it is likely the packets are already in flight due to buffering and pipelining). B BE CAREFUL! If you drop the connection legal MTAs will retry again and again, spammers will probably not. This is not RFC compliant and can lead to an unpredictable mess. Use with caution. B This hook does not currently work in async mode. Why this hook may be useful for you, see L, ff. Allowed return codes: =over 4 =item DENY_DISCONNECT Return B<554 Message denied> and disconnect =item DENYSOFT_DISCONNECT Return B<421 Message denied temporarily> and disconnect =item DECLINED Do nothing =back Arguments: my ($self, $transaction) = @_; B check arguments =head2 hook_data_post The C hook is called after the client sent the final C<.\r\n> of a message, before the mail is sent to the queue. Allowed return codes are =over 4 =item DENY Return a hard failure code =item DENYSOFT Return a soft failure code =item DENY_DISCONNECT / DENYSOFT_DISCONNECT as above but with disconnect =item DONE skip further processing (message will not be queued), plugin gave the response. B just returning I from a special queue plugin does (nearly) the same (i.e. dropping the mail to F) and you don't have to send the response on your own. If you want the mail to be queued, you have to queue it manually! =back Arguments: my ($self, $transaction) = @_; Example plugins: F, F =head2 hook_queue_pre This hook is run, just before the mail is queued to the ``backend''. You may modify the in-process transaction object (e.g. adding headers) or add something like a footer to the mail (the latter is not recommended). Allowed return codes are =over 4 =item DONE no queuing is done =item OK / DECLINED queue the mail =back =head2 hook_queue When all C hooks accepted the message, this hook is called. It is used to queue the message to the ``backend''. Allowed return codes: =over 4 =item DONE skip further processing (plugin gave response code) =item OK Return success message, i.e. tell the client the message was queued (this may be used to drop the message silently). =item DENY Return hard failure code =item DENYSOFT Return soft failure code, i.e. if disk full or other temporary queuing problems =back Arguments: my ($self, $transaction) = @_; Example plugins: all F plugins =head2 hook_queue_post This hook is called always after C. If the return code is B I, a message (all remaining return values) with level I is written to the log. Arguments are my $self = shift; B C<$transaction> is not valid at this point, therefore not mentioned. =head2 hook_reset_transaction This hook will be called several times. At the beginning of a transaction (i.e. when the client sends a B command the first time), after queueing the mail and every time a client sends a B command. Arguments are my ($self, $transaction) = @_; B don't rely on C<$transaction> being valid at this point. =head2 hook_quit After the client sent a B command, this hook is called (before the C). Allowed return codes =over 4 =item DONE plugin sent response =item DECLINED next plugin and / or qpsmtpd sends response =back Arguments: the only argument is C<$self> =cut ### XXX: FIXME pass the rest of the line to this hook? =pod Expample plugin is the F plugin. =head2 hook_disconnect This hook will be called from several places: After a plugin returned I, before connection is disconnected or after the client sent the B command, AFTER the quit hook and ONLY if no plugin hooking C returned I. All return values are ignored, arguments are just C<$self> Example plugin is F =head2 hook_post_connection This is the counter part of the C hook, it is called directly before the connection is finished, for example, just before the qpsmtpd-forkserver instance exits or if the client drops the connection without notice (without a B). This hook is not called if the qpsmtpd instance is killed. =cut FIXME: we should run this hook on a ``SIGHUP'' or some other signal? =pod The only argument is C<$self> and all return codes are ignored, it would be too late anyway :-). Example: F =head1 Parsing Hooks Before the line from the client is parsed by Cparse()> with the built in parser, these hooks are called. They can be used to supply a parsing function for the line, which will be used instead of the built in parser. The hook must return two arguments, the first is (currently) ignored, the second argument must be a (CODE) reference to a sub routine. This sub routine receives three arguments: =over 4 =item $self the plugin object =item $cmd the command (i.e. the first word of the line) sent by the client =item $line the line sent by the client without the first word =back Expected return values from this sub are I and a reason which is sent to the client or I and the C<$line> broken into pieces according to the syntax rules for the command. B, the C hook was never implemented,...> =head2 hook_helo_parse / hook_ehlo_parse The provided sub routine must return two or more values. The first is discarded, the second is the hostname (sent by the client as argument to the B / B command). All other values are passed to the helo / ehlo hook. This hook may be used to change the hostname the client sent... not recommended, but if your local policy says only to accept I hosts with FQDNs and you have a legal client which can not be changed to send his FQDN, this is the right place. =head2 hook_mail_parse / hook_rcpt_parse The provided sub routine must return two or more values. The first is either I to indicate that parsing of the line was successfull or anything else to bail out with I<501 Syntax error in command>. In case of failure the second argument is used as the error message for the client. If parsing was successfull, the second argument is the sender's / recipient's address (this may be without the surrounding I> and I>, don't add them here, use the C / C methods for this). All other arguments are sent to the C hook as B / B parameters (see RFC 1869 I for more info). Note that the mail and rcpt hooks expect a list of key/value pairs as the last arguments. =head2 hook_auth_parse B =head1 Special hooks Now some special hooks follow. Some of these hooks are some internal hooks, which may be used to alter the logging or retrieving config values from other sources (other than flat files) like SQL databases. =head2 hook_logging This hook is called when a log message is written, for example in a plugin it fires if someone calls C<$self-Elog($level, $msg);>. Allowed return codes are =over 4 =item DECLINED next logging plugin =item OK (not I, as some might expect!) ok, plugin logged the message =back Arguments are my ($self, $transaction, $trace, $hook, $plugin, @log) = @_; # $trace: level of message, for example # LOGWARN, LOGDEBUG, ... # $hook: the hook in/for which this logging # was called # $plugin: the plugin calling this hook # @log: the log message B C<$transaction> may be C, depending when / where this hook is called. It's probably best not to try acessing it. All F plugins can be used as example plugins. =head2 hook_deny This hook is called after a plugin returned I, I, I or I. All return codes are ignored, arguments are my ($self, $transaction, $prev_plugin, $return, $return_text) = @_; B C<$transaction> may be C, depending when / where this hook is called. It's probably best not to try acessing it. Example plugin for this hook is F. =head2 hook_ok The counter part of C, it is called after a plugin B return I, I, I or I. All return codes are ignored, arguments are my ( $self, $transaction, $prev_plugin, $return, $return_text ) = @_; B C<$transaction> may be C, depending when / where this hook is called. It's probably best not to try acessing it. =head2 hook_config Called when a config file is requested, for example in a plugin it fires if someone calls Cqp-Econfig($cfg_name);>. Allowed return codes are =over 4 =item DECLINED plugin didn't find the requested value =item OK requested values as C<@list>, example: return (OK, @{$config{$value}}) if exists $config{$value}; return (DECLINED); =back Arguments: my ($self,$transaction,$value) = @_; # $value: the requested config item(s) B C<$transaction> may be C, depending when / where this hook is called. It's probably best not to try acessing it. Example plugin is F from the qpsmtpd distribution. =head2 hook_unrecognized_command This is called if the client sent a command unknown to the core of qpsmtpd. This can be used to implement new SMTP commands or just count the number of unknown commands from the client, see below for examples. Allowed return codes: =over 4 =item DENY_DISCONNECT Return B<521> and disconnect the client =item DENY Return B<500> =item DONE Qpsmtpd wont do anything; the plugin responded, this is what you want to return, if you are implementing new commands =item Anything else... Return B<500 Unrecognized command> =back Arguments: my ($self, $transaction, $cmd, @args) = @_; # $cmd = the first "word" of the line # sent by the client # @args = all the other "words" of the # line sent by the client # "word(s)": white space split() line B C<$transaction> may be C, depending when / where this hook is called. It's probably best not to try acessing it. Example plugin is F. =head2 hook_help This hook triggers if a client sends the B command, allowed return codes are: =over 4 =item DONE Plugin gave the answer. =item DENY The client will get a C message, probably not what you want, better use $self->qp->respond(502, "Not implemented."); return DONE; =back Anything else will be send as help answer. Arguments are my ($self, $transaction, @args) = @_; with C<@args> being the arguments from the client's command. =head2 hook_vrfy If the client sents the B command, this hook is called. Default is to return a message telling the user to just try sending the message. Allowed return codes: =over 4 =item OK Recipient Exists =item DENY Return a hard failure code =item DONE Return nothing and move on =item Anything Else... Return a B<252> =back Arguments are: my ($self) = shift; =cut FIXME: this sould be changed in Qpsmtpd::SMTP to pass the rest of the line as arguments to the hook =pod =head2 hook_noop If the client sents the B command, this hook is called. Default is to return C<250 OK>. Allowed return codes are: =over 4 =item DONE Plugin gave the answer =item DENY_DISCONNECT Return error code and disconnect client =item DENY Return error code. =item Anything Else... Give the default answer of B<250 OK>. =back Arguments are my ($self,$transaction,@args) = @_; =head2 hook_post_fork B This hook is only available in qpsmtpd-async. It is called while starting qpsmtpd-async. You can run more than one instance of qpsmtpd-async (one per CPU probably). This hook is called after forking one instance. Arguments: my $self = shift; The return values of this hook are discarded. =head1 Authentication hooks =cut B auth_parse #=head2 auth B #=head2 auth-plain B #=head2 auth-login B #=head2 auth-cram-md5 B =pod See F. =cut # vim: ts=2 sw=2 expandtab qpsmtpd-0.84/docs/logging.pod000644 000765 000024 00000005435 11165321461 016147 0ustar00askstaff000000 000000 # # 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 and L 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 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 hook in order to retrieve that information before it is discarded when the transaction is closed (see the L 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) 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. =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. See L 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 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, there may be additional terms passed between C<$self> and C<$transaction>. See L for and example. qpsmtpd-0.84/docs/plugins.pod000644 000765 000024 00000031651 11211430037 016171 0ustar00askstaff000000 000000 # # This file is best read with ``perldoc plugins.pod'' # ### # Conventions: # plugin names: F, F # constants: I # smtp commands, answers: B, B<250 Queued!> # # Notes: # * due to restrictions of some POD parsers, no C<<$object->method()>> # are allowed, use C<$object-Emethod()> # =head1 Introduction Plugins are the heart of qpsmtpd. The core implements only basic SMTP protocol functionality. No useful function can be done by qpsmtpd without loading plugins. Plugins are loaded on startup where each of them register their interest in various I provided by the qpsmtpd core engine. At least one plugin B allow or deny the B command to enable receiving mail. The F plugin is the standard plugin for this. Other plugins provide extra functionality related to this; for example the F plugin. =head2 Loading Plugins The list of plugins to load are configured in the I configuration file. One plugin per line, empty lines and lines starting with I<#> are ignored. The order they are loaded is the same as given in this config file. This is also the order the registered I are run. The plugins are loaded from the F directory or from a subdirectory of it. If a plugin should be loaded from such a subdirectory, the directory must also be given, like the F in the example below. Alternate plugin directories may be given in the F config file, one directory per line, these will be searched first before using the builtin fallback of F relative to the qpsmtpd root directory. It may be necessary, that the F must be used (if you're using F, for example). Some plugins may be configured by passing arguments in the F config file. A plugin can be loaded two or more times with different arguments by adding I<:N> to the plugin filename, with I being a number, usually starting at I<0>. Another method to load a plugin is to create a valid perl module, drop this module in perl's C<@INC> path and give the name of this module as plugin name. The only restriction to this is, that the module name B contain I<::>, e.g. C would be ok, C not. Appending of I<:0>, I<:1>, ... does not work with module plugins. check_relay virus/clamdscan spamassassin reject_threshold 7 my_rcpt_check example.com my_rcpt_check:0 example.org My::Plugin =head1 Anatomy of a plugin A plugin has at least one method, which inherits from the C object. The first argument for this method is always the plugin object itself (and usually called C<$self>). The most simple plugin has one method with a predefined name which just returns one constant. # plugin temp_disable_connection sub hook_connect { return(DENYSOFT, "Sorry, server is temporarily unavailable."); } While this is a valid plugin, it is not very useful except for rare circumstances. So let us see what happens when a plugin is loaded. =head2 Initialisation After the plugin is loaded the C method of the plugin is called, if present. The arguments passed to C are =over 4 =item $self the current plugin object, usually called C<$self> =item $qp the Qpsmtpd object, usually called C<$qp>. =item @args the values following the plugin name in the F config, split by white space. These arguments can be used to configure the plugin with default and/or static config settings, like database paths, timeouts, ... =back This is mainly used for inheriting from other plugins, but may be used to do the same as in C. The next step is to register the hooks the plugin provides. Any method which is named C is automagically added. Plugins should be written using standard named hook subroutines. This allows them to be overloaded and extended easily. Because some of the callback names have characters invalid in subroutine names , they must be translated. The current translation routine is C, see L for more info. If you choose not to use the default naming convention, you need to register the hooks in your plugin in the C method (see below) with the C call on the plugin object. sub register { my ($self, $qp, @args) = @_; $self->register_hook("mail", "mail_handler"); $self->register_hook("rcpt", "rcpt_handler"); } sub mail_handler { ... } sub rcpt_handler { ... } The C method is called last. It receives the same arguments as C. There is no restriction, what you can do in C, but creating database connections and reuse them later in the process may not be a good idea. This initialisation happens before any C is done. Therefore the file handle will be shared by all qpsmtpd processes and the database will probably be confused if several different queries arrive on the same file handle at the same time (and you may get the wrong answer, if any). This is also true for F and the pperl flavours, but not for F started by (x)inetd or tcpserver. In short: don't do it if you want to write portable plugins. =head2 Hook - Subroutine translations As mentioned above, the hook name needs to be translated to a valid perl C name. This is done like ($sub = $hook) =~ s/\W/_/g; $sub = "hook_$sub"; Some examples follow, for a complete list of available (documented ;-)) hooks (method names), use something like $ perl -lne 'print if s/^=head2\s+(hook_\S+)/$1/' docs/plugins.pod All valid hooks are defined in F, C. =head3 Translation table hook method ---------- ------------ config hook_config queue hook_queue data hook_data data_post hook_data_post quit hook_quit rcpt hook_rcpt mail hook_mail ehlo hook_ehlo helo hook_helo auth hook_auth auth-plain hook_auth_plain auth-login hook_auth_login auth-cram-md5 hook_auth_cram_md5 connect hook_connect reset_transaction hook_reset_transaction unrecognized_command hook_unrecognized_command =head2 Inheritance Inheriting methods from other plugins is an advanced topic. You can alter arguments for the underlying plugin, prepare something for the I plugin or skip a hook with this. Instead of modifying C<@ISA> directly in your plugin, use the C method from the C subroutine. # rcpt_ok_child sub init { my ($self, $qp, @args) = @_; $self->isa_plugin("rcpt_ok"); } sub hook_rcpt { my ($self, $transaction, $recipient) = @_; # do something special here... $self->SUPER::hook_rcpt($transaction, $recipient); } See also chapter C and F in SVN. =head2 Config files Most of the existing plugins fetch their configuration data from files in the F sub directory. This data is read at runtime and may be changed without restarting qpsmtpd. B<(FIXME: caching?!)> The contents of the files can be fetched via @lines = $self->qp->config("my_config"); All empty lines and lines starting with C<#> are ignored. If you don't want to read your data from files, but from a database you can still use this syntax and write another plugin hooking the C hook. =head2 Logging Log messages can be written to the log file (or STDERR if you use the F plugin) with $self->qp->log($loglevel, $logmessage); The log level is one of (from low to high priority) =over 4 =item * LOGDEBUG =item * LOGINFO =item * LOGNOTICE =item * LOGWARN =item * LOGERROR =item * LOGCRIT =item * LOGALERT =item * LOGEMERG =back While debugging your plugins, you want to set the log level in the F config file to I. This will log very much data. To restrict this output just to the plugin you are debugging, you can use the following plugin: =cut FIXME: Test if this really works as inteded ;-) =pod # logging/debug_plugin - just show LOGDEBUG messages of one plugin # Usage: # logging/debug_plugin my_plugin LOGLEVEL # # LOGLEVEL is the log level for all other log messages use Qpsmtpd::Constants; sub register { my ($self, $qp, $plugin, $loglevel) = @_; die "no plugin name given" unless $plugin; $loglevel = "LOGWARN" unless defined $loglevel; $self->{_plugin} = $plugin; $self->{_level} = Qpsmtpd::Constants::log_level($loglevel); $self->{_level} = LOGWARN unless defined $self->{_level}; } sub hook_logging { my ($self, $transaction, $trace, $hook, $plugin, @log) = @_; return(OK) # drop these lines if $plugin ne $self->{_plugin} and $trace > $self->{_level}; return(DECLINED); } The above plugin should be loaded before the default logging plugin, which logs with I. The plugin name must be the one returned by the C method of the debugged plugin. This is probably not the same as the name of the plugin (i.e. not the same you write in the F config file). In doubt: take a look in the log file for lines like C (here: F =E F). For more information about logging, see F. =head2 Information about the current plugin Each plugin inherits the public methods from C. =over 4 =item plugin_name() Returns the name of the currently running plugin =item hook_name() Returns the name of the running hook =item auth_user() Returns the name of the user the client is authed as (if authentication is used, of course) =item auth_mechanism() Returns the auth mechanism if authentication is used =item connection() Returns the C object associated with the current connection =item transaction() Returns the C object associated with the current transaction =back =head2 Temporary Files The temporary file and directory functions can be used for plugin specific workfiles and will automatically be deleted at the end of the current transaction. =over 4 =item temp_file() Returns a unique name of a file located in the default spool directory, but does not open that file (i.e. it is the name not a file handle). =item temp_dir() Returns the name of a unique directory located in the default spool directory, after creating the directory with 0700 rights. If you need a directory with different rights (say for an antivirus daemon), you will need to use the base function C<$self-Eqp-Etemp_dir()>, which takes a single parameter for the permissions requested (see L for details). A directory created like this will not be deleted when the transaction is ended. =item spool_dir() Returns the configured system-wide spool directory. =back =head2 Connection and Transaction Notes Both may be used to share notes across plugins and/or hooks. The only real difference is their life time. The connection notes start when a new connection is made and end, when the connection ends. This can, for example, be used to count the number of none SMTP commands. The plugin which uses this is the F plugin from the qpsmtpd core distribution. The transaction note starts after the B command and are just valid for the current transaction, see below in the I hook when the transaction ends. =head1 Return codes Each plugin must return an allowed constant for the hook and (usually) optionally a ``message'' for the client. Generally all plugins for a hook are processed until one returns something other than I. Plugins are run in the order they are listed in the F configuration file. The return constants are defined in C and have the following meanings: =over 4 =item DECLINED Plugin declined work; proceed as usual. This return code is I unless noted otherwise. =item OK Action allowed. =item DENY Action denied. =item DENYSOFT Action denied; return a temporary rejection code (say B<450> instead of B<550>). =item DENY_DISCONNECT Action denied; return a permanent rejection code and disconnect the client. Use this for "rude" clients. Note that you're not supposed to do this according to the SMTP specs, but bad clients don't listen sometimes. =item DENYSOFT_DISCONNECT Action denied; return a temporary rejection code and disconnect the client. See note above about SMTP specs. =item DONE Finishing processing of the request. Usually used when the plugin sent the response to the client. =item YIELD Only used in F, see F =back =cut # vim: ts=2 sw=2 expandtab qpsmtpd-0.84/docs/writing.pod000644 000765 000024 00000016772 11211430037 016202 0ustar00askstaff000000 000000 # # This file is best read with ``perldoc writing.pod'' # ### # Conventions: # plugin names: F, F # constants: I # smtp commands, answers: B, B<250 Queued!> # # Notes: # * due to restrictions of some POD parsers, no C<<$object->method()>> # are allowed, use C<$object-Emethod()> # =head1 Writing your own plugins This is a walk through a new queue plugin, which queues the mail to a (remote) QMQP-Server. First step is to pull in the necessary modules use IO::Socket; use Text::Netstring qw( netstring_encode netstring_decode netstring_verify netstring_read ); We know, we need a server to send the mails to. This will be the same for every mail, so we can use arguments to the plugin to configure this server (and port). Inserting this static config is done in C: sub register { my ($self, $qp, @args) = @_; die "No QMQP server specified in qmqp-forward config" unless @args; $self->{_qmqp_timeout} = 120; if ($args[0] =~ /^([\.\w_-]+)$/) { $self->{_qmqp_server} = $1; } else { die "Bad data in qmqp server: $args[0]"; } $self->{_qmqp_port} = 628; if (@args > 1 and $args[1] =~ /^(\d+)$/) { $self->{_qmqp_port} = $1; } $self->log(LOGWARN, "WARNING: Ignoring additional arguments.") if (@args > 2); } We're going to write a queue plugin, so we need to hook to the I hook. sub hook_queue { my ($self, $transaction) = @_; $self->log(LOGINFO, "forwarding to $self->{_qmqp_server}:" ."$self->{_qmqp_port}"); The first step is to open a connection to the remote server. my $sock = IO::Socket::INET->new( PeerAddr => $self->{_qmqp_server}, PeerPort => $self->{_qmqp_port}, Timeout => $self->{_qmqp_timeout}, Proto => 'tcp') or $self->log(LOGERROR, "Failed to connect to " ."$self->{_qmqp_server}:" ."$self->{_qmqp_port}: $!"), return(DECLINED); $sock->autoflush(1); =over 4 =item * The client starts with a safe 8-bit text message. It encodes the message as the byte string C. (The last line is usually, but not necessarily, empty.) The client then encodes this byte string as a netstring. The client also encodes the envelope sender address as a netstring, and encodes each envelope recipient address as a netstring. The client concatenates all these netstrings, encodes the concatenation as a netstring, and sends the result. (from L) =back The first idea is to build the package we send, in the order described in the paragraph above: my $message = $transaction->header->as_string; $transaction->body_resetpos; while (my $line = $transaction->body_getline) { $message .= $line; } $message = netstring_encode($message); $message .= netstring_encode($transaction->sender->address); for ($transaction->recipients) { push @rcpt, $_->address; } $message .= join "", netstring_encode(@rcpt); print $sock netstring_encode($message) or do { my $err = $!; $self->_disconnect($sock); return(DECLINED, "Failed to print to socket: $err"); }; This would mean, we have to hold the full message in memory... Not good for large messages, and probably even slower (for large messages). Luckily it's easy to build a netstring without the help of the C module if you know the size of the string (for more info about netstrings see L). We start with the sender and recipient addresses: my ($addrs, $headers, @rcpt); $addrs = netstring_encode($transaction->sender->address); for ($transaction->recipients) { push @rcpt, $_->address; } $addrs .= join "", netstring_encode(@rcpt); Ok, we got the sender and the recipients, now let's see what size the message is. $headers = $transaction->header->as_string; my $msglen = length($headers) + $transaction->body_length; We've got everything we need. Now build the netstrings for the full package and the message. First the beginning of the netstring of the full package # (+ 2: the ":" and "," of the message's netstring) print $sock ($msglen + length($msglen) + 2 + length($addrs)) .":" ."$msglen:$headers" ### beginning of messages netstring or do { my $err = $!; $self->_disconnect($sock); return(DECLINED, "Failed to print to socket: $err"); }; Go to beginning of the body $transaction->body_resetpos; If the message is spooled to disk, read the message in blocks and write them to the server if ($transaction->body_fh) { my $buff; my $size = read $transaction->body_fh, $buff, 4096; unless (defined $size) { my $err = $!; $self->_disconnect($sock); return(DECLINED, "Failed to read from body_fh: $err"); } while ($size) { print $sock $buff or do { my $err = $!; $self->_disconnect($sock); return(DECLINED, "Failed to print to socket: $err"); }; $size = read $transaction->body_fh, $buff, 4096; unless (defined $size) { my $err = $!; $self->_disconnect($sock); return(DECLINED, "Failed to read from body_fh: $err"); } } } Else we have to read it line by line ... else { while (my $line = $transaction->body_getline) { print $sock $line or do { my $err = $!; $self->_disconnect($sock); return(DECLINED, "Failed to print to socket: $err"); }; } } Message is at the server, now finish the package. print $sock "," # end of messages netstring .$addrs # sender + recpients ."," # end of netstring of # the full package or do { my $err = $!; $self->_disconnect($sock); return(DECLINED, "Failed to print to socket: $err"); }; We're done. Now let's see what the remote qmqpd says... =over 4 =item * (continued from L:) The server's response is a nonempty string of 8-bit bytes, encoded as a netstring. The first byte of the string is either K, Z, or D. K means that the message has been accepted for delivery to all envelope recipients. This is morally equivalent to the 250 response to DATA in SMTP; it is subject to the reliability requirements of RFC 1123, section 5.3.3. Z means temporary failure; the client should try again later. D means permanent failure. Note that there is only one response for the entire message; the server cannot accept some recipients while rejecting others. =back my $answer = netstring_read($sock); $self->_disconnect($sock); if (defined $answer and netstring_verify($answer)) { $answer = netstring_decode($answer); $answer =~ s/^K// and return(OK, "Queued! $answer"); $answer =~ s/^Z// and return(DENYSOFT, "Deferred: $answer"); $answer =~ s/^D// and return(DENY, "Denied: $answer"); } If this is the only F plugin, the client will get a 451 temp error: return(DECLINED, "Protocol error"); } sub _disconnect { my ($self,$sock) = @_; if (defined $sock) { eval { close $sock; }; undef $sock; } } =cut # vim: ts=2 sw=2 expandtab qpsmtpd-0.84/config.sample/badhelo000644 000765 000024 00000000144 11144617464 017133 0ustar00askstaff000000 000000 # these domains never uses their domain when greeting us, so reject transactions aol.com yahoo.com qpsmtpd-0.84/config.sample/badmailfrom000644 000765 000024 00000000306 11231107355 020000 0ustar00askstaff000000 000000 # This is a sample config file for badmailfrom # - single email address badmailexample@microsoft.com # - block and entire host, and provide a custom reason @www.yahoo.com yahoo never sends from wwwqpsmtpd-0.84/config.sample/badrcptto_patterns000644 000765 000024 00000000336 11165321461 021432 0ustar00askstaff000000 000000 # 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 qpsmtpd-0.84/config.sample/dnsbl_zones000644 000765 000024 00000000046 11165321461 020046 0ustar00askstaff000000 000000 spamsources.fabel.dk zen.spamhaus.org qpsmtpd-0.84/config.sample/flat_auth_pw000644 000765 000024 00000000064 11165321461 020203 0ustar00askstaff000000 000000 good@example.com:good_pass bad@example.com:bad_pass qpsmtpd-0.84/config.sample/invalid_resolvable_fromhost000644 000765 000024 00000000154 11165321461 023313 0ustar00askstaff000000 000000 # 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 qpsmtpd-0.84/config.sample/IP000644 000765 000024 00000000177 11144617464 016053 0ustar00askstaff000000 000000 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. qpsmtpd-0.84/config.sample/logging000644 000765 000024 00000000017 11165321461 017152 0ustar00askstaff000000 000000 logging/warn 9 qpsmtpd-0.84/config.sample/loglevel000644 000765 000024 00000000227 11165322277 017346 0ustar00askstaff000000 000000 # Log levels # LOGDEBUG = 7 # LOGINFO = 6 # LOGNOTICE = 5 # LOGWARN = 4 # LOGERROR = 3 # LOGCRIT = 2 # LOGALERT = 1 # LOGEMERG = 0 4 qpsmtpd-0.84/config.sample/plugins000644 000765 000024 00000003355 11165325762 017225 0ustar00askstaff000000 000000 # # 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 # enable to accept MAIL FROM:/RCPT TO: addresses without surrounding <> dont_require_anglebrackets # enable to reject MAIL FROM:/RCPT TO: parameters if client helo was HELO # (strict RFC 821)... this is not used in EHLO ... # parse_addr_withhelo quit_fortune check_earlytalker count_unrecognized_commands 4 check_relay require_resolvable_fromhost rhsbl dnsbl check_badmailfrom check_badrcptto check_spamhelo # sender_permitted_from auth/auth_flat_file auth/authdeny # 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 # You must enable a queue plugin - see the options in plugins/queue/ - for example: # queue to a maildir # queue/maildir /home/spamtrap/mail # queue the mail with qmail-queue # queue/qmail-queue # If you need to run the same plugin multiple times, you can do # something like the following # check_relay # check_relay:0 somearg # check_relay:1 someotherarg qpsmtpd-0.84/config.sample/rcpthosts000644 000765 000024 00000000012 11165321461 017550 0ustar00askstaff000000 000000 localhost qpsmtpd-0.84/config.sample/relayclients000644 000765 000024 00000000216 11165321461 020223 0ustar00askstaff000000 000000 # Format is IP, or IP part with trailing dot # e.g. "127.0.0.1", or "192.168." 127.0.0.1 # leading/trailing whitespace is ignored 192.168. qpsmtpd-0.84/config.sample/require_resolvable_fromhost000644 000765 000024 00000000057 11144617464 023353 0ustar00askstaff000000 000000 1 # use 0 to disable; anything else to enable.qpsmtpd-0.84/config.sample/rhsbl_zones000644 000765 000024 00000000157 11144617464 020071 0ustar00askstaff000000 000000 dsn.rfc-ignorant.org does not accept bounces. This violates RFC 821/2505/2821 http://www.rfc-ignorant.org/ qpsmtpd-0.84/config.sample/size_threshold000644 000765 000024 00000000240 11165321461 020550 0ustar00askstaff000000 000000 # 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 qpsmtpd-0.84/config.sample/tls_before_auth000644 000765 000024 00000000104 11165321461 020666 0ustar00askstaff000000 000000 # change the next line to 0 if you want to offer AUTH without TLS 1 qpsmtpd-0.84/config.sample/tls_ciphers000644 000765 000024 00000000263 11165321461 020046 0ustar00askstaff000000 000000 # Override default security using suitable string from available ciphers at # L # See plugins/tls for details. HIGH