From b00f4c7793dc067eef4a8460c98f5156bb4ba5fd Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 22 Jun 2012 05:38:01 -0400 Subject: [PATCH] initial import - based on my qpsmtpd fork which will merge into the main branch fairly easily --- .gitignore | 36 +- .perltidyrc | 16 + .travis.yml | 5 + CREDITS | 36 + Changes | 1001 +++++++++++++++++ LICENSE | 19 + MANIFEST | 160 +++ MANIFEST.SKIP | 32 + Makefile.PL | 38 + README | 205 ++++ README.plugins | 13 + STATUS | 77 ++ UPGRADING | 26 + config.sample/IP | 4 + config.sample/badhelo | 4 + config.sample/badmailfrom | 5 + config.sample/badrcptto | 9 + config.sample/badrcptto_patterns | 5 + config.sample/dnsbl_allow | 2 + config.sample/dnsbl_zones | 2 + config.sample/flat_auth_pw | 4 + config.sample/invalid_resolvable_fromhost | 6 + config.sample/logging | 23 + config.sample/loglevel | 12 + config.sample/norelayclients | 6 + config.sample/plugins | 94 ++ config.sample/rcpthosts | 1 + config.sample/relayclients | 6 + config.sample/require_resolvable_fromhost | 3 + config.sample/rhsbl_zones | 5 + config.sample/size_threshold | 3 + config.sample/smtpauth-checkpassword | 1 + config.sample/tls_before_auth | 2 + config.sample/tls_ciphers | 10 + docs/FAQ.pod | 47 + docs/advanced.pod | 93 ++ docs/authentication.pod | 258 +++++ docs/config.pod | 200 ++++ docs/development.pod | 143 +++ docs/hooks.pod | 915 +++++++++++++++ docs/logging.pod | 191 ++++ docs/plugins.pod | 401 +++++++ docs/writing.pod | 271 +++++ lib/Apache/Qpsmtpd.pm | 246 ++++ lib/Danga/Client.pm | 221 ++++ lib/Danga/TimeoutSocket.pm | 67 ++ lib/Qpsmtpd.pm | 630 +++++++++++ lib/Qpsmtpd/Address.pm | 362 ++++++ lib/Qpsmtpd/Auth.pm | 223 ++++ lib/Qpsmtpd/Command.pm | 171 +++ lib/Qpsmtpd/ConfigServer.pm | 287 +++++ lib/Qpsmtpd/Connection.pm | 228 ++++ lib/Qpsmtpd/Constants.pm | 110 ++ lib/Qpsmtpd/DSN.pm | 621 ++++++++++ lib/Qpsmtpd/Plugin.pm | 292 +++++ lib/Qpsmtpd/Plugin/Async/DNSBLBase.pm | 87 ++ lib/Qpsmtpd/PollServer.pm | 349 ++++++ lib/Qpsmtpd/Postfix.pm | 223 ++++ lib/Qpsmtpd/Postfix/Constants.pm | 86 ++ lib/Qpsmtpd/Postfix/pf2qp.pl | 115 ++ lib/Qpsmtpd/SMTP.pm | 854 ++++++++++++++ lib/Qpsmtpd/SMTP/Prefork.pm | 30 + lib/Qpsmtpd/TcpServer.pm | 194 ++++ lib/Qpsmtpd/TcpServer/Prefork.pm | 79 ++ lib/Qpsmtpd/Transaction.pm | 399 +++++++ lib/Qpsmtpd/Utils.pm | 15 + log/run | 5 + packaging/rpm/Makefile | 182 +++ packaging/rpm/PACKAGE | 1 + packaging/rpm/RELEASE | 1 + packaging/rpm/VERSION | 1 + packaging/rpm/files/README.selinux | 10 + packaging/rpm/files/in.qpsmtpd | 3 + packaging/rpm/files/qpsmtpd-forkserver.rc | 122 ++ .../rpm/files/qpsmtpd-forkserver.sysconfig | 3 + .../rpm/files/qpsmtpd-plugin-file_connection | 184 +++ packaging/rpm/files/qpsmtpd-xinetd | 19 + packaging/rpm/files/qpsmtpd.conf | 16 + packaging/rpm/qpsmtpd.spec.in | 335 ++++++ plugins/async/check_earlytalker | 134 +++ plugins/async/dns_whitelist_soft | 88 ++ plugins/async/dnsbl | 202 ++++ plugins/async/queue/smtp-forward | 400 +++++++ plugins/async/require_resolvable_fromhost | 181 +++ plugins/async/rhsbl | 92 ++ plugins/async/uribl | 142 +++ plugins/auth/auth_checkpassword | 192 ++++ plugins/auth/auth_cvm_unix_local | 130 +++ plugins/auth/auth_flat_file | 83 ++ plugins/auth/auth_ldap_bind | 197 ++++ plugins/auth/auth_vpopmail | 101 ++ plugins/auth/auth_vpopmail_sql | 156 +++ plugins/auth/auth_vpopmaild | 120 ++ plugins/auth/authdeny | 23 + plugins/check_badmailfrom | 159 +++ plugins/check_badmailfromto | 83 ++ plugins/check_badrcptto | 129 +++ plugins/check_badrcptto_patterns | 48 + plugins/check_basicheaders | 162 +++ plugins/check_bogus_bounce | 126 +++ plugins/check_earlytalker | 228 ++++ plugins/check_loop | 55 + plugins/check_spamhelo | 34 + plugins/connection_time | 79 ++ plugins/content_log | 25 + plugins/count_unrecognized_commands | 49 + plugins/dns_whitelist_soft | 158 +++ plugins/dnsbl | 343 ++++++ plugins/domainkeys | 166 +++ plugins/dont_require_anglebrackets | 40 + plugins/dspam | 545 +++++++++ plugins/greylisting | 552 +++++++++ plugins/headers | 181 +++ plugins/helo | 488 ++++++++ plugins/help | 142 +++ plugins/hosts_allow | 105 ++ plugins/http_config | 50 + plugins/ident/geoip | 312 +++++ plugins/ident/p0f | 363 ++++++ plugins/karma | 474 ++++++++ plugins/karma_tool | 250 ++++ plugins/logging/adaptive | 184 +++ plugins/logging/apache | 113 ++ plugins/logging/connection_id | 81 ++ plugins/logging/devnull | 7 + plugins/logging/file | 282 +++++ plugins/logging/syslog | 186 +++ plugins/logging/transaction_id | 80 ++ plugins/logging/warn | 76 ++ plugins/milter | 236 ++++ plugins/naughty | 161 +++ plugins/noop_counter | 62 + plugins/parse_addr_withhelo | 68 ++ plugins/queue/exim-bsmtp | 145 +++ plugins/queue/maildir | 214 ++++ plugins/queue/postfix-queue | 198 ++++ plugins/queue/qmail-queue | 115 ++ plugins/queue/smtp-forward | 70 ++ plugins/quit_fortune | 17 + plugins/random_error | 85 ++ plugins/rcpt_map | 189 ++++ plugins/rcpt_ok | 99 ++ plugins/rcpt_regexp | 98 ++ plugins/relay | 237 ++++ plugins/require_resolvable_fromhost | 318 ++++++ plugins/rhsbl | 176 +++ plugins/sender_permitted_from | 236 ++++ plugins/spamassassin | 471 ++++++++ plugins/tls | 327 ++++++ plugins/tls_cert | 147 +++ plugins/uribl | 514 +++++++++ plugins/virus/aveclient | 180 +++ plugins/virus/bitdefender | 132 +++ plugins/virus/clamav | 231 ++++ plugins/virus/clamdscan | 301 +++++ plugins/virus/hbedv | 158 +++ plugins/virus/kavscanner | 176 +++ plugins/virus/klez_filter | 34 + plugins/virus/sophie | 198 ++++ plugins/virus/uvscan | 134 +++ qpsmtpd | 38 + qpsmtpd-async | 431 +++++++ qpsmtpd-forkserver | 370 ++++++ qpsmtpd-prefork | 748 ++++++++++++ run | 38 + t/01-syntax.t | 41 + t/02-pod.t | 18 + t/Test/Qpsmtpd.pm | 118 ++ t/Test/Qpsmtpd/Plugin.pm | 94 ++ t/addresses.t | 41 + t/auth.t | 143 +++ t/config.t | 34 + t/config/badhelo | 4 + t/config/badrcptto | 9 + t/config/dnsbl_zones | 1 + t/config/flat_auth_pw | 2 + t/config/invalid_resolvable_fromhost | 6 + t/config/plugins | 94 ++ t/config/rcpthosts | 1 + t/config/relayclients | 5 + t/helo.t | 12 + t/misc.t | 29 + t/plugin_tests.t | 17 + t/plugin_tests/auth/auth_checkpassword | 44 + t/plugin_tests/auth/auth_flat_file | 27 + t/plugin_tests/auth/auth_vpopmail | 38 + t/plugin_tests/auth/auth_vpopmail_sql | 48 + t/plugin_tests/auth/auth_vpopmaild | 27 + t/plugin_tests/auth/authdeny | 14 + t/plugin_tests/auth/authnull | 14 + t/plugin_tests/check_badmailfrom | 104 ++ t/plugin_tests/check_badmailfromto | 36 + t/plugin_tests/check_badrcptto | 92 ++ t/plugin_tests/check_basicheaders | 112 ++ t/plugin_tests/check_earlytalker | 147 +++ t/plugin_tests/count_unrecognized_commands | 31 + t/plugin_tests/dnsbl | 90 ++ t/plugin_tests/dspam | 127 +++ t/plugin_tests/greylisting | 167 +++ t/plugin_tests/helo | 179 +++ t/plugin_tests/ident/geoip | 146 +++ t/plugin_tests/ident/p0f | 87 ++ t/plugin_tests/rcpt_ok | 104 ++ t/plugin_tests/relay | 81 ++ t/plugin_tests/require_resolvable_fromhost | 165 +++ t/plugin_tests/sender_permitted_from | 50 + t/plugin_tests/spamassassin | 202 ++++ t/plugin_tests/virus/clamdscan | 81 ++ t/qpsmtpd-address.t | 108 ++ t/rset.t | 13 + t/tempstuff.t | 27 + 211 files changed, 30127 insertions(+), 12 deletions(-) create mode 100644 .perltidyrc create mode 100644 .travis.yml create mode 100644 CREDITS create mode 100644 Changes create mode 100644 LICENSE create mode 100644 MANIFEST create mode 100644 MANIFEST.SKIP create mode 100644 Makefile.PL create mode 100644 README create mode 100644 README.plugins create mode 100644 STATUS create mode 100644 UPGRADING create mode 100644 config.sample/IP create mode 100644 config.sample/badhelo create mode 100644 config.sample/badmailfrom create mode 100644 config.sample/badrcptto create mode 100644 config.sample/badrcptto_patterns create mode 100644 config.sample/dnsbl_allow create mode 100644 config.sample/dnsbl_zones create mode 100644 config.sample/flat_auth_pw create mode 100644 config.sample/invalid_resolvable_fromhost create mode 100644 config.sample/logging create mode 100644 config.sample/loglevel create mode 100644 config.sample/norelayclients create mode 100644 config.sample/plugins create mode 100644 config.sample/rcpthosts create mode 100644 config.sample/relayclients create mode 100644 config.sample/require_resolvable_fromhost create mode 100644 config.sample/rhsbl_zones create mode 100644 config.sample/size_threshold create mode 100644 config.sample/smtpauth-checkpassword create mode 100644 config.sample/tls_before_auth create mode 100644 config.sample/tls_ciphers create mode 100644 docs/FAQ.pod create mode 100644 docs/advanced.pod create mode 100644 docs/authentication.pod create mode 100644 docs/config.pod create mode 100644 docs/development.pod create mode 100644 docs/hooks.pod create mode 100644 docs/logging.pod create mode 100644 docs/plugins.pod create mode 100644 docs/writing.pod create mode 100644 lib/Apache/Qpsmtpd.pm create mode 100644 lib/Danga/Client.pm create mode 100644 lib/Danga/TimeoutSocket.pm create mode 100644 lib/Qpsmtpd.pm create mode 100644 lib/Qpsmtpd/Address.pm create mode 100644 lib/Qpsmtpd/Auth.pm create mode 100644 lib/Qpsmtpd/Command.pm create mode 100644 lib/Qpsmtpd/ConfigServer.pm create mode 100644 lib/Qpsmtpd/Connection.pm create mode 100644 lib/Qpsmtpd/Constants.pm create mode 100644 lib/Qpsmtpd/DSN.pm create mode 100644 lib/Qpsmtpd/Plugin.pm create mode 100644 lib/Qpsmtpd/Plugin/Async/DNSBLBase.pm create mode 100644 lib/Qpsmtpd/PollServer.pm create mode 100644 lib/Qpsmtpd/Postfix.pm create mode 100644 lib/Qpsmtpd/Postfix/Constants.pm create mode 100755 lib/Qpsmtpd/Postfix/pf2qp.pl create mode 100644 lib/Qpsmtpd/SMTP.pm create mode 100644 lib/Qpsmtpd/SMTP/Prefork.pm create mode 100644 lib/Qpsmtpd/TcpServer.pm create mode 100644 lib/Qpsmtpd/TcpServer/Prefork.pm create mode 100644 lib/Qpsmtpd/Transaction.pm create mode 100644 lib/Qpsmtpd/Utils.pm create mode 100755 log/run create mode 100644 packaging/rpm/Makefile create mode 100644 packaging/rpm/PACKAGE create mode 100644 packaging/rpm/RELEASE create mode 100644 packaging/rpm/VERSION create mode 100644 packaging/rpm/files/README.selinux create mode 100755 packaging/rpm/files/in.qpsmtpd create mode 100755 packaging/rpm/files/qpsmtpd-forkserver.rc create mode 100644 packaging/rpm/files/qpsmtpd-forkserver.sysconfig create mode 100644 packaging/rpm/files/qpsmtpd-plugin-file_connection create mode 100644 packaging/rpm/files/qpsmtpd-xinetd create mode 100644 packaging/rpm/files/qpsmtpd.conf create mode 100644 packaging/rpm/qpsmtpd.spec.in create mode 100644 plugins/async/check_earlytalker create mode 100644 plugins/async/dns_whitelist_soft create mode 100644 plugins/async/dnsbl create mode 100644 plugins/async/queue/smtp-forward create mode 100644 plugins/async/require_resolvable_fromhost create mode 100644 plugins/async/rhsbl create mode 100644 plugins/async/uribl create mode 100644 plugins/auth/auth_checkpassword create mode 100644 plugins/auth/auth_cvm_unix_local create mode 100644 plugins/auth/auth_flat_file create mode 100644 plugins/auth/auth_ldap_bind create mode 100644 plugins/auth/auth_vpopmail create mode 100644 plugins/auth/auth_vpopmail_sql create mode 100644 plugins/auth/auth_vpopmaild create mode 100644 plugins/auth/authdeny create mode 100644 plugins/check_badmailfrom create mode 100644 plugins/check_badmailfromto create mode 100644 plugins/check_badrcptto create mode 100644 plugins/check_badrcptto_patterns create mode 100644 plugins/check_basicheaders create mode 100644 plugins/check_bogus_bounce create mode 100644 plugins/check_earlytalker create mode 100644 plugins/check_loop create mode 100644 plugins/check_spamhelo create mode 100644 plugins/connection_time create mode 100644 plugins/content_log create mode 100644 plugins/count_unrecognized_commands create mode 100644 plugins/dns_whitelist_soft create mode 100644 plugins/dnsbl create mode 100644 plugins/domainkeys create mode 100644 plugins/dont_require_anglebrackets create mode 100644 plugins/dspam create mode 100644 plugins/greylisting create mode 100644 plugins/headers create mode 100644 plugins/helo create mode 100644 plugins/help create mode 100644 plugins/hosts_allow create mode 100644 plugins/http_config create mode 100644 plugins/ident/geoip create mode 100644 plugins/ident/p0f create mode 100644 plugins/karma create mode 100755 plugins/karma_tool create mode 100644 plugins/logging/adaptive create mode 100644 plugins/logging/apache create mode 100644 plugins/logging/connection_id create mode 100644 plugins/logging/devnull create mode 100644 plugins/logging/file create mode 100644 plugins/logging/syslog create mode 100644 plugins/logging/transaction_id create mode 100644 plugins/logging/warn create mode 100644 plugins/milter create mode 100644 plugins/naughty create mode 100644 plugins/noop_counter create mode 100644 plugins/parse_addr_withhelo create mode 100644 plugins/queue/exim-bsmtp create mode 100644 plugins/queue/maildir create mode 100644 plugins/queue/postfix-queue create mode 100644 plugins/queue/qmail-queue create mode 100644 plugins/queue/smtp-forward create mode 100644 plugins/quit_fortune create mode 100644 plugins/random_error create mode 100644 plugins/rcpt_map create mode 100644 plugins/rcpt_ok create mode 100644 plugins/rcpt_regexp create mode 100644 plugins/relay create mode 100644 plugins/require_resolvable_fromhost create mode 100644 plugins/rhsbl create mode 100644 plugins/sender_permitted_from create mode 100644 plugins/spamassassin create mode 100644 plugins/tls create mode 100644 plugins/tls_cert create mode 100644 plugins/uribl create mode 100644 plugins/virus/aveclient create mode 100644 plugins/virus/bitdefender create mode 100644 plugins/virus/clamav create mode 100644 plugins/virus/clamdscan create mode 100644 plugins/virus/hbedv create mode 100644 plugins/virus/kavscanner create mode 100644 plugins/virus/klez_filter create mode 100644 plugins/virus/sophie create mode 100644 plugins/virus/uvscan create mode 100755 qpsmtpd create mode 100755 qpsmtpd-async create mode 100755 qpsmtpd-forkserver create mode 100755 qpsmtpd-prefork create mode 100755 run create mode 100644 t/01-syntax.t create mode 100644 t/02-pod.t create mode 100644 t/Test/Qpsmtpd.pm create mode 100644 t/Test/Qpsmtpd/Plugin.pm create mode 100644 t/addresses.t create mode 100644 t/auth.t create mode 100644 t/config.t create mode 100644 t/config/badhelo create mode 100644 t/config/badrcptto create mode 100644 t/config/dnsbl_zones create mode 100644 t/config/flat_auth_pw create mode 100644 t/config/invalid_resolvable_fromhost create mode 100644 t/config/plugins create mode 100644 t/config/rcpthosts create mode 100644 t/config/relayclients create mode 100644 t/helo.t create mode 100644 t/misc.t create mode 100644 t/plugin_tests.t create mode 100644 t/plugin_tests/auth/auth_checkpassword create mode 100644 t/plugin_tests/auth/auth_flat_file create mode 100644 t/plugin_tests/auth/auth_vpopmail create mode 100644 t/plugin_tests/auth/auth_vpopmail_sql create mode 100644 t/plugin_tests/auth/auth_vpopmaild create mode 100644 t/plugin_tests/auth/authdeny create mode 100644 t/plugin_tests/auth/authnull create mode 100644 t/plugin_tests/check_badmailfrom create mode 100644 t/plugin_tests/check_badmailfromto create mode 100644 t/plugin_tests/check_badrcptto create mode 100644 t/plugin_tests/check_basicheaders create mode 100644 t/plugin_tests/check_earlytalker create mode 100644 t/plugin_tests/count_unrecognized_commands create mode 100644 t/plugin_tests/dnsbl create mode 100644 t/plugin_tests/dspam create mode 100644 t/plugin_tests/greylisting create mode 100644 t/plugin_tests/helo create mode 100644 t/plugin_tests/ident/geoip create mode 100644 t/plugin_tests/ident/p0f create mode 100644 t/plugin_tests/rcpt_ok create mode 100644 t/plugin_tests/relay create mode 100644 t/plugin_tests/require_resolvable_fromhost create mode 100644 t/plugin_tests/sender_permitted_from create mode 100644 t/plugin_tests/spamassassin create mode 100644 t/plugin_tests/virus/clamdscan create mode 100644 t/qpsmtpd-address.t create mode 100644 t/rset.t create mode 100644 t/tempstuff.t diff --git a/.gitignore b/.gitignore index d3e79f9..7873acf 100644 --- a/.gitignore +++ b/.gitignore @@ -1,15 +1,27 @@ -blib/ -.build/ -_build/ -cover_db/ -inc/ -Build -Build.bat +/config +/config/ +/pm_to_blib +/blib/ + +# only ignore top-level Makefile; we need the one in packaging/rpm! +/Makefile +Makefile.[a-z]* + +# ignore file produced by rpm build process +/packaging/rpm/qpsmtpd.spec +packaging/rpm/build/ + +*~ +*.bak +denysoft_greylist.dbm +denysoft_greylist.dbm.lock +greylist.dbm +greylist.dbm.lock + +/cover_db/ .last_cover_stats -Makefile -Makefile.old + +*.tar.gz + MANIFEST.bak -META.yml -MYMETA.yml nytprof.out -pm_to_blib diff --git a/.perltidyrc b/.perltidyrc new file mode 100644 index 0000000..65b29f2 --- /dev/null +++ b/.perltidyrc @@ -0,0 +1,16 @@ + +-i=4 # 4 space indentation (we used to use 2; in the future we'll use 4) +-ci=2 # continuation indention + +-pt=2 # tight parens +-sbt=2 # tight square parens +-bt=2 # tight curly braces +-bbt=0 # open code block curly braces + +-lp # line up with parentheses +-cti=1 # align closing parens with opening parens ("closing token placement") + +# -nolq # don't outdent long quotes (not sure if we should enable this) + + + diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..d32947f --- /dev/null +++ b/.travis.yml @@ -0,0 +1,5 @@ +language: perl +perl: + - "5.14" + - "5.12" + - "5.10" diff --git a/CREDITS b/CREDITS new file mode 100644 index 0000000..7dd9ab7 --- /dev/null +++ b/CREDITS @@ -0,0 +1,36 @@ +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 version control logs and + mailing list archives. Thanks everyone! diff --git a/Changes b/Changes new file mode 100644 index 0000000..547bac5 --- /dev/null +++ b/Changes @@ -0,0 +1,1001 @@ + +Next Version + + check_basicheaders. New arguments available: past, future, reject, reject_type + + sender_permitted_from. see UPGRADING (Matt Simerson) + + dspam plugin added (Matt Simerson) + + p0f version 3 supported and new default. see UPGRADING (Matt Simerson) + + require_resolvable_fromhost ignores DNS search path (i.e. it expects fully resolved domains) (Robert Spier, Charlie Brady) + + new plugin auth_vpopmaild (Robin Bowes) + + new plugin auth_checkpassword (Matt Simerson) + + auth_vpopmail_sql: more flexible db config (Matt Simerson) + + new plugin check_bogus_bounce (Steve Kemp) + + clamav: added ClamAV version to the X-Virus-Checked header, + as well as noting "no virus found". (Matt Simerson) + + assorted documentation cleanups (Steve Kemp, Robert Spier) + + Revert "Spool body when $transaction->body_fh() is called" + +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. + + diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..4e5050c --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (C) 2001-2010 Ask Bjoern Hansen, Develooper LLC + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies +of the Software, and to permit persons to whom the Software is furnished to do +so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..ed6a279 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,160 @@ +.gitignore +Changes +config.sample/badhelo +config.sample/badmailfrom +config.sample/badrcptto_patterns +config.sample/dnsbl_zones +config.sample/flat_auth_pw +config.sample/invalid_resolvable_fromhost +config.sample/IP +config.sample/logging +config.sample/loglevel +config.sample/plugins +config.sample/rcpthosts +config.sample/relayclients +config.sample/require_resolvable_fromhost +config.sample/rhsbl_zones +config.sample/size_threshold +config.sample/tls_before_auth +config.sample/tls_ciphers +CREDITS +docs/advanced.pod +docs/authentication.pod +docs/config.pod +docs/development.pod +docs/hooks.pod +docs/logging.pod +docs/plugins.pod +docs/writing.pod +lib/Apache/Qpsmtpd.pm +lib/Danga/Client.pm +lib/Danga/TimeoutSocket.pm +lib/Qpsmtpd.pm +lib/Qpsmtpd/Address.pm +lib/Qpsmtpd/Auth.pm +lib/Qpsmtpd/Command.pm +lib/Qpsmtpd/ConfigServer.pm +lib/Qpsmtpd/Connection.pm +lib/Qpsmtpd/Constants.pm +lib/Qpsmtpd/DSN.pm +lib/Qpsmtpd/Plugin.pm +lib/Qpsmtpd/Plugin/Async/DNSBLBase.pm +lib/Qpsmtpd/PollServer.pm +lib/Qpsmtpd/Postfix.pm +lib/Qpsmtpd/Postfix/Constants.pm +lib/Qpsmtpd/Postfix/pf2qp.pl +lib/Qpsmtpd/SMTP.pm +lib/Qpsmtpd/SMTP/Prefork.pm +lib/Qpsmtpd/TcpServer.pm +lib/Qpsmtpd/TcpServer/Prefork.pm +lib/Qpsmtpd/Transaction.pm +lib/Qpsmtpd/Utils.pm +LICENSE +log/run +Makefile.PL +MANIFEST This list of files +MANIFEST.SKIP +META.yml Module meta-data (added by MakeMaker) +plugins/async/check_earlytalker +plugins/async/dns_whitelist_soft +plugins/async/dnsbl +plugins/async/queue/smtp-forward +plugins/async/require_resolvable_fromhost +plugins/async/rhsbl +plugins/async/uribl +plugins/auth/auth_checkpassword +plugins/auth/auth_cvm_unix_local +plugins/auth/auth_flat_file +plugins/auth/auth_ldap_bind +plugins/auth/auth_vpopmail +plugins/auth/auth_vpopmail_sql +plugins/auth/auth_vpopmaild +plugins/auth/authdeny +plugins/check_badmailfrom +plugins/check_badmailfromto +plugins/check_badrcptto +plugins/check_badrcptto_patterns +plugins/check_bogus_bounce +plugins/check_basicheaders +plugins/check_earlytalker +plugins/check_loop +plugins/relay +plugins/check_spamhelo +plugins/connection_time +plugins/content_log +plugins/count_unrecognized_commands +plugins/dns_whitelist_soft +plugins/dnsbl +plugins/domainkeys +plugins/dont_require_anglebrackets +plugins/greylisting +plugins/help +plugins/hosts_allow +plugins/http_config +plugins/ident/geoip +plugins/ident/p0f +plugins/logging/adaptive +plugins/logging/apache +plugins/logging/connection_id +plugins/logging/devnull +plugins/logging/file +plugins/logging/syslog +plugins/logging/transaction_id +plugins/logging/warn +plugins/milter +plugins/noop_counter +plugins/parse_addr_withhelo +plugins/queue/exim-bsmtp +plugins/queue/maildir +plugins/queue/postfix-queue +plugins/queue/qmail-queue +plugins/queue/smtp-forward +plugins/quit_fortune +plugins/random_error +plugins/rcpt_ok +plugins/rcpt_regexp +plugins/require_resolvable_fromhost +plugins/rhsbl +plugins/sender_permitted_from +plugins/spamassassin +plugins/tls +plugins/tls_cert +plugins/uribl +plugins/virus/aveclient +plugins/virus/bitdefender +plugins/virus/clamav +plugins/virus/clamdscan +plugins/virus/hbedv +plugins/virus/kavscanner +plugins/virus/klez_filter +plugins/virus/sophie +plugins/virus/uvscan +qpsmtpd +qpsmtpd-async +qpsmtpd-forkserver +qpsmtpd-prefork +README +README.plugins +run +STATUS +t/addresses.t +t/config.t +t/helo.t +t/misc.t +t/plugin_tests.t +t/plugin_tests/auth/auth_flat_file +t/plugin_tests/auth/auth_vpopmail +t/plugin_tests/auth/auth_vpopmail_sql +t/plugin_tests/auth/auth_vpopmaild +t/plugin_tests/auth/authdeny +t/plugin_tests/auth/authnull +t/plugin_tests/check_badrcptto +t/plugin_tests/greylisting +t/plugin_tests/dnsbl +t/plugin_tests/ident/geoip +t/plugin_tests/rcpt_ok +t/qpsmtpd-address.t +t/rset.t +t/tempstuff.t +t/Test/Qpsmtpd.pm +t/Test/Qpsmtpd/Plugin.pm diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP new file mode 100644 index 0000000..bc39413 --- /dev/null +++ b/MANIFEST.SKIP @@ -0,0 +1,32 @@ +CVS/.* +\.cvsignore$ +\.bak$ +\.sw[a-z]$ +\.tar$ +\.tgz$ +\.tar\.gz$ +\.o$ +\.xsi$ +\.bs$ +output/.* +\.# +^mess/ +^sqlite/ +^output/ +^tmp/ +^blib/ +^blibdirs$ +^Makefile$ +^Makefile\.[a-z]+$ +^pm_to_blib$ +~$ +^MANIFEST\.bak +^tv\.log$ +^MakeMaker-\d +\#$ +\B\.svn\b +^\.perltidyrc$ +^\.git/.* +^cover_db/ +\.(orig|rej)$ +packaging diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..3a40c1b --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,38 @@ +#!/usr/bin/perl -w + +use strict; +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'qpsmtpd', + VERSION_FROM => 'lib/Qpsmtpd.pm', + PREREQ_PM => { + 'Mail::Header' => 0, + 'MIME::Base64' => 0, + 'Net::DNS' => 0.39, + 'Data::Dumper' => 0, + 'File::Temp' => 0, + 'Time::HiRes' => 0, + 'Net::IP' => 0, + 'Date::Parse' => 0, + }, + ABSTRACT => 'Flexible smtpd daemon written in Perl', + AUTHOR => 'Ask Bjoern Hansen ', + 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 +] + +} diff --git a/README b/README new file mode 100644 index 0000000..baf18b9 --- /dev/null +++ b/README @@ -0,0 +1,205 @@ +# +# this file is best read with `perldoc README` +# + +=head1 NAME + +Qpsmtpd - qmail perl simple mail transfer protocol daemon + +web: + http://smtpd.develooper.com/ + +mailinglist: + qpsmtpd-subscribe@perl.org + + +=head1 DESCRIPTION + +What is Qpsmtpd? + +Qpsmtpd is an extensible SMTP engine written in Perl. No, make that +easily extensible! See plugins/quit_fortune for a very useful, er, +cute example. + +=head2 License + +Qpsmtpd is licensed under the MIT License; see the LICENSE file for +more information. + +=head2 What's new in this release? + +See the Changes file! :-) + + +=head1 Installation + +=head2 Required Perl Modules + +The following Perl modules are required: + Net::DNS + MIME::Base64 + Mail::Header (part of the MailTools distribution) + +If you use a version of Perl older than 5.8.0 you will also need + Data::Dumper + File::Temp + Time::HiRes + +The easiest way to install modules from CPAN is with the CPAN shell. +Run it with + + perl -MCPAN -e shell + +=head2 qpsmtpd installation + +Make a new user and a directory where you'll install qpsmtpd. I +usually use "smtpd" for the user and /home/smtpd/qpsmtpd/ for the +directory. + +Put the files there. If you install from git you can just do +run the following command in the /home/smtpd/ directory. + + git clone git://github.com/smtpd/qpsmtpd.git + +Beware that the master branch might be unstable and unsuitable for anything +but development, so you might want to get a specific release, for +example (after running git clone): + + git checkout -b local_branch v0.84 + +chmod o+t ~smtpd/qpsmtpd/ (or whatever directory you installed qpsmtpd +in) to make supervise start the log process. + +Edit the file config/IP and put the ip address you want to use for +qpsmtpd on the first line (or use 0 to bind to all interfaces). + +If you use the supervise tools, then you are practically done! +Just symlink /home/smtpd/qpsmtpd into your /services (or /var/services +or /var/svscan or whatever) directory. Remember to shutdown +qmail-smtpd if you are replacing it with qpsmtpd. + +If you don't use supervise, then you need to run the ./run script in +some other way. + +The smtpd user needs write access to ~smtpd/qpsmtpd/tmp/ but should +not need to write anywhere else. This directory can be configured +with the "spool_dir" configuration and permissions can be set with +"spool_perms". + +As per version 0.25 the distributed ./run script runs tcpserver with +the -R flag to disable identd lookups. Remove the -R flag if that's +not what you want. + + +=head2 Configuration + +Configuration files can go into either /var/qmail/control or into the +config subdirectory of the qpsmtpd installation. Configuration should +be compatible with qmail-smtpd making qpsmtpd a drop-in replacement. + +If qmail is installed in a nonstandard location you should set the +$QMAIL environment variable to that location in your "./run" file. + +If there is anything missing, then please send a patch (or just +information about what's missing) to the mailinglist or to +ask@develooper.com. + + +=head1 Better Performance + +For better performance we recommend using "qpsmtpd-forkserver" or +running qpsmtpd under Apache 2.x. If you need extremely high +concurrency and all your plugins are compatible, you might want to try +the "qpsmtpd-async" model. + +=head1 Plugins + +The qpsmtpd core only implements the SMTP protocol. No useful +function can be done by qpsmtpd without loading plugins. + +Plugins are loaded on startup where each of them register their +interest in various "hooks" provided by the qpsmtpd core engine. + +At least one plugin MUST allow or deny the RCPT command to enable +receiving mail. The "rcpt_ok" is one basic plugin that does +this. Other plugins provide extra functionality related to this; for +example the require_resolvable_fromhost plugin described above. + + +=head1 Configuration files + +All the files used by qmail-smtpd should be supported; so see the man +page for qmail-smtpd. Extra files used by qpsmtpd include: + +=over 4 + +=item plugins + +List of plugins, one per line, to be loaded in the order they +appear in the file. Plugins are in the plugins directory (or in +a subdirectory of there). + + +=item rhsbl_zones + +Right hand side blocking lists, one per line. For example: + + dsn.rfc-ignorant.org does not accept bounces - http://www.rfc-ignorant.org/ + +See http://www.rfc-ignorant.org/ for more examples. + + +=item dnsbl_zones + +Normal ip based DNS blocking lists ("RBLs"). For example: + + relays.ordb.org + spamsources.fabel.dk + + +=item require_resolvable_fromhost + +If this file contains anything but a 0 on the first line, envelope +senders will be checked against DNS. If an A or a MX record can't be +found the mail command will return a soft rejection (450). + +=item spool_dir + +If this file contains a directory, it will be the spool directory +smtpd uses during the data transactions. If this file doesn't exist, it +will default to use $ENV{HOME}/tmp/. This directory should be set with +a mode of 700 and owned by the smtpd user. + +=item spool_perms + +The default spool permissions are 0700. If you need some other value, +chmod the directory and set it's octal value in config/spool_perms. + +=item tls_before_auth + +If this file contains anything except a 0 on the first noncomment line, then +AUTH will not be offered unless TLS/SSL are in place, either with STARTTLS, +or SMTP-SSL on port 465. + +=item everything (?) that qmail-smtpd supports. + +In my test qpsmtpd installation I have a "config/me" file containing +the hostname I use for testing qpsmtpd (so it doesn't introduce itself +with the normal name of the server). + +=back + + +=head1 Problems + +In case of problems, always check the logfile first. + +By default, qpsmtpd logs to log/main/current. Qpsmtpd can log a lot of +debug information. You can get more or less by adjusting the number in +config/loglevel. Between 1 and 3 should give you a little. Setting it +to 10 or higher will get lots of information in the logs. + +If the logfile doesn't give away the problem, then post to the +mailinglist (subscription instructions above). If possible, put +the logfile on a webserver and include a reference to it in the mail. + diff --git a/README.plugins b/README.plugins new file mode 100644 index 0000000..eb02b33 --- /dev/null +++ b/README.plugins @@ -0,0 +1,13 @@ +# +# 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 + diff --git a/STATUS b/STATUS new file mode 100644 index 0000000..78ef005 --- /dev/null +++ b/STATUS @@ -0,0 +1,77 @@ + +New Name Suggestions +==================== +ignite +flare(mta) +quench +pez (or pezmail) + + +Roadmap +======= + + - http://code.google.com/p/smtpd/issues + + - Bugfixes - qpsmtpd is extremely stable (in production since 2001), but + there are always more things to fix. + + - Add user configuration plugin infrastructure + - Add plugin API for checking if a local email address is valid + + - Add API to reject individual recipients after the RCPT has been + accepted and generate individual bounce messages. + +Issues +====== + +See http://code.google.com/p/smtpd/issues/list + +------ The rest of the list here might be outdated. ------ +------ Patches to remove things are welcome. ------ + + +add whitelist support to the dnsbl plugin (and maybe to the rhsbl +plugin too). Preferably both supporting DNS based whitelists and +filebased (CDB) ones. + + +plugin support; + + allow plugins to return multiple response lines (does it have to + join them to one for SMTP?) + + support plugins for the rest of the commands. + + specify a priority in register_hook. ("LAST", "FIRST", "MIDDLE", or + maybe a number) + + plugin access to the data line by line during the DATA phase + (instead of just after) + + if qmail-queue can't be loaded we still return 250 ?! + +Make a system for configuring the plugins per user/domain/... + + support databytes per user / domain + +localiphost - support foo@[a.b.c.d] addresses + +Move dispatch() etc from SMTP.pm to Qpsmtpd.pm to allow other similar +protocols to use the qpsmtpd framework. + + + +Future Ideas +============ + +Methods to create a bounce message easily; partly so we can accept a +mail for one user but bounce it right away for another RCPT'er. + +The data_post hook should be able to put in the notes what addresses +should go through, bounce and get rejected respectively, and qpsmtpd +should just do the right thing. See also +http://nntp.perl.org/group/perl.qpsmtpd/170 + +David Carraway has some thoughts for "user filters" +http://nntp.perl.org/group/perl.qpsmtpd/2 + diff --git a/UPGRADING b/UPGRADING new file mode 100644 index 0000000..7a3b478 --- /dev/null +++ b/UPGRADING @@ -0,0 +1,26 @@ + +When upgrading from: + +v 0.84 or below + +CHECK_RELAY, CHECK_NORELAY, RELAY_ONLY + + All 3 plugins are deprecated and replaced with a new 'relay' plugin. The new plugin reads the same config files (see 'perldoc plugins/relay') as the previous plugins. To get the equivalent functionality of enabling 'relay_only', use the 'only' argument to the relay plugin as documented in the RELAY ONLY section of plugins/relay. + +GREYLISTING plugin: + + 'mode' config argument is deprecated. Use reject and reject_type instead. + + The greylisting DB format has changed to accommodate IPv6 addresses. (The DB key has colon ':' seperated fields, and IPv6 addresses are colon delimited). The new format converts the IPs into integers. There is a new config option named 'upgrade' that when enabled, updates all the records in your DB to the new format. Simply add 'upgrade 1' to the plugin entry in config/plugins, start up qpsmtpd once, make one connection. A log entry will be made, telling how many records were upgraded. Remove the upgrade option from your config. + +SPF plugin: + + spf_deny setting deprecated. Use reject N setting instead, which provides administrators with more granular control over SPF. For backward compatibility, a spf_deny setting of 1 is mapped to 'reject 3' and a 'spf_deny 2' is mapped to 'reject 4'. + + +P0F plugin: + defaults to p0f v3 (was v2). + + Upgrade p0f to version 3 or add 'version 2' to your p0f line in config/plugins. perldoc plugins/ident/p0f for more details. + + diff --git a/config.sample/IP b/config.sample/IP new file mode 100644 index 0000000..1c9ec7c --- /dev/null +++ b/config.sample/IP @@ -0,0 +1,4 @@ +0 +# the first line of this file is being used as the IP +# address tcpserver will bind to. Use 0 to bind to all +# interfaces. diff --git a/config.sample/badhelo b/config.sample/badhelo new file mode 100644 index 0000000..a13ebfa --- /dev/null +++ b/config.sample/badhelo @@ -0,0 +1,4 @@ +# these domains never uses their domain when greeting us, so reject transactions +aol.com +yahoo.com + diff --git a/config.sample/badmailfrom b/config.sample/badmailfrom new file mode 100644 index 0000000..61114a0 --- /dev/null +++ b/config.sample/badmailfrom @@ -0,0 +1,5 @@ +# This is a sample config file for badmailfrom +# - single email address +badmailexample@microsoft.com +# - block and entire host, and provide a custom reason +@www.yahoo.com yahoo never sends from www \ No newline at end of file diff --git a/config.sample/badrcptto b/config.sample/badrcptto new file mode 100644 index 0000000..a7f88ca --- /dev/null +++ b/config.sample/badrcptto @@ -0,0 +1,9 @@ +######## entries used for testing ### +bad@example.com +@bad.example.com +######## Example patterns ####### +# Format is pattern\s+Response +# Don't forget to anchor the pattern if required +! Sorry, bang paths not accepted here +@.*@ Sorry, multiple at signs not accepted here +% Sorry, percent hack not accepted here diff --git a/config.sample/badrcptto_patterns b/config.sample/badrcptto_patterns new file mode 100644 index 0000000..e3bdca9 --- /dev/null +++ b/config.sample/badrcptto_patterns @@ -0,0 +1,5 @@ +# Format is pattern\s+Response +# Don't forget to anchor the pattern if required +! Sorry, bang paths not accepted here +@.*@ Sorry, multiple at signs not accepted here +% Sorry, percent hack not accepted here diff --git a/config.sample/dnsbl_allow b/config.sample/dnsbl_allow new file mode 100644 index 0000000..a9c72d5 --- /dev/null +++ b/config.sample/dnsbl_allow @@ -0,0 +1,2 @@ +# test entry for dnsbl plugin +192.168.99.5 diff --git a/config.sample/dnsbl_zones b/config.sample/dnsbl_zones new file mode 100644 index 0000000..15c4425 --- /dev/null +++ b/config.sample/dnsbl_zones @@ -0,0 +1,2 @@ +spamsources.fabel.dk +zen.spamhaus.org diff --git a/config.sample/flat_auth_pw b/config.sample/flat_auth_pw new file mode 100644 index 0000000..fcf3b3c --- /dev/null +++ b/config.sample/flat_auth_pw @@ -0,0 +1,4 @@ +# used by plugins/auth/auth_flat_file +# example entries +good@example.com:good_pass +bad@example.com:bad_pass diff --git a/config.sample/invalid_resolvable_fromhost b/config.sample/invalid_resolvable_fromhost new file mode 100644 index 0000000..db90eb8 --- /dev/null +++ b/config.sample/invalid_resolvable_fromhost @@ -0,0 +1,6 @@ +# include full network block including mask +127.0.0.0/8 +0.0.0.0/8 +224.0.0.0/4 +169.254.0.0/16 +10.0.0.0/8 diff --git a/config.sample/logging b/config.sample/logging new file mode 100644 index 0000000..a870643 --- /dev/null +++ b/config.sample/logging @@ -0,0 +1,23 @@ +# by default, qpsmtpd logs to STDERR at the level set in config/loglevel. +# +# In addition, qpsmtpd will log through any plugins enabled in this file. +# You can enable as many plugins as you wish. Example plugin invocations +# are included below. Just remove the # symbol to enable them. + +# default logging plugin +logging/warn 9 + +#logging/adaptive [accept minlevel] [reject maxlevel] [prefix char] +#logging/adaptive 4 6 + +# send logs to apache (useful if running qpsmtpd under apache) +#logging/apache + +# send logs to the great bit bucket +#logging/devnull + +# log to a file +#logging/file loglevel LOGINFO /var/log/qpsmtpd.log + +# log to syslog +#logging/syslog loglevel LOGWARN priority LOG_NOTICE diff --git a/config.sample/loglevel b/config.sample/loglevel new file mode 100644 index 0000000..e067bbd --- /dev/null +++ b/config.sample/loglevel @@ -0,0 +1,12 @@ +# Log levels +# LOGDEBUG = 7 +# LOGINFO = 6 +# LOGNOTICE = 5 +# LOGWARN = 4 +# LOGERROR = 3 +# LOGCRIT = 2 +# LOGALERT = 1 +# LOGEMERG = 0 +# +# This setting controls the built-in qpsmtpd logging. +4 diff --git a/config.sample/norelayclients b/config.sample/norelayclients new file mode 100644 index 0000000..1ac21a4 --- /dev/null +++ b/config.sample/norelayclients @@ -0,0 +1,6 @@ +# used by plugins/relay +# test entries - http://tools.ietf.org/html/rfc5737 +192.0.99.5 +192.0.99.6 +192.0.98. +# add your own entries below... diff --git a/config.sample/plugins b/config.sample/plugins new file mode 100644 index 0000000..e03310b --- /dev/null +++ b/config.sample/plugins @@ -0,0 +1,94 @@ +# +# Example configuration file for plugins +# + +# enable this to get configuration via http; see perldoc +# plugins/http_config for details. +# http_config http://localhost/~smtpd/config/ http://www.example.com/smtp.pl?config= + +# hosts_allow does not work with the tcpserver deployment model! +# perldoc plugins/hosts_allow for an alternative. +# +# The hosts_allow module must be loaded if you want the -m / --max-from-ip / +# my $MAXCONNIP = 5; # max simultaneous connections from one IP +# settings... without this it will NOT refuse more than $MAXCONNIP connections +# from one IP! +hosts_allow + +# information plugins +ident/geoip +#ident/p0f /tmp/.p0f_socket version 3 +#connection_time + +# enable to accept MAIL FROM:/RCPT TO: addresses without surrounding <> +dont_require_anglebrackets + +# enable to reject MAIL FROM:/RCPT TO: parameters if client helo was HELO +# (strict RFC 821)... this is not used in EHLO ... +# parse_addr_withhelo + +quit_fortune +# tls should load before count_unrecognized_commands +#tls +check_earlytalker +count_unrecognized_commands 4 +relay + +require_resolvable_fromhost + +rhsbl +dnsbl +check_badmailfrom +check_badrcptto +check_spamhelo + +# sender_permitted_from +# greylisting p0f genre,windows + +#auth/auth_checkpassword checkpw /usr/local/vpopmail/bin/vchkpw true /usr/bin/true +#auth/auth_vpopmail +#auth/auth_vpopmaild +#auth/auth_vpopmail_sql +auth/auth_flat_file +auth/authdeny + +# this plugin needs to run after all other "rcpt" plugins +rcpt_ok + +check_basicheaders days 5 reject_type temp +domainkeys + +# content filters +virus/klez_filter + + +# You can run the spamassassin plugin with options. See perldoc +# plugins/spamassassin for details. +# +spamassassin + +# rejects mails with a SA score higher than 20 and munges the subject +# of the score is higher than 10. +# +# spamassassin reject_threshold 20 munge_subject_threshold 10 + +# dspam must run after spamassassin for the learn_from_sa feature to work +dspam learn_from_sa 7 reject 1 + +# run the clamav virus checking plugin +# virus/clamav + +# You must enable a queue plugin - see the options in plugins/queue/ - for example: + +# queue to a maildir +# queue/maildir /home/spamtrap/mail + +# queue the mail with qmail-queue +# queue/qmail-queue + + +# If you need to run the same plugin multiple times, you can do +# something like the following +# relay +# relay:0 somearg +# relay:1 someotherarg diff --git a/config.sample/rcpthosts b/config.sample/rcpthosts new file mode 100644 index 0000000..2fbb50c --- /dev/null +++ b/config.sample/rcpthosts @@ -0,0 +1 @@ +localhost diff --git a/config.sample/relayclients b/config.sample/relayclients new file mode 100644 index 0000000..792c76b --- /dev/null +++ b/config.sample/relayclients @@ -0,0 +1,6 @@ +# used by plugins/relay +# Format is IP, or IP part with trailing dot +# e.g. "127.0.0.1", or "192.168." +127.0.0.1 +# leading/trailing whitespace is ignored + 192.0. diff --git a/config.sample/require_resolvable_fromhost b/config.sample/require_resolvable_fromhost new file mode 100644 index 0000000..ce052b5 --- /dev/null +++ b/config.sample/require_resolvable_fromhost @@ -0,0 +1,3 @@ +1 + +# use 0 to disable; anything else to enable. \ No newline at end of file diff --git a/config.sample/rhsbl_zones b/config.sample/rhsbl_zones new file mode 100644 index 0000000..5c5c73d --- /dev/null +++ b/config.sample/rhsbl_zones @@ -0,0 +1,5 @@ +dsn.rfc-ignorant.org does not accept bounces. This violates RFC 821/2505/2821 http://www.rfc-ignorant.org/ + + + + diff --git a/config.sample/size_threshold b/config.sample/size_threshold new file mode 100644 index 0000000..a6a1fb4 --- /dev/null +++ b/config.sample/size_threshold @@ -0,0 +1,3 @@ +# Messages below the size below will be stored in memory and not spooled. +# Without this file, the default is 0 bytes, i.e. all messages will be spooled. +10000 diff --git a/config.sample/smtpauth-checkpassword b/config.sample/smtpauth-checkpassword new file mode 100644 index 0000000..a029f3d --- /dev/null +++ b/config.sample/smtpauth-checkpassword @@ -0,0 +1 @@ +/usr/local/vpopmail/bin/vchkpw /bin/true diff --git a/config.sample/tls_before_auth b/config.sample/tls_before_auth new file mode 100644 index 0000000..d9084c2 --- /dev/null +++ b/config.sample/tls_before_auth @@ -0,0 +1,2 @@ +# change the next line to 0 if you want to offer AUTH without TLS +1 diff --git a/config.sample/tls_ciphers b/config.sample/tls_ciphers new file mode 100644 index 0000000..7bb0204 --- /dev/null +++ b/config.sample/tls_ciphers @@ -0,0 +1,10 @@ +# Override default security using suitable string from available ciphers at +# L +# See plugins/tls for details. +# +# HIGH is a reasonable default that should satisfy most installations +HIGH:!SSLv2 +# +# if you have legacy clients that require less secure connections, +# consider using this less secure, but PCI compliant setting: +#DEFAULT:!ADH:!LOW:!EXP:!SSLv2:+HIGH:+MEDIUM diff --git a/docs/FAQ.pod b/docs/FAQ.pod new file mode 100644 index 0000000..68e8806 --- /dev/null +++ b/docs/FAQ.pod @@ -0,0 +1,47 @@ +# best read with perldoc: perldoc FAQ.pod + +=head1 FAQ + +=head2 Q: Do I need to enable a logging plugin? + +=head2 A: No. + +When zero logging plugins are configured, logs are directed to STDERR. This +is the 'default' logging and logs are piped to multilog and stored in +log/main/current. + +When more than zero logging plugins are enabled, builtin logging is disabled +and logs are sent to every logging plugin configured in config/plugins. + + +=head2 Q: How do I watch the logs? + +=head2 A: Here's a few examples: + +The default log files can be watched in real time lik this: + + tail -F ~smtpd/log/main/current + +To convert the tai timestamps to human readable date time: + + tail -F ~smtpd/log/main/current | tai64nlocal + +To exclude the dates entirely, use this command: + + tail -F ~smtpd/smtpd/log/main/current | cut -d' ' -f2-3 + + +=head2 Q: How do I get alerts when qpsmtpd has a problem? + +=head2 A: Send logs with levels below LOGERROR to syslog. + +This can be done by adding the following lines to config/plugins: + + logging/syslog loglevel LOGERROR + logging/warn LOGINFO + +The warn logging plugin replicates the builtin logging, directing log messages to STDERR. The syslog plugin directs errors to syslog where standard monitoring tools can pick them up and act on them. + +With these settings, errors will still get sent to STDERR as well. + +=cut diff --git a/docs/advanced.pod b/docs/advanced.pod new file mode 100644 index 0000000..caa0d10 --- /dev/null +++ b/docs/advanced.pod @@ -0,0 +1,93 @@ +# +# 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->connection->notes('count_relay_attempts') || 0) + 1; + $self->connection->notes('count_relay_attempts', $count); + + return ($rc, @msg) unless ($count > $self->{_count_relay_max}); + return Qpsmtpd::DSN->relaying_denied(DENY_DISCONNECT, + "Too many relaying attempts"); + } + +=head2 Results of other hooks + +B 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 diff --git a/docs/authentication.pod b/docs/authentication.pod new file mode 100644 index 0000000..1cf7a35 --- /dev/null +++ b/docs/authentication.pod @@ -0,0 +1,258 @@ +# +# read this with 'perldoc authentication.pod' ... +# + +=head1 NAME + +Authentication framework for qpsmtpd + +=head1 DESCRIPTION + +Provides support for SMTP AUTH within qpsmtpd transactions, see + +L +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 VPOPMAIL + +There are 4 authentication (smtp-auth) plugins that can be used with +vpopmail. + +=over 4 + +=item auth_vpopmaild + +If you aren't sure which one to use, then use auth_vpopmaild. It +supports the PLAIN and LOGIN authentication methods, +doesn't require the qpsmtpd process to run with special permissions, and +can authenticate against vpopmail running on another host. It does require +the vpopmaild server to be running. + +=item auth_vpopmail + +The next best solution is auth_vpopmail. It requires the p5-vpopmail perl +module and it compiles against libvpopmail.a. There are two catches. The +qpsmtpd daemon must run as the vpopmail user, and you must be running v0.09 +or higher for CRAM-MD5 support. The released version is 0.08 but my +CRAM-MD5 patch has been added to the developers repo: + http://github.com/sscanlon/vpopmail + +=item auth_vpopmail_sql + +If you are using the MySQL backend for vpopmail, then this module can be +used for smtp-auth. It supports LOGIN, PLAIN, and CRAM-MD5. However, it +does not work with some vpopmail features such as alias domains, service +restrictions, nor does it update vpopmail's last_auth information. + +=item auth_checkpassword + +The auth_checkpassword is a generic authentication module that will work +with any DJB style checkpassword program, including ~vpopmail/bin/vchkpw. +It only supports PLAIN and LOGIN auth methods. + +=back + +=head1 AUTHOR + +John Peacock + +Matt Simerson (added VPOPMAIL) + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2004-2006 John Peacock + +Portions based on original code by Ask Bjoern Hansen and Guillaume Filion + +This plugin is licensed under the same terms as the qpsmtpd package itself. +Please see the LICENSE file included with qpsmtpd for details. + +=cut diff --git a/docs/config.pod b/docs/config.pod new file mode 100644 index 0000000..dd863cc --- /dev/null +++ b/docs/config.pod @@ -0,0 +1,200 @@ + +=head1 Qpsmtpd configuration + +The default way of setting config values is placing files with the +name of the config variable in the config directory F, 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 files + +=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 + +=head2 Plugin settings arguments + +These are arguments that can be set on the config/plugins line, after the name +of the plugin. These config options are available to all plugins. + +=over 4 + +=item loglevel + +Adjust the quantity of logging for the plugin. See docs/logging.pod + +=item reject + + plugin reject [ 0 | 1 | naughty ] + +Should the plugin reject mail? + +The special 'naughty' case will mark the connection as a naughty. Most plugins +skip processing naughty connections. Filtering plugins can learn from them. +Naughty connections are terminated up by the B plugin. + +Plugins that use $self->get_reject() or $self->get_reject_type() will +automatically honor this setting. + +=item reject_type + + plugin reject_type [ perm | temp | disconnect | temp_disconnect ] + +Default: perm + +Values with temp in the name return a 4xx code and the others return a 5xx +code. + +The I argument and the corresponding get_reject_type() method +provides a standard way for plugins to automatically return the selected +rejection type, as chosen by the config setting, the plugin author, or the +get_reject_type() method. + +Plugins that are updated to use the $self->get_reject() or +$self->get_reject_type() methods will automatically honor this setting. + +=back + +=cut + diff --git a/docs/development.pod b/docs/development.pod new file mode 100644 index 0000000..a77e00e --- /dev/null +++ b/docs/development.pod @@ -0,0 +1,143 @@ + +=head1 Developing Qpsmtpd + +=head2 Mailing List + +All qpsmtpd development happens on the qpsmtpd mailing list. + +Subscribe by sending mail to qpsmtpd-subscribe@perl.org + +=head2 Git + +We use git for version control. + +Ask owns the master repository at git://github.com/smtpd/qpsmtpd.git + +We suggest using github to host your repository -- it makes your +changes easily accessible for pulling into the master. After you +create a github account, go to +http://github.com/smtpd/qpsmtpd/tree/master and click on the "fork" +button to get your own repository. + +=head3 Making a working Copy + + git clone git@github.com:username/qpsmtpd.git qpsmtpd + +will check out your copy into a directory called qpsmtpd + +=head3 Making a branch for your change + +As a general rule, you'll be better off if you do your changes on a +branch - preferably a branch per unrelated change. + +You can use the C command to see which branch you are on. + +The easiest way to make a new branch is + + git checkout -b topic/my-great-change + +This will create a new branch with the name "topic/my-great-change" +(and your current commit as the starting point). + +=head3 Committing a change + +Edit the appropriate files, and be sure to run the test suite. + + emacs lib/Qpsmtpd.pm # for example + perl Makefile.PL + make test + +When you're ready to check it in... + + git add lib/Qpsmtpd.pm # to let git know you changed the file + git add --patch plugin/tls # interactive choose which changes to add + git diff --cached # review changes added + git commit # describe the commit + git log -p # review your commit a last time + git push origin # to send to github + +=head3 Commit Descriptions + +Though not required, it's a good idea to begin the commit message with +a single short (less than 50 character) line summarizing the change, +followed by a blank line and then a more thorough description. Tools +that turn commits into email, for example, use the first line on the +Subject: line and the rest of the commit in the body. +(From: L) + +=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 'smtpd' +for now, but you could call it anything you want. You only have to do +this once. + + git remote add smtpd git://github.com/smtpd/qpsmtpd.git + +Pull in data from all remote branches + + git remote update + +Forward-port local commits to the updated upstream head + + git rebase smtpd/master + +If you have a change that conflicts with an upstream change (git will +let you know) you have two options. + +Manually fix the conflict and then do + + git add some/file + git commit + +Or if the conflicting upstream commit did the same logical change then +you might want to just skip the local change: + + git rebase --skip + +Be sure to decide whether you're going to skip before you merge, or +you might get yourself into an odd situation. + +Conflicts happen because upstream committers may make minor tweaks to +your change before applying it. + +=head3 Throwing away changes + +If you get your working copy into a state you don't like, you can +always revert to the last commit: + + git reset --hard HEAD + +Or throw away your most recent commit: + + git reset --hard HEAD^ + +If you make a mistake with this, git is pretty good about keeping your +commits around even as you merge, rebase and reset away. This log of +your git changes is called with "git reflog". + +=head3 Applying other peoples changes + +If you get a change in an email with the patch, one easy way to apply +other peoples changes is to use C. 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". + diff --git a/docs/hooks.pod b/docs/hooks.pod new file mode 100644 index 0000000..182fa9c --- /dev/null +++ b/docs/hooks.pod @@ -0,0 +1,915 @@ +# +# 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 diff --git a/docs/logging.pod b/docs/logging.pod new file mode 100644 index 0000000..0066132 --- /dev/null +++ b/docs/logging.pod @@ -0,0 +1,191 @@ +# +# read this with 'perldoc docs/logging.pod' +# + +=head1 qpsmtpd logging; user documentation + +Qpsmtpd has a modular logging system. Here's a few things you need to know: + + * The built-in logging prints log messages to STDERR. + * A variety of logging plugins is included, each with its own behavior. + * When a logging plugin is enabled, the built-in logging is disabled. + * plugins/logging/warn mimics the built-in logging. + * Multiple logging plugins can be enabled simultaneously. + +Read the POD within each logging plugin (perldoc plugins/logging/B) +to learn if it tickles your fancy. + +=head2 enabling plugins + +To enable logging plugins, edit the file I and uncomment the +entries for the plugins you wish to use. + +=head2 logging level + +The 'master switch' for loglevel is I. Qpsmtpd and active +plugins will output all messages that are less than or equal to the value +specified. The log levels correspond to syslog levels: + + LOGDEBUG = 7 + LOGINFO = 6 + LOGNOTICE = 5 + LOGWARN = 4 + LOGERROR = 3 + LOGCRIT = 2 + LOGALERT = 1 + LOGEMERG = 0 + LOGRADAR = 0 + +Level 6, LOGINFO, is the level at which most servers should start logging. At +level 6, each plugin should log one and occasionally two entries that +summarize their activity. Here's a few sample lines: + + (connect) ident::geoip: SA, Saudi Arabia + (connect) ident::p0f: Windows 7 or 8 + (connect) earlytalker: pass: remote host said nothing spontaneous + (data_post) domainkeys: skip: unsigned + (data_post) spamassassin: pass, Spam, 21.7 < 100 + (data_post) dspam: fail: agree, Spam, 1.00 c + 552 we agree, no spam please (#5.6.1) + +Three plugins fired during the SMTP connection phase and 3 more ran during the +data_post phase. Each plugin emitted one entry stating their findings. + +If you aren't processing the logs, you can save some disk I/O by reducing the +loglevel, so that the only messages logged are ones that indicate a human +should be taking some corrective action. + +=head2 log location + +If qpsmtpd is started using the distributed run file (cd ~smtpd; ./run), then +you will see the log entries printed to your terminal. This solution works +great for initial setup and testing and is the simplest case. + +A typical way to run qpsmtpd is as a supervised process with daemontools. If +daemontools is already set up, setting up qpsmtpd may be as simple as: + +C + +If svcscan is running, the symlink will be detected and tcpserver will +run the 'run' files in the ./ and ./log directories. Any log entries +emitted will get handled per the instructions in log/run. The default +location specified in log/run is log/main/current. + +=head2 plugin loglevel + +Most plugins support a loglevel argument after their config/plugins entry. +The value can be a whole number (N) or a relative number (+/-N), where +N is a whole number from 0-7. See the descriptions of each below. + +C + +C + +ATTN plugin authors: To support loglevel in your plugin, you must store the +loglevel settings from the plugins/config entry $self->{_args}{loglevel}. A +simple and recommended example is as follows: + + sub register { + my ( $self, $qp ) = shift, shift; + $self->log(LOGERROR, "Bad arguments") if @_ % 2; + $self->{_args} = { @_ }; + } + +=head3 whole number + +If loglevel is a whole number, then all log activity in the plugin is logged +at that level, regardless of the level the plugin author selected. This can +be easily understood with a couple examples: + +The master loglevel is set at 6 (INFO). The mail admin sets a plugin loglevel +to 7 (DEBUG). No messages from that plugin are emitted because DEBUG log +entries are not <= 6 (INFO). + +The master loglevel is 6 (INFO) and the plugin loglevel is set to 5 or 6. All +log entries will be logged because 5 is <= 6. + +This behavior is very useful to plugin authors. While testing and monitoring +a plugin, they can set the level of their plugin to log everything. To return +to 'normal' logging, they just update their config/plugins entry. + +=head3 relative + +Relative loglevel arguments adjust the loglevel of each logging call within +a plugin. A value of I would make every logging entry one level +less severe, where a value of I would make every logging entry +one level more severe. + +For example, if a plugin has a loglevel setting of -1 and that same plugin +logged a LOGDEBUG, it would instead be a LOGINFO message. Relative values +makes it easy to control the verbosity and/or severity of individual plugins. + +=head1 qpsmtpd logging system; developer documentation + +Qpsmtpd now (as of 0.30-dev) supports a plugable logging architecture, so +that different logging plugins can be supported. See the example logging +plugins in plugins/logging, specifically the L 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. + diff --git a/docs/plugins.pod b/docs/plugins.pod new file mode 100644 index 0000000..43a4c4e --- /dev/null +++ b/docs/plugins.pod @@ -0,0 +1,401 @@ +# +# 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->log($loglevel, $logmessage); + +The log level is one of (from low to high priority) + +=over 4 + +=item * + +LOGDEBUG + +=item * + +LOGINFO + +=item * + +LOGNOTICE + +=item * + +LOGWARN + +=item * + +LOGERROR + +=item * + +LOGCRIT + +=item * + +LOGALERT + +=item * + +LOGEMERG + +=back + +While debugging your plugins, set your plugins loglevel to LOGDEBUG. This +will log every logging statement within your plugin. + +For more information about logging, see F. + +=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 diff --git a/docs/writing.pod b/docs/writing.pod new file mode 100644 index 0000000..8105baa --- /dev/null +++ b/docs/writing.pod @@ -0,0 +1,271 @@ +# +# 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 diff --git a/lib/Apache/Qpsmtpd.pm b/lib/Apache/Qpsmtpd.pm new file mode 100644 index 0000000..d85d608 --- /dev/null +++ b/lib/Apache/Qpsmtpd.pm @@ -0,0 +1,246 @@ +package Apache::Qpsmtpd; + +use 5.006001; +use strict; +use warnings FATAL => 'all'; + +use Apache2::ServerUtil (); +use Apache2::Connection (); +use Apache2::Const -compile => qw(OK MODE_GETLINE); +use APR::Const -compile => qw(SO_NONBLOCK EOF SUCCESS); +use APR::Error (); +use APR::Brigade (); +use APR::Bucket (); +use APR::Socket (); +use Apache2::Filter (); +use ModPerl::Util (); + +our $VERSION = '0.02'; + +sub handler { + my Apache2::Connection $c = shift; + $c->client_socket->opt_set(APR::Const::SO_NONBLOCK => 0); + + die "\$ENV{QPSMTPD_CONFIG} must be given" unless $ENV{QPSMTPD_CONFIG}; + + my $qpsmtpd = Qpsmtpd::Apache->new(); + $qpsmtpd->start_connection( + ip => $c->remote_ip, + host => $c->remote_host, + info => undef, + conn => $c, + ); + + $qpsmtpd->run($c); + $qpsmtpd->run_hooks("post-connection"); + $qpsmtpd->connection->reset; + + return Apache2::Const::OK; +} + +package Qpsmtpd::Apache; + +use Qpsmtpd::Constants; +use base qw(Qpsmtpd::SMTP); + +my %cdir_memo; + +sub config_dir { + my ($self, $config) = @_; + if (exists $cdir_memo{$config}) { + return $cdir_memo{$config}; + } + + if (uc($ENV{QPSMTPD_CONFIG}) eq 'USE-VIRTUAL-DOMAINS') { + my $cdir = $self->{conn}->base_server->dir_config("qpsmtpd.config_dir"); + $cdir =~ /^(.*)$/; # detaint + my $configdir = $1 if -e "$1/$config"; + $cdir_memo{$config} = $configdir; + } else { + $cdir_memo{$config} = $self->SUPER::config_dir(@_); + } + return $cdir_memo{$config}; +} + +sub start_connection { + my $self = shift; + my %opts = @_; + + $self->{conn} = $opts{conn}; + $self->{conn}->client_socket->timeout_set($self->config('timeout') * 1_000_000); + $self->{bb_in} = APR::Brigade->new($self->{conn}->pool, $self->{conn}->bucket_alloc); + $self->{bb_out} = APR::Brigade->new($self->{conn}->pool, $self->{conn}->bucket_alloc); + + my $remote_host = $opts{host} || ( $opts{ip} ? "[$opts{ip}]" : "[noip!]"); + my $remote_info = $opts{info} ? "$opts{info}\@$remote_host" : $remote_host; + my $remote_ip = $opts{ip}; + + $self->log(LOGNOTICE, "Connection from $remote_info [$remote_ip]"); + + $self->SUPER::connection->start( + remote_info => $remote_info, + remote_ip => $remote_ip, + remote_host => $remote_host, + local_ip => $opts{conn}->local_ip, + @_ + ); +} + +sub config { + my $self = shift; + my ($param, $type) = @_; + if (!$type) { + my $opt = $self->{conn}->base_server->dir_config("qpsmtpd.$param"); + return $opt if defined($opt); + } + return $self->SUPER::config(@_); +} + +sub run { + my $self = shift; + + # should be somewhere in Qpsmtpd.pm and not here... + $self->load_plugins; + + my $rc = $self->start_conversation; + return if $rc != DONE; + + # this should really be the loop and read_input should just + # get one line; I think + $self->read_input(); +} + +sub getline { + my $self = shift; + my $c = $self->{conn} || die "Cannot getline without a conn"; + + return if $c->aborted; + + my $bb = $self->{bb_in}; + + while (1) { + my $rc = $c->input_filters->get_brigade($bb, Apache2::Const::MODE_GETLINE); + return if $rc == APR::Const::EOF; + die APR::Error::strerror($rc) unless $rc == APR::Const::SUCCESS; + + next unless $bb->flatten(my $data); + + $bb->cleanup; + return $data; + } + + return ''; +} + +sub read_input { + my $self = shift; + my $c = $self->{conn}; + + while (defined(my $data = $self->getline)) { + $data =~ s/\r?\n$//s; # advanced chomp + $self->connection->notes('original_string', $data); + $self->log(LOGDEBUG, "dispatching $data"); + defined $self->dispatch(split / +/, $data, 2) + or $self->respond(502, "command unrecognized: '$data'"); + last if $self->{_quitting}; + } +} + +sub respond { + my ($self, $code, @messages) = @_; + my $c = $self->{conn}; + while (my $msg = shift @messages) { + my $bb = $self->{bb_out}; + my $line = $code . (@messages?"-":" ").$msg; + $self->log(LOGDEBUG, $line); + my $bucket = APR::Bucket->new(($c->bucket_alloc), "$line\r\n"); + $bb->insert_tail($bucket); + $c->output_filters->fflush($bb); + # $bucket->remove; + $bb->cleanup; + } + return 1; +} + +sub disconnect { + my $self = shift; + $self->SUPER::disconnect(@_); + $self->{_quitting} = 1; + $self->{conn}->client_socket->close(); +} + +1; + +__END__ + +=head1 NAME + +Apache::Qpsmtpd - a mod_perl-2 connection handler for qpsmtpd + +=head1 SYNOPSIS + + Listen 0.0.0.0:25 smtp + AcceptFilter smtp none + ## "smtp" and the AcceptFilter are required for Linux, FreeBSD + ## with apache >= 2.1.5, for others it doesn't hurt. See also + ## http://httpd.apache.org/docs/2.2/mod/core.html#acceptfilter + ## and http://httpd.apache.org/docs/2.2/mod/mpm_common.html#listen + + LoadModule perl_module modules/mod_perl.so + + + 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 + + +Using multiple instances of Qpsmtpd on the same server is also +possible by setting: + + $ENV{QPSMTPD_CONFIG} = "USE-VIRTUAL-DOMAINS"; + +Then in the VirtualHost of each config define the configuration +directory: + + PerlSetVar qpsmtpd.config_dir /path/to/qpsmtpd/config + +Several different configurations can be running on the same +server. + +=head1 DESCRIPTION + +This module implements a mod_perl/apache 2.0 connection handler +that turns Apache into an SMTP server using Qpsmtpd. + +It also allows you to set single-valued config options (such +as I, 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. added the virtual +host support. + +=cut diff --git a/lib/Danga/Client.pm b/lib/Danga/Client.pm new file mode 100644 index 0000000..25fe6dd --- /dev/null +++ b/lib/Danga/Client.pm @@ -0,0 +1,221 @@ +# $Id: Client.pm,v 1.8 2005/02/14 22:06:38 msergeant Exp $ + +package Danga::Client; +use base 'Danga::TimeoutSocket'; +use fields qw( + line + pause_count + read_bytes + data_bytes + callback + get_chunks + reader_object + ); +use Time::HiRes (); + +use bytes; + +# 30 seconds max timeout! +sub max_idle_time { 30 } +sub max_connect_time { 1200 } + +sub new { + my Danga::Client $self = shift; + $self = fields::new($self) unless ref $self; + $self->SUPER::new( @_ ); + + $self->reset_for_next_message; + return $self; +} + +sub reset_for_next_message { + my Danga::Client $self = shift; + $self->{line} = ''; + $self->{pause_count} = 0; + $self->{read_bytes} = 0; + $self->{callback} = undef; + $self->{reader_object} = undef; + $self->{data_bytes} = ''; + $self->{get_chunks} = 0; + return $self; +} + +sub get_bytes { + my Danga::Client $self = shift; + my ($bytes, $callback) = @_; + if ($self->{callback}) { + die "get_bytes/get_chunks currently in progress!"; + } + $self->{read_bytes} = $bytes; + $self->{data_bytes} = $self->{line}; + $self->{read_bytes} -= length($self->{data_bytes}); + $self->{line} = ''; + if ($self->{read_bytes} <= 0) { + if ($self->{read_bytes} < 0) { + $self->{line} = substr($self->{data_bytes}, + $self->{read_bytes}, # negative offset + 0 - $self->{read_bytes}, # to end of str + ""); # truncate that substr + } + $callback->($self->{data_bytes}); + return; + } + $self->{callback} = $callback; +} + +sub process_chunk { + my Danga::Client $self = shift; + my $callback = shift; + + my $last_crlf = rindex($self->{line}, "\r\n"); + + if ($last_crlf != -1) { + if ($last_crlf + 2 == length($self->{line})) { + my $data = $self->{line}; + $self->{line} = ''; + $callback->($data); + } + else { + my $data = substr($self->{line}, 0, $last_crlf + 2); + $self->{line} = substr($self->{line}, $last_crlf + 2); + $callback->($data); + } + } +} + +sub get_chunks { + my Danga::Client $self = shift; + my ($bytes, $callback) = @_; + if ($self->{callback}) { + die "get_bytes/get_chunks currently in progress!"; + } + $self->{read_bytes} = $bytes; + $self->process_chunk($callback) if length($self->{line}); + $self->{callback} = $callback; + $self->{get_chunks} = 1; +} + +sub end_get_chunks { + my Danga::Client $self = shift; + my $remaining = shift; + $self->{callback} = undef; + $self->{get_chunks} = 0; + if (defined($remaining)) { + $self->process_read_buf(\$remaining); + } +} + +sub set_reader_object { + my Danga::Client $self = shift; + $self->{reader_object} = shift; +} + +sub event_read { + my Danga::Client $self = shift; + if (my $obj = $self->{reader_object}) { + $self->{reader_object} = undef; + $obj->event_read($self); + } + elsif ($self->{callback}) { + $self->{alive_time} = time; + if ($self->{get_chunks}) { + my $bref = $self->read($self->{read_bytes}); + return $self->close($!) unless defined $bref; + $self->{line} .= $$bref; + $self->process_chunk($self->{callback}) if length($self->{line}); + return; + } + if ($self->{read_bytes} > 0) { + my $bref = $self->read($self->{read_bytes}); + return $self->close($!) unless defined $bref; + $self->{read_bytes} -= length($$bref); + $self->{data_bytes} .= $$bref; + } + if ($self->{read_bytes} <= 0) { + # print "Erk, read too much!\n" if $self->{read_bytes} < 0; + my $cb = $self->{callback}; + $self->{callback} = undef; + $cb->($self->{data_bytes}); + } + } + else { + my $bref = $self->read(8192); + return $self->close($!) unless defined $bref; + $self->process_read_buf($bref); + } +} + +sub process_read_buf { + my Danga::Client $self = shift; + my $bref = shift; + $self->{line} .= $$bref; + return if $self->{pause_count} || $self->{closed}; + + if ($self->{line} =~ s/^(.*?\n)//) { + my $line = $1; + $self->{alive_time} = time; + my $resp = $self->process_line($line); + if ($::DEBUG > 1 and $resp) { print "$$:".($self+0)."S: $_\n" for split(/\n/, $resp) } + $self->write($resp) if $resp; + # $self->watch_read(0) if $self->{pause_count}; + return if $self->{pause_count} || $self->{closed}; + # read more in a timer, to give other clients a look in + $self->AddTimer(0, sub { + if (length($self->{line}) && !$self->paused) { + $self->process_read_buf(\""); # " for bad syntax highlighters + } + }); + } +} + +sub has_data { + my Danga::Client $self = shift; + return length($self->{line}) ? 1 : 0; +} + +sub clear_data { + my Danga::Client $self = shift; + $self->{line} = ''; +} + +sub paused { + my Danga::Client $self = shift; + return 1 if $self->{pause_count}; + return 1 if $self->{closed}; + return 0; +} + +sub pause_read { + my Danga::Client $self = shift; + $self->{pause_count}++; + # $self->watch_read(0); +} + +sub continue_read { + my Danga::Client $self = shift; + $self->{pause_count}--; + if ($self->{pause_count} <= 0) { + $self->{pause_count} = 0; + $self->AddTimer(0, sub { + if (length($self->{line}) && !$self->paused) { + $self->process_read_buf(\""); # " for bad syntax highlighters + } + }); + } +} + +sub process_line { + my Danga::Client $self = shift; + return ''; +} + +sub close { + my Danga::Client $self = shift; + print "closing @_\n" if $::DEBUG; + $self->SUPER::close(@_); +} + +sub event_err { my Danga::Client $self = shift; $self->close("Error") } +sub event_hup { my Danga::Client $self = shift; $self->close("Disconnect (HUP)") } + +1; diff --git a/lib/Danga/TimeoutSocket.pm b/lib/Danga/TimeoutSocket.pm new file mode 100644 index 0000000..c15aab6 --- /dev/null +++ b/lib/Danga/TimeoutSocket.pm @@ -0,0 +1,67 @@ +# $Id: TimeoutSocket.pm,v 1.2 2005/02/02 20:44:35 msergeant Exp $ + +package Danga::TimeoutSocket; + +use base 'Danga::Socket'; +use fields qw(alive_time create_time); + +our $last_cleanup = 0; + +Danga::Socket->AddTimer(15, \&_do_cleanup); + +sub new { + my Danga::TimeoutSocket $self = shift; + my $sock = shift; + $self = fields::new($self) unless ref($self); + $self->SUPER::new($sock); + + my $now = time; + $self->{alive_time} = $self->{create_time} = $now; + + return $self; +} + +# overload these in a subclass +sub max_idle_time { 0 } +sub max_connect_time { 0 } + +sub Reset { + Danga::Socket->Reset; + Danga::Socket->AddTimer(15, \&_do_cleanup); +} + +sub _do_cleanup { + my $now = time; + + Danga::Socket->AddTimer(15, \&_do_cleanup); + + my $sf = __PACKAGE__->get_sock_ref; + + my %max_age; # classname -> max age (0 means forever) + my %max_connect; # classname -> max connect time + my @to_close; + while (my $k = each %$sf) { + my Danga::TimeoutSocket $v = $sf->{$k}; + my $ref = ref $v; + next unless $v->isa('Danga::TimeoutSocket'); + unless (defined $max_age{$ref}) { + $max_age{$ref} = $ref->max_idle_time || 0; + $max_connect{$ref} = $ref->max_connect_time || 0; + } + if (my $t = $max_connect{$ref}) { + if ($v->{create_time} < $now - $t) { + push @to_close, $v; + next; + } + } + if (my $t = $max_age{$ref}) { + if ($v->{alive_time} < $now - $t) { + push @to_close, $v; + } + } + } + + $_->close("Timeout") foreach @to_close; +} + +1; diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm new file mode 100644 index 0000000..86ac87d --- /dev/null +++ b/lib/Qpsmtpd.pm @@ -0,0 +1,630 @@ +package Qpsmtpd; +use strict; +use vars qw($VERSION $TraceLevel $Spool_dir $Size_threshold); + +use Sys::Hostname; +use Qpsmtpd::Constants; + +#use DashProfiler; + +$VERSION = "0.84"; + +my $git; + +if (-e ".git") { + local $ENV{PATH} = "/usr/bin:/usr/local/bin:/opt/local/bin/"; + $git = `git describe`; + $git && chomp $git; +} + +my $hooks = {}; +my %defaults = ( + me => hostname, + timeout => 1200, + ); +my $_config_cache = {}; +my %config_dir_memo; + +#DashProfiler->add_profile("qpsmtpd"); +#my $SAMPLER = DashProfiler->prepare("qpsmtpd"); +my $LOGGING_LOADED = 0; + +sub _restart { + my $self = shift; + my %args = @_; + if ($args{restart}) { + # reset all global vars to defaults + $self->clear_config_cache; + $hooks = {}; + $LOGGING_LOADED = 0; + %config_dir_memo = (); + $TraceLevel = LOGWARN; + $Spool_dir = undef; + $Size_threshold = undef; + } +} + + +sub DESTROY { + #warn $_ for DashProfiler->profile_as_text("qpsmtpd"); +} + +sub version { $VERSION . ($git ? "/$git" : "") }; + +sub TRACE_LEVEL { $TraceLevel }; # leave for plugin compatibility + + +sub hooks { $hooks; } + +sub load_logging { + # need to do this differently than other plugins so as to + # not trigger logging activity + return if $LOGGING_LOADED; + my $self = shift; + return if $hooks->{"logging"}; + my $configdir = $self->config_dir("logging"); + my $configfile = "$configdir/logging"; + my @loggers = $self->_config_from_file($configfile,'logging'); + + $configdir = $self->config_dir('plugin_dirs'); + $configfile = "$configdir/plugin_dirs"; + my @plugin_dirs = $self->_config_from_file($configfile,'plugin_dirs'); + unless (@plugin_dirs) { + my ($name) = ($0 =~ m!(.*?)/([^/]+)$!); + @plugin_dirs = ( "$name/plugins" ); + } + + my @loaded; + for my $logger (@loggers) { + push @loaded, $self->_load_plugin($logger, @plugin_dirs); + } + + foreach my $logger (@loaded) { + $self->log(LOGINFO, "Loaded $logger"); + } + + $configdir = $self->config_dir("loglevel"); + $configfile = "$configdir/loglevel"; + $TraceLevel = $self->_config_from_file($configfile,'loglevel'); + + unless (defined($TraceLevel) and $TraceLevel =~ /^\d+$/) { + $TraceLevel = LOGWARN; # Default if no loglevel file found. + } + + $LOGGING_LOADED = 1; + + return @loggers; +} + +sub trace_level { + my $self = shift; + return $TraceLevel; +} + +sub init_logger { # needed for compatibility purposes + shift->trace_level(); +} + +sub log { + my ($self, $trace, @log) = @_; + $self->varlog($trace,join(" ",@log)); +} + +sub varlog { + my ($self, $trace) = (shift,shift); + my ($hook, $plugin, @log); + if ( $#_ == 0 ) { # log itself + (@log) = @_; + } + elsif ( $#_ == 1 ) { # plus the hook + ($hook, @log) = @_; + } + else { # called from plugin + ($hook, $plugin, @log) = @_; + } + + $self->load_logging; # in case we don't have this loaded yet + + my ($rc) = $self->run_hooks_no_respond("logging", $trace, $hook, $plugin, @log) + or return; + + return if $rc == DECLINED || $rc == OK; # plugin success + return if $trace > $TraceLevel; + + # no logging plugins registered, fall back to STDERR + my $prefix = defined $plugin && defined $hook ? " ($hook) $plugin:" : + defined $plugin ? " $plugin:" : + defined $hook ? " ($hook) running plugin:" : ''; + + warn join(' ', $$ . $prefix, @log), "\n"; +} + +sub clear_config_cache { + $_config_cache = {}; +} + +# +# method to get the configuration. It just calls get_qmail_config by +# default, but it could be overwritten to look configuration up in a +# database or whatever. +# +sub config { + my ($self, $c, $type) = @_; + + $self->log(LOGDEBUG, "in config($c)"); + + # first try the cache + # XXX - is this always the right thing to do? what if a config hook + # can return different values on subsequent calls? + if ($_config_cache->{$c}) { + $self->log(LOGDEBUG, "config($c) returning (@{$_config_cache->{$c}}) from cache"); + return wantarray ? @{$_config_cache->{$c}} : $_config_cache->{$c}->[0]; + } + + # then run the hooks + my ($rc, @config) = $self->run_hooks_no_respond("config", $c); + $self->log(LOGDEBUG, "config($c): hook returned ($rc, @config) "); + if ($rc == OK) { + $self->log(LOGDEBUG, "setting _config_cache for $c to [@config] from hooks and returning it"); + $_config_cache->{$c} = \@config; + return wantarray ? @{$_config_cache->{$c}} : $_config_cache->{$c}->[0]; + } + + # and then get_qmail_config + @config = $self->get_qmail_config($c, $type); + if (@config) { + $self->log(LOGDEBUG, "setting _config_cache for $c to [@config] from get_qmail_config and returning it"); + $_config_cache->{$c} = \@config; + return wantarray ? @{$_config_cache->{$c}} : $_config_cache->{$c}->[0]; + } + + # finally we use the default if there is any: + if (exists($defaults{$c})) { + $self->log(LOGDEBUG, "setting _config_cache for $c to @{[$defaults{$c}]} from defaults and returning it"); + $_config_cache->{$c} = [$defaults{$c}]; + return wantarray ? @{$_config_cache->{$c}} : $_config_cache->{$c}->[0]; + } + return; +} + +sub config_dir { + my ($self, $config) = @_; + if (exists $config_dir_memo{$config}) { + return $config_dir_memo{$config}; + } + my $configdir = ($ENV{QMAIL} || '/var/qmail') . '/control'; + my ($path) = ($ENV{PROCESS} ? $ENV{PROCESS} : $0) =~ m!(.*?)/([^/]+)$!; + $configdir = "$path/config" if (-e "$path/config/$config"); + if (exists $ENV{QPSMTPD_CONFIG}) { + $ENV{QPSMTPD_CONFIG} =~ /^(.*)$/; # detaint + $configdir = $1 if -e "$1/$config"; + } + return $config_dir_memo{$config} = $configdir; +} + +sub plugin_dirs { + my $self = shift; + my @plugin_dirs = $self->config('plugin_dirs'); + + unless (@plugin_dirs) { + my ($path) = ($ENV{PROCESS} ? $ENV{PROCESS} : $0) =~ m!(.*?)/([^/]+)$!; + @plugin_dirs = ( "$path/plugins" ); + } + return @plugin_dirs; +} + +sub get_qmail_config { + my ($self, $config, $type) = @_; + $self->log(LOGDEBUG, "trying to get config for $config"); + my $configdir = $self->config_dir($config); + + my $configfile = "$configdir/$config"; + + # CDB config support really should be moved to a plugin + if ($type and $type eq "map") { + unless (-e $configfile . ".cdb") { + $_config_cache->{$config} ||= []; + return +{}; + } + eval { require CDB_File }; + + if ($@) { + $self->log(LOGERROR, "No CDB Support! Did NOT read $configfile.cdb, could not load CDB_File module: $@"); + return +{}; + } + + my %h; + unless (tie(%h, 'CDB_File', "$configfile.cdb")) { + $self->log(LOGERROR, "tie of $configfile.cdb failed: $!"); + return +{}; + } + # We explicitly don't cache cdb entries. The assumption is that + # the data is in a CDB file in the first place because there's + # lots of data and the cache hit ratio would be low. + return \%h; + } + + return $self->_config_from_file($configfile, $config); +} + +sub _config_from_file { + my ($self, $configfile, $config, $visited) = @_; + unless (-e $configfile) { + $_config_cache->{$config} ||= []; + return; + } + + $visited ||= []; + push @{$visited}, $configfile; + + open CF, "<$configfile" or warn "$$ could not open configfile $configfile: $!" and return; + my @config = ; + chomp @config; + @config = grep { length($_) and $_ !~ m/^\s*#/ and $_ =~ m/\S/} + map {s/^\s+//; s/\s+$//; $_;} # trim leading/trailing whitespace + @config; + close CF; + + my $pos = 0; + while ($pos < @config) { + # recursively pursue an $include reference, if found. An inclusion which + # begins with a leading slash is interpreted as a path to a file and will + # supercede the usual config path resolution. Otherwise, the normal + # config_dir() lookup is employed (the location in which the inclusion + # appeared receives no special precedence; possibly it should, but it'd + # be complicated beyond justifiability for so simple a config system. + if ($config[$pos] =~ /^\s*\$include\s+(\S+)\s*$/) { + my ($includedir, $inclusion) = ('', $1); + + splice @config, $pos, 1; # remove the $include line + if ($inclusion !~ /^\//) { + $includedir = $self->config_dir($inclusion); + $inclusion = "$includedir/$inclusion"; + } + + if (grep($_ eq $inclusion, @{$visited})) { + $self->log(LOGERROR, "Circular \$include reference in config $config:"); + $self->log(LOGERROR, "From $visited->[0]:"); + $self->log(LOGERROR, " includes $_") + for (@{$visited}[1..$#{$visited}], $inclusion); + return wantarray ? () : undef; + } + push @{$visited}, $inclusion; + + for my $inc ($self->expand_inclusion_($inclusion, $configfile)) { + my @insertion = $self->_config_from_file($inc, $config, $visited); + splice @config, $pos, 0, @insertion; # insert the inclusion + $pos += @insertion; + } + } else { + $pos++; + } + } + + $_config_cache->{$config} = \@config; + + return wantarray ? @config : $config[0]; +} + +sub expand_inclusion_ { + my $self = shift; + my $inclusion = shift; + my $context = shift; + my @includes; + + if (-d $inclusion) { + $self->log(LOGDEBUG, "inclusion of directory $inclusion from $context"); + + if (opendir(INCD, $inclusion)) { + @includes = map { "$inclusion/$_" } + (grep { -f "$inclusion/$_" and !/^\./ } sort readdir INCD); + closedir INCD; + } else { + $self->log(LOGERROR, "Couldn't open directory $inclusion,". + " referenced from $context ($!)"); + } + } else { + $self->log(LOGDEBUG, "inclusion of file $inclusion from $context"); + @includes = ( $inclusion ); + } + return @includes; +} + + +sub load_plugins { + my $self = shift; + + my @plugins = $self->config('plugins'); + my @loaded; + + if ($hooks->{queue}) { + #$self->log(LOGWARN, "Plugins already loaded"); + return @plugins; + } + + for my $plugin_line (@plugins) { + my $this_plugin = $self->_load_plugin($plugin_line, $self->plugin_dirs); + push @loaded, $this_plugin if $this_plugin; + } + + return @loaded; +} + +sub _load_plugin { + my $self = shift; + my ($plugin_line, @plugin_dirs) = @_; + + my ($plugin, @args) = split ' ', $plugin_line; + + my $package; + + if ($plugin =~ m/::/) { + # "full" package plugin (My::Plugin) + $package = $plugin; + $package =~ s/[^_a-z0-9:]+//gi; + my $eval = qq[require $package;\n] + .qq[sub ${plugin}::plugin_name { '$plugin' }]; + $eval =~ m/(.*)/s; + $eval = $1; + eval $eval; + die "Failed loading $package - eval $@" if $@; + $self->log(LOGDEBUG, "Loading $package ($plugin_line)") + unless $plugin_line =~ /logging/; + } + else { + # regular plugins/$plugin plugin + my $plugin_name = $plugin; + $plugin =~ s/:\d+$//; # after this point, only used for filename + + # Escape everything into valid perl identifiers + $plugin_name =~ s/([^A-Za-z0-9_\/])/sprintf("_%2x",unpack("C",$1))/eg; + + # second pass cares for slashes and words starting with a digit + $plugin_name =~ s{ + (/+) # directory + (\d?) # package's first character + }[ + "::" . (length $2 ? sprintf("_%2x",unpack("C",$2)) : "") + ]egx; + + $package = "Qpsmtpd::Plugin::$plugin_name"; + + # don't reload plugins if they are already loaded + unless ( defined &{"${package}::plugin_name"} ) { + PLUGIN_DIR: for my $dir (@plugin_dirs) { + if (-e "$dir/$plugin") { + Qpsmtpd::Plugin->compile($plugin_name, $package, + "$dir/$plugin", $self->{_test_mode}, $plugin); + $self->log(LOGDEBUG, "Loading $plugin_line from $dir/$plugin") + unless $plugin_line =~ /logging/; + last PLUGIN_DIR; + } + } + die "Plugin $plugin_name not found in our plugin dirs (", + join(", ", @plugin_dirs),")" + unless defined &{"${package}::plugin_name"}; + } + } + + my $plug = $package->new(); + $plug->_register($self, @args); + + return $plug; +} + +sub transaction { return {}; } # base class implements empty transaction + +sub run_hooks { + my ($self, $hook) = (shift, shift); + if ($hooks->{$hook}) { + my @r; + my @local_hooks = @{$hooks->{$hook}}; + $self->{_continuation} = [$hook, [@_], @local_hooks]; + return $self->run_continuation(); + } + return $self->hook_responder($hook, [0, ''], [@_]); +} + +sub run_hooks_no_respond { + my ($self, $hook) = (shift, shift); + if ($hooks->{$hook}) { + my @r; + for my $code (@{$hooks->{$hook}}) { + eval { (@r) = $code->{code}->($self, $self->transaction, @_); }; + $@ and warn("FATAL PLUGIN ERROR [" . $code->{name} . "]: ", $@) and next; + if ($r[0] == YIELD) { + die "YIELD not valid from $hook hook"; + } + last unless $r[0] == DECLINED; + } + $r[0] = DECLINED if not defined $r[0]; + return @r; + } + return (0, ''); +} + +sub continue_read {} # subclassed in -async +sub pause_read { die "Continuations only work in qpsmtpd-async" } + +sub run_continuation { + my $self = shift; + #my $t1 = $SAMPLER->("run_hooks", undef, 1); + die "No continuation in progress" unless $self->{_continuation}; + $self->continue_read(); + my $todo = $self->{_continuation}; + $self->{_continuation} = undef; + my $hook = shift @$todo || die "No hook in the continuation"; + my $args = shift @$todo || die "No hook args in the continuation"; + my @r; + while (@$todo) { + my $code = shift @$todo; + #my $t2 = $SAMPLER->($hook . "_" . $code->{name}, undef, 1); + #warn("Got sampler called: ${hook}_$code->{name}\n"); + $self->varlog(LOGDEBUG, $hook, $code->{name}); + my $tran = $self->transaction; + eval { (@r) = $code->{code}->($self, $tran, @$args); }; + $@ and $self->log(LOGCRIT, "FATAL PLUGIN ERROR [" . $code->{name} . "]: ", $@) and next; + + !defined $r[0] + and $self->log(LOGERROR, "plugin ".$code->{name} + ." running the $hook hook returned undef!") + and next; + + # note this is wrong as $tran is always true in the + # current code... + if ($tran) { + my $tnotes = $tran->notes( $code->{name} ); + $tnotes->{"hook_$hook"}->{'return'} = $r[0] + if (!defined $tnotes || ref $tnotes eq "HASH"); + } + else { + my $cnotes = $self->connection->notes( $code->{name} ); + $cnotes->{"hook_$hook"}->{'return'} = $r[0] + if (!defined $cnotes || ref $cnotes eq "HASH"); + } + + if ($r[0] == YIELD) { + $self->pause_read(); + $self->{_continuation} = [$hook, $args, @$todo]; + return @r; + } + elsif ($r[0] == DENY or $r[0] == DENYSOFT or + $r[0] == DENY_DISCONNECT or $r[0] == DENYSOFT_DISCONNECT) + { + $r[1] = "" if not defined $r[1]; + $self->log(LOGDEBUG, "Plugin ".$code->{name}. + ", hook $hook returned ".return_code($r[0]).", $r[1]"); + $self->run_hooks_no_respond("deny", $code->{name}, $r[0], $r[1]) unless ($hook eq "deny"); + } + else { + $r[1] = "" if not defined $r[1]; + $self->log(LOGDEBUG, "Plugin ".$code->{name}. + ", hook $hook returned ".return_code($r[0]).", $r[1]"); + $self->run_hooks_no_respond("ok", $code->{name}, $r[0], $r[1]) unless ($hook eq "ok"); + } + + last unless $r[0] == DECLINED; + } + $r[0] = DECLINED if not defined $r[0]; + # hook_*_parse() may return a CODE ref.. + # ... which breaks when splitting as string: + @r = map { split /\n/ } @r unless (ref($r[1]) eq "CODE"); + return $self->hook_responder($hook, \@r, $args); +} + +sub hook_responder { + my ($self, $hook, $msg, $args) = @_; + + #my $t1 = $SAMPLER->("hook_responder", undef, 1); + my $code = shift @$msg; + + my $responder = $hook . '_respond'; + if (my $meth = $self->can($responder)) { + return $meth->($self, $code, $msg, $args); + } + return $code, @$msg; +} + +sub _register_hook { + my $self = shift; + my ($hook, $code, $unshift) = @_; + + if ($unshift) { + unshift @{$hooks->{$hook}}, $code; + } + else { + push @{$hooks->{$hook}}, $code; + } +} + +sub spool_dir { + my $self = shift; + + unless ( $Spool_dir ) { # first time through + $self->log(LOGDEBUG, "Initializing spool_dir"); + $Spool_dir = $self->config('spool_dir') + || Qpsmtpd::Utils::tildeexp('~/tmp/'); + + $Spool_dir .= "/" unless ($Spool_dir =~ m!/$!); + + $Spool_dir =~ /^(.+)$/ or die "spool_dir not configured properly"; + $Spool_dir = $1; # cleanse the taint + my $Spool_perms = $self->config('spool_perms') || '0700'; + + if (! -d $Spool_dir) { # create it if it doesn't exist + mkdir($Spool_dir,oct($Spool_perms)) + or die "Could not create spool_dir $Spool_dir: $!"; + }; + # Make sure the spool dir has appropriate rights + $self->log(LOGWARN, + "Permissions on spool_dir $Spool_dir are not $Spool_perms") + unless ((stat $Spool_dir)[2] & 07777) == oct($Spool_perms); + } + + return $Spool_dir; +} + +# For unique filenames. We write to a local tmp dir so we don't need +# to make them unpredictable. +my $transaction_counter = 0; + +sub temp_file { + my $self = shift; + my $filename = $self->spool_dir() + . join(":", time, $$, $transaction_counter++); + return $filename; +} + +sub temp_dir { + my $self = shift; + my $mask = shift || 0700; + my $dirname = $self->temp_file(); + -d $dirname or mkdir($dirname, $mask) + or die "Could not create temporary directory $dirname: $!"; + return $dirname; +} + +sub size_threshold { + my $self = shift; + unless ( defined $Size_threshold ) { + $Size_threshold = $self->config('size_threshold') || 0; + $self->log(LOGNOTICE, "size_threshold set to $Size_threshold"); + } + return $Size_threshold; +} + +sub authenticated { + my $self = shift; + return (defined $self->{_auth} ? $self->{_auth} : "" ); +} + +sub auth_user { + my $self = shift; + return (defined $self->{_auth_user} ? $self->{_auth_user} : "" ); +} + +sub auth_mechanism { + my $self = shift; + return (defined $self->{_auth_mechanism} ? $self->{_auth_mechanism} : "" ); +} + +1; + +__END__ + +=head1 NAME + +Qpsmtpd - base class for the qpsmtpd mail server + +=head1 DESCRIPTION + +This is the base class for the qpsmtpd mail server. See +L and the I file for more information. + +=head1 COPYRIGHT + +Copyright 2001-2012 Ask Bjørn Hansen, Develooper LLC. See the +LICENSE file for more information. + +=cut + diff --git a/lib/Qpsmtpd/Address.pm b/lib/Qpsmtpd/Address.pm new file mode 100644 index 0000000..50d008d --- /dev/null +++ b/lib/Qpsmtpd/Address.pm @@ -0,0 +1,362 @@ +#!/usr/bin/perl -w +package Qpsmtpd::Address; +use strict; + +=head1 NAME + +Qpsmtpd::Address - Lightweight E-Mail address objects + +=head1 DESCRIPTION + +Based originally on cut and paste from Mail::Address and including +every jot and tittle from RFC-2821/2822 on what is a legal e-mail +address for use during the SMTP transaction. + +=head1 USAGE + + my $rcpt = Qpsmtpd::Address->new(''); + +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; diff --git a/lib/Qpsmtpd/Auth.pm b/lib/Qpsmtpd/Auth.pm new file mode 100644 index 0000000..e55a30a --- /dev/null +++ b/lib/Qpsmtpd/Auth.pm @@ -0,0 +1,223 @@ +package Qpsmtpd::Auth; +# See the documentation in 'perldoc docs/authentication.pod' + +use strict; +use warnings; + +use Qpsmtpd::Constants; + +use Digest::HMAC_MD5 qw(hmac_md5_hex); +use MIME::Base64; + +sub e64 { + my ($arg) = @_; + my $res = encode_base64($arg); + chomp($res); + return($res); +} + +sub SASL { + + # $DB::single = 1; + my ( $session, $mechanism, $prekey ) = @_; + my ( $user, $passClear, $passHash, $ticket, $loginas ); + + if ( $mechanism eq 'plain' ) { + ($loginas, $user, $passClear) = get_auth_details_plain($session,$prekey); + return DECLINED if ! $user || ! $passClear; + } + elsif ( $mechanism eq 'login' ) { + ($user, $passClear) = get_auth_details_login($session,$prekey); + return DECLINED if ! $user || ! $passClear; + } + elsif ( $mechanism eq 'cram-md5' ) { + ( $ticket, $user, $passHash ) = get_auth_details_cram_md5($session); + return DECLINED if ! $user || ! $passHash; + } + else { + #this error is now caught in SMTP.pm's sub auth + $session->respond( 500, "Internal server error" ); + return DECLINED; + } + + # try running the specific hooks first + my ( $rc, $msg ) = + $session->run_hooks( "auth-$mechanism", $mechanism, $user, $passClear, + $passHash, $ticket ); + + # try running the polymorphous hooks next + if ( !$rc || $rc == DECLINED ) { + ( $rc, $msg ) = + $session->run_hooks( "auth", $mechanism, $user, $passClear, + $passHash, $ticket ); + } + + if ( $rc == OK ) { + $msg = uc($mechanism) . " authentication successful for $user" . + ( $msg ? " - $msg" : ''); + $session->respond( 235, $msg ); + $session->connection->relay_client(1); + if ( $session->connection->notes('naughty' ) ) { + $session->log( LOGINFO, "auth success cleared naughty" ); + $session->connection->notes('naughty',0); + }; + $session->log( LOGDEBUG, $msg ); # already logged by $session->respond + + $session->{_auth_user} = $user; + $session->{_auth_mechanism} = $mechanism; + s/[\r\n].*//s for ($session->{_auth_user}, $session->{_auth_mechanism}); + + return OK; + } + else { + $msg = uc($mechanism) . " authentication failed for $user" . + ( $msg ? " - $msg" : ''); + $session->respond( 535, $msg ); + $session->log( LOGDEBUG, $msg ); # already logged by $session->respond + return DENY; + } +} + +sub get_auth_details_plain { + my ( $session, $prekey ) = @_; + + if ( ! $prekey) { + $session->respond( 334, ' ' ); + $prekey= ; + } + + my ( $loginas, $user, $passClear ) = split /\x0/, decode_base64($prekey); + + if ( ! $user ) { + if ( $loginas ) { + $session->respond(535, "Authentication invalid ($loginas)"); + } + else { + $session->respond(535, "Authentication invalid"); + } + return; + }; + + # Authorization ID must not be different from Authentication ID + if ( $loginas ne '' && $loginas ne $user ) { + $session->respond(535, "Authentication invalid for $user"); + return; + } + + return ($loginas, $user, $passClear); +}; + +sub get_auth_details_login { + my ( $session, $prekey ) = @_; + + my $user; + + if ( $prekey ) { + $user = decode_base64($prekey); + } + else { + $user = get_base64_response($session,'Username:') or return; + } + + my $passClear = get_base64_response($session,'Password:') or return; + + return ($user, $passClear); +}; + +sub get_auth_details_cram_md5 { + my ( $session, $ticket ) = @_; + + if ( ! $ticket ) { # ticket is only passed in during testing + # rand() is not cryptographic, but we only need to generate a globally + # unique number. The rand() is there in case the user logs in more than + # once in the same second, or if the clock is skewed. + $ticket = sprintf( '<%x.%x@%s>', + rand(1000000), time(), $session->config('me') ); + }; + + # send the base64 encoded ticket + $session->respond( 334, encode_base64( $ticket, '' ) ); + my $line = ; + + if ( $line eq '*' ) { + $session->respond( 501, "Authentication canceled" ); + return; + }; + + my ( $user, $passHash ) = split( ' ', decode_base64($line) ); + unless ( $user && $passHash ) { + $session->respond(504, "Invalid authentication string"); + return; + } + + $session->{auth}{ticket} = $ticket; + return ($ticket, $user, $passHash); +}; + +sub get_base64_response { + my ($session, $question) = @_; + + $session->respond(334, e64($question)); + my $answer = decode_base64( ); + if ($answer eq '*') { + $session->respond(501, "Authentication canceled"); + return; + } + return $answer; +}; + +sub validate_password { + my ( $self, %a ) = @_; + + my ($pkg, $file, $line) = caller(); + $file = (split '/', $file)[-1]; # strip off the path + + my $src_clear = $a{src_clear}; + my $src_crypt = $a{src_crypt}; + my $attempt_clear = $a{attempt_clear}; + my $attempt_hash = $a{attempt_hash}; + my $method = $a{method} or die "missing method"; + my $ticket = $a{ticket} || $self->{auth}{ticket}; + my $deny = $a{deny} || DENY; + + if ( ! $src_crypt && ! $src_clear ) { + $self->log(LOGINFO, "fail: missing password"); + return ( $deny, "$file - no such user" ); + }; + + if ( ! $src_clear && $method =~ /CRAM-MD5/i ) { + $self->log(LOGINFO, "skip: cram-md5 not supported w/o clear pass"); + return ( DECLINED, $file ); + } + + if ( defined $attempt_clear ) { + if ( $src_clear && $src_clear eq $attempt_clear ) { + $self->log(LOGINFO, "pass: clear match"); + return ( OK, $file ); + }; + + if ( $src_crypt && $src_crypt eq crypt( $attempt_clear, $src_crypt ) ) { + $self->log(LOGINFO, "pass: crypt match"); + return ( OK, $file ); + } + }; + + if ( defined $attempt_hash && $src_clear ) { + if ( ! $ticket ) { + $self->log(LOGERROR, "skip: missing ticket"); + return ( DECLINED, $file ); + }; + + if ( $attempt_hash eq hmac_md5_hex( $ticket, $src_clear ) ) { + $self->log(LOGINFO, "pass: hash match"); + return ( OK, $file ); + }; + }; + + $self->log(LOGINFO, "fail: wrong password"); + return ( $deny, "$file - wrong password" ); +}; + +# tag: qpsmtpd plugin that sets RELAYCLIENT when the user authenticates + +1; diff --git a/lib/Qpsmtpd/Command.pm b/lib/Qpsmtpd/Command.pm new file mode 100644 index 0000000..e48c0f2 --- /dev/null +++ b/lib/Qpsmtpd/Command.pm @@ -0,0 +1,171 @@ +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 strict; + +use Qpsmtpd::Constants; +use vars qw(@ISA); +@ISA = qw(Qpsmtpd::SMTP); + +sub parse { + my ($me,$cmd,$line,$sub) = @_; + return (OK) unless defined $line; # trivial case + my $self = {}; + bless $self, $me; + $cmd = lc $cmd; + if ($sub and (ref($sub) eq 'CODE')) { + my @ret = eval { $sub->($self, $cmd, $line); }; + if ($@) { + $self->log(LOGERROR, "Failed to parse command [$cmd]: $@"); + return (DENY, $line, ()); + } + ## my @log = @ret; + ## for (@log) { + ## $_ ||= ""; + ## } + ## $self->log(LOGDEBUG, "parse($cmd) => [".join("], [", @log)."]"); + return @ret; + } + my $parse = "parse_$cmd"; + if ($self->can($parse)) { + # print "CMD=$cmd,line=$line\n"; + my @out = eval { $self->$parse($cmd, $line); }; + if ($@) { + $self->log(LOGERROR, "$parse($cmd,$line) failed: $@"); + return(DENY, "Failed to parse line"); + } + return @out; + } + return(OK, split(/ +/, $line)); # default :) +} + +sub parse_rcpt { + my ($self,$cmd,$line) = @_; + return (DENY, "Syntax error in command") unless $line =~ s/^to:\s*//i; + return &_get_mail_params($cmd, $line); +} + +sub parse_mail { + my ($self,$cmd,$line) = @_; + return (DENY, "Syntax error in command") unless $line =~ s/^from:\s*//i; + return &_get_mail_params($cmd, $line); +} +### RFC 1869: +## 6. MAIL FROM and RCPT TO Parameters +## [...] +## +## esmtp-cmd ::= inner-esmtp-cmd [SP esmtp-parameters] CR LF +## esmtp-parameters ::= esmtp-parameter *(SP esmtp-parameter) +## esmtp-parameter ::= esmtp-keyword ["=" esmtp-value] +## esmtp-keyword ::= (ALPHA / DIGIT) *(ALPHA / DIGIT / "-") +## +## ; syntax and values depend on esmtp-keyword +## esmtp-value ::= 1* 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; diff --git a/lib/Qpsmtpd/ConfigServer.pm b/lib/Qpsmtpd/ConfigServer.pm new file mode 100644 index 0000000..a112545 --- /dev/null +++ b/lib/Qpsmtpd/ConfigServer.pm @@ -0,0 +1,287 @@ +package Qpsmtpd::ConfigServer; + +use base ('Danga::Client'); +use Qpsmtpd::Constants; + +use strict; + +use fields qw( + _auth + _commands + _config_cache + _connection + _transaction + _test_mode + _extras + other_fds +); + +my $PROMPT = "Enter command: "; + +sub new { + my Qpsmtpd::ConfigServer $self = shift; + + $self = fields::new($self) unless ref $self; + $self->SUPER::new( @_ ); + $self->write($PROMPT); + return $self; +} + +sub max_idle_time { 3600 } # one hour + +sub process_line { + my $self = shift; + my $line = shift || return; + if ($::DEBUG > 1) { print "$$:".($self+0)."C($self->{mode}): $line"; } + local $SIG{ALRM} = sub { + my ($pkg, $file, $line) = caller(); + die "ALARM: $pkg, $file, $line"; + }; + my $prev = alarm(2); # must process a command in < 2 seconds + my $resp = eval { $self->_process_line($line) }; + alarm($prev); + if ($@) { + print STDERR "Error: $@\n"; + } + return $resp || ''; +} + +sub respond { + my $self = shift; + my (@messages) = @_; + while (my $msg = shift @messages) { + $self->write("$msg\r\n"); + } + return; +} + +sub fault { + my $self = shift; + my ($msg) = shift || "program fault - command not performed"; + print STDERR "$0 [$$]: $msg ($!)\n"; + $self->respond("Error - " . $msg); + return $PROMPT; +} + +sub _process_line { + my $self = shift; + my $line = shift; + + $line =~ s/\r?\n//; + my ($cmd, @params) = split(/ +/, $line); + my $meth = "cmd_" . lc($cmd); + if (my $lookup = $self->can($meth)) { + my $resp = eval { + $lookup->($self, @params); + }; + if ($@) { + my $error = $@; + chomp($error); + Qpsmtpd->log(LOGERROR, "Command Error: $error"); + return $self->fault("command '$cmd' failed unexpectedly"); + } + return "$resp\n$PROMPT"; + } + else { + # No such method - i.e. unrecognized command + return $self->fault("command '$cmd' unrecognised"); + } +} + +my %helptext = ( + help => "HELP [CMD] - Get help on all commands or a specific command", + status => "STATUS - Returns status information about current connections", + list => "LIST [LIMIT] - List the connections, specify limit or negative limit to shrink list", + kill => "KILL (\$IP | \$REF) - Disconnect all connections from \$IP or connection reference \$REF", + pause => "PAUSE - Stop accepting new connections", + continue => "CONTINUE - Resume accepting connections", + reload => "RELOAD - Reload all plugins and config", + quit => "QUIT - Exit the config server", + ); + +sub cmd_help { + my $self = shift; + my ($subcmd) = @_; + + $subcmd ||= 'help'; + $subcmd = lc($subcmd); + + if ($subcmd eq 'help') { + my $txt = join("\n", map { substr($_, 0, index($_, "-")) } sort values(%helptext)); + return "Available Commands:\n\n$txt\n"; + } + my $txt = $helptext{$subcmd} || "Unrecognised help option. Try 'help' for a full list."; + return "$txt\n"; +} + +sub cmd_quit { + my $self = shift; + $self->close; +} + +sub cmd_shutdown { + exit; +} + +sub cmd_pause { + my $self = shift; + + my $other_fds = $self->OtherFds; + + $self->{other_fds} = { %$other_fds }; + %$other_fds = (); + return "PAUSED"; +} + +sub cmd_continue { + my $self = shift; + + my $other_fds = $self->{other_fds}; + + $self->OtherFds( %$other_fds ); + %$other_fds = (); + return "UNPAUSED"; +} + +sub cmd_status { + my $self = shift; + +# Status should show: +# - Total time running +# - Total number of mails received +# - Total number of mails rejected (5xx) +# - Total number of mails tempfailed (5xx) +# - Avg number of mails/minute +# - Number of current connections +# - Number of outstanding DNS queries + + my $output = "Current Status as of " . gmtime() . " GMT\n\n"; + + if (defined &Qpsmtpd::Plugin::stats::get_stats) { + # Stats plugin is loaded + $output .= Qpsmtpd::Plugin::stats->get_stats; + } + + my $descriptors = Danga::Socket->DescriptorMap; + + my $current_connections = 0; + my $current_dns = 0; + foreach my $fd (keys %$descriptors) { + my $pob = $descriptors->{$fd}; + if ($pob->isa("Qpsmtpd::PollServer")) { + $current_connections++; + } + elsif ($pob->isa("ParaDNS::Resolver")) { + $current_dns = $pob->pending; + } + } + + $output .= "Curr Connections: $current_connections / $::MAXconn\n". + "Curr DNS Queries: $current_dns"; + + return $output; +} + +sub cmd_list { + my $self = shift; + my ($count) = @_; + + my $descriptors = Danga::Socket->DescriptorMap; + + my $list = "Current" . ($count ? (($count > 0) ? " Oldest $count" : " Newest ".-$count) : "") . " Connections: \n\n"; + my @all; + foreach my $fd (keys %$descriptors) { + my $pob = $descriptors->{$fd}; + if ($pob->isa("Qpsmtpd::PollServer")) { + next unless $pob->connection->remote_ip; # haven't even started yet + push @all, [$pob+0, $pob->connection->remote_ip, + $pob->connection->remote_host, $pob->uptime]; + } + } + + @all = sort { $a->[3] <=> $b->[3] } @all; + if ($count) { + if ($count > 0) { + @all = @all[$#all-($count-1) .. $#all]; + } + else { + @all = @all[0..(abs($count) - 1)]; + } + } + foreach my $item (@all) { + $list .= sprintf("%x : %s [%s] Connected %0.2fs\n", map { defined()?$_:'' } @$item); + } + + return $list; +} + +sub cmd_kill { + my $self = shift; + my ($match) = @_; + + return "SYNTAX: KILL (\$IP | \$REF)\n" unless $match; + + my $descriptors = Danga::Socket->DescriptorMap; + + my $killed = 0; + my $is_ip = (index($match, '.') >= 0); + foreach my $fd (keys %$descriptors) { + my $pob = $descriptors->{$fd}; + if ($pob->isa("Qpsmtpd::PollServer")) { + if ($is_ip) { + next unless $pob->connection->remote_ip; # haven't even started yet + if ($pob->connection->remote_ip eq $match) { + $pob->write("550 Your connection has been killed by an administrator\r\n"); + $pob->disconnect; + $killed++; + } + } + else { + # match by ID + if ($pob+0 == hex($match)) { + $pob->write("550 Your connection has been killed by an administrator\r\n"); + $pob->disconnect; + $killed++; + } + } + } + } + + return "Killed $killed connection" . ($killed > 1 ? "s" : "") . "\n"; +} + +sub cmd_dump { + my $self = shift; + my ($ref) = @_; + + return "SYNTAX: DUMP \$REF\n" unless $ref; + require Data::Dumper; + $Data::Dumper::Indent=1; + + my $descriptors = Danga::Socket->DescriptorMap; + foreach my $fd (keys %$descriptors) { + my $pob = $descriptors->{$fd}; + if ($pob->isa("Qpsmtpd::PollServer")) { + if ($pob+0 == hex($ref)) { + return Data::Dumper::Dumper($pob); + } + } + } + + return "Unable to find the connection: $ref. Try the LIST command\n"; +} + +1; +__END__ + +=head1 NAME + +Qpsmtpd::ConfigServer - a configuration server for qpsmtpd + +=head1 DESCRIPTION + +When qpsmtpd runs in multiplex mode it also provides a config server that you +can connect to. This allows you to view current connection statistics and other +gumph that you probably don't care about. + +=cut diff --git a/lib/Qpsmtpd/Connection.pm b/lib/Qpsmtpd/Connection.pm new file mode 100644 index 0000000..99b7b38 --- /dev/null +++ b/lib/Qpsmtpd/Connection.pm @@ -0,0 +1,228 @@ +package Qpsmtpd::Connection; +use strict; + +# All of these parameters depend only on the physical connection, +# i.e. not on anything sent from the remote machine. Hence, they +# are an appropriate set to use for either start() or clone(). Do +# not add parameters here unless they also meet that criteria. +my @parameters = qw( + remote_host + remote_ip + remote_info + remote_port + local_ip + local_port + relay_client +); + + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = {}; + bless ($self, $class); +} + +sub start { + my $self = shift; + $self = $self->new(@_) unless ref $self; + + my %args = @_; + + foreach my $f ( @parameters ) { + $self->$f($args{$f}) if $args{$f}; + } + + return $self; +} + +sub clone { + my $self = shift; + my %args = @_; + my $new = $self->new(); + foreach my $f ( @parameters ) { + $new->$f($self->$f()) if $self->$f(); + } + $new->{_notes} = $self->{_notes} if defined $self->{_notes}; + # reset the old connection object like it's done at the end of a connection + # to prevent leaks (like prefork/tls problem with the old SSL file handle + # still around) + $self->reset unless $args{no_reset}; + # should we generate a new id here? + return $new; +} + +sub remote_host { + my $self = shift; + @_ and $self->{_remote_host} = shift; + $self->{_remote_host}; +} + +sub remote_ip { + my $self = shift; + @_ and $self->{_remote_ip} = shift; + $self->{_remote_ip}; +} + +sub remote_port { + my $self = shift; + @_ and $self->{_remote_port} = shift; + $self->{_remote_port}; +} + +sub local_ip { + my $self = shift; + @_ and $self->{_local_ip} = shift; + $self->{_local_ip}; +} + +sub local_port { + my $self = shift; + @_ and $self->{_local_port} = shift; + $self->{_local_port}; +} + + +sub remote_info { + my $self = shift; + @_ and $self->{_remote_info} = shift; + $self->{_remote_info}; +} + +sub relay_client { + my $self = shift; + @_ and $self->{_relay_client} = shift; + $self->{_relay_client}; +} + +sub hello { + my $self = shift; + @_ and $self->{_hello} = shift; + $self->{_hello}; +} + +sub hello_host { + my $self = shift; + @_ and $self->{_hello_host} = shift; + $self->{_hello_host}; +} + +sub notes { + my ($self,$key) = (shift,shift); + # Check for any additional arguments passed by the caller -- including undef + return $self->{_notes}->{$key} unless @_; + return $self->{_notes}->{$key} = shift; +} + +sub reset { + my $self = shift; + $self->{_notes} = undef; + $self = $self->new; +} + +1; + +__END__ + +=head1 NAME + +Qpsmtpd::Connection - A single SMTP connection + +=head1 SYNOPSIS + + my $rdns = $qp->connection->remote_host; + my $ip = $qp->connection->remote_ip; + +=head1 DESCRIPTION + +This class contains details about an individual SMTP connection. A +connection lasts the lifetime of a TCP connection to the SMTP server. + +See also L 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 diff --git a/lib/Qpsmtpd/Constants.pm b/lib/Qpsmtpd/Constants.pm new file mode 100644 index 0000000..ccd8440 --- /dev/null +++ b/lib/Qpsmtpd/Constants.pm @@ -0,0 +1,110 @@ +package Qpsmtpd::Constants; +use strict; +require Exporter; + +# log levels +my %log_levels = ( + LOGDEBUG => 7, + LOGINFO => 6, + LOGNOTICE => 5, + LOGWARN => 4, + LOGERROR => 3, + LOGCRIT => 2, + LOGALERT => 1, + LOGEMERG => 0, + LOGRADAR => 0, +); + +# return codes +my %return_codes = ( + OK => 900, + DENY => 901, # 550 + DENYSOFT => 902, # 450 + DENYHARD => 903, # 550 + disconnect (deprecated in 0.29) + DENY_DISCONNECT => 903, # 550 + disconnect + DENYSOFT_DISCONNECT => 904, # 450 + disconnect + DECLINED => 909, + DONE => 910, + CONTINUATION => 911, # deprecated - use YIELD + YIELD => 911, +); + +use vars qw(@ISA @EXPORT); +@ISA = qw(Exporter); +@EXPORT = (keys(%return_codes), keys(%log_levels), "return_code", "log_level"); + +foreach (keys %return_codes ) { + eval "use constant $_ => ".$return_codes{$_}; +} + +foreach (keys %log_levels ) { + eval "use constant $_ => ".$log_levels{$_}; +} + +sub return_code { + my $test = shift; + if ( $test =~ /^\d+$/ ) { # need to return the textural form + foreach ( keys %return_codes ) { + return $_ if $return_codes{$_} =~ /$test/; + } + } + else { # just return the numeric value + return $return_codes{$test}; + } +} + +sub log_level { + my $test = shift; + if ( $test =~ /^\d+$/ ) { # need to return the textural form + foreach ( keys %log_levels ) { + return $_ if $log_levels{$_} =~ /$test/; + } + } + else { # just return the numeric value + return $log_levels{$test}; + } +} + +1; + +=head1 NAME + +Qpsmtpd::Constants - Constants for plugins to use + +=head1 CONSTANTS + +See L 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 diff --git a/lib/Qpsmtpd/DSN.pm b/lib/Qpsmtpd/DSN.pm new file mode 100644 index 0000000..d446edd --- /dev/null +++ b/lib/Qpsmtpd/DSN.pm @@ -0,0 +1,621 @@ +# +# Enhanced Mail System Status Codes - RFC 1893 +# +package Qpsmtpd::DSN; +use strict; +use Qpsmtpd::Constants; + +=head1 NAME + +Qpsmtpd::DSN - Enhanced Mail System Status Codes - RFC 1893 + +=head1 DESCRIPTION + +The B 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 diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm new file mode 100644 index 0000000..57a8614 --- /dev/null +++ b/lib/Qpsmtpd/Plugin.pm @@ -0,0 +1,292 @@ +package Qpsmtpd::Plugin; + +use strict; +use warnings; + +use Qpsmtpd::Constants; + +# more or less in the order they will fire +our @hooks = qw( + logging config post-fork pre-connection connect ehlo_parse ehlo + helo_parse helo auth_parse auth auth-plain auth-login auth-cram-md5 + rcpt_parse rcpt_pre rcpt mail_parse mail mail_pre + data data_headers_end data_post queue_pre queue queue_post vrfy noop + quit reset_transaction disconnect post-connection + unrecognized_command deny ok received_line help +); +our %hooks = map { $_ => 1 } @hooks; + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + bless ({}, $class); +} + +sub hook_name { + return shift->{_hook}; +} + +sub register_hook { + my ($plugin, $hook, $method, $unshift) = @_; + + die $plugin->plugin_name . " : Invalid hook: $hook" unless $hooks{$hook}; + + $plugin->{_qp}->log(LOGDEBUG, $plugin->plugin_name, "hooking", $hook) + unless $hook =~ /logging/; # can't log during load_logging() + + # I can't quite decide if it's better to parse this code ref or if + # we should pass the plugin object and method name ... hmn. + $plugin->qp->_register_hook + ($hook, + { code => sub { local $plugin->{_qp} = shift; + local $plugin->{_hook} = $hook; + $plugin->$method(@_) + }, + name => $plugin->plugin_name, + }, + $unshift, + ); +} + +sub _register { + my $self = shift; + my $qp = shift; + local $self->{_qp} = $qp; + $self->init($qp, @_) if $self->can('init'); + $self->_register_standard_hooks($qp, @_); + $self->register($qp, @_) if $self->can('register'); +} + +sub qp { + shift->{_qp}; +} + +sub log { + my $self = shift; + return if defined $self->{_hook} && $self->{_hook} eq 'logging'; + my $level = $self->adjust_log_level( shift, $self->plugin_name ); + $self->{_qp}->varlog($level, $self->{_hook}, $self->plugin_name, @_); +} + +sub adjust_log_level { + my ( $self, $cur_level, $plugin_name) = @_; + + my $adj = $self->{_args}{loglevel} or return $cur_level; + + return $adj if $adj =~ m/^[01234567]$/; # a raw syslog numeral + + if ( $adj !~ /^[\+\-][\d]$/ ) { + $self->log( LOGERROR, $self-"invalid $plugin_name loglevel setting ($adj)" ); + undef $self->{_args}{loglevel}; # only complain once per plugin + return $cur_level; + }; + + my $operator = substr($adj, 0, 1); + my $adjust = substr($adj, -1, 1); + + my $new_level = $operator eq '+' ? $cur_level + $adjust : $cur_level - $adjust; + + $new_level = 7 if $new_level > 7; + $new_level = 0 if $new_level < 0; + + return $new_level; +}; + +sub transaction { + # not sure if this will work in a non-forking or a threaded daemon + shift->qp->transaction; +} + +sub connection { + shift->qp->connection; +} + +sub spool_dir { + shift->qp->spool_dir; +} + +sub auth_user { + shift->qp->auth_user; +} + +sub auth_mechanism { + shift->qp->auth_mechanism; +} + +sub temp_file { + my $self = shift; + my $tempfile = $self->qp->temp_file; + push @{$self->qp->transaction->{_temp_files}}, $tempfile; + return $tempfile; +} + +sub temp_dir { + my $self = shift; + my $tempdir = $self->qp->temp_dir(); + push @{$self->qp->transaction->{_temp_dirs}}, $tempdir; + return $tempdir; +} + +# plugin inheritance: +# usage: +# sub init { +# my $self = shift; +# $self->isa_plugin("rhsbl"); +# $self->SUPER::register(@_); +# } +sub isa_plugin { + my ($self, $parent) = @_; + my ($currentPackage) = caller; + + my $cleanParent = $parent; + $cleanParent =~ s/\W/_/g; + my $newPackage = $currentPackage."::_isa_$cleanParent"; + + # don't reload plugins if they are already loaded + return if defined &{"${newPackage}::plugin_name"}; + + # find $parent in plugin_dirs + my $parent_dir; + for ($self->qp->plugin_dirs) { + if (-e "$_/$parent") { + $parent_dir = $_; + last; + } + } + die "cannot find plugin '$parent'" unless $parent_dir; + + $self->compile($self->plugin_name . "_isa_$cleanParent", + $newPackage, + "$parent_dir/$parent"); + warn "---- $newPackage\n"; + no strict 'refs'; + push @{"${currentPackage}::ISA"}, $newPackage; +} + +# why isn't compile private? it's only called from Plugin and Qpsmtpd. +sub compile { + my ($class, $plugin, $package, $file, $test_mode, $orig_name) = @_; + + my $sub; + open F, $file or die "could not open $file: $!"; + { + local $/ = undef; + $sub = ; + } + 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 get_reject { + my $self = shift; + my $message = shift || "why didn't you pass an error message?"; + my $log_info = shift || ''; + $log_info = ", $log_info" if $log_info; + + my $reject = $self->{_args}{reject}; + if ( defined $reject && ! $reject ) { + $self->log(LOGINFO, 'fail, reject disabled'); + return DECLINED; + }; + + # the naughty plugin will reject later + if ( $reject eq 'naughty' ) { + $self->log(LOGINFO, 'fail, NAUGHTY'); + $self->connection->notes('naughty', $message); + return (DECLINED); + }; + + # they asked for reject, we give them reject + $self->log(LOGINFO, 'fail'.$log_info); + return ( $self->get_reject_type(), $message); +}; + +sub get_reject_type { + my $self = shift; + my $default = shift || DENY; + my $deny = $self->{_args}{reject_type} or return $default; + + return $deny =~ /^(temp|soft)$/i ? DENYSOFT + : $deny =~ /^(perm|hard)$/i ? DENY + : $deny eq 'disconnect' ? DENY_DISCONNECT + : $deny eq 'temp_disconnect' ? DENYSOFT_DISCONNECT + : $default; +}; + +sub is_immune { + my $self = shift; + + if ( $self->qp->connection->relay_client() ) { + # set by plugins/relay, or Qpsmtpd::Auth + $self->log(LOGINFO, "skip, relay client"); + return 1; + }; + if ( $self->qp->connection->notes('whitelisthost') ) { + # set by plugins/dns_whitelist_soft or plugins/whitelist + $self->log(LOGINFO, "skip, whitelisted host"); + return 1; + }; + if ( $self->qp->transaction->notes('whitelistsender') ) { + # set by plugins/whitelist + $self->log(LOGINFO, "skip, whitelisted sender"); + return 1; + }; + if ( $self->connection->notes('naughty') ) { + # see plugins/naughty + $self->log(LOGINFO, "skip, naughty"); + return 1; + }; + if ( $self->connection->notes('rejected') ) { + # http://www.steve.org.uk/Software/ms-lite/ + $self->log(LOGINFO, "skip, already rejected"); + return 1; + }; + return; +}; + +sub _register_standard_hooks { + my ($plugin, $qp) = @_; + + for my $hook (@hooks) { + my $hooksub = "hook_$hook"; + $hooksub =~ s/\W/_/g; + $plugin->register_hook( $hook, $hooksub ) + if ($plugin->can($hooksub)); + } +} + + +1; diff --git a/lib/Qpsmtpd/Plugin/Async/DNSBLBase.pm b/lib/Qpsmtpd/Plugin/Async/DNSBLBase.pm new file mode 100644 index 0000000..0a791f8 --- /dev/null +++ b/lib/Qpsmtpd/Plugin/Async/DNSBLBase.pm @@ -0,0 +1,87 @@ +package Qpsmtpd::Plugin::Async::DNSBLBase; + +# Class methods shared by the async plugins using DNS based blacklists or +# whitelists. + +use strict; +use Qpsmtpd::Constants; +use ParaDNS; + +sub lookup { + my ($class, $qp, $A_lookups, $TXT_lookups) = @_; + + my $total_zones = @$A_lookups + @$TXT_lookups; + + my ($A_pdns, $TXT_pdns); + + if (@$A_lookups) { + $qp->log(LOGDEBUG, "Checking ", + join(", ", @$A_lookups), + " for A record in the background"); + + $A_pdns = ParaDNS->new( + callback => sub { + my ($result, $query) = @_; + return if $result !~ /^\d+\.\d+\.\d+\.\d+$/; + $qp->log(LOGDEBUG, "Result for A $query: $result"); + $class->process_a_result($qp, $result, $query); + }, + finished => sub { + $total_zones -= @$A_lookups; + $class->finished($qp, $total_zones); + }, + hosts => [@$A_lookups], + type => 'A', + client => $qp->input_sock, + ); + + return unless defined $A_pdns; + } + + if (@$TXT_lookups) { + $qp->log(LOGDEBUG, "Checking ", + join(", ", @$TXT_lookups), + " for TXT record in the background"); + + $TXT_pdns = ParaDNS->new( + callback => sub { + my ($result, $query) = @_; + return if $result !~ /[a-z]/; + $qp->log(LOGDEBUG, "Result for TXT $query: $result"); + $class->process_txt_result($qp, $result, $query); + }, + finished => sub { + $total_zones -= @$TXT_lookups; + $class->finished($qp, $total_zones); + }, + hosts => [@$TXT_lookups], + type => 'TXT', + client => $qp->input_sock, + ); + + unless (defined $TXT_pdns) { + undef $A_pdns; + return; + } + } + + return 1; +} + +sub finished { + my ($class, $qp, $total_zones) = @_; + $qp->log(LOGDEBUG, "Finished ($total_zones)"); + $qp->run_continuation unless $total_zones; +} + +# plugins should implement the following two methods to do something +# useful with the results +sub process_a_result { + my ($class, $qp, $result, $query) = @_; +} + +sub process_txt_result { + my ($class, $qp, $result, $query) = @_; +} + +1; diff --git a/lib/Qpsmtpd/PollServer.pm b/lib/Qpsmtpd/PollServer.pm new file mode 100644 index 0000000..9d91af7 --- /dev/null +++ b/lib/Qpsmtpd/PollServer.pm @@ -0,0 +1,349 @@ +package Qpsmtpd::PollServer; + +use base ('Danga::Client', 'Qpsmtpd::SMTP'); +# use fields required to be a subclass of Danga::Client. Have to include +# all fields used by Qpsmtpd.pm here too. +use fields qw( + input_sock + mode + header_lines + in_header + data_size + max_size + hooks + start_time + cmd_timeout + conn + _auth + _auth_mechanism + _auth_state + _auth_ticket + _auth_user + _commands + _config_cache + _connection + _continuation + _extras + _test_mode + _transaction +); +use Qpsmtpd::Constants; +use Qpsmtpd::Address; +use ParaDNS; +use Mail::Header; +use POSIX qw(strftime); +use Socket qw(inet_aton AF_INET CRLF); +use Time::HiRes qw(time); +use strict; + +sub max_idle_time { 60 } +sub max_connect_time { 1200 } + +sub input_sock { + my $self = shift; + @_ and $self->{input_sock} = shift; + $self->{input_sock} || $self; +} + +sub new { + my Qpsmtpd::PollServer $self = shift; + + $self = fields::new($self) unless ref $self; + $self->SUPER::new( @_ ); + $self->{cmd_timeout} = 5; + $self->{start_time} = time; + $self->{mode} = 'connect'; + $self->load_plugins; + $self->load_logging; + + my ($rc, @msg) = $self->run_hooks_no_respond("pre-connection"); + if ($rc == DENYSOFT || $rc == DENYSOFT_DISCONNECT) { + @msg = ("Sorry, try again later") + unless @msg; + $self->respond(451, @msg); + $self->disconnect; + } + elsif ($rc == DENY || $rc == DENY_DISCONNECT) { + @msg = ("Sorry, service not available for you") + unless @msg; + $self->respond(550, @msg); + $self->disconnect; + } + + return $self; +} + +sub uptime { + my Qpsmtpd::PollServer $self = shift; + + return (time() - $self->{start_time}); +} + +sub reset_for_next_message { + my Qpsmtpd::PollServer $self = shift; + $self->SUPER::reset_for_next_message(@_); + + $self->{_commands} = { + ehlo => 1, + helo => 1, + rset => 1, + mail => 1, + rcpt => 1, + data => 1, + help => 1, + vrfy => 1, + noop => 1, + quit => 1, + auth => 0, # disabled by default + }; + $self->{mode} = 'cmd'; + $self->{_extras} = {}; +} + +sub respond { + my Qpsmtpd::PollServer $self = shift; + my ($code, @messages) = @_; + while (my $msg = shift @messages) { + my $line = $code . (@messages ? "-" : " ") . $msg; + $self->write("$line\r\n"); + } + return 1; +} + +sub fault { + my Qpsmtpd::PollServer $self = shift; + $self->SUPER::fault(@_); + return; +} + +my %cmd_cache; + +sub process_line { + my Qpsmtpd::PollServer $self = shift; + my $line = shift || return; + if ($::DEBUG > 1) { print "$$:".($self+0)."C($self->{mode}): $line"; } + if ($self->{mode} eq 'cmd') { + $line =~ s/\r?\n$//s; + $self->connection->notes('original_string', $line); + my ($cmd, @params) = split(/ +/, $line, 2); + my $meth = lc($cmd); + if (my $lookup = $cmd_cache{$meth} || $self->{_commands}->{$meth} && $self->can($meth)) { + $cmd_cache{$meth} = $lookup; + eval { + $lookup->($self, @params); + }; + if ($@) { + my $error = $@; + chomp($error); + $self->log(LOGERROR, "Command Error: $error"); + $self->fault("command '$cmd' failed unexpectedly"); + } + } + else { + # No such method - i.e. unrecognized command + my ($rc, $msg) = $self->run_hooks("unrecognized_command", $meth, @params); + } + } + elsif ($self->{mode} eq 'connect') { + $self->{mode} = 'cmd'; + # I've removed an eval{} from around this. It shouldn't ever die() + # but if it does we're a bit screwed... Ah well :-) + $self->start_conversation; + } + else { + die "Unknown mode"; + } + return; +} + +sub disconnect { + my Qpsmtpd::PollServer $self = shift; + $self->SUPER::disconnect(@_); + $self->close; +} + +sub close { + my Qpsmtpd::PollServer $self = shift; + $self->run_hooks_no_respond("post-connection"); + $self->connection->reset; + $self->SUPER::close; +} + +sub start_conversation { + my Qpsmtpd::PollServer $self = shift; + + my $conn = $self->connection; + # set remote_host, remote_ip and remote_port + my ($ip, $port) = split(':', $self->peer_addr_string); + return $self->close() unless $ip; + $conn->remote_ip($ip); + $conn->remote_port($port); + $conn->remote_info("[$ip]"); + my ($lip,$lport) = split(':', $self->local_addr_string); + $conn->local_ip($lip); + $conn->local_port($lport); + + ParaDNS->new( + finished => sub { $self->continue_read(); $self->run_hooks("connect") }, + # NB: Setting remote_info to the same as remote_host + callback => sub { $conn->remote_info($conn->remote_host($_[0])) }, + host => $ip, + ); + + return; +} + +sub data { + my Qpsmtpd::PollServer $self = shift; + + my ($rc, $msg) = $self->run_hooks("data"); + return 1; +} + +sub data_respond { + my Qpsmtpd::PollServer $self = shift; + my ($rc, $msg) = @_; + if ($rc == DONE) { + return; + } + elsif ($rc == DENY) { + $msg->[0] ||= "Message denied"; + $self->respond(554, @$msg); + $self->reset_transaction(); + return; + } + elsif ($rc == DENYSOFT) { + $msg->[0] ||= "Message denied temporarily"; + $self->respond(451, @$msg); + $self->reset_transaction(); + return; + } + elsif ($rc == DENY_DISCONNECT) { + $msg->[0] ||= "Message denied"; + $self->respond(554, @$msg); + $self->disconnect; + return; + } + elsif ($rc == DENYSOFT_DISCONNECT) { + $msg->[0] ||= "Message denied temporarily"; + $self->respond(451, @$msg); + $self->disconnect; + return; + } + return $self->respond(503, "MAIL first") unless $self->transaction->sender; + return $self->respond(503, "RCPT first") unless $self->transaction->recipients; + + $self->{header_lines} = ''; + $self->{data_size} = 0; + $self->{in_header} = 1; + $self->{max_size} = ($self->config('databytes'))[0] || 0; + + $self->log(LOGDEBUG, "max_size: $self->{max_size} / size: $self->{data_size}"); + + $self->respond(354, "go ahead"); + + my $max_get = $self->{max_size} || 1048576; + $self->get_chunks($max_get, sub { $self->got_data($_[0]) }); + return 1; +} + +sub got_data { + my Qpsmtpd::PollServer $self = shift; + my $data = shift; + + my $done = 0; + my $remainder; + if ($data =~ s/^\.\r\n(.*)\z//ms) { + $remainder = $1; + $done = 1; + } + + # add a transaction->blocked check back here when we have line by line plugin access... + unless (($self->{max_size} and $self->{data_size} > $self->{max_size})) { + $data =~ s/\r\n/\n/mg; + $data =~ s/^\.\./\./mg; + + if ($self->{in_header}) { + $self->{header_lines} .= $data; + + if ($self->{header_lines} =~ s/\n(\n.*)\z/\n/ms) { + $data = $1; + # end of headers + $self->{in_header} = 0; + + # ... need to check that we don't reformat any of the received lines. + # + # 3.8.2 Received Lines in Gatewaying + # When forwarding a message into or out of the Internet environment, a + # gateway MUST prepend a Received: line, but it MUST NOT alter in any + # way a Received: line that is already in the header. + my @header_lines = split(/^/m, $self->{header_lines}); + + my $header = Mail::Header->new(\@header_lines, + Modify => 0, MailFrom => "COERCE"); + $self->transaction->header($header); + $self->transaction->body_write($self->{header_lines}); + $self->{header_lines} = ''; + + #$header->add("X-SMTPD", "qpsmtpd/".$self->version.", http://smtpd.develooper.com/"); + + # FIXME - call plugins to work on just the header here; can + # save us buffering the mail content. + + # Save the start of just the body itself + $self->transaction->set_body_start(); + } + } + + $self->transaction->body_write(\$data); + $self->{data_size} += length $data; + } + + + if ($done) { + $self->end_of_data; + $self->end_get_chunks($remainder); + } + +} + +sub end_of_data { + my Qpsmtpd::PollServer $self = shift; + + #$self->log(LOGDEBUG, "size is at $size\n") unless ($i % 300); + + $self->log(LOGDEBUG, "max_size: $self->{max_size} / size: $self->{data_size}"); + + my $header = $self->transaction->header; + if (!$header) { + $header = Mail::Header->new(Modify => 0, MailFrom => "COERCE"); + $self->transaction->header($header); + } + + my $smtp = $self->connection->hello eq "ehlo" ? "ESMTP" : "SMTP"; + my $esmtp = substr($smtp,0,1) eq "E"; + my $authheader; + my $sslheader; + + if (defined $self->connection->notes('tls_enabled') + and $self->connection->notes('tls_enabled')) + { + $smtp .= "S" if $esmtp; # RFC3848 + $sslheader = "(".$self->connection->notes('tls_socket')->get_cipher()." encrypted) "; + } + + if (defined $self->{_auth} and $self->{_auth} == OK) { + $smtp .= "A" if $esmtp; # RFC3848 + $authheader = "(smtp-auth username $self->{_auth_user}, mechanism $self->{_auth_mechanism})\n"; + } + + $header->add("Received", $self->received_line($smtp, $authheader, $sslheader), 0); + + return $self->respond(552, "Message too big!") if $self->{max_size} and $self->{data_size} > $self->{max_size}; + + my ($rc, $msg) = $self->run_hooks("data_post"); + return 1; +} + +1; + diff --git a/lib/Qpsmtpd/Postfix.pm b/lib/Qpsmtpd/Postfix.pm new file mode 100644 index 0000000..519e5f6 --- /dev/null +++ b/lib/Qpsmtpd/Postfix.pm @@ -0,0 +1,223 @@ +package Qpsmtpd::Postfix; + +=head1 NAME + +Qpsmtpd::Postfix - postfix queueing support for qpsmtpd + +=head2 DESCRIPTION + +This package implements the protocol Postfix servers use to communicate +with each other. See src/global/rec_type.h in the postfix source for +details. + +=cut + +use strict; +use IO::Socket::UNIX; +use IO::Socket::INET; +use vars qw(@ISA); +@ISA = qw(IO::Socket::UNIX); + +my %rec_types; + +sub init { + my ($self) = @_; + + %rec_types = ( + REC_TYPE_SIZE => 'C', # first record, created by cleanup + REC_TYPE_TIME => 'T', # time stamp, required + REC_TYPE_FULL => 'F', # full name, optional + REC_TYPE_INSP => 'I', # inspector transport + REC_TYPE_FILT => 'L', # loop filter transport + REC_TYPE_FROM => 'S', # sender, required + REC_TYPE_DONE => 'D', # delivered recipient, optional + REC_TYPE_RCPT => 'R', # todo recipient, optional + REC_TYPE_ORCP => 'O', # original recipient, optional + REC_TYPE_WARN => 'W', # warning message time + REC_TYPE_ATTR => 'A', # named attribute for extensions + + REC_TYPE_MESG => 'M', # start message records + + REC_TYPE_CONT => 'L', # long data record + REC_TYPE_NORM => 'N', # normal data record + + REC_TYPE_XTRA => 'X', # start extracted records + + REC_TYPE_RRTO => 'r', # return-receipt, from headers + REC_TYPE_ERTO => 'e', # errors-to, from headers + REC_TYPE_PRIO => 'P', # priority + REC_TYPE_VERP => 'V', # VERP delimiters + + REC_TYPE_END => 'E', # terminator, required + + ); + +} + +sub print_rec { + my ($self, $type, @list) = @_; + + die "unknown record type" unless ($rec_types{$type}); + $self->print($rec_types{$type}); + + # the length is a little endian base-128 number where each + # byte except the last has the high bit set: + my $s = "@list"; + my $ln = length($s); + while ($ln >= 0x80) { + my $lnl = $ln & 0x7F; + $ln >>= 7; + $self->print(chr($lnl | 0x80)); + } + $self->print(chr($ln)); + + $self->print($s); +} + +sub print_rec_size { + my ($self, $content_size, $data_offset, $rcpt_count) = @_; + + my $s = sprintf("%15ld %15ld %15ld", $content_size, $data_offset, $rcpt_count); + $self->print_rec('REC_TYPE_SIZE', $s); +} + +sub print_rec_time { + my ($self, $time) = @_; + + $time = time() unless (defined($time)); + + my $s = sprintf("%d", $time); + $self->print_rec('REC_TYPE_TIME', $s); +} + +sub open_cleanup { + my ($class, $socket) = @_; + + my $self; + if ($socket =~ m#^(/.+)#) { + $socket = $1; # un-taint socket path + $self = IO::Socket::UNIX->new(Type => SOCK_STREAM, + Peer => $socket) if $socket; + + } elsif ($socket =~ /(.*):(\d+)/) { + my ($host,$port) = ($1,$2); # un-taint address and port + $self = IO::Socket::INET->new(Proto => 'tcp', + PeerAddr => $host,PeerPort => $port) + if $host and $port; + } + unless (ref $self) { + warn "Couldn't open \"$socket\": $!"; + return; + } + # allow buffered writes + $self->autoflush(0); + bless ($self, $class); + $self->init(); + return $self; +} + +sub print_attr { + my ($self, @kv) = @_; + for (@kv) { + $self->print("$_\0"); + } + $self->print("\0"); +} + +sub get_attr { + my ($self) = @_; + local $/ = "\0"; + my %kv; + for(;;) { + my $k = $self->getline; + chomp($k); + last unless ($k); + my $v = $self->getline; + chomp($v); + $kv{$k} = $v; + } + return %kv; +} + + +=head2 print_msg_line($line) + +print one line of a message to cleanup. + +This removes any linefeed characters from the end of the line +and splits the line across several records if it is longer than +1024 chars. + +=cut + +sub print_msg_line { + my ($self, $line) = @_; + + $line =~ s/\r?\n$//s; + + # split into 1k chunks. + while (length($line) > 1024) { + my $s = substr($line, 0, 1024); + $line = substr($line, 1024); + $self->print_rec('REC_TYPE_CONT', $s); + } + $self->print_rec('REC_TYPE_NORM', $line); +} + +=head2 inject_mail($transaction) + +(class method) inject mail in $transaction into postfix queue via cleanup. +$transaction is supposed to be a Qpsmtpd::Transaction object. + +=cut + +sub inject_mail { + my ($class, $transaction) = @_; + + my @sockets = @{$transaction->notes('postfix-queue-sockets') + // ['/var/spool/postfix/public/cleanup']}; + my $strm; + $strm = $class->open_cleanup($_) and last for @sockets; + die "Unable to open any cleanup sockets!" unless $strm; + + my %at = $strm->get_attr; + my $qid = $at{queue_id}; + print STDERR "qid=$qid\n"; + $strm->print_attr('flags' => $transaction->notes('postfix-queue-flags')); + $strm->print_rec_time(); + $strm->print_rec('REC_TYPE_FROM', $transaction->sender->address|| ""); + for (map { $_->address } $transaction->recipients) { + $strm->print_rec('REC_TYPE_RCPT', $_); + } + # add an empty message length record. + # cleanup is supposed to understand that. + # see src/pickup/pickup.c + $strm->print_rec('REC_TYPE_MESG', ""); + + # a received header has already been added in SMTP.pm + # so we can just copy the message: + + my $hdr = $transaction->header->as_string; + for (split(/\r?\n/, $hdr)) { + print STDERR "hdr: $_\n"; + $strm->print_msg_line($_); + } + $transaction->body_resetpos; + while (my $line = $transaction->body_getline) { + # print STDERR "body: $line\n"; + $strm->print_msg_line($line); + } + + # finish it. + $strm->print_rec('REC_TYPE_XTRA', ""); + $strm->print_rec('REC_TYPE_END', ""); + $strm->flush(); + %at = $strm->get_attr; + my $status = $at{status}; + my $reason = $at{reason}; + $strm->close(); + return wantarray ? ($status, $qid, $reason || "") : $status; +} + +1; +# vim:sw=2 diff --git a/lib/Qpsmtpd/Postfix/Constants.pm b/lib/Qpsmtpd/Postfix/Constants.pm new file mode 100644 index 0000000..c06ad3f --- /dev/null +++ b/lib/Qpsmtpd/Postfix/Constants.pm @@ -0,0 +1,86 @@ +# +# Qpsmtpd::Postfix::Constants +# +# This is a generated file, do not edit +# +# created by pf2qp.pl v0.1 @ Sun Oct 29 09:10:18 2006 +# postfix version 2.4 +# +package Qpsmtpd::Postfix::Constants; + +use Qpsmtpd::Constants; + +require Exporter; + +use vars qw(@ISA @EXPORT %cleanup_soft %cleanup_hard $postfix_version); +use strict; + +@ISA = qw(Exporter); +@EXPORT = qw( + %cleanup_soft + %cleanup_hard + $postfix_version + CLEANUP_FLAG_NONE + CLEANUP_FLAG_BOUNCE + CLEANUP_FLAG_FILTER + CLEANUP_FLAG_HOLD + CLEANUP_FLAG_DISCARD + CLEANUP_FLAG_BCC_OK + CLEANUP_FLAG_MAP_OK + CLEANUP_FLAG_MILTER + CLEANUP_FLAG_FILTER_ALL + CLEANUP_FLAG_MASK_EXTERNAL + CLEANUP_FLAG_MASK_INTERNAL + CLEANUP_FLAG_MASK_EXTRA + CLEANUP_STAT_OK + CLEANUP_STAT_BAD + CLEANUP_STAT_WRITE + CLEANUP_STAT_SIZE + CLEANUP_STAT_CONT + CLEANUP_STAT_HOPS + CLEANUP_STAT_RCPT + CLEANUP_STAT_PROXY + CLEANUP_STAT_DEFER + CLEANUP_STAT_MASK_CANT_BOUNCE + CLEANUP_STAT_MASK_INCOMPLETE +); + +$postfix_version = "2.4"; +use constant CLEANUP_FLAG_NONE => 0; # /* No special features */ +use constant CLEANUP_FLAG_BOUNCE => (1<<0); # /* Bounce bad messages */ +use constant CLEANUP_FLAG_FILTER => (1<<1); # /* Enable header/body checks */ +use constant CLEANUP_FLAG_HOLD => (1<<2); # /* Place message on hold */ +use constant CLEANUP_FLAG_DISCARD => (1<<3); # /* Discard message silently */ +use constant CLEANUP_FLAG_BCC_OK => (1<<4); # /* Ok to add auto-BCC addresses */ +use constant CLEANUP_FLAG_MAP_OK => (1<<5); # /* Ok to map addresses */ +use constant CLEANUP_FLAG_MILTER => (1<<6); # /* Enable Milter applications */ +use constant CLEANUP_FLAG_FILTER_ALL => (CLEANUP_FLAG_FILTER | CLEANUP_FLAG_MILTER); +use constant CLEANUP_FLAG_MASK_EXTERNAL => (CLEANUP_FLAG_FILTER_ALL | CLEANUP_FLAG_BCC_OK | CLEANUP_FLAG_MAP_OK); +use constant CLEANUP_FLAG_MASK_INTERNAL => CLEANUP_FLAG_MAP_OK; +use constant CLEANUP_FLAG_MASK_EXTRA => (CLEANUP_FLAG_HOLD | CLEANUP_FLAG_DISCARD); + +use constant CLEANUP_STAT_OK => 0; # /* Success. */ +use constant CLEANUP_STAT_BAD => (1<<0); # /* Internal protocol error */ +use constant CLEANUP_STAT_WRITE => (1<<1); # /* Error writing message file */ +use constant CLEANUP_STAT_SIZE => (1<<2); # /* Message file too big */ +use constant CLEANUP_STAT_CONT => (1<<3); # /* Message content rejected */ +use constant CLEANUP_STAT_HOPS => (1<<4); # /* Too many hops */ +use constant CLEANUP_STAT_RCPT => (1<<6); # /* No recipients found */ +use constant CLEANUP_STAT_PROXY => (1<<7); # /* Proxy reject */ +use constant CLEANUP_STAT_DEFER => (1<<8); # /* Temporary reject */ +use constant CLEANUP_STAT_MASK_CANT_BOUNCE => (CLEANUP_STAT_BAD | CLEANUP_STAT_WRITE | CLEANUP_STAT_DEFER); +use constant CLEANUP_STAT_MASK_INCOMPLETE => (CLEANUP_STAT_BAD | CLEANUP_STAT_WRITE | CLEANUP_STAT_SIZE | CLEANUP_STAT_DEFER); + +%cleanup_soft = ( + CLEANUP_STAT_DEFER => "service unavailable (#4.7.1)", + CLEANUP_STAT_PROXY => "queue file write error (#4.3.0)", + CLEANUP_STAT_BAD => "internal protocol error (#4.3.0)", + CLEANUP_STAT_WRITE => "queue file write error (#4.3.0)", +); +%cleanup_hard = ( + CLEANUP_STAT_RCPT => "no recipients specified (#5.1.0)", + CLEANUP_STAT_HOPS => "too many hops (#5.4.0)", + CLEANUP_STAT_SIZE => "message file too big (#5.3.4)", + CLEANUP_STAT_CONT => "message content rejected (#5.7.1)", +); +1; diff --git a/lib/Qpsmtpd/Postfix/pf2qp.pl b/lib/Qpsmtpd/Postfix/pf2qp.pl new file mode 100755 index 0000000..0cd7894 --- /dev/null +++ b/lib/Qpsmtpd/Postfix/pf2qp.pl @@ -0,0 +1,115 @@ +#/usr/bin/perl -w +# +# +my $version = "0.1"; +$0 =~ s#.*/##; +my $path = $&; # sneaky way to get path back + +my $POSTFIX_SRC = shift || die <<"EOF"; +Usage: + $0 /path/to/postfix/source + +EOF + +my $header = "$POSTFIX_SRC/src/global/cleanup_user.h"; +my $src = "$POSTFIX_SRC/src/global/cleanup_strerror.c"; +my $pf_vers = "$POSTFIX_SRC/src/global/mail_version.h"; +my $postfix_version = ""; + +open VERS, $pf_vers + or die "Could not open $pf_vers: $!\n"; +while () { + 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; diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm new file mode 100644 index 0000000..5394646 --- /dev/null +++ b/lib/Qpsmtpd/SMTP.pm @@ -0,0 +1,854 @@ +package Qpsmtpd::SMTP; +use Qpsmtpd; +@ISA = qw(Qpsmtpd); +my %auth_mechanisms = (); + +package Qpsmtpd::SMTP; +use strict; +use Carp; + +use Qpsmtpd::Connection; +use Qpsmtpd::Transaction; +use Qpsmtpd::Plugin; +use Qpsmtpd::Constants; +use Qpsmtpd::Auth; +use Qpsmtpd::Address (); +use Qpsmtpd::Command; + +use Mail::Header (); +#use Data::Dumper; +use POSIX qw(strftime); +use Net::DNS; + +# this is only good for forkserver +# can't set these here, cause forkserver resets them +#$SIG{ALRM} = sub { respond(421, "Game over pal, game over. You got a timeout; I just can't wait that long..."); exit }; +#$SIG{ALRM} = sub { warn "Connection Timed Out\n"; exit; }; + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + + my %args = @_; + + my $self = bless ({ args => \%args }, $class); + + my (@commands) = qw(ehlo helo rset mail rcpt data help vrfy noop quit); + my (%commands); @commands{@commands} = ('') x @commands; + # this list of valid commands should probably be a method or a set of methods + $self->{_commands} = \%commands; + $self->SUPER::_restart(%args) if $args{restart}; # calls Qpsmtpd::_restart() + $self; +} + +sub command_counter { + my $self = shift; + $self->{_counter} || 0; +} + +sub dispatch { + my $self = shift; + my ($cmd) = lc shift; + + $self->{_counter}++; + + if ($cmd !~ /^(\w{1,12})$/ or !exists $self->{_commands}->{$1}) { + $self->run_hooks("unrecognized_command", $cmd, @_); + return 1; + } + $cmd = $1; + + my ($result) = eval { $self->$cmd(@_) }; + $self->log(LOGERROR, "XX: $@") if $@; + return $result if defined $result; + return $self->fault("command '$cmd' failed unexpectedly"); +} + +sub unrecognized_command_respond { + my ($self, $rc, $msg) = @_; + if ($rc == DENY_DISCONNECT) { + $self->respond(521, @$msg); + $self->disconnect; + } + elsif ($rc == DENY) { + $self->respond(500, @$msg); + } + elsif ($rc != DONE) { + $self->respond(500, "Unrecognized command"); + } +} + +sub fault { + my $self = shift; + my ($msg) = shift || "program fault - command not performed"; + my ($name) = split /\s+/, $0, 2; + print STDERR $name,"[$$]: $msg ($!)\n"; + return $self->respond(451, "Internal error - try again later - " . $msg); +} + + +sub start_conversation { + my $self = shift; + # this should maybe be called something else than "connect", see + # lib/Qpsmtpd/TcpServer.pm for more confusion. + $self->run_hooks("connect"); + return DONE; +} + +sub connect_respond { + my ($self, $rc, $msg) = @_; + if ($rc == DENY || $rc == DENY_DISCONNECT) { + $msg->[0] ||= 'Connection from you denied, bye bye.'; + $self->respond(550, @$msg); + $self->disconnect; + } + elsif ($rc == DENYSOFT || $rc == DENYSOFT_DISCONNECT) { + $msg->[0] ||= 'Connection from you temporarily denied, bye bye.'; + $self->respond(450, @$msg); + $self->disconnect; + } + elsif ($rc != DONE) { + my $greets = $self->config('smtpgreeting'); + if ( $greets ) { + $greets .= " ESMTP" unless $greets =~ /(^|\W)ESMTP(\W|$)/; + } + else { + $greets = $self->config('me') + . " ESMTP qpsmtpd " + . $self->version + . " ready; send us your mail, but not your spam."; + } + + $self->respond(220, $greets); + } +} + +sub transaction { + my $self = shift; + return $self->{_transaction} || $self->reset_transaction(); +} + +sub reset_transaction { + my $self = shift; + $self->run_hooks("reset_transaction") if $self->{_transaction}; + return $self->{_transaction} = Qpsmtpd::Transaction->new(); +} + + +sub connection { + my $self = shift; + @_ and $self->{_connection} = shift; + return $self->{_connection} || ($self->{_connection} = Qpsmtpd::Connection->new()); +} + +sub helo { + my ($self, $line) = @_; + my ($rc, @msg) = $self->run_hooks('helo_parse'); + my ($ok, $hello_host, @stuff) = Qpsmtpd::Command->parse('helo', $line, $msg[0]); + + return $self->respond (501, + "helo requires domain/address - see RFC-2821 4.1.1.1") unless $hello_host; + my $conn = $self->connection; + return $self->respond (503, "but you already said HELO ...") if $conn->hello; + + $self->run_hooks("helo", $hello_host, @stuff); +} + +sub helo_respond { + my ($self, $rc, $msg, $args) = @_; + my ($hello_host) = @$args; + if ($rc == DONE) { + # do nothing: + 1; + } elsif ($rc == DENY) { + $self->respond(550, @$msg); + } elsif ($rc == DENYSOFT) { + $self->respond(450, @$msg); + } elsif ($rc == DENY_DISCONNECT) { + $self->respond(550, @$msg); + $self->disconnect; + } elsif ($rc == DENYSOFT_DISCONNECT) { + $self->respond(450, @$msg); + $self->disconnect; + } else { + my $conn = $self->connection; + $conn->hello("helo"); + $conn->hello_host($hello_host); + $self->transaction; + $self->respond(250, $self->config('me') ." Hi " . $conn->remote_info . " [" . $conn->remote_ip ."]; I am so happy to meet you."); + } +} + +sub ehlo { + my ($self, $line) = @_; + my ($rc, @msg) = $self->run_hooks('ehlo_parse'); + my ($ok, $hello_host, @stuff) = Qpsmtpd::Command->parse('ehlo', $line, $msg[0]); + return $self->respond (501, + "ehlo requires domain/address - see RFC-2821 4.1.1.1") unless $hello_host; + my $conn = $self->connection; + return $self->respond (503, "but you already said HELO ...") if $conn->hello; + + $self->run_hooks("ehlo", $hello_host, @stuff); +} + +sub ehlo_respond { + my ($self, $rc, $msg, $args) = @_; + my ($hello_host) = @$args; + if ($rc == DONE) { + # do nothing: + 1; + } elsif ($rc == DENY) { + $self->respond(550, @$msg); + } elsif ($rc == DENYSOFT) { + $self->respond(450, @$msg); + } elsif ($rc == DENY_DISCONNECT) { + $self->respond(550, @$msg); + $self->disconnect; + } elsif ($rc == DENYSOFT_DISCONNECT) { + $self->respond(450, @$msg); + $self->disconnect; + } else { + my $conn = $self->connection; + $conn->hello("ehlo"); + $conn->hello_host($hello_host); + $self->transaction; + + my @capabilities = $self->transaction->notes('capabilities') + ? @{ $self->transaction->notes('capabilities') } + : (); + + # Check for possible AUTH mechanisms +HOOK: foreach my $hook ( keys %{$self->hooks} ) { + if ( $hook =~ m/^auth-?(.+)?$/ ) { + if ( defined $1 ) { + $auth_mechanisms{uc($1)} = 1; + } + else { # at least one polymorphous auth provider + %auth_mechanisms = map {$_,1} qw(PLAIN CRAM-MD5 LOGIN); + last HOOK; + } + } + } + + # Check if we should only offer AUTH after TLS is completed + my $tls_before_auth = ($self->config('tls_before_auth') ? ($self->config('tls_before_auth'))[0] && $self->transaction->notes('tls_enabled') : 0); + if ( %auth_mechanisms && !$tls_before_auth) { + push @capabilities, 'AUTH '.join(" ",keys(%auth_mechanisms)); + $self->{_commands}->{'auth'} = ""; + } + + $self->respond(250, + $self->config("me") . " Hi " . $conn->remote_info . " [" . $conn->remote_ip ."]", + "PIPELINING", + "8BITMIME", + ($self->config('databytes') ? "SIZE ". ($self->config('databytes'))[0] : ()), + @capabilities, + ); + } +} + +sub auth { + my ($self, $line) = @_; + $self->run_hooks('auth_parse', $line); +} + +sub auth_parse_respond { + my ($self, $rc, $msg, $args) = @_; + my ($line) = @$args; + + my ($ok, $mechanism, @stuff) = Qpsmtpd::Command->parse('auth', $line, $msg->[0]); + return $self->respond(501, $mechanism || "Syntax error in command") + unless ($ok == OK); + + $mechanism = lc($mechanism); + + #they AUTH'd once already + return $self->respond( 503, "but you already said AUTH ..." ) + if ( defined $self->{_auth} && $self->{_auth} == OK ); + + return $self->respond( 503, "AUTH not defined for HELO" ) + if ( $self->connection->hello eq "helo" ); + + return $self->respond( 503, "SSL/TLS required before AUTH" ) + if ( ($self->config('tls_before_auth'))[0] + && $self->transaction->notes('tls_enabled') ); + + # we don't have a plugin implementing this auth mechanism, 504 + if( exists $auth_mechanisms{uc($mechanism)} ) { + return $self->{_auth} = Qpsmtpd::Auth::SASL( $self, $mechanism, @stuff ); + }; + + $self->respond( 504, "Unimplemented authentification mechanism: $mechanism" ); + return DENY; +} + +sub mail { + my ($self, $line) = @_; + # -> from RFC2821 + # The MAIL command (or the obsolete SEND, SOML, or SAML commands) + # begins a mail transaction. Once started, a mail transaction + # consists of a transaction beginning command, one or more RCPT + # commands, and a DATA command, in that order. A mail transaction + # may be aborted by the RSET (or a new EHLO) command. There may be + # zero or more transactions in a session. MAIL (or SEND, SOML, or + # SAML) MUST NOT be sent if a mail transaction is already open, + # i.e., it should be sent only if no mail transaction had been + # started in the session, or it the previous one successfully + # concluded with a successful DATA command, or if the previous one + # was aborted with a RSET. + + # sendmail (8.11) rejects a second MAIL command. + + # qmail-smtpd (1.03) accepts it and just starts a new transaction. + # Since we are a qmail-smtpd thing we will do the same. + + $self->reset_transaction; + + unless ($self->connection->hello) { + return $self->respond(503, "please say hello first ..."); + } + else { + $self->log(LOGDEBUG, "full from_parameter: $line"); + $self->run_hooks("mail_parse", $line); + } +} + +sub mail_parse_respond { + my ($self, $rc, $msg, $args) = @_; + my ($line) = @$args; + my ($ok, $from, @params) = Qpsmtpd::Command->parse('mail', $line, $msg->[0]); + return $self->respond(501, $from || "Syntax error in command") + unless ($ok == OK); + my %param; + foreach (@params) { + my ($k,$v) = split /=/, $_, 2; + $param{lc $k} = $v; + } + # to support addresses without <> we now require a plugin + # hooking "mail_pre" to + # return (OK, "<$from>"); + # (...or anything else parseable by Qpsmtpd::Address ;-)) + # see also comment in sub rcpt() + $self->run_hooks("mail_pre", $from, \%param); +} + +sub mail_pre_respond { + my ($self, $rc, $msg, $args) = @_; + my ($from, $param) = @$args; + if ($rc == OK) { + $from = shift @$msg; + } + + $self->log(LOGDEBUG, "from email address : [$from]"); + return $self->respond(501, "could not parse your mail from command") + unless $from =~ /^<.*>$/; + + if ($from eq "<>" or $from =~ m/\[undefined\]/ or $from eq "<#@[]>") { + $from = Qpsmtpd::Address->new("<>"); + } + else { + $from = (Qpsmtpd::Address->parse($from))[0]; + } + return $self->respond(501, "could not parse your mail from command") unless $from; + + $self->run_hooks("mail", $from, %$param); +} + +sub mail_respond { + my ($self, $rc, $msg, $args) = @_; + my ($from, $param) = @$args; + if ($rc == DONE) { + return 1; + } + elsif ($rc == DENY) { + $msg->[0] ||= $from->format . ', denied'; + $self->log(LOGINFO, "deny mail from " . $from->format . " (@$msg)"); + $self->respond(550, @$msg); + } + elsif ($rc == DENYSOFT) { + $msg->[0] ||= $from->format . ', temporarily denied'; + $self->log(LOGINFO, "denysoft mail from " . $from->format . " (@$msg)"); + $self->respond(450, @$msg); + } + elsif ($rc == DENY_DISCONNECT) { + $msg->[0] ||= $from->format . ', denied'; + $self->log(LOGINFO, "deny mail from " . $from->format . " (@$msg)"); + $self->respond(550, @$msg); + $self->disconnect; + } + elsif ($rc == DENYSOFT_DISCONNECT) { + $msg->[0] ||= $from->format . ', temporarily denied'; + $self->log(LOGINFO, "denysoft mail from " . $from->format . " (@$msg)"); + $self->respond(421, @$msg); + $self->disconnect; + } + else { # includes OK + $self->log(LOGDEBUG, "getting mail from ".$from->format); + $self->respond(250, $from->format . ", sender OK - how exciting to get mail from you!"); + $self->transaction->sender($from); + } +} + +sub rcpt { + my ($self, $line) = @_; + $self->run_hooks("rcpt_parse", $line); +} + +sub rcpt_parse_respond { + my ($self, $rc, $msg, $args) = @_; + my ($line) = @$args; + my ($ok, $rcpt, @param) = Qpsmtpd::Command->parse("rcpt", $line, $msg->[0]); + return $self->respond(501, $rcpt || "Syntax error in command") + unless ($ok == OK); + return $self->respond(503, "Use MAIL before RCPT") unless $self->transaction->sender; + + my %param; + foreach (@param) { + my ($k,$v) = split /=/, $_, 2; + $param{lc $k} = $v; + } + # to support addresses without <> we now require a plugin + # hooking "rcpt_pre" to + # return (OK, "<$rcpt>"); + # (... or anything else parseable by Qpsmtpd::Address ;-)) + # this means, a plugin can decide to (pre-)accept + # addresses like 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->connection->notes(disconnected => 1); + $self->reset_transaction; +} + +sub data { + my $self = shift; + $self->run_hooks("data"); +} + +sub data_respond { + my ($self, $rc, $msg, $args) = @_; + if ($rc == DONE) { + return 1; + } + elsif ($rc == DENY) { + $msg->[0] ||= "Message denied"; + $self->respond(554, @$msg); + $self->reset_transaction(); + return 1; + } + elsif ($rc == DENYSOFT) { + $msg->[0] ||= "Message denied temporarily"; + $self->respond(451, @$msg); + $self->reset_transaction(); + return 1; + } + elsif ($rc == DENY_DISCONNECT) { + $msg->[0] ||= "Message denied"; + $self->respond(554, @$msg); + $self->disconnect; + return 1; + } + elsif ($rc == DENYSOFT_DISCONNECT) { + $msg->[0] ||= "Message denied temporarily"; + $self->respond(421, @$msg); + $self->disconnect; + return 1; + } + $self->respond(503, "MAIL first"), return 1 unless $self->transaction->sender; + $self->respond(503, "RCPT first"), return 1 unless $self->transaction->recipients; + $self->respond(354, "go ahead"); + + my $buffer = ''; + my $size = 0; + my $i = 0; + my $max_size = ($self->config('databytes'))[0] || 0; # this should work in scalar context + my $blocked = ""; + my %matches; + my $in_header = 1; + my $complete = 0; + + $self->log(LOGDEBUG, "max_size: $max_size / size: $size"); + + my $header = Mail::Header->new(Modify => 0, MailFrom => "COERCE"); + + my $timeout = $self->config('timeout'); + while (defined($_ = $self->getline($timeout))) { + $complete++, last if $_ eq ".\r\n"; + $i++; + + # should probably use \012 and \015 in these checks instead of \r and \n ... + + # Reject messages that have either bare LF or CR. rjkaes noticed a + # lot of spam that is malformed in the header. + + ($_ eq ".\n" or $_ eq ".\r") + and $self->respond(421, "See http://smtpd.develooper.com/barelf.html") + and return $self->disconnect; + + # add a transaction->blocked check back here when we have line by line plugin access... + unless (($max_size and $size > $max_size)) { + s/\r\n$/\n/; + s/^\.\./\./; + if ($in_header and m/^$/) { + $in_header = 0; + my @headers = split /^/m, $buffer; + + # ... need to check that we don't reformat any of the received lines. + # + # 3.8.2 Received Lines in Gatewaying + # When forwarding a message into or out of the Internet environment, a + # gateway MUST prepend a Received: line, but it MUST NOT alter in any + # way a Received: line that is already in the header. + + $header->extract(\@headers); + #$header->add("X-SMTPD", "qpsmtpd/".$self->version.", http://smtpd.develooper.com/"); + + $buffer = ""; + + $self->transaction->header($header); + + # NOTE: This will not work properly under async. A + # data_headers_end_respond needs to be created. + my ($rc, $msg) = $self->run_hooks('data_headers_end'); + if ($rc == DENY_DISCONNECT) { + $self->respond(554, $msg || "Message denied"); + $self->disconnect; + return 1; + } elsif ($rc == DENYSOFT_DISCONNECT) { + $self->respond(421, $msg || "Message denied temporarily"); + $self->disconnect; + return 1; + } + + # Save the start of just the body itself + $self->transaction->set_body_start(); + + } + + # grab a copy of all of the header lines + if ($in_header) { + $buffer .= $_; + } + + # copy all lines into the spool file, including the headers + # we will create a new header later before sending onwards + $self->transaction->body_write($_); + $size += length $_; + } + #$self->log(LOGDEBUG, "size is at $size\n") unless ($i % 300); + } + + $self->log(LOGDEBUG, "max_size: $max_size / size: $size"); + + my $smtp = $self->connection->hello eq "ehlo" ? "ESMTP" : "SMTP"; + my $esmtp = substr($smtp,0,1) eq "E"; + my $authheader = ''; + my $sslheader = ''; + + if (defined $self->connection->notes('tls_enabled') + and $self->connection->notes('tls_enabled')) { + $smtp .= "S" if $esmtp; # RFC3848 + $sslheader = "(".$self->connection->notes('tls_socket')->get_cipher()." encrypted) "; + } + + if (defined $self->{_auth} and $self->{_auth} == OK) { + $smtp .= "A" if $esmtp; # RFC3848 + $authheader = "(smtp-auth username $self->{_auth_user}, mechanism $self->{_auth_mechanism})\n"; + } + + $header->add("Received", $self->received_line($smtp, $authheader, $sslheader), 0); + + # if we get here without seeing a terminator, the connection is + # probably dead. + unless ( $complete ) { + $self->respond(451, "Incomplete DATA"); + $self->reset_transaction; # clean up after ourselves + return 1; + } + + #$self->respond(550, $self->transaction->blocked),return 1 if ($self->transaction->blocked); + if ($max_size and $size > $max_size) { + $self->log(LOGALERT, "Message too big: size: $size (max size: $max_size)"); + $self->respond(552, "Message too big!"); + $self->reset_transaction; # clean up after ourselves + return 1; + } + + $self->run_hooks("data_post"); +} + +sub received_line { + my ($self, $smtp, $authheader, $sslheader) = @_; + my ($rc, @received) = $self->run_hooks("received_line", $smtp, $authheader, $sslheader); + if ($rc == YIELD) { + die "YIELD not supported for received_line hook"; + } + elsif ($rc == OK) { + return join("\n", @received); + } + else { # assume $rc == DECLINED + return "from ".$self->connection->remote_info + ." (HELO ".$self->connection->hello_host . ") (".$self->connection->remote_ip + . ")\n $authheader by ".$self->config('me')." (qpsmtpd/".$self->version + .") with $sslheader$smtp; ". (strftime('%a, %d %b %Y %H:%M:%S %z', localtime)) + } +} + +sub data_post_respond { + my ($self, $rc, $msg, $args) = @_; + if ($rc == DONE) { + return 1; + } + elsif ($rc == DENY) { + $msg->[0] ||= "Message denied"; + $self->respond(552, @$msg); + # DATA is always the end of a "transaction" + return $self->reset_transaction; + } + elsif ($rc == DENYSOFT) { + $msg->[0] ||= "Message denied temporarily"; + $self->respond(452, @$msg); + # DATA is always the end of a "transaction" + return $self->reset_transaction; + } + elsif ($rc == DENY_DISCONNECT) { + $msg->[0] ||= "Message denied"; + $self->respond(552, @$msg); + $self->disconnect; + return 1; + } + elsif ($rc == DENYSOFT_DISCONNECT) { + $msg->[0] ||= "Message denied temporarily"; + $self->respond(452, @$msg); + $self->disconnect; + return 1; + } + else { + $self->queue($self->transaction); + } +} + +sub getline { + my ($self, $timeout) = @_; + + alarm $timeout; + my $line = ; # 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; diff --git a/lib/Qpsmtpd/SMTP/Prefork.pm b/lib/Qpsmtpd/SMTP/Prefork.pm new file mode 100644 index 0000000..af8fb8e --- /dev/null +++ b/lib/Qpsmtpd/SMTP/Prefork.pm @@ -0,0 +1,30 @@ +package Qpsmtpd::SMTP::Prefork; +use Qpsmtpd::SMTP; +use Qpsmtpd::Constants; +@ISA = qw(Qpsmtpd::SMTP); + +sub dispatch { + my $self = shift; + my ($cmd) = lc shift; + + $self->{_counter}++; + + if ($cmd !~ /^(\w{1,12})$/ or !exists $self->{_commands}->{$1}) { + $self->run_hooks("unrecognized_command", $cmd, @_); + return 1; + } + $cmd = $1; + + if (1 or $self->{_commands}->{$cmd} and $self->can($cmd)) { + my ($result) = eval { $self->$cmd(@_) }; + if ($@ =~ /^disconnect_tcpserver/) { + die "disconnect_tcpserver"; + } elsif ($@) { + $self->log(LOGERROR, "XX: $@") if $@; + } + return $result if defined $result; + return $self->fault("command '$cmd' failed unexpectedly"); + } + + return; +} diff --git a/lib/Qpsmtpd/TcpServer.pm b/lib/Qpsmtpd/TcpServer.pm new file mode 100644 index 0000000..7215090 --- /dev/null +++ b/lib/Qpsmtpd/TcpServer.pm @@ -0,0 +1,194 @@ +package Qpsmtpd::TcpServer; +use Qpsmtpd::SMTP; +use Qpsmtpd::Constants; +use Socket; + +@ISA = qw(Qpsmtpd::SMTP); +use strict; + +use POSIX (); + +my $has_ipv6; +if ( + eval {require Socket6;} && + # INET6 prior to 2.01 will not work; sorry. + eval {require IO::Socket::INET6; IO::Socket::INET6->VERSION("2.00");} + ) { + import Socket6; + $has_ipv6=1; +} +else { + $has_ipv6=0; +} + +sub has_ipv6 { + return $has_ipv6; +} + +my $first_0; + +sub start_connection { + my $self = shift; + + my ( + $remote_host, $remote_info, $remote_ip, $remote_port, + $local_ip, $local_port, $local_host + ); + + if ($ENV{TCPREMOTEIP}) { + # started from tcpserver (or some other superserver which + # exports the TCPREMOTE* variables. + $remote_ip = $ENV{TCPREMOTEIP}; + $remote_host = $ENV{TCPREMOTEHOST} || "[$remote_ip]"; + $remote_info = $ENV{TCPREMOTEINFO} ? "$ENV{TCPREMOTEINFO}\@$remote_host" : $remote_host; + $remote_port = $ENV{TCPREMOTEPORT}; + $local_ip = $ENV{TCPLOCALIP}; + $local_port = $ENV{TCPLOCALPORT}; + $local_host = $ENV{TCPLOCALHOST}; + } else { + # Started from inetd or similar. + # get info on the remote host from the socket. + # ignore ident/tap/... + my $hersockaddr = getpeername(STDIN) + or die "getpeername failed: $0 must be called from tcpserver, (x)inetd or a similar program which passes a socket to stdin"; + my ($port, $iaddr) = sockaddr_in($hersockaddr); + $remote_ip = inet_ntoa($iaddr); + $remote_host = gethostbyaddr($iaddr, AF_INET) || "[$remote_ip]"; + $remote_info = $remote_host; + } + $self->log(LOGNOTICE, "Connection from $remote_info [$remote_ip]"); + + # if the local dns resolver doesn't filter it out we might get + # ansi escape characters that could make a ps axw do "funny" + # things. So to be safe, cut them out. + $remote_host =~ tr/a-zA-Z\.\-0-9\[\]//cd; + + $first_0 = $0 unless $first_0; + my $now = POSIX::strftime("%H:%M:%S %Y-%m-%d", localtime); + $0 = "$first_0 [$remote_ip : $remote_host : $now]"; + + $self->SUPER::connection->start(remote_info => $remote_info, + remote_ip => $remote_ip, + remote_host => $remote_host, + remote_port => $remote_port, + local_ip => $local_ip, + local_port => $local_port, + local_host => $local_host, + @_); +} + +sub run { + my ($self, $client) = @_; + + # Set local client_socket to passed client object for testing socket state on writes + $self->{__client_socket} = $client; + + $self->load_plugins unless $self->{hooks}; + + my $rc = $self->start_conversation; + return if $rc != DONE; + + # this should really be the loop and read_input should just get one line; I think + $self->read_input; +} + +sub read_input { + my $self = shift; + + my $timeout = + $self->config('timeoutsmtpd') # qmail smtpd control file + || $self->config('timeout') # qpsmtpd control file + || 1200; # default value + + alarm $timeout; + while () { + alarm 0; + $_ =~ s/\r?\n$//s; # advanced chomp + $self->log(LOGINFO, "dispatching $_"); + $self->connection->notes('original_string', $_); + defined $self->dispatch(split / +/, $_, 2) + or $self->respond(502, "command unrecognized: '$_'"); + alarm $timeout; + } + alarm(0); + return if $self->connection->notes('disconnected'); + $self->reset_transaction; + $self->run_hooks('disconnect'); + $self->connection->notes(disconnected => 1); +} + +sub respond { + my ($self, $code, @messages) = @_; + my $buf = ''; + + if ( !$self->check_socket() ) { + $self->log(LOGERROR, "Lost connection to client, cannot send response."); + return(0); + } + + while (my $msg = shift @messages) { + my $line = $code . (@messages?"-":" ").$msg; + $self->log(LOGINFO, $line); + $buf .= "$line\r\n"; + } + print $buf or ($self->log(LOGERROR, "Could not print [$buf]: $!"), return 0); + return 1; +} + +sub disconnect { + my $self = shift; + $self->log(LOGINFO,"click, disconnecting"); + $self->SUPER::disconnect(@_); + $self->run_hooks("post-connection"); + $self->connection->reset; + exit; +} + +# local/remote port and ip address +sub lrpip { + my ($server, $client, $hisaddr) = @_; + + my ($port, $iaddr) = ($server->sockdomain == AF_INET) ? (sockaddr_in($hisaddr)) : (sockaddr_in6($hisaddr)); + my $localsockaddr = getsockname($client); + my ($lport, $laddr) = ($server->sockdomain == AF_INET) ? (sockaddr_in($localsockaddr)) : (sockaddr_in6($localsockaddr)); + + my $nto_iaddr = ($server->sockdomain == AF_INET) ? (inet_ntoa($iaddr)) : (inet_ntop(AF_INET6(), $iaddr)); + my $nto_laddr = ($server->sockdomain == AF_INET) ? (inet_ntoa($laddr)) : (inet_ntop(AF_INET6(), $laddr)); + $nto_iaddr =~ s/::ffff://; + $nto_laddr =~ s/::ffff://; + + return ($port, $iaddr, $lport, $laddr, $nto_iaddr, $nto_laddr); +} + +sub tcpenv { + my ($nto_laddr, $nto_iaddr, $no_rdns) = @_; + + my $TCPLOCALIP = $nto_laddr; + my $TCPREMOTEIP = $nto_iaddr; + + if ($no_rdns) { + return ($TCPLOCALIP, $TCPREMOTEIP, $TCPREMOTEIP ? "[$ENV{TCPREMOTEIP}]" : "[noip!]"); + } + my $res = new Net::DNS::Resolver; + $res->tcp_timeout(3); + $res->udp_timeout(3); + my $query = $res->query($nto_iaddr); + my $TCPREMOTEHOST; + if($query) { + foreach my $rr ($query->answer) { + next unless $rr->type eq "PTR"; + $TCPREMOTEHOST = $rr->ptrdname; + } + } + return ($TCPLOCALIP, $TCPREMOTEIP, $TCPREMOTEHOST || "Unknown"); +} + +sub check_socket() { + my $self = shift; + + return 1 if ( $self->{__client_socket}->connected ); + + return 0; +} + +1; diff --git a/lib/Qpsmtpd/TcpServer/Prefork.pm b/lib/Qpsmtpd/TcpServer/Prefork.pm new file mode 100644 index 0000000..2728cea --- /dev/null +++ b/lib/Qpsmtpd/TcpServer/Prefork.pm @@ -0,0 +1,79 @@ +package Qpsmtpd::TcpServer::Prefork; +use Qpsmtpd::TcpServer; +use Qpsmtpd::SMTP::Prefork; +use Qpsmtpd::Constants; + +@ISA = qw(Qpsmtpd::SMTP::Prefork Qpsmtpd::TcpServer); + +my $first_0; + +sub start_connection { + my $self = shift; + + #reset info + $self->{_connection} = Qpsmtpd::Connection->new(); #reset connection + $self->reset_transaction; + $self->SUPER::start_connection(@_); +} + +sub read_input { + my $self = shift; + + my $timeout = + $self->config('timeoutsmtpd') # qmail smtpd control file + || $self->config('timeout') # qpsmtpd control file + || 1200; # default value + + alarm $timeout; + eval { + while () { + alarm 0; + $_ =~ s/\r?\n$//s; # advanced chomp + $self->log(LOGINFO, "dispatching $_"); + $self->connection->notes('original_string', $_); + defined $self->dispatch(split / +/, $_, 2) + or $self->respond(502, "command unrecognized: '$_'"); + alarm $timeout; + } + unless ($self->connection->notes('disconnected')) { + $self->reset_transaction; + $self->run_hooks('disconnect'); + $self->connection->notes(disconnected => 1); + } + }; + if ($@ =~ /^disconnect_tcpserver/) { + die "disconnect_tcpserver"; + } else { + $self->run_hooks("post-connection"); + $self->connection->reset; + die "died while reading from STDIN (probably broken sender) - $@"; + } + alarm(0); +} + +sub respond { + my ($self, $code, @messages) = @_; + + if ( !$self->check_socket() ) { + $self->log(LOGERROR, "Lost connection to client, cannot send response."); + return(0); + } + + while (my $msg = shift @messages) { + my $line = $code . (@messages?"-":" ").$msg; + $self->log(LOGINFO, $line); + print "$line\r\n" or ($self->log(LOGERROR, "Could not print [$line]: $!"), return 0); + } + return 1; +} + +sub disconnect { + my $self = shift; + $self->log(LOGINFO,"click, disconnecting"); + $self->SUPER::disconnect(@_); + $self->run_hooks("post-connection"); + $self->connection->reset; + die "disconnect_tcpserver"; +} + +1; diff --git a/lib/Qpsmtpd/Transaction.pm b/lib/Qpsmtpd/Transaction.pm new file mode 100644 index 0000000..0dabffa --- /dev/null +++ b/lib/Qpsmtpd/Transaction.pm @@ -0,0 +1,399 @@ +package Qpsmtpd::Transaction; +use Qpsmtpd; +@ISA = qw(Qpsmtpd); +use strict; +use Qpsmtpd::Utils; +use Qpsmtpd::Constants; +use Socket qw(inet_aton); +use Sys::Hostname; +use Time::HiRes qw(gettimeofday); + +use IO::File qw(O_RDWR O_CREAT); + +sub new { start(@_) } + +sub start { + my $proto = shift; + my $class = ref($proto) || $proto; + my %args = @_; + + my $self = { _rcpt => [], started => time, }; + bless ($self, $class); + return $self; +} + +sub add_recipient { + my ($self, $rcpt) = @_; + push @{$self->{_recipients}}, $rcpt if $rcpt; +} + +sub remove_recipient { + my ($self,$rcpt) = @_; + $self->{_recipients} = [grep {$_->address ne $rcpt->address} + @{$self->{_recipients} || []}] if $rcpt; +} + +sub recipients { + my $self = shift; + @_ and $self->{_recipients} = [@_]; + ($self->{_recipients} ? @{$self->{_recipients}} : ()); +} + +sub sender { + my $self = shift; + @_ and $self->{_sender} = shift; + $self->{_sender}; +} + +sub header { + my $self = shift; + @_ and $self->{_header} = shift; + $self->{_header}; +} + +# blocked() will return when we actually can do something useful with it... +#sub blocked { +# my $self = shift; +# carp 'Use of transaction->blocked is deprecated;' +# . 'tell ask@develooper.com if you have a reason to use it'; +# @_ and $self->{_blocked} = shift; +# $self->{_blocked}; +#} + +sub notes { + my ($self,$key) = (shift,shift); + # Check for any additional arguments passed by the caller -- including undef + return $self->{_notes}->{$key} unless @_; + return $self->{_notes}->{$key} = shift; +} + +sub set_body_start { + my $self = shift; + $self->{_body_start} = $self->body_current_pos; + if ($self->{_body_file}) { + $self->{_header_size} = $self->{_body_start}; + } + else { + $self->{_header_size} = 0; + if ($self->{_body_array}) { + foreach my $line (@{ $self->{_body_array} }) { + $self->{_header_size} += length($line); + } + } + } +} + +sub body_start { + my $self = shift; + @_ and die "body_start now read only"; + $self->{_body_start}; +} + +sub body_current_pos { + my $self = shift; + if ($self->{_body_file}) { + return tell($self->{_body_file}); + } + return $self->{_body_current_pos} || 0; +} + +sub body_filename { + my $self = shift; + $self->body_spool() unless $self->{_filename}; + $self->{_body_file}->flush(); # so contents won't be cached + return $self->{_filename}; +} + +sub body_spool { + my $self = shift; + $self->log(LOGINFO, "spooling message to disk"); + $self->{_filename} = $self->temp_file(); + $self->{_body_file} = IO::File->new($self->{_filename}, O_RDWR|O_CREAT, 0600) + or die "Could not open file $self->{_filename} - $! "; # . $self->{_body_file}->error; + if ($self->{_body_array}) { + foreach my $line (@{ $self->{_body_array} }) { + $self->{_body_file}->print($line) or die "Cannot print to temp file: $!"; + } + $self->{_body_start} = $self->{_header_size}; + } + $self->{_body_array} = undef; +} + +sub body_write { + my $self = shift; + my $data = shift; + if ($self->{_body_file}) { + #warn("body_write to file\n"); + # go to the end of the file + seek($self->{_body_file},0,2) + unless $self->{_body_file_writing}; + $self->{_body_file_writing} = 1; + $self->{_body_file}->print(ref $data eq "SCALAR" ? $$data : $data) + and $self->{_body_size} += length (ref $data eq "SCALAR" ? $$data : $data); + } + else { + #warn("body_write to array\n"); + $self->{_body_array} ||= []; + my $ref = ref($data) eq "SCALAR" ? $data : \$data; + pos($$ref) = 0; + while ($$ref =~ m/\G(.*?\n)/gc) { + push @{ $self->{_body_array} }, $1; + $self->{_body_size} += length($1); + ++$self->{_body_current_pos}; + } + if ($$ref =~ m/\G(.+)\z/gc) { + push @{ $self->{_body_array} }, $1; + $self->{_body_size} += length($1); + ++$self->{_body_current_pos}; + } + $self->body_spool if ( $self->{_body_size} >= $self->size_threshold() ); + } +} + +sub body_size { # depreceated, use data_size() instead + my $self = shift; + $self->log(LOGWARN, "WARNING: body_size() is depreceated, use data_size() instead"); + $self->{_body_size} || 0; +} + +sub data_size { + shift->{_body_size} || 0; +} + +sub body_length { + my $self = shift; + $self->{_body_size} or return 0; + $self->{_header_size} or return 0; + return $self->{_body_size} - $self->{_header_size}; +} + +sub body_resetpos { + my $self = shift; + + if ($self->{_body_file}) { + my $start = $self->{_body_start} || 0; + seek($self->{_body_file}, $start, 0); + $self->{_body_file_writing} = 0; + } + else { + $self->{_body_current_pos} = $self->{_body_start}; + } + + 1; +} + +sub body_getline { + my $self = shift; + if ($self->{_body_file}) { + my $start = $self->{_body_start} || 0; + seek($self->{_body_file}, $start,0) + if $self->{_body_file_writing}; + $self->{_body_file_writing} = 0; + my $line = $self->{_body_file}->getline; + return $line; + } + else { + return unless $self->{_body_array}; + $self->{_body_current_pos} ||= 0; + my $line = $self->{_body_array}->[$self->{_body_current_pos}]; + $self->{_body_current_pos}++; + return $line; + } +} + +sub body_as_string { + my $self = shift; + $self->body_resetpos; + local $/; + my $str = ''; + while (defined(my $line = $self->body_getline)) { + $str .= $line; + } + return $str; +} + +sub body_fh { + return shift->{_body_file}; +} + +sub dup_body_fh { + my ($self) = @_; + open(my $fh, '<&=', $self->body_fh); + return $fh; +} + +sub DESTROY { + my $self = shift; + # would we save some disk flushing if we unlinked the file before + # closing it? + + undef $self->{_body_file} if $self->{_body_file}; + if ($self->{_filename} and -e $self->{_filename}) { + unlink $self->{_filename} or $self->log(LOGERROR, "Could not unlink ", $self->{_filename}, ": $!"); + } + + # These may not exist + if ( $self->{_temp_files} ) { + $self->log(LOGDEBUG, "Cleaning up temporary transaction files"); + foreach my $file ( @{$self->{_temp_files}} ) { + next unless -e $file; + unlink $file or $self->log(LOGERROR, + "Could not unlink temporary file", $file, ": $!"); + } + } + # Ditto + if ( $self->{_temp_dirs} ) { + eval {use File::Path}; + $self->log(LOGDEBUG, "Cleaning up temporary directories"); + foreach my $dir ( @{$self->{_temp_dirs}} ) { + rmtree($dir) or $self->log(LOGERROR, + "Could not unlink temporary dir", $dir, ": $!"); + } + } +} + + +1; +__END__ + +=head1 NAME + +Qpsmtpd::Transaction - single SMTP session transaction data + +=head1 SYNOPSIS + + foreach my $recip ($transaction->recipients) { + print "T", $recip->address, "\0"; + } + +=head1 DESCRIPTION + +Qpsmtpd::Transaction maintains a single SMTP session's data, including +the envelope details and the mail header and body. + +The docs below cover using the C<$transaction> object from within plugins +rather than constructing a C 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 diff --git a/lib/Qpsmtpd/Utils.pm b/lib/Qpsmtpd/Utils.pm new file mode 100644 index 0000000..7ddc801 --- /dev/null +++ b/lib/Qpsmtpd/Utils.pm @@ -0,0 +1,15 @@ +package Qpsmtpd::Utils; +use strict; + +sub tildeexp { + my $path = shift; + $path =~ s{^~([^/]*)} { + $1 + ? (getpwnam($1))[7] + : ( $ENV{HOME} || $ENV{LOGDIR} || (getpwuid($>))[7]) + }ex; + return $path; +} + + +1; diff --git a/log/run b/log/run new file mode 100755 index 0000000..5a4d84b --- /dev/null +++ b/log/run @@ -0,0 +1,5 @@ +#! /bin/sh +export LOGDIR=./main +mkdir -p $LOGDIR +exec multilog t s1000000 n20 $LOGDIR + diff --git a/packaging/rpm/Makefile b/packaging/rpm/Makefile new file mode 100644 index 0000000..23756e1 --- /dev/null +++ b/packaging/rpm/Makefile @@ -0,0 +1,182 @@ +# -- generic Makefile for building RPM-based packages out of source +# code control systems (git, cvs, svn) + +SCM_TYPE := git +SCM_PATH := ../../ +#CVSROOT := $(shell cat 2>/dev/null src/CVS/Root) +#SVN_PATH := $(shell svn info ${SCM_PATH} 2>/dev/null | awk '/^URL:/{print $$2}') +#SVN_REV := $(shell svn info ${SVN_PATH} 2>/dev/null | awk '/^Last Changed Rev:/{print $$4}') + +PACKAGE := $(shell cat PACKAGE) +VERSION := $(shell cat VERSION) +RELEASE := $(shell cat RELEASE) +BASE_VER := ${VERSION}-${RELEASE} +CURRENT_PACKAGE := $(PACKAGE)-$(BASE_VER) +TARBALL := $(CURRENT_PACKAGE).tar + +DIRNAME := $(shell echo $${PWD}) +DIRBASE := $(shell basename $${PWD}) + + +.SUFFIXES: +.PHONY: clean mrclean distclean prepclean all default +.PHONY: rpm rpmdist buildrpm buildrpmdist +.PHONY: buildtarball buildtargz +.PHONY: builddir distdir prepbuildtarball +.PHONY: cvs-export git-export svn-export test-export +.PHONY: cvs-clean git-clean svn-clean test-clean +.PHONY: update + +default: rpmdist + +# -- the "rpmdist" target will build out of the SCM, but will +# use the user's default build settings (which in many cases +# is exposed as an RPM repository) +# +#rpmdist: buildrpmdist distclean +rpmdist: buildrpmdist + +buildrpmdist: buildtargz + @rpmbuild \ + --define "_package ${PACKAGE}" \ + --define "_version ${VERSION}" \ + --define "_release ${RELEASE}" \ + -ta ./build/$(TARBALL).gz + +# -- the "srpmdist" target will build an SRPM out of the SCM, but +# will use the user's default build settings (which in many +# cases is exposed as an RPM repository) +# +srpmdist: buildsrpmdist + +buildsrpmdist: buildtargz + @rpmbuild \ + --define "_package ${PACKAGE}" \ + --define "_version ${VERSION}" \ + --define "_release ${RELEASE}" \ + -ts --nodeps ./build/$(TARBALL).gz + +# -- the "rpm" target will build out of the SCM, but will leave +# the resulting package in the relative ./build/ directory +# +rpm: buildrpm $(SCM_TYPE)-clean + +buildrpm: buildtargz + @echo ${PACKAGE} ${VERSION} ${RELEASE} + @rpmbuild \ + --define "_rpmdir ./build/" \ + --define "_sourcedir ./build/" \ + --define "_srcrpmdir ./build/" \ + --define "_package ${PACKAGE}" \ + --define "_version ${VERSION}" \ + --define "_release ${RELEASE}" \ + -ta ./build/$(TARBALL).gz + +# -- the "srpm" target will build an SRPM out of the SCM, but +# will leave the resulting package in the relative ./build/ +# directory +# +srpm: buildsrpm $(SCM_TYPE)-clean + +buildsrpm: buildtargz + @echo ${PACKAGE} ${VERSION} ${RELEASE} + @rpmbuild \ + --define "_rpmdir ./build/" \ + --define "_sourcedir ./build/" \ + --define "_srcrpmdir ./build/" \ + --define "_package ${PACKAGE}" \ + --define "_version ${VERSION}" \ + --define "_release ${RELEASE}" \ + -ts --nodeps ./build/$(TARBALL).gz + +buildtarball: prepbuildtarball + @tar \ + --create \ + --directory ./build/ \ + --file ./build/$(TARBALL) \ + ${CURRENT_PACKAGE} + +buildtargz: buildtarball + @gzip -c < ./build/$(TARBALL) > ./build/$(TARBALL).gz + +prepbuildtarball: $(SCM_TYPE)-export + ${MAKE} update \ + && cp ${PACKAGE}.spec ./build/${CURRENT_PACKAGE} \ + && cp files/* ./build/ + +test-clean: + @cd .. \ + && rm "$(CURRENT_PACKAGE)" + +test-export: builddir + @cd .. \ + && ln -snvf $(DIRBASE) $(CURRENT_PACKAGE) \ + && tar \ + --create \ + --dereference \ + --to-stdout \ + --exclude "*.git*" \ + --exclude "*.svn*" \ + --exclude "*/CVS/*" \ + --exclude "$(CURRENT_PACKAGE)/build/*" \ + $(CURRENT_PACKAGE) \ + | tar \ + --extract \ + --directory $(CURRENT_PACKAGE)/build/ \ + --file - + +git-export: builddir prepclean + (cd $(SCM_PATH) ; git archive --format=tar --prefix=$(CURRENT_PACKAGE)/ HEAD) \ + | tar \ + --extract \ + --directory ./build/ \ + --file - + +git-clean: + @: + +cvs-export: builddir prepclean + @cd ./build/ \ + && echo CURRENT_PACKAGE: ${CURRENT_PACKAGE} \ + && echo CVSROOT: ${CVSROOT} \ + && CVSROOT=${CVSROOT} cvs export -r HEAD -d$(CURRENT_PACKAGE) ${PACKAGE} + +cvs-clean: + @: + +svn-export: builddir prepclean + @cd ./build/ \ + && svn export $(SVN_PATH) $(CURRENT_PACKAGE) + +svn-clean: + @: + +builddir: + @mkdir -p ./build + +distdir: + @mkdir -p ./dist + +prepclean: + @rm -rf ./build/$(CURRENT_PACKAGE)* + +clean: + @rm -rf ./build/* ./dist/* 2>/dev/null || : + +mrclean: clean + +distclean: clean $(SCM_TYPE)-clean + @rmdir ./build/ ./dist/ 2>/dev/null || : + +# -- recursive Makefile calls (during build phase) +# +update: $(PACKAGE).spec VERSION RELEASE + +$(PACKAGE).spec: VERSION RELEASE $(PACKAGE).spec.in + @sed \ + -e "s|@PACKAGE@|$(PACKAGE)|" \ + -e "s|@VERSION@|$(VERSION)|" \ + -e "s|@RELEASE@|$(RELEASE)|" \ + < $(PACKAGE).spec.in > $@ + +# -- end of Makefile diff --git a/packaging/rpm/PACKAGE b/packaging/rpm/PACKAGE new file mode 100644 index 0000000..9df0b30 --- /dev/null +++ b/packaging/rpm/PACKAGE @@ -0,0 +1 @@ +qpsmtpd diff --git a/packaging/rpm/RELEASE b/packaging/rpm/RELEASE new file mode 100644 index 0000000..49d5957 --- /dev/null +++ b/packaging/rpm/RELEASE @@ -0,0 +1 @@ +0.1 diff --git a/packaging/rpm/VERSION b/packaging/rpm/VERSION new file mode 100644 index 0000000..e6e9cf4 --- /dev/null +++ b/packaging/rpm/VERSION @@ -0,0 +1 @@ +0.82 diff --git a/packaging/rpm/files/README.selinux b/packaging/rpm/files/README.selinux new file mode 100644 index 0000000..39c015f --- /dev/null +++ b/packaging/rpm/files/README.selinux @@ -0,0 +1,10 @@ +If you run qpsmtpd-apache on a box with SELinux enabled, you'll need to +allow apache to listen to your SMTP port, typically port 25. + +The following command allows apache to listen on port 25: + + semanage port -m -t http_port_t -p tcp 25 + +Use the -d option to remove this permission: + + semanage port -d -t http_port_t -p tcp 25 diff --git a/packaging/rpm/files/in.qpsmtpd b/packaging/rpm/files/in.qpsmtpd new file mode 100755 index 0000000..8d45af0 --- /dev/null +++ b/packaging/rpm/files/in.qpsmtpd @@ -0,0 +1,3 @@ +#!/bin/sh +export QPSMTPD_CONFIG=/etc/qpsmtpd +exec /usr/bin/qpsmtpd 2> /dev/null diff --git a/packaging/rpm/files/qpsmtpd-forkserver.rc b/packaging/rpm/files/qpsmtpd-forkserver.rc new file mode 100755 index 0000000..14775e4 --- /dev/null +++ b/packaging/rpm/files/qpsmtpd-forkserver.rc @@ -0,0 +1,122 @@ +#! /bin/bash +# +# qpsmtpd-forkserver Start/Stop the qpsmtpd forking server +# +# chkconfig: 2345 90 60 +# description: qpsmtpd is a flexible smtpd daemon written in Perl. \ +# Apart from the core SMTP features, all functionality is \ +# implemented in small "extension plugins" using the easy \ +# to use object oriented plugin API. +# processname: qpsmtpd-forkserver +# config: /etc/qpsmtpd +# pidfile: /var/run/qpsmtpd-forkserver.pid + + +# Source function library. +. /etc/init.d/functions +. /etc/sysconfig/qpsmtpd-forkserver + +RETVAL=0 + +# See how we were called. + +prog="qpsmtpd-forkserver" + +start() { + # cleanup environment a bit. + unset PERL_UNICODE + unset LANG + unset LC_TIME + unset LC_ALL + unset BASH_ENV + unset ENV + unset CDPATH + unset IFS + + echo -n $"Starting $prog: " + trap "" 1 + daemon $prog --detach $QPSMTPD_OPTIONS + RETVAL=$? + echo + [ $RETVAL -eq 0 ] && touch /var/lock/subsys/$prog + return $RETVAL +} + +stop() { + echo -n $"Stopping $prog: " + killproc $prog + RETVAL=$? + echo + [ $RETVAL -eq 0 ] && rm -f /var/lock/subsys/$prog + return $RETVAL +} + +# functions status() uses pidof, which doesn't work with (?) scripts +qpstatus() { + local base=${1##*/} + local pid + + # Test syntax. + if [ "$#" = 0 ] ; then + echo $"Usage: status {program}" + return 1 + fi + + # Use "/var/run/*.pid" file for pid + if [ -f /var/run/${base}.pid ] ; then + read pid < /var/run/${base}.pid + if [ -n "$pid" ]; then + /bin/ps -p $pid >/dev/null + if [ $? -eq 0 ]; then + echo $"${base} (pid $pid) is running..." + return 0 + else + echo $"${base} dead but pid file exists" + return 1 + fi + fi + fi + # See if /var/lock/subsys/${base} exists + if [ -f /var/lock/subsys/${base} ]; then + echo $"${base} dead but subsys locked" + return 2 + fi + echo $"${base} is stopped" + return 3 +} + +restart() { + stop + start +} + +reload() { + stop + start +} + +case "$1" in + start) + start + ;; + stop) + stop + ;; + restart) + restart + ;; + reload) + reload + ;; + status) + qpstatus qpsmtpd-forkserver + ;; + condrestart) + [ -f /var/lock/subsys/$prog ] && restart || : + ;; + *) + echo $"Usage: $0 {start|stop|status|reload|restart|condrestart}" + exit 1 +esac + +exit $? diff --git a/packaging/rpm/files/qpsmtpd-forkserver.sysconfig b/packaging/rpm/files/qpsmtpd-forkserver.sysconfig new file mode 100644 index 0000000..d7a7f7c --- /dev/null +++ b/packaging/rpm/files/qpsmtpd-forkserver.sysconfig @@ -0,0 +1,3 @@ +QPSMTPD_OPTIONS="-p 25 -l 127.0.0.1 --pid-file /var/run/qpsmtpd-forkserver.pid" +export QPSMTPD_CONFIG=/etc/qpsmtpd +export HOME=~smtpd diff --git a/packaging/rpm/files/qpsmtpd-plugin-file_connection b/packaging/rpm/files/qpsmtpd-plugin-file_connection new file mode 100644 index 0000000..1321049 --- /dev/null +++ b/packaging/rpm/files/qpsmtpd-plugin-file_connection @@ -0,0 +1,184 @@ +#!/usr/bin/perl +# $Id: file 478 2005-07-19 07:40:16Z aqua $ + +=head1 NAME + +file_connection - Simple per session log-to-file logging for qpsmtpd + +=head1 DESCRIPTION + +The 'file_connection' logging plugin for qpsmtpd records qpsmtpd log messages into a +file (or a named pipe, if you prefer.) + +The file is reopened for each connection. To facilitate automatic +logfile switching the filename can contain strftime conversion +specifiers, which are expanded immediately before opening the file. This +ensures that a single connection is never split across logfiles. + +The list of supported conversion specifiers depends on the strftime +implementation of your C library. See strftime(3) for details. +Additionally, %i exands to a (hopefully) unique session-id. + + +=head1 CONFIGURATION + +To enable the logging plugin, add a line of this form to the qpsmtpd plugins +configuration file: + +=over + +logging/file_connection [loglevel I] I + +For example: + +logging/file_connection loglevel LOGINFO /var/log/qpsmtpd/%Y-%m-%d + +=back + +Multiple instances of the plugin can be configured by appending :I for any +integer(s) I, to log to multiple files simultaneously, e.g. to log critical +errors and normally verbose logs elsewhere. + +The following optional configuration setting can be supplied: + +=over + +=item loglevel I + +The internal log level below which messages will be logged. The I +given should be chosen from this list. Priorities count downward (for example, +if LOGWARN were selected, LOGERROR, LOGCRIT and LOGEMERG messages would be +logged as well): + +=over + +=item B + +=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 AUTHOR + +Peter J. Holzer , based on a plugin by +Devin Carraway + +=head1 LICENSE + +Copyright (c) 2005, Devin Carraway. + +This plugin is licensed under the same terms as the qpsmtpd package itself. +Please see the LICENSE file included with qpsmtpd for details. + +=cut + +use strict; +use warnings; + +use IO::File; +#use Sys::Hostname; +use POSIX qw(strftime); + +sub register { + my ($self, $qp, @args) = @_; + my %args; + + $self->{_loglevel} = LOGWARN; + + while (1) { + last if !@args; + if (lc $args[0] eq 'loglevel') { + shift @args; + my $ll = shift @args; + if (!defined $ll) { + warn "Malformed arguments to logging/file_connection plugin"; + return; + } + if ($ll =~ /^(\d+)$/) { + $self->{_loglevel} = $1; + } + elsif ($ll =~ /^(LOG\w+)$/) { + $self->{_loglevel} = log_level($1); + defined $self->{_loglevel} or $self->{_loglevel} = LOGWARN; + } + } + else { last } + } + + unless (@args && $args[0]) { + warn "Malformed arguments to syslog plugin"; + return; + } + + $self->{_logfile} = join(' ', @args); + $self->{_log_session_id_prefix} = sprintf("%08x%04x", time(), $$); + $self->{_log_session_id_counter} = 0; + + $self->register_hook('logging', 'write_log'); + $self->register_hook('pre-connection', 'open_log'); + $self->open_log($qp); +} + +sub open_log { + my ($self, $qp) = @_; + my $output = $self->{_logfile}; + $self->{_log_session_id} = + $self->{_log_session_id_prefix} . "." . + ++$self->{_log_session_id_counter}; + + $output =~ s/%i/$self->{_log_session_id}/; + $output = strftime($output, localtime); + #print STDERR "open_log: output=$output, uid=$>\n"; + if ($output =~ /^\s*\|(.*)/) { + unless ($self->{_f} = new IO::File "|$1") { + warn "Error opening log output to command $1: $!"; + return; + } + } elsif ($output =~ /^(.*)/) { # detaint + unless ($self->{_f} = new IO::File ">>$1") { + warn "Error opening log output to path $1: $!"; + return; + } + } + $self->{_f}->autoflush(1); + + return DECLINED; +} + +sub write_log { + my ($self, $txn, $trace, $hook, $plugin, @log) = @_; + + return DECLINED if $trace > $self->{_loglevel}; + return DECLINED if defined $plugin and $plugin eq $self->plugin_name; + $self->open_log unless($self->{_f}); + + my $f = $self->{_f}; + print STDERR "no open file\n" unless (defined $f); + print $f join(" ", + strftime("%Y-%m-%dT%H:%M:%S%z", localtime), $self->{_log_session_id}, + (defined $plugin ? " $plugin plugin:" : + defined $hook ? " running plugin ($hook):" : ""), + @log), "\n"; + return DECLINED; +} + +# vi: tabstop=4 shiftwidth=4 expandtab: + diff --git a/packaging/rpm/files/qpsmtpd-xinetd b/packaging/rpm/files/qpsmtpd-xinetd new file mode 100644 index 0000000..31ad54c --- /dev/null +++ b/packaging/rpm/files/qpsmtpd-xinetd @@ -0,0 +1,19 @@ +# default: on +# description: The telnet server serves telnet sessions; it uses \ +# unencrypted username/password pairs for authentication. +service smtp +{ + flags = REUSE + socket_type = stream + wait = no + user = smtpd + groups = yes + server = /usr/sbin/in.qpsmtpd + log_on_failure += USERID + disable = yes + rlimit_as = 128M + instances = 40 + per_source = 10 + cps = 50 10 +} + diff --git a/packaging/rpm/files/qpsmtpd.conf b/packaging/rpm/files/qpsmtpd.conf new file mode 100644 index 0000000..b46ead7 --- /dev/null +++ b/packaging/rpm/files/qpsmtpd.conf @@ -0,0 +1,16 @@ +Listen 0.0.0.0:25 smtp +AcceptFilter smtp none +## "smtp" and the AcceptFilter are required for Linux, FreeBSD +## with apache >= 2.1.5, for others it doesn't hurt. See also +## http://httpd.apache.org/docs/2.2/mod/core.html#acceptfilter +## and http://httpd.apache.org/docs/2.2/mod/mpm_common.html#listen + + + use Apache::Qpsmtpd; + $ENV{QPSMTPD_CONFIG} = "/etc/qpsmtpd"; + + + + PerlModule Apache::Qpsmtpd + PerlProcessConnectionHandler Apache::Qpsmtpd + diff --git a/packaging/rpm/qpsmtpd.spec.in b/packaging/rpm/qpsmtpd.spec.in new file mode 100644 index 0000000..e7529de --- /dev/null +++ b/packaging/rpm/qpsmtpd.spec.in @@ -0,0 +1,335 @@ +Name: %{_package} +Version: %{_version} +Release: %{_release} + +Summary: qpsmtpd + qpsmtpd-apache + qpsmtpd-async +License: MIT +Group: System Environment/Daemons +URL: http://smtpd.develooper.com/ +BuildRoot: %{_builddir}/%{name}-%{version}-%{release}-root +BuildRequires: perl >= 0:5.00503 +BuildArchitectures: noarch +Requires: perl(Mail::Header), perl(Net::DNS) perl(Net::IP) perl(IPC::Shareable) +Requires(pre): coreutils, shadow-utils, perl + +Source0: %{name}-%{version}-%{release}.tar.gz +Source1: qpsmtpd-forkserver.rc +Source2: qpsmtpd-forkserver.sysconfig +Source3: qpsmtpd-plugin-file_connection +Source4: qpsmtpd-xinetd +Source5: in.qpsmtpd +Source6: qpsmtpd.conf +Source7: README.selinux + +%description +qpsmtpd is a flexible smtpd daemon written in Perl. Apart from the core +SMTP features, all functionality is implemented in small "extension +plugins" using the easy to use object oriented plugin API. + +qpsmtpd was originally written as a drop-in qmail-smtpd replacement, but +now it also includes a smtp forward and a postfix "backend". + +%package apache +Requires: perl(mod_perl2) +Summary: mod_perl-2 connection handler for qpsmtpd +Group: System Environment/Daemons + +%package async +Summary: qpsmtpd using async I/O in a single process +Group: System Environment/Daemons + +%description apache + +This module implements a mod_perl/apache 2.0 connection handler +that turns Apache into an SMTP server using Qpsmtpd. + +%description async +This package contains the Qpsmtpd::PollServer module, which allows +qpsmtd to handle many connections in a single process and the +qpsmpd-async which uses it. + +%prep +%setup -q -n %{name}-%{version}-%{release} + +%build +CFLAGS="$RPM_OPT_FLAGS" perl Makefile.PL INSTALLSITELIB=%{_prefix}/lib/perl5/site_perl +make + +%clean +rm -rf $RPM_BUILD_ROOT +%install + +rm -rf $RPM_BUILD_ROOT +eval `perl '-V:installarchlib'` +mkdir -p $RPM_BUILD_ROOT/$installarchlib +if grep -q DESTDIR Makefile +then + make DESTDIR=$RPM_BUILD_ROOT + find blib/lib -name '*.pm.*' -exec rm -f {} \; + make DESTDIR=$RPM_BUILD_ROOT install + +else + make PREFIX=$RPM_BUILD_ROOT/usr + find blib/lib -name '*.pm.*' -exec rm -f {} \; + make PREFIX=$RPM_BUILD_ROOT/usr install +fi +mkdir -p ${RPM_BUILD_ROOT}%{_datadir}/%{name} +rm -f ${RPM_BUILD_ROOT}%{_datadir}/%{name}/plugins/*.* +cp -r plugins ${RPM_BUILD_ROOT}%{_datadir}/%{name}/plugins +mkdir -p ${RPM_BUILD_ROOT}%{_sysconfdir}/%{name} +rm -f ${RPM_BUILD_ROOT}%{_sysconfdir}/%{name}/*.* +cp -r config.sample/* ${RPM_BUILD_ROOT}%{_sysconfdir}/%{name}/ +echo %{_datadir}/%{name}/plugins > ${RPM_BUILD_ROOT}%{_sysconfdir}/%{name}/plugin_dirs +echo %{_localstatedir}/spool/qpsmtpd > ${RPM_BUILD_ROOT}%{_sysconfdir}/%{name}/spool_dir +echo logging/file_connection loglevel LOGINFO %{_localstatedir}/log/qpsmtpd/%Y-%m-%d > ${RPM_BUILD_ROOT}%{_sysconfdir}/%{name}/logging +mkdir -p ${RPM_BUILD_ROOT}%{_initrddir} +cp %{SOURCE1} ${RPM_BUILD_ROOT}%{_initrddir}/qpsmtpd-forkserver +mkdir -p ${RPM_BUILD_ROOT}%{_sysconfdir}/sysconfig +cp %{SOURCE2} ${RPM_BUILD_ROOT}%{_sysconfdir}/sysconfig/qpsmtpd-forkserver +cp %{SOURCE3} ${RPM_BUILD_ROOT}%{_datadir}/%{name}/plugins/logging/file_connection +mkdir -p ${RPM_BUILD_ROOT}%{_localstatedir}/spool/qpsmtpd +mkdir -p ${RPM_BUILD_ROOT}%{_localstatedir}/log/qpsmtpd +mkdir -p ${RPM_BUILD_ROOT}%{_sysconfdir}/xinetd.d +cp %{SOURCE4} ${RPM_BUILD_ROOT}%{_sysconfdir}/xinetd.d/smtp +mkdir -p ${RPM_BUILD_ROOT}%{_sbindir} +cp %{SOURCE5} ${RPM_BUILD_ROOT}%{_sbindir}/in.smtp +mkdir -p ${RPM_BUILD_ROOT}%{_sysconfdir}/httpd/conf.d +cp %{SOURCE6} ${RPM_BUILD_ROOT}%{_sysconfdir}/httpd/conf.d +mkdir -p $RPM_BUILD_ROOT%{_docdir}/%{name}-apache-%{version} +cp %{SOURCE7} $RPM_BUILD_ROOT%{_docdir}/%{name}-apache-%{version} + +[ -x /usr/lib/rpm/brp-compress ] && /usr/lib/rpm/brp-compress + +find ${RPM_BUILD_ROOT}%{_prefix} \( -name perllocal.pod -o -name .packlist \) -exec rm {} \; +find ${RPM_BUILD_ROOT}%{_prefix} -type f -print | \ + sed "s@^$RPM_BUILD_ROOT@@g" | \ + grep -v [Aa]sync | \ + grep -v packaging | \ + grep -v README.selinux | \ + grep -v /Apache | \ + grep -v /Danga | \ + grep -v Qpsmtpd/ConfigServer.pm | \ + grep -v Qpsmtpd/PollServer.pm > %{name}-%{version}-%{release}-filelist +if [ "$(cat %{name}-%{version}-%{release}-filelist)X" = "X" ] ; then + echo "ERROR: EMPTY FILE LIST" + exit -1 +fi + +%files -f %{name}-%{version}-%{release}-filelist +%defattr(-,root,root) +%doc CREDITS Changes LICENSE README README.plugins STATUS +%{_initrddir}/qpsmtpd-forkserver +%config(noreplace) %{_sysconfdir}/qpsmtpd/* +%config(noreplace) %{_sysconfdir}/xinetd.d/smtp +%config(noreplace) %{_sysconfdir}/sysconfig/qpsmtpd-forkserver +%attr(2750,qpsmtpd,clamav) %dir %{_localstatedir}/spool/qpsmtpd +%attr(0750,smtpd,smtpd) %dir %{_localstatedir}/log/qpsmtpd + +%files apache +%defattr(-,root,root) +%{_prefix}/lib/perl5/site_perl/Apache/Qpsmtpd.pm +%{_mandir}/man3/Apache::Qpsmtpd.3pm.gz +%config(noreplace) %{_sysconfdir}/httpd/conf.d/* +%doc %{_docdir}/%{name}-apache-%{version}/README.selinux + +%files async +%defattr(-,root,root) +%{_bindir}/qpsmtpd-async +%{_prefix}/lib/perl5/site_perl/Danga/Client.pm +%{_prefix}/lib/perl5/site_perl/Danga/TimeoutSocket.pm +%{_prefix}/lib/perl5/site_perl/Qpsmtpd/ConfigServer.pm +%{_prefix}/lib/perl5/site_perl/Qpsmtpd/Plugin/Async/DNSBLBase.pm +%{_prefix}/lib/perl5/site_perl/Qpsmtpd/PollServer.pm +%{_mandir}/man1/qpsmtpd-async.1.gz +%{_datadir}/%{name}/plugins/async/* + +%pre +if ! id smtpd >/dev/null 2>&1 +then + # need to create smtpd user. + if perl -e 'exit ! defined(getgrnam("postdrop"))' + then + # if postfix is installed, we will probably use + # queue/postfix, which will need this: + supp="-G postdrop" + fi + useradd -r -M -s /bin/false $supp smtpd +fi + +%changelog +* Sun Jul 12 2009 0.82-0.1 +- Update to latest release +- don't add qpsmtpd to start-up by default +- add apache config file to qpsmtpd-apache package +- remove all patches +- use rpm macros for dirs +- use a filelist for main package instead of a long list of files + +* Tue Jul 15 2008 0.43-0.7 +- Removed SelectServer.pm from .spec file + +* Tue Mar 18 2008 0.43-0.6 +- moved config files back to /etc/qpsmtpd following some changes + to the qpsmtpd src + +* Tue Mar 18 2008 0.43-0.5 +- moved config files to /etc/qpsmtpd/config + +* Tue Mar 18 2008 0.43-0.4 +- Moved qpsmtpd-async to /usr/bin +- Added qpsmtpd-async man page to async package +- Added async smtproute plugin to async package + +* Wed Mar 12 2008 0.43-0.3 +- Makefile.PL now updated in svn, so remove hack + +* Wed Mar 12 2008 0.43-0.2 +- Added qpsmtpd-prefork to qpsmtpd RPM, inc. hack to work round + deficiency in Makefile.PL + +* Mon Mar 10 2008 0.43-0.1 +- Updated to work with Makefile to build from svn + +* Wed Sep 12 2007 0.40-2.0 +- Updated to build trunk-r790 + +* Tue Jun 12 2007 0.40-1.0 +- updated to 0.40 - no code change. + +* Thu Jun 07 2007 0.40-0.2 +- unset environment variables which are normally tainted in perl. +- updated to 0.40rc1 +- added dependency on Net::IP (needed by some plugins) + +* Sat May 05 2007 0.33-0.5 +- moved environment cleanup into start() function, otherwise + LANG just gets reinitialized. + +* Sat May 05 2007 0.33-0.4 +- split qpsmtpd-async into a separate package to avoid dependency + on ParaDNS. + +* Sat May 05 2007 0.33-0.3 +- also unset LANG, LC_ALL and LC_TIME in startup script to prevent + locale specific Received headers (bug reported by Dominik Meyer) + +* Sun Feb 25 2007 0.33-0.2 +- 0.3x branch has been merged back to trunk. + Got current snapshot (r715) from trunk. + +* Sun Feb 25 2007 0.33-0.1 +- Start forkserver via "daemon" (Gavin Carr) +- Fixed 'service qpsmtpd-forkserver status' (Gavin Carr) +- Changed policy for config files to noreplace (Gavin Carr) + +* Sun Nov 05 2006 0.33-0.0 +- Upgraded to current snapshot from 0.3x branch (which should become + 0.33 soon-ish) +- included xinetd-support again. + +* Sat Mar 18 2006 0.32-2 +- fix dnsbl to check whether answer fits query. +- randomize Net::DNS ids for qpsmtpd-forkserver child processes. + +* Wed Mar 08 2006 0.32-1 +- New upstream 0.32 +- rc-file unsets PERL_UNICODE (bug #38397) + +* Sat Jan 28 2006 0.31.1-3 +- Use ${SOURCE*} macros to refer to source files +- Avoid invoking rpm and other cleanup in pre section +- Invoke chkconfig in post. +- (Thanks to Josko Plazonic for the reporting these problems and + suggesting fixes) + +* Tue Nov 30 2005 0.31.1-2 +- Revision 170 of plugins/loggin/file_connection: + Return DECLINED from open_log. + Open log in write_log if it isn't already open. + +* Tue Nov 29 2005 0.31.1-1 +- Commented out queue plugins from sample config +- Added dependencies +- Create smtpd user if it doesn't exist +- Added /var/log/qpsmtpd and /var/spool/qpsmtpd + +* Sat Nov 26 2005 +- Added file_connection plugin +- Startup file for qpsmtpd-forkserver now uses --detach and assumes that + a suitable logging module is configured (file_connection by default) + +* Wed Nov 23 2005 +- Forkserver drops privileges before loading plugins now. + +* Sun Nov 20 2005 +- New upstream 0.31.1 + +* Mon Nov 14 2005 0.31-8 +- New upstream 0.31rc3. +- pre-connection patch slightly simplified since upstream fixed one of + the bugs. + +* Tue Aug 23 2005 +- forced INSTALLSITELIB=/usr/lib/perl5/site_perl as suggested by + Charlie Brady. + +* Sat Aug 20 2005 0.31-7 +- RC2 from upstream. +- Removed patches which aren't applied from spec file. + +* Fri Jul 22 2005 0.31-6 +- New upstream snapshot from 0.31 branch: svn revision 509. + +* Sun Jul 17 2005 0.31-5 +- include only /etc/init.d/qpsmtpd-forkserver, not /etc/init.d + it conflicts with old initscripts packages. + +* Sun Jul 17 2005 0.31-4 +- removed tabs from forkserver + +* Sun Jul 17 2005 0.31-3 +- added startup script for forkserver +- changed BuildArchitectures to noarch. + +* Sat Jul 16 2005 0.31-2 +- pre-connection hook is now actually called, not just defined. + +* Fri Jul 15 2005 0.31-1 +- merged with 0.31. Most of my patches are now in the official release. +- merged Gavin's per-user-config patch with my dirs patch, since the + latter needs a way to turn off logging. +- added /etc/qpsmtpd/plugin_dir to package. + +* Mon Jun 13 2005 0.29-6 +- fixed removal of patch backup files +- fixed option --pid-file + +* Sun Jun 12 2005 +- avoid installing patch backup files +- split Apache::Qpsmtpd into separate package to avoid dependency hell. +- fixed URL +- changed group to Daemons. +- Fixed installation for newer versions of ExtUtils::MakeMaker + +* Wed Jun 1 2005 0.29-5 +- Really don't reap children in signal handler. + +* Tue May 31 2005 0.29-4 +- Return 421 for DENYSOFT_DISCONNECT +- Don't reap children in signal handler. + +* Thu May 19 2005 0.29-3 +- removed code to accept paths without <>. + +* Thu May 19 2005 0.29-2 +- added QPSMTPD_CONFIG env variable and plugin_dir config. +- added supplemental groups and support for pid file +- added shared_connect hook +- changed log level for SMTP dialog from DEBUG to INFO + +* Thu Apr 21 2005 hjp@hjp.at +- added plugins, /etc and docs. + +* Mon Apr 18 2005 hjp@hjp.at +- Specfile autogenerated + diff --git a/plugins/async/check_earlytalker b/plugins/async/check_earlytalker new file mode 100644 index 0000000..fa0266d --- /dev/null +++ b/plugins/async/check_earlytalker @@ -0,0 +1,134 @@ +#!perl -w + +=head1 NAME + +check_earlytalker - Check that the client doesn't talk before we send the SMTP banner + +=head1 DESCRIPTION + +Checks to see if the remote host starts talking before we've issued a 2xx +greeting. If so, we're likely looking at a direct-to-MX spam agent which +pipelines its entire SMTP conversation, and will happily dump an entire spam +into our mail log even if later tests deny acceptance. + +Depending on configuration, clients which behave in this way are either +immediately disconnected with a deny or denysoft code, or else are issued this +on all mail/rcpt commands in the transaction. + +=head1 CONFIGURATION + +=over 4 + +=item wait [integer] + +The number of seconds to delay the initial greeting to see if the connecting +host speaks first. The default is 1. Do not select a value that is too high, +or you may be unable to receive mail from MTAs with short SMTP connect or +greeting timeouts -- these are known to range as low as 30 seconds, and may +in some cases be configured lower by mailserver admins. Network transit time +must also be allowed for. + +=item action [string: deny, denysoft, log] + +What to do when matching an early-talker -- the options are I, +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) = @_; + + return DECLINED unless $self->connection->notes('earlytalker'); + return DECLINED if $self->{'defer-reject'}; + return (DENY,$MSG) if $self->{_args}->{'action'} eq 'deny'; + return (DENYSOFT,$MSG) if $self->{_args}->{'action'} eq 'denysoft'; + return DECLINED; # assume action eq 'log' +} + +sub hook_mail { + my ($self, $transaction) = @_; + + return DECLINED unless $self->connection->notes('earlytalker'); + return (DENY,$MSG) if $self->{_args}->{'action'} eq 'deny'; + return (DENYSOFT,$MSG) if $self->{_args}->{'action'} eq 'denysoft'; + return DECLINED; +} + diff --git a/plugins/async/dns_whitelist_soft b/plugins/async/dns_whitelist_soft new file mode 100644 index 0000000..1d42a03 --- /dev/null +++ b/plugins/async/dns_whitelist_soft @@ -0,0 +1,88 @@ +#!perl -w + +use Qpsmtpd::Plugin::Async::DNSBLBase; + +sub init { + my $self = shift; + my $class = ref $self; + + no strict 'refs'; + push @{"${class}::ISA"}, 'Qpsmtpd::Plugin::Async::DNSBLBase'; +} + +sub hook_connect { + my ($self, $transaction) = @_; + my $class = ref $self; + + my %whitelist_zones = + map { (split /\s+/, $_, 2)[0, 1] } $self->qp->config('whitelist_zones'); + + return DECLINED unless %whitelist_zones; + + my $remote_ip = $self->connection->remote_ip; + my $reversed_ip = join(".", reverse(split(/\./, $remote_ip))); + + # type TXT lookup only + return DECLINED + unless $class->lookup($self->qp, [], + [map { "$reversed_ip.$_" } keys %whitelist_zones], + ); + + return YIELD; +} + +sub process_txt_result { + my ($class, $qp, $result, $query) = @_; + + my $connection = $qp->connection; + $connection->notes('whitelisthost', $result) + unless $connection->notes('whitelisthost'); +} + +sub hook_rcpt { + my ($self, $transaction, $rcpt) = @_; + my $connection = $self->qp->connection; + + if (my $note = $connection->notes('whitelisthost')) { + my $ip = $connection->remote_ip; + $self->log(LOGNOTICE, "Host $ip is whitelisted: $note"); + } + return DECLINED; +} + +=head1 NAME + +dns_whitelist_soft - dns-based whitelist override for other qpsmtpd plugins + +=head1 DESCRIPTION + +The dns_whitelist_soft plugin allows selected host to be whitelisted as +exceptions to later plugin processing. It is most suitable for multisite +installations, so that the whitelist is stored in one location and available +from all. + +=head1 CONFIGURATION + +To enable the plugin, add it to the ~qpsmtpd/config/plugins file as usual. +It should precede any plugins whose rejections you wish to override. You may +have to alter those plugins to check the appropriate notes field. + +Several configuration files are supported, corresponding to different +parts of the SMTP conversation: + +=over 4 + +=item whitelist_zones + +Any IP address listed in the whitelist_zones file is queried using +the connecting MTA's IP address. Any A or TXT answer means that the +remote HOST address can be selectively exempted at other stages by plugins +testing for a 'whitelisthost' connection note. + +=back + +NOTE: in contrast to the non-async version, the other 'connect' hooks +fired after the 'connect' hook of this plugin will see the 'whitelisthost' +connection note, if set by this plugin. + +=cut diff --git a/plugins/async/dnsbl b/plugins/async/dnsbl new file mode 100644 index 0000000..e9c99ee --- /dev/null +++ b/plugins/async/dnsbl @@ -0,0 +1,202 @@ +#!perl -w + +use Qpsmtpd::Plugin::Async::DNSBLBase; + +sub init { + my ($self, $qp, $denial) = @_; + my $class = ref $self; + + { + no strict 'refs'; + push @{"${class}::ISA"}, 'Qpsmtpd::Plugin::Async::DNSBLBase'; + } + + if (defined $denial and $denial =~ /^disconnect$/i) { + $self->{_dnsbl}->{DENY} = DENY_DISCONNECT; + } + else { + $self->{_dnsbl}->{DENY} = DENY; + } +} + +sub hook_connect { + my ($self, $transaction) = @_; + my $class = ref $self; + + my $remote_ip = $self->connection->remote_ip; + + my $allow = + grep { s/\.?$/./; $_ eq substr($remote_ip . '.', 0, length $_) } + $self->qp->config('dnsbl_allow'); + return DECLINED if $allow; + + my %dnsbl_zones = + map { (split /:/, $_, 2)[0, 1] } $self->qp->config('dnsbl_zones'); + return DECLINED unless %dnsbl_zones; + + my $reversed_ip = join(".", reverse(split(/\./, $remote_ip))); + + my @A_zones = grep { defined($dnsbl_zones{$_}) } keys %dnsbl_zones; + my @TXT_zones = grep { !defined($dnsbl_zones{$_}) } keys %dnsbl_zones; + + if (@A_zones) { + + # message templates for responding to the client + $self->connection->notes( + dnsbl_templates => { + map { + +"$reversed_ip.$_" => $dnsbl_zones{$_} + } @A_zones + } + ); + } + + return DECLINED + unless $class->lookup($self->qp, + [map { "$reversed_ip.$_" } @A_zones], + [map { "$reversed_ip.$_" } @TXT_zones], + ); + + return YIELD; +} + +sub process_a_result { + my ($class, $qp, $result, $query) = @_; + + my $conn = $qp->connection; + return if $class->connection->notes('dnsbl'); + + my $templates = $class->connection->notes('dnsbl_templates'); + my $ip = $conn->remote_ip; + + my $template = $templates->{$query}; + $template =~ s/%IP%/$ip/g; + + $class->connection->notes('dnsbl', $template); +} + +sub process_txt_result { + my ($class, $qp, $result, $query) = @_; + + my $conn = $class->connection; + $conn->notes('dnsbl', $result) unless $conn->notes('dnsbl'); +} + +sub hook_rcpt { + my ($self, $transaction, $rcpt) = @_; + my $connection = $self->qp->connection; + + # RBLSMTPD being non-empty means it contains the failure message to return + if (defined($ENV{'RBLSMTPD'}) && $ENV{'RBLSMTPD'} ne '') { + my $result = $ENV{'RBLSMTPD'}; + my $remote_ip = $self->connection->remote_ip; + $result =~ s/%IP%/$remote_ip/g; + return (DENY, join(" ", $self->qp->config('dnsbl_rejectmsg'), $result)); + } + + my $note = $self->connection->notes('dnsbl'); + return (DENY, $note) if $note; + return DECLINED; +} + +=head1 NAME + +dnsbl - handle DNS BlackList lookups + +=head1 DESCRIPTION + +Plugin that checks the IP address of the incoming connection against +a configurable set of RBL services. + +=head1 Configuration files + +This plugin uses the following configuration files. All of these are optional. +However, not specifying dnsbl_zones is like not using the plugin at all. + +=over 4 + +=item dnsbl_zones + +Normal ip based dns blocking lists ("RBLs") which contain TXT records are +specified simply as: + + relays.ordb.org + spamsources.fabel.dk + +To configure RBL services which do not contain TXT records in the DNS, +but only A records (e.g. the RBL+ at http://www.mail-abuse.org), specify your +own error message to return in the SMTP conversation after a colon e.g. + + rbl-plus.mail-abuse.org:You are listed at - http://http://www.mail-abuse.org/cgi-bin/lookup?%IP% + +The string %IP% will be replaced with the IP address of incoming connection. +Thus a fully specified file could be: + + sbl-xbl.spamhaus.org + list.dsbl.org + rbl-plus.mail-abuse.ja.net:Listed by rbl-plus.mail-abuse.ja.net - see + 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 diff --git a/plugins/async/queue/smtp-forward b/plugins/async/queue/smtp-forward new file mode 100644 index 0000000..10665bf --- /dev/null +++ b/plugins/async/queue/smtp-forward @@ -0,0 +1,400 @@ +#!perl -w + +=head1 NAME + +smtp-forward + +=head1 DESCRIPTION + +This plugin forwards the mail via SMTP to a specified server, rather than +delivering the email locally. + +=head1 CONFIG + +It takes one required parameter, the IP address or hostname to forward to. + + async/queue/smtp-forward 10.2.2.2 + +Optionally you can also add a port: + + async/queue/smtp-forward 10.2.2.2 9025 + +=cut + +use Qpsmtpd::Constants; + +sub register { + my ($self, $qp) = @_; + + $self->register_hook(queue => "start_queue"); + $self->register_hook(queue => "finish_queue"); +} + +sub init { + my ($self, $qp, @args) = @_; + + if (@args > 0) { + if ($args[0] =~ /^([\.\w_-]+)$/) { + $self->{_smtp_server} = $1; + } + else { + die "Bad data in smtp server: $args[0]"; + } + $self->{_smtp_port} = 25; + if (@args > 1 and $args[1] =~ /^(\d+)$/) { + $self->{_smtp_port} = $1; + } + + $self->log(LOGWARN, "WARNING: Ignoring additional arguments.") if (@args > 2); + } + else { + die("No SMTP server specified in smtp-forward config"); + } + +} + +sub start_queue { + my ($self, $transaction) = @_; + + my $qp = $self->qp; + my $SERVER = $self->{_smtp_server}; + my $PORT = $self->{_smtp_port}; + $self->log(LOGINFO, "forwarding to $SERVER:$PORT"); + + $transaction->notes('async_sender', + AsyncSMTPSender->new($SERVER, $PORT, $qp, $self, $transaction) + ); + + return YIELD; +} + +sub finish_queue { + my ($self, $transaction) = @_; + + my $sender = $transaction->notes('async_sender'); + $transaction->notes('async_sender', undef); + + my ($rc, $msg) = $sender->results; + + return $rc, $msg; +} + +package AsyncSMTPSender; + +use IO::Socket; + +use base qw(Danga::Socket); +use fields qw( + qp + pkg + tran + state + rcode + rmsg + buf + command + resp + to + ); + +use constant ST_CONNECTING => 0; +use constant ST_CONNECTED => 1; +use constant ST_COMMANDS => 2; +use constant ST_DATA => 3; + +use Qpsmtpd::Constants; + +sub new { + my ($self, $server, $port, $qp, $pkg, $transaction) = @_; + $self = fields::new($self) unless ref $self; + + my $sock = IO::Socket::INET->new( + PeerAddr => $server, + PeerPort => $port, + Blocking => 0, + ) or die "Error connecting to server $server:$port : $!\n"; + + IO::Handle::blocking($sock, 0); + binmode($sock, ':raw'); + + $self->{qp} = $qp; + $self->{pkg} = $pkg; + $self->{tran} = $transaction; + $self->{state} = ST_CONNECTING; + $self->{rcode} = DECLINED; + $self->{command} = 'connect'; + $self->{buf} = ''; + $self->{resp} = []; + # copy the recipients so we can pop them off one by one + $self->{to} = [ $transaction->recipients ]; + + $self->SUPER::new($sock); + # Watch for write first, this is when the TCP session is established. + $self->watch_write(1); + + return $self; +} + +sub results { + my AsyncSMTPSender $self = shift; + return ( $self->{rcode}, $self->{rmsg} ); +} + +sub log { + my AsyncSMTPSender $self = shift; + $self->{qp}->log(@_); +} + +sub cont { + my AsyncSMTPSender $self = shift; + $self->{qp}->run_continuation; +} + +sub command { + my AsyncSMTPSender $self = shift; + my ($command, $params) = @_; + $params ||= ''; + + $self->log(LOGDEBUG, ">> $command $params"); + + $self->write(($command =~ m/ / ? "$command:" : $command) + . ($params ? " $params" : "") . "\r\n"); + $self->watch_read(1); + $self->{command} = ($command =~ /(\S+)/)[0]; +} + +sub handle_response { + my AsyncSMTPSender $self = shift; + + my $method = "cmd_" . lc($self->{command}); + + $self->$method(@_); +} + +sub cmd_connect { + my AsyncSMTPSender $self = shift; + my ($code, $response) = @_; + + if ($code != 220) { + $self->{rmsg} = "Error on connect: @$response"; + $self->close; + $self->cont; + } + else { + my $host = $self->{qp}->config('me'); + print "HELOing with $host\n"; + $self->command((join '', @$response) =~ m/ ESMTP/ ? "EHLO" : "HELO", $host); + } +} + +sub cmd_helo { + my AsyncSMTPSender $self = shift; + my ($code, $response) = @_; + + if ($code != 250) { + $self->{rmsg} = "Error on HELO: @$response"; + $self->close; + $self->cont; + } + else { + $self->command("MAIL", "FROM:" . $self->{tran}->sender->format); + } +} + +sub cmd_ehlo { + my AsyncSMTPSender $self = shift; + my ($code, $response) = @_; + + if ($code != 250) { + $self->{rmsg} = "Error on EHLO: @$response"; + $self->close; + $self->cont; + } + else { + $self->command("MAIL", "FROM:" . $self->{tran}->sender->format); + } +} + +sub cmd_mail { + my AsyncSMTPSender $self = shift; + my ($code, $response) = @_; + + if ($code != 250) { + $self->{rmsg} = "Error on MAIL FROM: @$response"; + $self->close; + $self->cont; + } + else { + $self->command("RCPT", "TO:" . shift(@{$self->{to}})->format); + } +} + +sub cmd_rcpt { + my AsyncSMTPSender $self = shift; + my ($code, $response) = @_; + + if ($code != 250) { + $self->{rmsg} = "Error on RCPT TO: @$response"; + $self->close; + $self->cont; + } + else { + if (@{$self->{to}}) { + $self->command("RCPT", "TO:" . shift(@{$self->{to}})->format); + } + else { + $self->command("DATA"); + } + } +} + +sub cmd_data { + my AsyncSMTPSender $self = shift; + my ($code, $response) = @_; + + if ($code != 354) { + $self->{rmsg} = "Error on DATA: @$response"; + $self->close; + $self->cont; + } + else { + # $self->{state} = ST_DATA; + $self->datasend($self->{tran}->header->as_string); + $self->{tran}->body_resetpos; + my $write_buf = ''; + while (my $line = $self->{tran}->body_getline) { + $line =~ s/\r?\n/\r\n/; + $write_buf .= $line; + if (length($write_buf) >= 131072) { # 128KB, arbitrary value + $self->log(LOGDEBUG, ">> $write_buf"); + $self->datasend($write_buf); + $write_buf = ''; + } + } + if (length($write_buf)) { + $self->log(LOGDEBUG, ">> $write_buf"); + $self->datasend($write_buf); + } + $self->write(".\r\n"); + $self->{command} = "DATAEND"; + } +} + +sub cmd_dataend { + my AsyncSMTPSender $self = shift; + my ($code, $response) = @_; + + if ($code != 250) { + $self->{rmsg} = "Error after DATA: @$response"; + $self->close; + $self->cont; + } + else { + $self->command("QUIT"); + } +} + +sub cmd_quit { + my AsyncSMTPSender $self = shift; + my ($code, $response) = @_; + + $self->{rcode} = OK; + $self->{rmsg} = "Queued!"; + $self->close; + $self->cont; +} + +sub datasend { + my AsyncSMTPSender $self = shift; + my ($data) = @_; + $data =~ s/^\./../mg; + $self->write(\$data); +} + +sub event_read { + my AsyncSMTPSender $self = shift; + + if ($self->{state} == ST_CONNECTED) { + $self->{state} = ST_COMMANDS; + } + + if ($self->{state} == ST_COMMANDS) { + my $in = $self->read(1024); + if (!$in) { + # XXX: connection closed + $self->close("lost connection"); + return; + } + + my @lines = split /\r?\n/, $self->{buf} . $$in, -1; + $self->{buf} = delete $lines[-1]; + + for(@lines) { + if (my ($code, $cont, $rest) = /^([0-9]{3})([ -])(.*)/) { + $self->log(LOGDEBUG, "<< $code$cont$rest"); + push @{$self->{resp}}, $rest; + + if($cont eq ' ') { + $self->handle_response($code, $self->{resp}); + $self->{resp} = []; + } + } + else { + $self->log(LOGERROR, "Unrecognised SMTP response line: $_"); + $self->{rmsg} = "Error from upstream SMTP server"; + $self->close; + $self->cont; + } + } + } + else { + $self->log(LOGERROR, "SMTP Session occurred out of order"); + $self->close; + $self->cont; + } +} + +sub event_write { + my AsyncSMTPSender $self = shift; + + if ($self->{state} == ST_CONNECTING) { + $self->watch_write(0); + $self->{state} = ST_CONNECTED; + $self->watch_read(1); + } + elsif (0 && $self->{state} == ST_DATA) { + # send more data + if (my $line = $self->{tran}->body_getline) { + $self->log(LOGDEBUG, ">> $line"); + $line =~ s/\r?\n/\r\n/; + $self->datasend($line); + } + else { + # no more data. + $self->log(LOGINFO, "No more data"); + $self->watch_write(0); + $self->{state} = ST_COMMANDS; + } + } + else { + $self->write(undef); + } +} + +sub event_err { + my ($self) = @_; + eval { $self->read(1); }; # gives us the correct error in errno + $self->{rmsg} = "Read error from remote server: $!"; + #print "lost connection: $!\n"; + $self->close; + $self->cont; +} + +sub event_hup { + my ($self) = @_; + eval { $self->read(1); }; # gives us the correct error in errno + $self->{rmsg} = "HUP error from remote server: $!"; + #print "lost connection: $!\n"; + $self->close; + $self->cont; +} diff --git a/plugins/async/require_resolvable_fromhost b/plugins/async/require_resolvable_fromhost new file mode 100644 index 0000000..4bfe7d8 --- /dev/null +++ b/plugins/async/require_resolvable_fromhost @@ -0,0 +1,181 @@ +#!perl -w + +use strict; +use warnings; + +use Qpsmtpd::Constants; +use Qpsmtpd::DSN; +use Qpsmtpd::TcpServer; + +#use ParaDNS; # moved into register +use Socket; + +my %invalid = (); +my $has_ipv6 = Qpsmtpd::TcpServer::has_ipv6(); + +sub register { + my ( $self, $qp ) = @_; + + foreach my $i ( $self->qp->config("invalid_resolvable_fromhost") ) { + $i =~ s/^\s*//; + $i =~ s/\s*$//; + if ( $i =~ m#^((\d{1,3}\.){3}\d{1,3})/(\d\d?)# ) { + $invalid{$1} = $3; + } + } + + eval 'use ParaDNS'; + if ( $@ ) { + warn "could not load ParaDNS, plugin disabled"; + return DECLINED; + }; + $self->register_hook( mail => 'hook_mail_start' ); + $self->register_hook( mail => 'hook_mail_done' ); +} + +sub hook_mail_start { + my ( $self, $transaction, $sender ) = @_; + + return DECLINED + if ($self->connection->notes('whitelisthost')); + + if ( $sender ne '<>' ) { + + unless ( $sender->host ) { + # default of addr_bad_from_system is DENY, we use DENYSOFT here to + # get the same behaviour as without Qpsmtpd::DSN... + return Qpsmtpd::DSN->addr_bad_from_system( DENYSOFT, + "FQDN required in the envelope sender" ); + } + + return DECLINED if $sender->host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/; + + unless ($self->check_dns( $sender->host )) { + return Qpsmtpd::DSN->temp_resolver_failed( + "Could not resolve " . $sender->host ); + } + + return YIELD; + } + + return DECLINED; +} + +sub hook_mail_done { + my ( $self, $transaction, $sender ) = @_; + + return DECLINED + if ( $self->connection->notes('whitelisthost') ); + + if ( $sender ne "<>" && !$transaction->notes('resolvable_fromhost') ) { + # default of temp_resolver_failed is DENYSOFT + return Qpsmtpd::DSN->temp_resolver_failed( + "Could not resolve " . $sender->host ); + } + return DECLINED; +} + +sub check_dns { + my ( $self, $host ) = @_; + my @host_answers; + + my $qp = $self->qp; + $qp->input_sock->pause_read; + + my $a_records = []; + my $num_queries = 1; # queries in progress + my $mx_found = 0; + + ParaDNS->new( + callback => sub { + my $mx = shift; + return if $mx =~ /^[A-Z]+$/; # error + + my $addr = $mx->[0]; + $mx_found = 1; + + $num_queries++; + ParaDNS->new( + callback => sub { push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/; }, + finished => sub { $num_queries--; $self->finish_up($qp, $a_records, $num_queries) }, + host => $addr, + type => 'A', + ); + + if ($has_ipv6) { + $num_queries++; + ParaDNS->new( + callback => sub { push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/; }, + finished => sub { $num_queries--; $self->finish_up($qp, $a_records, $num_queries) }, + host => $addr, + type => 'AAAA', + ); + } + }, + finished => sub { + + unless ($mx_found) { + + $num_queries++; + ParaDNS->new( + callback => sub { push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/; }, + finished => sub { $num_queries--; $self->finish_up($qp, $a_records, $num_queries) }, + host => $host, + type => 'A', + ); + + if ($has_ipv6) { + $num_queries++; + ParaDNS->new( + callback => sub { push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/; }, + finished => sub { $num_queries--; $self->finish_up($qp, $a_records, $num_queries) }, + host => $host, + type => 'AAAA', + ); + } + + } + + $num_queries--; + $self->finish_up($qp, $a_records, $num_queries); + }, + host => $host, + type => 'MX', + ) or $qp->input_sock->continue_read, return; + + return 1; +} + +sub finish_up { + my ($self, $qp, $a_records, $num_queries) = @_; + + return if defined $qp->transaction->notes('resolvable_fromhost'); + + foreach my $addr (@$a_records) { + if (is_valid($addr)) { + $qp->transaction->notes('resolvable_fromhost', 1); + $qp->input_sock->continue_read; + $qp->run_continuation; + return; + } + } + + unless ($num_queries) { + # all queries returned no valid response + $qp->transaction->notes('resolvable_fromhost', 0); + $qp->input_sock->continue_read; + $qp->run_continuation; + } +} + +sub is_valid { + my $ip = shift; + my ( $net, $mask ); + foreach $net ( keys %invalid ) { + $mask = $invalid{$net}; + $mask = pack "B32", "1" x ($mask) . "0" x ( 32 - $mask ); + return 0 + if join( ".", unpack( "C4", inet_aton($ip) & $mask ) ) eq $net; + } + return 1; +} diff --git a/plugins/async/rhsbl b/plugins/async/rhsbl new file mode 100644 index 0000000..c0a5e53 --- /dev/null +++ b/plugins/async/rhsbl @@ -0,0 +1,92 @@ +#!perl -w + +use Qpsmtpd::Plugin::Async::DNSBLBase; + +sub init { + my $self = shift; + my $class = ref $self; + + no strict 'refs'; + push @{"${class}::ISA"}, 'Qpsmtpd::Plugin::Async::DNSBLBase'; +} + +sub hook_mail { + my ($self, $transaction, $sender) = @_; + my $class = ref $self; + + return DECLINED if $sender->format eq '<>'; + + my %rhsbl_zones = + map { (split /\s+/, $_, 2)[0, 1] } $self->qp->config('rhsbl_zones'); + return DECLINED unless %rhsbl_zones; + + my $sender_host = $sender->host; + + my @A_zones = grep { defined($rhsbl_zones{$_}) } keys %rhsbl_zones; + my @TXT_zones = grep { !defined($rhsbl_zones{$_}) } keys %rhsbl_zones; + + if (@A_zones) { + + # message templates for responding to the client + $transaction->notes(rhsbl_templates => + {map { +"$sender_host.$_" => $rhsbl_zones{$_} } @A_zones}); + } + + return DECLINED + unless $class->lookup($self->qp, + [map { "$sender_host.$_" } @A_zones], + [map { "$sender_host.$_" } @TXT_zones], + ); + + return YIELD; +} + +sub process_a_result { + my ($class, $qp, $result, $query) = @_; + + my $transaction = $qp->transaction; + $transaction->notes('rhsbl', + $transaction->notes('rhsbl_templates')->{$query}) + unless $transaction->notes('rhsbl'); +} + +sub process_txt_result { + my ($class, $qp, $result, $query) = @_; + + my $transaction = $qp->transaction; + $transaction->notes('rhsbl', $result) unless $transaction->notes('rhsbl'); +} + +sub hook_rcpt { + my ($self, $transaction, $rcpt) = @_; + my $host = $transaction->sender->host; + + my $note = $transaction->notes('rhsbl'); + return (DENY, "Mail from $host rejected because it $note") if $note; + return DECLINED; +} + +=head1 NAME + +rhsbl - handle RHSBL lookups + +=head1 DESCRIPTION + +Pluging that checks the host part of the sender's address against a +configurable set of RBL services. + +=head1 CONFIGURATION + +This plugin reads the lists to use from the rhsbl_zones configuration +file. Normal domain based dns blocking lists ("RBLs") which contain TXT +records are specified simply as: + + dsn.rfc-ignorant.org + +To configure RBL services which do not contain TXT records in the DNS, +but only A records, specify, after a whitespace, your own error message +to return in the SMTP conversation e.g. + + abuse.rfc-ignorant.org does not support abuse@domain + +=cut diff --git a/plugins/async/uribl b/plugins/async/uribl new file mode 100644 index 0000000..27b991b --- /dev/null +++ b/plugins/async/uribl @@ -0,0 +1,142 @@ +#!perl -w + +use Qpsmtpd::Plugin::Async::DNSBLBase; + +use strict; +use warnings; + +sub init { + my ($self, $qp, %args) = @_; + my $class = ref $self; + + $self->isa_plugin("uribl"); + { + no strict 'refs'; + push @{"${class}::ISA"}, 'Qpsmtpd::Plugin::Async::DNSBLBase'; + } + + $self->SUPER::init($qp, %args); +} + +sub register { + my $self = shift; + + $self->register_hook('data_post', 'start_data_post'); + $self->register_hook('data_post', 'finish_data_post'); +} + +sub start_data_post { + my ($self, $transaction) = @_; + my $class = ref $self; + + my @names; + + my $queries = $self->lookup_start($transaction, sub { + my ($self, $name) = @_; + push @names, $name; + }); + + my @hosts; + foreach my $z (keys %{$self->{uribl_zones}}) { + push @hosts, map { "$_.$z" } @names; + } + + $transaction->notes(uribl_results => {}); + $transaction->notes(uribl_zones => $self->{uribl_zones}); + + return DECLINED + unless @hosts && $class->lookup($self->qp, [ @hosts ], [ @hosts ]); + + return YIELD; +} + +sub finish_data_post { + my ($self, $transaction) = @_; + + my $matches = $self->collect_results($transaction); + for (@$matches) { + $self->log(LOGWARN, $_->{desc}); + if ($_->{action} eq 'add-header') { + $transaction->header->add('X-URIBL-Match', $_->{desc}); + } elsif ($_->{action} eq 'deny') { + return (DENY, $_->{desc}); + } elsif ($_->{action} eq 'denysoft') { + return (DENYSOFT, $_->{desc}); + } + } + return DECLINED; +} + +sub init_resolver { } + +sub process_a_result { + my ($class, $qp, $result, $query) = @_; + + my $transaction = $qp->transaction; + my $results = $transaction->notes('uribl_results'); + my $zones = $transaction->notes('uribl_zones'); + + foreach my $z (keys %$zones) { + if ($query =~ /^(.*)\.$z$/) { + my $name = $1; + $results->{$z}->{$name}->{a} = $result; + } + } +} + +sub process_txt_result { + my ($class, $qp, $result, $query) = @_; + + my $transaction = $qp->transaction; + my $results = $transaction->notes('uribl_results'); + my $zones = $transaction->notes('uribl_zones'); + + foreach my $z (keys %$zones) { + if ($query =~ /^(.*)\.$z$/) { + my $name = $1; + $results->{$z}->{$name}->{txt} = $result; + } + } +} + +sub collect_results { + my ($self, $transaction) = @_; + + my $results = $transaction->notes('uribl_results'); + + my @matches; + foreach my $z (keys %$results) { + foreach my $n (keys %{$results->{$z}}) { + if (exists $results->{$z}->{$n}->{a}) { + if ($self->evaluate($z, $results->{$z}->{$n}->{a})) { + $self->log(LOGDEBUG, "match $n in $z"); + push @matches, { + action => $self->{uribl_zones}->{$z}->{action}, + desc => "$n in $z: " . + ($results->{$z}->{$n}->{txt} || $results->{$z}->{$n}->{a}), + }; + } + } + } + } + + return \@matches; +} + +=head1 NAME + +uribl - URIBL blocking plugin for qpsmtpd + +=head1 DESCRIPTION + +This plugin implements DNSBL lookups for URIs found in spam, such as that +implemented by SURBL (see 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 diff --git a/plugins/auth/auth_checkpassword b/plugins/auth/auth_checkpassword new file mode 100644 index 0000000..28d7894 --- /dev/null +++ b/plugins/auth/auth_checkpassword @@ -0,0 +1,192 @@ +#!perl -w + +=head1 NAME + +auth_checkpassword - Authenticate against a DJB style checkpassword program + +=head1 DESCRIPTION + +This plugin authenticates users against a DJB style checkpassword +program. Unlike previous checkpassword implementations, this plugin +expects qpsmtpd to be running as the qpsmtpd user. Privilege +escalation can be attained by running the checkpassword binary setuid +or with sudo. + +=head1 CONFIGURATION + +Configure the path to your checkpassword binary. You can configure this in +config/plugins by defining the checkpw and true arguments as follows: + + auth/auth_checkpassword checkpw /usr/local/vpopmail/bin/vchkpw true /bin/true + +or by editing the config file config/smtpauth-checkpassword: + + echo "/usr/local/vpopmail/bin/vchkpw /bin/true" > ~qpsmtpd/config/smtpauth-checkpassword + +vchkpw is the checkpassword program provided by vpopmail. Substitute +your own checkpassword app as appropriate. + +If you are using vchkpw and this plugin is being executed by a user ID +other than 89 or 0 (as is the default), and the vchkpw binary is not +setuid (as is the default), this plugin will automatically prepend the +vchkpw command with sudo. If that is the case, you must configure sudo +by adding these two lines to your sudoers file: + + Defaults:qpsmtpd closefrom_override + qpsmtpd ALL = (ALL) NOPASSWD: /usr/local/vpopmail/bin/vchkpw + +The closefrom_override option is necessary because, by default, sudo +appropriates the first 3 file descriptors. Those descriptors are +necessary to communicate with the checkpassword program. If you run +qpsmtpd as some other user, adjust the sudo lines approriately. + +Using sudo is preferable to enabling setuid on the vchkpw binary. If +you reinstall vpopmail and the setuid bit is lost, this plugin will be +broken. + +=head1 SEE ALSO + +If you are using this plugin with vpopmail, please read the VPOPMAIL +section in docs/authentication.pod + +=head1 DIAGNOSTICS + +Is the path in the config/smtpauth-checkpassword correct? + +Is the path to true in config/smtpauth-checkpassword correct? + +Is qpsmtpd running as the qpsmtpd user? If not, did you adjust the +sudo configuration appropriately? + +If you are not using sudo, did you remember to make the vchkpw binary +setuid (chmod 4711 ~vpopmail/bin/vchkpw)? + +While writing this plugin, I first wrote myself a little test script, +which helped me identify the sudo closefrom_override issue. Here is +that script: + + #!/usr/bin/perl + use strict; + my $sudo = "/usr/local/bin/sudo"; + $sudo .= " -C4 -u vpopmail"; + my $vchkpw = "/usr/local/vpopmail/bin/vchkpw"; + my $true = "/bin/true"; + + open(CPW,"|$sudo $vchkpw $true 3<&0"); + printf(CPW "%s\0%s\0Y123456\0",'user@example.com','pa55word'); + close(CPW); + + my $status = $?; + print "FAIL\n" and exit if ( $status != 0 ); + print "OK\n"; + +Save that script to vchkpw.pl and then run it as the same user that +qpsmtpd runs as: + + setuidgid qpsmtpd perl vchkpw.pl + +If you aren't using sudo, then remove $sudo from the open line. + +=head1 ACKNOWLEDGEMENTS + +based upon authcheckpassword by Michael Holzt +and adapted by Johan Almqvist 2006-01-18 + +=head1 AUTHOR + +Matt Simerson + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2010 Matt Simerson + +This plugin is licensed under the same terms as the qpsmtpd package itself. +Please see the LICENSE file included with qpsmtpd for details. + +=cut + +sub register { + my ($self, $qp, %args ) = @_; + + my ($checkpw, $true) = $self->get_checkpw( \%args ); + return DECLINED if ! $checkpw || ! $true; + + $self->connection->notes('auth_checkpassword_bin', $checkpw); + $self->connection->notes('auth_checkpassword_true', $true); + + $self->register_hook('auth-plain', 'auth_checkpassword'); + $self->register_hook('auth-login', 'auth_checkpassword'); +} + +sub auth_checkpassword { + my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) = + @_; + + my $binary = $self->connection->notes('auth_checkpassword_bin'); + my $true = $self->connection->notes('auth_checkpassword_true'); + chomp ($binary, $true); + + my $sudo = get_sudo($binary); + + $self->log(LOGDEBUG, "auth_checkpassword: $sudo $binary $true 3<&0"); + open(CPW, "|$sudo $binary $true 3<&0"); + printf(CPW "%s\0%s\0Y123456\0", $user, $passClear); + close(CPW); + + my $status = $?; + + if ($status != 0) { + $self->log(LOGNOTICE, "authentication failed ($status)"); + return (DECLINED); + }; + + $self->connection->notes('authuser', $user); + return (OK, "auth_checkpassword"); +} + +sub get_checkpw { + my ($self, $args) = @_; + + my ($checkpw) = $args->{checkpw} =~ /^(.*)$/ if $args->{checkpw}; # untaint + my ($true) = $args->{true} =~ /^(.*)$/ if $args->{true}; # untaint + + return ( $checkpw, $true ) + if ( $checkpw && $true && -x $checkpw && -x $true ); + + my $missing_config = "disabled due to invalid configuration. See 'perldoc plugins/auth/auth_checkpassword' for how to configure."; + + if ( ! $self->qp->config('smtpauth-checkpassword') ) { + $self->log(LOGERROR, $missing_config ); + return; + }; + + $self->log(LOGNOTICE, "reading config from smtpauth-checkpassword"); + my $config = $self->qp->config("smtpauth-checkpassword"); + ($checkpw, $true) = $config =~ /^(\S+)\s+(\S+)\s*$/; + + if ( ! $checkpw || ! $true || ! -x $checkpw || ! -x $true ) { + $self->log(LOGERROR, $missing_config ); + return; + }; + return ($checkpw, $true); +}; + +sub get_sudo { + my $binary = shift; + + return '' if $> == 0; # running as root + return '' if $> == 89 && $binary =~ /vchkpw$/; # running as vpopmail + + my $mode = (stat($binary))[2]; + $mode = sprintf "%lo", $mode & 07777; + return '' if $mode eq '4711'; # $binary is setuid + + my $sudo = `which sudo` || '/usr/local/bin/sudo'; + return '' if ! -x $sudo; + + $sudo .= ' -C4'; # prevent sudo from clobbering file descriptor 3 + + return $sudo if $binary !~ /vchkpw$/; + return "$sudo -u vpopmail"; +} + diff --git a/plugins/auth/auth_cvm_unix_local b/plugins/auth/auth_cvm_unix_local new file mode 100644 index 0000000..c468381 --- /dev/null +++ b/plugins/auth/auth_cvm_unix_local @@ -0,0 +1,130 @@ +#!perl -w + +=head1 NAME + +auth_cvm_unix_local - SMTP AUTH LOGIN module using +Bruce Guenther's Credential Validation Module (CVM) + http://untroubled.org/cvm/ + +=head1 SYNOPSIS + +In config/plugins: + + auth/auth_cvm_unix_local \ + cvm_socket /var/lib/cvm/cvm-unix-local.socket \ + enable_smtp no \ + enable_ssmtp yes + +=head1 BUGS + +- Should probably handle auth-cram-md5 as well. However, this requires +access to the plain text password. We could store a separate database +of passwords purely for SMTP AUTH, for example as an optional +SMTPAuthPassword property of an account in the esmith::AccountsDB; + +=head1 DESCRIPTION + +This plugin implements an authentication plugin using Bruce Guenther's +Credential Validation Module (http://untroubled.org/cvm). + +=head1 AUTHOR + +Copyright 2005 Gordon Rowell + +This software is free software and may be distributed under the same +terms as qpsmtpd itself. + +=head1 VERSION + +Version $Id: auth_cvm_unix_local,v 1.1 2005/06/09 22:50:06 gordonr Exp gordonr $ + +=cut + +use strict; +use warnings; + +use Qpsmtpd::Constants; + +use Socket; +use constant SMTP_PORT => getservbyname("smtp", "tcp") || 25; +use constant SSMTP_PORT => getservbyname("ssmtp", "tcp") || 465; + +sub register { + my ( $self, $qp, %arg ) = @_; + + unless ($arg{cvm_socket}) { + $self->log(LOGERROR, "skip: requires cvm_socket argument"); + return 0; + }; + + $self->{_args} = { %arg }; + $self->{_enable_smtp} = $arg{enable_smtp} || 'no'; + $self->{_enable_ssmtp} = $arg{enable_ssmtp} || 'yes'; + + my $port = $ENV{PORT} || SMTP_PORT; + + return 0 if ($port == SMTP_PORT && $arg{enable_smtp} ne 'yes'); + return 0 if ($port == SSMTP_PORT && $arg{enable_ssmtp} ne 'yes'); + + if ($arg{cvm_socket} =~ /^([\w\/.-]+)$/) { + $self->{_cvm_socket} = $1; + } + + unless (-S $self->{_cvm_socket}) { + $self->log(LOGERROR, "skip: cvm_socket missing or not usable"); + return 0; + } + + $self->register_hook("auth-plain", "authcvm_plain"); + $self->register_hook("auth-login", "authcvm_plain"); +# $self->register_hook("auth-cram-md5", "authcvm_hash"); +} + +sub authcvm_plain { + my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) = + @_; + + socket(SOCK, PF_UNIX, SOCK_STREAM, 0) or do { + $self->log(LOGERROR, "skip: socket creation attempt for: $user"); + return (DENY, "authcvm"); + }; + +# DENY, really? Should this plugin return a DENY when it cannot connect +# to the cvs socket? I'd expect such a failure to return DECLINED, so +# any other auth plugins could take a stab at authenticating the user + + connect(SOCK, sockaddr_un($self->{_cvm_socket})) or do { + $self->log(LOGERROR, "skip: socket connection attempt for: $user"); + return (DENY, "authcvm"); + }; + + my $o = select(SOCK); $| = 1; select($o); + + my ($u, $host) = split(/\@/, $user); + $host ||= "localhost"; + + print SOCK "\001$u\000$host\000$passClear\000\000"; + + shutdown SOCK, 1; # tell remote we're finished + + my $ret = ; + my ($s) = unpack ("C", $ret); + + if ( ! defined $s ) { + $self->log(LOGERROR, "skip: no response from cvm for $user"); + return (DECLINED); + }; + + if ( $s == 0 ) { + $self->log(LOGINFO, "pass: authentication for: $user"); + return (OK, "auth success for $user"); + }; + + if ( $s == 100 ) { + $self->log(LOGINFO, "fail: authentication failure for: $user"); + return (DENY, 'auth failure (100)'); + }; + + $self->log(LOGERROR, "skip: unknown response from cvm for $user"); + return (DECLINED, "unknown result code ($s)"); +} diff --git a/plugins/auth/auth_flat_file b/plugins/auth/auth_flat_file new file mode 100644 index 0000000..a17d051 --- /dev/null +++ b/plugins/auth/auth_flat_file @@ -0,0 +1,83 @@ +#!perl -w + +=head1 NAME + +auth_flat_file - simple CRAM MD5 auth plugin using a flat password file + +=head1 SYNOPSIS + +in config/plugins: + + auth/auth_flat_file + +in config/flat_auth_pw + + username1:password1 + username2:password2 + ... + +=head1 DESCRIPTION + +This plugin implements a very simple authentication plugin using a flat password +file containing username and password separated by colons. + +Note that this plugin enforces the use of a full email address (including +@domain) as the username. There's no particular reason for this so feel free +to modify the code to suit your setup. + +The password is stored on disk unencrypted, however authentication uses a HMAC +algorithm so no password is transfered in the clear. + +=cut + +use strict; +use warnings; + +use Qpsmtpd::Auth; +use Qpsmtpd::Constants; + +sub register { + my ( $self, $qp ) = @_; + + $self->register_hook('auth-plain', 'auth_flat_file'); + $self->register_hook('auth-login', 'auth_flat_file'); + $self->register_hook('auth-cram-md5', 'auth_flat_file'); +} + +sub auth_flat_file { + my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) = + @_; + + if ( ! defined $passClear && ! defined $passHash ) { + $self->log(LOGINFO, "fail: missing password"); + return ( DENY, "authflat - missing password" ); + } + + my ( $pw_name, $pw_domain ) = split '@', lc($user); + + unless ( defined $pw_domain ) { + $self->log(LOGINFO, "fail: missing domain"); + return DECLINED; + } + + my ($auth_line) = grep {/^$pw_name\@$pw_domain:/} $self->qp->config('flat_auth_pw'); + + if ( ! defined $auth_line) { + $self->log(LOGINFO, "fail: no such user: $user"); + return DECLINED; + } + + my ($auth_user, $auth_pass) = split(/:/, $auth_line, 2); + + # at this point we can assume the user name matched + return Qpsmtpd::Auth::validate_password( $self, + src_clear => $auth_pass, + src_crypt => undef, + attempt_clear => $passClear, + attempt_hash => $passHash, + method => $method, + ticket => $ticket, + deny => DENY, + ); +} + diff --git a/plugins/auth/auth_ldap_bind b/plugins/auth/auth_ldap_bind new file mode 100644 index 0000000..76acae3 --- /dev/null +++ b/plugins/auth/auth_ldap_bind @@ -0,0 +1,197 @@ +#!perl -w + +=head1 NAME + +auth_ldap_bind - Authenticate user via an LDAP bind + +=head1 DESCRIPTION + +This plugin authenticates users against an LDAP Directory. The plugin +first performs a lookup for an entry matching the connecting user. This +lookup uses the 'ldap_auth_filter_attr' attribute to match the connecting +user to their LDAP DN. Once the plugin has found the user's DN, the plugin +will attempt to bind to the Directory as that DN with the password that has +been supplied. + +=head1 CONFIGURATION + +Configuration items can be held in either the 'ldap' configuration file, or as +arguments to the plugin. + +Configuration items in the 'ldap' configuration file +are set one per line, starting the line with the configuration item key, +followed by a space, then the values associated with the configuration item. + +Configuration items given as arguments to the plugin are keys and values +separated by spaces. Be sure to quote any values that have spaces in them. + +The only configuration item which is required is 'ldap_base'. This tells the +plugin what your base DN is. The plugin will not work until it has been +configured. + +The configuration items 'ldap_host' and 'ldap_port' specify the host and port +at which your Directory server may be contacted. If these are not specified, +the plugin will use port '389' on 'localhost'. + +The configuration item 'ldap_timeout' specifies how long the plugin should +wait for a response from your Directory server. By default, the value is 5 +seconds. + +The configuration item 'ldap_auth_filter_attr' specifies how the plugin should +find the user in your Directory. By default, the plugin will look up the user +based on the 'uid' attribute. + +=head1 NOTES + +Each auth requires an initial lookup to find the user's DN. Ideally, the +plugin would simply bind as the user without the need for this lookup (see +FUTURE DIRECTION below). + +This plugin requires that the Directory allow anonymous bind (see FUTURE +DIRECTION below). + +=head1 FUTURE DIRECTION + +A configurable LDAP filter should be made available, to account for users +who are over quota, have had their accounts disabled, or whatever other +arbitrary requirements. + +A configurable DN template (uid=$USER,ou=$DOMAIN,$BASE). This would prevent +the need of the initial user lookup, as the DN is created from the template. + +A configurable bind DN, for Directories that do not allow anonymous bind. + +Another plugin ('ldap_auth_cleartext'?), to allow retrieval of plain-text +passwords from the Directory, permitting CRAM-MD5 or other hash algorithm +authentication. + +=head1 AUTHOR + +Elliot Foster + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005 Elliot Foster + +This plugin is licensed under the same terms as the qpsmtpd package itself. +Please see the LICENSE file included with qpsmtpd for details. + +=cut + +use strict; +use warnings; + +use Net::LDAP qw(:all); +use Qpsmtpd::Constants; + +sub register { + my ($self, $qp, @args) = @_; + + $self->register_hook("auth-plain", "authldap"); + $self->register_hook("auth-login", "authldap"); + + # pull config defaults in from file + %{$self->{"ldconf"}} = + map { (split /\s+/, $_, 2)[0, 1] } $self->qp->config('ldap'); + + # override ldap config defaults with plugin args + for my $ldap_arg (@args) { + %{$self->{"ldconf"}} = map { (split /\s+/, $_, 2)[0, 1] } $ldap_arg; + } + + # do light validation of ldap_host and ldap_port to satisfy -T + my $ldhost = $self->{"ldconf"}->{'ldap_host'}; + my $ldport = $self->{"ldconf"}->{'ldap_port'}; + if (($ldhost) && ($ldhost =~ m/^(([a-z0-9]+\.?)+)$/)) { + $self->{"ldconf"}->{'ldap_host'} = $1; + } + else { + undef $self->{"ldconf"}->{'ldap_host'}; + } + if (($ldport) && ($ldport =~ m/^(\d+)$/)) { + $self->{"ldconf"}->{'ldap_port'} = $1; + } + else { + undef $self->{"ldconf"}->{'ldap_port'}; + } + + # set any values that are not already + $self->{"ldconf"}->{"ldap_host"} ||= "127.0.0.1"; + $self->{"ldconf"}->{"ldap_port"} ||= 389; + $self->{"ldconf"}->{"ldap_timeout"} ||= 5; + $self->{"ldconf"}->{"ldap_auth_filter_attr"} ||= "uid"; +} + +sub authldap { + my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) = + @_; + my ($ldhost, $ldport, $ldwait, $ldbase, $ldmattr, $lduserdn, $ldh, $mesg); + + # pull values in from config + $ldhost = $self->{"ldconf"}->{"ldap_host"}; + $ldport = $self->{"ldconf"}->{"ldap_port"}; + $ldbase = $self->{"ldconf"}->{"ldap_base"}; + + # log error here and DECLINE if no baseDN, because a custom baseDN is required: + unless ($ldbase) { + $self->log(LOGERROR, "skip: please configure ldap_base"); + return (DECLINED, "authldap - temporary auth error"); + }; + $ldwait = $self->{"ldconf"}->{'ldap_timeout'}; + $ldmattr = $self->{"ldconf"}->{'ldap_auth_filter_attr'}; + + my ($pw_name, $pw_domain) = split "@", lc($user); + + # find dn of user matching supplied username + $ldh = Net::LDAP->new($ldhost, port => $ldport, timeout => $ldwait) or do { + $self->log(LOGALERT, "skip: error in initial conn"); + return (DECLINED, "authldap - temporary auth error"); + }; + + # find the user's DN + $mesg = $ldh->search( base => $ldbase, + scope => 'sub', + filter => "$ldmattr=$pw_name", + attrs => ['uid'], + timeout => $ldwait, + sizelimit => '1' + ) or do { + $self->log(LOGALERT, "skip: err in search for user"); + return (DECLINED, "authldap - temporary auth error"); + }; + + # deal with errors if they exist + if ($mesg->code) { + $self->log(LOGALERT, "skip: err " . $mesg->code . " in search for user"); + return (DECLINED, "authldap - temporary auth error"); + } + + # unbind, so as to allow a rebind below + $ldh->unbind if $ldh; + + # bind against directory as user with password supplied + if ( ! $mesg->count || $lduserdn = $mesg->entry->dn ) { + $self->log(LOGALERT, "fail: user not found"); + return (DECLINED, "authldap - wrong username or password"); + }; + + $ldh = Net::LDAP->new($ldhost, port => $ldport, timeout => $ldwait) or do { + $self->log(LOGALERT, "skip: err in user conn"); + return (DECLINED, "authldap - temporary auth error"); + }; + + # here's the whole reason for the script + $mesg = $ldh->bind($lduserdn, password => $passClear, timeout => $ldwait); + $ldh->unbind if $ldh; + + # deal with errors if they exist, or allow success + if ($mesg->code) { + $self->log(LOGALERT, "fail: error in user bind"); + return (DECLINED, "authldap - wrong username or password"); + } + + $self->log(LOGINFO, "pass: $user auth success"); + $self->log(LOGDEBUG, "user: $user, pass: $passClear"); + return (OK, "authldap"); +} + diff --git a/plugins/auth/auth_vpopmail b/plugins/auth/auth_vpopmail new file mode 100644 index 0000000..91a5ac6 --- /dev/null +++ b/plugins/auth/auth_vpopmail @@ -0,0 +1,101 @@ +#!perl -w + +=head1 NAME + +auth_vpopmail - Authenticate against libvpopmail.a + +=head1 DESCRIPTION + +This plugin authenticates vpopmail users using p5-vpopmail. +Using CRAM-MD5 requires that vpopmail be built with the +'--enable-clear-passwd=y' option. + +=head1 CONFIGURATION + +This module will only work if qpsmtpd is running as the 'vpopmail' user. + +CRAM-MD5 authentication will only work with p5-vpopmail 0.09 or higher. + http://github.com/sscanlon/vpopmail + +Decide which authentication methods you are willing to support and uncomment +the lines in the register() sub. See the POD for Qspmtpd::Auth for more +details on the ramifications of supporting various authentication methods. + +=head1 SEE ALSO + +For an overview of the vpopmail authentication plugins and their merits, +please read the VPOPMAIL section in docs/authentication.pod + +=head1 AUTHOR + +Matt Simerson + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2010 Matt Simerson + +This plugin is licensed under the same terms as the qpsmtpd package itself. +Please see the LICENSE file included with qpsmtpd for details. + +=cut + +use strict; +use warnings; + +use Qpsmtpd::Auth; +use Qpsmtpd::Constants; + +#use vpopmail; # we eval this in $test_vpopmail_module + +sub register { + my ($self, $qp) = @_; + + return (DECLINED) if ! $self->test_vpopmail_module(); + + $self->register_hook("auth-plain", "auth_vpopmail" ); + $self->register_hook("auth-login", "auth_vpopmail" ); + $self->register_hook("auth-cram-md5", "auth_vpopmail"); +} + +sub auth_vpopmail { + my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) = + @_; + + my $pw = vauth_getpw( split '@', lc($user) ); + my $pw_clear_passwd = $pw->{pw_clear_passwd}; + my $pw_passwd = $pw->{pw_passwd}; + + if (!$pw || (!$pw_clear_passwd && !$pw_passwd)) { + $self->log(LOGINFO, "fail: invalid user $user"); + return (DENY, "auth_vpopmail - invalid user"); + # change DENY to DECLINED to support multiple auth plugins + } + + return Qpsmtpd::Auth::validate_password( $self, + src_clear => $pw->{pw_clear_passwd}, + src_crypt => $pw->{pw_passwd}, + attempt_clear => $passClear, + attempt_hash => $passHash, + method => $method, + ticket => $ticket, + deny => DENY, + ); +} + +sub test_vpopmail_module { + my $self = shift; +# vpopmail will not allow vauth_getpw to succeed unless the requesting user is vpopmail or root. +# by default, qpsmtpd runs as the user 'qpsmtpd' and does not have permission. + eval 'use vpopmail'; + if ( $@ ) { + $self->log(LOGERROR, "skip: is vpopmail perl module installed?"); + return; + }; + + my ($domain) = vpopmail::vlistdomains(); + my $r = vauth_getpw('postmaster', $domain) or do { + $self->log(LOGERROR, "skip: could not query vpopmail"); + return; + }; + return 1; +} diff --git a/plugins/auth/auth_vpopmail_sql b/plugins/auth/auth_vpopmail_sql new file mode 100644 index 0000000..dd9b3cb --- /dev/null +++ b/plugins/auth/auth_vpopmail_sql @@ -0,0 +1,156 @@ +#!perl -w + +=head1 NAME + +auth_vpopmail_sql - Authenticate to vpopmail via MySQL + +=head1 DESCRIPTION + +This plugin authenticates vpopmail users directly against a standard +vpopmail MySQL database. It makes the not-unreasonable assumption that +both pw_name and pw_domain are lowercase only (qmail doesn't actually care). +If you are using CRAM-MD5, it also requires that vpopmail be built with the +recommended '--enable-clear-passwd=y' option, because there is no way +to compare the crypted password. + +=head1 CONFIGURATION + + echo "dbi:mysql:dbname=vpopmail;host=127.0.0.1" > config/vpopmail_mysql_dsn + echo "vpopmailuser" > config/vpopmail_mysql_user + echo "vpoppasswd" > config/vpopmail_mysql_pass + +This can be a read-only database user since the plugin does not update the +last accessed time (yet, see below). + +This module supports PLAIN, LOGIN, and CRAM-MD5 authentication methods. You +can disable undesired methods by editing this module and uncommenting +the lines in the register() sub. See the POD for Qspmtpd::Auth for more +details on the ramifications of supporting various authentication methods. + +The remote user must login with a fully qualified e-mail address (i.e. both +account name and domain), even if they don't normally need to. This is +because the vpopmail table has a unique index on pw_name/pw_domain, and this +module requires that only a single record be returned from the database. + +=head1 LIMITATIONS + +This authentication modules does not recognize domain aliases. So, if you have +the domain example.com, with domain aliases for example.org and example.net, +smtp-auth will only work for $user@example.com. If you have domain aliases, +consider using another plugin (see SEE ALSO). + +=head1 FUTURE DIRECTION + +The default MySQL configuration for vpopmail includes a table to log access, +lastauth, which could conceivably be updated upon sucessful authentication. +The addition of this feature is left as an exercise for someone who cares. ;) + +=head1 SEE ALSO + +For an overview of the vpopmail authentication plugins and their merits, +please read the VPOPMAIL section in docs/authentication.pod + +=head1 AUTHOR + +John Peacock + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2004 John Peacock + +This plugin is licensed under the same terms as the qpsmtpd package itself. +Please see the LICENSE file included with qpsmtpd for details. + +=cut + +use strict; +use warnings; + +use Qpsmtpd::Auth; +use Qpsmtpd::Constants; + +#use DBI; # done in ->register + +sub register { + my ( $self, $qp ) = @_; + + eval 'use DBI'; + if ( $@ ) { + warn "plugin disabled. is DBI installed?\n"; + $self->log(LOGERROR, "skip: plugin disabled. is DBI installed?\n"); + return; + }; + + $self->register_hook('auth-plain', 'auth_vmysql'); + $self->register_hook('auth-login', 'auth_vmysql'); + $self->register_hook('auth-cram-md5', 'auth_vmysql'); +} + +sub get_db_handle { + my $self = shift; + + my $dsn = $self->qp->config("vpopmail_mysql_dsn") || "dbi:mysql:dbname=vpopmail;host=127.0.0.1"; + my $dbuser = $self->qp->config("vpopmail_mysql_user") || "vpopmailuser"; + my $dbpass = $self->qp->config("vpopmail_mysql_pass") || "vpoppasswd"; + + my $dbh = DBI->connect( $dsn, $dbuser, $dbpass ) or do { + $self->log(LOGERROR, "skip: db connection failed"); + return; + }; + $dbh->{ShowErrorStatement} = 1; + return $dbh; +}; + +sub get_vpopmail_user { + my ( $self, $dbh, $user ) = @_; + + my ( $pw_name, $pw_domain ) = split '@', lc($user); + + if ( ! defined $pw_domain ) { + $self->log(LOGINFO, "skip: missing domain: " . lc $user ); + return; + }; + + $self->log(LOGDEBUG, "auth_vpopmail_sql: $user"); + + my $query = "SELECT pw_passwd,pw_clear_passwd +FROM vpopmail + WHERE pw_name = ? + AND pw_domain = ?"; + + my $sth = $dbh->prepare( $query ); + $sth->execute( $pw_name, $pw_domain ); + my $userd_ref = $sth->fetchrow_hashref; + $sth->finish; + $dbh->disconnect; + return $userd_ref; +}; + +sub auth_vmysql { + my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) = @_; + + my $dbh = $self->get_db_handle() or return DECLINED; + my $u = $self->get_vpopmail_user($dbh, $user) or return DECLINED; + + # if vpopmail was not built with '--enable-clear-passwd=y' + # then pw_clear_passwd may not even exist + # my $pw_clear_passwd = $db_user->{'pw_clear_passwd'}; + + if ( ! $u->{pw_passwd} && ! $u->{pw_clear_passwd} ) { + $self->log(LOGINFO, "fail: no such user"); + return ( DENY, "auth_vmysql - no such user" ); + }; + + # at this point, the user name has matched + + return Qpsmtpd::Auth::validate_password( $self, + src_clear => $u->{pw_clear_passwd}, + src_crypt => $u->{pw_passwd}, + attempt_clear => $passClear, + attempt_hash => $passHash, + method => $method, + ticket => $ticket, + deny => DENY, + ); +} + diff --git a/plugins/auth/auth_vpopmaild b/plugins/auth/auth_vpopmaild new file mode 100644 index 0000000..fe51c0c --- /dev/null +++ b/plugins/auth/auth_vpopmaild @@ -0,0 +1,120 @@ +#!perl -w + +use strict; +use warnings; + +use Qpsmtpd::Constants; +use IO::Socket; +use version; +my $VERSION = qv('1.0.3'); + +sub register { + my ($self, $qp, %args) = @_; + + $self->{_vpopmaild_host} = $args{host} || 'localhost'; + $self->{_vpopmaild_port} = $args{port} || '89'; + + $self->register_hook('auth-plain', 'auth_vpopmaild'); + $self->register_hook('auth-login', 'auth_vpopmaild'); + #$self->register_hook('auth-cram-md5', 'auth_vpopmaild'); # not supported +} + +sub auth_vpopmaild { + my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) = @_; + + if ( ! $passClear ) { + $self->log(LOGINFO, "skip: vpopmaild does not support cram-md5"); + return DECLINED; + } + + # create socket + my $vpopmaild_socket = IO::Socket::INET->new( + PeerAddr => $self->{_vpopmaild_host}, + PeerPort => $self->{_vpopmaild_port}, + Proto => 'tcp', + Type => SOCK_STREAM + ) or do { + $self->log(LOGERROR, "skip: socket connection to vpopmaild failed"); + return DECLINED; + }; + + $self->log(LOGDEBUG, "attempting $method"); + + # Get server greeting (+OK) + my $connect_response = <$vpopmaild_socket>; + if ( ! $connect_response ) { + $self->log(LOGERROR, "skip: no connection response"); + close($vpopmaild_socket); + return DECLINED; + }; + + if ( $connect_response !~ /^\+OK/ ) { + $self->log(LOGERROR, "skip: bad connection response: $connect_response"); + close($vpopmaild_socket); + return DECLINED; + }; + + print $vpopmaild_socket "login $user $passClear\n\r"; # send login details + my $login_response = <$vpopmaild_socket>; # get response from server + close($vpopmaild_socket); + + if ( ! $login_response ) { + $self->log(LOGERROR, "skip: no login response"); + return DECLINED; + }; + + # check for successful login (single line (+OK) or multiline (+OK+)) + if ( $login_response =~ /^\+OK/ ) { + $self->log(LOGINFO, "pass: clear"); + return (OK, 'auth_vpopmaild'); + }; + + chomp $login_response; + $self->log(LOGNOTICE, "fail: $login_response"); + return DECLINED; +} + +__END__ + +=head1 NAME + +auth_vpopmaild - Authenticate to vpopmaild + +=head1 DESCRIPTION + +Authenticates the user against against vpopmaild [1] daemon. + +=head1 CONFIGURATION + +Add a line to C as follows: + +auth_vpopmaild + +By default, the plugin connects to localhot on port 89. If your vpopmaild +daemon is running on a different host or port, specify as follows: + +auth_vpopmaild host [host] port [port] + +=head1 SEE ALSO + +For an overview of the vpopmail authentication plugins and their merits, +please read the VPOPMAIL section in doc/authentication.pod + +=head1 LINKS + +[1] http://www.qmailwiki.org/Vpopmaild + +=head1 AUTHOR + +Robin Bowes + +Matt Simerson (updated response parsing, added logging) + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2010 Robin Bowes + +This plugin is licensed under the same terms as the qpsmtpd package itself. +Please see the LICENSE file included with qpsmtpd for details. + +=cut diff --git a/plugins/auth/authdeny b/plugins/auth/authdeny new file mode 100644 index 0000000..deb8537 --- /dev/null +++ b/plugins/auth/authdeny @@ -0,0 +1,23 @@ +#!perl -w + +=head1 NAME + +authdeny + +=head1 SYNOPSIS + +This plugin doesn't actually check anything and will fail any +user no matter what they type. It is strictly a proof of concept for +the Qpsmtpd::Auth module. Don't run this in production!!! + +=cut + +sub hook_auth { + my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) = + @_; + + $self->log( LOGWARN, "fail: cannot authenticate" ); + + return ( DECLINED, "$user is not free to abuse my relay" ); +} + diff --git a/plugins/check_badmailfrom b/plugins/check_badmailfrom new file mode 100644 index 0000000..f4d1d84 --- /dev/null +++ b/plugins/check_badmailfrom @@ -0,0 +1,159 @@ +#!perl -w + +=head1 NAME + +check_badmailfrom - checks the badmailfrom config, with per-line reasons + +=head1 DESCRIPTION + +Reads the "badmailfrom" configuration like qmail-smtpd does. From the +qmail-smtpd docs: + +"Unacceptable envelope sender addresses. qmail-smtpd will reject every +recipient address for a message if the envelope sender address is +listed in badmailfrom. A line in badmailfrom may be of the form +@host, meaning every address at host." + +You may include an optional message after the sender address (leave a space), +to be used when rejecting the sender. + +=head1 CONFIGURATION + +=head2 reject + + badmailfrom reject [ 0 | 1 | naughty ] + +I<0> will not reject any connections. + +I<1> will reject naughty senders. + +I is the most efficient setting. It's also the default. + +To reject at any other connection hook, use the I setting and the +B plugin. + +=head1 PATTERNS + +This plugin also supports regular expression matches. This allows +special patterns to be denied (e.g. FQDN-VERP, percent hack, bangs, +double ats). + +Patterns are stored in the format pattern(\s+)response, where pattern +is a Perl pattern expression. Don't forget to anchor the pattern +(front ^ and back $) if you want to restrict it from matching +anywhere in the string. + + ^streamsendbouncer@.*\.mailengine1\.com$ Your right-hand side VERP doesn't fool me + ^return.*@.*\.pidplate\.biz$ I don' want it regardless of subdomain + ^admin.*\.ppoonn400\.com$ + + +=head1 NOTES + +According to the SMTP protocol, we can't reject until after the RCPT +stage, so store it until later. + + +=head1 AUTHORS + +2002 - Jim Winstead - initial author of badmailfrom + +2010 - Johan Almqvist - pattern matching plugin + +2012 - Matt Simerson - merging of the two and plugin tests + +=cut + +sub register { + my ($self,$qp) = shift, shift; + $self->{_args} = { @_ }; + + # preserve legacy "reject during rcpt" behavior + $self->{_args}{reject} = 1 if ! defined $self->{_args}{reject}; + + return if ! $self->{_args}{reject}; # reject 0, log only + return if $self->{_args}{reject} eq 'naughty'; # naughty will reject + + $self->register_hook('rcpt', 'rcpt_handler'); +}; + +sub hook_mail { + my ($self, $transaction, $sender, %param) = @_; + + return DECLINED if $self->is_immune(); + + my @badmailfrom = $self->qp->config('badmailfrom'); + if ( defined $self->{_badmailfrom_config} ) { # testing + @badmailfrom = @{$self->{_badmailfrom_config}}; + }; + + return DECLINED if $self->is_immune_sender( $sender, \@badmailfrom ); + + my $host = lc $sender->host; + my $from = lc($sender->user) . '@' . $host; + + for my $config (@badmailfrom) { + $config =~ s/^\s+//g; # trim leading whitespace + my ($bad, $reason) = split /\s+/, $config, 2; + next unless $bad; + next unless $self->is_match( $from, $bad, $host ); + $reason ||= "Your envelope sender is in my badmailfrom list"; + $self->connection->notes('naughty', $reason); + } + if ( ! $self->connection->notes('naughty') ) { + $self->log(LOGINFO, "pass"); + }; + return DECLINED; +} + +sub is_match { + my ( $self, $from, $bad, $host ) = @_; + + if ( $bad =~ /[\/\^\$\*\+]/ ) { # it's a regexp + $self->log(LOGDEBUG, "badmailfrom pattern ($bad) match for $from"); + return 1 if $from =~ /$bad/; + return; + }; + + $bad = lc $bad; + if ( $bad !~ m/\@/ ) { + $self->log(LOGWARN, "badmailfrom: bad config: no \@ sign in $bad"); + return; + }; + if ( substr($bad,0,1) eq '@' ) { + return 1 if $bad eq "\@$host"; + return; + }; + return if $bad ne $from; + return 1; +}; + +sub rcpt_handler { + my ($self, $transaction, $rcpt, %param) = @_; + + my $note = $self->connection->notes('naughty') or return (DECLINED); + + $self->log(LOGINFO, "fail, $note"); + return (DENY, $note); +} + +sub is_immune_sender { + my ($self, $sender, $badmf ) = @_; + + if ( ! scalar @$badmf ) { + $self->log(LOGDEBUG, 'skip: empty list'); + return 1; + }; + + if ( ! $sender || $sender->format eq '<>' ) { + $self->log(LOGDEBUG, 'skip: null sender'); + return 1; + }; + + if ( ! $sender->host || ! $sender->user ) { + $self->log(LOGDEBUG, 'skip: missing user or host'); + return 1; + }; + + return; +}; diff --git a/plugins/check_badmailfromto b/plugins/check_badmailfromto new file mode 100644 index 0000000..3a39874 --- /dev/null +++ b/plugins/check_badmailfromto @@ -0,0 +1,83 @@ +#!perl -w + +=head1 NAME + +check_badmailfromto - checks the badmailfromto config + +=head1 DESCRIPTION + +Much like the similar check_badmailfrom, this plugin references both the +FROM: and TO: lines, and if they both are present in the badmailfromto +config file (a tab delimited list of FROM/TO pairs), then the message is +blocked as if the recipient (TO) didn't exist. This is specifically designed +to not give the impression that the sender is blocked (good for cases of +harassment). + +Based heavily on check_badmailfrom. + +=cut + +use strict; +use Qpsmtpd::Constants; + +sub hook_mail { + my ($self, $transaction, $sender, %param) = @_; + + my @badmailfromto = $self->qp->config("badmailfromto"); + return DECLINED if $self->is_sender_immune( $sender, \@badmailfromto ); + + my $host = lc $sender->host; + my $from = lc($sender->user) . '@' . $host; + + for my $bad (@badmailfromto) { + $bad =~ s/^\s*(\S+).*/$1/; + next unless $bad; + $bad = lc $bad; + if ( $bad !~ m/\@/ ) { + $self->log(LOGWARN, 'badmailfromto: bad config, no @ sign in '. $bad); + next; + }; + if ( $bad eq $from || (substr($bad,0,1) eq '@' && $bad eq "\@$host") ) { + $transaction->notes('badmailfromto', $bad); + }; + } + return (DECLINED); +} + +sub hook_rcpt { + my ($self, $transaction, $rcpt, %param) = @_; + my $recipient = lc($rcpt->user) . '@' . lc($rcpt->host); + my $sender = $transaction->notes('badmailfromto') or do { + $self->log(LOGDEBUG, "pass: sender not listed"); + return (DECLINED); + }; + + foreach ( $self->qp->config("badmailfromto") ) { + my ($from, $to) = m/^\s*(\S+)\t(\S+).*/; + return (DENY, "mail to $recipient not accepted here") + if lc($from) eq $sender && lc($to) eq $recipient; + } + $self->log(LOGDEBUG, "pass: recipient not listed"); + return (DECLINED); +} + +sub is_sender_immune { + my ($self, $sender, $badmf ) = @_; + + if ( ! scalar @$badmf ) { + $self->log(LOGDEBUG, 'skip: empty list'); + return 1; + }; + + if ( ! $sender || $sender->format eq '<>' ) { + $self->log(LOGDEBUG, 'skip: null sender'); + return 1; + }; + + if ( ! $sender->host || ! $sender->user ) { + $self->log(LOGDEBUG, 'skip: missing user or host'); + return 1; + }; + + return; +}; diff --git a/plugins/check_badrcptto b/plugins/check_badrcptto new file mode 100644 index 0000000..7b5f7d9 --- /dev/null +++ b/plugins/check_badrcptto @@ -0,0 +1,129 @@ +#!perl -w + +=head1 SYNOPSIS + +deny connections to recipients in the I file + +like badmailfrom, but for recipient address rather than sender + +=head1 CONFIG + +Recipients are matched against entries in I. Entries can be +a complete email address, a host entry that starts with an @ symbol, or a +regular expression. For regexp pattern matches, see PATTERNS. + +=head1 PATTERNS + +This allows special patterns to be denied (e.g. percent hack, bangs, +double ats). + +Patterns are stored in the format pattern\sresponse, where pattern +is a Perl pattern expression. Don't forget to anchor the pattern if +you want to restrict it from matching anywhere in the string. + +qpsmtpd already ensures that the address contains an @, with something +to the left and right of the @. + +=head1 AUTHOR + +2002 - original badrcptto plugin - apparently Jim Winstead + https://github.com/smtpd/qpsmtpd/commits/master/plugins/check_badrcptto + +2005 - pattern feature, (c) Gordon Rowell + +2012 - merged the two, refactored, added tests - Matt Simerson + +=head1 LICENSE + +This software is free software and may be distributed under the same +terms as qpsmtpd itself. + +=cut + +use strict; +use warnings; + +use Qpsmtpd::Constants; +use Qpsmtpd::DSN; + +sub hook_rcpt { + my ($self, $transaction, $recipient, %param) = @_; + + return (DECLINED) if $self->is_immune(); + + my ($host, $to) = $self->get_host_and_to( $recipient ) + or return (DECLINED); + + my @badrcptto = $self->qp->config("badrcptto") or do { + $self->log(LOGINFO, "skip: empty config"); + return (DECLINED); + }; + + for my $line (@badrcptto) { + $line =~ s/^\s+//g; # trim leading whitespace + my ($bad, $reason) = split /\s+/, $line, 2; + next if ! $bad; + if ( $self->is_match( $to, lc($bad), $host ) ) { + if ( $reason ) { + return (DENY, "mail to $bad not accepted here"); + } + else { + return Qpsmtpd::DSN->no_such_user("mail to $bad not accepted here"); + } + }; + } + $self->log(LOGINFO, 'pass'); + return (DECLINED); +} + +sub is_match { + my ( $self, $to, $bad, $host ) = @_; + + if ( $bad =~ /[\/\^\$\*\+\!\%]/ ) { # it's a regexp + $self->log(LOGDEBUG, "badmailfrom pattern ($bad) match for $to"); + if ( $to =~ /$bad/i ) { + $self->log(LOGINFO, 'fail: pattern match'); + return 1; + }; + return; + }; + + if ( $bad !~ m/\@/ ) { + $self->log(LOGERROR, "badrcptto: bad config: no \@ sign in $bad"); + return; + }; + + $bad = lc $bad; + $to = lc $to; + + if ( substr($bad,0,1) eq '@' ) { + if ( $bad eq "\@$host" ) { + $self->log(LOGINFO, 'fail: host match'); + return 1; + }; + return; + }; + + if ( $bad eq $to ) { + $self->log(LOGINFO, 'fail: rcpt match'); + return 1; + } + return; +}; + +sub get_host_and_to { + my ( $self, $recipient ) = @_; + + if ( ! $recipient ) { + $self->log(LOGERROR, 'skip: no recipient!'); + return; + }; + + if ( ! $recipient->host || ! $recipient->user ) { + $self->log(LOGINFO, 'skip: missing host or user'); + return; + }; + + my $host = lc $recipient->host; + return ( $host, lc($recipient->user) . '@' . $host ); +}; diff --git a/plugins/check_badrcptto_patterns b/plugins/check_badrcptto_patterns new file mode 100644 index 0000000..807eb69 --- /dev/null +++ b/plugins/check_badrcptto_patterns @@ -0,0 +1,48 @@ +#!perl -w +=pod + +=head1 SYNOPSIS + +This plugin checks the badrcptto_patterns config. This allows +special patterns to be denied (e.g. percent hack, bangs, +double ats). + +=head1 CONFIG + +config/badrcptto_patterns + +Patterns are stored in the format pattern\sresponse, where pattern +is a Perl pattern expression. Don't forget to anchor the pattern if +you want to restrict it from matching anywhere in the string. + +qpsmtpd already ensures that the address contains an @, with something +to the left and right of the @. + +=head1 AUTHOR + +Copyright 2005 Gordon Rowell + +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); +} diff --git a/plugins/check_basicheaders b/plugins/check_basicheaders new file mode 100644 index 0000000..4758b67 --- /dev/null +++ b/plugins/check_basicheaders @@ -0,0 +1,162 @@ +#!perl -w + +=head1 NAME + +check_basicheaders + +=head1 DESCRIPTION + +Checks for missing or empty values in the From or Date headers. + +Optionally test if the Date header is too many days in the past or future. If +I or I are not defined, they are not tested. + +If the remote IP is whitelisted, header validation is skipped. + +=head1 CONFIGURATION + +The following optional settings exist: + +=head2 future + +The number of days in the future beyond which messages are invalid. + + check_basicheaders [ future 1 ] + +=head2 past + +The number of days in the past beyond which a message is invalid. The Date header is added by the MUA, so there are many valid reasons a message may have an older date in the header. It could have been delayed by the client, the sending server, connectivity problems, recipient server problem, recipient server configuration, etc. The I setting should take those factors into consideration. + +I would be surprised if a valid message ever had a date header older than a week. + + check_basicheaders [ past 5 ] + +=head2 reject + +Determine if the connection is denied. Use the I option when first enabling the plugin, and then watch your logs to see what would have been rejected. When you are no longer concerned that valid messages will be rejected, enable with I. + + check_basicheaders reject [ 0 | 1 ] + +Default: 1 + +=head2 reject_type + +Whether to issue a permanent or temporary rejection. The default is permanent. + + check_basicheaders reject_type [ temp | perm ] + +Using a temporary rejection is a cautious way to enable rejections. It allows an administrator to watch for a trial period and assure no valid messages are rejected. If a deferral of valid mail is noticed, I can be set to permit the deferred message to be delivered. + +Default: perm + +=head2 loglevel + +Adjust the quantity of logging for this plugin. See docs/logging.pod + +=head1 AUTHOR + + 2004 - Written by Jim Winstead Jr. + + 2012 - added logging, named arguments, reject_type, tests - Matt Simerson + - deprecate days for I & I. Improved POD + +=head1 LICENSE + +Released to the public domain, 26 March 2004. + +=cut + +use strict; +use warnings; + +use Qpsmtpd::Constants; + +use Date::Parse qw(str2time); + +sub register { + my ($self, $qp, @args) = @_; + + if ( @args == 1 ) { + $self->{_args}{days} = $args[0]; + } + elsif ( @args % 2 ) { + $self->log(LOGWARN, "invalid arguments"); + } + else { + $self->{_args} = { @args }; + }; +# provide backwards compatibility with the previous unnamed 'days' argument + if ( $self->{_args}{days} ) { + if ( ! defined $self->{_args}{future} ) { + $self->{_args}{future} = $self->{_args}{days}; + }; + if ( ! defined $self->{_args}{past} ) { + $self->{_args}{past} = $self->{_args}{days}; + }; + }; +# set explicit defaults + $self->{_args}{reject_type} ||= 'perm'; + if ( ! defined $self->{_args}{reject} ) { + $self->{_args}{reject} = 1; + }; +} + +sub hook_data_post { + my ($self, $transaction) = @_; + + my $type = $self->get_reject_type(); + + if ( $transaction->data_size == 0 ) { + $self->log(LOGINFO, "fail: no data"); + return ($type, "You must send some data first"); + }; + + my $header = $transaction->header or do { + $self->log(LOGINFO, "fail: no headers"); + return ($type, "missing header"); + }; + + return (DECLINED, "immune") if $self->is_immune(); + + if ( ! $header->get('From') ) { + $self->log(LOGINFO, "fail: no from"); + return ($type, "We require a valid From header"); + }; + + my $date = $header->get('Date') or do { + $self->log(LOGINFO, "fail: no date"); + return ($type, "We require a valid Date header"); + }; + chomp $date; + + my $err_msg = $self->invalid_date_range($date); + if ( $err_msg ) { + return ($type, $err_msg ); + }; + + return (DECLINED); +}; + +sub invalid_date_range { + my ($self, $date) = @_; + + my $ts = str2time($date) or do { + $self->log(LOGINFO, "skip: date not parseable ($date)"); + return; + }; + + my $past = $self->{_args}{past}; + if ( $past && $ts < time - ($past*24*3600) ) { + $self->log(LOGINFO, "fail: date too old ($date)"); + return "The Date header is too far in the past"; + }; + + my $future = $self->{_args}{future}; + if ( $future && $ts > time + ($future*24*3600) ) { + $self->log(LOGINFO, "fail: date in future ($date)"); + return "The Date header is too far in the future"; + }; + + $self->log(LOGINFO, "pass"); + return; +} diff --git a/plugins/check_bogus_bounce b/plugins/check_bogus_bounce new file mode 100644 index 0000000..6bbf29c --- /dev/null +++ b/plugins/check_bogus_bounce @@ -0,0 +1,126 @@ +#!perl -w + +=head1 NAME + +check_bogus_bounce - Check that a bounce message isn't bogus + +=head1 DESCRIPTION + +This plugin is designed to reject bogus bounce messages. + +In our case a bogus bounce message is defined as a bounce message +which has more than a single recipient. + +=head1 CONFIGURATION + +Only a single argument is recognized and is assumed to be the default +action. Valid settings are: + +=over 8 + +=item log + +Merely log the receipt of the bogus bounce (the default behaviour). + +=item deny + +Deny with a hard error code. + +=item denysoft + +Deny with a soft error code. + +=back + +=cut + +=head1 AUTHOR + +Steve Kemp +-- +http://steve.org.uk/Software/qpsmtpd/ + +=cut + +=begin doc + +Look for our single expected argument and configure "action" appropriately. + +=end doc + +=cut + +sub register { + my ($self, $qp, $arg, @nop) = (@_); + + # + # Default behaviour is to merely log. + # + $self->{_action} = "log"; + + # + # Unless one was specified + # + if ($arg) { + if ($arg =~ /^(log|deny|denysoft)$/i) { + $self->{_action} = $arg; + } + else { + die "Invalid argument '$arg' - use one of : log, deny, denysoft"; + } + } +} + +=begin doc + +Handle the detection of bounces here. + +If we find a match then we'll react with our expected action. + +=end doc + +=cut + +sub hook_data_post { + my ($self, $transaction) = (@_); + + # + # Find the sender, and return unless it wasn't a bounce. + # + my $sender = $transaction->sender->address || undef; + return DECLINED unless ($sender eq "<>"); + + # + # Get the recipients. + # + my @to = $transaction->recipients || (); + return DECLINED unless (scalar @to > 1); + + # + # OK at this point we know: + # + # 1. It is a bounce, via the null-envelope. + # 2. It is a bogus bounce, because there are more than one recipients. + # + if (lc $self->{_action} eq "log") { + $self->log(LOGWARN, + $self->plugin_name() . " bogus bounce for :" . join(",", @to)); + } + elsif (lc $self->{_action} eq "deny") { + return (DENY, + $self->plugin_name() . " determined this to be a bogus bounce"); + } + elsif (lc $self->{_action} eq "denysoft") { + return (DENYSOFT, + $self->plugin_name() . " determined this to be a bogus bounce"); + } + else { + $self->log(LOGWARN, + $self->plugin_name() . " failed to determine action. bug?"); + } + + # + # All done; allow this to proceed + # + return DECLINED; +} diff --git a/plugins/check_earlytalker b/plugins/check_earlytalker new file mode 100644 index 0000000..b4b8e95 --- /dev/null +++ b/plugins/check_earlytalker @@ -0,0 +1,228 @@ +#!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 + +=head2 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. + +=head2 reject + +Do we reject/deny connections to early talkers? + + check_earlytalker reject [ 0 | 1 ] + +Default: I + +=head2 reject_type [ temp | perm ] + +What type of rejection to send. A temporary rejection tells the remote server to try again later. A permanent error tells it to give up permanently. + +Default I. + +=head2 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. + + check_earlytalker defer-reject [ 0 | 1 ] + +=head2 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. + +=head2 loglevel + +Adjust the quantity of logging for this plugin. See docs/logging.pod + +=cut + +use strict; +use warnings; + +use IO::Select; +use Qpsmtpd::Constants; + +sub register { + my ($self, $qp, @args) = @_; + + if (@args % 2) { + $self->log(LOGERROR, "Unrecognized/mismatched arguments"); + return; + } + 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, + @args, + 'check-at' => \%check_at, + }; +# backwards compat with old 'action' argument + if ( defined $self->{_args}{action} && ! defined $self->{_args}{reject} ) { + $self->{_args}{reject} = $self->{_args}{action} =~ /^deny/i ? 1 : 0; + }; + if ( defined $self->{_args}{'defer-reject'} && ! defined $self->{_args}{reject_type} ) { + $self->{_args}{reject_type} = $self->{_args}{action} == 'denysoft' ? 'temp' : 'perm'; + }; + if ( ! defined $self->{_args}{reject_type} ) { + $self->{_args}{reject_type} = 'perm'; + }; +# /end compat + 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'}; + $self->{_args}{reject} = 1 if ! defined $self->{_args}{reject}; +} + +sub apr_connect_handler { + my ($self, $transaction) = @_; + + return DECLINED unless $self->{_args}{'check-at'}{CONNECT}; + return DECLINED if $self->is_immune(); + + my $c = $self->qp->{conn} or return DECLINED; + my $socket = $c->client_socket or return DECLINED; + my $timeout = $self->{_args}{'wait'} * 1_000_000; + + my $rc = $socket->poll($c->pool, $timeout, APR::Const::POLLIN()); + if ($rc == APR::Const::SUCCESS()) { + if ($self->{_args}{'defer-reject'}) { + $self->qp->connection->notes('earlytalker', 1); + return DECLINED; + }; + return $self->log_and_deny(); + }; + return $self->log_and_pass(); +} + +sub apr_data_handler { + my ($self, $transaction) = @_; + + return DECLINED unless $self->{_args}{'check-at'}{DATA}; + return DECLINED if $self->is_immune(); + + my $c = $self->qp->{conn} or return DECLINED; + my $socket = $c->client_socket or return DECLINED; + my $timeout = $self->{_args}{'wait'} * 1_000_000; + + my $rc = $socket->poll($c->pool, $timeout, APR::Const::POLLIN()); + if ($rc == APR::Const::SUCCESS()) { + return $self->log_and_deny(); + }; + return $self->log_and_pass(); +} + +sub connect_handler { + my ($self, $transaction) = @_; + my $in = new IO::Select; + + return DECLINED unless $self->{_args}{'check-at'}{CONNECT}; + return DECLINED if $self->is_immune(); + + $in->add(\*STDIN) or return DECLINED; + if (! $in->can_read($self->{_args}{'wait'})) { + return $self->log_and_pass(); + }; + + if ( ! $self->{_args}{'defer-reject'}) { + return $self->log_and_deny(); + }; + + $self->qp->connection->notes('earlytalker', 1); + return DECLINED; +} + +sub data_handler { + my ($self, $transaction) = @_; + my $in = new IO::Select; + + return DECLINED unless $self->{_args}{'check-at'}{DATA}; + return DECLINED if $self->is_immune(); + + $in->add(\*STDIN) or return DECLINED; + if ( ! $in->can_read($self->{_args}{'wait'})) { + return $self->log_and_pass(); + }; + + return $self->log_and_deny(); +}; + +sub log_and_pass { + my $self = shift; + my $ip = $self->qp->connection->remote_ip || 'remote host'; + $self->log(LOGINFO, "pass: $ip said nothing spontaneous"); + return DECLINED; +} + +sub log_and_deny { + my $self = shift; + + my $ip = $self->qp->connection->remote_ip || 'remote host'; + my $msg = 'Connecting host started transmitting before SMTP greeting'; + + $self->qp->connection->notes('earlytalker', 1); + $self->log(LOGNOTICE, "fail: $ip started talking before we said hello"); + + return ( $self->get_reject_type(), $msg ) if $self->{_args}{reject}; + return DECLINED; +} + +sub mail_handler { + my ($self, $transaction) = @_; + + return DECLINED unless $self->qp->connection->notes('earlytalker'); + return $self->log_and_deny(); +} + +sub get_reject_type { + my $self = shift; + my $deny = $self->{_args}{reject_type} or return DENY; + + return $deny eq 'temp' ? DENYSOFT + : $deny eq 'disconnect' ? DENY_DISCONNECT + : DENY; +}; diff --git a/plugins/check_loop b/plugins/check_loop new file mode 100644 index 0000000..5ffa608 --- /dev/null +++ b/plugins/check_loop @@ -0,0 +1,55 @@ +#!perl -w + +=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; +} diff --git a/plugins/check_spamhelo b/plugins/check_spamhelo new file mode 100644 index 0000000..3b60a0a --- /dev/null +++ b/plugins/check_spamhelo @@ -0,0 +1,34 @@ +#!perl -w +=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; diff --git a/plugins/connection_time b/plugins/connection_time new file mode 100644 index 0000000..9cff7f9 --- /dev/null +++ b/plugins/connection_time @@ -0,0 +1,79 @@ +#!perl -w + +=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 + +=head2 loglevel + +Adjust the quantity of logging for this plugin. See docs/logging.pod + + connection_time loglevel +1 (less logging) + + connection_time loglevel -1 (more logging) + +=cut + +use strict; +use warnings; + +use Qpsmtpd::Constants; + +use Time::HiRes qw(gettimeofday tv_interval); + +sub register { + my ($self, $qp) = shift, shift; + if ( @_ == 1 ) { # backwards compatible + $self->{_args}{loglevel} = shift; + if ( $self->{_args}{loglevel} =~ /\D/ ) { + $self->{_args}{loglevel} = Qpsmtpd::Constants::log_level($self->{_args}{loglevel}); + }; + $self->{_args}{loglevel} ||= 6; + } + elsif ( @_ % 2 ) { + $self->log(LOGERROR, "invalid arguments"); + } + else { + $self->{_args} = { @_ }; # named args, inherits loglevel + }; +} + +sub hook_pre_connection { + my $self = shift; + $self->{_connection_start} = [gettimeofday]; + $self->log(LOGDEBUG, "started at " . $self->{_connection_start} ); + return (DECLINED); +} + +sub hook_connect { + my $self = shift; +# this method is needed to function with the tcpserver deployment model + return (DECLINED) if defined $self->{_connection_start}; + $self->{_connection_start} = [gettimeofday]; + $self->log(LOGDEBUG, "started at " . $self->{_connection_start} ); + return (DECLINED); +} + +sub hook_post_connection { + my $self = shift; + + if ( ! $self->{_connection_start} ) { + $self->log(LOGERROR, "Start time not set?!"); + return (DECLINED); + }; + + my $elapsed = tv_interval( $self->{_connection_start}, [gettimeofday] ); + + $self->log(LOGINFO, sprintf "%.3f s.", $elapsed ); + return (DECLINED); +} + diff --git a/plugins/content_log b/plugins/content_log new file mode 100644 index 0000000..696c9e0 --- /dev/null +++ b/plugins/content_log @@ -0,0 +1,25 @@ +#!perl -w + +# 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"); +} diff --git a/plugins/count_unrecognized_commands b/plugins/count_unrecognized_commands new file mode 100644 index 0000000..3060e61 --- /dev/null +++ b/plugins/count_unrecognized_commands @@ -0,0 +1,49 @@ +#!perl -w + +=head1 NAME + +count_unrecognized_commands - and disconnect after 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 + +use strict; +use warnings; + +use Qpsmtpd::Constants; + +sub register { + my ($self, $qp ) = shift, shift; + + $self->{_unrec_cmd_max} = shift || 4; + + if ( scalar @_ ) { + $self->log(LOGWARN, "Ignoring additional arguments."); + } +} + +sub hook_unrecognized_command { + my ($self, $cmd) = @_[0,2]; + + my $count = $self->connection->notes('unrec_cmd_count') || 0; + $count = $count + 1; + $self->connection->notes('unrec_cmd_count', $count); + + if ( $count < $self->{_unrec_cmd_max} ) { + $self->log(LOGINFO, "'$cmd', ($count)"); + return DECLINED; + }; + + $self->log(LOGINFO, "fail, '$cmd' ($count)"); + return (DENY_DISCONNECT, "Closing connection, $count unrecognized commands. Perhaps you should read RFC 2821?" ); +} + diff --git a/plugins/dns_whitelist_soft b/plugins/dns_whitelist_soft new file mode 100644 index 0000000..6ca699b --- /dev/null +++ b/plugins/dns_whitelist_soft @@ -0,0 +1,158 @@ +#!perl -w +=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->connection->notes('whitelist_sockets', $sel); + + return DECLINED; +} + +sub process_sockets { + my ($self) = @_; + + my $conn = $self->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; diff --git a/plugins/dnsbl b/plugins/dnsbl new file mode 100644 index 0000000..43b2e58 --- /dev/null +++ b/plugins/dnsbl @@ -0,0 +1,343 @@ +#!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. + +=head1 USAGE + +Add the following line to the config/plugins file: + + dnsbl [ reject_type disconnect ] [loglevel -1] + +=head2 reject_type [ temp | perm ] + +To immediately drop the connection (since some blacklisted servers attempt +multiple sends per session), set I. 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). + +Default: perm + +=head2 loglevel + +Adjust the quantity of logging for this plugin. See docs/logging.pod + + dnsbl [loglevel -1] + +=head1 CONFIG FILES + +This plugin uses the following configuration files. All are optional. Not +specifying dnsbl_zones is like not using the plugin at all. + +=head2 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 + +=head2 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. + +=head2 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. + +=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: https://github.com/smtpd/qpsmtpd/commits/master/plugins/dnsbl + +=cut + +sub register { + my ($self, $qp) = shift, shift; + + if ( @_ % 2 ) { + $self->{_args}{reject_type} = shift; # backwards compatibility + } + else { + $self->{_args} = { @_ }; + }; +} + +sub hook_connect { + my ($self, $transaction) = @_; + + # perform RBLSMTPD checks to mimic Dan Bernstein's rblsmtpd + return DECLINED if $self->is_set_rblsmtpd(); + return DECLINED if $self->is_immune(); + return DECLINED if $self->ip_whitelisted(); + + my %dnsbl_zones = map { (split /:/, $_, 2)[0,1] } $self->qp->config('dnsbl_zones'); + if ( ! %dnsbl_zones ) { + $self->log( LOGDEBUG, "skip: no list configured"); + return DECLINED; + }; + + my $remote_ip = $self->qp->connection->remote_ip; + my $reversed_ip = join('.', reverse(split(/\./, $remote_ip))); + + # we queue these lookups in the background and fetch the + # results in the first rcpt handler + + 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->connection->notes('dnsbl_sockets', $sel); + $self->connection->notes('dnsbl_domains', $dom); + + return DECLINED; +} + +sub is_set_rblsmtpd { + my $self = shift; + + my $remote_ip = $self->qp->connection->remote_ip; + + if ( ! defined $ENV{'RBLSMTPD'} ) { + $self->log(LOGDEBUG, "RBLSMTPD not set for $remote_ip"); + return; + }; + + if ($ENV{'RBLSMTPD'} ne '') { + $self->log(LOGINFO, "RBLSMTPD=\"$ENV{'RBLSMTPD'}\" for $remote_ip"); + return $ENV{'RBLSMTPD'}; + } + + $self->log(LOGINFO, "RBLSMTPD set, but empty for $remote_ip"); + return 1; # don't return empty string, it evaluates to false +}; + +sub ip_whitelisted { + my $self = shift; + + my $remote_ip = shift || $self->qp->connection->remote_ip; + + return + grep { s/\.?$/./; $_ eq substr($remote_ip . '.', 0, length $_) } + $self->qp->config('dnsbl_allow'); +}; + +sub process_sockets { + my ($self) = @_; + + my $conn = $self->connection; + + return $conn->notes('dnsbl') if $conn->notes('dnsbl'); + + my %dnsbl_zones = map { (split /:/, $_, 2)[0,1] } $self->qp->config('dnsbl_zones'); + + my $sel = $conn->notes('dnsbl_sockets') or return ''; + my $dom = $conn->notes('dnsbl_domains'); + my $remote_ip = $self->qp->connection->remote_ip; + + my $result; + my $res = new Net::DNS::Resolver; + $res->tcp_timeout(30); + $res->udp_timeout(30); + + $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) = @_; + + return DECLINED if $self->is_immune(); + + # 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->qp->connection->remote_ip; + $result =~ s/%IP%/$remote_ip/g; + my $msg = $self->qp->config('dnsbl_rejectmsg'); + $self->log(LOGINFO, "fail: $msg"); + return ( $self->get_reject_type(), join(' ', $msg, $result)); + } + + my $note = $self->process_sockets or return DECLINED; + if ( $self->ip_whitelisted() ) { + $self->log(LOGINFO, "skip: whitelisted"); + return DECLINED; + }; + + if ( $rcpt->user =~ /^(?:postmaster|abuse|mailer-daemon|root)$/i ) { + $self->log(LOGWARN, "skip: don't blacklist special account: ".$rcpt->user); + return DECLINED; + } + + $self->log(LOGINFO, 'fail'); + return ( $self->get_reject_type(), $note); +} + +sub hook_disconnect { + my ($self, $transaction) = @_; + + $self->connection->notes('dnsbl_sockets', undef); + + return DECLINED; +} + +sub get_reject_type { + my $self = shift; + my $default = shift || DENY; + my $deny = $self->{_args}{reject_type} or return $default; + + return $self->{_args}{reject_type} eq 'temp' ? DENYSOFT + : $self->{_args}{reject_type} eq 'disconnect' ? DENY_DISCONNECT + : $default; +}; + diff --git a/plugins/domainkeys b/plugins/domainkeys new file mode 100644 index 0000000..928aa05 --- /dev/null +++ b/plugins/domainkeys @@ -0,0 +1,166 @@ +#!perl -w + +=head1 NAME + +domainkeys: validate a DomainKeys signature on an incoming mail + +=head1 SYNOPSIS + + domainkeys [reject 1] + +Performs a DomainKeys validation on the message. + +=head1 CONFIGURATION + +=head2 reject + + reject 1 + +Reject is a boolean that toggles message rejection on or off. Messages failing +DomainKeys validation are rejected by default. + +=head2 reject_type + + reject_type [ temp | perm ] + +The default rejection type is permanent. + +=head2 warn_only + +A deprecated option that disables message rejection. See reject instead. + +=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. + +=head1 AUTHORS + + Matt Simerson - 2012 + John Peacock - 2005-2006 + Anthony D. Urso. - 2004 + +=cut + +use strict; +use warnings; + +use Qpsmtpd::Constants; + +sub init { + my ($self, $qp, %args) = @_; + + foreach my $key ( %args ) { + $self->{$key} = $args{$key}; + } + $self->{reject} = 1 if ! defined $self->{reject}; # default reject + $self->{reject_type} = 'perm' if ! defined $self->{reject_type}; + + if ( $args{'warn_only'} ) { + $self->log(LOGNOTICE, "warn_only is deprecated. Use reject instead"); + $self->{'reject'} = 0; + }; +} + +sub register { + my $self = shift; + + for my $m ( qw/ Mail::DomainKeys::Message Mail::DomainKeys::Policy / ) { + eval "use $m"; + if ( $@ ) { + warn "skip: plugin disabled, could not load $m\n"; + $self->log(LOGERROR, "skip: plugin disabled, is $m installed?"); + return; + }; + }; + + $self->register_hook('data_post', 'data_post_handler'); +}; + +sub data_post_handler { + my ($self, $transaction) = @_; + + return DECLINED if $self->is_immune(); + + if ( ! $transaction->header->get('DomainKey-Signature') ) { + $self->log(LOGINFO, "skip: unsigned"); + return DECLINED; + }; + + my $body = $self->assemble_body( $transaction ); + + my $message = load Mail::DomainKeys::Message( + HeadString => $transaction->header->as_string, + BodyReference => $body) or do { + $self->log(LOGWARN, "skip: unable to load message"), + return DECLINED; + }; + + # no sender domain means no verification + if ( ! $message->senderdomain ) { + $self->log(LOGINFO, "skip: failed to parse sender domain"), + return DECLINED; + }; + + my $status = $self->get_message_status( $message ); + + if ( defined $status ) { + $transaction->header->replace("DomainKey-Status", $status); + $self->log(LOGINFO, "pass: $status"); + return DECLINED; + }; + + $self->log(LOGERROR, "fail: signature failed to verify"); + return DECLINED if ! $self->{reject}; + my $deny = $self->{reject_type} eq 'temp' ? DENYSOFT : DENY; + return ($deny, "DomainKeys signature failed to verify"); +} + +sub get_message_status { + my ($self, $message) = @_; + + if ( $message->testing ) { + return "testing"; # key testing, don't do anything else + }; + + if ( $message->signed && $message->verify ) { + return $message->signature->status; # verified: add good header + }; + + # not signed or not verified + my $policy = fetch Mail::DomainKeys::Policy( + Protocol => 'dns', + Domain => $message->senderdomain + ); + + if ( ! $policy ) { + return $message->signed ? "non-participant" : "no signature"; + }; + + if ( $policy->testing ) { + return "testing"; # Don't do anything else + }; + + if ( $policy->signall ) { + return undef; # policy requires all mail to be signed + }; + + # $policy->signsome + return "no signature"; # not signed and domain doesn't sign all +}; + +sub assemble_body { + my ($self, $transaction) = @_; + + $transaction->body_resetpos; + $transaction->body_getline; # \r\n seperator is NOT part of the body + + my @body; + while (my $line = $transaction->body_getline) { + push @body, $line; + } + return \@body; +}; diff --git a/plugins/dont_require_anglebrackets b/plugins/dont_require_anglebrackets new file mode 100644 index 0000000..000030a --- /dev/null +++ b/plugins/dont_require_anglebrackets @@ -0,0 +1,40 @@ +#!perl -w + +=head1 NAME + +dont_require_anglebrackets + +=head1 SYNOPSIS + +accept addresses in MAIL FROM:/RCPT TO: commands without surrounding <> + +=head1 DESCRIPTION + +RFC821 requires that email addresses presented during the SMTP conversation +be enclosed in angle brackets. Like this: + +MAIL FROM: + +This plugin relaxes that requirement, accepting messages in this format: + +MAIL FROM:user@example.com + +=cut + +sub hook_mail_pre { + my ($self,$transaction, $addr) = @_; + unless ($addr =~ /^<.*>$/) { + $self->log(LOGINFO, "added MAIL angle brackets"); + $addr = '<'.$addr.'>'; + } + return (OK, $addr); +} + +sub hook_rcpt_pre { + my ($self,$transaction, $addr) = @_; + unless ($addr =~ /^<.*>$/) { + $self->log(LOGINFO, "added RCPT angle brackets"); + $addr = '<'.$addr.'>'; + } + return (OK, $addr); +} diff --git a/plugins/dspam b/plugins/dspam new file mode 100644 index 0000000..51e067f --- /dev/null +++ b/plugins/dspam @@ -0,0 +1,545 @@ +#!perl -w + +=head1 NAME + +dspam - dspam integration for qpsmtpd + +=head1 DESCRIPTION + +Uses dspam to classify messages. Use B, B, and B +to train dspam. + +Adds the X-DSPAM-Result and X-DSPAM-Signature headers to messages. The latter is essential for +training dspam and the former is useful to MDAs, MUAs, and humans. + +Adds a transaction note to the qpsmtpd transaction. The note is a hashref +with at least the 'class' field (Spam,Innocent,Whitelisted). It will normally +contain a probability and confidence rating. + +=head1 TRAINING DSPAM + +Do not just enable dspam! Its false positive rate when untrained is high. The +good news is; dspam learns very, very fast. + +To get dspam into a useful state, it must be trained. The best method way to +train dspam is to feed it two large equal sized corpuses of spam and ham from +your mail server. The dspam authors suggest avoiding public corpuses. I train +dspam as follows: + +=over 4 + +=item learn from SpamAssassin + +See the SPAMASSASSIN section. + +=item periodic training + +I have a script that searches the contents of every users maildir. Any read +messages that have changed since the last processing run are learned as ham +or spam. + +The ham message list consists of read messages in any folder not named like +Spam, Junk, Trash, or Deleted. This catches messages that users have read +and left in their inbox or filed away into subfolders. + +=item on-the-fly training + +The dovecot IMAP server has an antispam plugin that will train dspam when +messages are moved to/from the Spam folder. + +=back + +=head1 CONFIG + +=head2 dspam_bin + +The path to the dspam binary. If yours is installed somewhere other +than /usr/local/bin/dspam, set this. + +=head2 autolearn [ naughty | karma | spamassassin | any ] + +=over 4 + +=item naughty + +learn naughty messages as spam (see plugins/naughty) + +=item karma + +learn messages with negative karma as spam (see plugins/karma) + +=item spamassassin + +learn from spamassassins messages with autolearn=(ham|spam) + +=item any + +all of the above, and any future tests too! + +=back + +=head2 reject + +Set to a floating point value between 0 and 1.00 where 0 is no confidence +and 1.0 is 100% confidence. + +If dspam's confidence is greater than or equal to this threshold, the +message will be rejected. The default is 1.00. + + dspam reject .95 + +To only reject mail if dspam and spamassassin both think the message is spam, +set I. + +=head2 reject_type + + reject_type [ perm | temp | disconnect ] + +By default, rejects are permanent (5xx). Set I to +defer mail instead of rejecting it. + +Set I if you'd prefer to immediately disconnect +the connection when a spam is encountered. This prevents the remote server +from issuing a reset and attempting numerous times in a single connection. + +=head1 dspam.conf + +dspam must be configured and working properly. I had to modify the following +settings on my system: + +=over 4 + +=item mysql storage + +=item Trust smtpd + +=item TrainingMode tum + +=item Tokenizer osb + +=item Preference "trainingMode=TOE" + +=item Preference "spamAction=deliver" + +=item Preference "signatureLocation=headers" + +=item TrainPristine off + +=item ParseToHeaders off + +=back + +Of those changes, the most important is the signature location. This plugin +only supports storing the signature in the headers. If you want to train dspam +after delivery (ie, users moving messages to/from spam folders), then the +dspam signature must be in the headers. + +When using the dspam MySQL backend, use InnoDB tables. DSPAM training +is dramatically slowed by MyISAM table locks and dspam requires lots +of training. InnoDB has row level locking and updates are much faster. + +=head1 DSPAM periodic maintenance + +Install this cron job to clean up your DSPAM database. + +http://dspam.git.sourceforge.net/git/gitweb.cgi?p=dspam/dspam;a=tree;f=contrib/dspam_maintenance;hb=HEAD + + + +=head1 SPAMASSASSIN + +DSPAM can be trained by SpamAssassin. This relationship between them requires +attention to several important details: + +=over 4 + +=item 1 + +dspam must be listed B spamassassin in the config/plugins file. +Because SA runs first, I set the SA reject_threshold up above 100 so that +all spam messages will be used to train dspam. + +Once dspam is trained and errors are rare, I plan to run dspam first and +reduce the SA load. + +=item 2 + +Autolearn must be enabled and configured in SpamAssassin. SA autolearn will +determine if a message is learned by dspam. The settings to pay careful +attention to in your SA local.cf file are I +and I. Make sure they are set to +conservative values that will yield no false positives. + +If you are using I and reject, messages that exceed +the SA threshholds will cause dspam to reject them. Again I say, make sure +the SA autolearn threshholds are set high enough to avoid false positives. + +=back + +=head1 MULTIPLE RECIPIENT BEHAVIOR + +For messages with multiple recipients, the user that dspam is running as will +be the dspam username. + +When messages have a single recipient, the recipient address is used as the +dspam username. For dspam to trust qpsmtpd with modifying the username, you +B add the username that qpsmtpd is running to to the dspamd.conf file. + +ie, (Trust smtpd). + +=head1 CHANGES + +2012-06 - Matt Simerson - added karma & naughty learning support + - worked around the DESTROY bug in dspam_process + +=head1 AUTHOR + +2012 - Matt Simerson + +=cut + +use strict; +use warnings; + +use Qpsmtpd::Constants; +use Qpsmtpd::DSN; +use IO::Handle; +use Socket qw(:DEFAULT :crlf); + +sub register { + my ($self, $qp) = shift, shift; + + $self->log(LOGERROR, "Bad parameters for the dspam plugin") if @_ % 2; + + $self->{_args} = { @_ }; + $self->{_args}{reject} = 1 if ! defined $self->{_args}{reject}; + $self->{_args}{reject_type} ||= 'perm'; + + $self->register_hook('data_post', 'data_post_handler'); +} + +sub data_post_handler { + my $self = shift; + my $transaction = shift || $self->qp->transaction; + + $self->autolearn( $transaction ); + return (DECLINED) if $self->is_immune(); + + if ( $transaction->data_size > 500_000 ) { + $self->log(LOGINFO, "skip, too big (" . $transaction->data_size . ")" ); + return (DECLINED); + }; + + my $username = $self->select_username( $transaction ); + my $filtercmd = $self->get_filter_cmd( $transaction, $username ); + $self->log(LOGDEBUG, $filtercmd); + + my $response = $self->dspam_process( $filtercmd, $transaction ); + if ( ! $response ) { + $self->log(LOGWARN, "skip, no dspam response. Check logs for errors."); + return (DECLINED); + }; + + $self->attach_headers( $response, $transaction ); + + return $self->log_and_return( $transaction ); +}; + +sub select_username { + my ($self, $transaction) = @_; + + my $recipient_count = scalar $transaction->recipients; + $self->log(LOGDEBUG, "Message has $recipient_count recipients"); + + if ( $recipient_count > 1 ) { + $self->log(LOGINFO, "skipping user prefs, $recipient_count recipients detected."); + return getpwuid($>); + }; + +# use the recipients email address as username. This enables user prefs + my $username = ($transaction->recipients)[0]->address; + return lc($username); +}; + +sub assemble_message { + my ($self, $transaction) = @_; + + $transaction->body_resetpos; + + my $message = "X-Envelope-From: " + . $transaction->sender->format . "\n" + . $transaction->header->as_string . "\n\n"; + + while (my $line = $transaction->body_getline) { $message .= $line; }; + + $message = join(CRLF, split/\n/, $message); + return $message . CRLF; +}; + +sub dspam_process { + my ( $self, $filtercmd, $transaction ) = @_; + + return $self->dspam_process_backticks( $filtercmd ); + #return $self->dspam_process_open2( $filtercmd, $transaction ); + + # yucky. This method (which forks) exercises a bug in qpsmtpd. When the + # child exits, the Transaction::DESTROY method is called, which deletes + # the spooled file from disk. The contents of $self->qp->transaction + # needed to spool it again are also destroyed. Don't use this. + my $message = $self->assemble_message( $transaction ); + my $in_fh; + if (! open($in_fh, '-|')) { # forks child for writing + open(my $out_fh, "|$filtercmd") or die "Can't run $filtercmd: $!\n"; + print $out_fh $message; + close $out_fh; + exit(0); + }; + my $response = <$in_fh>; + close $in_fh; + chomp $response; + $self->log(LOGDEBUG, $response); + return $response; +}; + +sub dspam_process_backticks { + my ( $self, $filtercmd ) = @_; + + my $filename = $self->qp->transaction->body_filename; + #my $response = `cat $filename | $filtercmd`; chomp $response; + my $response = `$filtercmd < $filename`; chomp $response; + $self->log(LOGDEBUG, $response); + return $response; +}; + +sub dspam_process_open2 { + my ( $self, $filtercmd, $transaction ) = @_; + + my $message = $self->assemble_message( $transaction ); + +# not sure why, but this is not as reliable as I'd like. What's a dspam +# error -5 mean anyway? + use FileHandle; + use IPC::Open2; + my ($dspam_in, $dspam_out); + my $pid = open2($dspam_out, $dspam_in, $filtercmd); + print $dspam_in $message; + close $dspam_in; + #my $response = join('', <$dspam_out>); # get full response + my $response = <$dspam_out>; # get first line only + waitpid $pid, 0; + chomp $response; + $self->log(LOGDEBUG, $response); + return $response; +}; + +sub log_and_return { + my $self = shift; + my $transaction = shift || $self->qp->transaction; + + my $d = $self->get_dspam_results( $transaction ) or return DECLINED; + + if ( ! $d->{class} ) { + $self->log(LOGWARN, "skip, no dspam class detected"); + return DECLINED; + }; + + my $status = "$d->{class}, $d->{confidence} c."; + my $reject = $self->{_args}{reject} or do { + $self->log(LOGINFO, "skip, reject disabled ($status)"); + return DECLINED; + }; + + if ( $reject eq 'agree' ) { + return $self->reject_agree( $transaction, $d ); + }; + + if ( $d->{class} eq 'Innocent' ) { + $self->log(LOGINFO, "pass, $status"); + return DECLINED; + }; + if ( $self->qp->connection->relay_client ) { + $self->log(LOGINFO, "skip, allowing spam, user authenticated ($status)"); + return DECLINED; + }; + if ( $d->{probability} <= $reject ) { + $self->log(LOGINFO, "pass, $d->{class} probability is too low ($d->{probability} < $reject)"); + return DECLINED; + }; + if ( $d->{confidence} != 1 ) { + $self->log(LOGINFO, "pass, $d->{class} confidence is too low ($d->{confidence})"); + return DECLINED; + }; + + # dspam is more than $reject percent sure this message is spam + $self->log(LOGINFO, "fail, $d->{class}, ($d->{confidence} confident)"); + my $deny = $self->get_reject_type(); + return Qpsmtpd::DSN->media_unsupported($deny, 'dspam says, no spam please'); +} + +sub reject_agree { + my ($self, $transaction, $d ) = @_; + + my $sa = $transaction->notes('spamassassin' ); + + my $status = "$d->{class}, $d->{confidence} c"; + + if ( ! $sa->{is_spam} ) { + $self->log(LOGINFO, "pass, cannot agree, SA results missing ($status)"); + return DECLINED; + }; + + if ( $d->{class} eq 'Spam' ) { + if ( $sa->{is_spam} eq 'Yes' ) { + if ( defined $self->connection->notes('karma') ) { + $self->connection->notes('karma', $self->connection->notes('karma') - 2); + }; + $self->log(LOGINFO, "fail, agree, $status"); + my $reject = $self->get_reject_type(); + return ($reject, 'we agree, no spam please'); + }; + + $self->log(LOGINFO, "fail, disagree, $status"); + return DECLINED; + }; + + if ( $d->{class} eq 'Innocent' ) { + if ( $sa->{is_spam} eq 'No' ) { + if ( $d->{confidence} > .9 ) { + if ( defined $self->connection->notes('karma') ) { + $self->connection->notes('karma', $self->connection->notes('karma') + 2); + }; + }; + $self->log(LOGINFO, "pass, agree, $status"); + return DECLINED; + }; + $self->log(LOGINFO, "pass, disagree, $status"); + }; + + $self->log(LOGINFO, "pass, other $status"); + return DECLINED; +}; + +sub get_dspam_results { + my $self = shift; + my $transaction = shift || $self->qp->transaction; + + if ( $transaction->notes('dspam') ) { + return $transaction->notes('dspam'); + }; + + my $string = $transaction->header->get('X-DSPAM-Result') or do { + $self->log(LOGWARN, "get_dspam_results: failed to find the header"); + return; + }; + + my @bits = split(/,\s+/, $string); chomp @bits; + my $class = shift @bits; + my %d; + foreach (@bits) { + my ($key,$val) = split(/=/, $_); + $d{$key} = $val; + }; + $d{class} = $class; + + my $message = $d{class}; + if ( defined $d{probability} && defined $d{confidence} ) { + $message .= ", prob: $d{probability}, conf: $d{confidence}"; + }; + $self->log(LOGDEBUG, $message); + $transaction->notes('dspam', \%d); + return \%d; +}; + +sub get_filter_cmd { + my ($self, $transaction, $user) = @_; + + my $dspam_bin = $self->{_args}{dspam_bin} || '/usr/local/bin/dspam'; + my $default = "$dspam_bin --user $user --mode=tum --process --deliver=summary --stdout"; + + my $learn = $self->{_args}{autolearn} or return $default; + return $default if ( $learn ne 'spamassassin' && $learn ne 'any' ); + + $self->log(LOGDEBUG, "attempting to learn from SA"); + + my $sa = $transaction->notes('spamassassin' ); + if ( ! $sa || ! $sa->{is_spam} ) { + $self->log(LOGERROR, "SA results missing"); + return $default; + }; + + if ( ! $sa->{autolearn} ) { + $self->log(LOGERROR, "SA autolearn unset"); + return $default; + }; + + if ( $sa->{is_spam} eq 'Yes' && $sa->{autolearn} eq 'spam' ) { + return "$dspam_bin --user $user --mode=tum --source=corpus --class=spam --deliver=summary --stdout"; + } + elsif ( $sa->{is_spam} eq 'No' && $sa->{autolearn} eq 'ham' ) { + return "$dspam_bin --user $user --mode=tum --source=corpus --class=innocent --deliver=summary --stdout"; + }; + + return $default; +}; + +sub attach_headers { + my ($self, $response, $transaction) = @_; + $transaction ||= $self->qp->transaction; + + # X-DSPAM-Result: user@example.com; result="Spam"; class="Spam"; probability=1.0000; confidence=1.00; signature=N/A + # X-DSPAM-Result: smtpd; result="Innocent"; class="Innocent"; probability=0.0023; confidence=1.00; signature=4f8dae6a446008399211546 + my ($result,$prob,$conf,$sig) = $response =~ /result=\"(Spam|Innocent)\";.*?probability=([\d\.]+); confidence=([\d\.]+); signature=(.*)/; + my $header_str = "$result, probability=$prob, confidence=$conf"; + $self->log(LOGDEBUG, $header_str); + my $name = 'X-DSPAM-Result'; + $transaction->header->delete($name) if $transaction->header->get($name); + $transaction->header->add($name, $header_str, 0); + + # the signature header is required if you intend to train dspam later. + # In dspam.conf, set: Preference "signatureLocation=headers" + $transaction->header->add('X-DSPAM-Signature', $sig, 0); +}; + +sub learn_as_ham { + my $self = shift; + my $transaction = shift; + + my $user = $self->select_username( $transaction ); + my $dspam_bin = $self->{_args}{dspam_bin} || '/usr/local/bin/dspam'; + my $cmd = "$dspam_bin --user $user --mode=tum --source=corpus --class=innocent --deliver=summary --stdout"; + $self->dspam_process( $cmd, $transaction ); +}; + +sub learn_as_spam { + my $self = shift; + my $transaction = shift; + + my $user = $self->select_username( $transaction ); + my $dspam_bin = $self->{_args}{dspam_bin} || '/usr/local/bin/dspam'; + my $cmd = "$dspam_bin --user $user --mode=tum --source=corpus --class=spam --deliver=summary --stdout"; + $self->dspam_process( $cmd, $transaction ); +}; + +sub autolearn { + my ( $self, $transaction ) = @_; + + my $learn = $self->{_args}{autolearn} or return; + + if ( $learn eq 'naughty' || $learn eq 'any' ) { + if ( $self->connection->notes('naughty') ) { + $self->log(LOGINFO, "training naughty as spam"); + $self->learn_as_spam( $transaction ); + }; + }; + if ( $learn eq 'karma' || $learn eq 'any' ) { + my $karma = $self->connection->notes('karma'); + if ( defined $karma && $karma <= -1 ) { + $self->log(LOGINFO, "training poor karma as spam"); + $self->learn_as_spam( $transaction ); + }; + if ( defined $karma && $karma >= 1 ) { + $self->log(LOGINFO, "training good karma as ham"); + $self->learn_as_ham( $transaction ); + }; + }; +}; diff --git a/plugins/greylisting b/plugins/greylisting new file mode 100644 index 0000000..462ea63 --- /dev/null +++ b/plugins/greylisting @@ -0,0 +1,552 @@ +#!perl -w + +=head1 NAME + +greylisting - delay mail from unknown senders + +=head1 DESCRIPTION + +Plugin implementing 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 tracks incoming connections using a triplet (see TRIPLET). It +has configurable timeout periods (black/grey/white) to control whether +connections are allowed, instead of using connection counts or rates. + +Automatic whitelisting is enabled for relayclients, whitelisted hosts, +whitelisted senders, p0f matches, and geoip matches. + +=head1 TRIPLETS + +In greylisting, I, I, and I are referred to +as the triplet that connections are deferred based on. This plugin allows +tracking on any or all of the three, using only the IP address by default. +A simple dbm database is used for tracking connections. + +How that works is best explained by example: + +A new connection arrives from the host shvj1.jpmchase.com. The sender is +chase@alerts.chase.com and the recipient is londonwhale@example.com. This is +the first connection for that triplet so the connection is deferred for +I minutes. After the timeout, but before the I +elapses, shvj1.jpmchase.com retries and successfully delivers the mail. For +the next I days, emails for that triplet are not delayed. + +The next day, shvj1.jpmchase.com tries to deliver a new email from +alerts@alerts.chase.com to jdimon@example.com. Since this triplet is new, it +will be delayed as our initial connection in the last scenario was. This +delay could end up costing over US $4B. + +By default, this plugin does not enable the sender or recipient in the triplet. +Once an email from a remote server has been delivered to anyone on our server, +that remote server is whitelisted for any sender and any recipient. This is a +policy that delays less mail and is less likely to impoverish your bank. + +=head1 CONFIG + +The following parameters can be passed to greylisting: + +=head2 remote_ip + +Include the remote ip in the connection triplet? Default: 1 + +=head2 sender + +Include the sender in the connection triplet? Default: 0. + +=head2 recipient + +Include the recipient in the connection triplet? Default: 0. + +=head2 deny_late + +Whether to defer denials during the 'mail' hook or later during 'data_post' +e.g. to allow per-recipient logging. Default: 0. + +=head2 black_timeout + +The initial period during which we issue DENYSOFTs for connections from an +unknown (or timed out) 'connection triplet'. Default: 50 minutes. + +=head2 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. + +=head2 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. + +=head2 reject + +Whether to issue deferrals (DENYSOFT) for black connections. Having reject +disabled is useful for seeding the database and testing without impacting +deliveries. It is recommended to begin with I for a week or two +before enabling I. + +Default: 1 + +=head2 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 + +=head2 per_recipient + +Flag to indicate whether to use per-recipient configs. + +=head2 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. + +=head2 nfslock + +Flag to indicate the database is stored on NFS. Uses File::NFSLock +instead of flock. + +=head2 p0f + +Enable greylisting only when certain p0f criteria is met. The required +argument is a comma delimited list of key/value pairs. The keys are the +following p0f TCP fingerprint elements: genre, detail, uptime, link, and +distance. + +To greylist emails from computers whose remote OS is windows: + + greylisting p0f genre,windows + +To greylist only windows computers on DSL links more than 3 network hops away: + + greylisting p0f genre,windows,link,dsl,distance,3 + +=head2 geoip + +Do not greylist connections that are in the comma separated list of countries. + + greylisting geoip US,UK + +Prior to adding GeoIP support, I greylisted all connections from windows computers. That deters the vast majority of spam connections, but it also delays legit mail from @msn, @live.com, and a small handful of other servers. Since adding geoip support, I haven't seen a single valid mail delivery delayed. + +=head2 loglevel + +Adjust the quantity of logging for this plugin. See docs/logging.pod + + +=head1 AUTHOR + +Written by Gavin Carr . + +nfslock feature by JT Moree - 2007-01-22 + +p0f feature by Matt Simerson - 2010-05-03 + +geoip, loglevel, reject added. Refactored into subs - Matt Simerson - 2012-05 + +=cut + +use strict; +use warnings; +use Qpsmtpd::Constants; + +my $VERSION = '0.11'; + +BEGIN { @AnyDBM_File::ISA = qw(DB_File GDBM_File NDBM_File) } +use AnyDBM_File; +use Fcntl qw(:DEFAULT :flock LOCK_EX LOCK_NB); +use Net::IP; + +my $DENYMSG = "This mail is temporarily denied"; +my ($QPHOME) = ($0 =~ m!(.*?)/([^/]+)$!); +my $DB = "greylist.dbm"; +my %PERMITTED_ARGS = map { $_ => 1 } qw(per_recipient remote_ip sender + recipient black_timeout grey_timeout white_timeout deny_late db_dir + nfslock p0f reject loglevel geoip upgrade ); + +my %DEFAULTS = ( + remote_ip => 1, + sender => 0, + recipient => 0, + reject => 1, + black_timeout => 50 * 60, # 50m + grey_timeout => 3 * 3600 + 20 * 60, # 3h:20m + white_timeout => 36 * 3600 * 24, # 36 days + nfslock => 0, + p0f => undef, +); + +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)); + } + # backwards compatibility with deprecated 'mode' setting + if ( defined $config->{mode} && ! defined $config->{reject} ) { + $config->{reject} = $config->{mode} =~ /testonly|off/i ? 0 : 1; + }; + $self->{_args} = $config; + unless ($config->{recipient} || $config->{per_recipient}) { + $self->register_hook('mail', 'mail_handler'); + } else { + $self->register_hook('rcpt', 'rcpt_handler'); + } + $self->prune_db(); + if ( $self->{_args}{upgrade} ) { + $self->convert_db(); + }; +} + +sub mail_handler { + my ($self, $transaction, $sender) = @_; + + my ($status, $msg) = $self->greylist($transaction, $sender); + + return DECLINED if $status != DENYSOFT; + + if ( ! $self->{_args}{deny_late} ) { + return (DENYSOFT, $msg); + }; + + $transaction->notes('greylist', $msg); + return DECLINED; +} + +sub rcpt_handler { + my ($self, $transaction, $rcpt) = @_; + # Load per_recipient configs + my $config = { %{$self->{_args}}, + map { split /\s+/, $_, 2 } $self->qp->config('denysoft_greylist', { rcpt => $rcpt }) }; + # Check greylisting + my $sender = $transaction->sender; + my ($status, $msg) = $self->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('greylist', $msg); + } + return DECLINED; +} + +sub hook_data { + my ($self, $transaction) = @_; + return DECLINED unless $transaction->notes('greylist'); + # Decline if ALL recipients are whitelisted + if (($transaction->notes('whitelistrcpt')||0) == scalar($transaction->recipients)) { + $self->log(LOGWARN,"skip: all recipients whitelisted"); + return DECLINED; + } + return DENYSOFT, $transaction->notes('greylist'); +} + +sub greylist { + my ($self, $transaction, $sender, $rcpt, $config) = @_; + $config ||= $self->{_args}; + $self->log(LOGDEBUG, "config: " . + join(',',map { $_ . '=' . $config->{$_} } sort keys %$config)); + + return DECLINED if $self->is_immune(); + return DECLINED if ! $self->is_p0f_match(); + return DECLINED if $self->geoip_match(); + + my $db = $self->get_db_location(); + my $lock = $self->get_db_lock( $db ) or return DECLINED; + my $tied = $self->get_db_tie( $db, $lock ) or return DECLINED; + my $key = $self->get_db_key( $sender, $rcpt ) or return DECLINED; + + my $fmt = "%s:%d:%d:%d"; + +# new IP or entry timed out - record new + if ( ! $tied->{$key} ) { + $tied->{$key} = sprintf $fmt, time, 1, 0, 0; + $self->log(LOGWARN, "fail: initial DENYSOFT, unknown"); + return $self->cleanup_and_return( $tied, $lock ); + }; + + my ($ts, $new, $black, $white) = split /:/, $tied->{$key}; + $self->log(LOGDEBUG, "ts: " . localtime($ts) . ", now: " . localtime); + + if ( $white ) { +# white IP - accept unless timed out + if (time - $ts < $config->{white_timeout}) { + $tied->{$key} = sprintf $fmt, time, $new, $black, ++$white; + $self->log(LOGINFO, "pass: white, $white deliveries"); + return $self->cleanup_and_return( $tied, $lock, DECLINED ); + } + else { + $self->log(LOGINFO, "key $key has timed out (white)"); + } + }; + +# Black IP - deny, but don't update timestamp + if (time - $ts < $config->{black_timeout}) { + $tied->{$key} = sprintf $fmt, $ts, $new, ++$black, 0; + $self->log(LOGWARN, "fail: black DENYSOFT - $black deferred connections"); + return $self->cleanup_and_return( $tied, $lock ); + } + +# Grey IP - accept unless timed out + elsif (time - $ts < $config->{grey_timeout}) { + $tied->{$key} = sprintf $fmt, time, $new, $black, 1; + $self->log(LOGWARN, "pass: updated grey->white"); + return $self->cleanup_and_return( $tied, $lock, DECLINED ); + } + + $self->log(LOGWARN, "pass: timed out (grey)"); + return $self->cleanup_and_return( $tied, $lock, DECLINED ); +} + +sub cleanup_and_return { + my ($self, $tied, $lock, $return_val ) = @_; + + untie $tied; + close $lock; + return $return_val if defined $return_val; # explicit override + return DECLINED if defined $self->{_args}{reject} && ! $self->{_args}{reject}; + return (DENYSOFT, $DENYMSG); +}; + +sub get_db_key { + my $self = shift; + my $sender = shift || $self->qp->transaction->sender; + my $rcpt = shift || ($self->qp->transaction->recipients)[0]; + + my @key; + if ( $self->{_args}{remote_ip} ) { + my $nip = Net::IP->new( $self->qp->connection->remote_ip ); + push @key, $nip->intip; # convert IP to integer + }; + + push @key, $sender->address || '' if $self->{_args}{sender}; + push @key, $rcpt->address if $rcpt && $self->{_args}{recipient}; + if ( ! scalar @key ) { + $self->log(LOGERROR, "enable one of remote_ip, sender, or recipient!"); + return; + }; + return join ':', @key; +}; + +sub get_db_tie { + my ( $self, $db, $lock ) = @_; + + tie( my %db, 'AnyDBM_File', $db, O_CREAT|O_RDWR, 0600) or do { + $self->log(LOGCRIT, "tie to database $db failed: $!"); + close $lock; + return; + }; + return \%db; +}; + +sub get_db_location { + my $self = shift; + + my $transaction = $self->qp->transaction; + my $config = $self->{_args}; + + if ($config->{db_dir} && $config->{db_dir} =~ m{^([-a-zA-Z0-9./_]+)$}) { + $config->{db_dir} = $1; + } + + # Setup database location + my $dbdir; + if ( $config->{per_recipient_db} ) { + $dbdir = $transaction->notes('per_rcpt_configdir'); + }; + + my @candidate_dirs = ( $dbdir, $config->{db_dir}, + "/var/lib/qpsmtpd/greylisting", "$QPHOME/var/db", "$QPHOME/config", '.' ); + + for my $d ( @candidate_dirs ) { + next if ! $d || ! -d $d; # impossible + $dbdir = $d; + last; # first match wins + } + my $db = "$dbdir/$DB"; + if ( ! -f $db && -f "$dbdir/denysoft_greylist.dbm" ) { + $db = "$dbdir/denysoft_greylist.dbm"; # old DB name + } + $self->log(LOGDEBUG,"using $db as greylisting database"); + return $db; +}; + +sub get_db_lock { + my ($self, $db) = @_; + + return $self->get_db_lock_nfs($db) if $self->{_args}{nfslock}; + + # Check denysoft db + open( my $lock, ">$db.lock" ) or do { + $self->log(LOGCRIT, "opening lockfile failed: $!"); + return; + }; + + flock( $lock, LOCK_EX ) or do { + $self->log(LOGCRIT, "flock of lockfile failed: $!"); + close $lock; + return; + }; + + return $lock; +} + +sub get_db_lock_nfs { + my ($self, $db) = @_; + + require File::NFSLock; + + ### set up a lock - lasts until object looses scope + my $nfslock = new File::NFSLock { + file => "$db.lock", + lock_type => LOCK_EX|LOCK_NB, + blocking_timeout => 10, # 10 sec + stale_lock_timeout => 30 * 60, # 30 min + } or do { + $self->log(LOGCRIT, "nfs lockfile failed: $!"); + return; + }; + + open( my $lock, "+<$db.lock") or do { + $self->log(LOGCRIT, "opening nfs lockfile failed: $!"); + return; + }; + + return $lock; +}; + +sub convert_db { + my $self = shift; + + my $db = $self->get_db_location(); + my $lock = $self->get_db_lock( $db ) or return DECLINED; + my $tied = $self->get_db_tie( $db, $lock ) or return DECLINED; + my $count = keys %$tied; + + my $converted = 0; + foreach my $key ( keys %$tied ) { + my ( @parts ) = split /:/, $key; + next if $parts[0] =~ /^[\d]+$/; # already converted + $converted++; + my $nip = Net::IP->new( $parts[0] ); + $parts[0] = $nip->intip; # convert IP to integer + my $new_key = join ':', @parts; + $tied->{$new_key} = $tied->{$key}; + delete $tied->{$key}; + }; + untie $tied; + close $lock; + $self->log( LOGINFO, "converted $converted of $count DB entries" ); + return $self->cleanup_and_return( $tied, $lock, DECLINED ); +}; + +sub prune_db { + my $self = shift; + + my $db = $self->get_db_location(); + my $lock = $self->get_db_lock( $db ) or return DECLINED; + my $tied = $self->get_db_tie( $db, $lock ) or return DECLINED; + my $count = keys %$tied; + + my $pruned = 0; + foreach my $key ( keys %$tied ) { + my ($ts, $new, $black, $white) = split /:/, $tied->{$key}; + my $age = time - $ts; + next if $age < $self->{_args}{white_timeout}; + $pruned++; + delete $tied->{$key}; + }; + untie $tied; + close $lock; + $self->log( LOGINFO, "pruned $pruned of $count DB entries" ); + return $self->cleanup_and_return( $tied, $lock, DECLINED ); +}; + +sub p0f_match { + my $self = shift; + + return if ! $self->{_args}{p0f}; + + my $p0f = $self->connection->notes('p0f'); + if ( !$p0f || !ref $p0f ) { # p0f fingerprint info not found + $self->LOGINFO(LOGERROR, "p0f info missing"); + return; + }; + + my %valid_matches = map { $_ => 1 } qw( genre detail uptime link distance ); + my %requested_matches = split(/\,/, $self->{_args}{p0f} ); + + foreach my $key (keys %requested_matches) { + next if ! $key; + if ( ! defined $valid_matches{$key} ) { + $self->log(LOGERROR, "discarding invalid match key ($key)" ); + next; + }; + my $value = $requested_matches{$key}; + next if ! defined $value; # bad config setting? + next if ! defined $p0f->{$key}; # p0f didn't detect the value + + if ( $key eq 'distance' && $p0f->{$key} > $value ) { + $self->log(LOGDEBUG, "p0f distance match ($value)"); + return 1; + }; + if ( $key eq 'genre' && $p0f->{$key} =~ /$value/i ) { + $self->log(LOGDEBUG, "p0f genre match ($value)"); + return 1; + }; + if ( $key eq 'uptime' && $p0f->{$key} < $value ) { + $self->log(LOGDEBUG, "p0f uptime match ($value)"); + return 1; + }; + if ( $key eq 'link' && $p0f->{$key} =~ /$value/i ) { + $self->log(LOGDEBUG, "p0f link match ($value)"); + return 1; + }; + } + $self->log(LOGINFO, "skip: no p0f match"); + return; +} + +sub geoip_match { + my $self = shift; + + return if ! $self->{_args}{geoip}; + + my $country = $self->connection->notes('geoip_country'); + my $c_name = $self->connection->notes('geoip_country_name') || ''; + + if ( !$country ) { + $self->LOGINFO(LOGNOTICE, "skip: no geoip country"); + return; + }; + + my @countries = split /,/, $self->{_args}{geoip}; + foreach ( @countries ) { + $self->LOGINFO(LOGINFO, "pass: geoip country match ($_, $c_name)"); + return 1 if lc $_ eq lc $country; + }; + + $self->LOGINFO(LOGINFO, "skip: no geoip match ($c_name)"); + return; +} + diff --git a/plugins/headers b/plugins/headers new file mode 100644 index 0000000..5b2ec71 --- /dev/null +++ b/plugins/headers @@ -0,0 +1,181 @@ +#!perl -w + +=head1 NAME + +headers + +=head1 DESCRIPTION + +Checks for missing or empty values in the From or Date headers. + +Make sure no singular headers are duplicated. Singular headers are: + + Date From Sender Reply-To To Cc Bcc + Message-Id In-Reply-To References Subject + +Optionally test if the Date header is too many days in the past or future. If +I or I are not defined, they are not tested. + +If the remote IP is whitelisted, header validation is skipped. + +=head1 CONFIGURATION + +The following optional settings exist: + +=head2 require + + headers require [ From | Date | From,Date | From,Date,Subject,Message-ID ] + +A comma separated list of headers to require. + +Default: From + +=head3 Requiring the Date header + +As of 2012, requiring a valid date header will almost certainly cause the loss +of valid mail. The JavaMail sender used by some banks, photo processing +services, health insurance companies, bounce senders, and others do send +messages without a Date header. For this reason, and despite RFC 5322, the +default is not to require Date. + +However, if the date header is present, and I and/or I are +defined, it will be validated. + +=head2 future + +The number of days in the future beyond which messages are invalid. + + headers [ future 1 ] + +=head2 past + +The number of days in the past beyond which a message is invalid. The Date header is added by the MUA, so there are many valid reasons a message may have an older date in the header. It could have been delayed by the client, the sending server, connectivity problems, recipient server problem, recipient server configuration, etc. The I setting should take those factors into consideration. + +I would be surprised if a valid message ever had a date header older than a week. + + headers [ past 5 ] + +=head2 reject + +Determine if the connection is denied. Use the I option when first enabling the plugin, and then watch your logs to see what would have been rejected. When you are no longer concerned that valid messages will be rejected, enable with I. + + headers reject [ 0 | 1 ] + +Default: 1 + +=head2 reject_type + +Whether to issue a permanent or temporary rejection. The default is permanent. + + headers reject_type [ temp | perm ] + +Using a temporary rejection is a cautious way to enable rejections. It allows an administrator to watch for a trial period and assure no valid messages are rejected. If a deferral of valid mail is noticed, I can be set to permit the deferred message to be delivered. + +Default: perm + +=head2 loglevel + +Adjust the quantity of logging for this plugin. See docs/logging.pod + +=head1 AUTHOR + +2012 - Matt Simerson + +=head1 ACKNOWLEDGEMENTS + +based in part upon check_basicheaders by Jim Winstead Jr. + +Singular headers idea from Haraka's data.rfc5322_header_checks.js by Steve Freegard + +=cut + +use strict; +use warnings; + +use Qpsmtpd::Constants; + +use Date::Parse qw(str2time); + +my @required_headers = qw/ From /; # <- to comply with RFC 5322, add Date here +#my @should_headers = qw/ Message-ID /; +my @singular_headers = qw/ Date From Sender Reply-To To Cc Bcc + Message-Id In-Reply-To References + Subject /; + +sub register { + my ($self, $qp ) = shift, shift; + + $self->log(LOGWARN, "invalid arguments") if @_ % 2; + $self->{_args} = { @_ }; + + $self->{_args}{reject_type} ||= 'perm'; # set default + if ( ! defined $self->{_args}{reject} ) { + $self->{_args}{reject} = 1; # set default + }; + + if ( $self->{_args}{require} ) { + @required_headers = split /,/, $self->{_args}{require}; + }; +} + +sub hook_data_post { + my ($self, $transaction) = @_; + + if ( $transaction->data_size == 0 ) { + return $self->get_reject( "You must send some data first", "no data" ); + }; + + my $header = $transaction->header or do { + return $self->get_reject( "missing headers", "missing headers" ); + }; + + #return (DECLINED, "immune") if $self->is_immune(); + + foreach my $h ( @required_headers ) { + if ( ! $header->get($h) ) { + return $self->get_reject( + "We require a valid $h header", "no $h header" + ); + }; + }; + + foreach my $h ( @singular_headers ) { + next if ! $header->get($h); # doesn't exist + my @qty = $header->get($h); + next if @qty == 1; # only 1 header + return $self->get_reject("Only one $h header allowed. See RFC 5322", "too many $h headers"); + }; + + my $err_msg = $self->invalid_date_range(); + return $self->get_reject($err_msg, $err_msg) if $err_msg; + + $self->log( LOGINFO, 'pass' ); + return (DECLINED); +}; + +sub invalid_date_range { + my $self = shift; + + my $date = $self->transaction->header->get('Date') or return; + chomp $date; + + my $ts = str2time($date) or do { + $self->log(LOGINFO, "skip, date not parseable ($date)"); + return; + }; + + my $past = $self->{_args}{past}; + if ( $past && $ts < time - ($past*24*3600) ) { + $self->log(LOGINFO, "fail, date too old ($date)"); + return "The Date header is too far in the past"; + }; + + my $future = $self->{_args}{future}; + if ( $future && $ts > time + ($future*24*3600) ) { + $self->log(LOGINFO, "fail, date in future ($date)"); + return "The Date header is too far in the future"; + }; + + return; +} + diff --git a/plugins/helo b/plugins/helo new file mode 100644 index 0000000..55e8e8e --- /dev/null +++ b/plugins/helo @@ -0,0 +1,488 @@ +#!perl -w + +=head1 NAME + +helo - validate the HELO message presented by a connecting host. + +=head1 DESCRIPTION + +Validate the HELO hostname. This plugin includes a suite of optional tests, +selectable by the I setting. The policy section details which tests +are enforced by each policy option. + +It sets the connection notes helo_forward_match and helo_reverse_match when +I or I are used. + +Adds an X-HELO header with the HELO hostname to the message. + +Using I will reject a very large portion of the spam from hosts +that have yet to get blacklisted. + +=head1 WHY IT WORKS + +The reverse DNS of the zombie PCs is out of the spam operators control. Their +only way to get past these tests is to limit themselves to hosts with matching +forward and reverse DNS, and then use the proper HELO hostname when spamming. +At present, this presents a very high hurdle. + +=head1 HELO VALIDATION TESTS + +=over 4 + +=item is_in_badhelo + +Matches in the I config file, including yahoo.com and aol.com, which +neither the real Yahoo or the real AOL use, but which spammers use a lot. + +Like qmail with the qregex patch, the B file can also contain perl +regular expressions. In addition to normal regexp processing, a pattern can +start with a ! character, and get a negated (!~) match. + +=item invalid_localhost + +Assure that if a sender uses the 'localhost' hostname, they are coming from +the localhost IP. + +=item is_plain_ip + +Disallow plain IP addresses. They are neither a FQDN nor an address literal. + +=item is_address_literal [N.N.N.N] + +An address literal (an IP enclosed in brackets) is legal but rarely, if ever, +encountered from legit senders. + +=item is_forged_literal + +If a literal is presented, make sure it matches the senders IP. + +=item is_not_fqdn + +Makes sure the HELO hostname contains at least one dot and has only those +characters specifically allowed in domain names (RFC 1035). + +=item no_forward_dns + +Make sure the HELO hostname resolves. + +=item no_reverse_dns + +Make sure the senders IP address resolves to a hostname. + +=item no_matching_dns + +Make sure the HELO hostname has an A or AAAA record that matches the senders +IP address, and make sure that the senders IP has a PTR that resolves to the +HELO hostname. + +Since the dawn of SMTP, having matching DNS has been a minimum standard +expected and oft required of mail servers. While requiring matching DNS is +prudent, requiring an exact match will reject valid email. While testing this +plugin with rejection disabled, I noticed that mx0.slc.paypal.com sends email +from an IP that reverses to mx1.slc.paypal.com. While that's technically an +error, I believe it's an error to reject mail based on it. Especially since +SLD and TLD match. + +To avoid snagging false positives, matches are extended to the first +3 octets of the IP and the last two labels of the FQDN. The following are +considered a match: + + 192.0.1.2, 192.0.1.3 + + foo.example.com, bar.example.com + +This allows I to be used without rejecting mail from orgs with +pools of servers where the HELO name and IP don't exactly match. This list +includes Yahoo, Gmail, PayPal, cheaptickets.com, exchange.microsoft.com, and +likely many more. + +=back + +=head1 CONFIGURATION + +=head2 policy [ lenient | rfc | strict ] + +Default: lenient + +=head3 lenient + +Reject failures of the following tests: is_in_badhelo, invalid_localhost, and +is_forged_literal. + +This setting is lenient enough not to cause problems for your Windows users. +It is comparable to running check_spamhelo, but with the addition of regexp +support and the prevention of forged localhost and forged IP literals. + +=head3 rfc + +Per RFC 2821, the HELO hostname is the FQDN of the sending server or an +address literal. When I is selected, all the lenient checks and +the following are enforced: is_plain_ip, is_not_fqdn, no_forward_dns, and +no_reverse_dns. + +If you have Windows users that send mail via your server, do not choose +I without I and the B plugin. Windows +users often send unqualified HELO names and will have trouble sending mail. + can defer the rejection, and if the user subsequently authenticates, +the rejection will be cancelled. + +=head3 strict + +Strict includes all the RFC tests and the following: no_matching_dns, and +is_address_literal. + +I have yet to see an address literal being used by a hammy sender. But I am +not certain that blocking them all is prudent. + +It is recommended that I be used with and that you +monitor your logs for false positives before enabling rejection. + +=head2 badhelo + +Add domains, hostnames, or perl regexp patterns to the F config +file; one per line. + +=head2 timeout [seconds] + +Default: 5 + +The number of seconds before DNS queries timeout. + +=head2 reject [ 0 | 1 | naughty ] + +Default: 1 + +0: do not reject + +1: reject + +naughty: naughty plugin handles rejection + +=head2 reject_type [ temp | perm | disconnect ] + +Default: disconnect + +What type of rejection should be sent? See docs/config.pod + +=head2 loglevel + +Adjust the quantity of logging for this plugin. See docs/logging.pod + +=head1 RFC 2821 + +=head2 4.1.1.1 + +The HELO hostname "...contains the fully-qualified domain name of the SMTP +client if one is available. In situations in which the SMTP client system +does not have a meaningful domain name (e.g., when its address is dynamically +allocated and no reverse mapping record is available), the client SHOULD send +an address literal (see section 4.1.3), optionally followed by information +that will help to identify the client system." + +=head2 2.3.5 + +The domain name, as described in this document and in [22], is the +entire, fully-qualified name (often referred to as an "FQDN"). A domain name +that is not in FQDN form is no more than a local alias. Local aliases MUST +NOT appear in any SMTP transaction. + + +=head1 AUTHOR + +2012 - Matt Simerson + +=head1 ACKNOWLEDGEMENTS + +badhelo processing from check_badhelo plugin + +badhelo regex processing idea from qregex patch + +additional check ideas from Hakura helo plugin + +=cut + +use strict; +use warnings; + +use Qpsmtpd::Constants; + +use Net::DNS; + +sub register { + my ($self, $qp) = shift, shift; + $self->{_args} = { @_ }; + $self->{_args}{reject_type} = 'disconnect'; + $self->{_args}{policy} ||= 'lenient'; + $self->{_args}{timeout} ||= 5; + + if ( ! defined $self->{_args}{reject} ) { + $self->{_args}{reject} = 1; + }; + + $self->populate_tests(); + $self->init_resolver(); + + $self->register_hook('helo', 'helo_handler'); + $self->register_hook('ehlo', 'helo_handler'); + $self->register_hook('data_post', 'data_post_handler'); +}; + +sub helo_handler { + my ($self, $transaction, $host) = @_; + + if ( ! $host ) { + $self->log(LOGINFO, "fail, no helo host"); + return DECLINED; + }; + + return DECLINED if $self->is_immune(); + + foreach my $test ( @{ $self->{_helo_tests} } ) { + my @err = $self->$test( $host ); + return $self->get_reject( @err ) if scalar @err; + }; + + $self->log(LOGINFO, "pass"); + return DECLINED; +} + +sub data_post_handler { + my ($self, $transaction) = @_; + + $transaction->header->delete('X-HELO'); + $transaction->header->add('X-HELO', $self->qp->connection->hello_host, 0 ); + + return (DECLINED); +}; + +sub populate_tests { + my $self = shift; + + my $policy = $self->{_args}{policy}; + @{ $self->{_helo_tests} } = qw/ is_in_badhelo invalid_localhost is_forged_literal /; + + if ( $policy eq 'rfc' || $policy eq 'strict' ) { + push @{ $self->{_helo_tests} }, qw/ is_plain_ip is_not_fqdn no_forward_dns + no_reverse_dns /; + }; + + if ( $policy eq 'strict' ) { + push @{ $self->{_helo_tests} }, qw/ is_address_literal no_matching_dns /; + }; +}; + +sub init_resolver { + my $self = shift; + return $self->{_resolver} if $self->{_resolver}; + $self->log( LOGDEBUG, "initializing Net::DNS::Resolver"); + $self->{_resolver} = Net::DNS::Resolver->new(dnsrch => 0); + my $timeout = $self->{_args}{timeout} || 5; + $self->{_resolver}->tcp_timeout($timeout); + $self->{_resolver}->udp_timeout($timeout); + return $self->{_resolver}; +}; + +sub is_in_badhelo { + my ( $self, $host ) = @_; + + my $error = "I do not believe you are $host."; + + $host = lc $host; + foreach my $bad ($self->qp->config('badhelo')) { + if ( $bad =~ /[\{\}\[\]\(\)\^\$\|\*\+\?\\\!]/ ) { # it's a regexp + return $self->is_regex_match( $host, $bad ); + }; + if ( $host eq lc $bad) { + return ($error, "in badhelo"); + } + } + return; +}; + +sub is_regex_match { + my ( $self, $host, $pattern ) = @_; + + my $error = "Your HELO hostname is not allowed"; + + #$self->log( LOGDEBUG, "is regex ($pattern)"); + if ( substr( $pattern, 0, 1) eq '!' ) { + $pattern = substr $pattern, 1; + if ( $host !~ /$pattern/ ) { + #$self->log( LOGDEBUG, "matched ($pattern)"); + return ($error, "badhelo pattern match ($pattern)"); + }; + return; + } + if ( $host =~ /$pattern/ ) { + #$self->log( LOGDEBUG, "matched ($pattern)"); + return ($error, "badhelo pattern match ($pattern)"); + }; + return; +} + +sub invalid_localhost { + my ( $self, $host ) = @_; + return if lc $host ne 'localhost'; + if ( $self->qp->connection->remote_ip ne '127.0.0.1' ) { + #$self->log( LOGINFO, "fail, not localhost" ); + return ("You are not localhost", "invalid localhost"); + }; + $self->log( LOGDEBUG, "pass, is localhost" ); + return; +}; + +sub is_plain_ip { + my ( $self, $host ) = @_; + return if $host =~ /[^\d\.]+/; # has chars other than digits and a dot + return if $host !~ m/^(\d{1,3}\.){3}\d{1,3}$/; + + $self->log( LOGDEBUG, "fail, plain IP" ); + return ("Plain IP is invalid HELO hostname (RFC 2821)", "plain IP"); +}; + +sub is_address_literal { + my ( $self, $host ) = @_; + return if $host !~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/; + + $self->log( LOGDEBUG, "fail, bracketed IP" ); + return ("RFC 2821 allows an address literal, but we do not", "bracketed IP"); +}; + +sub is_forged_literal { + my ( $self, $host ) = @_; + return if $host !~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/; + + $host = substr $host, 1, -1; + return if $host eq $self->qp->connection->remote_ip; + return ("Forged IPs not accepted here", "forged IP literal"); +}; + +sub is_not_fqdn { + my ($self, $host) = @_; + return if $host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/; # address literal, skip + if ( $host !~ /\./ ) { # has no dots + return ("HELO name is not fully qualified. Read RFC 2821", "not FQDN"); + }; + if ( $host =~ /[^a-zA-Z0-9\-\.]/ ) { + return ("HELO name contains invalid FQDN characters. Read RFC 1035", "invalid FQDN chars"); + }; + return; +}; + +sub no_forward_dns { + my ( $self, $host ) = @_; + + my $res = $self->init_resolver(); + + $host = "$host." if $host !~ /\.$/; # fully qualify name + my $query = $res->search($host); + + if (! $query) { + if ( $res->errorstring eq 'NXDOMAIN' ) { + return ("HELO hostname does not exist", "HELO hostname does not exist"); + } + $self->log(LOGERROR, "skip, query failed (", $res->errorstring, ")" ); + return; + }; + my $hits = 0; + foreach my $rr ($query->answer) { + next unless $rr->type =~ /^(?:A|AAAA)$/; + $self->check_ip_match( $rr->address ); + $hits++; + } + if ( $hits ) { + $self->log(LOGDEBUG, "pass, forward DNS") if $hits; + return; + }; + return ("helo hostname did not resolve", "fail, HELO forward DNS"); +}; + +sub no_reverse_dns { + my ( $self, $host, $ip ) = @_; + + my $res = $self->init_resolver(); + $ip ||= $self->qp->connection->remote_ip; + + my $query = $res->query( $ip ) or do { + if ( $res->errorstring eq 'NXDOMAIN' ) { + return ("no rDNS for $ip", "no rDNS"); + }; + $self->log( LOGINFO, $res->errorstring ); + return ("error getting reverse DNS for $ip", "rDNS " . $res->errorstring); + }; + + my $hits = 0; + for my $rr ($query->answer) { + next if $rr->type ne 'PTR'; + $self->log(LOGDEBUG, "PTR: " . $rr->ptrdname ); + $self->check_name_match( lc $rr->ptrdname, lc $host ); + $hits++; + }; + if ( $hits ) { + $self->log(LOGDEBUG, "has rDNS"); + return; + }; + return ("no reverse DNS for $ip", "no rDNS"); +}; + +sub no_matching_dns { + my ( $self, $host ) = @_; + + if ( $self->connection->notes('helo_forward_match') && + $self->connection->notes('helo_reverse_match') ) { + $self->log( LOGDEBUG, "foward and reverse match" ); +# TODO: consider adding some karma here + return; + }; + + if ( $self->connection->notes('helo_forward_match') ) { + $self->log( LOGDEBUG, "name matches IP" ); + return; + } + if ( $self->connection->notes('helo_reverse_match') ) { + $self->log( LOGDEBUG, "reverse matches name" ); + return; + }; + + $self->log( LOGINFO, "fail, no forward or reverse DNS match" ); + return ("That HELO hostname fails forward and reverse DNS checks", "no matching DNS"); +}; + +sub check_ip_match { + my $self = shift; + my $ip = shift or return; + + if ( $ip eq $self->qp->connection->remote_ip ) { + $self->log( LOGDEBUG, "forward ip match" ); + $self->connection->notes('helo_forward_match', 1); + return; + }; + + my $dns_net = join('.', (split('\.', $ip))[0,1,2] ); + my $rem_net = join('.', (split('\.', $self->qp->connection->remote_ip))[0,1,2] ); + + if ( $dns_net eq $rem_net ) { + $self->log( LOGNOTICE, "forward network match" ); + $self->connection->notes('helo_forward_match', 1); + }; +}; + +sub check_name_match { + my $self = shift; + my ($dns_name, $helo_name) = @_; + + if ( $dns_name eq $helo_name ) { + $self->log( LOGDEBUG, "reverse name match" ); + $self->connection->notes('helo_reverse_match', 1); + return; + }; + + my $dns_dom = join('.', (split('\.', $dns_name ))[-2,-1] ); + my $helo_dom = join('.', (split('\.', $helo_name))[-2,-1] ); + + if ( $dns_dom eq $helo_dom ) { + $self->log( LOGNOTICE, "reverse domain match" ); + $self->connection->notes('helo_reverse_match', 1); + }; +}; + diff --git a/plugins/help b/plugins/help new file mode 100644 index 0000000..e9cd4d5 --- /dev/null +++ b/plugins/help @@ -0,0 +1,142 @@ +#!perl -w + +=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; +} + diff --git a/plugins/hosts_allow b/plugins/hosts_allow new file mode 100644 index 0000000..77aafd1 --- /dev/null +++ b/plugins/hosts_allow @@ -0,0 +1,105 @@ +#!perl -w + +=head1 NAME + +hosts_allow - decide if a host is allowed to connect + +=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 config/plugin arguments. + +This plugin only works with the forkserver and prefork deployment models. It +does not work with the tcpserver deployment model. See SEE ALSO below. + +=head1 CONFIG + +The I config file contains lines with two or three items. The +first is 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. + +=head1 SEE ALSO + +To get similar functionality for the tcpserver deployment model, use +tcpserver's -x feature. Create a tcp.smtp file with entries like this: + + 70.65.227.235:deny + 183.7.90.207:deny + :allow + +compile the tcp.smtp file like this: + + /usr/local/bin/tcprules tcp.smtp.cdb tcp.smtp.tmp < tcp.smtp + +and add the file to the chain of arguments to tcpserver in your run file. + +See also: http://cr.yp.to/ucspi-tcp.html + +=cut + +use strict; +use warnings; + +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}; + my $max = $args{max_conn_ip}; + + if ( $max ) { + 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 > $max ) { + my $err_mess = "too many connections from $remote"; + $self->log(LOGINFO, "fail: $err_mess ($num_conn > $max)"); + return (DENYSOFT, "Sorry, $err_mess, 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; + $mask = 32 if !defined $mask; + $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; + if ( $const =~ /deny/i ) { + $self->log( LOGINFO, "fail: $message" ); + }; + $self->log( LOGDEBUG, "pass: $const, $message" ); + return($const, $message); + } + } + + $self->log( LOGDEBUG, "pass" ); + return (DECLINED); +} diff --git a/plugins/http_config b/plugins/http_config new file mode 100644 index 0000000..bb3f674 --- /dev/null +++ b/plugins/http_config @@ -0,0 +1,50 @@ +#!perl -w +=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; +} diff --git a/plugins/ident/geoip b/plugins/ident/geoip new file mode 100644 index 0000000..fddaa10 --- /dev/null +++ b/plugins/ident/geoip @@ -0,0 +1,312 @@ +#!perl -w + +=head1 NAME + +geoip - provide geographic information about mail senders. + +=head1 SYNOPSIS + +Use MaxMind's GeoIP databases and the Geo::IP perl module to report geographic +information about incoming connections. + +=head1 DESCRIPTION + +This plugin saves geographic information in the following connection notes: + + geoip_country - 2 char country code + geoip_country_name - full english name of country + geoip_continent - 2 char continent code + geoip_distance - distance in kilometers + +And adds entries like this to your logs: + + (connect) ident::geoip: US, United States, NA, 1319 km + (connect) ident::geoip: IN, India, AS, 13862 km + (connect) ident::geoip: fail: no results + (connect) ident::geoip: CA, Canada, NA, 2464 km + (connect) ident::geoip: US, United States, NA, 2318 km + (connect) ident::geoip: PK, Pakistan, AS, 12578 km + (connect) ident::geoip: TJ, Tajikistan, AS, 11965 km + (connect) ident::geoip: AT, Austria, EU, 8745 km + (connect) ident::geoip: IR, Iran, Islamic Republic of, AS, 12180 km + (connect) ident::geoip: BY, Belarus, EU, 9030 km + (connect) ident::geoip: CN, China, AS, 11254 km + (connect) ident::geoip: PA, Panama, NA, 3163 km + +Calculating the distance has three prerequsites: + + 1. The MaxMind city database (free or subscription) + 2. The Math::Complex perl module + 3. The IP address of this mail server (see CONFIG) + +Other plugins can utilize the geographic notes to alter the +connection, reject, greylist, etc. + +=head1 CONFIG + +The following options can be appended in this plugins config/plugins entry. + +=head2 distance + +Enables geodesic distance calculation. Will calculate the distance "as the +crow flies" from the remote mail server. Accepts a single argument, the IP +address to calculate the distance from. This will typically be the public +IP of your mail server. + + ident/geoip [ distance 192.0.1.5 ] + +Default: none. (no distance calculations) + +=head2 db_dir + +The path to the GeoIP database directory. + + ident/geoip [ db_dir /etc/GeoIP ] + +Default: /usr/local/share/GeoIP + +=head1 LIMITATIONS + +The distance calculations are more concerned with being fast than accurate. +The MaxMind location data is collected from whois and is of limited accuracy. +MaxMind offers more accurate data for a fee. + +For distance calculations, the earth is considered a perfect sphere. In +reality, it is not. Accuracy should be within 1%. + +This plugin does not update the GeoIP databases. You may want to. + +=head1 CHANGES + +2012-06 - Matt Simerson - added GeoIP City support, continent, distance + +2012-05 - Matt Simerson - added geoip_country_name note, added tests + +=head1 SEE ALSO + +MaxMind: http://www.maxmind.com/ + +Databases: http://geolite.maxmind.com/download/geoip/database + +It may become worth adding support for Geo::IPfree, which uses another +data source: http://software77.net/geo-ip/ + +=head1 ACKNOWLEDGEMENTS + +Stevan Bajic, the DSPAM author, who suggested SNARE, which describes using +geodesic distance to determine spam probability. The research paper on SNARE +can be found here: +http://smartech.gatech.edu/bitstream/handle/1853/25135/GT-CSE-08-02.pdf + +=cut + +use strict; +use warnings; + +use Qpsmtpd::Constants; +#use Geo::IP; # eval'ed in register() +#use Math::Trig; # eval'ed in set_distance_gc + +sub register { + my ($self, $qp ) = shift, shift; + + $self->log(LOGERROR, "Bad arguments") if @_ % 2; + $self->{_args} = { @_ }; + $self->{_args}{db_dir} ||= '/usr/local/share/GeoIP'; + + eval 'use Geo::IP'; + if ( $@ ) { + warn "could not load Geo::IP"; + $self->log( LOGERROR, "could not load Geo::IP" ); + return; + }; + +# Note that opening the GeoIP DB only in register has caused problems before: +# https://github.com/smtpd/qpsmtpd/commit/29ea9516806e9a8ca6519fcf987dbd684793ebdd#plugins/ident/geoip +# Opening the DB anew for every connection is horribly inefficient. +# Instead, attempt to reopen upon connect if the DB connection fails. + $self->open_geoip_db(); + + $self->init_my_country_code(); + + $self->register_hook( 'connect', 'connect_handler' ); +}; + +sub connect_handler { + my $self = shift; + + # reopen the DB if Geo::IP failed due to DB update + $self->open_geoip_db(); + + my $c_code = $self->set_country_code() or do { + $self->log( LOGINFO, "fail: no results" ); + return DECLINED; + }; + $self->qp->connection->notes('geoip_country', $c_code); + + my $c_name = $self->set_country_name(); + my ($continent_code, $distance); + + if ( $self->{_my_country_code} ) { + $continent_code = $self->set_continent( $c_code ); + $distance = $self->set_distance_gc(); + }; + + my $message = $c_code; + $message .= ", $c_name" if $c_name; + $message .= ", $continent_code" if $continent_code && $continent_code ne '--'; + $message .= ", \t$distance km" if $distance; + $self->log(LOGINFO, $message); + + return DECLINED; +} + +sub open_geoip_db { + my $self = shift; + + # this might detect if the DB connection failed. If not, this is where + # to add more code to do it. + return if ( defined $self->{_geoip_city} || defined $self->{_geoip} ); + + # The methods for using GeoIP work differently for the City vs Country DB + # save the handles in different locations + my $db_dir = $self->{_args}{db_dir}; + foreach my $db ( qw/ GeoIPCity GeoLiteCity / ) { + if ( -f "$db_dir/$db.dat" ) { + $self->log(LOGDEBUG, "using db $db"); + $self->{_geoip_city} = Geo::IP->open( "$db_dir/$db.dat" ); + } + }; + + # can't think of a good reason to load country if city data is present + if ( ! $self->{_geoip_city} ) { + $self->log(LOGDEBUG, "using default db"); + $self->{_geoip} = Geo::IP->new(); # loads default Country DB + }; +}; + +sub init_my_country_code { + my $self = shift; + my $ip = $self->{_args}{distance} or return; + $self->{_my_country_code} = $self->get_country_code( $ip ); +}; + +sub set_country_code { + my $self = shift; + return $self->get_country_code_gc() if $self->{_geoip_city}; + my $remote_ip = $self->qp->connection->remote_ip; + my $code = $self->get_country_code(); + $self->qp->connection->notes('geoip_country', $code); + return $code; +}; + +sub get_country_code { + my $self = shift; + my $ip = shift || $self->qp->connection->remote_ip; + return $self->get_country_code_gc( $ip ) if $self->{_geoip_city}; + return $self->{_geoip}->country_code_by_addr( $ip ); +}; + +sub get_country_code_gc { + my $self = shift; + my $ip = shift || $self->qp->connection->remote_ip; + $self->{_geoip_record} = $self->{_geoip_city}->record_by_addr($ip) or return; + return $self->{_geoip_record}->country_code; +}; + +sub set_country_name { + my $self = shift; + return $self->set_country_name_gc() if $self->{_geoip_city}; + my $remote_ip = $self->qp->connection->remote_ip; + my $name = $self->{_geoip}->country_name_by_addr( $remote_ip ) or return; + $self->qp->connection->notes('geoip_country_name', $name); + return $name; +}; + +sub set_country_name_gc { + my $self = shift; + return if ! $self->{_geoip_record}; + my $remote_ip = $self->qp->connection->remote_ip; + my $name = $self->{_geoip_record}->country_name() or return; + $self->qp->connection->notes('geoip_country_name', $name); + return $name; +}; + +sub set_continent { + my $self = shift; + return $self->set_continent_gc() if $self->{_geoip_city}; + my $c_code = shift or return; + my $continent = $self->{_geoip}->continent_code_by_country_code( $c_code ) + or return; + $self->qp->connection->notes('geoip_continent', $continent); + return $continent; +}; + +sub set_continent_gc { + my $self = shift; + return if ! $self->{_geoip_record}; + my $continent = $self->{_geoip_record}->continent_code() or return; + $self->qp->connection->notes('geoip_continent', $continent); + return $continent; +}; + +sub set_distance_gc { + my $self = shift; + return if ! $self->{_geoip_record}; + + my ($self_lat, $self_lon) = $self->get_my_lat_lon() or return; + my ($sender_lat, $sender_lon) = $self->get_sender_lat_lon() or return; + + eval 'use Math::Trig qw(great_circle_distance deg2rad)'; + if ( $@ ) { + $self->log( LOGERROR, "can't calculate distance, Math::Trig not installed"); + return; + }; + + # Notice the 90 - latitude: phi zero is at the North Pole. + sub NESW { deg2rad($_[0]), deg2rad(90 - $_[1]) }; + my @me = NESW($self_lon, $self_lat ); + my @sender = NESW($sender_lon, $sender_lat); + my $km = great_circle_distance(@me, @sender, 6378); + $km = sprintf("%.0f", $km); + + $self->qp->connection->notes('geoip_distance', $km); + #$self->log( LOGINFO, "distance $km km"); + return $km; +}; + +sub get_my_lat_lon { + my $self = shift; + return if ! $self->{_geoip_city}; + + if ( $self->{_latitude} && $self->{_longitude} ) { + return ( $self->{_latitude}, $self->{_longitude} ); # cached + }; + + my $ip = $self->{_args}{distance} or return; + my $record = $self->{_geoip_city}->record_by_addr($ip) or do { + $self->log( LOGERROR, "no record for my Geo::IP location"); + return; + }; + + $self->{_latitude} = $record->latitude(); + $self->{_longitude} = $record->longitude(); + + if ( ! $self->{_latitude} || ! $self->{_longitude} ) { + $self->log( LOGNOTICE, "could not get my lat/lon"); + }; + return ( $self->{_latitude}, $self->{_longitude} ); +}; + +sub get_sender_lat_lon { + my $self = shift; + + my $lat = $self->{_geoip_record}->latitude(); + my $lon = $self->{_geoip_record}->longitude(); + if ( ! $lat || ! $lon ) { + $self->log( LOGNOTICE, "could not get sender lat/lon"); + return; + }; + return ($lat, $lon); +}; + diff --git a/plugins/ident/p0f b/plugins/ident/p0f new file mode 100644 index 0000000..2386980 --- /dev/null +++ b/plugins/ident/p0f @@ -0,0 +1,363 @@ +#!perl -w + +=head1 NAME + +p0f - A TCP Fingerprinting Identification Plugin + +=head1 SYNOPSIS + +Use TCP fingerprint info (remote computer OS, network distance, etc) to +implement more sophisticated anti-spam policies. + +=head1 DESCRIPTION + +This p0f module inserts a 'p0f' note that other qpsmtpd plugins can inspect. +It includes the following information about the TCP fingerprint (link, +detail, distance, uptime, genre). Here's an example connection note: + + genre => FreeBSD + detail => 6.x (1) + uptime => 1390 + link => ethernet/modem + distance => 17 + +Which was parsed from this p0f fingerprint: + + 24.18.227.2:39435 - FreeBSD 6.x (1) (up: 1390 hrs) + -> 208.75.177.101:25 (distance 17, link: ethernet/modem) + +=head1 MOTIVATION + +This p0f plugin provides a way to make sophisticated policies for email +messages. For example, the vast majority of email connections to my server +from Windows computers are spam (>99%). But, I have a few clients that use +Exchange servers so I can't just block email from all Windows computers. + +Same goes for greylisting. Finance companies (AmEx, BoA, etc) just love to +send notices that they won't queue and retry. Either they deliver at that +instant or never. When I enable greylisting, I lose valid messages. Grrr. + +So, while I'm not willing to use greylisting, and I'm not willing to block +connections from Windows computers, I am quite willing to greylist all email +from Windows computers. + +=head1 CONFIGURATION + +Configuration consists of two steps: starting p0f and configuring this plugin. + +=head2 start p0f + +Create a startup script for PF that creates a communication socket when your +server starts up. + +p0f v2 example: + + p0f -u qpsmtpd -d -q -Q /tmp/.p0f_socket2 'dst port 25' -o /dev/null + chown qpsmtpd /tmp/.p0f_socket2 + +p0f v3 example: + + p0f -u qpsmtpd -d -s /tmp/.p0f_socket3 'dst port 25' + chown qpsmtpd /tmp/.p0f_socket3 + +=head2 configure p0f plugin + +add an entry to config/plugins to enable p0f: + + ident/p0f /tmp/.p0f_socket3 + +It's even possible to run both versions of p0f simultaneously: + + ident/p0f:2 /tmp/.p0f_socket2 version 2 + ident/p0f:3 /tmp/.p0f_socket3 + +=head2 local_ip + +Use the local_ip option to override the IP address of your mail server. This +is useful if your mail server has a private IP because it is running behind +a firewall. For example, my mail server has the IP 127.0.0.6, but the world +knows my mail server as 208.75.177.101. + +Example config/plugins entry with local_ip override: + + ident/p0f /tmp/.p0f_socket local_ip 208.75.177.101 + + +=head2 version + +The version settings specifies the version of p0f you are running. This plugin supports p0f versions 2 and 3. If version is not defined, version 3 is assumed. + +Example entry specifying p0f version 2 + + ident/p0f /tmp/.p0f_socket version 2 + +=head1 Environment requirements + +p0f v3 requires only the remote IP. + +p0f v2 requires four pieces of information to look up the p0f fingerprint: +local_ip, local_port, remote_ip, and remote_port. TcpServer.pm has been +has been updated to provide that information when running under djb's +tcpserver. The async, forkserver, and prefork models will likely require +some additional changes to make sure these fields are populated. + +=head1 ACKNOWLEDGEMENTS + +Version 2 code heavily based upon the p0fq.pl included with the p0f distribution. + +=head1 AUTHORS + +Robert Spier ( original author ) + +Matt Simerson + +=head1 CHANGES + +Added local_ip option - Matt Simerson (5/2010) + +Refactored and added p0f v3 support - Matt Simerson (4/2012) + +=cut + +use strict; +use warnings; + +use Qpsmtpd::Constants; +use IO::Socket; +use Net::IP; + +my $QUERY_MAGIC_V2 = 0x0defaced; +my $QUERY_MAGIC_V3 = 0x50304601; +my $RESP_MAGIC_V3 = 0x50304602; + +my $P0F_STATUS_BADQUERY = 0x00; +my $P0F_STATUS_OK = 0x10; +my $P0F_STATUS_NOMATCH = 0x20; + +sub register { + my ($self, $qp, $p0f_socket, %args) = @_; + + $p0f_socket =~ /(.*)/; # untaint + $self->{_args}->{p0f_socket} = $1; + foreach (keys %args) { + $self->{_args}->{$_} = $args{$_}; + } +} + +sub hook_connect { + my($self, $qp) = @_; + + my $p0f_version = $self->{_args}{version} || 3; + if ( $p0f_version == 3 ) { + my $response = $self->query_p0f_v3() or return DECLINED; + $self->test_v3_response( $response ) or return DECLINED; + $self->store_v3_results( $response ); + } + else { + my $response = $self->query_p0f_v2() or return DECLINED; + $self->test_v2_response( $response ) or return DECLINED; + $self->store_v2_results( $response ); + } + + return DECLINED; +} + +sub get_v2_query { + my $self = shift; + + my $local_ip = $self->{_args}{local_ip} || $self->qp->connection->local_ip; + + my $src = new Net::IP ($self->qp->connection->remote_ip) + or $self->log(LOGERROR, "p0f: ".Net::IP::Error()), return; + + my $dst = new Net::IP($local_ip) + or $self->log(LOGERROR, "p0f: ".NET::IP::Error()), return; + + return pack("L L L N N S S", + $QUERY_MAGIC_V2, + 1, + rand ^ 42 ^ time, + $src->intip(), + $dst->intip(), + $self->qp->connection->remote_port, + $self->qp->connection->local_port); +}; + +sub get_v3_query { + my $self = shift; + + my $src_ip = $self->qp->connection->remote_ip or do { + $self->log( LOGERROR, "unable to determine remote IP"); + return; + }; + + if ( $src_ip =~ /:/ ) { # IPv6 + my @bits = split(/\:/, $src_ip ); + return pack( "L C C C C C C C C C C C C C C C C C", $QUERY_MAGIC_V3, 0x06, @bits ); + }; + + my @octets = split(/\./, $src_ip); + return pack( "L C C16", $QUERY_MAGIC_V3, 0x04, @octets ); +}; + +sub query_p0f_v3 { + my $self = shift; + + my $p0f_socket = $self->{_args}{p0f_socket} or do { + $self->log(LOGERROR, "socket not defined in config."); + return; + }; + my $query = $self->get_v3_query() or return; + +# Open the connection to p0f + my $sock; + eval { + $sock = IO::Socket::UNIX->new(Peer => $p0f_socket, Type => SOCK_STREAM ); + }; + if ( ! $sock ) { + $self->log(LOGERROR, "p0f: could not open socket: $@"); + return; + }; + + $sock->autoflush(1); # paranoid redundancy + $sock->connected or do { + $self->log(LOGERROR, "p0f: socket not connected: $!"); + return; + }; + + my $sent = $sock->send($query, 0) or do { + $self->log(LOGERROR, "p0f: send failed: $!"); + return; + }; + + print $sock $query; # yes, this is redundant, but I get no response from p0f otherwise + + $self->log(LOGDEBUG, "p0f: send $sent byte request"); + + my $response; + $sock->recv( $response, 232 ); + my $length = length $response; + $self->log(LOGDEBUG, "p0f: received $length byte response"); + close $sock; + return $response; +}; + +sub query_p0f_v2 { + my $self = shift; + + my $p0f_socket = $self->{_args}->{p0f_socket}; + my $query = $self->get_v2_query() or return; + + # Open the connection to p0f + socket(SOCK, PF_UNIX, SOCK_STREAM, 0) + or $self->log(LOGERROR, "p0f: socket: $!"), return; + connect(SOCK, sockaddr_un($p0f_socket)) + or $self->log(LOGERROR, "p0f: connect: $!"), return; + defined syswrite SOCK, $query + or $self->log(LOGERROR, "p0f: write: $!"), close SOCK, return; + + my $response; + defined sysread SOCK, $response, 1024 + or $self->log(LOGERROR, "p0f: read: $!"), close SOCK, return; + close SOCK; + return $response; +}; + +sub test_v2_response { + my ($self, $response ) = @_; + + # Extract part of the p0f response + my ($magic, $id, $type) = unpack ("L L C", $response); + + # $self->log(LOGERROR, $response); + if ($magic != $QUERY_MAGIC_V2) { + $self->log(LOGERROR, "p0f: Bad response magic."); + return; + } + + if ($type == 1) { + $self->log(LOGERROR, "p0f: p0f did not honor our query"); + return; + } + elsif ($type == 2) { + $self->log(LOGWARN, "p0f: This connection is no longer in the cache"); + return; + } + return 1; +}; + +sub test_v3_response { + my ($self, $response ) = @_; + + my ($magic,$status) = unpack ("L L", $response); + + # check the magic response value (a p0f constant) + if ($magic != $RESP_MAGIC_V3 ) { + $self->log(LOGERROR, "p0f: Bad response magic."); + return; + } + + # check the response status + if ($status == $P0F_STATUS_BADQUERY ) { + $self->log(LOGERROR, "p0f: bad query"); + return; + } + elsif ($status == $P0F_STATUS_NOMATCH ) { + $self->log(LOGINFO, "p0f: no match"); + return; + } + if ($status == $P0F_STATUS_OK ) { + $self->log(LOGDEBUG, "p0f: query ok"); + return 1; + } + return; +}; + +sub store_v2_results { + my ($self, $response ) = @_; + + 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); + + my $p0f = { + genre => $genre, + detail => $detail, + distance => $dist, + link => $link, + uptime => $uptime, + }; + + $self->connection->notes('p0f', $p0f); + $self->log(LOGINFO, $genre." (".$detail.")"); + $self->log(LOGERROR,"error: $@") if $@; + return $p0f; +}; + +sub store_v3_results { + my ($self, $response ) = @_; + + my @labels = qw/ magic status first_seen last_seen total_conn uptime_min + up_mod_days last_nat last_chg distance bad_sw os_match_q os_name os_flavor + http_name http_flavor link_type language /; + my @values = unpack ("L L L L L L L L L s C C A32 A32 A32 A32 A32 A32 A32", $response); + + my %r; + foreach my $i ( 0 .. ( scalar @labels -1 ) ) { + next if ! defined $values[$i]; + next if ! defined $values[$i]; + $r{ $labels[$i] } = $values[$i]; + }; + if ( $r{os_name} ) { # compat with p0f v2 + $r{genre} = "$r{os_name} $r{os_flavor}"; + $r{link} = $r{link_type} if $r{link_type}; + $r{uptime} = $r{uptime_min} if $r{uptime_min}; + }; + + $self->connection->notes('p0f', \%r); + $self->log(LOGINFO, "$r{os_name} $r{os_flavor}"); + $self->log(LOGDEBUG, join(' ', @values )); + $self->log(LOGERROR,"error: $@") if $@; + return \%r; +}; + diff --git a/plugins/karma b/plugins/karma new file mode 100644 index 0000000..b85f5e6 --- /dev/null +++ b/plugins/karma @@ -0,0 +1,474 @@ +#!perl -w + +=head1 NAME + +karma - reward nice and penalize naughty mail senders + +=head1 SYNOPSIS + +Karma tracks sender history, providing the ability to deliver differing levels +of service to naughty, nice, and unknown senders. + +=head1 DESCRIPTION + +Karma records the number of nice, naughty, and total connections from mail +senders. After sending a naughty message, if a sender has more naughty than +nice connections, they are penalized for I. Connections +from senders in the penalty box are tersely disconnected. + +Karma provides other plugins with a karma value they can use to be more +lenient, strict, or skip processing entirely. + +Karma is small, fast, and ruthlessly efficient. Karma can be used to craft +custom connection policies such as these two examples: + +=over 4 + +Hi there, well behaved sender. Please help yourself to TLS, AUTH, greater +concurrency, multiple recipients, no delays, and other privileges. + +Hi there, naughty sender. Enjoy this poke in the eye with a sharp stick. Bye. + +=back + +=head1 CONFIG + +=head2 negative + +How negative a senders karma can get before we penalize them for sending a +naughty message. Karma is the number of nice - naughty connections. + +Default: 1 + +Examples: + + negative 1: 0 nice - 1 naughty = karma -1, penalize + negative 1: 1 nice - 1 naughty = karma 0, okay + negative 2: 1 nice - 2 naughty = karma -1, okay + negative 2: 1 nice - 3 naughty = karma -2, penalize + +With the default negative limit of one, there's a very small chance you could +penalize a "mostly good" sender. Raising it to 2 reduces that possibility to +improbable. + +=head2 penalty_days + +The number of days a naughty sender is refused connections. Use a decimal +value to penalize for portions of days. + + karma penalty_days 1 + +Default: 1 + +=head2 reject + + karma reject [ 0 | 1 | connect | naughty ] + +I<0> will not reject any connections. + +I<1> will reject naughty senders. + +I is the most efficient setting. + +To reject at any other connection hook, use the I setting and the +B plugin. + +=head2 db_dir + +Path to a directory in which the DB will be stored. This directory must be +writable by the qpsmtpd user. If unset, the first usable directory from the +following list will be used: + +=over 4 + +=item /var/lib/qpsmtpd/karma + +=item I/var/db (where BINDIR is the location of the qpsmtpd binary) + +=item I/config + +=back + +=head2 loglevel + +Adjust the quantity of logging for this plugin. See docs/logging.pod + +=head1 BENEFITS + +Karma reduces the resources wasted by naughty mailers. When used with +I, naughty senders are disconnected in about 0.1 seconds. + +The biggest gains to be had are by having heavy plugins (spamassassin, dspam, +virus filters) set the B transaction note (see KARMA) when they encounter +naughty senders. Reasons to send servers to the penalty box could include +sending a virus, early talking, or sending messages with a very high spam +score. + +This plugin does not penalize connections with transaction notes I +or I set. These notes would have been set by the B, +B, and B plugins. Obviously, those plugins must +run before B for that to work. + +=head1 KARMA + +No attempt is made by this plugin to determine what karma is. It is up to +other plugins to make that determination and communicate it to this plugin by +incrementing or decrementing the transaction note B. Raise it for good +karma and lower it for bad karma. This is best done like so: + + # only if karma plugin loaded + if ( defined $connection->notes('karma') ) { + $connection->notes('karma', $connection->notes('karma') - 1); # bad + $connection->notes('karma', $connection->notes('karma') + 1); # good + }; + +After the connection ends, B will record the result. Mail servers whose +naughty connections exceed nice ones are sent to the penalty box. Servers in +the penalty box will be tersely disconnected for I. Here is +an example connection from an IP in the penalty box: + + 73122 Connection from smtp.midsetmediacorp.com [64.185.226.65] + 73122 (connect) ident::geoip: US, United States + 73122 (connect) ident::p0f: Windows 7 or 8 + 73122 (connect) earlytalker: pass: 64.185.226.65 said nothing spontaneous + 73122 (connect) relay: skip: no match + 73122 (connect) karma: fail + 73122 550 You were naughty. You are penalized for 0.99 more days. + 73122 click, disconnecting + 73122 (post-connection) connection_time: 1.048 s. + +If we only set negative karma, we will almost certainly penalize servers we +want to receive mail from. For example, a Yahoo user sends an egregious spam +to a user on our server. Now nobody on our server can receive email from that +Yahoo server for I. This should happen approximately 0% of +the time if we are careful to also set positive karma. + +=head1 KARMA HISTORY + +Karma maintains a history for each IP. When a senders history has decreased +below -5 and they have never sent a good message, they get a karma bonus. +The bonus tacks on an extra day of blocking for every naughty message they +sent us. + +Example: an unknown sender delivers a spam. They get a one day penalty_box. +After 5 days, 5 spams, 5 penalties, and 0 nice messages, they get a six day +penalty. The next offence gets a 7 day penalty, and so on. + +=head1 USING KARMA + +To get rid of naughty connections as fast as possible, run karma before other +connection plugins. Plugins that trigger DNS lookups or impose time delays +should run after B. In this example, karma runs before all but the +ident plugins. + + 89011 Connection from Unknown [69.61.27.204] + 89011 (connect) ident::geoip: US, United States + 89011 (connect) ident::p0f: Linux 3.x + 89011 (connect) karma: fail, 1 naughty, 0 nice, 1 connects + 89011 550 You were naughty. You are penalized for 0.99 more days. + 89011 click, disconnecting + 89011 (post-connection) connection_time: 0.118 s. + 88798 cleaning up after 89011 + +Unlike RBLs, B only penalizes IPs that have sent us spam, and only when +those senders haven't sent us any ham. As such, it's much safer to use. + +=head1 USING KARMA IN OTHER PLUGINS + +This plugin sets the connection note I. Your plugin can +use the senders karma to be more gracious or rude to senders. The value of +I is the number the nice connections minus naughty +ones. The higher the number, the better you should treat the sender. + +When I is set and a naughty sender is encountered, most +plugins should skip processing. However, if you wish to toy with spammers by +teergrubing, extending banner delays, limiting connections, limiting +recipients, random disconnects, handoffs to rblsmtpd, and other fun tricks, +then connections with the I note set are for you! + +=head1 EFFECTIVENESS + +In the first 24 hours, B rejected 8% of all connections. After one +week of running with I, karma has rejected 15% of all +connections. + +This plugins effectiveness results from the propensity of naughty senders +to be repeat offenders. Limiting them to a single offense per day(s) greatly +reduces the number of useless tokens miscreants add to our Bayes databases. + +Of the connections that had previously passed all other checks and were caught +only by spamassassin and/or dspam, B rejected 31 percent. Since +spamassassin and dspam consume more resources than others plugins, this plugin +seems to be a very big win. + +=head1 DATABASE + +Connection summaries are stored in a database. The database key is the int +form of the remote IP. The value is a : delimited list containing a penalty +box start time (if the server is/was on timeout) and the count of naughty, +nice, and total connections. The database can be listed and searched with the +karma_dump.pl script. + +=head1 BUGS & LIMITATIONS + +This plugin is reactionary. Like the FBI, it doesn't punish until +after a crime has been committed. It an "abuse me once, shame on you, +abuse me twice, shame on me" policy. + +There is little to be gained by listing servers that are already on DNS +blacklists, send to non-existent users, earlytalkers, etc. Those already have +very lightweight tests. + +=head1 AUTHOR + + 2012 - Matt Simerson - msimerson@cpan.org + +=head1 ACKNOWLEDGEMENTS + +Gavin Carr's DB implementation in the greylisting plugin. + +=cut + +use strict; +use warnings; + +use Qpsmtpd::Constants; + +BEGIN { @AnyDBM_File::ISA = qw(DB_File GDBM_File NDBM_File) } +use AnyDBM_File; +use Fcntl qw(:DEFAULT :flock LOCK_EX LOCK_NB); +use Net::IP; + +sub register { + my ($self, $qp ) = shift, shift; + $self->log(LOGERROR, "Bad arguments") if @_ % 2; + $self->{_args} = { @_ }; + $self->{_args}{negative} ||= 1; + $self->{_args}{penalty_days} ||= 1; + $self->{_args}{reject_type} ||= 'disconnect'; + + if ( ! defined $self->{_args}{reject} ) { + $self->{_args}{reject} = 'naughty'; + }; + #$self->prune_db(); # keep the DB compact + $self->register_hook('connect', 'connect_handler'); + $self->register_hook('disconnect', 'disconnect_handler'); +} + +sub connect_handler { + my $self = shift; + + $self->connection->notes('karma', 0); # default + + return DECLINED if $self->is_immune(); + + my $db = $self->get_db_location(); + my $lock = $self->get_db_lock( $db ) or return DECLINED; + my $tied = $self->get_db_tie( $db, $lock ) or return DECLINED; + my $key = $self->get_db_key(); + + if ( ! $tied->{$key} ) { + $self->log(LOGINFO, "pass, no record"); + return $self->cleanup_and_return($tied, $lock ); + }; + + my ($penalty_start_ts, $naughty, $nice, $connects) = $self->parse_value( $tied->{$key} ); + my $summary = "$naughty naughty, $nice nice, $connects connects"; + my $karma = $self->calc_karma($naughty, $nice); + + if ( ! $penalty_start_ts ) { + $self->log(LOGINFO, "pass, no penalty ($summary)"); + return $self->cleanup_and_return($tied, $lock ); + }; + + my $days_old = (time - $penalty_start_ts) / 86400; + if ( $days_old >= $self->{_args}{penalty_days} ) { + $self->log(LOGINFO, "pass, penalty expired ($summary)"); + return $self->cleanup_and_return($tied, $lock ); + }; + + $tied->{$key} = join(':', $penalty_start_ts, $naughty, $nice, ++$connects); + $self->cleanup_and_return($tied, $lock ); + + my $left = sprintf "%.2f", $self->{_args}{penalty_days} - $days_old; + my $mess = "You were naughty. You are penalized for $left more days."; + + return $self->get_reject( $mess, $karma ); +} + +sub disconnect_handler { + my $self = shift; + + my $karma = $self->connection->notes('karma') or do { + $self->log(LOGDEBUG, "no karma"); + return DECLINED; + }; + + my $db = $self->get_db_location(); + my $lock = $self->get_db_lock( $db ) or return DECLINED; + my $tied = $self->get_db_tie( $db, $lock ) or return DECLINED; + my $key = $self->get_db_key(); + + my ($penalty_start_ts, $naughty, $nice, $connects) = $self->parse_value( $tied->{$key} ); + + if ( $karma < 0 ) { + $naughty++; + my $negative_limit = 0 - $self->{_args}{negative}; + my $history = ($nice || 0) - $naughty; + if ( $history <= $negative_limit ) { + if ( $nice == 0 && $history < -5 ) { + $self->log(LOGINFO, "penalty box bonus!"); + $penalty_start_ts = sprintf "%s", time + abs($history) * 86400; + } + else { + $penalty_start_ts = sprintf "%s", time; + }; + $self->log(LOGINFO, "negative, sent to penalty box ($history)"); + } + else { + $self->log(LOGINFO, "negative"); + }; + } + elsif ($karma > 1) { + $nice++; + $self->log(LOGINFO, "positive"); + } + + $tied->{$key} = join(':', $penalty_start_ts, $naughty, $nice, ++$connects); + return $self->cleanup_and_return($tied, $lock ); +} + +sub parse_value { + my ($self, $value) = @_; + + my $penalty_start_ts = my $naughty = my $nice = my $connects = 0; + if ( $value ) { + ($penalty_start_ts, $naughty, $nice, $connects) = split /:/, $value; + $penalty_start_ts ||= 0; + $nice ||= 0; + $naughty ||= 0; + $connects ||= 0; + }; + return ($penalty_start_ts, $naughty, $nice, $connects ); +}; + +sub calc_karma { + my ($self, $naughty, $nice) = @_; + return 0 if ( ! $naughty && ! $nice ); + + my $karma = ( $nice || 0 ) - ( $naughty || 0 ); + $self->connection->notes('karma_history', $karma ); + return $karma; +}; + +sub cleanup_and_return { + my ($self, $tied, $lock, $return_val ) = @_; + + untie $tied; + close $lock; + return ($return_val) if defined $return_val; # explicit override + return (DECLINED); +}; + +sub get_db_key { + my $self = shift; + my $nip = Net::IP->new( $self->qp->connection->remote_ip ); + return $nip->intip; # convert IP to an int +}; + +sub get_db_tie { + my ( $self, $db, $lock ) = @_; + + tie( my %db, 'AnyDBM_File', $db, O_CREAT|O_RDWR, 0600) or do { + $self->log(LOGCRIT, "tie to database $db failed: $!"); + close $lock; + return; + }; + return \%db; +}; + +sub get_db_location { + my $self = shift; + + # Setup database location + my ($QPHOME) = ($0 =~ m!(.*?)/([^/]+)$!); + my @candidate_dirs = ( $self->{args}{db_dir}, + "/var/lib/qpsmtpd/karma", "$QPHOME/var/db", "$QPHOME/config", '.' ); + + my $dbdir; + for my $d ( @candidate_dirs ) { + next if ! $d || ! -d $d; # impossible + $dbdir = $d; + last; # first match wins + } + my $db = "$dbdir/karma.dbm"; + $self->log(LOGDEBUG,"using $db as karma database"); + return $db; +}; + +sub get_db_lock { + my ($self, $db) = @_; + + return $self->get_db_lock_nfs($db) if $self->{_args}{nfslock}; + + # Check denysoft db + open( my $lock, ">$db.lock" ) or do { + $self->log(LOGCRIT, "opening lockfile failed: $!"); + return; + }; + + flock( $lock, LOCK_EX ) or do { + $self->log(LOGCRIT, "flock of lockfile failed: $!"); + close $lock; + return; + }; + + return $lock; +} + +sub get_db_lock_nfs { + my ($self, $db) = @_; + + require File::NFSLock; + + ### set up a lock - lasts until object looses scope + my $nfslock = new File::NFSLock { + file => "$db.lock", + lock_type => LOCK_EX|LOCK_NB, + blocking_timeout => 10, # 10 sec + stale_lock_timeout => 30 * 60, # 30 min + } or do { + $self->log(LOGCRIT, "nfs lockfile failed: $!"); + return; + }; + + open( my $lock, "+<$db.lock") or do { + $self->log(LOGCRIT, "opening nfs lockfile failed: $!"); + return; + }; + + return $lock; +}; + +sub prune_db { + my $self = shift; + + my $db = $self->get_db_location(); + my $lock = $self->get_db_lock( $db ) or return DECLINED; + my $tied = $self->get_db_tie( $db, $lock ) or return DECLINED; + my $count = keys %$tied; + + my $pruned = 0; + foreach my $key ( keys %$tied ) { + my $ts = $tied->{$key}; + my $days_old = ( time - $ts ) / 86400; + next if $days_old < $self->{_args}{penalty_days} * 2; + delete $tied->{$key}; + $pruned++; + }; + untie $tied; + close $lock; + $self->log( LOGINFO, "pruned $pruned of $count DB entries" ); + return $self->cleanup_and_return( $tied, $lock, DECLINED ); +}; + diff --git a/plugins/karma_tool b/plugins/karma_tool new file mode 100755 index 0000000..d7556a5 --- /dev/null +++ b/plugins/karma_tool @@ -0,0 +1,250 @@ +#!/usr/bin/perl +package Karma; + +use strict; +use warnings; + +BEGIN { @AnyDBM_File::ISA = qw(DB_File GDBM_File NDBM_File) } +use AnyDBM_File; +use Data::Dumper; +use Fcntl qw(:DEFAULT :flock LOCK_EX LOCK_NB); +use Net::IP qw(:PROC); +use POSIX qw(strftime); + +my $self = bless( { args => { db_dir => 'config' }, }, 'Karma' ); +my $command = $ARGV[0]; + +if ( ! $command ) { + $self->usage(); +} +elsif ( $command eq 'capture' ) { + $self->capture( $ARGV[1] ); +} +elsif ( $command eq 'release' ) { + $self->capture( $ARGV[1] ); +} +elsif ( $command eq 'prune' ) { + $self->prune_db( $ARGV[1] || 7 ); +} +elsif ( $command eq 'list' | $command eq 'search' ) { + $self->main(); +}; + +exit(0); + +sub usage { + print <get_db_location(); + my $lock = $self->get_db_lock( $db ) or return; + my $tied = $self->get_db_tie( $db, $lock ) or return; + my $key = $self->get_db_key( $ip ); + + $tied->{$key} = join(':', time, 1, 0, 1); + return $self->cleanup_and_return( $tied, $lock ); +}; + +sub release { + my $self = shift; + my $ip = shift or return; + is_ip( $ip ) or do { + warn "not an IP: $ip\n"; + return; + }; + + my $db = $self->get_db_location(); + my $lock = $self->get_db_lock( $db ) or return; + my $tied = $self->get_db_tie( $db, $lock ) or return; + my $key = $self->get_db_key( $ip ); + + $tied->{$key} = join(':', 0, 1, 0, 1); + return $self->cleanup_and_return( $tied, $lock ); +}; + +sub main { + my $self = shift; + + my $db = $self->get_db_location(); + my $lock = $self->get_db_lock( $db ) or return; + my $tied = $self->get_db_tie( $db, $lock ) or return; + my %totals; + + print " IP Address Penalty Naughty Nice Connects Hostname\n"; + foreach my $r ( sort keys %$tied ) { + my $ip = ip_bintoip( ip_inttobin( $r, 4 ), 4); + my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/, $tied->{$r}; + $naughty ||= ''; + $nice ||= ''; + $connects ||= ''; + my $time_human = ''; + if ( $command eq 'search' ) { + my $search = $ARGV[1]; + if ( $search eq 'nice' ) { + next if ! $nice; + } + elsif ( $search eq 'naughty' ) { + next if ! $naughty; + } + elsif ( $search eq 'both' ) { + next if ! $naughty || ! $nice; + } + elsif ( is_ip() && $search ne $ip ) { + next; + } + }; + if ( $penalty_start_ts ) { + $time_human = strftime "%a %b %e %H:%M", localtime $penalty_start_ts; + }; + my $hostname = ''; + if ( $naughty && $nice ) { + $hostname = `dig +short -x $ip`; chomp $hostname; + }; + printf(" %-18s %24s %3s %3s %3s %30s\n", $ip, $time_human, $naughty, $nice, $connects, $hostname); + $totals{naughty} += $naughty if $naughty; + $totals{nice} += $nice if $nice; + $totals{connects} += $connects if $connects; + }; + print Dumper(\%totals); +} + +sub is_ip { + my $ip = shift || $ARGV[0]; + return 1 if $ip =~ /^(\d{1,3}\.){3}\d{1,3}$/; + return; +}; + +sub cleanup_and_return { + my ($self, $tied, $lock ) = @_; + untie $tied; + close $lock; +}; + +sub get_db_key { + my $self = shift; + my $nip = Net::IP->new( shift ); + return $nip->intip; # convert IP to an int +}; + +sub get_db_tie { + my ( $self, $db, $lock ) = @_; + + tie( my %db, 'AnyDBM_File', $db, O_CREAT|O_RDWR, 0600) or do { + warn "tie to database $db failed: $!"; + close $lock; + return; + }; + return \%db; +}; + +sub get_db_location { + my $self = shift; + + # Setup database location + my @candidate_dirs = ( $self->{args}{db_dir}, + "/var/lib/qpsmtpd/karma", "./var/db", "./config", '.' ); + + my $dbdir; + for my $d ( @candidate_dirs ) { + next if ! $d || ! -d $d; # impossible + $dbdir = $d; + last; # first match wins + } + my $db = "$dbdir/karma.dbm"; + print "using karma db at $db\n"; + return $db; +}; + +sub get_db_lock { + my ($self, $db) = @_; + + return $self->get_db_lock_nfs($db) if $self->{_args}{nfslock}; + + # Check denysoft db + open( my $lock, ">$db.lock" ) or do { + warn "opening lockfile failed: $!"; + return; + }; + + flock( $lock, LOCK_EX ) or do { + warn "flock of lockfile failed: $!"; + close $lock; + return; + }; + + return $lock; +} + +sub get_db_lock_nfs { + my ($self, $db) = @_; + + require File::NFSLock; + + ### set up a lock - lasts until object looses scope + my $nfslock = new File::NFSLock { + file => "$db.lock", + lock_type => LOCK_EX|LOCK_NB, + blocking_timeout => 10, # 10 sec + stale_lock_timeout => 30 * 60, # 30 min + } or do { + warn "nfs lockfile failed: $!"; + return; + }; + + open( my $lock, "+<$db.lock") or do { + warn "opening nfs lockfile failed: $!"; + return; + }; + + return $lock; +}; + +sub prune_db { + my $self = shift; + my $prune_days = shift; + + my $db = $self->get_db_location(); + my $lock = $self->get_db_lock( $db ) or return; + my $tied = $self->get_db_tie( $db, $lock ) or return; + my $count = keys %$tied; + + my $pruned = 0; + foreach my $key ( keys %$tied ) { + my ($ts, $naughty, $nice, $connects) = split /:/, $tied->{$key}; + my $days_old = ( time - $ts ) / 86400; + next if $days_old < $prune_days; + delete $tied->{$key}; + $pruned++; + }; + untie $tied; + close $lock; + warn "pruned $pruned of $count DB entries"; + return $self->cleanup_and_return( $tied, $lock ); +}; + diff --git a/plugins/logging/adaptive b/plugins/logging/adaptive new file mode 100644 index 0000000..4e96ba6 --- /dev/null +++ b/plugins/logging/adaptive @@ -0,0 +1,184 @@ +#!perl -w +# 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; +} + +=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 + diff --git a/plugins/logging/apache b/plugins/logging/apache new file mode 100644 index 0000000..317b45c --- /dev/null +++ b/plugins/logging/apache @@ -0,0 +1,113 @@ +#!perl -w + +=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; +} + +=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 + diff --git a/plugins/logging/connection_id b/plugins/logging/connection_id new file mode 100644 index 0000000..7023601 --- /dev/null +++ b/plugins/logging/connection_id @@ -0,0 +1,81 @@ +#!perl -w +# 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; +} + +=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 + diff --git a/plugins/logging/devnull b/plugins/logging/devnull new file mode 100644 index 0000000..e8bbf8f --- /dev/null +++ b/plugins/logging/devnull @@ -0,0 +1,7 @@ +#!perl -w +# this is a simple 'drop packets on the floor' plugin + +sub hook_logging { + return DECLINED; +} + diff --git a/plugins/logging/file b/plugins/logging/file new file mode 100644 index 0000000..cc51d92 --- /dev/null +++ b/plugins/logging/file @@ -0,0 +1,282 @@ +#!perl -w + +=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); +use Qpsmtpd::Constants; + +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; +} + diff --git a/plugins/logging/syslog b/plugins/logging/syslog new file mode 100644 index 0000000..8552650 --- /dev/null +++ b/plugins/logging/syslog @@ -0,0 +1,186 @@ +#!perl -w + +=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 Qpsmtpd::Constants; +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; +} + diff --git a/plugins/logging/transaction_id b/plugins/logging/transaction_id new file mode 100644 index 0000000..bc5a293 --- /dev/null +++ b/plugins/logging/transaction_id @@ -0,0 +1,80 @@ +#!perl -w +# 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; +} + +=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 + diff --git a/plugins/logging/warn b/plugins/logging/warn new file mode 100644 index 0000000..c85b9d5 --- /dev/null +++ b/plugins/logging/warn @@ -0,0 +1,76 @@ +#!perl -w + +=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. + +It demonstrates that a logging plugin can call ->log itself as well +as how to ignore log entries from itself + +=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 + +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 && $plugin eq $self->plugin_name; + + return DECLINED if $trace > $self->{_level}; + + my $prefix = defined $plugin && defined $hook ? " ($hook) $plugin:" : + defined $plugin ? " $plugin:" : + defined $hook ? " ($hook) running plugin:" : ''; + + warn join(' ', $$ . $prefix, @log), "\n"; + + return DECLINED; +} + diff --git a/plugins/milter b/plugins/milter new file mode 100644 index 0000000..64370e9 --- /dev/null +++ b/plugins/milter @@ -0,0 +1,236 @@ +#!perl -w +=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; +use Qpsmtpd::Constants; +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->connection->notes('milter') || return DECLINED; + $milter->send_quit(); + + $self->connection->notes('spam', undef); + $self->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->connection->notes(milter => $milter); + + $self->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->connection->notes('spam', $@) if $@; + + return DECLINED; +} + +sub hook_helo { + my ($self, $transaction) = @_; + + if (my $txt = $self->connection->notes('spam')) { + return DENY, $txt; + } + + my $milter = $self->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->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->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->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; +} diff --git a/plugins/naughty b/plugins/naughty new file mode 100644 index 0000000..f7ae28f --- /dev/null +++ b/plugins/naughty @@ -0,0 +1,161 @@ +#!perl -w + +=head1 NAME + +naughty - dispose of naughty connections + +=head1 BACKGROUND + +Rather than immediately terminating naughty connections, plugins often mark +the connections and dispose of them later. Examples are B, B, +B, B and B. + +This practice is based on RFC standards and the belief that malware will retry +less if we disconnect after RCPT. This may have been true, and may still be, +but my observations in 2012 suggest it makes no measurable difference whether +I disconnect during connect or rcpt. + +Disconnecting later is inefficient because other plugins continue to do their +work, oblivious to the fact that the connection is destined for the bit bucket. + +=head1 DESCRIPTION + +Naughty provides the following: + +=head2 efficiency + +Naughty provides plugins with an efficient way to offer late disconnects. It +does this by allowing other plugins to detect that a connection is naughty. +For efficiency, other plugins should skip processing naughty connections. +Plugins like SpamAssassin and DSPAM can benefit from using naughty connections +to train their filters. + +Since so many connections are from blacklisted IPs, naughty significantly +reduces the processing time required for disposing of them. Over 80% of my +connections are disposed of after after a few DNS queries (B or one DB +query (B) and 0.01s of compute time. + +=head2 naughty cleanup + +Instead of each plugin handling cleanup, B does it. Set I to +the hook you prefer to reject in and B will reject the naughty +connections, regardless of who identified them, exactly when you choose. + +=head2 simplicity + +Rather than having plugins split processing across hooks, they can run to +completion when they have the information they need, issue a +I if warranted, and be done. + +This may help reduce the code divergence between the sync and async +deployment models. + +=head2 authentication + +When a user authenticates, the naughty flag on their connection is cleared. +This is to allow users to send email from IPs that fail connection tests such +as B. Keep in mind that if I is set, connections will +not get the chance to authenticate. + +=head2 naughty + + provides a a consistent way for plugins to mark connections as +naughty. Set the connection note I to the message you wish to send +the naughty sender during rejection. + + $self->connection->notes('naughty', $message); + +This happens for plugins automatically if they use the $self->get_reject() +method and have set I in the plugin configuration. + +=head1 CONFIGURATION + +=head2 reject + + naughty reject [ connect | mail | rcpt | data | data_post ] + +The phase of the connection in which the naughty connection will be terminated. +Keep in mind that if you choose rcpt and a plugin (like B) runs first, +and B returns OK, then this plugin will not get called and the +message will not get rejected. + +Solutions are to make sure B is listed before rcpt_ok in config/plugins +or set naughty to run in a phase after the one you wish to complete. +In this case, use data instead of rcpt to disconnect after rcpt_ok. The latter +is particularly useful if your rcpt plugins skip naughty testing. In that case, +any recipient is accepted for naughty connections, which prevents spammers +from detecting address validity. + +=head2 reject_type [ temp | perm | disconnect ] + +What type of rejection should be sent? See docs/config.pod + +=head2 loglevel + +Adjust the quantity of logging for this plugin. See docs/logging.pod + +=head1 EXAMPLES + +Here's how to use naughty and get_reject in your plugin: + + sub register { + my ($self,$qp) = shift, shift; + $self->{_args} = { @_ }; + $self->{_args}{reject} ||= 'naughty'; + }; + + sub connect_handler { + my ($self, $transaction) = @_; + ... do a bunch of stuff ... + return DECLINED if is_okay(); + return $self->get_reject( $message ); + }; + +=head1 AUTHOR + + 2012 - Matt Simerson - msimerson@cpan.org + +=cut + +use strict; +use warnings; + +use Qpsmtpd::Constants; + +sub register { + my ($self, $qp ) = shift, shift; + $self->log(LOGERROR, "Bad arguments") if @_ % 2; + $self->{_args} = { @_ }; + $self->{_args}{reject} ||= 'rcpt'; + $self->{_args}{reject_type} ||= 'disconnect'; + + my $reject = lc $self->{_args}{reject}; + my %hooks = map { $_ => 1 } + qw/ connect mail rcpt data data_post hook_queue_post /; + + if ( ! $hooks{$reject} ) { + $self->log( LOGERROR, "fail, invalid hook $reject" ); + $self->register_hook( 'data_post', 'naughty'); + return; + }; + + # just in case naughty doesn't disconnect, which can happen if a plugin + # with the same hook returned OK before naughty ran, or .... + if ( $reject ne 'data_post' && $reject ne 'hook_queue_post' ) { + $self->register_hook( 'data_post', 'naughty'); + }; + + $self->log(LOGDEBUG, "registering hook $reject"); + $self->register_hook( $reject, 'naughty'); +} + +sub naughty { + my $self = shift; + my $naughty = $self->connection->notes('naughty') or do { + $self->log(LOGINFO, "pass, clean"); + return DECLINED; + }; + $self->log(LOGINFO, "disconnecting"); + return ( $self->get_reject_type(), $naughty ); +}; + diff --git a/plugins/noop_counter b/plugins/noop_counter new file mode 100644 index 0000000..6ce949b --- /dev/null +++ b/plugins/noop_counter @@ -0,0 +1,62 @@ +#!perl -w + +=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; + diff --git a/plugins/parse_addr_withhelo b/plugins/parse_addr_withhelo new file mode 100644 index 0000000..49c8a0f --- /dev/null +++ b/plugins/parse_addr_withhelo @@ -0,0 +1,68 @@ +#!perl -w + +=head1 NAME + +parse_addr_withhelo + +=head1 SYNOPSIS + +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. + +=cut + +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; + } +} + diff --git a/plugins/queue/exim-bsmtp b/plugins/queue/exim-bsmtp new file mode 100644 index 0000000..0dd4246 --- /dev/null +++ b/plugins/queue/exim-bsmtp @@ -0,0 +1,145 @@ +#!perl -w +=head1 NAME + +exim-bsmtp + +=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 + +=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); +use Qpsmtpd::Constants; + +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!"); +} + diff --git a/plugins/queue/maildir b/plugins/queue/maildir new file mode 100644 index 0000000..0c71b85 --- /dev/null +++ b/plugins/queue/maildir @@ -0,0 +1,214 @@ +#!perl -w + +=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); +} + diff --git a/plugins/queue/postfix-queue b/plugins/queue/postfix-queue new file mode 100644 index 0000000..2586d9a --- /dev/null +++ b/plugins/queue/postfix-queue @@ -0,0 +1,198 @@ +#!perl -w + +=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). +The 'postfix_queue' plugin can also contain a list of cleanup socket paths +and/or remote postfix cleanup service hosts specified in the form of +'address:port'. If set, the environment variable POSTFIXQUEUE overrides both +of these settings. + +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; + } + + 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} = $ENV{POSTFIXQUEUE} if $ENV{POSTFIXQUEUE}; + +} + +sub hook_queue { + my ($self, $transaction) = @_; + $transaction->notes('postfix-queue-flags', $self->{_queue_flags}); + my @queue; + @queue = ($self->{_queue_socket_env}) if $self->{_queue_socket_env}; + @queue = $self->qp->config('cleanup_sockets') unless @queue; + @queue = ($self->{_queue_socket} // ()) unless @queue; + $transaction->notes('postfix-queue-sockets', \@queue) if @queue; + + # $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)"); +} + diff --git a/plugins/queue/qmail-queue b/plugins/queue/qmail-queue new file mode 100644 index 0000000..de639eb --- /dev/null +++ b/plugins/queue/qmail-queue @@ -0,0 +1,115 @@ +#!perl -w + +=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 + } +} diff --git a/plugins/queue/smtp-forward b/plugins/queue/smtp-forward new file mode 100644 index 0000000..a6c23c3 --- /dev/null +++ b/plugins/queue/smtp-forward @@ -0,0 +1,70 @@ +#!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. + + 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!"); +} diff --git a/plugins/quit_fortune b/plugins/quit_fortune new file mode 100644 index 0000000..2e1effe --- /dev/null +++ b/plugins/quit_fortune @@ -0,0 +1,17 @@ +#!perl -w + +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; +} diff --git a/plugins/random_error b/plugins/random_error new file mode 100644 index 0000000..3faf890 --- /dev/null +++ b/plugins/random_error @@ -0,0 +1,85 @@ +#!perl -w +=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->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]->connection->notes('random_fail_%'); + +=head1 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]->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 +} + diff --git a/plugins/rcpt_map b/plugins/rcpt_map new file mode 100644 index 0000000..32c0a3b --- /dev/null +++ b/plugins/rcpt_map @@ -0,0 +1,189 @@ +#!perl -w + +=head1 NAME + +rcpt_map - check recipients against recipient map + +=head1 DESCRIPTION + +B reads a list of adresses, return codes and comments +from the supplied config file. Adresses are 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. + +When the given map file changes on disk, it is re-read in the pre-connection +hook. + +=head1 ARGUMENTS + +The C and C arguments are required. The default value of +the C argument is C (see below why C<_>). + +=over 4 + +=item domain NAME + +If the recipient address does not match this domain name NAME, this plugin will +return C + +=item file MAP + +Use the config file as map file, format as explained below + +=item default CODE[=MSG] + +Use CODE as default return code (and return MSG as message) if a recipient +was B found in the map. Since we can't use spaces in MSG, every C<_> +is replaced by a space, i.e. use C if you want a deny +message C. + +=back + +=head1 CONFIG FILE + +The config file contains lines with an address, a return code and a comment, +which will be returned to the sender, if the code is not OK or DECLINED. +Example: + + # example_org_map - config for rcpt_map plugin + me@example.org OK + you@example.org OK + info@example.org DENY User not found. + +=head1 NOTES + +We're currently running this plugin like shown in the following example. + +Excerpt from the C config file: + + ## list of valid users, config in /srv/qpsmtpd/config/rcpt_regexp + ## ... except for "*@example.org": + rcpt_regexp + ## only for "@example.org": + rcpt_map domain example.org file /srv/qpsmtpd/config/map_example_org + +And the C config file: + + ### "example.org" addresses are checked later by the rcpt_map + ### plugin, return DECLINED here: + /^.*\@example\.org$/ DECLINED + ### all other domains just check for valid users, the validity + ### of the domain is checked by the rcpt_ok plugin => never use + ### something else than "DENY" or "DECLINED" here! + /^(abuse|postmaster)\@/ DECLINED + /^(me|you)\@/ DECLINED + /^.*$/ DENY No such user. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2009 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; + +our %map; + +sub register { + my ($self, $qp, %args) = @_; + foreach my $arg (qw(domain file default)) { + next unless exists $args{$arg}; + if ($arg eq "default") { + my ($code, $msg) = split /=/, $args{$arg}; + + $code = Qpsmtpd::Constants::return_code($code); + die "Not a valid constant for 'default' arg" + unless defined $code; + + $msg or $msg = "No such user."; + $msg =~ s/_/ /g; + + $self->{_default} = [$code, $msg]; + } + else { + $self->{"_$arg"} = $args{$arg}; + } + } + + $self->{_default} + or $self->{_default} = [DENY, "No such user."]; + + $self->{_file} + or die "No map file given..."; + + $self->{_domain} + or die "No domain name given..."; + $self->{_domain} = lc $self->{_domain}; + + $self->log(LOGDEBUG, + "Using map ".$self->{_file}." for domain ".$self->{_domain}); + %map = $self->read_map(1); + die "Empty map file ".$self->{_file} + unless keys %map; +} + +sub hook_pre_connection { + my $self = shift; + my ($time) = (stat($self->{_file}))[9] || 0; + if ($time > $self->{_time}) { + my %temp = $self->read_map(); + keys %temp + or return DECLINED; + %map = %temp; + } + return DECLINED; +} + +sub read_map { + my $self = shift; + my %hash = (); + open F, $self->{_file} + or do { $_[0] ? die "ERROR opening: $!" : return (); }; + + ($self->{_time}) = (stat(F))[9] || 0; + + my $line = 0; + while () { + ++$line; + s/^\s*//; + next if /^#/; + next unless $_; + my ($addr, $code, $msg) = split ' ', $_, 3; + next unless $addr; + + unless ($code) { + $self->log(LOGERROR, + "No constant in line $line in ".$self->{_file}); + next; + } + $code = Qpsmtpd::Constants::return_code($code); + unless (defined $code) { + $self->log(LOGERROR, + "Not a valid constant in line $line in ".$self->{_file}); + next; + } + $msg or $msg = "No such user."; + $hash{$addr} = [$code, $msg]; + } + return %hash; +} + +sub hook_rcpt { + my ($self, $transaction, $recipient) = @_; + return (DECLINED) + unless $recipient->host && $recipient->user; + + return (DECLINED) + unless lc($recipient->host) eq $self->{_domain}; + + my $rcpt = lc $recipient->user . '@' . lc $recipient->host; + return (@{$self->{_default}}) + unless exists $map{$rcpt}; + + return @{$map{$rcpt}}; +} diff --git a/plugins/rcpt_ok b/plugins/rcpt_ok new file mode 100644 index 0000000..ba4ba45 --- /dev/null +++ b/plugins/rcpt_ok @@ -0,0 +1,99 @@ +#!perl -w + +=head1 NAME + +rcpt_ok + +=head1 SYNOPSIS + +this plugin checks the standard rcpthosts config + +=head1 DESCRIPTION + +Check the recipient hostname and determine if we accept mail to that host. + +This is functionally identical to qmail's rcpthosts implementation, consulting +both rcpthosts and morercpthosts.cdb. + +=head1 CONFIGURATION + +It should be configured to be run _LAST_! + +=cut + +use strict; +use warnings; + +use Qpsmtpd::Constants; +use Qpsmtpd::DSN; + +sub hook_rcpt { + my ($self, $transaction, $recipient, %param) = @_; + + # 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 $host = $self->get_rcpt_host( $recipient ) or return (OK); + + return (OK) if $self->is_in_rcpthosts( $host ); + return (OK) if $self->is_in_morercpthosts( $host ); + return (OK) if $self->qp->connection->relay_client; # failsafe + + # default of relaying_denied is obviously DENY, + # we use the default "Relaying denied" message... + return Qpsmtpd::DSN->relaying_denied(); +} + +sub is_in_rcpthosts { + my ( $self, $host ) = @_; + + my @rcpt_hosts = ($self->qp->config('me'), $self->qp->config('rcpthosts')); + + # Check if this recipient host is allowed + for my $allowed (@rcpt_hosts) { + $allowed =~ s/^\s*(\S+)/$1/; + if ( $host eq lc $allowed ) { + $self->log( LOGINFO, "pass: $host in rcpthosts" ); + return 1; + }; + + if ( substr($allowed,0,1) eq '.' and $host =~ m/\Q$allowed\E$/i ) { + $self->log( LOGINFO, "pass: $host in rcpthosts as $allowed" ); + return 1; + }; + } + + return; +}; + +sub is_in_morercpthosts { + my ( $self, $host ) = @_; + + my $more_rcpt_hosts = $self->qp->config('morercpthosts', 'map'); + + if ( exists $more_rcpt_hosts->{$host} ) { + $self->log( LOGINFO, "pass: $host found in morercpthosts" ); + return 1; + }; + + $self->log( LOGINFO, "fail: $host not in morercpthosts" ); + return; +}; + +sub get_rcpt_host { + my ( $self, $recipient ) = @_; + + return if ! $recipient; # Qpsmtpd::Address couldn't parse the recipient + + if ( $recipient->host ) { + return lc $recipient->host; + }; + + # no host portion exists + my $user = $recipient->user or return; + if ( lc $user eq 'postmaster' || lc $user eq 'abuse' ) { + return $self->qp->config('me'); + }; + return; +}; + diff --git a/plugins/rcpt_regexp b/plugins/rcpt_regexp new file mode 100644 index 0000000..40705b7 --- /dev/null +++ b/plugins/rcpt_regexp @@ -0,0 +1,98 @@ +#!perl -w +=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); +} diff --git a/plugins/relay b/plugins/relay new file mode 100644 index 0000000..c7890bc --- /dev/null +++ b/plugins/relay @@ -0,0 +1,237 @@ +#!perl -w + +=head1 SYNOPSIS + +relay - control whether relaying is permitted + +=head1 DESCRIPTION + +relay - check the following places to see if relaying is allowed: + +I<$ENV{RELAYCLIENT}> + +I, I, I + +The search order is as shown and cascades until a match is found or the list +is exhausted. + +Note that I is the first file checked. A match there will +override matches in the subsequent files. + +=head1 CONFIG + +Enable this plugin by adding it to config/plugins above the rcpt_* plugins + + # other plugins... + + relay + + # rcpt_* go here + +=head2 relayclients + +A list of IP addresses that are permitted to relay mail through this server. + +Each line in I is one of: + - a full IP address + + - partial IP address terminated by a dot or colon for matching whole networks + 192.168.42. + fdda:b13d:e431:ae06: + ... + + - a network/mask, aka a CIDR block + 10.1.0.0/24 + fdda:b13d:e431:ae06::/64 + ... + +=head2 morerelayclients + +Additional IP addresses that are permitted to relay. The syntax of the config +file is identical to I except that CIDR (net/mask) entries are +not supported. If you have many (>50) IPs allowed to relay, most should likely +be listed in I where lookups are faster. + + +=head2 norelayclients + +I allows specific clients, such as a mail gateway, to be denied +relaying, even though they would be allowed by I. This is most +useful when a block of IPs is allowed in relayclients, but several IPs need to +be excluded. + +The file format is the same as morerelayclients. + +=head2 RELAY ONLY + +The relay only option restricts connections to only clients that have relay +permission. All other connections are denied during the RCPT phase of the +SMTP conversation. + +This option is useful when 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 before other RCPT hooks! Only clients that +have authenticated or are listed in the relayclient file will be allowed to +send mail. + +To enable relay only mode, set the B option to any true value in +I as shown: + + relay only 1 + +=head1 AUTHOR + +2012 - Matt Simerson - Merged check_relay, check_norelay, and relayonly + +2006 - relay_only - John Peackock + +2005 - check_norelay - Copyright Gordon Rowell + +2002 - check_relay - Ask Bjorn Hansen + +=head1 LICENSE + +This software is free software and may be distributed under the same +terms as qpsmtpd itself. + +=cut + +use strict; +use warnings; + +use Qpsmtpd::Constants; +use Net::IP qw(:PROC); + +sub register { + my ($self, $qp) = shift, shift; + $self->log(LOGERROR, "Bad arguments") if @_ % 2; + $self->{_args} = { @_ }; + + if ( $self->{_args}{only} ) { + $self->register_hook('rcpt', 'relay_only'); + }; +}; + +sub is_in_norelayclients { + my $self = shift; + + my %no_relay_clients = map { $_ => 1 } $self->qp->config('norelayclients'); + + my $ip = $self->qp->connection->remote_ip; + + while ( $ip ) { + if ( exists $no_relay_clients{$ip} ) { + $self->log(LOGNOTICE, "$ip in norelayclients"); + return 1; + } + $ip =~ s/(\d|\w)+(:|\.)?$// or last; # strip off another octet + }; + + $self->log(LOGDEBUG, "no match in norelayclients"); + return; +}; + +sub populate_relayclients { + my $self = shift; + + foreach ( $self->qp->config('relayclients') ) { + my ($network, $netmask) = ip_splitprefix($_); + if ( $netmask ) { + push @{ $self->{_cidr_blocks} }, $_; + next; + } + $self->{_octets}{$_} = 1; # no prefix, split + } +}; + +sub is_in_cidr_block { + my $self = shift; + + my $ip = $self->qp->connection->remote_ip; + my $cversion = ip_get_version($ip); + for ( @{ $self->{_cidr_blocks} } ) { + my ($network, $mask) = ip_splitprefix($_); # split IP & CIDR range + my $rversion = ip_get_version($network); # get IP version (4 vs 6) + my ($begin, $end) = ip_normalize($_, $rversion); # get pool start/end + +# expand the client address (zero pad it) before converting to binary + my $bin_ip = ip_iptobin(ip_expand_address($ip, $cversion), $cversion); + + if ( ip_bincomp($bin_ip, 'gt', ip_iptobin($begin, $rversion)) + && ip_bincomp($bin_ip, 'lt', ip_iptobin($end, $rversion)) + ) { + $self->log(LOGINFO, "pass, cidr match ($ip)"); + return 1; + } + } + + $self->log(LOGDEBUG, "no cidr match"); + return; +}; + +sub is_octet_match { + my $self = shift; + + my $ip = $self->qp->connection->remote_ip; + $ip =~ s/::/:/; + + if ( $ip eq ':1' ) { + $self->log(LOGINFO, "pass, octet matched localhost ($ip)"); + return 1; + }; + + my $more_relay_clients = $self->qp->config('morerelayclients', 'map'); + + while ($ip) { + if ( exists $self->{_octets}{$ip} ) { + $self->log(LOGINFO, "pass, octet match in relayclients ($ip)"); + return 1; + }; + + if ( exists $more_relay_clients->{$ip} ) { + $self->log(LOGINFO, "pass, octet match in morerelayclients ($ip)"); + return 1; + }; + $ip =~ s/(\d|\w)+(:|\.)?$// or last; # strip off another 8 bits + } + + $self->log(LOGDEBUG, "no octet match" ); + return; +} + +sub hook_connect { + my ($self, $transaction) = @_; + + if ( $self->is_in_norelayclients() ) { + $self->qp->connection->relay_client(0); + delete $ENV{RELAYCLIENT}; + return (DECLINED); + } + + if ( $ENV{RELAYCLIENT} ) { + $self->qp->connection->relay_client(1); + $self->log(LOGINFO, "pass, enabled by env"); + return (DECLINED); + }; + + $self->populate_relayclients(); + + if ( $self->is_in_cidr_block() || $self->is_octet_match() ) { + $self->qp->connection->relay_client(1); + return (DECLINED); + }; + + $self->log(LOGINFO, "skip, no match"); + return (DECLINED); +} + +sub relay_only { + my $self = shift; + if ( $self->qp->connection->relay_client ) { + return (OK); + }; + return (DENY); +} + diff --git a/plugins/require_resolvable_fromhost b/plugins/require_resolvable_fromhost new file mode 100644 index 0000000..e3ff208 --- /dev/null +++ b/plugins/require_resolvable_fromhost @@ -0,0 +1,318 @@ +#!perl -w + +=head1 NAME + +resolvable_fromhost + +=head1 SYNOPSIS + +Determine if the from host resolves to a valid MX or host. + +=head1 DESCRIPTION + +The fromhost is the part of the email address after the @ symbol, provided by +the sending server during the SMTP conversation. This is usually, but not +always, the same as the hostname in the From: header. + +B tests to see if the fromhost resolves. It saves the +results in the transaction note I where other plugins can +use that information. Typical results are: + + a - fromhost resolved as an A record + mx - fromhost has valid MX record(s) + ip - fromhost was an IP + whitelist - skipped checks due to whitelisting + null - null sender + config - fromhost not resolvable, but I was set. + +Any other result is an error message with details of the failure. + +If B is enabled, the from hostname is also stored in +I, making it accessible when $sender is not. + +=head1 CONFIGURATION + +=head2 reject + +If I is set, the old require_resolvable_fromhost plugin behavior of +temporary rejection is the default. + + resolvable_fromhost reject [ 0 | 1 ] + +Default: 1 + +=head2 reject_type + + reject_type [ perm | temp ] + +Set I to reject mail instead of deferring it. + +Default: temp (temporary, aka soft, aka 4xx). + +=head1 EXAMPLE LOG ENTRIES + + 80072 (mail) resolvable_fromhost: googlegroups.com has valid MX at gmr-smtp-in.l.google.com + 80108 (mail) resolvable_fromhost: zerobarriers.net has valid MX at zerobarriers.net + 80148 (mail) resolvable_fromhost: uhin.com has valid MX at filter.itsafemail.com + 86627 (mail) resolvable_fromhost: no MX records for palmalar.com + 86627 (mail) resolvable_fromhost: fail: palmalar.com (SERVFAIL) + +=head1 AUTHORS + +2012 - Matt Simerson - refactored, added: POD, tests, reject, reject_type + +2002 - Ask Bjørn Hansen - intial plugin + +=cut + + +use strict; +use warnings; + +use Qpsmtpd::Constants; +use Qpsmtpd::DSN; +use Qpsmtpd::TcpServer; + +use Socket; +use Net::DNS qw(mx); +use Net::IP qw(:PROC); + +my %invalid = (); +my $has_ipv6 = Qpsmtpd::TcpServer::has_ipv6(); + +sub register { + my ($self, $qp, %args) = @_; + + foreach (keys %args) { + $self->{_args}->{$_} = $args{$_}; + } + if ( ! defined $self->{_args}{reject} ) { + $self->{_args}{reject} = 1; + }; + $self->{_args}{reject_type} ||= 'soft'; +} + +sub hook_mail { + my ($self, $transaction, $sender, %param) = @_; + + $self->populate_invalid_networks(); + + # check first, so results are noted for other plugins + my $resolved = $self->check_dns($sender->host, $transaction); + + return DECLINED if $resolved; # success, no need to continue + return DECLINED if $self->is_immune( $sender, $transaction ); + return DECLINED if ! $self->{_args}{reject}; + + return DECLINED if $sender->host; # reject later + + $self->log(LOGWARN, "FQDN required in envelope sender"); + return Qpsmtpd::DSN->addr_bad_from_system( $self->get_reject_type(), + "FQDN required in the envelope sender"); +} + +sub hook_rcpt { + my ($self, $transaction, $recipient, %args) = @_; + + my $result = $transaction->notes('resolvable_fromhost'); + return DECLINED if ! $self->{_args}{reject}; # no reject policy + return DECLINED if $result =~ /^(a|ip|mx)$/; # success + return DECLINED if $result =~ /^(whitelist|null|config)$/; # immunity + + $self->log(LOGINFO, $result ); # log error + return Qpsmtpd::DSN->temp_resolver_failed( $self->get_reject_type(), $result ); +} + +sub check_dns { + my ($self, $host, $transaction) = @_; + + # we can't even parse a hostname out of the address + if ( ! $host ) { + $transaction->notes('resolvable_fromhost', 'unparsable host'); + return; + }; + + $transaction->notes('resolvable_fromhost_host', $host); + + if ( $host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/ ) { + $self->log(LOGINFO, "skip: $host is an IP"); + $transaction->notes('resolvable_fromhost', 'ip'); + return 1; + }; + + my $res = new Net::DNS::Resolver(dnsrch => 0); + $res->tcp_timeout(30); + $res->udp_timeout(30); + + my $has_mx = $self->get_and_validate_mx( $res, $host, $transaction ); + return 1 if $has_mx == 1; # success! + return if $has_mx == -1; # has invalid MX records + + my @host_answers = $self->get_host_records( $res, $host, $transaction ); + foreach my $rr (@host_answers) { + if ( $rr->type eq 'A' || $rr->type eq 'AAAA' ) { + $self->log(LOGINFO, "pass: found valid A for $host"); + $transaction->notes('resolvable_fromhost', 'a'); + return $self->ip_is_valid($rr->address); + }; + if ( $rr->type eq 'MX' ) { + $self->log(LOGINFO, "pass: found valid MX for $host"); + $transaction->notes('resolvable_fromhost', 'mx'); + return $self->mx_address_resolves($rr->exchange, $host); + }; + } + return; +} + +sub ip_is_valid { + my ($self, $ip) = @_; + 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 if $net eq join('.', unpack("C4", inet_aton($ip) & $mask)); + } + return 1; +} + +sub get_and_validate_mx { + my ($self, $res, $host, $transaction ) = @_; + + my @mx = mx($res, $host); + if ( ! scalar @mx ) { # no mx records + $self->log(LOGINFO, "no MX records for $host"); + return 0; + }; + + foreach my $mx (@mx) { + # if any MX is valid, then we consider the domain resolvable + if ( $self->mx_address_resolves($mx->exchange, $host) ) { + $self->log(LOGINFO, "pass: $host has valid MX at " . $mx->exchange); + $transaction->notes('resolvable_fromhost', 'mx'); + return 1; + }; + } + + # if there are MX records, and we got here, none are valid + $self->log(LOGINFO, "fail: invalid MX for $host"); + $transaction->notes('resolvable_fromhost', "invalid MX for $host"); + return -1; +}; + +sub get_host_records { + my ($self, $res, $host, $transaction ) = @_; + + my @answers; + my $query = $res->search($host); + + if ($query) { + foreach my $rrA ($query->answer) { + push(@answers, $rrA); + } + } + + if ($has_ipv6) { + $query = $res->search($host, 'AAAA'); + if ($query) { + foreach my $rrAAAA ($query->answer) { + push(@answers, $rrAAAA); + } + } + } + + if ( ! scalar @answers) { + if ( $res->errorstring ne 'NXDOMAIN' ) { + $self->log(LOGWARN, "$$ query for $host failed: ", $res->errorstring); + }; + return; + }; + + return @answers; +}; + +sub mx_address_resolves { + my ($self, $name, $fromhost) = @_; + + # IP in MX + return $self->ip_is_valid($name) if ip_is_ipv4($name) || ip_is_ipv6($name); + + my $res = new Net::DNS::Resolver(dnsrch => 0); + 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) { + $self->log(LOGWARN, "query for $fromhost failed: ", $res->errorstring) + unless $res->errorstring eq "NXDOMAIN"; + return; + } + + foreach my $rr (@mx_answers) { + next if ( $rr->type ne 'A' && $rr->type ne 'AAAA' ); + return $self->ip_is_valid($rr->address); + } + + return; +} + +sub populate_invalid_networks { + my $self = shift; + + foreach my $i ($self->qp->config("invalid_resolvable_fromhost")) { + $i =~ s/^\s*//; # trim leading spaces + $i =~ s/\s*$//; # trim trailing spaces + if ($i =~ m#^((\d{1,3}\.){3}\d{1,3})/(\d\d?)#) { + $invalid{$1} = $3; + } + } +}; + +sub is_immune { + my ($self, $sender, $transaction) = @_; + + if ( $self->qp->connection->notes('whitelisthost') ) { + $transaction->notes('resolvable_fromhost', 'whitelist'); + $self->log(LOGINFO, "pass: whitelisted"); + return 1; + }; + + if ( $sender eq '<>' ) { + $transaction->notes('resolvable_fromhost', 'null'); + $self->log(LOGINFO, "pass: null sender"); + return 1; + }; + + if ( ! $self->{_args}{reject} ) { + $transaction->notes('resolvable_fromhost', 'config'); + $self->log(LOGINFO, "skip: reject not enabled in config."); + return; + }; + + return; +}; + +sub get_reject_type { + my $self = shift; + my $default = shift || DENYSOFT; + my $deny = $self->{_args}{reject_type} or return $default; + + return $deny =~ /^(temp|soft)$/i ? DENYSOFT + : $deny =~ /^(perm|hard)$/i ? DENY + : $deny eq 'disconnect' ? DENY_DISCONNECT + : $default; +}; diff --git a/plugins/rhsbl b/plugins/rhsbl new file mode 100644 index 0000000..5706f0c --- /dev/null +++ b/plugins/rhsbl @@ -0,0 +1,176 @@ +#!perl -w + +=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 + +use strict; +use warnings; + +use Qpsmtpd::Constants; + +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) = @_; + + return DECLINED if $self->is_immune(); + + if ($sender->format eq '<>') { + $self->log(LOGINFO, 'skip, null sender'); + return DECLINED; + }; + + my %rhsbl_zones = map { (split /\s+/, $_, 2)[0,1] } $self->qp->config('rhsbl_zones'); + + if ( ! %rhsbl_zones ) { + $self->log(LOGINFO, 'skip, no zones'); + return DECLINED; + }; + + 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: + + 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); + + return DECLINED; +} + +sub hook_rcpt { + my ($self, $transaction, $rcpt) = @_; + + my $result = $self->process_sockets or do { + $self->log(LOGINFO, "pass"); + return DECLINED; + }; + + + if ( defined($self->{_rhsbl_zones_map}{$result}) ) { + my $host = $transaction->sender->host; + if ($result =~ /^$host\./ ) { + return ($self->{_rhsbl}->{DENY}, "Mail from $host rejected because it " . $self->{_rhsbl_zones_map}{$result}); + } else { + my $hello = $self->qp->connection->hello_host; + return ($self->{_rhsbl}->{DENY}, "Mail from HELO $hello rejected because it " . $self->{_rhsbl_zones_map}{$result}); + } + } + return ($self->{_rhsbl}->{DENY}, $result); +} + +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; +} + diff --git a/plugins/sender_permitted_from b/plugins/sender_permitted_from new file mode 100644 index 0000000..553ea76 --- /dev/null +++ b/plugins/sender_permitted_from @@ -0,0 +1,236 @@ +#!perl -w + +=head1 NAME + +SPF - plugin to implement Sender Permitted From + +=head1 SYNOPSIS + +Prevents email sender address spoofing by checking the SPF policy of the purported senders domain. + +=head1 DESCRIPTION + +Sender Policy Framework (SPF) is an e-mail validation system designed to prevent spam by addressing source address spoofing. SPF allows administrators to specify which hosts are allowed to send e-mail from a given domain by creating a specific SPF record in the public DNS. Mail exchangers then use the DNS to check that mail from a given domain is being sent by a host sanctioned by that domain's administrators. -- http://en.wikipedia.org/wiki/Sender_Policy_Framework + +The results of a SPF query are stored in a transaction note named 'spfquery'; + +=head1 CONFIGURATION + +In config/plugins, add arguments to the sender_permitted_from line. + + sender_permitted_from reject 3 + +=head2 reject + +Set to a value between 1 and 6 to enable the following SPF behaviors: + + 1 annotate-only, add Received-SPF header, no rejections. + 2 defer on DNS failures. Assure there's always a meaningful SPF header. + 3 rejected if SPF record says 'fail' + 4 stricter reject. Also rejects 'softfail' + 5 reject 'neutral' + 6 reject if no SPF records, or a syntax error + +Most sites should start at level 3. It temporarily defers connections (4xx) that have soft SFP failures and only rejects (5xx) messages when the sending domains policy suggests it. + +SPF levels above 4 are for crusaders who don't mind rejecting some valid mail when the sending server administrator hasn't dotted his i's and crossed his t's. May the deities bless theirobsessive little hearts. + +=head1 SEE ALSO + + http://spf.pobox.com/ + http://en.wikipedia.org/wiki/Sender_Policy_Framework + +=head1 ACKNOWLDGEMENTS + +The reject options are modeled after, and aim to match the functionality of those found in the SPF patch for qmail-smtpd. + +=head1 AUTHOR + +Matt Simerson - 2002 - increased policy options from 3 to 6 + +Matt Simerson - 2011 - rewrote using Mail::SPF + +Matt Sergeant - 2003 - initial plugin + +=cut + +use strict; +use warnings; + +#use Mail::SPF 2.000; # eval'ed in ->register +use Qpsmtpd::Constants; + +sub register { + my ($self, $qp, %args) = @_; + eval 'use Mail::SPF'; + if ( $@ ) { + warn "skip: plugin disabled, could not find Mail::SPF\n"; + $self->log(LOGERROR, "skip: plugin disabled, is Mail::SPF installed?"); + return; + }; + $self->{_args} = { %args }; + if ( $self->{_args}{spf_deny} ) { + $self->{_args}{reject} = 3 if $self->{_args}{spf_deny} == 1; + $self->{_args}{reject} = 4 if $self->{_args}{spf_deny} == 2; + }; + if ( ! $self->{_args}{reject} && $self->qp->config('spfbehavior') ) { + $self->{_args}{reject} = $self->qp->config('spfbehavior'); + }; +} + +sub hook_mail { + my ($self, $transaction, $sender, %param) = @_; + + return (DECLINED) if $self->is_immune(); + + if ( ! $self->{_args}{reject} ) { + $self->log( LOGINFO, "skip: disabled in config" ); + return (DECLINED); + }; + + my $format = $sender->format; + if ( $format eq '<>' || ! $sender->host || ! $sender->user ) { + $self->log( LOGINFO, "skip: null sender" ); + return (DECLINED, "SPF - null sender"); + }; + + if ( $self->is_in_relayclients() ) { + return (DECLINED, "SPF - relaying permitted"); + }; + + my $client_ip = $self->qp->connection->remote_ip; + my $from = $sender->user . '@' . lc($sender->host); + my $helo = $self->qp->connection->hello_host; + my $scope = $from ? 'mfrom' : 'helo'; + my %req_params = ( versions => [1, 2], # optional + scope => $scope, + ip_address => $client_ip, + ); + + if ($scope =~ /^mfrom|pra$/) { + $req_params{identity} = $from; + $req_params{helo_identity} = $helo if $helo; + } + elsif ($scope eq 'helo') { + $req_params{identity} = $helo; + $req_params{helo_identity} = $helo; + } + + my $spf_server = Mail::SPF::Server->new(); + my $request = Mail::SPF::Request->new(%req_params); + my $result = $spf_server->process($request); + + $transaction->notes('spfquery', $result); + + $self->log( LOGINFO, $result ); + + return (DECLINED, "SPF - $result->code"); +} + +sub hook_rcpt { + my ($self, $transaction, $rcpt, %param) = @_; + + return DECLINED if $self->is_special_recipient( $rcpt ); + + my $result = $transaction->notes('spfquery') or return DECLINED; + my $code = $result->code; + my $why = $result->local_explanation; + my $reject = $self->{_args}{reject}; + + if ( ! $code ) { + return (DENYSOFT, "SPF - no response") if $reject >= 2; + return (DECLINED, "SPF - no response"); + }; + + return (DECLINED, "SPF - $code: $why") if ! $reject; + +# SPF result codes: pass fail softfail neutral none error permerror temperror + if ( $code eq 'pass' ) { } + elsif ( $code eq 'fail' ) { + return (DENY, "SPF - forgery: $why") if $reject >= 3; + return (DENYSOFT, "SPF - $code: $why") if $reject >= 2; + } + elsif ( $code eq 'softfail' ) { + return (DENY, "SPF - forgery: $why") if $reject >= 4; + return (DENYSOFT, "SPF - $code: $why") if $reject >= 3; + } + elsif ( $code eq 'neutral' ) { + return (DENY, "SPF - forgery: $why") if $reject >= 5; + } + elsif ( $code eq 'none' ) { + return (DENY, "SPF - forgery: $why") if $reject >= 6; + } + elsif ( $code eq 'error' ) { + return (DENY, "SPF - $code: $why") if $reject >= 6; + return (DENYSOFT, "SPF - $code: $why") if $reject >= 2; + } + elsif ( $code eq 'permerror' ) { + return (DENY, "SPF - $code: $why") if $reject >= 6; + return (DENYSOFT, "SPF - $code: $why") if $reject >= 3; + } + elsif ( $code eq 'temperror' ) { + return (DENYSOFT, "SPF - $code: $why") if $reject >= 2; + } + + $self->log(LOGDEBUG, "result for $rcpt->address was $code: $why"); + return (DECLINED, "SPF - $code: $why"); +} + +sub hook_data_post { + my ($self, $transaction) = @_; + + my $result = $transaction->notes('spfquery') or return DECLINED; + + $self->log(LOGDEBUG, "result was $result->code"); + + if ( ! $transaction->header ) { + $self->log(LOGERROR, "missing headers!"); + return DECLINED; + }; + + $transaction->header->add('Received-SPF' => $result->received_spf_header, 0); + + return DECLINED; +} + +sub is_in_relayclients { + my $self = shift; + + # If we are receiving from a relay permitted host, then we are probably + # not the delivery system, and so we shouldn't check + my $client_ip = $self->qp->connection->remote_ip; + my @relay_clients = $self->qp->config('relayclients'); + my $more_relay_clients = $self->qp->config('morerelayclients', 'map'); + my %relay_clients = map { $_ => 1 } @relay_clients; + + while ($client_ip) { + if ( exists $relay_clients{$client_ip} || + exists $more_relay_clients->{$client_ip} ) { + $self->log( LOGDEBUG, "skip: relaying permitted (config)" ); + return 1; + }; + $client_ip =~ s/\d+\.?$// or last; # strip off another 8 bits + } + return; +}; + +sub is_special_recipient { + my ($self, $rcpt) = @_; + + if ( ! $rcpt ) { + $self->log(LOGINFO, "skip: missing recipient"); + return 1; + }; + if ( ! $rcpt->user ) { + $self->log(LOGINFO, "skip: missing user"); + return 1; + }; + + # special addresses don't get SPF-tested. + if ( $rcpt->user =~ /^(?:postmaster|abuse|mailer-daemon|root)$/i ) { + $self->log(LOGINFO, "skip: special user (".$rcpt->user.")"); + return 1; + }; + + return; +}; diff --git a/plugins/spamassassin b/plugins/spamassassin new file mode 100644 index 0000000..1101f8e --- /dev/null +++ b/plugins/spamassassin @@ -0,0 +1,471 @@ +#!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. + +Stores the results in a note named spamassassin (for other plugins). The note +is a hashref with whatever fields are defined in your spamassassin config. +These are the common ones: score,required,autolearn,tests,version + +=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 7 leave_old_headers keep + +=over 4 + +=item reject [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. + +=item relayclient skip + +What special treatment is offered to connection with relay permission? Relay +permissions are granted when the connecting IP is listed in the relayclients +file and/or when the user has authenticated. The only valid option at present +is 'skip', which skips SA scoring. + +If SpamAssasin has certain network tests enabled, users may get elevated spam +scores because their dynamic IP space is properly listed on DUL blocking lists. +If the user is authenticated or coming from a trusted IP, odds are we don't +want to be reject their messages. Especially when running qpsmtpd on port 587. + +=back + +With both of the first options the configuration line will look like the following + + spamasssasin reject 18 munge_subject_threshold 8 + + +=head1 MULTIPLE RECIPIENT BEHAVIOR + +This plugin supports per-user SpamAssassin preferences. When per-user SA prefs +are enabled (by setting spamd_user = vpopmail), the message recipient is used +as the spamd username. If SpamAssassin has per-user preferences enabled, it +will consult the users spam preferences when scoring the message. + +When a message has multiple recipients, we do not change the spamd username. +The message is still scored by SA, but per-user preferences are not +consulted. To aid in debugging, messages with multiple recipents will +have an X-Spam-User header inserted. Admins and savvy users can look for +that header to confirm the reason their personal prefs were not consulted. + +To get per-user SA prefs to work for messages with multiple recipients, the +LDA should be configured to check for the presence of the X-Spam-User header. +If the X-Spam-User header is present, the LDA should submit the message to +spamd for re-processing with the recipients address. + + +=head1 TODO + +Make the "subject munge string" configurable + +=head1 CHANGES + +2012.04.02 - Matt Simerson + + * refactored for ease of maintenance + * added support for per-user SpamAssassin preferences + * updated get_spam_results so that score=N.N works (as well as hits=N.N) + * rewrote the X-Spam-* header additions so that SA generated headers are + not discarded. Admin can alter SA headers with add_header in their SA + config. Subverting their changes there is unexpected. Making them read + code to figure out why is an unnecessary hurdle. + * added assemble_message, so we can calc content size which spamd wants + +=cut + +use strict; +use warnings; + +use Qpsmtpd::Constants; +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 }; + + # backwards compatibility with previous config syntax + if ( ! defined $self->{_args}{reject} && defined $self->{_args}{reject_threshold} ) { + $self->{_args}{reject} = $self->{_args}{reject_threshold}; + }; + + $self->register_hook('data_post', 'check_spam_reject'); + $self->register_hook('data_post', 'check_spam_munge_subject'); +} + +sub hook_data_post { + my ($self, $transaction) = @_; + + return (DECLINED) if $self->is_immune(); + + if ( $transaction->data_size > 500_000 ) { + $self->log(LOGINFO, "skip: too large (".$transaction->data_size.")"); + return (DECLINED); + }; + + my $SPAMD = $self->connect_to_spamd() or return (DECLINED); + my $username = $self->select_spamd_username( $transaction ); + my $message = $self->assemble_message($transaction); + my $length = length $message; + + $self->print_to_spamd( $SPAMD, $message, $length, $username ); + shutdown($SPAMD, 1); # close our side of the socket (tell spamd we're done) + my $headers = $self->parse_spamd_response( $SPAMD ) or return (DECLINED); + + $self->insert_spam_headers( $transaction, $headers, $username ); + return (DECLINED); +}; + +sub select_spamd_username { + my ($self, $transaction) = @_; + + my $username = $self->{_args}{spamd_user} || getpwuid($>); + + my $recipient_count = scalar $transaction->recipients; + if ( $recipient_count > 1 ) { + $self->log(LOGDEBUG, "Message has $recipient_count recipients"); + return $username; + }; + + if ( $username eq 'vpopmail' ) { +# use the recipients email address as username. This enables per-user SA prefs + $username = ($transaction->recipients)[0]->address; + } + else { + $self->log(LOGDEBUG, "skipping per-user SA prefs"); + }; + + return $username; +}; + +sub parse_spamd_response { + my ( $self, $SPAMD ) = @_; + + my $line0 = <$SPAMD>; # get the first protocol line + if ( $line0 !~ /EX_OK/ ) { + $self->log(LOGERROR, "invalid response from spamd: $line0"); + return; + }; + + my (%new_headers, $last_header); + while (<$SPAMD>) { + s/[\r\n]//g; + if ( m/^(X-Spam-.*?): (.*)?/ ) { + $new_headers{$1} = $2 || ''; + $last_header = $1; + next; + } + if ( $last_header && m/^(\s+.*)/ ) { # a folded line, append to last + $new_headers{$last_header} .= CRLF . "\t" . $1; + next; + } + $last_header = undef; + } + close $SPAMD; + $self->log(LOGDEBUG, "finished reading from spamd"); + + return scalar keys %new_headers ? \%new_headers : undef; +}; + +sub insert_spam_headers { + my ( $self, $transaction, $new_headers, $username ) = @_; + + my $recipient_count = scalar $transaction->recipients; + + $self->_cleanup_spam_header($transaction, 'X-Spam-User'); # always clean up + if ( $recipient_count > 1 ) { # add for multiple recipients + $transaction->header->add('X-Spam-User', $username . ", $recipient_count recipients", 0); + }; + + foreach my $name ( keys %$new_headers ) { + next if $name eq 'X-Spam-Prev-Subject'; # might exist if SA rewrote subject + if ( $name eq 'X-Spam-Report' ) { + next; # Mail::Header mangles this prefolded header +# $self->log(LOGDEBUG, $new_headers->{$name} ); + }; + if ( $name eq 'X-Spam-Status' ) { + $self->parse_spam_header( $new_headers->{$name} ); + }; + $new_headers->{$name} =~ s/\015//; # hack for outlook + $self->_cleanup_spam_header($transaction, $name); + $transaction->header->add($name, $new_headers->{$name}, 0); + }; +} + +sub assemble_message { + my ($self, $transaction) = @_; + + $transaction->body_resetpos; + + my $message = "X-Envelope-From: " + . $transaction->sender->format . "\n" + . $transaction->header->as_string . "\n\n"; + + while (my $line = $transaction->body_getline) { $message .= $line; }; + + $message = join(CRLF, split/\n/, $message); + return $message . CRLF; +}; + +sub connect_to_spamd { + my $self = shift; + my $socket = $self->{_args}{spamd_socket}; + my $SPAMD; + if ( $socket && $socket =~ /\// ) { # file path + $SPAMD = $self->connect_to_spamd_socket( $socket ); + } + else { + $SPAMD = $self->connect_to_spamd_tcpip( $socket ); + }; + + return if ! $SPAMD; + $SPAMD->autoflush(1); + return $SPAMD; +}; + +sub connect_to_spamd_socket { + my ( $self, $socket ) = @_; + + if ( ! $socket || $socket !~ /^([\w\/.-]+)$/ ) { # Unix Domain Socket + $self->log(LOGERROR, "not a valid path"); + return; + }; + + socket(my $SPAMD, PF_UNIX, SOCK_STREAM, 0) or do { + $self->log(LOGERROR, "Could not open socket: $!"); + return; + }; + my $paddr = sockaddr_un( $socket ); + + connect($SPAMD, $paddr) or do { + $self->log(LOGERROR, "Could not connect to spamd socket: $!"); + return; + }; + + $self->log(LOGDEBUG, "connected to spamd"); + return $SPAMD; +}; + +sub connect_to_spamd_tcpip { + my ( $self, $socket ) = @_; + + my $remote = 'localhost'; + my $port = 783; + + if (defined $socket && $socket =~ /^([\w.-]+):(\d+)$/) { + $remote = $1; + $port = $2; + } + if ($port =~ /\D/) { $port = getservbyname($port, 'tcp') }; + if ( ! $port ) { + $self->log(LOGERROR, "No spamd port, check your spamd_socket config."); + return; + }; + my $iaddr = inet_aton($remote) or do { + $self->log(LOGERROR, "Could not resolve host: $remote"); + return; + }; + my $paddr = sockaddr_in($port, $iaddr); + my $proto = getprotobyname('tcp'); + + socket(my $SPAMD, PF_INET, SOCK_STREAM, $proto) or do { + $self->log(LOGERROR, "Could not open socket: $!"); + return; + }; + + connect($SPAMD, $paddr) or do { + $self->log(LOGERROR, "Could not connect to spamd: $!"); + return; + }; + + $self->log(LOGDEBUG, "connected to spamd"); + return $SPAMD; +}; + +sub print_to_spamd { + my ( $self, $SPAMD, $message, $length, $username ) = @_; + + print $SPAMD "HEADERS SPAMC/1.4" . CRLF; + print $SPAMD "Content-length: $length" . CRLF; + print $SPAMD "User: $username" . CRLF; + print $SPAMD CRLF; + print $SPAMD $message or $self->log(LOGWARN, "Could not print to spamd: $!"); + + $self->log(LOGDEBUG, "check_spam: finished sending to spamd"); +}; + +sub check_spam_reject { + my ($self, $transaction) = @_; + + my $sa_results = $self->get_spam_results($transaction) or do { + $self->log(LOGNOTICE, "skip: no spamassassin results"); + return DECLINED; + }; + my $score = $sa_results->{score} or do { + $self->log(LOGERROR, "skip: error getting spamassassin score"); + return DECLINED; + }; + + my $ham_or_spam = $sa_results->{is_spam} eq 'Yes' ? 'Spam' : 'Ham'; + + my $reject = $self->{_args}{reject} or do { + $self->log(LOGERROR, "skip: reject not set ($ham_or_spam, $score)"); + return DECLINED; + }; + + if ( $score < $reject ) { + $self->log(LOGINFO, "pass, $ham_or_spam, $score < $reject"); + return DECLINED; + }; + +# default of media_unsupported is DENY, so just change the message + $self->log(LOGINFO, "deny, $ham_or_spam, $score > $reject"); + return Qpsmtpd::DSN->media_unsupported("spam score exceeded threshold"); +} + +sub check_spam_munge_subject { + my ($self, $transaction) = @_; + + my $qp_num = $self->{_args}{munge_subject_threshold}; + my $sa = $self->get_spam_results($transaction) or return DECLINED; + + my $required = $sa->{required} || $qp_num or do { + $self->log(LOGDEBUG, "skipping munge, no user or qpsmtpd pref set"); + return DECLINED; + }; + return DECLINED unless $sa->{score} > $required; + + 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_results { + my ($self, $transaction) = @_; + + if ( defined $transaction->notes('spamassassin') ) { + return $transaction->notes('spamassassin'); + }; + + my $header = $transaction->header->get('X-Spam-Status') or return; + my $r = $self->parse_spam_header( $header ); + + $self->log(LOGDEBUG, "$r->{is_spam}, $r->{score}"); + $transaction->notes('spamassassin', $r); + + return $r; +} + +sub parse_spam_header { + my ($self, $string) = @_; + +# the X-Spam-Score header contents vary based on the settings in +# the spamassassin *.cf files. Rather than parse via regexp, split +# on the consistent whitespace and = delimiters. More reliable and +# likely faster. + my @parts = split(/\s+/, $string); + my $is_spam = shift @parts; + chomp @parts; + chop $is_spam; # remove trailing , + + my %r; + foreach ( @parts ) { + my ($key,$val) = split(/=/, $_); + $r{$key} = $val; + } + $r{is_spam} = $is_spam; + + # backwards compatibility for SA versions < 3 + if ( defined $r{hits} && ! defined $r{score} ) { + $r{score} = delete $r{hits}; + }; + return \%r; +}; + +sub _cleanup_spam_header { + my ($self, $transaction, $header_name) = @_; + + my $action = 'rename'; + if ( $self->{_args}->{leave_old_headers} ) { + $action = lc($self->{_args}->{leave_old_headers}); + }; + + return unless $action eq 'drop' || $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); + } +} diff --git a/plugins/tls b/plugins/tls new file mode 100644 index 0000000..df12f65 --- /dev/null +++ b/plugins/tls @@ -0,0 +1,327 @@ +#!perl -w + +=head1 NAME + +tls - plugin to support STARTTLS + +=head1 SYNOPSIS + +# in config/plugins + +tls [B] + +=over 4 + +=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 defined $local_port && $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} ) { + $self->{_stashed_qp}->clear_data(); + 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; + $self->connection->notes('tls_socket', $sock); + $self->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(); + } +} diff --git a/plugins/tls_cert b/plugins/tls_cert new file mode 100644 index 0000000..e4d52fa --- /dev/null +++ b/plugins/tls_cert @@ -0,0 +1,147 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +# 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 $template; +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); +} diff --git a/plugins/uribl b/plugins/uribl new file mode 100644 index 0000000..ab7498b --- /dev/null +++ b/plugins/uribl @@ -0,0 +1,514 @@ +#!perl -w + +=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 + +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) = @_; + + return (DECLINED) if $self->is_immune(); + + 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}); +} + diff --git a/plugins/virus/aveclient b/plugins/virus/aveclient new file mode 100644 index 0000000..f321f76 --- /dev/null +++ b/plugins/virus/aveclient @@ -0,0 +1,180 @@ +#!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); +} diff --git a/plugins/virus/bitdefender b/plugins/virus/bitdefender new file mode 100644 index 0000000..17609a2 --- /dev/null +++ b/plugins/virus/bitdefender @@ -0,0 +1,132 @@ +#!perl -w + +=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 strict; +use warnings; + +use File::Path; +use Qpsmtpd::Constants; + +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); +} + diff --git a/plugins/virus/clamav b/plugins/virus/clamav new file mode 100644 index 0000000..73d505c --- /dev/null +++ b/plugins/virus/clamav @@ -0,0 +1,231 @@ +#!perl -w + +=head1 NAME + +clamav -- ClamAV antivirus plugin for qpsmtpd + +=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; + +use Qpsmtpd::Constants; + +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); +} + diff --git a/plugins/virus/clamdscan b/plugins/virus/clamdscan new file mode 100644 index 0000000..906a21d --- /dev/null +++ b/plugins/virus/clamdscan @@ -0,0 +1,301 @@ +#!perl -w + +=head1 NAME + +clamdscan + +=head1 DESCRIPTION + +A qpsmtpd plugin for virus scanning using the ClamAV scan daemon, clamd. + +=head1 RESTRICTIONS + +The ClamAV scan daemon, clamd, must have at least 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 strict; +use warnings; + +#use ClamAV::Client; # eval'ed in $self->register +use Qpsmtpd::Constants; + +sub register { + my ( $self, $qp ) = shift, shift; + + $self->log(LOGERROR, "Bad parameters for the clamdscan plugin") if @_ % 2; + $self->{'_args'} = { @_ }; + + eval 'use ClamAV::Client'; + if ( $@ ) { + warn "unable to load ClamAV::Client\n"; + $self->log(LOGERROR, "unable to load ClamAV::Client"); + return; + }; + + # Set some sensible defaults + $self->{'_args'}{'deny_viruses'} ||= 'yes'; + $self->{'_args'}{'max_size'} ||= 128; + $self->{'_args'}{'scan_all'} ||= 0; + for my $setting ('deny_viruses', 'defer_on_error') { + next unless $self->{'_args'}{$setting}; + if ( lc $self->{'_args'}{$setting} eq 'no' ) { + $self->{'_args'}{$setting} = 0; + }; + } + + $self->register_hook('data_post', 'data_post_handler'); +} + +sub data_post_handler { + my ( $self, $transaction ) = @_; + + my $filename = $self->get_filename( $transaction ) or return DECLINED; + + return (DECLINED) if $self->is_immune( ); + return (DECLINED) if $self->is_too_big( $transaction ); + return (DECLINED) if $self->is_not_multipart( $transaction ); + + $self->set_permission( $filename ) or return DECLINED; + + my $clamd = $self->get_clamd() + or return $self->err_and_return( "Cannot instantiate ClamAV::Client" ); + + unless ( eval { $clamd->ping() } ) { + return $self->err_and_return( "Cannot ping clamd server: $@" ); + } + + my ($version) = split(/\//, $clamd->version); + $version ||= 'ClamAV'; + + my ( $path, $found ) = eval { $clamd->scan_path( $filename ) }; + if ($@) { + return $self->err_and_return( "Error scanning mail: $@" ); + }; + + if ( $found ) { + $self->log( LOGNOTICE, "fail, found virus $found" ); + + $self->connection->notes('naughty', 1); # see plugins/naughty + + if ( defined $self->connection->notes('karma') ) { + $self->connection->notes('karma', $self->connection->notes('karma') - 1); + }; + + if ( $self->{_args}{deny_viruses} ) { + return ( DENY, "Virus found: $found" ); + } + + $transaction->header->add( 'X-Virus-Found', 'Yes', 0 ); + $transaction->header->add( 'X-Virus-Details', $found, 0 ); + return (DECLINED); + } + + $self->log( LOGINFO, "pass, clean"); + $transaction->header->add( 'X-Virus-Found', 'No', 0 ); + $transaction->header->add( 'X-Virus-Checked', "by $version on " . $self->qp->config('me'), 0); + return (DECLINED); +} + +sub err_and_return { + my $self = shift; + my $message = shift; + if ( $message ) { + $self->log( LOGERROR, $message ); + }; + return (DENYSOFT, "Unable to scan for viruses") if $self->{_args}{defer_on_error}; + return (DECLINED, "skip"); +}; + +sub get_filename { + my $self = shift; + my $transaction = shift || $self->qp->transaction; + + my $filename = $transaction->body_filename; + + if ( ! $filename ) { + $self->log( LOGWARN, "Cannot process due to lack of filename" ); + return; + } + + if ( ! -f $filename ) { + $self->log( LOGERROR, "spool file missing! Attempting to respool" ); + $transaction->body_spool; + $filename = $transaction->body_filename; + if ( ! -f $filename ) { + $self->log( LOGERROR, "skip: failed spool to $filename! Giving up" ); + return; + }; + my $size = (stat($filename))[7]; + $self->log( LOGDEBUG, "Spooled $size bytes to $filename" ); + } + + return $filename; +}; + +sub set_permission { + my ($self, $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 $dir_mode = ( stat( $self->spool_dir() ) )[2]; + $self->log( LOGDEBUG, "spool dir mode: $dir_mode" ); + + if ( $dir_mode & 0010 || $dir_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 = ($dir_mode & 0044) | + ($dir_mode & 0010 ? 0040 : 0) | + ($dir_mode & 0001 ? 0004 : 0); + + unless ( chmod $fmode, $filename ) { + $self->log( LOGERROR, "chmod: $filename: $!" ); + return; + } + return 1; + } + $self->log( LOGWARN, "spool directory permissions do not permit scanner access" ); + return 1; +}; + +sub get_clamd { + my $self = shift; + + my $port = $self->{'_args'}{'clamd_port'}; + my $host = $self->{'_args'}{'clamd_host'} || 'localhost'; + + if ( $port && $port =~ /^(\d+)/ ) { + return new ClamAV::Client( socket_host => $host, socket_port => $1 ); + }; + + my $socket = $self->{'_args'}{'clamd_socket'}; + if ( $socket ) { + if ( $socket =~ /([\w\/.]+)/ ) { + return new ClamAV::Client( socket_name => $1 ); + } + $self->log( LOGERROR, "invalid characters in socket name" ); + } + + return new ClamAV::Client; +}; + +sub is_too_big { + my $self = shift; + my $transaction = shift || $self->qp->transaction; + + my $size = $transaction->data_size; + if ( $size > $self->{_args}{max_size} * 1024 ) { + $self->log( LOGINFO, "skip, too big ($size)" ); + return 1; + } + + $self->log( LOGDEBUG, "data_size, $size" ); + return; +}; + +sub is_not_multipart { + my $self = shift; + my $transaction = shift || $self->qp->transaction; + + return if $self->{'_args'}{'scan_all'}; + + # Ignore non-multipart emails + my $content_type = $transaction->header->get('Content-Type') or return 1; + $content_type =~ s/\s/ /g; + if ( $content_type !~ m!\bmultipart/.*\bboundary="?([^"]+)!i ) { + $self->log( LOGNOTICE, "skip, not multipart" ); + return 1; + } + + return; +}; diff --git a/plugins/virus/hbedv b/plugins/virus/hbedv new file mode 100644 index 0000000..60e01de --- /dev/null +++ b/plugins/virus/hbedv @@ -0,0 +1,158 @@ +#!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) +} diff --git a/plugins/virus/kavscanner b/plugins/virus/kavscanner new file mode 100644 index 0000000..92a1bd5 --- /dev/null +++ b/plugins/virus/kavscanner @@ -0,0 +1,176 @@ +#!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); +} + diff --git a/plugins/virus/klez_filter b/plugins/virus/klez_filter new file mode 100644 index 0000000..8a977fc --- /dev/null +++ b/plugins/virus/klez_filter @@ -0,0 +1,34 @@ +#!perl -w + +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); +} diff --git a/plugins/virus/sophie b/plugins/virus/sophie new file mode 100644 index 0000000..6fc0f52 --- /dev/null +++ b/plugins/virus/sophie @@ -0,0 +1,198 @@ +#!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 + diff --git a/plugins/virus/uvscan b/plugins/virus/uvscan new file mode 100644 index 0000000..8faa531 --- /dev/null +++ b/plugins/virus/uvscan @@ -0,0 +1,134 @@ +#!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); +} diff --git a/qpsmtpd b/qpsmtpd new file mode 100755 index 0000000..19fa862 --- /dev/null +++ b/qpsmtpd @@ -0,0 +1,38 @@ +#!/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; diff --git a/qpsmtpd-async b/qpsmtpd-async new file mode 100755 index 0000000..e2986e8 --- /dev/null +++ b/qpsmtpd-async @@ -0,0 +1,431 @@ +#!/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; +} diff --git a/qpsmtpd-forkserver b/qpsmtpd-forkserver new file mode 100755 index 0000000..c281a4f --- /dev/null +++ b/qpsmtpd-forkserver @@ -0,0 +1,370 @@ +#!/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; diff --git a/qpsmtpd-prefork b/qpsmtpd-prefork new file mode 100755 index 0000000..c176886 --- /dev/null +++ b/qpsmtpd-prefork @@ -0,0 +1,748 @@ +#!/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); + +# 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_instance('restart' => 1); # reload plugins... + $qpsmtpd->load_plugins; + kill 'HUP' => keys %children; + info("reload daemon requested"); + }; + + # setup qpsmtpd_instance + $qpsmtpd = 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 creating a new instance + $qpsmtpd = qpsmtpd_instance(); + + # 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; + } +} diff --git a/run b/run new file mode 100755 index 0000000..22c6029 --- /dev/null +++ b/run @@ -0,0 +1,38 @@ +#!/bin/sh +# +# You might want/need to to edit these settings +QPUSER=smtpd +# limit qpsmtpd to 150MB memory, should be several times what is needed. +MAXRAM=150000000 +BIN=/usr/local/bin +PERL=/usr/bin/perl + +# You should not need to edit these. +QMAILDUID=`id -u $QPUSER` +NOFILESGID=`id -g $QPUSER` +IP=`head -1 config/IP` +LANG=C + +# Remove the comments between the and tags to choose a +# deployment model. See also: http://wiki.qpsmtpd.org/deploy:start + +# +exec $BIN/softlimit -m $MAXRAM \ + $BIN/tcpserver -c 10 -v -R -p \ + -u $QMAILDUID -g $NOFILESGID $IP smtp \ + ./qpsmtpd 2>&1 +# + + +# +#exec 2>&1 \ +#sh -c " +# exec $BIN/softlimit -m $MAXRAM \ +# $PERL -T ./qpsmtpd-forkserver \ +# --listen-address $IP \ +# --port 25 \ +# --limit-connections 15 \ +# --max-from-ip 5 \ +# --user $QPUSER +#" +# diff --git a/t/01-syntax.t b/t/01-syntax.t new file mode 100644 index 0000000..c0ea682 --- /dev/null +++ b/t/01-syntax.t @@ -0,0 +1,41 @@ +use Config qw/ myconfig /; +use Data::Dumper; +use English qw/ -no_match_vars /; +use File::Find; +use Test::More; + +if ( ! $ENV{'QPSMTPD_DEVELOPER'} ) { + plan skip_all => "not a developer, skipping POD tests"; +}; + +use lib 'lib'; + +my $this_perl = $Config{'perlpath'} || $EXECUTABLE_NAME; + +my @files = find( {wanted=>\&test_syntax, no_chdir=>1}, 'plugins', 'lib', 't' ); + +sub test_syntax { + my $f = $File::Find::name; + chomp $f; + return if ! -f $f; + return if $f =~ m/(~|\.(bak|orig|rej))/; + my $r; + eval { $r = `$this_perl -Ilib -MQpsmtpd::Constants -c $f 2>&1`; }; + my $exit_code = sprintf ("%d", $CHILD_ERROR >> 8); + if ( $exit_code == 0 ) { + ok( $exit_code == 0, "syntax $f"); + return; + }; + if ( $r =~ /^Can't locate (.*?) in / ) { + ok( 0 == 0, "skipping $f, I couldn't load w/o $1"); + return; + } + if ( $r =~ /^Base class package "Danga::Socket" is empty/ ) { + ok( 0 == 0, "skipping $f, Danga::Socket not available."); + return; + } + print "ec: $exit_code, r: $r\n"; +}; + +done_testing(); + diff --git a/t/02-pod.t b/t/02-pod.t new file mode 100644 index 0000000..e989b93 --- /dev/null +++ b/t/02-pod.t @@ -0,0 +1,18 @@ +#!perl + +use Test::More; + +if ( ! $ENV{'QPSMTPD_DEVELOPER'} ) { + plan skip_all => "not a developer, skipping POD tests"; + exit; +} + +eval "use Test::Pod 1.14"; +if ( $@ ) { + plan skip_all => "Test::Pod 1.14 required for testing POD"; + exit; +}; + +my @poddirs = qw( lib plugins ); +all_pod_files_ok( all_pod_files( @poddirs ) ); +done_testing(); diff --git a/t/Test/Qpsmtpd.pm b/t/Test/Qpsmtpd.pm new file mode 100644 index 0000000..48041ee --- /dev/null +++ b/t/Test/Qpsmtpd.pm @@ -0,0 +1,118 @@ +package Test::Qpsmtpd; +use strict; +use lib 't'; +use lib 'lib'; +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 { + return './t/config' if $ENV{QPSMTPD_DEVELOPER}; + './config.sample'; +} + +sub plugin_dirs { + ('./plugins', './plugins/ident', './plugins/async'); +} + +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; + diff --git a/t/Test/Qpsmtpd/Plugin.pm b/t/Test/Qpsmtpd/Plugin.pm new file mode 100644 index 0000000..81969d1 --- /dev/null +++ b/t/Test/Qpsmtpd/Plugin.pm @@ -0,0 +1,94 @@ +package Test::Qpsmtpd::Plugin; +1; + +# Additional plugin methods used during testing +package Qpsmtpd::Plugin; + +use strict; +use warnings; + +use Qpsmtpd::Constants; +use Test::More; + +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(); + } +} + +sub validate_password { + my ( $self, %a ) = @_; + + my ($pkg, $file, $line) = caller(); + + my $src_clear = $a{src_clear}; + my $src_crypt = $a{src_crypt}; + my $attempt_clear = $a{attempt_clear}; + my $attempt_hash = $a{attempt_hash}; + my $method = $a{method} or die "missing method"; + my $ticket = $a{ticket}; + my $deny = $a{deny} || DENY; + + if ( ! $src_crypt && ! $src_clear ) { + $self->log(LOGINFO, "fail: missing password"); + return ( $deny, "$file - no such user" ); + }; + + if ( ! $src_clear && $method =~ /CRAM-MD5/i ) { + $self->log(LOGINFO, "skip: cram-md5 not supported w/o clear pass"); + return ( DECLINED, $file ); + } + + if ( defined $attempt_clear ) { + if ( $src_clear && $src_clear eq $attempt_clear ) { + $self->log(LOGINFO, "pass: clear match"); + return ( OK, $file ); + }; + + if ( $src_crypt && $src_crypt eq crypt( $attempt_clear, $src_crypt ) ) { + $self->log(LOGINFO, "pass: crypt match"); + return ( OK, $file ); + } + }; + + if ( defined $attempt_hash && $src_clear ) { + if ( ! $ticket ) { + $self->log(LOGERROR, "skip: missing ticket"); + return ( DECLINED, $file ); + }; + + if ( $attempt_hash eq hmac_md5_hex( $ticket, $src_clear ) ) { + $self->log(LOGINFO, "pass: hash match"); + return ( OK, $file ); + }; + }; + + $self->log(LOGINFO, "fail: wrong password"); + return ( $deny, "$file - wrong password" ); +}; + +1; diff --git a/t/addresses.t b/t/addresses.t new file mode 100644 index 0000000..5fbc375 --- /dev/null +++ b/t/addresses.t @@ -0,0 +1,41 @@ +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'); + + diff --git a/t/auth.t b/t/auth.t new file mode 100644 index 0000000..d6e23b4 --- /dev/null +++ b/t/auth.t @@ -0,0 +1,143 @@ +#!/usr/bin/perl -w +use strict; +use warnings; + +use lib 't'; +use lib 'lib'; + +use Data::Dumper; +use Digest::HMAC_MD5 qw(hmac_md5_hex); +use English qw/ -no_match_vars /; +use File::Path; + +use Qpsmtpd::Constants; +use Scalar::Util qw( openhandle ); +use Test::More qw(no_plan); + +use_ok('Test::Qpsmtpd'); +use_ok('Qpsmtpd::Auth'); + +my ($smtpd, $conn) = Test::Qpsmtpd->new_conn(); + +ok( $smtpd, "get new connection ($smtpd)"); +isa_ok( $conn, 'Qpsmtpd::Connection', "get new connection"); + +#warn Dumper($smtpd) and exit; +#my $hooks = $smtpd->hooks; +#warn Dumper($hooks) and exit; + +my $r; +my $user = 'good@example.com'; +my $pass = 'good_pass'; +my $enc_plain= Qpsmtpd::Auth::e64( join("\0", '', $user, $pass ) ); + +# get_auth_details_plain: plain auth method handles credentials properly +my ($loginas,$ruser,$passClear) = Qpsmtpd::Auth::get_auth_details_plain($smtpd, $enc_plain); +cmp_ok( $user, 'eq', $user, "get_auth_details_plain, user"); +cmp_ok( $passClear, 'eq', $pass, "get_auth_details_plain, password"); + +my $bad_auth = Qpsmtpd::Auth::e64( join("\0", 'loginas', 'user@foo', 'passer') ); +($loginas,$ruser,$passClear) = Qpsmtpd::Auth::get_auth_details_plain($smtpd, $bad_auth ); +ok( ! $loginas, "get_auth_details_plain, loginas -"); +ok( !$ruser, "get_auth_details_plain, user -"); +ok( !$passClear, "get_auth_details_plain, pass -"); + +# these plugins test against whicever loaded plugin provides their selected +# auth type. Right now, they end up testing against auth_flat_file. + +# PLAIN +$r = Qpsmtpd::Auth::SASL($smtpd, 'plain', $enc_plain); +cmp_ok( OK, '==', $r, "plain auth"); + +if ( $ENV{QPSMTPD_DEVELOPER} && is_interactive() ) { +# same thing, but must be entered interactively + print "answer: $enc_plain\n"; + $r = Qpsmtpd::Auth::SASL($smtpd, 'plain', ''); + cmp_ok( OK, '==', $r, "SASL, plain"); +}; + + +# LOGIN + +if ( $ENV{QPSMTPD_DEVELOPER} && is_interactive() ) { + + my $enc_user = Qpsmtpd::Auth::e64( $user ); + my $enc_pass = Qpsmtpd::Auth::e64( $pass ); + +# get_base64_response + print "answer: $enc_user\n"; + $r = Qpsmtpd::Auth::get_base64_response( $smtpd, 'Username' ); + cmp_ok( $r, 'eq', $user, "get_base64_response +"); + +# get_auth_details_login + print "answer: $enc_pass\n"; + ($ruser,$passClear) = Qpsmtpd::Auth::get_auth_details_login( $smtpd, $enc_user ); + cmp_ok( $ruser, 'eq', $user, "get_auth_details_login, user +"); + cmp_ok( $passClear, 'eq', $pass, "get_auth_details_login, pass +"); + + print "encoded pass: $enc_pass\n"; + $r = Qpsmtpd::Auth::SASL($smtpd, 'login', $enc_user); + cmp_ok( OK, '==', $r, "SASL, login"); +}; + + +# CRAM-MD5 + +if ( $ENV{QPSMTPD_DEVELOPER} && is_interactive() ) { + print "starting SASL\n"; + +# since we don't have bidirection communication here, we pre-generate a ticket + my $ticket = sprintf( '<%x.%x@%s>', rand(1000000), time(), $smtpd->config('me') ); + my $hash_pass = hmac_md5_hex( $ticket, $pass ); + my $enc_answer = Qpsmtpd::Auth::e64( join(' ', $user, $hash_pass ) ); + print "answer: $enc_answer\n"; + my (@r) = Qpsmtpd::Auth::get_auth_details_cram_md5( $smtpd, $ticket ); + cmp_ok( $r[0], 'eq', $ticket, "get_auth_details_cram_md5, ticket" ); + cmp_ok( $r[1], 'eq', $user, "get_auth_details_cram_md5, user" ); + cmp_ok( $r[2], 'eq', $hash_pass, "get_auth_details_cram_md5, passHash" ); +#warn Data::Dumper::Dumper(\@r); + +# this isn't going to work without bidirection communication to get the ticket + #$r = Qpsmtpd::Auth::SASL($smtpd, 'cram-md5' ); + #cmp_ok( OK, '==', $r, "login auth"); +}; + + +sub is_interactive { + +## no critic +# borrowed from IO::Interactive + my ($out_handle) = ( @_, select ); # Default to default output handle + +# Not interactive if output is not to terminal... + return if not -t $out_handle; + +# If *ARGV is opened, we're interactive if... + if ( openhandle * ARGV ) { + +# ...it's currently opened to the magic '-' file + return -t *STDIN if defined $ARGV && $ARGV eq '-'; + +# ...it's at end-of-file and the next file is the magic '-' file + return @ARGV > 0 && $ARGV[0] eq '-' && -t *STDIN if eof *ARGV; + +# ...it's directly attached to the terminal + return -t *ARGV; + }; + +# If *ARGV isn't opened, it will be interactive if *STDIN is attached +# to a terminal and either there are no files specified on the command line +# or if there are files and the first is the magic '-' file + return -t *STDIN && ( @ARGV == 0 || $ARGV[0] eq '-' ); +} + + +__END__ + +if ( ref $r ) { +} else { + warn $r; +} +#print Data::Dumper::Dumper($conn); +#print Data::Dumper::Dumper($smtpd); + diff --git a/t/config.t b/t/config.t new file mode 100644 index 0000000..8b6b11e --- /dev/null +++ b/t/config.t @@ -0,0 +1,34 @@ +#!/usr/bin/perl -w +use Test::More qw(no_plan); +use File::Path; +use strict; +use lib 't'; +use_ok('Test::Qpsmtpd'); + +my @mes; + +BEGIN { # need this to happen before anything else + my $cwd = `pwd`; + chomp($cwd); + @mes = qw{ ./config.sample/me ./t/config/me }; + foreach my $f ( @mes ) { + open my $me_config, '>', $f; + 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.0.', 'config("relayclients") are trimmed'); + +foreach my $f ( @mes ) { + unlink $f if -f $f; +}; + + diff --git a/t/config/badhelo b/t/config/badhelo new file mode 100644 index 0000000..a13ebfa --- /dev/null +++ b/t/config/badhelo @@ -0,0 +1,4 @@ +# these domains never uses their domain when greeting us, so reject transactions +aol.com +yahoo.com + diff --git a/t/config/badrcptto b/t/config/badrcptto new file mode 100644 index 0000000..a7f88ca --- /dev/null +++ b/t/config/badrcptto @@ -0,0 +1,9 @@ +######## entries used for testing ### +bad@example.com +@bad.example.com +######## Example patterns ####### +# Format is pattern\s+Response +# Don't forget to anchor the pattern if required +! Sorry, bang paths not accepted here +@.*@ Sorry, multiple at signs not accepted here +% Sorry, percent hack not accepted here diff --git a/t/config/dnsbl_zones b/t/config/dnsbl_zones new file mode 100644 index 0000000..1053328 --- /dev/null +++ b/t/config/dnsbl_zones @@ -0,0 +1 @@ +zen.spamhaus.org diff --git a/t/config/flat_auth_pw b/t/config/flat_auth_pw new file mode 100644 index 0000000..292d9f5 --- /dev/null +++ b/t/config/flat_auth_pw @@ -0,0 +1,2 @@ +good@example.com:good_pass +bad@example.com:bad_pass diff --git a/t/config/invalid_resolvable_fromhost b/t/config/invalid_resolvable_fromhost new file mode 100644 index 0000000..db90eb8 --- /dev/null +++ b/t/config/invalid_resolvable_fromhost @@ -0,0 +1,6 @@ +# include full network block including mask +127.0.0.0/8 +0.0.0.0/8 +224.0.0.0/4 +169.254.0.0/16 +10.0.0.0/8 diff --git a/t/config/plugins b/t/config/plugins new file mode 100644 index 0000000..5225ba0 --- /dev/null +++ b/t/config/plugins @@ -0,0 +1,94 @@ +# +# Example configuration file for plugins +# + +# enable this to get configuration via http; see perldoc +# plugins/http_config for details. +# http_config http://localhost/~smtpd/config/ http://www.example.com/smtp.pl?config= + +# hosts_allow does not work with the tcpserver deployment model! +# perldoc plugins/hosts_allow for an alternative. +# +# The hosts_allow module must be loaded if you want the -m / --max-from-ip / +# my $MAXCONNIP = 5; # max simultaneous connections from one IP +# settings... without this it will NOT refuse more than $MAXCONNIP connections +# from one IP! +hosts_allow + +# information plugins +ident/geoip +#ident/p0f /tmp/.p0f_socket version 3 +connection_time + +# enable to accept MAIL FROM:/RCPT TO: addresses without surrounding <> +dont_require_anglebrackets + +# enable to reject MAIL FROM:/RCPT TO: parameters if client helo was HELO +# (strict RFC 821)... this is not used in EHLO ... +parse_addr_withhelo + +quit_fortune +# tls should load before count_unrecognized_commands +#tls +check_earlytalker +count_unrecognized_commands 4 +relay + +require_resolvable_fromhost + +rhsbl +dnsbl +check_badmailfrom +check_badrcptto +check_spamhelo + +sender_permitted_from +greylisting p0f genre,windows + +auth/auth_checkpassword checkpw /usr/local/vpopmail/bin/vchkpw true /usr/bin/true +auth/auth_vpopmail +auth/auth_vpopmaild +auth/auth_vpopmail_sql +auth/auth_flat_file +auth/authdeny + +# this plugin needs to run after all other "rcpt" plugins +rcpt_ok + +check_basicheaders days 5 reject_type temp +domainkeys + +# content filters +virus/klez_filter + + +# You can run the spamassassin plugin with options. See perldoc +# plugins/spamassassin for details. +# +spamassassin + +# rejects mails with a SA score higher than 20 and munges the subject +# of the score is higher than 10. +# +# spamassassin reject_threshold 20 munge_subject_threshold 10 + +# dspam must run after spamassassin for the learn_from_sa feature to work +dspam learn_from_sa 7 reject 1 + +# run the clamav virus checking plugin +virus/clamav + +# You must enable a queue plugin - see the options in plugins/queue/ - for example: + +# queue to a maildir +# queue/maildir /home/spamtrap/mail + +# queue the mail with qmail-queue +queue/qmail-queue + + +# If you need to run the same plugin multiple times, you can do +# something like the following +# relay +# relay:0 somearg +# relay:1 someotherarg diff --git a/t/config/rcpthosts b/t/config/rcpthosts new file mode 100644 index 0000000..2fbb50c --- /dev/null +++ b/t/config/rcpthosts @@ -0,0 +1 @@ +localhost diff --git a/t/config/relayclients b/t/config/relayclients new file mode 100644 index 0000000..13c9be7 --- /dev/null +++ b/t/config/relayclients @@ -0,0 +1,5 @@ +# Format is IP, or IP part with trailing dot +# e.g. "127.0.0.1", or "192.168." +127.0.0.1 +# leading/trailing whitespace is ignored + 192.0. diff --git a/t/helo.t b/t/helo.t new file mode 100644 index 0000000..f45680e --- /dev/null +++ b/t/helo.t @@ -0,0 +1,12 @@ +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'); + diff --git a/t/misc.t b/t/misc.t new file mode 100644 index 0000000..96b80f8 --- /dev/null +++ b/t/misc.t @@ -0,0 +1,29 @@ +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'); + diff --git a/t/plugin_tests.t b/t/plugin_tests.t new file mode 100644 index 0000000..69344c1 --- /dev/null +++ b/t/plugin_tests.t @@ -0,0 +1,17 @@ +#!/usr/bin/perl -w +use strict; +use lib 't'; +use Test::Qpsmtpd; + +my $qp = Test::Qpsmtpd->new(); + +$qp->run_plugin_tests(); + +foreach my $file ( + "./t/config/greylist.dbm", + "./t/config/greylist.dbm.lock" + ) { + next if ! -f $file; + unlink $file; +}; + diff --git a/t/plugin_tests/auth/auth_checkpassword b/t/plugin_tests/auth/auth_checkpassword new file mode 100644 index 0000000..c51fa2d --- /dev/null +++ b/t/plugin_tests/auth/auth_checkpassword @@ -0,0 +1,44 @@ +#!perl -w + +warn "loaded auth_checkpassword\n"; + +sub register_tests { + my $self = shift; + + my ($vpopdir) = (getpwnam('vpopmail'))[7]; + + if ( ! $vpopdir ) { + warn "skipping tests, vpopmail not installed\n"; + return; + }; + + if ( ! -d "$vpopdir/domains/example.com" ) { + warn "skipping tests, no example users set up.\n"; + return; + }; + + $self->register_test("test_auth_checkpassword", 3); +} + +my @u_list = qw ( good bad none ); +my %u_data = ( + good => [ 'postmaster@example.com', OK, 'Good Strong Passphrase' ], + bad => [ 'bad@example.com', DENY, 'not_bad_pass' ], + none => [ 'none@example.com', DECLINED, '' ], + ); + +sub test_auth_checkpassword { + 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->auth_checkpassword($tran,'LOGIN',$a,$p); + defined $note or $note='No-Message'; + is ($ret, $r, $note); + + ($ret, $note) = $self->auth_checkpassword($tran,'PLAIN',$a,$p); + defined $note or $note='No-Message'; + is ($ret, $r, $note); + } +} diff --git a/t/plugin_tests/auth/auth_flat_file b/t/plugin_tests/auth/auth_flat_file new file mode 100644 index 0000000..35dc826 --- /dev/null +++ b/t/plugin_tests/auth/auth_flat_file @@ -0,0 +1,27 @@ +#!perl -w + +sub register_tests { + my $self = shift; + $self->register_test("test_auth_flat_file", 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_auth_flat_file { + 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->auth_flat_file($tran,'CRAMMD5',$a,$p); + defined $note or $note='authflat: No-Message'; + is ($ret, $r, $note); + # - for debugging. + # warn "$note\n"; + } +} diff --git a/t/plugin_tests/auth/auth_vpopmail b/t/plugin_tests/auth/auth_vpopmail new file mode 100644 index 0000000..5213890 --- /dev/null +++ b/t/plugin_tests/auth/auth_vpopmail @@ -0,0 +1,38 @@ +#!perl -w + +use strict; +use warnings; + +use Qpsmtpd::Constants; + +sub register_tests { + my $self = shift; + + $self->register_test("test_auth_vpopmail", 3); +} + +my @u_list = qw ( good bad none ); +my %u_data = ( + good => [ 'postmaster@example.com', OK, 'Good Strong Passphrase' ], + bad => [ 'bad@example.com', DENY, 'not_bad_pass' ], + none => [ 'none@example.com', DECLINED, '' ], + ); + +sub test_auth_vpopmail { + my $self = shift; + + if ( ! $self->test_vpopmail_module ) { + warn "vpopmail plugin not configured\n"; + foreach ( 0..2) { ok( 1, "skipped") }; + return; + }; + + 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->auth_vpopmail($tran,'CRAMMD5',$a,$p); + defined $note or $note='auth_vpopmail: No-Message'; + is ($ret, $r, $note); + } +} diff --git a/t/plugin_tests/auth/auth_vpopmail_sql b/t/plugin_tests/auth/auth_vpopmail_sql new file mode 100644 index 0000000..1af4871 --- /dev/null +++ b/t/plugin_tests/auth/auth_vpopmail_sql @@ -0,0 +1,48 @@ +#!perl -w + +use strict; +use warnings; + +sub register_tests { + my $self = shift; + + eval 'use DBI'; + if ( $@ ) { + warn "skipping auth_vpopmail_sql tests, is DBI installed?\n"; + return; + }; + $self->register_test("auth_vpopmail_sql", 3); +} + +sub auth_vpopmail_sql { + my $self = shift; + my ( $transaction, $method, $user, $passClear, $passHash, $ticket ) = @_; + + my $dbh = $self->get_db_handle() or do { + foreach ( 0..2 ) { + ok( 1, "skipped (no DB)" ); + }; + return; + }; + ok( $dbh, "auth_vpopmail_sql, got a dbh" ); + + my $vuser = $self->get_vpopmail_user( $dbh, 'postmaster@example.com' ); + if ( ! $vuser || ! $vuser->{pw_passwd} ) { + foreach ( 0..1 ) { + ok( 1, "no example.com domain" ); + }; + return; + }; + ok( ref $vuser, "found example.com domain" ); + + ok( $self->auth_vmysql( + $self->qp->transaction, + 'PLAIN', + 'postmaster@example.com', + $vuser->{pw_clear_passwd}, + $vuser->{pw_passwd}, + $ticket, + ), + "postmaster" + ); +} diff --git a/t/plugin_tests/auth/auth_vpopmaild b/t/plugin_tests/auth/auth_vpopmaild new file mode 100644 index 0000000..2916798 --- /dev/null +++ b/t/plugin_tests/auth/auth_vpopmaild @@ -0,0 +1,27 @@ +#!perl -w + +warn "loaded test auth_vpopmaild\n"; + +sub register_tests { + my $self = shift; + $self->register_test("test_auth_vpopmaild", 3); +} + +my @u_list = qw ( good bad none ); +my %u_data = ( + good => [ 'postmaster@example.com', OK, 'Good Strong Passphrase' ], + bad => [ 'bad@example.com', DENY, 'not_bad_pass' ], + none => [ 'none@example.com', DECLINED, '' ], + ); + +sub test_auth_vpopmaild { + 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->auth_vpopmaild($tran,'LOGIN',$a,$p); + defined $note or $note='No-Message'; + is ($ret, $r, $note); + } +} diff --git a/t/plugin_tests/auth/authdeny b/t/plugin_tests/auth/authdeny new file mode 100644 index 0000000..ca92405 --- /dev/null +++ b/t/plugin_tests/auth/authdeny @@ -0,0 +1,14 @@ +#!perl -w + +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"); +} diff --git a/t/plugin_tests/auth/authnull b/t/plugin_tests/auth/authnull new file mode 100644 index 0000000..8c64ad1 --- /dev/null +++ b/t/plugin_tests/auth/authnull @@ -0,0 +1,14 @@ +#!perl -w + +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"); +} diff --git a/t/plugin_tests/check_badmailfrom b/t/plugin_tests/check_badmailfrom new file mode 100644 index 0000000..a4a45b3 --- /dev/null +++ b/t/plugin_tests/check_badmailfrom @@ -0,0 +1,104 @@ +#!perl -w + +use strict; +use Data::Dumper; + +use Qpsmtpd::Address; + +sub register_tests { + my $self = shift; + + $self->register_test("test_badmailfrom_is_immune_sender", 5); + $self->register_test("test_badmailfrom_match", 7); + $self->register_test("test_badmailfrom_hook_mail", 4); + $self->register_test("test_badmailfrom_rcpt_handler", 2); +} + +sub test_badmailfrom_is_immune_sender { + my $self = shift; + + my $transaction = $self->qp->transaction; + my $test_email = 'matt@test.com'; + my $address = Qpsmtpd::Address->new( "<$test_email>" ); + $transaction->sender($address); + ok( $self->is_immune_sender( $transaction->sender, [] ), "empty list"); + + $address = Qpsmtpd::Address->new( '<>' ); + $transaction->sender($address); + ok( $self->is_immune_sender( $transaction->sender, ['bad@example.com'] ), "null sender"); + + $address = Qpsmtpd::Address->new( '' ); + $transaction->sender($address); + ok( $self->is_immune_sender( $transaction->sender, ['bad@example.com'] ), "missing host"); + + $address = Qpsmtpd::Address->new( '<@example.com>' ); + $transaction->sender($address); + ok( $self->is_immune_sender( $transaction->sender, ['bad@example.com'] ), "missing user"); + + $address = Qpsmtpd::Address->new( '' ); + $transaction->sender($address); + ok( ! $self->is_immune_sender( $transaction->sender, ['bad@example.com'] ), "false"); +}; + +sub test_badmailfrom_hook_mail { + my $self = shift; + + my $transaction = $self->qp->transaction; + + my $test_email = 'matt@test.com'; + my $address = Qpsmtpd::Address->new( "<$test_email>" ); + $transaction->sender($address); + + $self->{_badmailfrom_config} = ['matt@test.net','matt@test.com']; + $self->connection->notes('badmailfrom', ''); + my ($r) = $self->hook_mail( $transaction, $address ); + ok( $r == 909, "badmailfrom hook_mail"); + cmp_ok( $self->connection->notes('naughty'), 'eq', 'Your envelope sender is in my badmailfrom list', "default reason"); + + $self->{_badmailfrom_config} = ['matt@test.net','matt@test.com Yer a spammin bastert']; + $self->connection->notes('badmailfrom', ''); + ($r) = $self->hook_mail( $transaction, $address ); + ok( $r == 909, "badmailfrom hook_mail"); + cmp_ok( $self->connection->notes('naughty'), 'eq', 'Yer a spammin bastert', "custom reason"); +}; + +sub test_badmailfrom_rcpt_handler { + my $self = shift; + + my $transaction = $self->qp->transaction; + + $transaction->notes('badmailfrom', 'Yer a spammin bastart. Be gon wit yuh.' ); + + my ($code,$note) = $self->rcpt_handler( $transaction ); + + ok( $code == 901, 'badmailfrom hook hit'); + ok( $note, $note ); +} + +sub test_badmailfrom_match { + my $self = shift; + +# is_match receives ( $from, $bad, $host ) + + my $r = $self->is_match( 'matt@test.net', 'matt@test.net', 'test.net' ); + ok($r, "check_badmailfrom match"); + + ok( ! $self->is_match( 'matt@test.net', 'matt@test.com', 'tnpi.net' ), + "check_badmailfrom non-match"); + + ok( $self->is_match( 'matt@test.net', '@test.net', 'test.net' ), + "check_badmailfrom match host"); + + ok( ! $self->is_match( 'matt@test.net', '@test.not', 'test.net' ), + "check_badmailfrom non-match host"); + + ok( ! $self->is_match( 'matt@test.net', '@test.net', 'test.not' ), + "check_badmailfrom non-match host"); + + ok( $self->is_match( 'matt@test.net', 'test.net$', 'tnpi.net' ), + "check_badmailfrom pattern match"); + + ok( ! $self->is_match( 'matt@test.net', 'test.not$', 'tnpi.net' ), + "check_badmailfrom pattern non-match"); +}; + diff --git a/t/plugin_tests/check_badmailfromto b/t/plugin_tests/check_badmailfromto new file mode 100644 index 0000000..73d9bb9 --- /dev/null +++ b/t/plugin_tests/check_badmailfromto @@ -0,0 +1,36 @@ +#!perl -w + +use strict; +use Data::Dumper; + +use Qpsmtpd::Address; + +sub register_tests { + my $self = shift; + + $self->register_test("test_badmailfromto_is_sender_immune", 5); +} + +sub test_badmailfromto_is_sender_immune { + my $self = shift; + + my $transaction = $self->qp->transaction; + my $test_email = 'matt@test.com'; + $transaction->sender( Qpsmtpd::Address->new( "<$test_email>" ) ); + ok( $self->is_sender_immune( $transaction->sender, [] ), "is_immune, empty list"); + + $transaction->sender( Qpsmtpd::Address->new( '<>' ) ); + ok( $self->is_sender_immune( $transaction->sender, ['bad@example.com'] ), "is_immune, null sender"); + + my $address = Qpsmtpd::Address->new( '' ); + $transaction->sender($address); + ok( $self->is_sender_immune( $transaction->sender, ['bad@example.com'] ), "is_immune, missing host"); + + $address = Qpsmtpd::Address->new( '<@example.com>' ); + $transaction->sender($address); + ok( $self->is_sender_immune( $transaction->sender, ['bad@example.com'] ), "is_immune, missing user"); + + $transaction->sender( Qpsmtpd::Address->new( '' ) ); + ok( ! $self->is_sender_immune( $transaction->sender, ['bad@example.com'] ), "is_immune, false"); +}; + diff --git a/t/plugin_tests/check_badrcptto b/t/plugin_tests/check_badrcptto new file mode 100644 index 0000000..ac9057d --- /dev/null +++ b/t/plugin_tests/check_badrcptto @@ -0,0 +1,92 @@ +#!perl -w + +use strict; +use warnings; + +use Qpsmtpd::Constants; + +sub register_tests { + my $self = shift; + + $self->register_test("test_is_match", 10); + $self->register_test("test_hook_rcpt", 3); + $self->register_test("test_get_host_and_to", 8); +} + +sub test_is_match { + my $self = shift; + +# is_match receives ( $to, $bad, $host ) + + my $r = $self->is_match( 'matt@example.com', 'matt@example.com', 'example.com' ); + ok($r, "match"); + + ok( $self->is_match( 'matt@exAmple.com', 'matt@example.com', 'tnpi.com' ), + "case insensitive match"); + + ok( $self->is_match( 'mAtt@example.com', 'matt@example.com', 'tnpi.com' ), + "case insensitive match +"); + + ok( ! $self->is_match( 'matt@exmple.com', 'matt@example.com', 'tnpi.com' ), + "non-match"); + + ok( ! $self->is_match( 'matt@example.com', 'matt@exAple.com', 'tnpi.com' ), + "case insensitive non-match"); + + ok( $self->is_match( 'matt@example.com', '@example.com', 'example.com' ), + "match host"); + + ok( ! $self->is_match( 'matt@example.com', '@example.not', 'example.com' ), + "non-match host"); + + ok( ! $self->is_match( 'matt@example.com', '@example.com', 'example.not' ), + "non-match host"); + + ok( $self->is_match( 'matt@example.com', 'example.com$', 'tnpi.com' ), + "pattern match"); + + ok( ! $self->is_match( 'matt@example.com', 'example.not$', 'tnpi.com' ), + "pattern non-match"); +}; + +sub test_hook_rcpt { + my $self = shift; + + my $transaction = $self->qp->transaction; + my $recipient = Qpsmtpd::Address->new( '' ); + + my ($r, $mess) = $self->hook_rcpt( $transaction, $recipient ); + cmp_ok( DECLINED, '==', $r, "valid +"); + + $recipient = Qpsmtpd::Address->new( '' ); + ($r, $mess) = $self->hook_rcpt( $transaction, $recipient ); + cmp_ok( DENY, '==', $r, "bad match, +"); + + $recipient = Qpsmtpd::Address->new( '' ); + ($r, $mess) = $self->hook_rcpt( $transaction, $recipient ); + cmp_ok( DENY, '==', $r, "bad host match, +"); +}; + +sub test_get_host_and_to { + my $self = shift; + + my $recipient = Qpsmtpd::Address->new( '<>' ); + my ($host, $to) = $self->get_host_and_to( $recipient ); + ok( ! $host, "null recipient -"); + + $recipient = Qpsmtpd::Address->new( '' ); + ($host, $to) = $self->get_host_and_to( $recipient ); + ok( ! $host, "missing host -"); + ok( ! $to, "unparseable to -"); + + $recipient = Qpsmtpd::Address->new( '' ); + ($host, $to) = $self->get_host_and_to( $recipient ); + ok( $host, "valid host +"); + ok( $to, "valid to +"); + cmp_ok( $to, 'eq', 'user@example.com', "valid to +"); + + $recipient = Qpsmtpd::Address->new( '' ); + ($host, $to) = $self->get_host_and_to( $recipient ); + cmp_ok( $host, 'eq', 'example.com', "case normalized +"); + cmp_ok( $to, 'eq', 'user@example.com', "case normalized +"); +}; diff --git a/t/plugin_tests/check_basicheaders b/t/plugin_tests/check_basicheaders new file mode 100644 index 0000000..2ac5748 --- /dev/null +++ b/t/plugin_tests/check_basicheaders @@ -0,0 +1,112 @@ +#!perl -w + +use strict; +use Data::Dumper; +use POSIX qw(strftime); + +use Qpsmtpd::Address; +use Qpsmtpd::Constants; + +my $test_email = 'matt@example.com'; + +sub register_tests { + my $self = shift; + + $self->register_test("test_hook_data_post", 7); + $self->register_test('test_invalid_date_range', 7); +} + +sub setup_test_headers { + my $self = shift; + + my $transaction = $self->qp->transaction; + my $address = Qpsmtpd::Address->new( "<$test_email>" ); + my $header = Mail::Header->new(Modify => 0, MailFrom => "COERCE"); + my $now = strftime "%a %b %e %H:%M:%S %Y", localtime time; + + $transaction->sender($address); + $transaction->header($header); + $transaction->header->add('From', "<$test_email>"); + $transaction->header->add('Date', $now ); + $transaction->body_write( "test message body " ); +}; + +sub test_invalid_date_range { + my $self = shift; + + my $now = strftime "%a %b %e %H:%M:%S %Y", localtime time; + ok( ! $self->invalid_date_range($now), "valid +"); + + $self->{_args}{future} = 2; + + my $future_6 = strftime "%a %b %e %H:%M:%S %Y", localtime time + 518400; #6d + my $r = $self->invalid_date_range( $future_6 ); + ok( $r, "too new -" ); + + my $future_3 = strftime "%a %b %e %H:%M:%S %Y", localtime time + 259200; #3d + $r = $self->invalid_date_range( $future_3 ); + ok( $r, "too new -" ); + + my $future_1 = strftime "%a %b %e %H:%M:%S %Y", localtime time + 86400; #1d + $r = $self->invalid_date_range( $future_1 ); + ok( ! $r, "a little new, +" ); + + + $self->{_args}{past} = 2; + + my $past_6 = strftime "%a %b %e %H:%M:%S %Y", localtime time - 518400; #6d + $r = $self->invalid_date_range( $past_6 ); + ok( $r, "too old -" ); + + my $past_3 = strftime "%a %b %e %H:%M:%S %Y", localtime time - 259200; #3d + $r = $self->invalid_date_range( $past_3 ); + ok( $r, "too old -" ); + + my $past_1 = strftime "%a %b %e %H:%M:%S %Y", localtime time - 86400; #1d + $r = $self->invalid_date_range( $past_1 ); + ok( ! $r, "a little old +" ); +}; + +sub test_hook_data_post { + my $self = shift; + + my $reject = $self->{_args}{reject_type}; + my $deny = $reject =~ /^temp|soft$/i ? DENYSOFT : DENY; + + $self->setup_test_headers(); + my $transaction = $self->qp->transaction; + + my ($code, $mess) = $self->hook_data_post( $transaction ); + cmp_ok( DECLINED, '==', $code, "okay +" ); + + $transaction->header->delete('Date'); + ($code, $mess) = $self->hook_data_post( $transaction ); + cmp_ok( $deny, '==', $code, "missing date ( $mess )" ); + + my $now = strftime "%a %b %e %H:%M:%S %Y", localtime time; + $transaction->header->add('Date', $now ); + $transaction->header->delete('From'); + ($code, $mess) = $self->hook_data_post( $transaction ); + cmp_ok( $deny, '==', $code, "missing from ( $mess )" ); + $transaction->header->add('From', "<$test_email>"); + + $self->{_args}{future} = 5; + my $future = strftime "%a %b %e %H:%M:%S %Y", localtime time + 518400; #6d + $transaction->header->replace('Date', $future ); + ($code, $mess) = $self->hook_data_post( $transaction ); + cmp_ok( $deny, '==', $code, "too new ( $mess )" ); + + $self->{_args}{past} = 5; + my $past = strftime "%a %b %e %H:%M:%S %Y", localtime time - 518400; #6d + $transaction->header->replace('Date', $past ); + ($code, $mess) = $self->hook_data_post( $transaction ); + cmp_ok( $deny, '==', $code, "too old ( $mess )" ); + + $self->{_args}{reject_type} = 'temp'; + ($code, $mess) = $self->hook_data_post( $transaction ); + cmp_ok( DENYSOFT, '==', $code, "defer, not deny ( $mess )" ); + + $self->{_args}{reject_type} = 'perm'; + ($code, $mess) = $self->hook_data_post( $transaction ); + cmp_ok( DENY, '==', $code, "deny ( $mess )" ); +}; diff --git a/t/plugin_tests/check_earlytalker b/t/plugin_tests/check_earlytalker new file mode 100644 index 0000000..570aebd --- /dev/null +++ b/t/plugin_tests/check_earlytalker @@ -0,0 +1,147 @@ +#!perl -w + +use strict; +use warnings; + +use Qpsmtpd::Constants; + +sub register_tests { + my $self = shift; + + $self->register_test('test_reject_type', 3); + $self->register_test('test_log_and_pass', 1); + $self->register_test('test_log_and_deny', 3); + $self->register_test('test_data_handler', 3); + $self->register_test('test_connect_handler', 3); + $self->register_test('test_apr_data_handler', 3); + $self->register_test('test_apr_connect_handler', 3); + $self->register_test('test_mail_handler', 4); +} + +sub test_apr_connect_handler { + my $self = shift; + + $self->{_args}{'check-at'} = undef; + my ($code, $mess) = $self->apr_connect_handler(); + cmp_ok( $code, '==', DECLINED, "no check-at set"); + + $self->{_args}{'check-at'}{'DATA'} = 1; + $self->qp->connection->notes('whitelisthost', 1); + ($code, $mess) = $self->apr_connect_handler(); + cmp_ok( $code, '==', DECLINED, "whitelisted host"); + + $self->qp->connection->notes('whitelisthost', 0); + ($code, $mess) = $self->apr_connect_handler(); + cmp_ok( $code, '==', DECLINED, "not sure"); +}; + +sub test_apr_data_handler { + my $self = shift; + + $self->{_args}{'check-at'} = undef; + my ($code, $mess) = $self->apr_data_handler(); + cmp_ok( $code, '==', DECLINED, "no check-at set"); + + $self->{_args}{'check-at'}{'DATA'} = 1; + $self->qp->connection->notes('whitelisthost', 1); + ($code, $mess) = $self->apr_data_handler(); + cmp_ok( $code, '==', DECLINED, "whitelisted host"); + + $self->qp->connection->notes('whitelisthost', 0); + ($code, $mess) = $self->apr_data_handler(); + cmp_ok( $code, '==', DECLINED, "not sure"); +}; + +sub test_connect_handler { + my $self = shift; + + $self->{_args}{'check-at'} = undef; + my ($code, $mess) = $self->connect_handler(); + cmp_ok( $code, '==', DECLINED, "no check-at set"); + + $self->{_args}{'check-at'}{'CONNECT'} = 1; + $self->qp->connection->notes('whitelisthost', 1); + ($code, $mess) = $self->connect_handler(); + cmp_ok( $code, '==', DECLINED, "whitelisted host"); + + $self->qp->connection->notes('whitelisthost', 0); + ($code, $mess) = $self->connect_handler(); + cmp_ok( $code, '==', DECLINED, "not sure"); +}; + +sub test_data_handler { + my $self = shift; + + $self->{_args}{'check-at'} = undef; + my ($code, $mess) = $self->data_handler(); + cmp_ok( $code, '==', DECLINED, "no check-at set"); + + $self->{_args}{'check-at'}{'DATA'} = 1; + $self->qp->connection->notes('whitelisthost', 1); + ($code, $mess) = $self->data_handler(); + cmp_ok( $code, '==', DECLINED, "whitelisted host"); + + $self->qp->connection->notes('whitelisthost', 0); + ($code, $mess) = $self->data_handler(); + cmp_ok( $code, '==', DECLINED, "not sure"); +}; + +sub test_log_and_pass { + my $self = shift; + + my ($code, $mess) = $self->log_and_pass(); + cmp_ok( $code, '==', DECLINED, "default"); +}; + +sub test_log_and_deny { + my $self = shift; + + $self->{_args}{reject_type} = undef; + + my ($code, $mess) = $self->log_and_deny(); + cmp_ok( $code, '==', DENY, "default"); + + $self->{_args}{reject_type} = 'temp'; + ($code, $mess) = $self->log_and_deny(); + cmp_ok( $code, '==', DENYSOFT, "bad, temp"); + + $self->{_args}{reject_type} = 'disconnect'; + ($code, $mess) = $self->log_and_deny(); + cmp_ok( $code, '==', DENY_DISCONNECT, "bad, disconnect"); +}; + +sub test_mail_handler { + my $self = shift; + + $self->{_args}{reject_type} = undef; + $self->qp->connection->notes('earlytalker', 0); + + my ($code, $mess) = $self->mail_handler(); + cmp_ok( $code, '==', DECLINED, "good"); + + $self->qp->connection->notes('earlytalker', 1); + ($code, $mess) = $self->mail_handler(); + cmp_ok( $code, '==', DENY, "bad"); + + $self->{_args}{reject_type} = 'temp'; + ($code, $mess) = $self->mail_handler(); + cmp_ok( $code, '==', DENYSOFT, "bad, temp"); + + $self->{_args}{reject_type} = 'disconnect'; + ($code, $mess) = $self->mail_handler(); + cmp_ok( $code, '==', DENY_DISCONNECT, "bad, disconnect"); +}; + +sub test_reject_type { + my $self = shift; + + $self->{_args}{reject_type} = undef; + cmp_ok( $self->get_reject_type(), '==', DENY, "default"); + + $self->{_args}{reject_type} = 'temp'; + cmp_ok( $self->get_reject_type(), '==', DENYSOFT, "defer"); + + $self->{_args}{reject_type} = 'disconnect'; + cmp_ok( $self->get_reject_type(), '==', DENY_DISCONNECT, "disconnect"); +}; + diff --git a/t/plugin_tests/count_unrecognized_commands b/t/plugin_tests/count_unrecognized_commands new file mode 100644 index 0000000..e7026cb --- /dev/null +++ b/t/plugin_tests/count_unrecognized_commands @@ -0,0 +1,31 @@ +#!perl -w + +use strict; +use warnings; + +use Qpsmtpd::Constants; + +sub register_tests { + my $self = shift; + + $self->register_test('test_hook_unrecognized_command', 4); +}; + +sub test_hook_unrecognized_command { + my $self = shift; + + $self->{_unrec_cmd_max} = 2; + $self->connection->notes( 'unrec_cmd_count', 0 ); + + my ($code, $mess) = $self->hook_unrecognized_command(undef,'hiya'); + cmp_ok( $code, '==', DECLINED, "good" ); + + $self->connection->notes( 'unrec_cmd_count', 2 ); + ($code, $mess) = $self->hook_unrecognized_command(undef,'snookums'); + cmp_ok( $code, '==', DENY_DISCONNECT, "limit" ); + + ($code, $mess) = $self->hook_unrecognized_command(undef,'wtf'); + cmp_ok( $code, '==', DENY_DISCONNECT, "over limit" ); + + cmp_ok( $self->connection->notes( 'unrec_cmd_count'), '==', 4, "correct increment" ); +}; diff --git a/t/plugin_tests/dnsbl b/t/plugin_tests/dnsbl new file mode 100644 index 0000000..ca14b7c --- /dev/null +++ b/t/plugin_tests/dnsbl @@ -0,0 +1,90 @@ +#!perl -w + +use strict; +use warnings; + +use Qpsmtpd::Constants; + +sub register_tests { + my $self = shift; + + $self->register_test('test_hook_connect', 2); + $self->register_test('test_hook_rcpt', 2); + $self->register_test('test_ip_whitelisted', 3); + $self->register_test('test_is_set_rblsmtpd', 4); + $self->register_test('test_hook_disconnect', 1); + $self->register_test('test_reject_type', 3); +} + +sub test_ip_whitelisted { + my $self = shift; + + $self->qp->connection->remote_ip('192.168.99.5'); + ok( $self->ip_whitelisted(), "+"); + + $self->qp->connection->remote_ip('192.168.99.6'); + ok( ! $self->ip_whitelisted(), "-"); + + $self->qp->connection->remote_ip('192.168.99.5'); + $self->qp->connection->notes('whitelisthost', 'hello honey!'); + ok( $self->ip_whitelisted(), "+"); + $self->qp->connection->notes('whitelisthost', undef); +}; + +sub test_is_set_rblsmtpd { + my $self = shift; + + $self->qp->connection->remote_ip('10.1.1.1'); + ok( ! defined $self->is_set_rblsmtpd('10.1.1.1'), "undef"); + + $ENV{RBLSMTPD} = "Yes we can!"; + cmp_ok( 'Yes we can!','eq',$self->is_set_rblsmtpd('10.1.1.1'), "value"); + + $ENV{RBLSMTPD} = "Oh yeah?"; + cmp_ok( 'Oh yeah?','eq',$self->is_set_rblsmtpd('10.1.1.1'), "value"); + + $ENV{RBLSMTPD} = ''; + cmp_ok( 1,'==',$self->is_set_rblsmtpd('10.1.1.1'), "empty"); +}; + +sub test_hook_connect { + my $self = shift; + + my $conn = $self->qp->connection; + $conn->relay_client(0); # other tests may leave it enabled + $conn->remote_ip('127.0.0.2'); # standard dnsbl test value + + cmp_ok( DECLINED, '==', $self->hook_connect($self->qp->transaction), + "connect +"); + + ok($self->connection->notes('dnsbl_sockets'), "sockets +"); + ok($self->connection->notes('dnsbl_domains'), "domains +"); +} + +sub test_hook_rcpt { + 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 ($note)"); + #print("# dnsbl result: $note\n"); +} +sub test_hook_disconnect { + my $self = shift; + + cmp_ok( DECLINED, '==', $self->hook_connect($self->qp->transaction), + "hook_disconnect +"); +} + +sub test_reject_type { + my $self = shift; + + $self->{_args}{reject_type} = undef; + cmp_ok( $self->get_reject_type(), '==', DENY, "default"); + + $self->{_args}{reject_type} = 'temp'; + cmp_ok( $self->get_reject_type(), '==', DENYSOFT, "defer"); + + $self->{_args}{reject_type} = 'disconnect'; + cmp_ok( $self->get_reject_type(), '==', DENY_DISCONNECT, "disconnect"); +}; diff --git a/t/plugin_tests/dspam b/t/plugin_tests/dspam new file mode 100644 index 0000000..5f104f1 --- /dev/null +++ b/t/plugin_tests/dspam @@ -0,0 +1,127 @@ +#!perl -w + +use strict; +use warnings; + +use Mail::Header; +use Qpsmtpd::Constants; + +my $r; + +sub register_tests { + my $self = shift; + + $self->register_test('test_get_filter_cmd', 5); + $self->register_test('test_get_dspam_results', 6); + $self->register_test('test_log_and_return', 6); + $self->register_test('test_reject_type', 3); +} + +sub test_log_and_return { + my $self = shift; + + my $transaction = $self->qp->transaction; + + # reject not set + $transaction->notes('dspam', { class=> 'Spam', probability => .99, confidence=>1 } ); + ($r) = $self->log_and_return( $transaction ); + cmp_ok( $r, '==', DECLINED, "($r)"); + + # reject exceeded + $self->{_args}{reject} = .95; + $transaction->notes('dspam', { class=> 'Spam', probability => .99, confidence=>1 } ); + ($r) = $self->log_and_return( $transaction ); + cmp_ok( $r, '==', DENY, "($r)"); + + # below reject threshold + $transaction->notes('dspam', { class=> 'Spam', probability => .94, confidence=>1 } ); + ($r) = $self->log_and_return( $transaction ); + cmp_ok( $r, '==', DECLINED, "($r)"); + + # requires agreement + $self->{_args}{reject} = 'agree'; + $transaction->notes('spamassassin', { is_spam => 'Yes', score => 25 } ); + $transaction->notes('dspam', { class=> 'Spam', probability => .90, confidence=>1 } ); + ($r) = $self->log_and_return( $transaction ); + cmp_ok( $r, '==', DENY, "($r)"); + + # requires agreement + $transaction->notes('spamassassin', { is_spam => 'No', score => 15 } ); + $transaction->notes('dspam', { class=> 'Spam', probability => .96, confidence=>1 } ); + ($r) = $self->log_and_return( $transaction ); + cmp_ok( $r, '==', DECLINED, "($r)"); + + # requires agreement + $transaction->notes('spamassassin', { is_spam => 'Yes', score => 10 } ); + $transaction->notes('dspam', { class=> 'Innocent', probability => .96, confidence=>1 } ); + ($r) = $self->log_and_return( $transaction ); + cmp_ok( $r, '==', DECLINED, "($r)"); +}; + +sub test_get_dspam_results { + my $self = shift; + + my $transaction = $self->qp->transaction; + my $header = Mail::Header->new(Modify => 0, MailFrom => "COERCE"); + $transaction->header( $header ); + + my @dspam_sample_headers = ( + 'Innocent, probability=0.0000, confidence=0.69', + 'Innocent, probability=0.0000, confidence=0.85', + 'Innocent, probability=0.0023, confidence=1.00', + 'Spam, probability=1.0000, confidence=0.87', + 'Spam, probability=1.0000, confidence=0.99', + 'Whitelisted', + ); + + foreach my $header ( @dspam_sample_headers ) { + $transaction->header->delete('X-DSPAM-Result'); + $transaction->header->add('X-DSPAM-Result', $header); + my $r = $self->get_dspam_results($transaction); + ok( ref $r, "r: ($header)" ); + #warn Data::Dumper::Dumper($r); + }; +}; + +sub test_get_filter_cmd { + my $self = shift; + + my $transaction = $self->qp->transaction; + my $dspam = "/usr/local/bin/dspam"; + $self->{_args}{dspam_bin} = $dspam; + $self->{_args}{autolearn} = 'spamassassin'; + + foreach my $user ( qw/ smtpd matt@example.com / ) { + my $answer = "$dspam --user smtpd --mode=tum --process --deliver=summary --stdout"; + my $r = $self->get_filter_cmd($transaction, 'smtpd'); + cmp_ok( $r, 'eq', $answer, "$user" ); + }; + + $transaction->notes('spamassassin', { is_spam => 'No', autolearn => 'ham' } ); + my $r = $self->get_filter_cmd($transaction, 'smtpd'); + cmp_ok( $r, 'eq', "$dspam --user smtpd --mode=tum --source=corpus --class=innocent --deliver=summary --stdout", + "smtpd, ham" ); + + $transaction->notes('spamassassin', { is_spam => 'Yes', autolearn => 'spam', score => 110 } ); + $r = $self->get_filter_cmd($transaction, 'smtpd'); + cmp_ok( $r, 'eq', "$dspam --user smtpd --mode=tum --source=corpus --class=spam --deliver=summary --stdout", + "smtpd, spam" ); + + $transaction->notes('spamassassin', { is_spam => 'No', autolearn => 'spam' } ); + $r = $self->get_filter_cmd($transaction, 'smtpd'); + cmp_ok( $r, 'eq', "$dspam --user smtpd --mode=tum --process --deliver=summary --stdout", + "smtpd, spam" ); +}; + +sub test_reject_type { + my $self = shift; + + $self->{_args}{reject_type} = undef; + cmp_ok( $self->get_reject_type(), '==', DENY, "default"); + + $self->{_args}{reject_type} = 'temp'; + cmp_ok( $self->get_reject_type(), '==', DENYSOFT, "defer"); + + $self->{_args}{reject_type} = 'disconnect'; + cmp_ok( $self->get_reject_type(), '==', DENY_DISCONNECT, "disconnect"); +}; diff --git a/t/plugin_tests/greylisting b/t/plugin_tests/greylisting new file mode 100644 index 0000000..8168d70 --- /dev/null +++ b/t/plugin_tests/greylisting @@ -0,0 +1,167 @@ +#!perl -w + +use strict; +use warnings; + +use Qpsmtpd::Address; +use Qpsmtpd::Constants; + +my $test_email = 'user@example.com'; + +my @greydbs = qw( denysoft_greylist.dbm denysoft_greylist.dbm.lock ); +foreach ( @greydbs ) { + unlink $_ if -f $_; +}; + +sub register_tests { + my $self = shift; + + $self->register_test('test_hook_data', 4); + $self->register_test('test_get_db_key', 4); + $self->register_test('test_get_db_location', 1); + $self->register_test("test_greylist_geoip", 7); + $self->register_test("test_greylist_p0f_genre", 2); + $self->register_test("test_greylist_p0f_distance", 2); + $self->register_test("test_greylist_p0f_link", 2); + $self->register_test("test_greylist_p0f_uptime", 2); +} + +sub test_hook_data { + my $self = shift; + my $transaction = $self->qp->transaction; + + my ($code, $mess) = $self->hook_data( $transaction ); + cmp_ok( $code, '==', DECLINED, "no note" ); + + $transaction->notes('greylist', 1); + + ($code, $mess) = $self->hook_data( $transaction ); + cmp_ok( $code, '==', DECLINED, "no recipients"); + + my $address = Qpsmtpd::Address->new( "<$test_email>" ); + $transaction->recipients( $address ); + + $transaction->notes('whitelistrcpt', 2); + ($code, $mess) = $self->hook_data( $transaction ); + cmp_ok( $code, '==', DENYSOFT, "missing recipients"); + + $transaction->notes('whitelistrcpt', 1); + ($code, $mess) = $self->hook_data( $transaction ); + cmp_ok( $code, '==', DECLINED, "missing recipients"); +}; + +sub test_get_db_key { + my $self = shift; + + $self->{_args}{sender} = 0; + $self->{_args}{recipient} = 0; + $self->{_args}{remote_ip} = 0; + + my $test_ip = '192.168.1.1'; + + my $address = Qpsmtpd::Address->new( "<$test_email>" ); + $self->qp->transaction->sender( $address ); + $self->qp->transaction->add_recipient( $address ); + $self->qp->connection->remote_ip($test_ip); + + my $key = $self->get_db_key(); + ok( ! $key, "db key empty: -"); + + $self->{_args}{remote_ip} = 1; + $key = $self->get_db_key( $address, $address ); + cmp_ok( $key, 'eq', '3232235777', "db key: $key"); + + $self->{_args}{sender} = 1; + $key = $self->get_db_key( $address, $address ); + cmp_ok( $key, 'eq', "3232235777:$test_email", "db key: $key"); + + $self->{_args}{recipient} = 1; + $key = $self->get_db_key( $address, $address ); + cmp_ok( $key, 'eq', "3232235777:$test_email:$test_email", "db key: $key"); +}; + +sub test_get_db_location { + my $self = shift; + + my $db = $self->get_db_location(); + ok( $db, "db location: $db"); +}; + +sub test_greylist_geoip { + my $self = shift; + + $self->{_args}{'geoip'} = 'US,UK,HU'; + + my @valid = qw/ US us UK hu /; + my @invalid = qw/ PK RU ru /; + + foreach my $cc ( @valid ) { + $self->connection->notes('geoip_country', $cc ); + ok( $self->geoip_match(), "match + ($cc)"); + }; + + foreach my $cc ( @invalid ) { + $self->connection->notes('geoip_country', $cc ); + ok( ! $self->geoip_match(), "bad - ($cc)"); + }; +}; + +sub test_greylist_p0f_genre { + my $self = shift; + + $self->{_args}{'p0f'} = 'genre,Linux'; + $self->connection->notes('p0f'=> { genre => 'windows', link => 'dsl' } ); + ok( ! $self->p0f_match(), 'p0f genre miss'); + + $self->{_args}{'p0f'} = 'genre,Windows'; + $self->connection->notes('p0f'=> { genre => 'windows', link => 'dsl' } ); + ok( $self->p0f_match(), 'p0f genre hit'); +} + +sub test_greylist_p0f_distance { + my $self = shift; + + $self->{_args}{'p0f'} = 'distance,8'; + $self->connection->notes('p0f'=> { distance=>9 } ); + ok( $self->p0f_match(), 'p0f distance hit'); + + $self->{_args}{'p0f'} = 'distance,8'; + $self->connection->notes('p0f'=> { distance=>7 } ); + ok( ! $self->p0f_match(), 'p0f distance miss'); +} + +sub test_greylist_p0f_link { + my $self = shift; + + $self->{_args}{'p0f'} = 'link,dsl'; + $self->connection->notes('p0f'=> { link=>'DSL' } ); + ok( $self->p0f_match(), 'p0f link hit'); + + $self->{_args}{'p0f'} = 'link,dsl'; + $self->connection->notes('p0f'=> { link=>'Ethernet' } ); + ok( ! $self->p0f_match(), 'p0f link miss'); +} + +sub test_greylist_p0f_uptime { + my $self = shift; + + $self->{_args}{'p0f'} = 'uptime,100'; + $self->connection->notes('p0f'=> { uptime=> 99 } ); + ok( $self->p0f_match(), 'p0f uptime hit'); + + $self->{_args}{'p0f'} = 'uptime,100'; + $self->connection->notes('p0f'=> { uptime=>500 } ); + ok( ! $self->p0f_match(), 'p0f uptime miss'); +} + +sub _reset_transaction { + my $self = shift; + + $self->qp->connection->relay_client(0); + $self->qp->transaction->notes('whitelistsender',0); + $self->connection->notes('whitelisthost',0); + $self->qp->transaction->notes('tls_enabled',0); + $self->{_args}{p0f} = undef; + $self->{_args}{geoip} = undef; +}; + diff --git a/t/plugin_tests/helo b/t/plugin_tests/helo new file mode 100644 index 0000000..20fa763 --- /dev/null +++ b/t/plugin_tests/helo @@ -0,0 +1,179 @@ +#!perl -w + +use strict; +use warnings; + +use Qpsmtpd::Constants; + +sub register_tests { + my $self = shift; + + $self->register_test('test_init_resolver', 2); + $self->register_test('test_is_in_badhelo', 2); + $self->register_test('test_is_regex_match', 3); + $self->register_test('test_invalid_localhost', 4); + $self->register_test('test_is_plain_ip', 3); + $self->register_test('test_is_address_literal', 3); + $self->register_test('test_no_forward_dns', 2); + $self->register_test('test_no_reverse_dns', 2); + $self->register_test('test_no_matching_dns', 4); + $self->register_test('test_no_matching_dns', 4); + $self->register_test('test_helo_handler', 1); + $self->register_test('test_check_ip_match', 4); + $self->register_test('test_check_name_match', 4); +} + +sub test_helo_handler { + my $self = shift; + + cmp_ok( $self->helo_handler(undef, undef), '==', DECLINED, "empty host"); +}; + +sub test_init_resolver { + my $self = shift; + my $net_dns = $self->init_resolver(); + ok( $net_dns, "net::dns" ); + cmp_ok( ref $net_dns, 'eq', 'Net::DNS::Resolver', "ref ok"); +}; + +sub test_is_in_badhelo { + my $self = shift; + + my ($err, $why) = $self->is_in_badhelo('yahoo.com'); + ok( $err, "yahoo.com, $why"); + + ($err, $why) = $self->is_in_badhelo('example.com'); + ok( ! $err, "example.com"); +}; + +sub test_is_regex_match { + my $self = shift; + + my ($err, $why) = $self->is_regex_match('yahoo.com', 'ya.oo\.com$' ); + ok( $err, "yahoo.com, $why"); + + ($err, $why) = $self->is_regex_match('yoda.com', 'ya.oo\.com$' ); + ok( ! $err, "yahoo.com"); + + ($err, $why) = $self->is_regex_match('host-only', '!\.' ); + ok( $err, "negated pattern, $why"); +}; + +sub test_invalid_localhost { + my $self = shift; + + $self->qp->connection->remote_ip(undef); + my ($err, $why) = $self->invalid_localhost('localhost' ); + ok( $err, "localhost, undefined remote IP: $why"); + + $self->qp->connection->remote_ip(''); + ($err, $why) = $self->invalid_localhost('localhost' ); + ok( $err, "localhost, empty remote IP: $why"); + + $self->qp->connection->remote_ip('192.0.99.5'); + ($err, $why) = $self->invalid_localhost('localhost'); + ok( $err, "localhost, invalid remote IP: $why"); + + $self->qp->connection->remote_ip('127.0.0.1'); + ($err, $why) = $self->invalid_localhost('localhost'); + ok( ! $err, "localhost, correct remote IP"); +}; + +sub test_is_plain_ip { + my $self = shift; + + my ($err, $why) = $self->is_plain_ip('0.0.0.0'); + ok( $err, "plain IP, $why"); + + ($err, $why) = $self->is_plain_ip('255.255.255.255'); + ok( $err, "plain IP, $why"); + + ($err, $why) = $self->is_plain_ip('[255.255.255.255]'); + ok( ! $err, "address literal"); +}; + +sub test_is_address_literal { + my $self = shift; + + my ($err, $why) = $self->is_address_literal('[0.0.0.0]'); + ok( $err, "plain IP, $why"); + + ($err, $why) = $self->is_address_literal('[255.255.255.255]'); + ok( $err, "plain IP, $why"); + + ($err, $why) = $self->is_address_literal('255.255.255.255'); + ok( ! $err, "address literal"); +}; + +sub test_no_forward_dns { + my $self = shift; + + my ($err, $why) = $self->no_forward_dns('perl.org'); + ok( ! $err, "perl.org"); + + # reserved .test TLD: http://tools.ietf.org/html/rfc2606 + ($err, $why) = $self->no_forward_dns('perl.org.test'); + ok( $err, "test.perl.org.test"); +}; + +sub test_no_reverse_dns { + my $self = shift; + + my ($err, $why) = $self->no_reverse_dns('test-host', '192.0.2.0'); + ok( $err, "192.0.2.0, $why"); + + ($err, $why) = $self->no_reverse_dns('test-host', '192.0.2.1'); + ok( $err, "192.0.2.1, $why"); + + ($err, $why) = $self->no_reverse_dns('mail.theartfarm.com', '208.75.177.101'); + ok( ! $err, "208.75.177.101"); +}; + +sub test_no_matching_dns { + my $self = shift; + + $self->qp->connection->notes('helo_forward_match', undef); + $self->qp->connection->notes('helo_reverse_match', undef); + + my ($err, $why) = $self->no_matching_dns('matt.test'); + ok( $err, "fail, $why"); + + $self->qp->connection->notes('helo_forward_match', 1); + ($err, $why) = $self->no_matching_dns('matt.test'); + ok( ! $err, "pass"); +}; + +sub test_check_ip_match { + my $self = shift; + + $self->qp->connection->remote_ip('192.0.2.1'); + + $self->connection->notes('helo_forward_match', 0); + $self->check_ip_match('192.0.2.1'); + ok( $self->connection->notes('helo_forward_match'), "exact"; + + $self->connection->notes('helo_forward_match', 0); + $self->check_ip_match('192.0.2.2'); + ok( $self->connection->notes('helo_forward_match'), "network"; + + $self->connection->notes('helo_forward_match', 0); + $self->check_ip_match('192.0.1.1'); + ok( ! $self->connection->notes('helo_forward_match'), "miss"; +}; + +sub test_check_name_match { + my $self = shift; + + $self->connection->notes('helo_reverse_match', 0); + $self->check_name_match('mx0.example.com', 'mx0.example.com'); + ok( $self->connection->notes('helo_reverse_match'), "exact"); + + $self->connection->notes('helo_reverse_match', 0); + $self->check_name_match('mx0.example.com', 'mx1.example.com'); + ok( $self->connection->notes('helo_reverse_match'), "domain"); + + $self->connection->notes('helo_reverse_match', 0); + $self->check_name_match('mx0.example.com', 'mx0.example.net'); + ok( ! $self->connection->notes('helo_reverse_match'), "domain"); +}; + diff --git a/t/plugin_tests/ident/geoip b/t/plugin_tests/ident/geoip new file mode 100644 index 0000000..8bf2fae --- /dev/null +++ b/t/plugin_tests/ident/geoip @@ -0,0 +1,146 @@ +#!perl -w + +use strict; +use warnings; + +use Qpsmtpd::Constants; + +sub register_tests { + my $self = shift; + + eval 'use Geo::IP'; + if ( $@ ) { + warn "could not load Geo::IP\n"; + return; + }; + + $self->register_test('test_geoip_lookup', 2); + $self->register_test('test_geoip_load_db', 2); + $self->register_test('test_geoip_init_cc', 2); + $self->register_test('test_set_country_code', 3); + $self->register_test('test_set_country_name', 3); + $self->register_test('test_set_continent', 3); + $self->register_test('test_set_distance', 3); +}; + +sub test_geoip_lookup { + my $self = shift; + + $self->qp->connection->remote_ip('24.24.24.24'); + cmp_ok( $self->connect_handler(), '==', DECLINED, "exit code"); + + cmp_ok( $self->connection->notes('geoip_country'), 'eq', 'US', "note"); +}; + +sub test_geoip_load_db { + my $self = shift; + + $self->open_geoip_db(); + + if ( $self->{_geoip_city} ) { + ok( ref $self->{_geoip_city}, "loaded GeoIP city db" ); + } + else { + ok( "no GeoIP city db" ); + }; + + if ( $self->{_geoip} ) { + ok( ref $self->{_geoip}, "loaded GeoIP db" ); + } + else { + ok( "no GeoIP db" ); + }; +}; + +sub test_geoip_init_cc { + my $self = shift; + + $self->{_my_country_code} = undef; + ok( ! $self->{_my_country_code}, "undefined"); + + my $test_ip = '208.175.177.10'; + $self->{_args}{distance} = $test_ip; + $self->init_my_country_code( $test_ip ); + cmp_ok( $self->{_my_country_code}, 'eq', 'US', "country set and matches"); +}; + +sub test_set_country_code { + my $self = shift; + + $self->qp->connection->remote_ip(''); + my $cc = $self->set_country_code(); + ok( ! $cc, "undef"); + + $self->qp->connection->remote_ip('24.24.24.24'); + $cc = $self->set_country_code(); + cmp_ok( $cc, 'eq', 'US', "$cc"); + + my $note = $self->connection->notes('geoip_country'); + cmp_ok( $note, 'eq', 'US', "note has: $cc"); +}; + +sub test_set_country_name { + my $self = shift; + + $self->{_geoip_record} = undef; + $self->qp->connection->remote_ip(''); + $self->set_country_code(); + my $cn = $self->set_country_name(); + ok( ! $cn, "undef") or warn "$cn\n"; + + $self->qp->connection->remote_ip('24.24.24.24'); + $self->set_country_code(); + $cn = $self->set_country_name(); + cmp_ok( $cn, 'eq', 'United States', "$cn"); + + my $note = $self->connection->notes('geoip_country_name'); + cmp_ok( $note, 'eq', 'United States', "note has: $cn"); +}; + +sub test_set_continent { + my $self = shift; + + $self->{_geoip_record} = undef; + $self->qp->connection->remote_ip(''); + $self->set_country_code(); + my $cn = $self->set_continent(); + ok( ! $cn, "undef") or warn "$cn\n"; + + $self->qp->connection->remote_ip('24.24.24.24'); + $self->set_country_code(); + $cn = $self->set_continent() || ''; + my $note = $self->connection->notes('geoip_continent'); + if ( $cn ) { + cmp_ok( $cn, 'eq', 'NA', "$cn"); + cmp_ok( $note, 'eq', 'NA', "note has: $cn"); + } + else { + ok(1, "no continent data" ); + ok(1, "no continent data" ); + }; +}; + +sub test_set_distance { + my $self = shift; + + $self->{_geoip_record} = undef; + $self->qp->connection->remote_ip(''); + $self->set_country_code(); + my $cn = $self->set_distance_gc(); + ok( ! $cn, "undef") or warn "$cn\n"; + + $self->qp->connection->remote_ip('24.24.24.24'); + $self->set_country_code(); + $cn = $self->set_distance_gc(); + if ( $cn ) { + ok( $cn, "$cn km"); + + my $note = $self->connection->notes('geoip_distance'); + ok( $note, "note has: $cn"); + } + else { + ok( 1, "no distance data"); + ok( 1, "no distance data"); + } +}; + diff --git a/t/plugin_tests/ident/p0f b/t/plugin_tests/ident/p0f new file mode 100644 index 0000000..cf743c9 --- /dev/null +++ b/t/plugin_tests/ident/p0f @@ -0,0 +1,87 @@ +#!perl -w + +use strict; +use warnings; + +use Qpsmtpd::Constants; + +sub register_tests { + my $self = shift; + + $self->register_test('test_get_v2_query', 1); + $self->register_test('test_get_v3_query', 1); + $self->register_test('test_store_v2_results', 2); + $self->register_test('test_store_v3_results', 2); +} + +sub test_query_p0f_v2 { +#TODO +# get path to p0f socket +# see if it exists +# try to connect to it +# if connection succeeds, send it a query +# do we a) pick an IP that recently connected? +# or b) create a connection to localhost... +# or c) is there a p0f test value? +# parse and validate the response +# using $self->test_v2_response() +}; + +sub test_query_p0f_v3 { +#TODO: similar to v2 .... +}; + +sub test_get_v2_query { + my $self = shift; + + my $local_ip = '208.75.177.101'; + my $remote = '108.60.149.81'; + $self->{_args}{local_ip} = $local_ip; + $self->qp->connection->local_ip($local_ip); + $self->qp->connection->remote_ip($remote); + $self->qp->connection->local_port(25); + $self->qp->connection->remote_port(2500); + + my $r = $self->get_v2_query(); + ok( $r, 'get_v2_query' ); + #use Data::Dumper; warn Data::Dumper::Dumper( $r ); +}; + +sub test_get_v3_query { + my $self = shift; + + my $remote = '108.60.149.81'; + $self->qp->connection->remote_ip($remote); + + my $r = $self->get_v3_query(); + ok( $r, 'get_v3_query' ); + #use Data::Dumper; warn Data::Dumper::Dumper( $r ); +}; + +sub test_store_v2_results { + my $self = shift; + + my $response = pack("L L C Z20 Z40 c Z30 Z30 C C C s S N", + '233811181', '1336687857', '0', 'Windows', 'XP/2000 (RFC1323+, w+, tstamp-)', + '11', 'ethernet/modem', '', '0', '0', '1', '-25600', '255', '255' ); + + my $r = $self->store_v2_results( $response ); + + ok( $r, "query_p0f_v2 result") or return; + ok( $r->{genre} =~ /windows/i, "store_v2_results, genre" ); + #use Data::Dumper; warn Data::Dumper::Dumper( $r ); +}; + +sub test_store_v3_results { + my $self = shift; + + my $response = pack("L L L L L L L L L s C C A32 A32 A32 A32 A32 A32 A32", + 1345340930, 16, 1336676595, 1336680290, 3, 0, 0, 0, 0, 13, 0, 0, + 'Windows', '7 or 8', '', '', 'Ethernet or modem', '', ''); + my $r = $self->store_v3_results( $response ); + + ok( $r, "query_p0f_v3 result"); + ok( $r->{genre} =~ /windows/i, "store_v3_results, genre" ); +}; + + diff --git a/t/plugin_tests/rcpt_ok b/t/plugin_tests/rcpt_ok new file mode 100644 index 0000000..a7fad27 --- /dev/null +++ b/t/plugin_tests/rcpt_ok @@ -0,0 +1,104 @@ +#!perl -w + +use strict; +use warnings; + +use Qpsmtpd::Constants; + +sub register_tests { + my $self = shift; + + $self->register_test('test_get_rcpt_host', 7); + $self->register_test('test_is_in_rcpthosts', 3); + $self->register_test('test_is_in_morercpthosts', 2); + $self->register_test('test_hook_rcpt', 3); +} + + +sub test_hook_rcpt { + my $self = shift; + + my $transaction = $self->qp->transaction; + + my $address = Qpsmtpd::Address->parse(''); + my ($r, $mess) = $self->hook_rcpt( $transaction, $address ); + cmp_ok( $r, '==', OK, "hook_rcpt, localhost"); + + $address = Qpsmtpd::Address->parse(''); + ($r, $mess) = $self->hook_rcpt( $transaction, $address ); + cmp_ok( $r, '==', DENY, "hook_rcpt, example.com"); + + $self->qp->connection->relay_client(1); + ($r, $mess) = $self->hook_rcpt( $transaction, $address ); + cmp_ok( $r, '==', OK, "hook_rcpt, example.com"); + $self->qp->connection->relay_client(0); +}; + +sub test_is_in_rcpthosts { + my $self = shift; + + my @hosts = $self->qp->config('rcpthosts'); + my $host = $hosts[0]; + + if ( $host ) { + ok( $self->is_in_rcpthosts( $host ), "is_in_rcpthosts, $host"); + } + else { + ok(1, "is_in_rcpthosts (skip, no entries)" ); + }; + + ok( $self->is_in_rcpthosts( 'localhost' ), "is_in_rcpthosts +"); + ok( ! $self->is_in_rcpthosts( 'example.com' ), "is_in_rcpthosts -"); +}; + +sub test_is_in_morercpthosts { + my $self = shift; + + my $ref = $self->qp->config('morercpthosts', 'map'); + my ($domain) = keys %$ref; + if ( $domain ) { + ok( $self->is_in_morercpthosts( $domain ), "is_in_morercpthosts, $domain"); + } + else { + ok(1, "is_in_morercpthosts (skip, no entries)" ); + }; + + ok( ! $self->is_in_morercpthosts( 'example.com' ), "is_in_morercpthosts -"); +}; + +sub test_get_rcpt_host { + my $self = shift; + + my $address = Qpsmtpd::Address->parse(''); + cmp_ok( $self->get_rcpt_host( $address ), 'eq', 'example.com', + "get_rcpt_host, +" ); + + $address = Qpsmtpd::Address->parse(''); + cmp_ok( $self->get_rcpt_host( $address ), 'eq', 'example.com', + "get_rcpt_host, +" ); + + $address = Qpsmtpd::Address->parse(''); + cmp_ok( $self->get_rcpt_host( $address ), 'eq', 'example.com', + "get_rcpt_host, +" ); + + $address = Qpsmtpd::Address->parse(''); + my $local_hostname = $self->get_rcpt_host( $address ); + if ( $local_hostname eq 'some.host.example.org' ) { + cmp_ok( $self->get_rcpt_host( $address ), 'eq', 'some.host.example.org', + "get_rcpt_host, special postmaster +" ); + } + else { + ok( 1, "get_rcpt_host, special postmaster + ($local_hostname)" ); + } + + # I think this is a bug. Qpsmtpd::Address fails to parse + $address = Qpsmtpd::Address->parse(''); + ok( ! $self->get_rcpt_host( $address ), "get_rcpt_host, missing host" ); + + $address = Qpsmtpd::Address->parse('<>'); + ok( ! $self->get_rcpt_host( $address ), "get_rcpt_host, null recipient" ); + + $address = Qpsmtpd::Address->parse('<@example.com>'); + ok( ! $self->get_rcpt_host( $address ), "get_rcpt_host, missing user" ); +}; + diff --git a/t/plugin_tests/relay b/t/plugin_tests/relay new file mode 100644 index 0000000..988c184 --- /dev/null +++ b/t/plugin_tests/relay @@ -0,0 +1,81 @@ +#!perl -w + +use strict; +use warnings; + +use Qpsmtpd::Constants; + +sub register_tests { + my $self = shift; + + $self->register_test('test_relay_only', 2); + $self->register_test('test_is_octet_match', 3); + $self->register_test('test_is_in_cidr_block', 4); + $self->register_test('test_is_in_norelayclients', 5); +} + +sub test_relay_only { + my $self = shift; + + $self->qp->connection->relay_client(0); + my $r = $self->relay_only(); + cmp_ok( $r, '==', DENY, "relay_only -"); + + $self->qp->connection->relay_client(1); + $r = $self->relay_only(); + cmp_ok( $r, '==', OK, "relay_only +"); + + $self->qp->connection->relay_client(0); +}; + +sub test_is_octet_match { + my $self = shift; + + $self->populate_relayclients(); + + $self->qp->connection->remote_ip('192.0.1.1'); + ok( $self->is_octet_match(), "match, +"); + + $self->qp->connection->remote_ip('192.51.1.1'); + ok( ! $self->is_octet_match(), "nope, -"); + + $self->qp->connection->remote_ip('203.0.113.0'); + ok( ! $self->is_octet_match(), "nope, -"); +}; + +sub test_is_in_cidr_block { + my $self = shift; + + $self->qp->connection->remote_ip('192.0.1.1'); + $self->{_cidr_blocks} = [ '192.0.1.0/24' ]; + ok( $self->is_in_cidr_block(), "match, +" ); + + $self->{_cidr_blocks} = [ '192.0.0.0/24' ]; + ok( ! $self->is_in_cidr_block(), "nope, -" ); + + + $self->qp->connection->remote_ip('fdda:b13d:e431:ae06:00a1::'); + $self->{_cidr_blocks} = [ 'fdda:b13d:e431:ae06::/64' ]; + ok( $self->is_in_cidr_block(), "match, +" ); + + $self->{_cidr_blocks} = [ 'fdda:b13d:e431:be17::' ]; + ok( ! $self->is_in_cidr_block(), "nope, -" ); +}; + +sub test_is_in_norelayclients { + my $self = shift; + + my @matches = qw/ 192.0.99.5 192.0.98.1 192.0.98.255 /; + my @false = qw/ 192.0.99.7 192.0.109.7 /; + + foreach ( @matches ) { + $self->qp->connection->remote_ip($_); + ok( $self->is_in_norelayclients(), "match, + ($_)"); + }; + + foreach ( @false ) { + $self->qp->connection->remote_ip($_); + ok( ! $self->is_in_norelayclients(), "match, + ($_)"); + }; +}; + diff --git a/t/plugin_tests/require_resolvable_fromhost b/t/plugin_tests/require_resolvable_fromhost new file mode 100644 index 0000000..865e993 --- /dev/null +++ b/t/plugin_tests/require_resolvable_fromhost @@ -0,0 +1,165 @@ +#!perl -w + +use strict; +use warnings; + +use Data::Dumper; +use Net::DNS; +use Qpsmtpd::Address; +use Qpsmtpd::Constants; + +my $res = new Net::DNS::Resolver(dnsrch => 0); +my $test_email = 'user@example.com'; + +sub register_tests { + my $self = shift; + + my %args = ( ); + $self->register( $self->qp, reject => 0 ); + + $self->register_test('test_is_immune', 3); + $self->register_test('test_populate_invalid_networks', 2); + $self->register_test('test_mx_address_resolves', 2); + $self->register_test('test_get_host_records', 2); + $self->register_test('test_get_and_validate_mx', 2); + $self->register_test('test_check_dns', 2); + $self->register_test('test_hook_rcpt', 10); + $self->register_test('test_hook_mail', 4); +} + +sub test_hook_mail { + my $self = shift; + + my $transaction = $self->qp->transaction; + my $address = Qpsmtpd::Address->new('remote@example.com'); + $transaction->sender($address); + + my $sender = $transaction->sender; + $sender->host('perl.com'); + + ok( $self->hook_mail( $transaction, $sender ) ); + ok( $self->hook_mail( $transaction, $sender ) ); + + $sender->host(''); + $self->{_args}{reject} = 1; + $self->{_args}{reject_type} = 'soft'; + my ($r) = $self->hook_mail( $transaction, $sender ); + ok( $r == DENYSOFT, "($r)"); + + $self->{_args}{reject_type} = 'hard'; + ($r) = $self->hook_mail( $transaction, $sender ); + ok( $r == DENY, "($r)"); +}; + +sub test_hook_rcpt { + my $self = shift; + + my $transaction = $self->qp->transaction; + my $recipient = 'foo@example.com'; + + $transaction->notes('resolvable_fromhost', 'a'); + ok( DECLINED == $self->hook_rcpt( $transaction, $recipient ) ); + + $transaction->notes('resolvable_fromhost', 'mx'); + ok( DECLINED == $self->hook_rcpt( $transaction, $recipient ) ); + + $transaction->notes('resolvable_fromhost', 'ip'); + ok( DECLINED == $self->hook_rcpt( $transaction, $recipient ) ); + + $transaction->notes('resolvable_fromhost', 'whitelist'); + ok( DECLINED == $self->hook_rcpt( $transaction, $recipient ) ); + + $transaction->notes('resolvable_fromhost', 'null'); + ok( DECLINED == $self->hook_rcpt( $transaction, $recipient ) ); + + $transaction->notes('resolvable_fromhost', 'config'); + ok( DECLINED == $self->hook_rcpt( $transaction, $recipient ) ); + + $transaction->notes('resolvable_fromhost', 'oops!'); + ok( DECLINED == $self->hook_rcpt( $transaction, $recipient ) ); + + $transaction->notes('resolvable_fromhost', 'oops!'); + ok( DECLINED == $self->hook_rcpt( $transaction, $recipient ) ); + + $transaction->notes('resolvable_fromhost', 'oops!'); + $self->{_args}{reject} = 1; + $self->{_args}{reject_type} = 'soft'; + my ($r) = $self->hook_rcpt( $transaction, $recipient ); + ok( DENYSOFT == $r, "($r)"); + + $transaction->notes('resolvable_fromhost', 'failed again'); + $self->{_args}{reject_type} = 'hard'; + ($r) = $self->hook_rcpt( $transaction, $recipient ); + ok( DENY == $r, "($r)"); +}; + +sub test_check_dns { + my $self = shift; + + my $transaction = $self->qp->transaction; + ok( ! $self->check_dns( '', $transaction ) ); + ok( $self->check_dns( 'perl.com', $transaction ) ); +} + +sub test_get_and_validate_mx { + my $self = shift; + my $transaction = $self->qp->transaction; + + ok( scalar $self->get_and_validate_mx( $res, 'perl.com', $transaction ) ); + + ok( ! scalar $self->get_host_records( $res, 'fake-domain-name-for-test.com', $transaction ) ); +}; + +sub test_get_host_records { + my $self = shift; + my $transaction = $self->qp->transaction; + + ok( scalar $self->get_host_records( $res, 'perl.com', $transaction ) ); + ok( ! scalar $self->get_host_records( $res, 'fake-domain-name-for-test.com', $transaction ) ); +}; + +sub test_mx_address_resolves { + my $self = shift; + + my $fromhost = 'perl.com'; + + ok( $self->mx_address_resolves('mail.perl.com', $fromhost) ); + ok( ! $self->mx_address_resolves('no-such-mx.perl.com', $fromhost) ); +}; + +sub test_populate_invalid_networks { + my $self = shift; + + my $ip = '10.9.8.7'; + ok( $self->ip_is_valid($ip) ); + + $self->qp->config('invalid_resolvable_fromhost', $ip); + $self->populate_invalid_networks(); + ok( ! $self->ip_is_valid($ip) ); + + # clean up afterwards + $self->qp->config('invalid_resolvable_fromhost', undef ); + $self->{invalid} = (); +}; + +sub test_is_immune { + my $self = shift; + + my $transaction = $self->qp->transaction; + + # null sender should be immune + $transaction->sender('<>'); + ok( $self->is_immune( $transaction->sender, $transaction ) ); + + # whitelisted host should be immune + my $connection = $self->qp->connection->notes('whitelisthost', 1); + ok( $self->is_immune( $transaction->sender, $transaction ) ); + $self->qp->connection->notes('whitelisthost', undef); + + # reject is not defined, so email should not be immune + my $address = Qpsmtpd::Address->new( "<$test_email>" ); + $transaction->sender($address); + ok( ! $self->is_immune( $transaction->sender, $transaction ) ); +}; + + diff --git a/t/plugin_tests/sender_permitted_from b/t/plugin_tests/sender_permitted_from new file mode 100644 index 0000000..a69f5b0 --- /dev/null +++ b/t/plugin_tests/sender_permitted_from @@ -0,0 +1,50 @@ +#!perl -w + +use strict; +use warnings; + +use Qpsmtpd::Constants; + +my $r; + +sub register_tests { + my $self = shift; + + eval 'use Mail::SPF'; + return if $@; + + $self->register_test('test_is_relayclient', 3); + $self->register_test('test_is_special_recipient', 5); +} + +sub test_is_relayclient { + my $self = shift; + + my $transaction = $self->qp->transaction; + ok( ! $self->is_relayclient( $transaction ), + "sender_permitted_from, is_relayclient -"); + + $self->qp->connection->relay_client(1); + ok( $self->is_relayclient( $transaction ), + "sender_permitted_from, is_relayclient +"); + + $self->qp->connection->relay_client(0); + $self->qp->connection->remote_ip('192.168.7.5'); + my $client_ip = $self->qp->connection->remote_ip; + ok( $client_ip, "sender_permitted_from, relayclients ($client_ip)"); +}; + +sub test_is_special_recipient { + my $self = shift; + + my $transaction = $self->qp->transaction; + my $address = Qpsmtpd::Address->new('user@example.com'); + + ok( ! $self->is_special_recipient( $address ), "is_special_recipient -"); + + foreach my $user ( qw/ postmaster abuse mailer-daemon root / ) { + $address = Qpsmtpd::Address->new("$user\@example.com"); + ok( $self->is_special_recipient( $address ), "is_special_recipient ($user)"); + }; +}; + diff --git a/t/plugin_tests/spamassassin b/t/plugin_tests/spamassassin new file mode 100644 index 0000000..67018b4 --- /dev/null +++ b/t/plugin_tests/spamassassin @@ -0,0 +1,202 @@ +#!perl -w + +use strict; +use warnings; + +use Mail::Header; +use Qpsmtpd::Address; +use Qpsmtpd::Constants; + +my @sample_headers = ( + 'No, score=-5.4 required=4.0 autolearn=ham', + 'No, score=-8.2 required=4.0 autolearn=ham', + 'No, score=-102.3 required=4.0 autolearn=disabled', + 'No, score=-0.1 required=5.0 tests=AWL,BAYES_00,FREEMAIL_FROM,HTML_MESSAGE,RCVD_IN_DNSWL_NONE,RDNS_NONE autolearn=no version=3.3.2', + 'No, score=4.4 required=5.0 autolearn=no', + 'Yes, score=14.3 required=5.0 autolearn=no', + 'Yes, score=18.3 required=5.0 autolearn=spam', + 'Yes, score=26.6 required=4.0 autolearn=unavailable', + 'No, score=-1.7 required=4.0 autolearn=unavailable version=3.3.2', + 'No, hits=-1.0 required=4.0 autolearn=unavailable version=3.3.2', +); + +sub register_tests { + my $self = shift; + + $self->register_test('test_connect_to_spamd', 4); + $self->register_test('test_parse_spam_header', 10); + $self->register_test('test_get_spam_results', 19); + $self->register_test('test_check_spam_munge_subject', 4); + $self->register_test('test_check_spam_reject', 2); +} + +sub test_connect_to_spamd { + my $self = shift; + + my $transaction = $self->qp->transaction; + $transaction->add_recipient( Qpsmtpd::Address->new( '' ) ); + my $username = $self->select_spamd_username( $transaction ); + my $message = $self->test_message(); + my $length = length $message; + + # Try a unix socket + $self->{_args}{spamd_socket} = '/var/run/spamd/spamd.socket'; + my $SPAMD = $self->connect_to_spamd(); + if ( $SPAMD ) { + ok( $SPAMD, "connect_to_spamd, socket"); + + $self->print_to_spamd( $SPAMD, $message, $length, $username ); + shutdown($SPAMD, 1); # close our side of the socket (tell spamd we're done) + my $headers = $self->parse_spamd_response( $SPAMD ); + #warn Data::Dumper::Dumper($headers); + ok( $headers, "connect_to_spamd, socket response\n"); + } + else { + ok( 1 == 1, "connect_to_spamd, socket connect FAILED"); + ok( 1 == 1, "connect_to_spamd, socket response FAILED"); + }; + + # Try a TCP/IP connection + $self->{_args}{spamd_socket} = '127.0.0.1:783'; + $SPAMD = $self->connect_to_spamd(); + if ( $SPAMD ) { + ok( $SPAMD, "connect_to_spamd, tcp/ip"); + #warn Data::Dumper::Dumper($SPAMD); + $self->print_to_spamd( $SPAMD, $message, $length, $username ); + shutdown($SPAMD, 1); # close our side of the socket (tell spamd we're done) + my $headers = $self->parse_spamd_response( $SPAMD ); + #warn Data::Dumper::Dumper($headers); + ok( $headers, "connect_to_spamd, tcp/ip response\n"); + } + else { + ok( 1 == 1, "connect_to_spamd, tcp/ip connect FAILED"); + ok( 1 == 1, "connect_to_spamd, tcp/ip response FAILED"); + }; +}; + +sub test_check_spam_reject { + my $self = shift; + + my $transaction = $self->qp->transaction; + $self->setup_headers(); + + # message scored a 10, should pass + $self->{_args}{reject} = 12; + $transaction->notes('spamassassin', { is_spam => 'Yes', score => 10 } ); + my $r = $self->check_spam_reject($transaction); + cmp_ok( DECLINED, '==', $r, "check_spam_reject, $r"); + + # message scored a 15, should fail + $self->{_args}{reject} = 12; + $transaction->notes('spamassassin', { is_spam => 'Yes', score => 15 } ); + ($r) = $self->check_spam_reject($transaction); + cmp_ok( DENY, '==', $r, "check_spam_reject, $r"); +}; + +sub test_check_spam_munge_subject { + my $self = shift; + + my $transaction = $self->qp->transaction; + $self->setup_headers(); + my $subject = 'DSPAM smells better than SpamAssassin'; + + $self->{_args}{munge_subject_threshold} = 5; + $transaction->notes('spamassassin', { score => 6 } ); + $transaction->header->add('Subject', $subject); + $self->check_spam_munge_subject($transaction); + my $r = $transaction->header->get('Subject'); chomp $r; + cmp_ok($r, 'eq', "*** SPAM *** $subject", "check_spam_munge_subject +"); + + $transaction->header->delete('Subject'); # cleanup + $self->{_args}{munge_subject_threshold} = 5; + $transaction->notes('spamassassin', { score => 3 } ); + $transaction->header->add('Subject', $subject); + $self->check_spam_munge_subject($transaction); + $r = $transaction->header->get('Subject'); chomp $r; + cmp_ok($r, 'eq', $subject, "check_spam_munge_subject -"); + + $transaction->header->delete('Subject'); # cleanup + $transaction->notes('spamassassin', { score => 3, required => 4 } ); + $transaction->header->add('Subject', $subject); + $self->check_spam_munge_subject($transaction); + $r = $transaction->header->get('Subject'); chomp $r; + cmp_ok($r, 'eq', $subject, "check_spam_munge_subject -"); + + $transaction->header->delete('Subject'); # cleanup + $transaction->notes('spamassassin', { score => 5, required => 4 } ); + $transaction->header->add('Subject', $subject); + $self->check_spam_munge_subject($transaction); + $r = $transaction->header->get('Subject'); chomp $r; + cmp_ok($r, 'eq', "*** SPAM *** $subject", "check_spam_munge_subject +"); +}; + +sub test_get_spam_results { + my $self = shift; + + my $transaction = $self->qp->transaction; + $self->setup_headers(); + + foreach my $h ( @sample_headers ) { + $transaction->notes('spamassassin', undef); # empty cache + $transaction->header->delete('X-Spam-Status'); # delete previous header + $transaction->header->add('X-Spam-Status', $h); + my $r_ref = $self->get_spam_results($transaction); + if ( $h =~ /hits=/ ) { + $r_ref->{hits} = delete $r_ref->{score}; # SA v2 compat + }; + my $r2 = _reassemble_header($r_ref); + cmp_ok( $h, 'eq', $r2, "get_spam_results ($h)" ); + + # this time it should be cached + $r_ref = $self->get_spam_results($transaction); + next if $h =~ /hits=/; # caching is broken for SA v2 headers + $r2 = _reassemble_header($r_ref); + cmp_ok( $h, 'eq', $r2, "get_spam_results ($h)" ); + }; + +}; + +sub test_parse_spam_header { + my $self = shift; + + foreach my $h ( @sample_headers ) { + my $r_ref = $self->parse_spam_header($h); + if ( $h =~ /hits=/ ) { + $r_ref->{hits} = delete $r_ref->{score}; # SA v2 compat + }; + my $r2 = _reassemble_header($r_ref); + cmp_ok( $h, 'eq', $r2, "parse_spam_header ($h)" ); + }; +}; + +sub setup_headers { + my $self = shift; + + my $transaction = $self->qp->transaction; + my $header = Mail::Header->new(Modify => 0, MailFrom => "COERCE"); + $transaction->header( $header ); +}; + +sub test_message { + return <<'EO_MESSAGE' +To: Fictitious User +From: No Such +Subject: jose can you see, by the dawns early light? + +What so proudly we. +EO_MESSAGE + + +}; + +sub _reassemble_header { + my $info_ref = shift; + my $string = $info_ref->{'is_spam'}; + $string .= ","; + foreach ( qw/ hits score required tests autolearn version / ) { + next if ! defined $info_ref->{$_}; + $string .= " $_=$info_ref->{$_}"; + }; + return $string; +}; + diff --git a/t/plugin_tests/virus/clamdscan b/t/plugin_tests/virus/clamdscan new file mode 100644 index 0000000..7aa450e --- /dev/null +++ b/t/plugin_tests/virus/clamdscan @@ -0,0 +1,81 @@ +#!perl -w + +use strict; +use warnings; + +use Qpsmtpd::Constants; + +sub register_tests { + my $self = shift; + + eval 'use ClamAV::Client'; + if ( ! $@ ) { + $self->register_test('test_register', 3); + $self->register_test('test_get_clamd', 1); + }; + $self->register_test('test_err_and_return', 2); + $self->register_test('test_get_filename', 1); + $self->register_test('test_set_permission', 1); + $self->register_test('test_is_too_big', 2); + $self->register_test('test_is_not_multipart', 2); +} + +sub test_register { + my $self = shift; + + ok( $self->{_args}{deny_viruses} eq 'yes', "deny_viruses"); + ok( $self->{_args}{max_size} == 128, "max_size"); + ok( $self->{_args}{scan_all} == 0, "scan_all"); +}; + +sub test_err_and_return { + my $self = shift; + + $self->{_args}{defer_on_error} = 1; + my ($code, $mess) = $self->err_and_return( "test oops" ); + cmp_ok( DENYSOFT, '==', $code, "oops ($mess)"); + + $self->{_args}{defer_on_error} = 0; + ($code, $mess) = $self->err_and_return( "test oops" ); + cmp_ok( DECLINED, '==', $code, "oops ($mess)"); +} + +sub test_get_filename { + my $self = shift; + my $filename = $self->get_filename(); + ok( $filename, "get_filename ($filename)" ); +} + +sub test_set_permission { + my $self = shift; + ok( $self->set_permission(), "set_permission" ); +} + +sub test_get_clamd { + my $self = shift; + my $clamd = $self->get_clamd(); + ok( ref $clamd, "get_clamd: " . ref $clamd ); +} + +sub test_is_too_big { + my $self = shift; + my $tran = shift || $self->qp->transaction(); + + $self->{_args}{max_size} = 8; + $tran->{_body_size} = (7 * 1024 ); + ok( ! $self->is_too_big( $tran ), "is_too_big"); + + $tran->{_body_size} = (9 * 1024 ); + ok( $self->is_too_big( $tran ), "is_too_big"); +} + +sub test_is_not_multipart { + my $self = shift; + my $tran = shift || $self->qp->transaction(); + + ok( $self->is_not_multipart(), "not_multipart" ); + + $tran->header->add('Content-Type', 'multipart/alternative; boundary="Jx3Wbb8BMHsO=_?:"'); + ok( ! $self->is_not_multipart(), "not_multipart" ); +} + diff --git a/t/qpsmtpd-address.t b/t/qpsmtpd-address.t new file mode 100644 index 0000000..599a4af --- /dev/null +++ b/t/qpsmtpd-address.t @@ -0,0 +1,108 @@ +#!/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"); diff --git a/t/rset.t b/t/rset.t new file mode 100644 index 0000000..ae1e462 --- /dev/null +++ b/t/rset.t @@ -0,0 +1,13 @@ +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'); diff --git a/t/tempstuff.t b/t/tempstuff.t new file mode 100644 index 0000000..467e5d7 --- /dev/null +++ b/t/tempstuff.t @@ -0,0 +1,27 @@ +#!/usr/bin/perl -w +use Test::More qw(no_plan); +use File::Path; +use strict; +use lib 't'; +use_ok('Test::Qpsmtpd'); + +BEGIN { # need this to happen before anything else + my $cwd = `pwd`; + chomp($cwd); + open my $spooldir, '>', "./config.sample/spool_dir"; + print $spooldir "$cwd/t/tmp"; + close $spooldir; +} + +ok(my ($smtpd, $conn) = Test::Qpsmtpd->new_conn(), "get new connection"); + +my ($spool_dir,$tempfile,$tempdir) = ( $smtpd->spool_dir, +$smtpd->temp_file(), $smtpd->temp_dir() ); + +ok( $spool_dir =~ m!t/tmp/$!, "Located the spool directory"); +ok( $tempfile =~ /^$spool_dir/, "Temporary filename" ); +ok( $tempdir =~ /^$spool_dir/, "Temporary directory" ); +ok( -d $tempdir, "And that directory exists" ); + +unlink "./config.sample/spool_dir"; +rmtree($spool_dir);