From 8a24c39f14308179e270b450ee3d9750c930e4cd Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 22 Jun 2012 02:15:11 -0700 Subject: [PATCH 001/352] Initial commit --- .gitignore | 15 +++++++++++++++ README.md | 2 ++ 2 files changed, 17 insertions(+) create mode 100644 .gitignore create mode 100644 README.md diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..d3e79f9 --- /dev/null +++ b/.gitignore @@ -0,0 +1,15 @@ +blib/ +.build/ +_build/ +cover_db/ +inc/ +Build +Build.bat +.last_cover_stats +Makefile +Makefile.old +MANIFEST.bak +META.yml +MYMETA.yml +nytprof.out +pm_to_blib diff --git a/README.md b/README.md new file mode 100644 index 0000000..11539af --- /dev/null +++ b/README.md @@ -0,0 +1,2 @@ +qpsmtpd-dev +=========== \ No newline at end of file From b00f4c7793dc067eef4a8460c98f5156bb4ba5fd Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 22 Jun 2012 05:38:01 -0400 Subject: [PATCH 002/352] 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); From 4bc50f1cd45c543b8f2291b7c593861cb2b9ca6a Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 22 Jun 2012 05:39:23 -0400 Subject: [PATCH 003/352] removed github template file README.md --- README.md | 2 -- 1 file changed, 2 deletions(-) delete mode 100644 README.md diff --git a/README.md b/README.md deleted file mode 100644 index 11539af..0000000 --- a/README.md +++ /dev/null @@ -1,2 +0,0 @@ -qpsmtpd-dev -=========== \ No newline at end of file From 0256e6af44635b298f4fe67aac24a955d8cf3da8 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 22 Jun 2012 05:44:42 -0400 Subject: [PATCH 004/352] removed check_badrcptto_patterns: merged into check_badrcptto --- plugins/check_badrcptto_patterns | 48 -------------------------------- 1 file changed, 48 deletions(-) delete mode 100644 plugins/check_badrcptto_patterns diff --git a/plugins/check_badrcptto_patterns b/plugins/check_badrcptto_patterns deleted file mode 100644 index 807eb69..0000000 --- a/plugins/check_badrcptto_patterns +++ /dev/null @@ -1,48 +0,0 @@ -#!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); -} From 8a8c78c601bc9b4cd7bb02d99bf162204cc4215b Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 22 Jun 2012 06:03:56 -0400 Subject: [PATCH 005/352] update Changes with badmailfrom_pattern deprecation and check_badrcptto_pattern --- Changes | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/Changes b/Changes index 547bac5..5620274 100644 --- a/Changes +++ b/Changes @@ -1,6 +1,10 @@ Next Version + check_badmailfrom_patterns, merged functionality into check_badmail_from + + check_badrcptto_patterns, merged functionality into check_badrcptto + check_basicheaders. New arguments available: past, future, reject, reject_type sender_permitted_from. see UPGRADING (Matt Simerson) From 618496ce51c2a18f4b8095c664df2847a02a790b Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 22 Jun 2012 18:06:32 -0400 Subject: [PATCH 006/352] MANIFEST.SKIP, add a few more entries --- MANIFEST.SKIP | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP index bc39413..c201e99 100644 --- a/MANIFEST.SKIP +++ b/MANIFEST.SKIP @@ -30,3 +30,7 @@ output/.* ^cover_db/ \.(orig|rej)$ packaging +log/main +config +supervise +ssl From 957b9ac241799f7cfe89145dba3ac00f5571af34 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 22 Jun 2012 18:08:16 -0400 Subject: [PATCH 007/352] added commented out uribl to config.sample/plugins --- config.sample/plugins | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config.sample/plugins b/config.sample/plugins index e03310b..9ec7489 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -59,9 +59,9 @@ check_basicheaders days 5 reject_type temp domainkeys # content filters +#uribl virus/klez_filter - # You can run the spamassassin plugin with options. See perldoc # plugins/spamassassin for details. # From e094e4a177e3eedc79eb0428348bbe0c8f848717 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 22 Jun 2012 18:09:20 -0400 Subject: [PATCH 008/352] Qpsmtpd.pm: less default logging at LOGINFO --- lib/Qpsmtpd.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index 86ac87d..fffecf0 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -588,7 +588,7 @@ 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"); + $self->log(LOGDEBUG, "size_threshold set to $Size_threshold"); } return $Size_threshold; } From 37cc9c6d87eeecd4c2bbdfe4f2aed48eb11f3a94 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 22 Jun 2012 18:14:44 -0400 Subject: [PATCH 009/352] Plugin.pm: more descriptive variable names append optional log_mess to log entry (more description) subsequent attempts to set naughty don't overwrite the first set the naughty rejection type to be the reject type of the plugin that marked the connection naughty get_reject_type can be passed an explicit default --- lib/Qpsmtpd/Plugin.pm | 23 ++++++++++++++--------- 1 file changed, 14 insertions(+), 9 deletions(-) diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm index 57a8614..6b063b4 100644 --- a/lib/Qpsmtpd/Plugin.pm +++ b/lib/Qpsmtpd/Plugin.pm @@ -212,32 +212,37 @@ sub compile { 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 $smtp_mess = shift || "why didn't you pass an error message?"; + my $log_mess = shift || ''; + $log_mess = ", $log_mess" if $log_mess; my $reject = $self->{_args}{reject}; if ( defined $reject && ! $reject ) { - $self->log(LOGINFO, 'fail, reject disabled'); + $self->log(LOGINFO, "fail, reject disabled" . $log_mess); return DECLINED; }; # the naughty plugin will reject later if ( $reject eq 'naughty' ) { - $self->log(LOGINFO, 'fail, NAUGHTY'); - $self->connection->notes('naughty', $message); + $self->log(LOGINFO, "fail, NAUGHTY" . $log_mess); + if ( ! $self->connection->notes('naughty') ) { + $self->connection->notes('naughty', $smtp_mess); + }; + if ( ! $self->connection->notes('naughty_reject_type') ) { + $self->connection->notes('naughty_reject_type', $self->{_args}{reject_type} ); + } return (DECLINED); }; # they asked for reject, we give them reject - $self->log(LOGINFO, 'fail'.$log_info); - return ( $self->get_reject_type(), $message); + $self->log(LOGINFO, "fail" . $log_mess); + return ( $self->get_reject_type(), $smtp_mess); }; sub get_reject_type { my $self = shift; my $default = shift || DENY; - my $deny = $self->{_args}{reject_type} or return $default; + my $deny = shift || $self->{_args}{reject_type} or return $default; return $deny =~ /^(temp|soft)$/i ? DENYSOFT : $deny =~ /^(perm|hard)$/i ? DENY From feab782a0abaad8f068ec95d7157429a3e96b9db Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 22 Jun 2012 18:16:43 -0400 Subject: [PATCH 010/352] Transaction.pm: added debugging messages for DESTROY --- lib/Qpsmtpd/Transaction.pm | 27 +++++++++++++++++++++------ 1 file changed, 21 insertions(+), 6 deletions(-) diff --git a/lib/Qpsmtpd/Transaction.pm b/lib/Qpsmtpd/Transaction.pm index 0dabffa..4283d29 100644 --- a/lib/Qpsmtpd/Transaction.pm +++ b/lib/Qpsmtpd/Transaction.pm @@ -2,14 +2,16 @@ package Qpsmtpd::Transaction; use Qpsmtpd; @ISA = qw(Qpsmtpd); use strict; +use warnings; + use Qpsmtpd::Utils; use Qpsmtpd::Constants; + +use IO::File qw(O_RDWR O_CREAT); 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 { @@ -116,6 +118,9 @@ sub body_spool { } $self->{_body_start} = $self->{_header_size}; } + else { + $self->log(LOGERROR, "no message body"); + } $self->{_body_array} = undef; } @@ -227,10 +232,20 @@ sub DESTROY { # 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}, ": $!"); - } + $self->log(LOGDEBUG, sprintf( "DESTROY called by %s, %s, %s", (caller) ) ); + + if ( $self->{_body_file} ) { + undef $self->{_body_file}; + }; + + if ($self->{_filename} and -e $self->{_filename}) { + if ( unlink $self->{_filename} ) { + $self->log(LOGDEBUG, "unlinked ", $self->{_filename} ); + } + else { + $self->log(LOGERROR, "Could not unlink ", $self->{_filename}, ": $!"); + } + } # These may not exist if ( $self->{_temp_files} ) { From a08745acc45d2ada9f18b0567698a88e72dceaf4 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 22 Jun 2012 18:20:15 -0400 Subject: [PATCH 011/352] badmailfrom: removed tests for rcpt_handler and shorten test response messages in badmailfromto --- t/plugin_tests/check_badmailfrom | 30 ++++++++---------------------- t/plugin_tests/check_badmailfromto | 8 ++++---- 2 files changed, 12 insertions(+), 26 deletions(-) diff --git a/t/plugin_tests/check_badmailfrom b/t/plugin_tests/check_badmailfrom index a4a45b3..e80e0fb 100644 --- a/t/plugin_tests/check_badmailfrom +++ b/t/plugin_tests/check_badmailfrom @@ -11,7 +11,6 @@ sub register_tests { $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 { @@ -50,31 +49,18 @@ sub test_badmailfrom_hook_mail { $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"); + $transaction->notes('badmailfrom', ''); + my ($r, $err) = $self->hook_mail( $transaction, $address ); + cmp_ok( $r, '==', 901, "hook_mail rc"); + cmp_ok( $err, 'eq', 'Your envelope sender is in my badmailfrom list', "hook_mail: 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"); + $transaction->notes('badmailfrom', ''); + ($r, $err) = $self->hook_mail( $transaction, $address ); + cmp_ok( $r, '==', 901, "hook_mail rc"); + cmp_ok( $err, 'eq', 'Yer a spammin bastert', "hook_mail: 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; diff --git a/t/plugin_tests/check_badmailfromto b/t/plugin_tests/check_badmailfromto index 73d9bb9..e71abd2 100644 --- a/t/plugin_tests/check_badmailfromto +++ b/t/plugin_tests/check_badmailfromto @@ -20,17 +20,17 @@ sub test_badmailfromto_is_sender_immune { 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"); + ok( $self->is_sender_immune( $transaction->sender, ['bad@example.com'] ), "null sender"); my $address = Qpsmtpd::Address->new( '' ); $transaction->sender($address); - ok( $self->is_sender_immune( $transaction->sender, ['bad@example.com'] ), "is_immune, missing host"); + ok( $self->is_sender_immune( $transaction->sender, ['bad@example.com'] ), "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"); + ok( $self->is_sender_immune( $transaction->sender, ['bad@example.com'] ), "missing user"); $transaction->sender( Qpsmtpd::Address->new( '' ) ); - ok( ! $self->is_sender_immune( $transaction->sender, ['bad@example.com'] ), "is_immune, false"); + ok( ! $self->is_sender_immune( $transaction->sender, ['bad@example.com'] ), "false"); }; From 1d67c849cfb29326074d62ac1f97ddf4056edce9 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 22 Jun 2012 18:29:28 -0400 Subject: [PATCH 012/352] spamassassin: add explicit default reject_type consolidate the two data_post methods into one (more linear, simpler) more informative log message add new headers to top of headers (not bottom (consistent MTA behavior)) --- plugins/spamassassin | 54 +++++++++++++++++----------- t/plugin_tests/spamassassin | 70 +++++++++++++++++++------------------ 2 files changed, 70 insertions(+), 54 deletions(-) diff --git a/plugins/spamassassin b/plugins/spamassassin index 1101f8e..2d7d2e5 100644 --- a/plugins/spamassassin +++ b/plugins/spamassassin @@ -141,6 +141,7 @@ use warnings; use Qpsmtpd::Constants; use Qpsmtpd::DSN; + use Socket qw(:DEFAULT :crlf); use IO::Handle; @@ -155,12 +156,14 @@ sub register { if ( ! defined $self->{_args}{reject} && defined $self->{_args}{reject_threshold} ) { $self->{_args}{reject} = $self->{_args}{reject_threshold}; }; + if ( ! defined $self->{_args}{reject_type} ) { + $self->{_args}{reject_type} = 'perm'; + }; - $self->register_hook('data_post', 'check_spam_reject'); - $self->register_hook('data_post', 'check_spam_munge_subject'); + $self->register_hook('data_post', 'data_post_handler'); } -sub hook_data_post { +sub data_post_handler { my ($self, $transaction) = @_; return (DECLINED) if $self->is_immune(); @@ -180,7 +183,8 @@ sub hook_data_post { my $headers = $self->parse_spamd_response( $SPAMD ) or return (DECLINED); $self->insert_spam_headers( $transaction, $headers, $username ); - return (DECLINED); + $self->munge_subject( $transaction ); + return $self->reject( $transaction ); }; sub select_spamd_username { @@ -361,52 +365,62 @@ sub print_to_spamd { $self->log(LOGDEBUG, "check_spam: finished sending to spamd"); }; -sub check_spam_reject { +sub reject { my ($self, $transaction) = @_; my $sa_results = $self->get_spam_results($transaction) or do { - $self->log(LOGNOTICE, "skip: no spamassassin results"); + $self->log(LOGNOTICE, "skip, no results"); return DECLINED; }; my $score = $sa_results->{score} or do { - $self->log(LOGERROR, "skip: error getting spamassassin score"); + $self->log(LOGERROR, "skip, error getting score"); return DECLINED; }; my $ham_or_spam = $sa_results->{is_spam} eq 'Yes' ? 'Spam' : 'Ham'; + my $status = "$ham_or_spam, $score"; + my $learn; + if ( $sa_results->{autolearn} ) { + $learn = "learn=". $sa_results->{autolearn}; + }; my $reject = $self->{_args}{reject} or do { - $self->log(LOGERROR, "skip: reject not set ($ham_or_spam, $score)"); + $self->log(LOGERROR, "skip, reject disabled ($status, $learn)"); return DECLINED; }; if ( $score < $reject ) { - $self->log(LOGINFO, "pass, $ham_or_spam, $score < $reject"); - return DECLINED; - }; + if ( $ham_or_spam eq 'Spam' ) { + $self->log(LOGINFO, "fail, $status < $reject, $learn"); + return DECLINED; + } + else { + $self->log(LOGINFO, "pass, $status < $reject, $learn"); + return DECLINED; + } + } + $self->connection->notes('karma', $self->connection->notes('karma') - 1); # 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"); + $self->log(LOGINFO, "deny, $status, > $reject, $learn"); + return ($self->get_reject_type(), "spam score exceeded threshold"); } -sub check_spam_munge_subject { +sub munge_subject { my ($self, $transaction) = @_; + my $sa = $self->get_spam_results($transaction) or return; 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; }; - return DECLINED unless $sa->{score} > $required; + return 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 { @@ -465,7 +479,7 @@ sub _cleanup_spam_header { $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->add($old_header_name, $header, 0) if $action eq 'rename'; $transaction->header->delete($header_name); } } diff --git a/t/plugin_tests/spamassassin b/t/plugin_tests/spamassassin index 67018b4..dfe6409 100644 --- a/t/plugin_tests/spamassassin +++ b/t/plugin_tests/spamassassin @@ -25,9 +25,9 @@ sub register_tests { $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); + $self->register_test('test_get_spam_results', 20); + $self->register_test('test_munge_subject', 4); + $self->register_test('test_reject', 2); } sub test_connect_to_spamd { @@ -43,38 +43,38 @@ sub test_connect_to_spamd { $self->{_args}{spamd_socket} = '/var/run/spamd/spamd.socket'; my $SPAMD = $self->connect_to_spamd(); if ( $SPAMD ) { - ok( $SPAMD, "connect_to_spamd, socket"); - + ok( $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"); + ok( $headers, "socket response\n"); } else { - ok( 1 == 1, "connect_to_spamd, socket connect FAILED"); - ok( 1 == 1, "connect_to_spamd, socket response FAILED"); + ok( 1 == 1, "socket connect FAILED"); + ok( 1 == 1, "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"); + ok( $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"); + ok( $headers, "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"); + ok( 1 == 1, "tcp/ip connect FAILED"); + ok( 1 == 1, "tcp/ip response FAILED"); }; }; -sub test_check_spam_reject { +sub test_reject { my $self = shift; my $transaction = $self->qp->transaction; @@ -83,17 +83,17 @@ sub test_check_spam_reject { # 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"); - + my $r = $self->reject($transaction); + cmp_ok( DECLINED, '==', $r, "r: $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"); + ($r) = $self->reject($transaction); + cmp_ok( DENY, '==', $r, "r: $r"); }; -sub test_check_spam_munge_subject { +sub test_munge_subject { my $self = shift; my $transaction = $self->qp->transaction; @@ -103,31 +103,31 @@ sub test_check_spam_munge_subject { $self->{_args}{munge_subject_threshold} = 5; $transaction->notes('spamassassin', { score => 6 } ); $transaction->header->add('Subject', $subject); - $self->check_spam_munge_subject($transaction); + $self->munge_subject($transaction); my $r = $transaction->header->get('Subject'); chomp $r; - cmp_ok($r, 'eq', "*** SPAM *** $subject", "check_spam_munge_subject +"); + cmp_ok($r, 'eq', "*** SPAM *** $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); + $self->munge_subject($transaction); $r = $transaction->header->get('Subject'); chomp $r; - cmp_ok($r, 'eq', $subject, "check_spam_munge_subject -"); + cmp_ok($r, 'eq', $subject, "-"); $transaction->header->delete('Subject'); # cleanup $transaction->notes('spamassassin', { score => 3, required => 4 } ); $transaction->header->add('Subject', $subject); - $self->check_spam_munge_subject($transaction); + $self->munge_subject($transaction); $r = $transaction->header->get('Subject'); chomp $r; - cmp_ok($r, 'eq', $subject, "check_spam_munge_subject -"); + cmp_ok($r, 'eq', $subject, "-"); $transaction->header->delete('Subject'); # cleanup $transaction->notes('spamassassin', { score => 5, required => 4 } ); $transaction->header->add('Subject', $subject); - $self->check_spam_munge_subject($transaction); + $self->munge_subject($transaction); $r = $transaction->header->get('Subject'); chomp $r; - cmp_ok($r, 'eq', "*** SPAM *** $subject", "check_spam_munge_subject +"); + cmp_ok($r, 'eq', "*** SPAM *** $subject", "+"); }; sub test_get_spam_results { @@ -145,15 +145,17 @@ sub test_get_spam_results { $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)" ); + cmp_ok( $h, 'eq', $r2, $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 + if ( $h =~ /hits=/ ) { + ok( 1 ); + next; + }; # caching is broken for SA v2 headers $r2 = _reassemble_header($r_ref); - cmp_ok( $h, 'eq', $r2, "get_spam_results ($h)" ); + cmp_ok( $h, 'eq', $r2, $h ); }; - }; sub test_parse_spam_header { @@ -161,11 +163,11 @@ sub test_parse_spam_header { foreach my $h ( @sample_headers ) { my $r_ref = $self->parse_spam_header($h); - if ( $h =~ /hits=/ ) { + 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)" ); + cmp_ok( $h, 'eq', $r2, $h ); }; }; @@ -181,7 +183,7 @@ sub test_message { return <<'EO_MESSAGE' To: Fictitious User From: No Such -Subject: jose can you see, by the dawns early light? +Subject: jose can you see, by the dawns early light? What so proudly we. EO_MESSAGE From 4cf99154ad556fec632882862dbe05fc5bfd8cb2 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 22 Jun 2012 19:21:44 -0400 Subject: [PATCH 013/352] headers: plugin tests, deprecate check_basicheaders --- config.sample/plugins | 2 +- plugins/check_basicheaders | 162 ------------------ plugins/headers | 11 +- .../{check_basicheaders => headers} | 33 ++-- 4 files changed, 28 insertions(+), 180 deletions(-) delete mode 100644 plugins/check_basicheaders rename t/plugin_tests/{check_basicheaders => headers} (75%) diff --git a/config.sample/plugins b/config.sample/plugins index 9ec7489..4839773 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -55,7 +55,7 @@ auth/authdeny # this plugin needs to run after all other "rcpt" plugins rcpt_ok -check_basicheaders days 5 reject_type temp +headers days 5 reject_type temp domainkeys # content filters diff --git a/plugins/check_basicheaders b/plugins/check_basicheaders deleted file mode 100644 index 4758b67..0000000 --- a/plugins/check_basicheaders +++ /dev/null @@ -1,162 +0,0 @@ -#!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/headers b/plugins/headers index 5b2ec71..14bef0d 100644 --- a/plugins/headers +++ b/plugins/headers @@ -2,7 +2,7 @@ =head1 NAME -headers +headers - validate message headers =head1 DESCRIPTION @@ -96,14 +96,14 @@ use Qpsmtpd::Constants; use Date::Parse qw(str2time); -my @required_headers = qw/ From /; # <- to comply with RFC 5322, add Date here +my @required_headers = qw/ From /; # <- to be RFC 5322 compliant, 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; + my ($self, $qp ) = (shift, shift); $self->log(LOGWARN, "invalid arguments") if @_ % 2; $self->{_args} = { @_ }; @@ -129,7 +129,7 @@ sub hook_data_post { return $self->get_reject( "missing headers", "missing headers" ); }; - #return (DECLINED, "immune") if $self->is_immune(); + return (DECLINED, "immune") if $self->is_immune(); foreach my $h ( @required_headers ) { if ( ! $header->get($h) ) { @@ -156,7 +156,8 @@ sub hook_data_post { sub invalid_date_range { my $self = shift; - my $date = $self->transaction->header->get('Date') or return; + return if ! $self->transaction->header; + my $date = shift || $self->transaction->header->get('Date') or return; chomp $date; my $ts = str2time($date) or do { diff --git a/t/plugin_tests/check_basicheaders b/t/plugin_tests/headers similarity index 75% rename from t/plugin_tests/check_basicheaders rename to t/plugin_tests/headers index 2ac5748..3470164 100644 --- a/t/plugin_tests/check_basicheaders +++ b/t/plugin_tests/headers @@ -12,8 +12,8 @@ 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); + $self->register_test("test_hook_data_post", 7); } sub setup_test_headers { @@ -29,18 +29,27 @@ sub setup_test_headers { $transaction->header->add('From', "<$test_email>"); $transaction->header->add('Date', $now ); $transaction->body_write( "test message body " ); + + $self->qp->connection->relay_client(0); + $self->qp->transaction->notes('whitelistsender', 0); + $self->connection->notes('whitelisthost', 0); + $self->connection->notes('naughty', 0); }; sub test_invalid_date_range { my $self = shift; + my $header = Mail::Header->new(Modify => 0, MailFrom => "COERCE"); + my $transaction = $self->qp->transaction->header($header); + my $now = strftime "%a %b %e %H:%M:%S %Y", localtime time; - ok( ! $self->invalid_date_range($now), "valid +"); + my $r = $self->invalid_date_range($now); + ok( ! $r, "valid +") or print "$r\n"; $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 ); + $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 @@ -49,7 +58,7 @@ sub test_invalid_date_range { 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, +" ); + ok( ! $r, "a little new, +" ) or warn "$r\n"; $self->{_args}{past} = 2; @@ -77,36 +86,36 @@ sub test_hook_data_post { my $transaction = $self->qp->transaction; my ($code, $mess) = $self->hook_data_post( $transaction ); - cmp_ok( DECLINED, '==', $code, "okay +" ); + cmp_ok( DECLINED, '==', $code, "okay $code, $mess" ); $transaction->header->delete('Date'); ($code, $mess) = $self->hook_data_post( $transaction ); - cmp_ok( $deny, '==', $code, "missing date ( $mess )" ); + cmp_ok( $code, '==', $deny, "missing date ( $code, $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 )" ); + cmp_ok( $deny, '==', $code, "missing from ( $code, $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 )" ); + cmp_ok( $deny, '==', $code, "too new ( $code, $mess )" ); $self->{_args}{past} = 5; - my $past = strftime "%a %b %e %H:%M:%S %Y", localtime time - 518400; #6d + 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 )" ); + cmp_ok( $deny, '==', $code, "too old ( $code, $mess )" ); $self->{_args}{reject_type} = 'temp'; ($code, $mess) = $self->hook_data_post( $transaction ); - cmp_ok( DENYSOFT, '==', $code, "defer, not deny ( $mess )" ); + cmp_ok( DENYSOFT, '==', $code, "defer, not deny ( $code, $mess )" ); $self->{_args}{reject_type} = 'perm'; ($code, $mess) = $self->hook_data_post( $transaction ); - cmp_ok( DENY, '==', $code, "deny ( $mess )" ); + cmp_ok( DENY, '==', $code, "deny ( $code, $mess )" ); }; From 5e2336f7dad35014903065d8eefd6ed7c99f90a2 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 22 Jun 2012 19:24:16 -0400 Subject: [PATCH 014/352] helo: refine plugin tests --- plugins/helo | 6 +++--- t/misc.t | 7 +------ t/plugin_tests/helo | 15 +++++++-------- 3 files changed, 11 insertions(+), 17 deletions(-) diff --git a/plugins/helo b/plugins/helo index 55e8e8e..58748c7 100644 --- a/plugins/helo +++ b/plugins/helo @@ -209,7 +209,7 @@ use Qpsmtpd::Constants; use Net::DNS; sub register { - my ($self, $qp) = shift, shift; + my ($self, $qp) = (shift, shift); $self->{_args} = { @_ }; $self->{_args}{reject_type} = 'disconnect'; $self->{_args}{policy} ||= 'lenient'; @@ -262,8 +262,8 @@ sub populate_tests { @{ $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 /; + push @{ $self->{_helo_tests} }, qw/ is_plain_ip is_not_fqdn + no_forward_dns no_reverse_dns /; }; if ( $policy eq 'strict' ) { diff --git a/t/misc.t b/t/misc.t index 96b80f8..82526bf 100644 --- a/t/misc.t +++ b/t/misc.t @@ -1,16 +1,11 @@ -use Test::More tests => 14; +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"); -# 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", diff --git a/t/plugin_tests/helo b/t/plugin_tests/helo index 20fa763..25ba153 100644 --- a/t/plugin_tests/helo +++ b/t/plugin_tests/helo @@ -15,12 +15,11 @@ sub register_tests { $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_no_reverse_dns', 3); + $self->register_test('test_no_matching_dns', 2); $self->register_test('test_helo_handler', 1); - $self->register_test('test_check_ip_match', 4); - $self->register_test('test_check_name_match', 4); + $self->register_test('test_check_ip_match', 3); + $self->register_test('test_check_name_match', 3); } sub test_helo_handler { @@ -150,15 +149,15 @@ sub test_check_ip_match { $self->connection->notes('helo_forward_match', 0); $self->check_ip_match('192.0.2.1'); - ok( $self->connection->notes('helo_forward_match'), "exact"; + 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"; + 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"; + ok( ! $self->connection->notes('helo_forward_match'), "miss"); }; sub test_check_name_match { From 1b72b9175df7d173f6f756528f1677481f4f32e6 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 22 Jun 2012 19:26:45 -0400 Subject: [PATCH 015/352] t/config/plugins: update test plugin list --- t/config/plugins | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/t/config/plugins b/t/config/plugins index 5225ba0..c7cf28d 100644 --- a/t/config/plugins +++ b/t/config/plugins @@ -17,7 +17,7 @@ hosts_allow # information plugins ident/geoip -#ident/p0f /tmp/.p0f_socket version 3 +ident/p0f /tmp/.p0f_socket version 3 connection_time # enable to accept MAIL FROM:/RCPT TO: addresses without surrounding <> @@ -34,13 +34,13 @@ check_earlytalker count_unrecognized_commands 4 relay -require_resolvable_fromhost +resolvable_fromhost rhsbl dnsbl check_badmailfrom check_badrcptto -check_spamhelo +helo sender_permitted_from greylisting p0f genre,windows @@ -55,7 +55,7 @@ auth/authdeny # this plugin needs to run after all other "rcpt" plugins rcpt_ok -check_basicheaders days 5 reject_type temp +headers days 5 reject_type temp require From,Date domainkeys # content filters @@ -77,6 +77,7 @@ dspam learn_from_sa 7 reject 1 # run the clamav virus checking plugin virus/clamav +virus/clamdscan # You must enable a queue plugin - see the options in plugins/queue/ - for example: From ccfee70c9b5a8362db4dfb6c70d4c9b21f913940 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 22 Jun 2012 19:27:40 -0400 Subject: [PATCH 016/352] t/config: add missing test config files --- t/config/dnsbl_allow | 2 ++ t/config/norelayclients | 6 ++++++ 2 files changed, 8 insertions(+) create mode 100644 t/config/dnsbl_allow create mode 100644 t/config/norelayclients diff --git a/t/config/dnsbl_allow b/t/config/dnsbl_allow new file mode 100644 index 0000000..a9c72d5 --- /dev/null +++ b/t/config/dnsbl_allow @@ -0,0 +1,2 @@ +# test entry for dnsbl plugin +192.168.99.5 diff --git a/t/config/norelayclients b/t/config/norelayclients new file mode 100644 index 0000000..1ac21a4 --- /dev/null +++ b/t/config/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... From 644709e6ae500cdc4bee3e85a5e896a703379fe6 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 22 Jun 2012 20:03:47 -0400 Subject: [PATCH 017/352] badmailfrom: remove rcpt hook (uses naughty instead) --- plugins/check_badmailfrom | 46 +++++++++----------------------- t/plugin_tests/check_badmailfrom | 23 +++++++++++----- 2 files changed, 30 insertions(+), 39 deletions(-) diff --git a/plugins/check_badmailfrom b/plugins/check_badmailfrom index f4d1d84..47aa425 100644 --- a/plugins/check_badmailfrom +++ b/plugins/check_badmailfrom @@ -48,12 +48,6 @@ anywhere in the string. ^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 @@ -65,16 +59,10 @@ stage, so store it until later. =cut sub register { - my ($self,$qp) = shift, shift; + 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 { @@ -86,7 +74,6 @@ sub hook_mail { if ( defined $self->{_badmailfrom_config} ) { # testing @badmailfrom = @{$self->{_badmailfrom_config}}; }; - return DECLINED if $self->is_immune_sender( $sender, \@badmailfrom ); my $host = lc $sender->host; @@ -98,20 +85,22 @@ sub hook_mail { 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); + $self->connection->notes('karma', ($self->connection->notes('karma') || 0) - 1); + return $self->get_reject( $reason ); } - if ( ! $self->connection->notes('naughty') ) { - $self->log(LOGINFO, "pass"); - }; + + $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/; + if ( $bad =~ /[\/\^\$\*\+\!\%\?\\]/ ) { # it's a regexp + if ( $from =~ /$bad/ ) { + $self->log(LOGDEBUG, "badmailfrom pattern ($bad) match for $from"); + return 1; + }; return; }; @@ -128,30 +117,21 @@ sub is_match { 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'); + $self->log(LOGDEBUG, 'skip, empty list'); return 1; }; if ( ! $sender || $sender->format eq '<>' ) { - $self->log(LOGDEBUG, 'skip: null sender'); + $self->log(LOGDEBUG, 'skip, null sender'); return 1; }; if ( ! $sender->host || ! $sender->user ) { - $self->log(LOGDEBUG, 'skip: missing user or host'); + $self->log(LOGDEBUG, 'skip, missing user or host'); return 1; }; diff --git a/t/plugin_tests/check_badmailfrom b/t/plugin_tests/check_badmailfrom index e80e0fb..042d3d0 100644 --- a/t/plugin_tests/check_badmailfrom +++ b/t/plugin_tests/check_badmailfrom @@ -4,6 +4,7 @@ use strict; use Data::Dumper; use Qpsmtpd::Address; +use Qpsmtpd::Constants; sub register_tests { my $self = shift; @@ -42,6 +43,8 @@ sub test_badmailfrom_is_immune_sender { sub test_badmailfrom_hook_mail { my $self = shift; + $self->_reset_connection_flags(); + my $transaction = $self->qp->transaction; my $test_email = 'matt@test.com'; @@ -49,16 +52,16 @@ sub test_badmailfrom_hook_mail { $transaction->sender($address); $self->{_badmailfrom_config} = ['matt@test.net','matt@test.com']; - $transaction->notes('badmailfrom', ''); + $transaction->notes('naughty', ''); my ($r, $err) = $self->hook_mail( $transaction, $address ); - cmp_ok( $r, '==', 901, "hook_mail rc"); - cmp_ok( $err, 'eq', 'Your envelope sender is in my badmailfrom list', "hook_mail: default reason"); + cmp_ok( $r, '==', DENY, "hook_mail rc"); + cmp_ok( $err, 'eq', 'Your envelope sender is in my badmailfrom list', "default reason"); $self->{_badmailfrom_config} = ['matt@test.net','matt@test.com Yer a spammin bastert']; - $transaction->notes('badmailfrom', ''); + $transaction->notes('naughty', ''); ($r, $err) = $self->hook_mail( $transaction, $address ); - cmp_ok( $r, '==', 901, "hook_mail rc"); - cmp_ok( $err, 'eq', 'Yer a spammin bastert', "hook_mail: custom reason"); + cmp_ok( $r, '==', DENY, "hook_mail rc"); + cmp_ok( $err, 'eq', 'Yer a spammin bastert', "custom reason"); }; sub test_badmailfrom_match { @@ -88,3 +91,11 @@ sub test_badmailfrom_match { "check_badmailfrom pattern non-match"); }; +sub _reset_connection_flags { + my $self = shift; + $self->qp->connection->relay_client(0); + $self->qp->connection->notes('whitelisthost', 0); + $self->connection->notes('naughty',0); + $self->connection->notes('rejected', 0); +}; + From c44f034a767d9fc16414844cc78535a56056d393 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 22 Jun 2012 20:07:29 -0400 Subject: [PATCH 018/352] rename check_badmailfrom -> badmailfrom --- plugins/{check_badmailfrom => badmailfrom} | 0 plugins/{check_badmailfromto => badmailfromto} | 12 ++++++------ t/plugin_tests/{check_badmailfrom => badmailfrom} | 0 3 files changed, 6 insertions(+), 6 deletions(-) rename plugins/{check_badmailfrom => badmailfrom} (100%) rename plugins/{check_badmailfromto => badmailfromto} (84%) rename t/plugin_tests/{check_badmailfrom => badmailfrom} (100%) diff --git a/plugins/check_badmailfrom b/plugins/badmailfrom similarity index 100% rename from plugins/check_badmailfrom rename to plugins/badmailfrom diff --git a/plugins/check_badmailfromto b/plugins/badmailfromto similarity index 84% rename from plugins/check_badmailfromto rename to plugins/badmailfromto index 3a39874..154f336 100644 --- a/plugins/check_badmailfromto +++ b/plugins/badmailfromto @@ -34,7 +34,7 @@ sub hook_mail { next unless $bad; $bad = lc $bad; if ( $bad !~ m/\@/ ) { - $self->log(LOGWARN, 'badmailfromto: bad config, no @ sign in '. $bad); + $self->log(LOGWARN, 'bad config, no @ sign in '. $bad); next; }; if ( $bad eq $from || (substr($bad,0,1) eq '@' && $bad eq "\@$host") ) { @@ -48,7 +48,7 @@ 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"); + $self->log(LOGDEBUG, "pass, sender not listed"); return (DECLINED); }; @@ -57,7 +57,7 @@ sub hook_rcpt { return (DENY, "mail to $recipient not accepted here") if lc($from) eq $sender && lc($to) eq $recipient; } - $self->log(LOGDEBUG, "pass: recipient not listed"); + $self->log(LOGDEBUG, "pass, recipient not listed"); return (DECLINED); } @@ -65,17 +65,17 @@ sub is_sender_immune { my ($self, $sender, $badmf ) = @_; if ( ! scalar @$badmf ) { - $self->log(LOGDEBUG, 'skip: empty list'); + $self->log(LOGDEBUG, 'skip, empty list'); return 1; }; if ( ! $sender || $sender->format eq '<>' ) { - $self->log(LOGDEBUG, 'skip: null sender'); + $self->log(LOGDEBUG, 'skip, null sender'); return 1; }; if ( ! $sender->host || ! $sender->user ) { - $self->log(LOGDEBUG, 'skip: missing user or host'); + $self->log(LOGDEBUG, 'skip, missing user or host'); return 1; }; diff --git a/t/plugin_tests/check_badmailfrom b/t/plugin_tests/badmailfrom similarity index 100% rename from t/plugin_tests/check_badmailfrom rename to t/plugin_tests/badmailfrom From db081a4c91cc43f8c048502adddd6de266bf2b73 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 22 Jun 2012 20:08:19 -0400 Subject: [PATCH 019/352] badmailfrom rename: update test config/plugins --- t/config/plugins | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/t/config/plugins b/t/config/plugins index c7cf28d..a6f6fd0 100644 --- a/t/config/plugins +++ b/t/config/plugins @@ -38,7 +38,7 @@ resolvable_fromhost rhsbl dnsbl -check_badmailfrom +badmailfrom check_badrcptto helo From 9fc6c7e484563f3a57988fa96d5288247ae76716 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 22 Jun 2012 20:21:09 -0400 Subject: [PATCH 020/352] badmailfrom rename fixups --- config.sample/plugins | 2 +- plugins/badmailfromto | 6 +++--- t/plugin_tests/badmailfrom | 14 +++++++------- 3 files changed, 11 insertions(+), 11 deletions(-) diff --git a/config.sample/plugins b/config.sample/plugins index 4839773..0775c24 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -38,7 +38,7 @@ require_resolvable_fromhost rhsbl dnsbl -check_badmailfrom +badmailfrom check_badrcptto check_spamhelo diff --git a/plugins/badmailfromto b/plugins/badmailfromto index 154f336..351345a 100644 --- a/plugins/badmailfromto +++ b/plugins/badmailfromto @@ -2,18 +2,18 @@ =head1 NAME -check_badmailfromto - checks the badmailfromto config +badmailfromto - checks the badmailfromto config =head1 DESCRIPTION -Much like the similar check_badmailfrom, this plugin references both the +Much like the similar 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. +Based heavily on badmailfrom. =cut diff --git a/t/plugin_tests/badmailfrom b/t/plugin_tests/badmailfrom index 042d3d0..463d5f7 100644 --- a/t/plugin_tests/badmailfrom +++ b/t/plugin_tests/badmailfrom @@ -70,25 +70,25 @@ sub test_badmailfrom_match { # 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($r, "match"); ok( ! $self->is_match( 'matt@test.net', 'matt@test.com', 'tnpi.net' ), - "check_badmailfrom non-match"); + "non-match"); ok( $self->is_match( 'matt@test.net', '@test.net', 'test.net' ), - "check_badmailfrom match host"); + "match host"); ok( ! $self->is_match( 'matt@test.net', '@test.not', 'test.net' ), - "check_badmailfrom non-match host"); + "non-match host"); ok( ! $self->is_match( 'matt@test.net', '@test.net', 'test.not' ), - "check_badmailfrom non-match host"); + "non-match host"); ok( $self->is_match( 'matt@test.net', 'test.net$', 'tnpi.net' ), - "check_badmailfrom pattern match"); + "pattern match"); ok( ! $self->is_match( 'matt@test.net', 'test.not$', 'tnpi.net' ), - "check_badmailfrom pattern non-match"); + "pattern non-match"); }; sub _reset_connection_flags { From cd699c80787e30155b2ae8ba3a32dfaabe2f05ef Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 22 Jun 2012 20:26:06 -0400 Subject: [PATCH 021/352] badmailfrom: more cleanups --- Changes | 6 +++++- docs/hooks.pod | 2 +- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/Changes b/Changes index 5620274..0945ba8 100644 --- a/Changes +++ b/Changes @@ -1,7 +1,11 @@ Next Version - check_badmailfrom_patterns, merged functionality into check_badmail_from + renamed check_badrcptto -> badrcptto + renamed check_badmailfromto -> badmailfromto + renamed check_badmailfrom -> badmailfrom + + check_badmailfrom_patterns, merged functionality into check_badmailfrom check_badrcptto_patterns, merged functionality into check_badrcptto diff --git a/docs/hooks.pod b/docs/hooks.pod index 182fa9c..0020613 100644 --- a/docs/hooks.pod +++ b/docs/hooks.pod @@ -236,7 +236,7 @@ Arguments for this hook are # sender of the message Example plugins for the C are F -and F. +and F. =head2 hook_rcpt_pre From b1850e8d85dd311b62344c547e67c52d518dcddc Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 22 Jun 2012 20:26:31 -0400 Subject: [PATCH 022/352] headers: test fix --- config.sample/plugins | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config.sample/plugins b/config.sample/plugins index 0775c24..b3df0a2 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -55,7 +55,7 @@ auth/authdeny # this plugin needs to run after all other "rcpt" plugins rcpt_ok -headers days 5 reject_type temp +headers days 5 reject_type temp require From,Date domainkeys # content filters From 4b2c25681984b245bd03499dc237f827da6e7d0b Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 22 Jun 2012 20:29:42 -0400 Subject: [PATCH 023/352] geoip: improve log messages list fixed with continent code first to improve readability added ability to include city in logging --- plugins/ident/geoip | 49 ++++++++++++++++++++++++++++----------------- 1 file changed, 31 insertions(+), 18 deletions(-) diff --git a/plugins/ident/geoip b/plugins/ident/geoip index fddaa10..fda062e 100644 --- a/plugins/ident/geoip +++ b/plugins/ident/geoip @@ -14,24 +14,25 @@ information about incoming connections. 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_country_name - english name of country geoip_continent - 2 char continent code + geoip_city - english name of city 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: NA, US, United States, 1319 km + (connect) ident::geoip: AS, IN, India, 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 + (connect) ident::geoip: NA, CA, Canada, 2464 km + (connect) ident::geoip: NA, US, United States, 2318 km + (connect) ident::geoip: AS, PK, Pakistan, 12578 km + (connect) ident::geoip: AS, TJ, Tajikistan, 11965 km + (connect) ident::geoip: EU, AT, Austria, 8745 km + (connect) ident::geoip: AS, IR, Iran, Islamic Republic of, 12180 km + (connect) ident::geoip: EU, BY, Belarus, 9030 km + (connect) ident::geoip: AS, CN, China, 11254 km + (connect) ident::geoip: NA, PA, Panama, 3163 km Calculating the distance has three prerequsites: @@ -145,18 +146,21 @@ sub connect_handler { $self->qp->connection->notes('geoip_country', $c_code); my $c_name = $self->set_country_name(); - my ($continent_code, $distance); + my ($city, $continent_code, $distance) = ''; if ( $self->{_my_country_code} ) { $continent_code = $self->set_continent( $c_code ); + $city = $self->set_city_gc(); $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); + my @msg_parts; + push @msg_parts, $continent_code if $continent_code && $continent_code ne '--'; + push @msg_parts, $c_code if $c_code; + #push @msg_parts, $c_name if $c_name; + push @msg_parts, $city if $city; + push @msg_parts, "\t$distance km" if $distance; + $self->log(LOGINFO, join( ", ", @msg_parts) ); return DECLINED; } @@ -250,6 +254,15 @@ sub set_continent_gc { return $continent; }; +sub set_city_gc { + my $self = shift; + return if ! $self->{_geoip_record}; + my $remote_ip = $self->qp->connection->remote_ip; + my $city = $self->{_geoip_record}->city() or return; + $self->qp->connection->notes('geoip_city', $city); + return $city; +}; + sub set_distance_gc { my $self = shift; return if ! $self->{_geoip_record}; From 2bef49183902760668adb0b469a40936b3a0a8f1 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 22 Jun 2012 20:38:08 -0400 Subject: [PATCH 024/352] remove deprecated config file badrcptto_patterns --- config.sample/badrcptto_patterns | 5 ----- 1 file changed, 5 deletions(-) delete mode 100644 config.sample/badrcptto_patterns diff --git a/config.sample/badrcptto_patterns b/config.sample/badrcptto_patterns deleted file mode 100644 index e3bdca9..0000000 --- a/config.sample/badrcptto_patterns +++ /dev/null @@ -1,5 +0,0 @@ -# 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 From 01c994439b59a96c29f6fb598cf10d17cedba458 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 22 Jun 2012 23:37:42 -0400 Subject: [PATCH 025/352] clamdscan: make sure headers exist before operating on them --- plugins/virus/clamdscan | 2 ++ t/plugin_tests/virus/clamdscan | 9 +++++++-- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/plugins/virus/clamdscan b/plugins/virus/clamdscan index 906a21d..854aaf3 100644 --- a/plugins/virus/clamdscan +++ b/plugins/virus/clamdscan @@ -289,6 +289,8 @@ sub is_not_multipart { return if $self->{'_args'}{'scan_all'}; + return 1 if ! $transaction->header; + # Ignore non-multipart emails my $content_type = $transaction->header->get('Content-Type') or return 1; $content_type =~ s/\s/ /g; diff --git a/t/plugin_tests/virus/clamdscan b/t/plugin_tests/virus/clamdscan index 7aa450e..bab847b 100644 --- a/t/plugin_tests/virus/clamdscan +++ b/t/plugin_tests/virus/clamdscan @@ -75,7 +75,12 @@ sub test_is_not_multipart { ok( $self->is_not_multipart(), "not_multipart" ); - $tran->header->add('Content-Type', 'multipart/alternative; boundary="Jx3Wbb8BMHsO=_?:"'); - ok( ! $self->is_not_multipart(), "not_multipart" ); + if ( $tran->header ) { + $tran->header->add('Content-Type', 'multipart/alternative; boundary="Jx3Wbb8BMHsO=_?:"'); + ok( ! $self->is_not_multipart(), "not_multipart" ); + } + else { + ok( 1 ); + } } From 3db3565144ca0b5661a6bd2c949fee584cebc86f Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 22 Jun 2012 23:44:55 -0400 Subject: [PATCH 026/352] dspam: changed to only train on error per suggestions by the dspam author --- plugins/dspam | 197 ++++++++++++++++++++++++++----------------- t/plugin_tests/dspam | 31 ------- 2 files changed, 119 insertions(+), 109 deletions(-) diff --git a/plugins/dspam b/plugins/dspam index 51e067f..d80551b 100644 --- a/plugins/dspam +++ b/plugins/dspam @@ -18,13 +18,13 @@ 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. +If you enable dspam rejection without training first, you will lose valid +mail. The dspam false positive rate is high when untrained. 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: +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 @@ -70,7 +70,7 @@ learn messages with negative karma as spam (see plugins/karma) =item spamassassin -learn from spamassassins messages with autolearn=(ham|spam) +learn from spamassassins messages with autolearn=(ham|spam). See SPAMASSASSIN. =item any @@ -135,7 +135,7 @@ 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 +is dramatically slowed by MyISAM table locks and dspam requires a lot of training. InnoDB has row level locking and updates are much faster. =head1 DSPAM periodic maintenance @@ -144,8 +144,6 @@ 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 @@ -164,13 +162,14 @@ reduce the SA load. =item 2 -Autolearn must be enabled and configured in SpamAssassin. SA autolearn will +For I to work, 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 +If you are using I and I, 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. @@ -207,7 +206,7 @@ use IO::Handle; use Socket qw(:DEFAULT :crlf); sub register { - my ($self, $qp) = shift, shift; + my ($self, $qp) = (shift, shift); $self->log(LOGERROR, "Bad parameters for the dspam plugin") if @_ % 2; @@ -222,7 +221,6 @@ 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 ) { @@ -231,16 +229,18 @@ sub data_post_handler { }; my $username = $self->select_username( $transaction ); - my $filtercmd = $self->get_filter_cmd( $transaction, $username ); + my $dspam_bin = $self->{_args}{dspam_bin} || '/usr/local/bin/dspam'; + my $filtercmd = "$dspam_bin --user $username --mode=tum --process --deliver=summary --stdout"; $self->log(LOGDEBUG, $filtercmd); my $response = $self->dspam_process( $filtercmd, $transaction ); - if ( ! $response ) { + if ( ! $response->{result} ) { $self->log(LOGWARN, "skip, no dspam response. Check logs for errors."); return (DECLINED); }; $self->attach_headers( $response, $transaction ); + $self->autolearn( $response, $transaction ); return $self->log_and_return( $transaction ); }; @@ -279,8 +279,26 @@ sub assemble_message { sub dspam_process { my ( $self, $filtercmd, $transaction ) = @_; - return $self->dspam_process_backticks( $filtercmd ); - #return $self->dspam_process_open2( $filtercmd, $transaction ); + my $dspam_response = $self->dspam_process_backticks( $filtercmd ); + #my $dspam_response = $self->dspam_process_open2( $filtercmd, $transaction ); + #my $dspam_response = $self->dspam_process_fork( $filtercmd ); + + # 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 ($r, $p, $c, $s) + = $dspam_response + =~ /result=\"(Spam|Innocent)\";.*?probability=([\d\.]+); confidence=([\d\.]+); signature=(.*)/; + + return { + result => $r, + probability => $p, + confidence => $c, + signature => $s, + }; +}; + +sub dspam_process_fork { + my ( $self, $filtercmd, $transaction ) = @_; # yucky. This method (which forks) exercises a bug in qpsmtpd. When the # child exits, the Transaction::DESTROY method is called, which deletes @@ -305,7 +323,6 @@ 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; @@ -450,46 +467,11 @@ sub get_dspam_results { 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) = @_; + my ($self, $r, $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"; + my $header_str = "$r->{result}, probability=$r->{probability}, confidence=$r->{confidence}"; $self->log(LOGDEBUG, $header_str); my $name = 'X-DSPAM-Result'; $transaction->header->delete($name) if $transaction->header->get($name); @@ -497,49 +479,108 @@ sub attach_headers { # 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); + $transaction->header->add('X-DSPAM-Signature', $r->{signature}, 0); }; -sub learn_as_ham { +sub train_error_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"; + my $cmd = "$dspam_bin --user $user --mode=toe --source=error --class=innocent --deliver=summary --stdout"; $self->dspam_process( $cmd, $transaction ); }; -sub learn_as_spam { +sub train_error_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"; + my $cmd = "$dspam_bin --user $user --mode=toe --source=error --class=spam --deliver=summary --stdout"; $self->dspam_process( $cmd, $transaction ); }; sub autolearn { - my ( $self, $transaction ) = @_; + my ( $self, $response, $transaction ) = @_; + + defined $self->{_args}{autolearn} or return; + + $self->autolearn_naughty( $response, $transaction ) and return; + $self->autolearn_karma( $response, $transaction ) and return; + $self->autolearn_spamassassin( $response, $transaction ) and return; +}; + +sub autolearn_naughty { + my ( $self, $response, $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 ); - }; + return if ( $learn ne 'naughty' && $learn ne 'any' ); + + if ( $self->connection->notes('naughty') && $response->{result} eq 'Innocent' ) { + $self->log(LOGINFO, "training naughty FN message as spam"); + $self->train_error_as_spam( $transaction ); + return 1; }; + + return; +}; + +sub autolearn_karma { + my ( $self, $response, $transaction ) = @_; + + my $learn = $self->{_args}{autolearn} or return; + + return if ( $learn ne 'karma' && $learn ne 'any' ); + + my $karma = $self->connection->notes('karma'); + return if ! defined $karma; + + if ( $karma <= -1 && $response->{result} eq 'Innocent' ) { + $self->log(LOGINFO, "training bad karma FN as spam"); + $self->train_error_as_spam( $transaction ); + return 1; + }; + + if ( $karma >= 1 && $response->{result} eq 'Spam' ) { + $self->log(LOGINFO, "training good karma FP as ham"); + $self->train_error_as_ham( $transaction ); + return 1; + }; + + return; +}; + +sub autolearn_spamassassin { + my ( $self, $response, $transaction ) = @_; + + my $learn = $self->{_args}{autolearn} or return; + + return if ( $learn ne 'spamassassin' && $learn ne 'any' ); + + my $sa = $transaction->notes('spamassassin' ); + if ( ! $sa || ! $sa->{is_spam} ) { + $self->log(LOGERROR, "SA results missing"); + return; + }; + + if ( ! $sa->{autolearn} ) { + $self->log(LOGERROR, "SA autolearn unset"); + return; + }; + + if ( $sa->{is_spam} eq 'Yes' && $sa->{autolearn} eq 'spam' && $response->{result} eq 'Innocent' ) { + $self->log(LOGINFO, "training spamassassin FN as spam"); + $self->train_error_as_spam( $transaction ); + return 1; + } + elsif ( $sa->{is_spam} eq 'No' && $sa->{autolearn} eq 'ham' && $response->{result} eq 'Spam' ) { + $self->log(LOGINFO, "training spamassassin FP as ham"); + $self->train_error_as_ham( $transaction ); + return 1; + }; + + return; }; diff --git a/t/plugin_tests/dspam b/t/plugin_tests/dspam index 5f104f1..4752ec8 100644 --- a/t/plugin_tests/dspam +++ b/t/plugin_tests/dspam @@ -11,7 +11,6 @@ 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); @@ -83,36 +82,6 @@ sub test_get_dspam_results { }; }; -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; From 2a95374977729f085c30b9f702b9da6d4fe4a82c Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 22 Jun 2012 23:47:34 -0400 Subject: [PATCH 027/352] p0f: POD & log message updates --- plugins/ident/p0f | 90 +++++++++++++++++++++------------------- t/plugin_tests/ident/p0f | 15 ++++--- 2 files changed, 54 insertions(+), 51 deletions(-) diff --git a/plugins/ident/p0f b/plugins/ident/p0f index 2386980..06c2da4 100644 --- a/plugins/ident/p0f +++ b/plugins/ident/p0f @@ -11,9 +11,9 @@ 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: +This p0f module inserts a I connection note with information deduced +from the TCP fingerprint. The note typically includes at least the link, +detail, distance, uptime, genre. Here's a p0f v2 example: genre => FreeBSD detail => 6.x (1) @@ -26,20 +26,29 @@ 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) +When using p0f v3, the following additional values may also be available in +the I connection note: + +=over 4 + +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, and language. + +=back + =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. +from Windows computers are spam (>99%). But, I have clients with +Exchange servers so I can't 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. +Same goes for greylisting. Finance companies (AmEx, BoA, etc) send notices +that they don't queue and retry. They deliver immediately or never. Enabling +greylisting means maintaining manual whitelists or losing valid messages. -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. +While I'm not willing to use greylisting for every connection, and I'm not +willing to block connections from Windows computers, I am willing to greylist +all email from Windows computers. =head1 CONFIGURATION @@ -47,7 +56,7 @@ 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 +Create a startup script for p0f that creates a communication socket when your server starts up. p0f v2 example: @@ -73,10 +82,9 @@ It's even possible to run both versions of p0f simultaneously: =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. +Use I to override the IP address of your mail server. This is useful +if your mail server runs on a private IP behind a firewall. 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: @@ -107,15 +115,11 @@ Version 2 code heavily based upon the p0fq.pl included with the p0f distribution =head1 AUTHORS -Robert Spier ( original author ) +2004 - Robert Spier ( original author ) -Matt Simerson +2010 - Matt Simerson - added local_ip option -=head1 CHANGES - -Added local_ip option - Matt Simerson (5/2010) - -Refactored and added p0f v3 support - Matt Simerson (4/2012) +2012 - Matt Simerson - refactored, v3 support =cut @@ -168,10 +172,10 @@ sub get_v2_query { 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; + or $self->log(LOGERROR, "skip, ".Net::IP::Error()), return; my $dst = new Net::IP($local_ip) - or $self->log(LOGERROR, "p0f: ".NET::IP::Error()), return; + or $self->log(LOGERROR, "skip, ".NET::IP::Error()), return; return pack("L L L N N S S", $QUERY_MAGIC_V2, @@ -187,7 +191,7 @@ 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"); + $self->log( LOGERROR, "skip, unable to determine remote IP"); return; }; @@ -204,7 +208,7 @@ sub query_p0f_v3 { my $self = shift; my $p0f_socket = $self->{_args}{p0f_socket} or do { - $self->log(LOGERROR, "socket not defined in config."); + $self->log(LOGERROR, "skip, socket not defined in config."); return; }; my $query = $self->get_v3_query() or return; @@ -215,29 +219,29 @@ sub query_p0f_v3 { $sock = IO::Socket::UNIX->new(Peer => $p0f_socket, Type => SOCK_STREAM ); }; if ( ! $sock ) { - $self->log(LOGERROR, "p0f: could not open socket: $@"); + $self->log(LOGERROR, "skip, could not open socket: $@"); return; }; $sock->autoflush(1); # paranoid redundancy $sock->connected or do { - $self->log(LOGERROR, "p0f: socket not connected: $!"); + $self->log(LOGERROR, "skip, socket not connected: $!"); return; }; my $sent = $sock->send($query, 0) or do { - $self->log(LOGERROR, "p0f: send failed: $!"); + $self->log(LOGERROR, "skip, 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"); + $self->log(LOGDEBUG, "sent $sent byte request"); my $response; $sock->recv( $response, 232 ); my $length = length $response; - $self->log(LOGDEBUG, "p0f: received $length byte response"); + $self->log(LOGDEBUG, "received $length byte response"); close $sock; return $response; }; @@ -250,15 +254,15 @@ sub query_p0f_v2 { # Open the connection to p0f socket(SOCK, PF_UNIX, SOCK_STREAM, 0) - or $self->log(LOGERROR, "p0f: socket: $!"), return; + or $self->log(LOGERROR, "socket: $!"), return; connect(SOCK, sockaddr_un($p0f_socket)) - or $self->log(LOGERROR, "p0f: connect: $!"), return; + or $self->log(LOGERROR, "connect: $!"), return; defined syswrite SOCK, $query - or $self->log(LOGERROR, "p0f: write: $!"), close SOCK, return; + or $self->log(LOGERROR, "write: $!"), close SOCK, return; my $response; defined sysread SOCK, $response, 1024 - or $self->log(LOGERROR, "p0f: read: $!"), close SOCK, return; + or $self->log(LOGERROR, "read: $!"), close SOCK, return; close SOCK; return $response; }; @@ -271,16 +275,16 @@ sub test_v2_response { # $self->log(LOGERROR, $response); if ($magic != $QUERY_MAGIC_V2) { - $self->log(LOGERROR, "p0f: Bad response magic."); + $self->log(LOGERROR, "skip, Bad response magic."); return; } if ($type == 1) { - $self->log(LOGERROR, "p0f: p0f did not honor our query"); + $self->log(LOGERROR, "skip, p0f did not honor our query"); return; } elsif ($type == 2) { - $self->log(LOGWARN, "p0f: This connection is no longer in the cache"); + $self->log(LOGWARN, "skip, this connection is no longer in the cache"); return; } return 1; @@ -293,21 +297,21 @@ sub test_v3_response { # check the magic response value (a p0f constant) if ($magic != $RESP_MAGIC_V3 ) { - $self->log(LOGERROR, "p0f: Bad response magic."); + $self->log(LOGERROR, "skip, Bad response magic."); return; } # check the response status if ($status == $P0F_STATUS_BADQUERY ) { - $self->log(LOGERROR, "p0f: bad query"); + $self->log(LOGERROR, "skip, bad query"); return; } elsif ($status == $P0F_STATUS_NOMATCH ) { - $self->log(LOGINFO, "p0f: no match"); + $self->log(LOGINFO, "skip, no match"); return; } if ($status == $P0F_STATUS_OK ) { - $self->log(LOGDEBUG, "p0f: query ok"); + $self->log(LOGDEBUG, "pass, query ok"); return 1; } return; diff --git a/t/plugin_tests/ident/p0f b/t/plugin_tests/ident/p0f index cf743c9..8643232 100644 --- a/t/plugin_tests/ident/p0f +++ b/t/plugin_tests/ident/p0f @@ -12,7 +12,7 @@ sub register_tests { $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 @@ -43,7 +43,7 @@ sub test_get_v2_query { $self->qp->connection->remote_port(2500); my $r = $self->get_v2_query(); - ok( $r, 'get_v2_query' ); + ok( $r, 'r +' ); #use Data::Dumper; warn Data::Dumper::Dumper( $r ); }; @@ -54,8 +54,7 @@ sub test_get_v3_query { $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 ); + ok( $r, 'any +' ); }; sub test_store_v2_results { @@ -67,8 +66,8 @@ sub test_store_v2_results { my $r = $self->store_v2_results( $response ); - ok( $r, "query_p0f_v2 result") or return; - ok( $r->{genre} =~ /windows/i, "store_v2_results, genre" ); + ok( $r, "r: +") or return; + ok( $r->{genre} =~ /windows/i, "genre +" ); #use Data::Dumper; warn Data::Dumper::Dumper( $r ); }; @@ -80,8 +79,8 @@ sub test_store_v3_results { '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" ); + ok( $r, "result"); + ok( $r->{genre} =~ /windows/i, "genre" ); }; From bcb0298440ff7aeff6f747c5fd44201dacbedbd3 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 22 Jun 2012 23:48:36 -0400 Subject: [PATCH 028/352] MANIFEST.SKIP: anchor the new additions entries are regexps, and 'config' matched too much --- MANIFEST.SKIP | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP index c201e99..704cede 100644 --- a/MANIFEST.SKIP +++ b/MANIFEST.SKIP @@ -30,7 +30,7 @@ output/.* ^cover_db/ \.(orig|rej)$ packaging -log/main -config -supervise -ssl +^log/main/ +^config/ +^supervise/ +^ssl/ From c150f5a8cc56907e0ae284b60db7cfd1e307e27f Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 22 Jun 2012 23:52:32 -0400 Subject: [PATCH 029/352] uribl: insert headers at top of message --- plugins/uribl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/uribl b/plugins/uribl index ab7498b..7e5e677 100644 --- a/plugins/uribl +++ b/plugins/uribl @@ -494,7 +494,7 @@ sub data_handler { for (@$matches) { $self->log(LOGWARN, $_->{desc}); if ($_->{action} eq 'add-header') { - $transaction->header->add('X-URIBL-Match', $_->{desc}); + $transaction->header->add('X-URIBL-Match', $_->{desc}, 0); } elsif ($_->{action} eq 'deny') { return (DENY, $_->{desc}); } elsif ($_->{action} eq 'denysoft') { From 60209495518013237524c6692c23d898fcdc81d8 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 22 Jun 2012 23:54:54 -0400 Subject: [PATCH 030/352] relay: logging tweak --- plugins/relay | 7 +++++-- t/plugin_tests/relay | 2 +- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/plugins/relay b/plugins/relay index c7890bc..e8b0743 100644 --- a/plugins/relay +++ b/plugins/relay @@ -105,7 +105,7 @@ use Qpsmtpd::Constants; use Net::IP qw(:PROC); sub register { - my ($self, $qp) = shift, shift; + my ($self, $qp) = ( shift, shift ); $self->log(LOGERROR, "Bad arguments") if @_ % 2; $self->{_args} = { @_ }; @@ -123,7 +123,7 @@ sub is_in_norelayclients { while ( $ip ) { if ( exists $no_relay_clients{$ip} ) { - $self->log(LOGNOTICE, "$ip in norelayclients"); + $self->log(LOGINFO, "$ip in norelayclients"); return 1; } $ip =~ s/(\d|\w)+(:|\.)?$// or last; # strip off another octet @@ -207,6 +207,7 @@ sub hook_connect { if ( $self->is_in_norelayclients() ) { $self->qp->connection->relay_client(0); delete $ENV{RELAYCLIENT}; + $self->log(LOGINFO, "fail, disabled by norelayclients"); return (DECLINED); } @@ -218,6 +219,8 @@ sub hook_connect { $self->populate_relayclients(); +# 95586 (connect) relay: pass, octet match in relayclients (127.0.0.) + if ( $self->is_in_cidr_block() || $self->is_octet_match() ) { $self->qp->connection->relay_client(1); return (DECLINED); diff --git a/t/plugin_tests/relay b/t/plugin_tests/relay index 988c184..cf14985 100644 --- a/t/plugin_tests/relay +++ b/t/plugin_tests/relay @@ -75,7 +75,7 @@ sub test_is_in_norelayclients { foreach ( @false ) { $self->qp->connection->remote_ip($_); - ok( ! $self->is_in_norelayclients(), "match, + ($_)"); + ok( ! $self->is_in_norelayclients(), "match, - ($_)"); }; }; From 560ce218e3e32abf861df3993457a127dcae09bb Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 22 Jun 2012 23:56:25 -0400 Subject: [PATCH 031/352] badrcptto: log tweaks, better regex detection --- plugins/check_badrcptto | 6 +++--- t/plugin_tests/check_badrcptto | 16 +++++++++++++--- 2 files changed, 16 insertions(+), 6 deletions(-) diff --git a/plugins/check_badrcptto b/plugins/check_badrcptto index 7b5f7d9..8787974 100644 --- a/plugins/check_badrcptto +++ b/plugins/check_badrcptto @@ -47,7 +47,7 @@ use Qpsmtpd::Constants; use Qpsmtpd::DSN; sub hook_rcpt { - my ($self, $transaction, $recipient, %param) = @_; + my ($self, $transaction, $recipient, %param) = @_; return (DECLINED) if $self->is_immune(); @@ -55,7 +55,7 @@ sub hook_rcpt { or return (DECLINED); my @badrcptto = $self->qp->config("badrcptto") or do { - $self->log(LOGINFO, "skip: empty config"); + $self->log(LOGINFO, "skip, empty config"); return (DECLINED); }; @@ -79,7 +79,7 @@ sub hook_rcpt { sub is_match { my ( $self, $to, $bad, $host ) = @_; - if ( $bad =~ /[\/\^\$\*\+\!\%]/ ) { # it's a regexp + 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'); diff --git a/t/plugin_tests/check_badrcptto b/t/plugin_tests/check_badrcptto index ac9057d..3e7c9a3 100644 --- a/t/plugin_tests/check_badrcptto +++ b/t/plugin_tests/check_badrcptto @@ -13,6 +13,14 @@ sub register_tests { $self->register_test("test_get_host_and_to", 8); } +sub _reset_connection_flags { + my $self = shift; + $self->qp->connection->relay_client(0); + $self->qp->connection->notes('whitelisthost', 0); + $self->connection->notes('naughty',0); + $self->connection->notes('rejected', 0); +}; + sub test_is_match { my $self = shift; @@ -52,19 +60,21 @@ sub test_is_match { sub test_hook_rcpt { my $self = shift; + $self->_reset_connection_flags(); + my $transaction = $self->qp->transaction; my $recipient = Qpsmtpd::Address->new( '' ); my ($r, $mess) = $self->hook_rcpt( $transaction, $recipient ); - cmp_ok( DECLINED, '==', $r, "valid +"); + cmp_ok( $r, '==', DECLINED, "valid +"); $recipient = Qpsmtpd::Address->new( '' ); ($r, $mess) = $self->hook_rcpt( $transaction, $recipient ); - cmp_ok( DENY, '==', $r, "bad match, +"); + cmp_ok( $r, '==', DENY, "bad match, +, $mess"); $recipient = Qpsmtpd::Address->new( '' ); ($r, $mess) = $self->hook_rcpt( $transaction, $recipient ); - cmp_ok( DENY, '==', $r, "bad host match, +"); + cmp_ok( $r, '==', DENY, "bad host match, +, $mess"); }; sub test_get_host_and_to { From cdfa106b3f13295b9c9ec1648b22b4796e155ed3 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 22 Jun 2012 23:57:43 -0400 Subject: [PATCH 032/352] karma: improve error handling --- plugins/karma | 9 ++++++--- plugins/karma_tool | 4 ++-- 2 files changed, 8 insertions(+), 5 deletions(-) diff --git a/plugins/karma b/plugins/karma index b85f5e6..e46fdfb 100644 --- a/plugins/karma +++ b/plugins/karma @@ -240,7 +240,7 @@ use Fcntl qw(:DEFAULT :flock LOCK_EX LOCK_NB); use Net::IP; sub register { - my ($self, $qp ) = shift, shift; + my ($self, $qp ) = (shift, shift); $self->log(LOGERROR, "Bad arguments") if @_ % 2; $self->{_args} = { @_ }; $self->{_args}{negative} ||= 1; @@ -265,7 +265,10 @@ sub connect_handler { 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 $key = $self->get_db_key() or do { + $self->log( LOGINFO, "skip, unable to get DB key" ); + return DECLINED; + }; if ( ! $tied->{$key} ) { $self->log(LOGINFO, "pass, no record"); @@ -372,7 +375,7 @@ sub cleanup_and_return { sub get_db_key { my $self = shift; - my $nip = Net::IP->new( $self->qp->connection->remote_ip ); + my $nip = Net::IP->new( $self->qp->connection->remote_ip ) or return; return $nip->intip; # convert IP to an int }; diff --git a/plugins/karma_tool b/plugins/karma_tool index d7556a5..eb3d921 100755 --- a/plugins/karma_tool +++ b/plugins/karma_tool @@ -38,7 +38,7 @@ sub usage { list takes no arguments. -search [ naughty nice both ] +search [ naughty nice both ] and returns a list of matching IPs capture [ IP ] @@ -115,7 +115,7 @@ sub main { elsif ( $search eq 'both' ) { next if ! $naughty || ! $nice; } - elsif ( is_ip() && $search ne $ip ) { + elsif ( is_ip( $ARGV[1] ) && $search ne $ip ) { next; } }; From 9e9fcf41a7a8e75b2361d0d85398852a041ddb72 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Jun 2012 00:02:03 -0400 Subject: [PATCH 033/352] badrcptto: dropped check_ prefix from name --- config.sample/plugins | 2 +- plugins/{check_badrcptto => badrcptto} | 0 t/config/plugins | 2 +- t/plugin_tests/{check_badrcptto => badrcptto} | 0 4 files changed, 2 insertions(+), 2 deletions(-) rename plugins/{check_badrcptto => badrcptto} (100%) rename t/plugin_tests/{check_badrcptto => badrcptto} (100%) diff --git a/config.sample/plugins b/config.sample/plugins index b3df0a2..4e351be 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -39,7 +39,7 @@ require_resolvable_fromhost rhsbl dnsbl badmailfrom -check_badrcptto +badrcptto check_spamhelo # sender_permitted_from diff --git a/plugins/check_badrcptto b/plugins/badrcptto similarity index 100% rename from plugins/check_badrcptto rename to plugins/badrcptto diff --git a/t/config/plugins b/t/config/plugins index a6f6fd0..41ff2fb 100644 --- a/t/config/plugins +++ b/t/config/plugins @@ -39,7 +39,7 @@ resolvable_fromhost rhsbl dnsbl badmailfrom -check_badrcptto +badrcptto helo sender_permitted_from diff --git a/t/plugin_tests/check_badrcptto b/t/plugin_tests/badrcptto similarity index 100% rename from t/plugin_tests/check_badrcptto rename to t/plugin_tests/badrcptto From f601516f9fc854a2156c68521133886c1389fffa Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Jun 2012 00:05:01 -0400 Subject: [PATCH 034/352] check_spamhelo: remove, deprecated by helo --- config.sample/plugins | 2 +- plugins/check_spamhelo | 34 ---------------------------------- 2 files changed, 1 insertion(+), 35 deletions(-) delete mode 100644 plugins/check_spamhelo diff --git a/config.sample/plugins b/config.sample/plugins index 4e351be..9e6d9d2 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -40,7 +40,7 @@ rhsbl dnsbl badmailfrom badrcptto -check_spamhelo +helo # sender_permitted_from # greylisting p0f genre,windows diff --git a/plugins/check_spamhelo b/plugins/check_spamhelo deleted file mode 100644 index 3b60a0a..0000000 --- a/plugins/check_spamhelo +++ /dev/null @@ -1,34 +0,0 @@ -#!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; From 89d82afe530c33a8e14c5198c7b9ab21308a69ec Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Jun 2012 00:09:46 -0400 Subject: [PATCH 035/352] dnsbl: process DNS queries immediately rather than deferring until RCPT. This greatly improves efficiency, since most connections will get marked naughty much sooner, having run fewer tests. --- plugins/dnsbl | 177 ++++++++++++++++++++++++------------------- t/plugin_tests/dnsbl | 18 +---- 2 files changed, 103 insertions(+), 92 deletions(-) diff --git a/plugins/dnsbl b/plugins/dnsbl index 43b2e58..977424f 100644 --- a/plugins/dnsbl +++ b/plugins/dnsbl @@ -13,9 +13,23 @@ a configurable set of RBL services. Add the following line to the config/plugins file: - dnsbl [ reject_type disconnect ] [loglevel -1] + dnsbl -=head2 reject_type [ temp | perm ] +The following options are also availble: + +=head2 reject [ 0 | 1 | naughty ] + + dnsbl reject 0 <- do not reject + + dnsbl reject 1 <- reject + + dnsbl reject naughty <- See perldoc plugins/naughty + +Also, when I is set, DNS queries are processed during connect. + +=head2 reject_type [ temp | perm | disconnect ] + +Default: perm To immediately drop the connection (since some blacklisted servers attempt multiple sends per session), set I. In most cases, @@ -23,14 +37,12 @@ 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] +Adjust the quantity of logging for this plugin. See docs/logging.pod + =head1 CONFIG FILES This plugin uses the following configuration files. All are optional. Not @@ -121,7 +133,7 @@ See: https://github.com/smtpd/qpsmtpd/commits/master/plugins/dnsbl =cut sub register { - my ($self, $qp) = shift, shift; + my ($self, $qp) = (shift, shift); if ( @_ % 2 ) { $self->{_args}{reject_type} = shift; # backwards compatibility @@ -129,53 +141,80 @@ sub register { else { $self->{_args} = { @_ }; }; + + # explicitly state legacy reject behavior + if ( ! defined $self->{_args}{reject_type} ) { + $self->{_args}{reject_type} = 'perm'; + }; + if ( ! defined $self->{_args}{reject} ) { + $self->{_args}{reject} = 1; + }; } sub hook_connect { - my ($self, $transaction) = @_; + my ($self, $transaction) = @_; + + my $reject = $self->{_args}{reject}; + + # RBLSMTPD being non-empty means it contains the failure message to return + if ( defined $ENV{'RBLSMTPD'} && $ENV{'RBLSMTPD'} ne '' ) { + return $self->return_env_message() if $reject && $reject eq 'connect'; + }; + + return DECLINED if $self->is_immune(); # 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'); + my %dnsbl_zones = map { (split /:/, $_, 2)[0,1] } $self->qp->config('dnsbl_zones'); if ( ! %dnsbl_zones ) { - $self->log( LOGDEBUG, "skip: no list configured"); + $self->log( LOGDEBUG, "skip, no zones"); return DECLINED; }; - my $remote_ip = $self->qp->connection->remote_ip; - my $reversed_ip = join('.', reverse(split(/\./, $remote_ip))); + 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 + $self->initiate_lookups( \%dnsbl_zones, $reversed_ip ); - my $res = new Net::DNS::Resolver; - $res->tcp_timeout(30); - $res->udp_timeout(30); + my $message = $self->process_sockets or do { + $self->log(LOGINFO, 'pass'); + return DECLINED; + }; - my $sel = IO::Select->new(); + return $self->get_reject( $message ); +}; - 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")); +sub initiate_lookups { + my ($self, $zones, $reversed_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 %$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($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")); + } } - 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; -} + $self->connection->notes('dnsbl_sockets', $sel); + $self->connection->notes('dnsbl_domains', $dom); +}; sub is_set_rblsmtpd { my $self = shift; @@ -199,26 +238,37 @@ sub is_set_rblsmtpd { sub ip_whitelisted { my $self = shift; - my $remote_ip = shift || $self->qp->connection->remote_ip; + my $remote_ip = $self->qp->connection->remote_ip; - return - grep { s/\.?$/./; $_ eq substr($remote_ip . '.', 0, length $_) } - $self->qp->config('dnsbl_allow'); + return grep { s/\.?$/./; + $_ eq substr($remote_ip . '.', 0, length $_) + } + $self->qp->config('dnsbl_allow'); }; +sub return_env_message { + my $self = shift; + 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)); +} + sub process_sockets { my ($self) = @_; - my $conn = $self->connection; + my $conn = $self->qp->connection; return $conn->notes('dnsbl') if $conn->notes('dnsbl'); - my %dnsbl_zones = map { (split /:/, $_, 2)[0,1] } $self->qp->config('dnsbl_zones'); - my $sel = $conn->notes('dnsbl_sockets') or return ''; my $dom = $conn->notes('dnsbl_domains'); my $remote_ip = $self->qp->connection->remote_ip; + my %dnsbl_zones = map { (split /:/, $_, 2)[0,1] } $self->qp->config('dnsbl_zones'); + my $result; my $res = new Net::DNS::Resolver; $res->tcp_timeout(30); @@ -229,7 +279,7 @@ sub process_sockets { # 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 ..."); + $self->log(LOGDEBUG, "done waiting for dnsbl dns, got ", scalar @ready, " answers ..."); return '' unless @ready; for my $socket (@ready) { @@ -294,33 +344,16 @@ sub process_sockets { } 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; - }; + my ($self, $transaction, $rcpt, %param) = @_; if ( $rcpt->user =~ /^(?:postmaster|abuse|mailer-daemon|root)$/i ) { - $self->log(LOGWARN, "skip: don't blacklist special account: ".$rcpt->user); - return DECLINED; + $self->log(LOGWARN, "skip, don't blacklist special account: ".$rcpt->user); + + # clear the naughty connection note here, if desired. + #$self->connection->notes('naughty', 0 ); } - $self->log(LOGINFO, 'fail'); - return ( $self->get_reject_type(), $note); + return DECLINED; } sub hook_disconnect { @@ -331,13 +364,3 @@ sub hook_disconnect { 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/t/plugin_tests/dnsbl b/t/plugin_tests/dnsbl index ca14b7c..9d42665 100644 --- a/t/plugin_tests/dnsbl +++ b/t/plugin_tests/dnsbl @@ -8,8 +8,7 @@ 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_hook_connect', 1); $self->register_test('test_ip_whitelisted', 3); $self->register_test('test_is_set_rblsmtpd', 4); $self->register_test('test_hook_disconnect', 1); @@ -54,21 +53,10 @@ sub test_hook_connect { $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 +"); + my ($rc, $mess) = $self->hook_connect($self->qp->transaction); + cmp_ok( $rc, '==', DENY, "connect +"); } -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; From bf0612c1e0b3a5b8d5c6907ee2d474a808df9e39 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Jun 2012 00:15:55 -0400 Subject: [PATCH 036/352] MANIFEST: long overdue update --- MANIFEST | 58 ++++++++++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 48 insertions(+), 10 deletions(-) diff --git a/MANIFEST b/MANIFEST index ed6a279..0a02e1b 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1,20 +1,24 @@ .gitignore +.travis.yml Changes config.sample/badhelo config.sample/badmailfrom -config.sample/badrcptto_patterns +config.sample/badrcptto +config.sample/dnsbl_allow 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/norelayclients config.sample/plugins config.sample/rcpthosts config.sample/relayclients config.sample/require_resolvable_fromhost config.sample/rhsbl_zones config.sample/size_threshold +config.sample/smtpauth-checkpassword config.sample/tls_before_auth config.sample/tls_ciphers CREDITS @@ -22,6 +26,7 @@ docs/advanced.pod docs/authentication.pod docs/config.pod docs/development.pod +docs/FAQ.pod docs/hooks.pod docs/logging.pod docs/plugins.pod @@ -70,16 +75,12 @@ 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/badmailfrom +plugins/badmailfromto +plugins/badrcptto 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 @@ -87,12 +88,17 @@ plugins/dns_whitelist_soft plugins/dnsbl plugins/domainkeys plugins/dont_require_anglebrackets +plugins/dspam plugins/greylisting +plugins/headers +plugins/helo plugins/help plugins/hosts_allow plugins/http_config plugins/ident/geoip plugins/ident/p0f +plugins/karma +plugins/karma_tool plugins/logging/adaptive plugins/logging/apache plugins/logging/connection_id @@ -102,6 +108,7 @@ plugins/logging/syslog plugins/logging/transaction_id plugins/logging/warn plugins/milter +plugins/naughty plugins/noop_counter plugins/parse_addr_withhelo plugins/queue/exim-bsmtp @@ -111,9 +118,12 @@ plugins/queue/qmail-queue plugins/queue/smtp-forward plugins/quit_fortune plugins/random_error +plugins/rcpt_map plugins/rcpt_ok plugins/rcpt_regexp +plugins/relay plugins/require_resolvable_fromhost +plugins/resolvable_fromhost plugins/rhsbl plugins/sender_permitted_from plugins/spamassassin @@ -137,24 +147,52 @@ README README.plugins run STATUS +t/01-syntax.t +t/02-pod.t t/addresses.t +t/auth.t t/config.t +t/config/badhelo +t/config/badrcptto +t/config/dnsbl_allow +t/config/dnsbl_zones +t/config/flat_auth_pw +t/config/invalid_resolvable_fromhost +t/config/norelayclients +t/config/plugins +t/config/rcpthosts +t/config/relayclients t/helo.t t/misc.t t/plugin_tests.t +t/plugin_tests/auth/auth_checkpassword 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/badmailfrom +t/plugin_tests/check_badmailfromto +t/plugin_tests/badrcptto +t/plugin_tests/check_earlytalker +t/plugin_tests/count_unrecognized_commands t/plugin_tests/dnsbl +t/plugin_tests/dspam +t/plugin_tests/greylisting +t/plugin_tests/headers +t/plugin_tests/helo t/plugin_tests/ident/geoip +t/plugin_tests/ident/p0f t/plugin_tests/rcpt_ok +t/plugin_tests/relay +t/plugin_tests/require_resolvable_fromhost +t/plugin_tests/sender_permitted_from +t/plugin_tests/spamassassin +t/plugin_tests/virus/clamdscan t/qpsmtpd-address.t t/rset.t t/tempstuff.t t/Test/Qpsmtpd.pm t/Test/Qpsmtpd/Plugin.pm +UPGRADING From 98c548751834bf96b2e73fc6028a275f820753a5 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Jun 2012 00:18:40 -0400 Subject: [PATCH 037/352] SMTP.pm: test if unrec cmd is set (suppress warning) and decrease log message priority in rcpt_response --- lib/Qpsmtpd/SMTP.pm | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index 5394646..4247503 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -47,8 +47,13 @@ sub command_counter { } sub dispatch { - my $self = shift; - my ($cmd) = lc shift; + my $self = shift; + my ($cmd) = shift; + if ( ! $cmd ) { + $self->run_hooks("unrecognized_command", '', @_); + return 1; + }; + $cmd = lc $cmd; $self->{_counter}++; @@ -304,13 +309,12 @@ sub mail { $self->reset_transaction; - unless ($self->connection->hello) { + if ( ! $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 { @@ -451,13 +455,13 @@ sub rcpt_respond { } elsif ($rc == DENY_DISCONNECT) { $msg->[0] ||= 'delivery denied'; - $self->log(LOGINFO, "delivery denied (@$msg)"); + $self->log(LOGDEBUG, "delivery denied (@$msg)"); $self->respond(550, @$msg); $self->disconnect; } elsif ($rc == DENYSOFT_DISCONNECT) { $msg->[0] ||= 'relaying denied'; - $self->log(LOGINFO, "delivery denied (@$msg)"); + $self->log(LOGDEBUG, "delivery denied (@$msg)"); $self->respond(421, @$msg); $self->disconnect; } From 12b4c6a02a0696abb6a653fdd97cde9114334bb7 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Jun 2012 00:32:40 -0400 Subject: [PATCH 038/352] bogus_bounce: added logging and rejection handling --- plugins/check_bogus_bounce | 69 ++++++++++++++------------------------ 1 file changed, 26 insertions(+), 43 deletions(-) diff --git a/plugins/check_bogus_bounce b/plugins/check_bogus_bounce index 6bbf29c..70e5de0 100644 --- a/plugins/check_bogus_bounce +++ b/plugins/check_bogus_bounce @@ -32,13 +32,9 @@ Deny with a soft error code. =back -=cut - =head1 AUTHOR -Steve Kemp --- -http://steve.org.uk/Software/qpsmtpd/ +2010 - Steve Kemp - http://steve.org.uk/Software/qpsmtpd/ =cut @@ -51,23 +47,22 @@ Look for our single expected argument and configure "action" appropriately. =cut sub register { - my ($self, $qp, $arg, @nop) = (@_); + my ($self, $qp) = (shift, shift); - # - # Default behaviour is to merely log. - # - $self->{_action} = "log"; + if ( @_ % 2 ) { + $self->{_args}{action} = shift; + } + else { + $self->{_args} = { @_ }; + }; - # - # 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"; - } + if ( ! defined $self->{_args}{reject} ) { + $self->{_args}{reject} = 0; # legacy default + }; + + # we only need to check for deferral, default is DENY + if ( $self->{_args}{action} =~ /soft/i ) { + $self->{_args}{reject_type} = 'temp'; } } @@ -88,39 +83,27 @@ sub hook_data_post { # Find the sender, and return unless it wasn't a bounce. # my $sender = $transaction->sender->address || undef; - return DECLINED unless ($sender eq "<>"); + if ( $sender && $sender ne '<>') { + $self->log(LOGINFO, "pass, not a null sender"); + return DECLINED; + }; # # Get the recipients. # my @to = $transaction->recipients || (); - return DECLINED unless (scalar @to > 1); + if (scalar @to == 1) { + $self->log(LOGINFO, "pass, only 1 recipient"); + return DECLINED; + }; # - # OK at this point we know: + # 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?"); - } + $self->log(LOGINFO, "fail, bogus bounce for :" . join(',', @to)); - # - # All done; allow this to proceed - # - return DECLINED; + $self->get_reject( "fail, this is a bogus bounce" ); } From fb4690ab431c1ae05653e81014d86307ce8c9d2e Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Jun 2012 00:37:54 -0400 Subject: [PATCH 039/352] earlytalker: updated for consistent note accessor --- plugins/check_earlytalker | 27 ++++++++++----------------- 1 file changed, 10 insertions(+), 17 deletions(-) diff --git a/plugins/check_earlytalker b/plugins/check_earlytalker index b4b8e95..892d514 100644 --- a/plugins/check_earlytalker +++ b/plugins/check_earlytalker @@ -131,7 +131,7 @@ sub apr_connect_handler { 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); + $self->connection->notes('earlytalker', 1); return DECLINED; }; return $self->log_and_deny(); @@ -172,7 +172,8 @@ sub connect_handler { return $self->log_and_deny(); }; - $self->qp->connection->notes('earlytalker', 1); + $self->connection->notes('earlytalker', 1); + $self->connection->notes('karma', -1); return DECLINED; } @@ -194,7 +195,7 @@ sub data_handler { sub log_and_pass { my $self = shift; my $ip = $self->qp->connection->remote_ip || 'remote host'; - $self->log(LOGINFO, "pass: $ip said nothing spontaneous"); + $self->log(LOGINFO, "pass, $ip said nothing spontaneous"); return DECLINED; } @@ -202,27 +203,19 @@ 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"); + $self->connection->notes('earlytalker', 1); - return ( $self->get_reject_type(), $msg ) if $self->{_args}{reject}; - return DECLINED; + my $log_mess = "fail, $ip started talking before we said hello"; + my $smtp_msg = 'Connecting host started transmitting before SMTP greeting'; + + return $self->get_reject( $smtp_msg, $log_mess ); } sub mail_handler { my ($self, $transaction) = @_; - return DECLINED unless $self->qp->connection->notes('earlytalker'); + return DECLINED unless $self->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; -}; From e9395d6a79936175fc623df7048c4d0169461b4b Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Jun 2012 00:38:58 -0400 Subject: [PATCH 040/352] loop: max loops was sometimes not set --- plugins/check_loop | 1 + 1 file changed, 1 insertion(+) diff --git a/plugins/check_loop b/plugins/check_loop index 5ffa608..634c126 100644 --- a/plugins/check_loop +++ b/plugins/check_loop @@ -35,6 +35,7 @@ sub init { if ( $self->{_max_hops} !~ /^\d+$/ ) { $self->log(LOGWARN, "Invalid max_hops value -- using default"); + $self->{_max_hops} = 100; } $self->log(LOGWARN, "Ignoring additional arguments") if @args > 1; } From b53bd08540b07d23ca50b8cb05f8a174401c9f66 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Jun 2012 00:40:02 -0400 Subject: [PATCH 041/352] connection_time: add compat with tcpserver deployment model --- plugins/connection_time | 20 ++++++++------------ 1 file changed, 8 insertions(+), 12 deletions(-) diff --git a/plugins/connection_time b/plugins/connection_time index 9cff7f9..2c9d8f7 100644 --- a/plugins/connection_time +++ b/plugins/connection_time @@ -31,7 +31,7 @@ use Qpsmtpd::Constants; use Time::HiRes qw(gettimeofday tv_interval); sub register { - my ($self, $qp) = shift, shift; + my ($self, $qp) = (shift, shift); if ( @_ == 1 ) { # backwards compatible $self->{_args}{loglevel} = shift; if ( $self->{_args}{loglevel} =~ /\D/ ) { @@ -45,21 +45,17 @@ sub register { else { $self->{_args} = { @_ }; # named args, inherits loglevel }; +# pre-connection is not available in the tcpserver deployment model. +# duplicate the handler, so it works both ways with no redudant methods + $self->register_hook('pre-connection', 'connect_handler'); + $self->register_hook('connect', 'connect_handler'); } -sub hook_pre_connection { +sub connect_handler { my $self = shift; + return DECLINED if ( $self->hook_name eq 'connect' && defined $self->{_connection_start} ); $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} ); + $self->log(LOGDEBUG, "started at " . scalar gettimeofday ); return (DECLINED); } From 8156341c6e3788a18f64fcc13e8ff2cfadc45b90 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Jun 2012 00:40:42 -0400 Subject: [PATCH 042/352] unrec: fixed variable assignment --- plugins/count_unrecognized_commands | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/count_unrecognized_commands b/plugins/count_unrecognized_commands index 3060e61..5cb6d69 100644 --- a/plugins/count_unrecognized_commands +++ b/plugins/count_unrecognized_commands @@ -22,7 +22,7 @@ use warnings; use Qpsmtpd::Constants; sub register { - my ($self, $qp ) = shift, shift; + my ($self, $qp ) = (shift, shift); $self->{_unrec_cmd_max} = shift || 4; From 3e223ef9dc9298cd97d834558c0c10e74475ef5d Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Jun 2012 00:43:20 -0400 Subject: [PATCH 043/352] dns_whitelist_soft: tiny tweaks of little consequence --- plugins/dns_whitelist_soft | 90 +++++++++++++++++++++----------------- 1 file changed, 49 insertions(+), 41 deletions(-) diff --git a/plugins/dns_whitelist_soft b/plugins/dns_whitelist_soft index 6ca699b..dc3785d 100644 --- a/plugins/dns_whitelist_soft +++ b/plugins/dns_whitelist_soft @@ -1,4 +1,5 @@ #!perl -w + =head1 NAME dns_whitelist_soft - dns-based whitelist override for other qpsmtpd plugins @@ -48,6 +49,17 @@ based on the 'whitelist' plugin by Devin Carraway . =cut +use strict; +use warnings; + +use Qpsmtpd::Constants; + +sub register { + my ( $self, $qp ) = (shift, shift); + $self->log(LOGERROR, "Bad arguments") if @_ % 2; + $self->{_args} = { @_ }; +} + sub hook_connect { my ($self, $transaction) = @_; @@ -58,7 +70,7 @@ sub hook_connect { return DECLINED unless %whitelist_zones; - my $reversed_ip = join(".", reverse(split(/\./, $remote_ip))); + 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 @@ -68,11 +80,10 @@ sub hook_connect { for my $dnsbl (keys %whitelist_zones) { $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl in the background"); - $sel->add($res->bgsend("$reversed_ip.$dnsbl", "TXT")); + $sel->add($res->bgsend("$reversed_ip.$dnsbl", 'TXT')); } $self->connection->notes('whitelist_sockets', $sel); - return DECLINED; } @@ -81,55 +92,54 @@ sub process_sockets { my $conn = $self->connection; - return $conn->notes('whitelisthost') - if $conn->notes('whitelisthost'); + return $conn->notes('whitelisthost') if $conn->notes('whitelisthost'); my $res = new Net::DNS::Resolver; - my $sel = $conn->notes('whitelist_sockets') or return ""; - - my $result; + my $sel = $conn->notes('whitelist_sockets') or return ''; $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 ...") ; + $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 $result; - my $whitelist; + for my $socket (@ready) { + my $query = $res->bgread($socket); + $sel->remove($socket); + undef $socket; - 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"; - } + my $whitelist; - if ($result) { - #kill any other pending I/O - $conn->notes('whitelist_sockets', undef); - return $conn->notes('whitelisthost', $result); + 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) + if $res->errorstring ne "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 @@ -142,12 +152,11 @@ sub process_sockets { $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 $ip = $self->qp->connection->remote_ip or return (DECLINED); my $note = $self->process_sockets; if ( $note ) { $self->log(LOGNOTICE,"Host $ip is whitelisted: $note"); @@ -155,4 +164,3 @@ sub hook_rcpt { return DECLINED; } -1; From efc3d1b914e67606222caa057416ed7559fbe928 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Jun 2012 00:43:53 -0400 Subject: [PATCH 044/352] greylisting: POD correction --- plugins/greylisting | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/greylisting b/plugins/greylisting index 462ea63..158404e 100644 --- a/plugins/greylisting +++ b/plugins/greylisting @@ -17,7 +17,7 @@ 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. +whitelisted senders, TLS connections, p0f matches, and geoip matches. =head1 TRIPLETS From 5dbc47ed1ac23b88079d3b87c25badfc4d7d66ba Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Jun 2012 00:45:18 -0400 Subject: [PATCH 045/352] hosts_allow: better logging --- plugins/hosts_allow | 44 +++++++++++++++++++++++++++----------------- 1 file changed, 27 insertions(+), 17 deletions(-) diff --git a/plugins/hosts_allow b/plugins/hosts_allow index 77aafd1..550504c 100644 --- a/plugins/hosts_allow +++ b/plugins/hosts_allow @@ -82,24 +82,34 @@ sub hook_pre_connection { } } - 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); - } - } + my @r = $self->in_hosts_allow( $remote ); + return @r if scalar @r; $self->log( LOGDEBUG, "pass" ); return (DECLINED); } + +sub in_hosts_allow { + my $self = shift; + my $remote = shift; + + foreach ( $self->qp->config('hosts_allow') ) { + s/^\s*//; # trim leading whitespace + 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); + } + } + + return; +}; From 4761e3f41ade768e43c8ee5f56f524d2071fc04a Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Jun 2012 00:46:39 -0400 Subject: [PATCH 046/352] naughty: support reject_type set by original plugin that marked the connection as naughty --- plugins/naughty | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/plugins/naughty b/plugins/naughty index f7ae28f..5283367 100644 --- a/plugins/naughty +++ b/plugins/naughty @@ -7,8 +7,8 @@ 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. +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, @@ -44,7 +44,7 @@ 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 +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 @@ -88,7 +88,8 @@ from detecting address validity. =head2 reject_type [ temp | perm | disconnect ] -What type of rejection should be sent? See docs/config.pod +If the plugin that set naughty didn't specify, what type of rejection should +be sent? See docs/config.pod =head2 loglevel @@ -99,7 +100,7 @@ Adjust the quantity of logging for this plugin. See docs/logging.pod Here's how to use naughty and get_reject in your plugin: sub register { - my ($self,$qp) = shift, shift; + my ($self, $qp) = (shift, shift); $self->{_args} = { @_ }; $self->{_args}{reject} ||= 'naughty'; }; @@ -123,14 +124,14 @@ use warnings; use Qpsmtpd::Constants; sub register { - my ($self, $qp ) = shift, shift; + 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 } + my %hooks = map { $_ => 1 } qw/ connect mail rcpt data data_post hook_queue_post /; if ( ! $hooks{$reject} ) { @@ -156,6 +157,8 @@ sub naughty { return DECLINED; }; $self->log(LOGINFO, "disconnecting"); - return ( $self->get_reject_type(), $naughty ); + my $type = $self->get_reject_type( 'disconnect', + $self->connection->notes('naughty_reject_type') ); + return ( $type, $naughty ); }; From dc61deb9aa2bf9652fe2668a80cd7dc512cfd2b5 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Jun 2012 00:47:46 -0400 Subject: [PATCH 047/352] parse_addr_withhelo: consistency additions --- plugins/parse_addr_withhelo | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/plugins/parse_addr_withhelo b/plugins/parse_addr_withhelo index 49c8a0f..2d70e7b 100644 --- a/plugins/parse_addr_withhelo +++ b/plugins/parse_addr_withhelo @@ -17,6 +17,11 @@ parameters is done. =cut +use strict; +use warnings; + +use Qpsmtpd::Constants; + sub hook_mail_parse { my $self = shift; return (OK, \&_parse) if ($self->qp->connection->hello eq 'helo'); From 8f40e2ef9a41f25f4dacfd99136396e7cb6452bc Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Jun 2012 00:52:05 -0400 Subject: [PATCH 048/352] spf: remove rcpt hook, process to completion during from --- plugins/sender_permitted_from | 45 +++++++++++++---------------------- 1 file changed, 17 insertions(+), 28 deletions(-) diff --git a/plugins/sender_permitted_from b/plugins/sender_permitted_from index 553ea76..7841a03 100644 --- a/plugins/sender_permitted_from +++ b/plugins/sender_permitted_from @@ -46,8 +46,7 @@ The reject options are modeled after, and aim to match the functionality of thos =head1 AUTHOR -Matt Simerson - 2002 - increased policy options from 3 to 6 - +Matt Simerson - 2012 - increased policy options from 3 to 6 Matt Simerson - 2011 - rewrote using Mail::SPF Matt Sergeant - 2003 - initial plugin @@ -64,7 +63,7 @@ sub register { my ($self, $qp, %args) = @_; eval 'use Mail::SPF'; if ( $@ ) { - warn "skip: plugin disabled, could not find Mail::SPF\n"; + warn "skip: plugin disabled, is Mail::SPF installed?\n"; $self->log(LOGERROR, "skip: plugin disabled, is Mail::SPF installed?"); return; }; @@ -76,28 +75,31 @@ sub register { if ( ! $self->{_args}{reject} && $self->qp->config('spfbehavior') ) { $self->{_args}{reject} = $self->qp->config('spfbehavior'); }; + $self->register_hook('mail', 'mail_handler'); + $self->register_hook('data_post', 'data_post_handler'); } -sub hook_mail { +sub mail_handler { 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" ); + $self->log( LOGINFO, "skip, null sender" ); return (DECLINED, "SPF - null sender"); }; if ( $self->is_in_relayclients() ) { + $self->log( LOGINFO, "skip, in relayclients" ); return (DECLINED, "SPF - relaying permitted"); }; + if ( ! $self->{_args}{reject} ) { + $self->log( LOGINFO, "skip, reject disabled" ); + return (DECLINED); + }; + my $client_ip = $self->qp->connection->remote_ip; my $from = $sender->user . '@' . lc($sender->host); my $helo = $self->qp->connection->hello_host; @@ -118,21 +120,10 @@ sub hook_mail { my $spf_server = Mail::SPF::Server->new(); my $request = Mail::SPF::Request->new(%req_params); - my $result = $spf_server->process($request); + my $result = $spf_server->process($request) or return DECLINED; $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}; @@ -172,11 +163,11 @@ sub hook_rcpt { return (DENYSOFT, "SPF - $code: $why") if $reject >= 2; } - $self->log(LOGDEBUG, "result for $rcpt->address was $code: $why"); + $self->log(LOGDEBUG, "SPF from $from was $code: $why"); return (DECLINED, "SPF - $code: $why"); } -sub hook_data_post { +sub data_post_handler { my ($self, $transaction) = @_; my $result = $transaction->notes('spfquery') or return DECLINED; @@ -188,7 +179,7 @@ sub hook_data_post { return DECLINED; }; - $transaction->header->add('Received-SPF' => $result->received_spf_header, 0); + $transaction->header->add('Received-SPF', $result->received_spf_header, 0); return DECLINED; } @@ -196,8 +187,6 @@ sub hook_data_post { 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'); @@ -206,7 +195,7 @@ sub is_in_relayclients { while ($client_ip) { if ( exists $relay_clients{$client_ip} || exists $more_relay_clients->{$client_ip} ) { - $self->log( LOGDEBUG, "skip: relaying permitted (config)" ); + $self->log( LOGDEBUG, "skip, IP in relayclients" ); return 1; }; $client_ip =~ s/\d+\.?$// or last; # strip off another 8 bits From cdf1e9d782fe8359363516ce6ee87f626deb92c9 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Jun 2012 00:53:18 -0400 Subject: [PATCH 049/352] tls: log improvement --- plugins/tls | 13 +++++-------- 1 file changed, 5 insertions(+), 8 deletions(-) diff --git a/plugins/tls b/plugins/tls index df12f65..8991230 100644 --- a/plugins/tls +++ b/plugins/tls @@ -59,7 +59,7 @@ and put a suitable string in config/tls_ciphers (e.g. "DEFAULT" or =cut -use IO::Socket::SSL 0.98; # qw(debug1 debug2 debug3 debug4); +use IO::Socket::SSL 0.98; sub init { my ($self, $qp, $cert, $key, $ca) = @_; @@ -75,7 +75,7 @@ sub init { $self->tls_ca($ca); $self->tls_ciphers($self->qp->config('tls_ciphers') || 'HIGH'); - $self->log(LOGINFO, "ciphers: ".$self->tls_ciphers); + $self->log(LOGDEBUG, "ciphers: ".$self->tls_ciphers); local $^W; # this bit is very noisy... my $ssl_ctx = IO::Socket::SSL::SSL_Context->new( @@ -111,8 +111,7 @@ sub hook_ehlo { 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 ||= []; + my $cap = $transaction->notes('capabilities') || []; push @$cap, 'STARTTLS'; $transaction->notes('tls_enabled', 1); $transaction->notes('capabilities', $cap); @@ -193,10 +192,8 @@ sub _convert_to_ssl { }; if ($@) { return 0; - } - else { - return 1; - } + }; + return 1; } sub _convert_to_ssl_async { From 781e3ada4d803576a42b86fc3d2769675f5202c9 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Jun 2012 00:53:46 -0400 Subject: [PATCH 050/352] updated SPF tests --- t/plugin_tests/sender_permitted_from | 20 ++++++++------------ 1 file changed, 8 insertions(+), 12 deletions(-) diff --git a/t/plugin_tests/sender_permitted_from b/t/plugin_tests/sender_permitted_from index a69f5b0..342586c 100644 --- a/t/plugin_tests/sender_permitted_from +++ b/t/plugin_tests/sender_permitted_from @@ -13,25 +13,21 @@ sub register_tests { eval 'use Mail::SPF'; return if $@; - $self->register_test('test_is_relayclient', 3); + $self->register_test('test_is_in_relayclients', 2); $self->register_test('test_is_special_recipient', 5); } -sub test_is_relayclient { +sub test_is_in_relayclients { 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->remote_ip('192.1.7.8'); + ok( ! $self->is_in_relayclients( $transaction ), "is_in_relayclients -"); $self->qp->connection->relay_client(0); - $self->qp->connection->remote_ip('192.168.7.5'); + $self->qp->connection->remote_ip('192.0.7.5'); my $client_ip = $self->qp->connection->remote_ip; - ok( $client_ip, "sender_permitted_from, relayclients ($client_ip)"); + ok( $client_ip, "relayclients ($client_ip)"); }; sub test_is_special_recipient { @@ -40,11 +36,11 @@ sub test_is_special_recipient { my $transaction = $self->qp->transaction; my $address = Qpsmtpd::Address->new('user@example.com'); - ok( ! $self->is_special_recipient( $address ), "is_special_recipient -"); + ok( ! $self->is_special_recipient( $address ), "not special"); 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)"); + ok( $self->is_special_recipient( $address ), "special: $user"); }; }; From 0498669f4579818c23937eae68cd7224869ff8a5 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Jun 2012 00:54:27 -0400 Subject: [PATCH 051/352] rcpt_ok: shorten test messages --- t/plugin_tests/rcpt_ok | 29 +++++++++++++---------------- 1 file changed, 13 insertions(+), 16 deletions(-) diff --git a/t/plugin_tests/rcpt_ok b/t/plugin_tests/rcpt_ok index a7fad27..3faaf0c 100644 --- a/t/plugin_tests/rcpt_ok +++ b/t/plugin_tests/rcpt_ok @@ -22,15 +22,15 @@ sub test_hook_rcpt { my $address = Qpsmtpd::Address->parse(''); my ($r, $mess) = $self->hook_rcpt( $transaction, $address ); - cmp_ok( $r, '==', OK, "hook_rcpt, localhost"); + cmp_ok( $r, '==', OK, "localhost"); $address = Qpsmtpd::Address->parse(''); ($r, $mess) = $self->hook_rcpt( $transaction, $address ); - cmp_ok( $r, '==', DENY, "hook_rcpt, example.com"); + cmp_ok( $r, '==', DENY, "example.com"); $self->qp->connection->relay_client(1); ($r, $mess) = $self->hook_rcpt( $transaction, $address ); - cmp_ok( $r, '==', OK, "hook_rcpt, example.com"); + cmp_ok( $r, '==', OK, "example.com"); $self->qp->connection->relay_client(0); }; @@ -57,48 +57,45 @@ sub test_is_in_morercpthosts { my $ref = $self->qp->config('morercpthosts', 'map'); my ($domain) = keys %$ref; if ( $domain ) { - ok( $self->is_in_morercpthosts( $domain ), "is_in_morercpthosts, $domain"); + ok( $self->is_in_morercpthosts( $domain ), "$domain"); } else { ok(1, "is_in_morercpthosts (skip, no entries)" ); }; - ok( ! $self->is_in_morercpthosts( 'example.com' ), "is_in_morercpthosts -"); + ok( ! $self->is_in_morercpthosts( 'example.com' ), "missing -"); }; 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, +" ); + cmp_ok( $self->get_rcpt_host( $address ), 'eq', 'example.com', "+" ); $address = Qpsmtpd::Address->parse(''); - cmp_ok( $self->get_rcpt_host( $address ), 'eq', 'example.com', - "get_rcpt_host, +" ); + cmp_ok( $self->get_rcpt_host( $address ), 'eq', 'example.com', "+" ); $address = Qpsmtpd::Address->parse(''); - cmp_ok( $self->get_rcpt_host( $address ), 'eq', 'example.com', - "get_rcpt_host, +" ); + cmp_ok( $self->get_rcpt_host( $address ), 'eq', 'example.com', "+" ); $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 +" ); + "special postmaster +" ); } else { - ok( 1, "get_rcpt_host, special postmaster + ($local_hostname)" ); + ok( 1, "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" ); + ok( ! $self->get_rcpt_host( $address ), "missing host" ); $address = Qpsmtpd::Address->parse('<>'); - ok( ! $self->get_rcpt_host( $address ), "get_rcpt_host, null recipient" ); + ok( ! $self->get_rcpt_host( $address ), "null recipient" ); $address = Qpsmtpd::Address->parse('<@example.com>'); - ok( ! $self->get_rcpt_host( $address ), "get_rcpt_host, missing user" ); + ok( ! $self->get_rcpt_host( $address ), "missing user" ); }; From 6afcc54f4bff0d3b164d9e46ebb4aedfed01fef9 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Jun 2012 00:56:05 -0400 Subject: [PATCH 052/352] MANIFEST.SKIP: ignore test greylist db --- MANIFEST.SKIP | 1 + 1 file changed, 1 insertion(+) diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP index 704cede..6369d37 100644 --- a/MANIFEST.SKIP +++ b/MANIFEST.SKIP @@ -34,3 +34,4 @@ packaging ^config/ ^supervise/ ^ssl/ +^t/config/greylist From 8c3377f02620852d94488334f6736fbef59fd459 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Jun 2012 00:57:04 -0400 Subject: [PATCH 053/352] qmail-queue: a few tweaks and a lot of whitespace --- plugins/queue/qmail-queue | 153 +++++++++++++++++++------------------- 1 file changed, 78 insertions(+), 75 deletions(-) diff --git a/plugins/queue/qmail-queue b/plugins/queue/qmail-queue index de639eb..b50b73a 100644 --- a/plugins/queue/qmail-queue +++ b/plugins/queue/qmail-queue @@ -20,96 +20,99 @@ If set the environment variable QMAILQUEUE overrides this setting. =cut + +use strict; +use warnings; + +use Qpsmtpd::Constants; use POSIX (); sub register { - my ($self, $qp, @args) = @_; + 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"; - } + if (@args > 0) { + $self->{_queue_exec} = $args[0]; + $self->log(LOGWARN, "WARNING: Ignoring additional arguments.") if @args > 1; + } - $self->{_queue_exec} = $ENV{QMAILQUEUE} if $ENV{QMAILQUEUE}; + $self->{_queue_exec} ||= ($ENV{QMAIL} || '/var/qmail') . "/bin/qmail-queue"; + $self->{_queue_exec} = $ENV{QMAILQUEUE} if $ENV{QMAILQUEUE}; } sub hook_queue { - my ($self, $transaction) = @_; + 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(); +# 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"; - not defined $child and die("Could not fork"); + local $SIG{PIPE} = sub { die 'SIGPIPE' }; + my $child = fork(); - if ($child) { - # Parent - my $oldfh = select(MESSAGE_WRITER); $| = 1; - select(ENVELOPE_WRITER); $| = 1; - select($oldfh); + ! defined $child and die "Could not fork"; - close MESSAGE_READER or die("close msg reader fault"); - close ENVELOPE_READER or die("close envelope reader fault"); + if ($child) { +# Parent + my $oldfh = select MESSAGE_WRITER; $| = 1; + select ENVELOPE_WRITER; $| = 1; + select $oldfh; - $transaction->header->print(\*MESSAGE_WRITER); - $transaction->body_resetpos; - while (my $line = $transaction->body_getline) { - print MESSAGE_WRITER $line; + 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"); } - close MESSAGE_WRITER; + elsif (defined $child) { +# Child + close MESSAGE_WRITER or exit 1; + close ENVELOPE_WRITER or exit 2; - 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)"); +# 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; + } - 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 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 } - - # 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 - } } From 51d2854764017dadcb26baee81ea8a8ea1b30d28 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Jun 2012 03:04:02 -0400 Subject: [PATCH 054/352] badmailfromto: fixed tests (rename cleanups) --- t/config/plugins | 1 + t/plugin_tests/{check_badmailfromto => badmailfromto} | 0 2 files changed, 1 insertion(+) rename t/plugin_tests/{check_badmailfromto => badmailfromto} (100%) diff --git a/t/config/plugins b/t/config/plugins index 41ff2fb..44bbe28 100644 --- a/t/config/plugins +++ b/t/config/plugins @@ -39,6 +39,7 @@ resolvable_fromhost rhsbl dnsbl badmailfrom +badmailfromto badrcptto helo diff --git a/t/plugin_tests/check_badmailfromto b/t/plugin_tests/badmailfromto similarity index 100% rename from t/plugin_tests/check_badmailfromto rename to t/plugin_tests/badmailfromto From 334ec769a5ada3d38dc11f586a4e24f9a17543b1 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Jun 2012 03:06:24 -0400 Subject: [PATCH 055/352] earlytalker: log message cleanup --- plugins/check_earlytalker | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/check_earlytalker b/plugins/check_earlytalker index 892d514..5a8ef3d 100644 --- a/plugins/check_earlytalker +++ b/plugins/check_earlytalker @@ -206,7 +206,7 @@ sub log_and_deny { $self->connection->notes('earlytalker', 1); - my $log_mess = "fail, $ip started talking before we said hello"; + my $log_mess = "$ip started talking before we said hello"; my $smtp_msg = 'Connecting host started transmitting before SMTP greeting'; return $self->get_reject( $smtp_msg, $log_mess ); From 21437011131e123db97b46b74ed76f8428bdb147 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Jun 2012 03:06:53 -0400 Subject: [PATCH 056/352] log/run: increase default log retention --- log/run | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/log/run b/log/run index 5a4d84b..5b3b4b6 100755 --- a/log/run +++ b/log/run @@ -1,5 +1,5 @@ #! /bin/sh export LOGDIR=./main mkdir -p $LOGDIR -exec multilog t s1000000 n20 $LOGDIR +exec multilog t s10000000 n20 $LOGDIR From a6cfb68392039e840bc7548c33747369fd6a39d4 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Jun 2012 03:10:48 -0400 Subject: [PATCH 057/352] dnsbl,rhsbl: process DNS immediately and use naughty for deferred rejection --- plugins/dnsbl | 170 ++++++++++++------------------------------ plugins/rhsbl | 203 +++++++++++++++++++++----------------------------- 2 files changed, 130 insertions(+), 243 deletions(-) diff --git a/plugins/dnsbl b/plugins/dnsbl index 977424f..b417bd4 100644 --- a/plugins/dnsbl +++ b/plugins/dnsbl @@ -176,44 +176,61 @@ sub hook_connect { my $remote_ip = $self->qp->connection->remote_ip; my $reversed_ip = join('.', reverse(split(/\./, $remote_ip))); - $self->initiate_lookups( \%dnsbl_zones, $reversed_ip ); - - my $message = $self->process_sockets or do { - $self->log(LOGINFO, 'pass'); - return DECLINED; - }; - - return $self->get_reject( $message ); -}; - -sub initiate_lookups { - my ($self, $zones, $reversed_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 %$zones) { + 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($zones->{$dnsbl})) { - $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for A record in the background"); - $sel->add($res->bgsend("$reversed_ip.$dnsbl")); + my $query; + if ( defined $dnsbl_zones{$dnsbl} ) { + $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for A record"); + $query = $res->query("$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->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for TXT record"); + $query = $res->query("$reversed_ip.$dnsbl", "TXT"); + } + + if ( ! $query) { + if ( $res->errorstring ne "NXDOMAIN" ) { + $self->log(LOGERROR, "$dnsbl query failed: ", $res->errorstring); + }; + next; + }; + + my $a_record = 0; + my $result; + foreach my $rr ($query->answer) { + if ( $rr->type eq 'A' ) { + $result = $rr->name; + $self->log(LOGDEBUG, "found A for $result with IP " . $rr->address); + } + elsif ($rr->type eq 'TXT') { + $self->log(LOGDEBUG, "found TXT, " . $rr->txtdata); + $result = $rr->txtdata; + }; + + next if ! $result; + + if ( ! $dnsbl ) { ($dnsbl) = ($result =~ m/(?:\d+\.){4}(.*)/); }; + if ( ! $dnsbl ) { $dnsbl = $result; }; + + if ($a_record) { + if (defined $dnsbl_zones{$dnsbl}) { + my $smtp_msg = $dnsbl_zones{$dnsbl}; + $smtp_msg =~ s/%IP%/$remote_ip/g; + return $self->get_reject( $smtp_msg, $dnsbl ); + } + return $self->get_reject( "Blocked by $dnsbl" ); + } + + return $self->get_reject( $result, $dnsbl ); } } - $self->connection->notes('dnsbl_sockets', $sel); - $self->connection->notes('dnsbl_domains', $dom); + $self->log(LOGINFO, 'pass'); + return DECLINED; }; sub is_set_rblsmtpd { @@ -236,7 +253,7 @@ sub is_set_rblsmtpd { }; sub ip_whitelisted { - my $self = shift; + my ($self) = @_; my $remote_ip = $self->qp->connection->remote_ip; @@ -256,93 +273,6 @@ sub return_env_message { return ( $self->get_reject_type(), join(' ', $msg, $result)); } -sub process_sockets { - my ($self) = @_; - - my $conn = $self->qp->connection; - - return $conn->notes('dnsbl') if $conn->notes('dnsbl'); - - my $sel = $conn->notes('dnsbl_sockets') or return ''; - my $dom = $conn->notes('dnsbl_domains'); - my $remote_ip = $self->qp->connection->remote_ip; - - my %dnsbl_zones = map { (split /:/, $_, 2)[0,1] } $self->qp->config('dnsbl_zones'); - - 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) = @_; @@ -356,11 +286,3 @@ sub hook_rcpt { return DECLINED; } -sub hook_disconnect { - my ($self, $transaction) = @_; - - $self->connection->notes('dnsbl_sockets', undef); - - return DECLINED; -} - diff --git a/plugins/rhsbl b/plugins/rhsbl index 5706f0c..3f08aac 100644 --- a/plugins/rhsbl +++ b/plugins/rhsbl @@ -31,146 +31,111 @@ 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; - } + my ($self, $qp ) = (shift, shift); + + my $denial; + if ( @_ == 1 ) { + $denial = shift; + if ( defined $denial && $denial =~ /^disconnect$/i ) { + $self->{_args}{reject_type} = 'disconnect'; + } + else { + $self->{_args}{reject_type} = 'perm'; + } + } + else { + $self->{_args} = { @_ }; + }; } sub hook_mail { - my ($self, $transaction, $sender, %param) = @_; + my ($self, $transaction, $sender, %param) = @_; return DECLINED if $self->is_immune(); if ($sender->format eq '<>') { - $self->log(LOGINFO, 'skip, null sender'); + $self->log(LOGINFO, 'pass, null sender'); return DECLINED; }; - my %rhsbl_zones = map { (split /\s+/, $_, 2)[0,1] } $self->qp->config('rhsbl_zones'); + my %rhsbl_zones = $self->populate_zones() or return DECLINED; - if ( ! %rhsbl_zones ) { - $self->log(LOGINFO, 'skip, no zones'); - return DECLINED; - }; + my $res = $self->init_resolver(); - 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; + my @hosts = $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}; + for my $rhsbl (keys %rhsbl_zones) { + my $query; +# 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"); + $query = $res->query("$host.$rhsbl"); + } else { + $self->log(LOGDEBUG, "Checking $host.$rhsbl for TXT record"); + $query = $res->query("$host.$rhsbl", 'TXT'); + } + + if ( ! $query) { + if ( $res->errorstring ne 'NXDOMAIN' ) { + $self->log(LOGCRIT, "query failed: ", $res->errorstring); + }; + next; + }; + + my $result; + foreach my $rr ($query->answer) { + $self->log(LOGDEBUG, 'got an ' . $rr->type . ' record ' . $rr->name); + if ($rr->type eq 'A') { + $self->log(LOGDEBUG, "A record found for $result with IP " . $rr->address); + $result = $rr->name; + } + elsif ($rr->type eq 'TXT') { + $result = $rr->txtdata; + $self->log(LOGDEBUG, "TXT record found: " . $rr->txtdata); + }; + + if ( $result ) { + $self->log(LOGINFO, "fail, $result"); + + my $host = $transaction->sender->host; + if ($result =~ /^$host\./ ) { + return $self->get_reject( "Mail from $host rejected because it $result" ); + }; + + my $hello = $self->qp->connection->hello_host; + return $self->get_reject( "Mail from HELO $hello rejected because it $result" ); + }; + } + } } - } - %{$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 = ''; +sub populate_zones { + my $self = shift; - return $trans->notes('rhsbl') if $trans->notes('rhsbl'); + my %rhsbl_zones + = map { (split /\s+/, $_, 2)[0,1] } + $self->qp->config('rhsbl_zones'); - my $res = new Net::DNS::Resolver; - my $sel = $trans->notes('rhsbl_sockets') or return ''; + if ( ! keys %rhsbl_zones ) { + $self->log(LOGINFO, 'pass, no zones'); + return; + }; - $self->log(LOGDEBUG, 'waiting for rhsbl dns'); + return %rhsbl_zones; +}; - # 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; -} +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} || 8; + $self->{_resolver}->tcp_timeout($timeout); + $self->{_resolver}->udp_timeout($timeout); + return $self->{_resolver}; +}; From 64b59d73c46955f9c4805c6f378781a53227c597 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Jun 2012 03:13:39 -0400 Subject: [PATCH 058/352] dnsbl test: remove hook_disconnect test --- t/plugin_tests/dnsbl | 8 -------- 1 file changed, 8 deletions(-) diff --git a/t/plugin_tests/dnsbl b/t/plugin_tests/dnsbl index 9d42665..517c220 100644 --- a/t/plugin_tests/dnsbl +++ b/t/plugin_tests/dnsbl @@ -11,7 +11,6 @@ sub register_tests { $self->register_test('test_hook_connect', 1); $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); } @@ -57,13 +56,6 @@ sub test_hook_connect { cmp_ok( $rc, '==', DENY, "connect +"); } -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; From 6654ff0150ac6f55cf6db2d2b21db8dfde6f67fc Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Jun 2012 23:04:50 -0400 Subject: [PATCH 059/352] TcpServer: assign default value during declaration --- lib/Qpsmtpd/TcpServer.pm | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/lib/Qpsmtpd/TcpServer.pm b/lib/Qpsmtpd/TcpServer.pm index 7215090..42dad62 100644 --- a/lib/Qpsmtpd/TcpServer.pm +++ b/lib/Qpsmtpd/TcpServer.pm @@ -8,7 +8,7 @@ use strict; use POSIX (); -my $has_ipv6; +my $has_ipv6 = 0; if ( eval {require Socket6;} && # INET6 prior to 2.01 will not work; sorry. @@ -17,9 +17,6 @@ if ( import Socket6; $has_ipv6=1; } -else { - $has_ipv6=0; -} sub has_ipv6 { return $has_ipv6; From 39b1668dda8065080cd615b2c86328f395181090 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 25 Jun 2012 02:41:43 -0400 Subject: [PATCH 060/352] domainkeys: add header at top of headers (not bottom) --- plugins/domainkeys | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/plugins/domainkeys b/plugins/domainkeys index 928aa05..d59cff1 100644 --- a/plugins/domainkeys +++ b/plugins/domainkeys @@ -86,7 +86,7 @@ sub data_post_handler { return DECLINED if $self->is_immune(); if ( ! $transaction->header->get('DomainKey-Signature') ) { - $self->log(LOGINFO, "skip: unsigned"); + $self->log(LOGINFO, "skip, unsigned"); return DECLINED; }; @@ -95,28 +95,28 @@ sub data_post_handler { my $message = load Mail::DomainKeys::Message( HeadString => $transaction->header->as_string, BodyReference => $body) or do { - $self->log(LOGWARN, "skip: unable to load message"), + $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"), + $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"); + $transaction->header->add("DomainKey-Status", $status, 0); + $self->log(LOGINFO, "pass, $status"); return DECLINED; }; - $self->log(LOGERROR, "fail: signature failed to verify"); + $self->log(LOGERROR, "fail, signature invalid"); return DECLINED if ! $self->{reject}; my $deny = $self->{reject_type} eq 'temp' ? DENYSOFT : DENY; - return ($deny, "DomainKeys signature failed to verify"); + return ($deny, "DomainKeys signature validation failed"); } sub get_message_status { From 60470d20a4eb456a11fefd9d2559dbfdef252f1c Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 25 Jun 2012 02:51:36 -0400 Subject: [PATCH 061/352] dspam: fixes for training dspam process_backticks now writes the entire message (headers + body) to a temp file and had dspam read that. Previously, dspam only read the body. With the new "process, then train on error" method, dspam didn't have access to the DSPAM signature (in the headers). replaced open2 with open3. Same results. Works part of the time, but not consistent, and I haven't been able to figure out why. dspam transaction note is now a hashref (was a string) parsing of dspam response via substring (was regexp) --- plugins/dspam | 152 ++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 115 insertions(+), 37 deletions(-) diff --git a/plugins/dspam b/plugins/dspam index d80551b..a71ee9b 100644 --- a/plugins/dspam +++ b/plugins/dspam @@ -235,10 +235,12 @@ sub data_post_handler { my $response = $self->dspam_process( $filtercmd, $transaction ); if ( ! $response->{result} ) { - $self->log(LOGWARN, "skip, no dspam response. Check logs for errors."); + $self->log(LOGWARN, "error, no dspam response. Check logs for errors."); return (DECLINED); }; + $transaction->notes('dspam', $response); + $self->attach_headers( $response, $transaction ); $self->autolearn( $response, $transaction ); @@ -264,37 +266,78 @@ sub select_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"; + $transaction->body_resetpos; while (my $line = $transaction->body_getline) { $message .= $line; }; $message = join(CRLF, split/\n/, $message); return $message . CRLF; }; +sub parse_response { + my $self = shift; + my $response = shift or do { + $self->log( LOGDEBUG, "missing dspam response!" ); + return; + }; + +# example DSPAM results: +# user@example.com; result="Spam"; class="Spam"; probability=1.0000; confidence=1.00; signature=N/A +# smtpd; result="Innocent"; class="Innocent"; probability=0.0023; confidence=1.00; signature=4f8dae6a446008399211546 + + #return $self->parse_response_regexp( $response ); # probably slower + + my ($user, $result, $class, $prob, $conf, $sig) = split '; ', $response; + + (undef, $result) = split '=', $result; + (undef, $class ) = split '=', $class; + (undef, $prob ) = split '=', $prob; + (undef, $conf ) = split '=', $conf; + (undef, $sig ) = split '=', $sig; + + $result = substr($result, 1, -1); # strip off quotes + $class = substr($class, 1, -1); + + return { + class => $class, + result => $result, + probability => $prob, + confidence => $conf, + signature => $sig, + }; +}; + +sub parse_response_regexp { + my ($self, $response) = @_; + + my ($result, $class, $prob, $conf, $sig) = $response =~ / + result=\"(Spam|Innocent)\";\s + class=\"(Spam|Innocent)\";\s + probability=([\d\.]+);\s + confidence=([\d\.]+);\s + signature=(.*) + /x; + + return { + class => $class, + result => $result, + probability => $prob, + confidence => $conf, + signature => $sig, + }; +}; + sub dspam_process { my ( $self, $filtercmd, $transaction ) = @_; - my $dspam_response = $self->dspam_process_backticks( $filtercmd ); - #my $dspam_response = $self->dspam_process_open2( $filtercmd, $transaction ); - #my $dspam_response = $self->dspam_process_fork( $filtercmd ); + my $response = $self->dspam_process_backticks( $filtercmd ); + #my $response = $self->dspam_process_open2( $filtercmd, $transaction ); + #my $response = $self->dspam_process_fork( $filtercmd ); - # 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 ($r, $p, $c, $s) - = $dspam_response - =~ /result=\"(Spam|Innocent)\";.*?probability=([\d\.]+); confidence=([\d\.]+); signature=(.*)/; - - return { - result => $r, - probability => $p, - confidence => $c, - signature => $s, - }; + return $self->parse_response( $response ); }; sub dspam_process_fork { @@ -322,10 +365,22 @@ sub dspam_process_fork { sub dspam_process_backticks { my ( $self, $filtercmd ) = @_; - my $filename = $self->qp->transaction->body_filename; - my $response = `$filtercmd < $filename`; chomp $response; - $self->log(LOGDEBUG, $response); - return $response; + my $transaction = $self->qp->transaction; + + my $message = $self->temp_file(); + open my $fh, '>', $message; + print $fh "X-Envelope-From: " + . $transaction->sender->format . CRLF + . $transaction->header->as_string . CRLF . CRLF; + + $transaction->body_resetpos; + while (my $line = $transaction->body_getline) { print $fh $line; }; + + close $fh; + + my ($line1) = split /[\r|\n]/, `$filtercmd < $message`; + $self->log(LOGDEBUG, $line1); + return $line1; }; sub dspam_process_open2 { @@ -336,16 +391,25 @@ sub dspam_process_open2 { # 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; + use IPC::Open3; + my ($read, $write, $err); + use Symbol 'gensym'; $err = gensym; + my $pid = open3($write, $read, $err, $filtercmd); + print $write $message; + close $write; #my $response = join('', <$dspam_out>); # get full response - my $response = <$dspam_out>; # get first line only + my $response = <$read>; # get first line only waitpid $pid, 0; - chomp $response; - $self->log(LOGDEBUG, $response); + my $child_exit_status = $? >> 8; + #$self->log(LOGINFO, "exit status: $child_exit_status"); + if ( $response ) { + chomp $response; + $self->log(LOGDEBUG, $response); + }; + my $err_msg = <$err>; + if ( $err_msg ) { + $self->log(LOGDEBUG, $err_msg ); + }; return $response; }; @@ -367,7 +431,7 @@ sub log_and_return { }; if ( $reject eq 'agree' ) { - return $self->reject_agree( $transaction, $d ); + return $self->reject_agree( $transaction ); }; if ( $d->{class} eq 'Innocent' ) { @@ -394,9 +458,10 @@ sub log_and_return { } sub reject_agree { - my ($self, $transaction, $d ) = @_; + my ($self, $transaction ) = @_; my $sa = $transaction->notes('spamassassin' ); + my $d = $transaction->notes('dspam' ); my $status = "$d->{class}, $d->{confidence} c"; @@ -423,13 +488,14 @@ sub reject_agree { 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->connection->notes('karma', ( $self->connection->notes('karma') + 2) ); }; }; $self->log(LOGINFO, "pass, agree, $status"); return DECLINED; }; $self->log(LOGINFO, "pass, disagree, $status"); + return DECLINED; }; $self->log(LOGINFO, "pass, other $status"); @@ -489,7 +555,13 @@ sub train_error_as_ham { my $user = $self->select_username( $transaction ); my $dspam_bin = $self->{_args}{dspam_bin} || '/usr/local/bin/dspam'; my $cmd = "$dspam_bin --user $user --mode=toe --source=error --class=innocent --deliver=summary --stdout"; - $self->dspam_process( $cmd, $transaction ); + my $response = $self->dspam_process( $cmd, $transaction ); + if ( $response ) { + $transaction->notes('dspam', $response); + } + else { + $transaction->notes('dspam', { class => 'Innocent', result => 'Innocent', confidence=>1 } ); + }; }; sub train_error_as_spam { @@ -499,7 +571,13 @@ sub train_error_as_spam { my $user = $self->select_username( $transaction ); my $dspam_bin = $self->{_args}{dspam_bin} || '/usr/local/bin/dspam'; my $cmd = "$dspam_bin --user $user --mode=toe --source=error --class=spam --deliver=summary --stdout"; - $self->dspam_process( $cmd, $transaction ); + my $response = $self->dspam_process( $cmd, $transaction ); + if ( $response ) { + $transaction->notes('dspam', $response); + } + else { + $transaction->notes('dspam', { class => 'Spam', result => 'Spam', confidence=>1 } ); + }; }; sub autolearn { @@ -572,12 +650,12 @@ sub autolearn_spamassassin { }; if ( $sa->{is_spam} eq 'Yes' && $sa->{autolearn} eq 'spam' && $response->{result} eq 'Innocent' ) { - $self->log(LOGINFO, "training spamassassin FN as spam"); + $self->log(LOGINFO, "training SA FN as spam"); $self->train_error_as_spam( $transaction ); return 1; } elsif ( $sa->{is_spam} eq 'No' && $sa->{autolearn} eq 'ham' && $response->{result} eq 'Spam' ) { - $self->log(LOGINFO, "training spamassassin FP as ham"); + $self->log(LOGINFO, "training SA FP as ham"); $self->train_error_as_ham( $transaction ); return 1; }; From 848b85c15069a617a5cc00c996c48ae8d1192a1c Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 25 Jun 2012 02:52:27 -0400 Subject: [PATCH 062/352] geoip: no data is a skip, not a fail --- plugins/ident/geoip | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/ident/geoip b/plugins/ident/geoip index fda062e..2f6b635 100644 --- a/plugins/ident/geoip +++ b/plugins/ident/geoip @@ -140,7 +140,7 @@ sub connect_handler { $self->open_geoip_db(); my $c_code = $self->set_country_code() or do { - $self->log( LOGINFO, "fail: no results" ); + $self->log( LOGINFO, "skip, no results" ); return DECLINED; }; $self->qp->connection->notes('geoip_country', $c_code); From 32d8b07f2809d1a3919b3f59bcc9d3e92eacfca5 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 25 Jun 2012 02:55:02 -0400 Subject: [PATCH 063/352] SPF: add more log messages --- plugins/sender_permitted_from | 39 +++++++++++++++++++++++++---------- 1 file changed, 28 insertions(+), 11 deletions(-) diff --git a/plugins/sender_permitted_from b/plugins/sender_permitted_from index 7841a03..dabad55 100644 --- a/plugins/sender_permitted_from +++ b/plugins/sender_permitted_from @@ -2,7 +2,7 @@ =head1 NAME -SPF - plugin to implement Sender Permitted From +SPF - implement Sender Permitted From =head1 SYNOPSIS @@ -10,7 +10,7 @@ Prevents email sender address spoofing by checking the SPF policy of the purport =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 +Sender Policy Framework (SPF) is an email validation system designed to prevent source address spoofing. SPF allows administrators to specify which hosts are allowed to send email from a given domain by creating a specific SPF record in the public DNS. Mail exchangers then use the DNS to verify that mail is being sent by a host sanctioned by a given domain administrators. -- http://en.wikipedia.org/wiki/Sender_Policy_Framework The results of a SPF query are stored in a transaction note named 'spfquery'; @@ -33,7 +33,7 @@ Set to a value between 1 and 6 to enable the following SPF behaviors: 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. +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 their obsessive little hearts. =head1 SEE ALSO @@ -120,7 +120,10 @@ sub mail_handler { my $spf_server = Mail::SPF::Server->new(); my $request = Mail::SPF::Request->new(%req_params); - my $result = $spf_server->process($request) or return DECLINED; + my $result = $spf_server->process($request) or do { + $self->log( LOGINFO, "fail, no result" ); + return DECLINED; + }; $transaction->notes('spfquery', $result); @@ -129,42 +132,56 @@ sub mail_handler { my $reject = $self->{_args}{reject}; if ( ! $code ) { + $self->log( LOGINFO, "fail, no response" ); return (DENYSOFT, "SPF - no response") if $reject >= 2; return (DECLINED, "SPF - no response"); }; - return (DECLINED, "SPF - $code: $why") if ! $reject; + if ( ! $reject ) { + $self->log( LOGINFO, "fail, no reject policy ($code: $why)" ); + return (DECLINED, "SPF - $code: $why") + }; # SPF result codes: pass fail softfail neutral none error permerror temperror - if ( $code eq 'pass' ) { } + if ( $code eq 'pass' ) { + $self->log(LOGINFO, "pass, $code: $why" ); + return (DECLINED); + } elsif ( $code eq 'fail' ) { + $self->log(LOGINFO, "fail, $why" ); 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; + $self->log(LOGINFO, "fail, $why" ); + return (DENY, "SPF - $code: $why") if $reject >= 4; return (DENYSOFT, "SPF - $code: $why") if $reject >= 3; } elsif ( $code eq 'neutral' ) { - return (DENY, "SPF - forgery: $why") if $reject >= 5; + $self->log(LOGINFO, "fail, $code, $why" ); + return (DENY, "SPF - $code: $why") if $reject >= 5; } elsif ( $code eq 'none' ) { - return (DENY, "SPF - forgery: $why") if $reject >= 6; + $self->log(LOGINFO, "fail, $code, $why" ); + return (DENY, "SPF - $code: $why") if $reject >= 6; } elsif ( $code eq 'error' ) { + $self->log(LOGINFO, "fail, $code, $why" ); return (DENY, "SPF - $code: $why") if $reject >= 6; return (DENYSOFT, "SPF - $code: $why") if $reject >= 2; } elsif ( $code eq 'permerror' ) { + $self->log(LOGINFO, "fail, $code, $why" ); return (DENY, "SPF - $code: $why") if $reject >= 6; return (DENYSOFT, "SPF - $code: $why") if $reject >= 3; } elsif ( $code eq 'temperror' ) { + $self->log(LOGINFO, "fail, $code, $why" ); return (DENYSOFT, "SPF - $code: $why") if $reject >= 2; } - $self->log(LOGDEBUG, "SPF from $from was $code: $why"); - return (DECLINED, "SPF - $code: $why"); + $self->log(LOGINFO, "SPF from $from was $code: $why"); + return (DECLINED); } sub data_post_handler { From 8d69b923fab665a2c12c297e6604830b9ab25163 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 25 Jun 2012 02:55:58 -0400 Subject: [PATCH 064/352] spamassassin: s/deny/fail/ from a log message (consistency) --- plugins/spamassassin | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/spamassassin b/plugins/spamassassin index 2d7d2e5..7070d7f 100644 --- a/plugins/spamassassin +++ b/plugins/spamassassin @@ -402,7 +402,7 @@ sub reject { $self->connection->notes('karma', $self->connection->notes('karma') - 1); # default of media_unsupported is DENY, so just change the message - $self->log(LOGINFO, "deny, $status, > $reject, $learn"); + $self->log(LOGINFO, "fail, $status, > $reject, $learn"); return ($self->get_reject_type(), "spam score exceeded threshold"); } From 4d394e847b0c4cf500a47fe3a00e16a1dbfb86b0 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 25 Jun 2012 02:57:37 -0400 Subject: [PATCH 065/352] clamdscan: fix karma decrementer --- plugins/virus/clamdscan | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/virus/clamdscan b/plugins/virus/clamdscan index 854aaf3..0af2929 100644 --- a/plugins/virus/clamdscan +++ b/plugins/virus/clamdscan @@ -140,7 +140,7 @@ sub data_post_handler { my $filename = $self->get_filename( $transaction ) or return DECLINED; - return (DECLINED) if $self->is_immune( ); + return (DECLINED) if $self->is_immune(); return (DECLINED) if $self->is_too_big( $transaction ); return (DECLINED) if $self->is_not_multipart( $transaction ); @@ -167,7 +167,7 @@ sub data_post_handler { $self->connection->notes('naughty', 1); # see plugins/naughty if ( defined $self->connection->notes('karma') ) { - $self->connection->notes('karma', $self->connection->notes('karma') - 1); + $self->connection->notes('karma', ($self->connection->notes('karma') - 1)); }; if ( $self->{_args}{deny_viruses} ) { From 2804afeb2dbbebbcbc90fb6b3de5d00f9cd77b7f Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 25 Jun 2012 03:08:25 -0400 Subject: [PATCH 066/352] rename require_resolvable_fromhost to resolvable_fromhost --- Changes | 12 ++++++------ MANIFEST | 7 +++---- README | 8 +------- config.sample/plugins | 2 +- config.sample/require_resolvable_fromhost | 3 --- docs/config.pod | 4 ++-- docs/hooks.pod | 2 +- docs/plugins.pod | 2 +- ...quire_resolvable_fromhost => resolvable_fromhost} | 0 ...quire_resolvable_fromhost => resolvable_fromhost} | 0 ...quire_resolvable_fromhost => resolvable_fromhost} | 0 11 files changed, 15 insertions(+), 25 deletions(-) delete mode 100644 config.sample/require_resolvable_fromhost rename plugins/async/{require_resolvable_fromhost => resolvable_fromhost} (100%) rename plugins/{require_resolvable_fromhost => resolvable_fromhost} (100%) rename t/plugin_tests/{require_resolvable_fromhost => resolvable_fromhost} (100%) diff --git a/Changes b/Changes index 0945ba8..4cba6eb 100644 --- a/Changes +++ b/Changes @@ -17,7 +17,7 @@ Next Version 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) + resolvable_fromhost ignores DNS search path (i.e. it expects fully resolved domains) (Robert Spier, Charlie Brady) new plugin auth_vpopmaild (Robin Bowes) @@ -44,7 +44,7 @@ Next Version AUTH PLAIN bug with Alpine (Rick Richard) - require_resolvable_fromhost: Moved DENYSOFT for temp_resolver_failed + resolvable_fromhost: Moved DENYSOFT for temp_resolver_failed to the RCPT TO hook. (Larry Nedry) Note Net::IP dependency (Larry Nedry) @@ -163,7 +163,7 @@ Next Version 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 + plugins/resolvable_fromhost: check all MX hosts, not just the first remove outdated virus/check_for_hi_virus plugin @@ -191,7 +191,7 @@ Next Version async: Dereference the DATA deny message before sending it to the client - Change async/require_resolvable_fromhost to match the logic of + Change async/resolvable_fromhost to match the logic of the non-async version and other MTAs async: Handle End-of-data marker split across packets @@ -453,7 +453,7 @@ Next Version example patterns for badrcptto plugin - Gordon Rowell - Extend require_resolvable_fromhost to include a configurable list of + Extend resolvable_fromhost to include a configurable list of "impossible" addresses to combat spammer forging. (Hanno Hecker) Use qmail/control/smtpdgreeting if it exists, otherwise @@ -570,7 +570,7 @@ Next Version no longer exists for that sender (great for harassment cases). (John Peacock) - check_earlytalker and require_resolvable_fromhost - short circuit test if + check_earlytalker and resolvable_fromhost - short circuit test if whitelistclient is set. (Michael Toren) check_badmailfrom - Do not say why a given message is denied. diff --git a/MANIFEST b/MANIFEST index 0a02e1b..b9d30ca 100644 --- a/MANIFEST +++ b/MANIFEST @@ -15,7 +15,6 @@ config.sample/norelayclients config.sample/plugins config.sample/rcpthosts config.sample/relayclients -config.sample/require_resolvable_fromhost config.sample/rhsbl_zones config.sample/size_threshold config.sample/smtpauth-checkpassword @@ -64,7 +63,7 @@ plugins/async/check_earlytalker plugins/async/dns_whitelist_soft plugins/async/dnsbl plugins/async/queue/smtp-forward -plugins/async/require_resolvable_fromhost +plugins/async/resolvable_fromhost plugins/async/rhsbl plugins/async/uribl plugins/auth/auth_checkpassword @@ -122,7 +121,7 @@ plugins/rcpt_map plugins/rcpt_ok plugins/rcpt_regexp plugins/relay -plugins/require_resolvable_fromhost +plugins/resolvable_fromhost plugins/resolvable_fromhost plugins/rhsbl plugins/sender_permitted_from @@ -186,7 +185,7 @@ t/plugin_tests/ident/geoip t/plugin_tests/ident/p0f t/plugin_tests/rcpt_ok t/plugin_tests/relay -t/plugin_tests/require_resolvable_fromhost +t/plugin_tests/resolvable_fromhost t/plugin_tests/sender_permitted_from t/plugin_tests/spamassassin t/plugin_tests/virus/clamdscan diff --git a/README b/README index baf18b9..421e7d4 100644 --- a/README +++ b/README @@ -123,7 +123,7 @@ 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. +example the resolvable_fromhost plugin described above. =head1 Configuration files @@ -157,12 +157,6 @@ Normal ip based DNS blocking lists ("RBLs"). For example: 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 diff --git a/config.sample/plugins b/config.sample/plugins index 9e6d9d2..887a022 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -34,7 +34,7 @@ check_earlytalker count_unrecognized_commands 4 relay -require_resolvable_fromhost +resolvable_fromhost rhsbl dnsbl diff --git a/config.sample/require_resolvable_fromhost b/config.sample/require_resolvable_fromhost deleted file mode 100644 index ce052b5..0000000 --- a/config.sample/require_resolvable_fromhost +++ /dev/null @@ -1,3 +0,0 @@ -1 - -# use 0 to disable; anything else to enable. \ No newline at end of file diff --git a/docs/config.pod b/docs/config.pod index dd863cc..86e0f0b 100644 --- a/docs/config.pod +++ b/docs/config.pod @@ -140,9 +140,9 @@ 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 +=item resolvable_fromhost -Plugin: F +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 diff --git a/docs/hooks.pod b/docs/hooks.pod index 0020613..6423fc6 100644 --- a/docs/hooks.pod +++ b/docs/hooks.pod @@ -235,7 +235,7 @@ Arguments for this hook are # $sender: an Qpsmtpd::Address object for # sender of the message -Example plugins for the C are F +Example plugins for the C are F and F. =head2 hook_rcpt_pre diff --git a/docs/plugins.pod b/docs/plugins.pod index 43a4c4e..586ebfa 100644 --- a/docs/plugins.pod +++ b/docs/plugins.pod @@ -25,7 +25,7 @@ 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. +F plugin. =head2 Loading Plugins diff --git a/plugins/async/require_resolvable_fromhost b/plugins/async/resolvable_fromhost similarity index 100% rename from plugins/async/require_resolvable_fromhost rename to plugins/async/resolvable_fromhost diff --git a/plugins/require_resolvable_fromhost b/plugins/resolvable_fromhost similarity index 100% rename from plugins/require_resolvable_fromhost rename to plugins/resolvable_fromhost diff --git a/t/plugin_tests/require_resolvable_fromhost b/t/plugin_tests/resolvable_fromhost similarity index 100% rename from t/plugin_tests/require_resolvable_fromhost rename to t/plugin_tests/resolvable_fromhost From caceda6d06a165c7f137c6a8017b43d492acb6a8 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 25 Jun 2012 03:24:08 -0400 Subject: [PATCH 067/352] resolvable_fromhost: log message updates --- plugins/async/resolvable_fromhost | 10 +-- plugins/resolvable_fromhost | 102 +++++++++++------------------- 2 files changed, 41 insertions(+), 71 deletions(-) diff --git a/plugins/async/resolvable_fromhost b/plugins/async/resolvable_fromhost index 4bfe7d8..acf93d6 100644 --- a/plugins/async/resolvable_fromhost +++ b/plugins/async/resolvable_fromhost @@ -15,7 +15,7 @@ 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*$//; @@ -35,7 +35,7 @@ sub register { sub hook_mail_start { my ( $self, $transaction, $sender ) = @_; - + return DECLINED if ($self->connection->notes('whitelisthost')); @@ -63,7 +63,7 @@ sub hook_mail_start { sub hook_mail_done { my ( $self, $transaction, $sender ) = @_; - + return DECLINED if ( $self->connection->notes('whitelisthost') ); @@ -81,7 +81,7 @@ sub check_dns { my $qp = $self->qp; $qp->input_sock->pause_read; - + my $a_records = []; my $num_queries = 1; # queries in progress my $mx_found = 0; @@ -159,7 +159,7 @@ sub finish_up { return; } } - + unless ($num_queries) { # all queries returned no valid response $qp->transaction->notes('resolvable_fromhost', 0); diff --git a/plugins/resolvable_fromhost b/plugins/resolvable_fromhost index e3ff208..d65bece 100644 --- a/plugins/resolvable_fromhost +++ b/plugins/resolvable_fromhost @@ -51,11 +51,11 @@ 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) + 80072 (mail) resolvable_fromhost: pass, googlegroups.com has MX at gmr-smtp-in.l.google.com + 80108 (mail) resolvable_fromhost: pass, zerobarriers.net has MX at zerobarriers.net + 80148 (mail) resolvable_fromhost: pass, uhin.com has MX at filter.itsafemail.com + 86627 (mail) resolvable_fromhost: palmalar.com has no MX + 86627 (mail) resolvable_fromhost: fail, palmalar.com (SERVFAIL) =head1 AUTHORS @@ -65,7 +65,6 @@ Default: temp (temporary, aka soft, aka 4xx). =cut - use strict; use warnings; @@ -95,32 +94,36 @@ sub register { sub hook_mail { my ($self, $transaction, $sender, %param) = @_; - $self->populate_invalid_networks(); + return DECLINED if $self->is_immune(); - # check first, so results are noted for other plugins + if ( $sender eq '<>' ) { + $transaction->notes('resolvable_fromhost', 'null'); + $self->log(LOGINFO, "pass, null sender"); + return DECLINED; + }; + + $self->populate_invalid_networks(); 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 - return DECLINED if $sender->host; # reject later + if ( ! $self->{_args}{reject} ) {; + $self->log(LOGINFO, 'skip, reject disabled' ); + return DECLINED; + }; - $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"); -} + my $result = $transaction->notes('resolvable_fromhost') or do { + return Qpsmtpd::DSN->temp_resolver_failed( $self->get_reject_type(), '' ); + }; -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 + return DECLINED if $result =~ /^(?:a|ip|mx)$/; # success + return DECLINED if $result =~ /^(?:whitelist|null|naughty)$/; # immunity $self->log(LOGINFO, $result ); # log error - return Qpsmtpd::DSN->temp_resolver_failed( $self->get_reject_type(), $result ); + + return Qpsmtpd::DSN->addr_bad_from_system( $self->get_reject_type(), + "FQDN required in the envelope sender"); } sub check_dns { @@ -135,7 +138,7 @@ sub check_dns { $transaction->notes('resolvable_fromhost_host', $host); if ( $host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/ ) { - $self->log(LOGINFO, "skip: $host is an IP"); + $self->log(LOGINFO, "skip, $host is an IP"); $transaction->notes('resolvable_fromhost', 'ip'); return 1; }; @@ -151,12 +154,12 @@ sub check_dns { 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"); + $self->log(LOGINFO, "pass, found 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"); + $self->log(LOGINFO, "pass, found MX for $host"); $transaction->notes('resolvable_fromhost', 'mx'); return $self->mx_address_resolves($rr->exchange, $host); }; @@ -184,21 +187,21 @@ sub get_and_validate_mx { my @mx = mx($res, $host); if ( ! scalar @mx ) { # no mx records - $self->log(LOGINFO, "no MX records for $host"); + $self->log(LOGINFO, "$host has no MX"); 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); + $self->log(LOGINFO, "pass, $host has 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"); + $self->log(LOGINFO, "fail, invalid MX for $host"); $transaction->notes('resolvable_fromhost', "invalid MX for $host"); return -1; }; @@ -226,7 +229,7 @@ sub get_host_records { if ( ! scalar @answers) { if ( $res->errorstring ne 'NXDOMAIN' ) { - $self->log(LOGWARN, "$$ query for $host failed: ", $res->errorstring); + $self->log(LOGWARN, "fail, query for $host, ", $res->errorstring); }; return; }; @@ -257,8 +260,9 @@ sub mx_address_resolves { } } if (! @mx_answers) { - $self->log(LOGWARN, "query for $fromhost failed: ", $res->errorstring) - unless $res->errorstring eq "NXDOMAIN"; + if ( $res->errorstring eq 'NXDOMAIN' ) { + $self->log(LOGWARN, "fail, query for $fromhost, ", $res->errorstring); + }; return; } @@ -282,37 +286,3 @@ sub populate_invalid_networks { } }; -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; -}; From 89ad78359536ca653d96133fed0970e5444296a6 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 25 Jun 2012 03:24:43 -0400 Subject: [PATCH 068/352] added plugin: qmail_deliverable --- plugins/qmail_deliverable | 165 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 165 insertions(+) create mode 100755 plugins/qmail_deliverable diff --git a/plugins/qmail_deliverable b/plugins/qmail_deliverable new file mode 100755 index 0000000..0704b06 --- /dev/null +++ b/plugins/qmail_deliverable @@ -0,0 +1,165 @@ +#!/usr/bin/perl + +=head1 NAME + +qmail_deliverable - Check that the recipient address is deliverable + +=head1 DESCRIPTION + +See the description of Qmail::Deliverable. + +This B uses the client/server interface and needs a running +qmail-deliverabled. If no connection can be made, deliverability is simply +assumed. + +The modules LWP (libwww-perl) and HTTP::Daemon, available from CPAN, are +required for qmail-deliverabled and Qmail::Deliverable::Client. + +=head1 CONFIGURATION + +=over 4 + +=item server host:port + +Hostname (or IP address), and port (both!) of the qmail-deliverabled server. If +none is specified, the default (127.0.0.1:8998) is used. + +=item server smtproutes:host:port + +If the specification is prepended by the literal text C, then for +recipient domains listed in your /var/qmail/control/smtproutes use their +respective hosts for the check. For other domains, the given host is used. The +port has to be the same across all servers. + +Example: + + qmail_deliverable server smtproutes:127.0.0.1:8998 + +Use "smtproutes:8998" (no second colon) to simply skip the deliverability +check for domains not listed in smtproutes. + +=back + +=head1 CAVEATS + +Given a null host in smtproutes, the normal MX lookup should be used. This +plugin does not do this, because we don't want to harrass arbitrary servers. + +Connection failure is *faked* when there is no smtproute. + +=head1 LEGAL + +This software is released into the public domain, and does not come with +warranty or guarantee of any kind. Use it at your own risk. + +=head1 AUTHOR + +Juerd <#####@juerd.nl> + +=head1 SEE ALSO + +L, L, L + +=cut + +use Qmail::Deliverable::Client qw(deliverable); +use strict; +use warnings; + +use Qpsmtpd::Constants; + +my %smtproutes; +my $shared_domain; # global variable to be closed over by the SERVER callback + +sub register { + my ($self, $qp, @args) = @_; + if (@args % 2) { + $self->log(LOGWARN, "Odd number of arguments, using default config"); + } else { + my %args = @args; + if ($args{server} =~ /^smtproutes:/) { + + my ($fallback, $port) = $args{server} =~ /:(?:(.*?):?)(\d+)/; + + open my $fh, "/var/qmail/control/smtproutes" + or warn "Could not read smtproutes"; + for (readline $fh) { + my ($domain, $mx) = /^(.*?) : \[? ( [^\]:\s]* )/x; + $smtproutes{$domain} = $mx; + } + + $Qmail::Deliverable::Client::SERVER = sub { + my $server = _smtproute($shared_domain); + return "$server:$port" if defined $server; + return "$fallback:$port" if defined $fallback; + return; + }; + + } elsif ($args{server}) { + $Qmail::Deliverable::Client::SERVER = $args{server}; + } + } + $self->register_hook('rcpt', 'rcpt_handler'); +} + +sub rcpt_handler { + my ($self, $transaction, $rcpt) = @_; + + return DECLINED if $self->is_immune(); + + my $address = $rcpt->address; + $self->log(LOGDEBUG, "Checking deliverability for recipient '$address'"); + + $shared_domain = $rcpt->host; + + my $rv = deliverable $address; + + if (not defined $rv or not length $rv) { + $self->log(LOGWARN, "Unknown error checking deliverability of '$address'"); + return DECLINED; + } + + my $k = 0; # known status code + $self->log(LOGINFO, "Permission failure"), $k++ if $rv == 0x11; + $self->log(LOGINFO, "pass, qmail-command in dot-qmail"),$k++ if $rv == 0x12; + $self->log(LOGINFO, "bouncesaying with program"), $k++ if $rv == 0x13; + $self->log(LOGINFO, "Temporarily undeliverable: group/world writable"), $k++ + if $rv == 0x21; + $self->log(LOGINFO, "Temporarily undeliverable: sticky home directory"),$k++ + if $rv == 0x22; + $self->log(LOGINFO, "error: $Qmail::Deliverable::Client::ERROR"), $k++ + if $rv == 0x2f; + $self->log(LOGINFO, "pass, normal delivery"), $k++ if $rv == 0xf1; + $self->log(LOGINFO, "pass, deliverable through vpopmail"), $k++ if $rv == 0xf2; + $self->log(LOGINFO, "SHOULD NOT HAPPEN"), $k++ if $rv == 0xfe; + $self->log(LOGINFO, "fail, address not local"), $k++ if $rv == 0xff; + + $self->log(LOGINFO, sprintf("Unknown: 0x%02x", $rv)) if $rv and not $k; + + return DECLINED if $rv; + + if ( defined $self->connection->notes('karma') ) { + $self->connection->notes('karma', ($self->connection->notes('karma') - 1)); + }; + return (DENY, "fail, no mailbox by that name. qd (#5.1.1)" ); +} + +sub _smtproute { + my ($domain) = @_; + my @parts = split /\./, $domain; + if (exists $smtproutes{$domain}) { + return undef if $smtproutes{$domain} eq ""; + return $smtproutes{$domain}; + } + for (reverse 1 .. @parts) { + my $wildcard = join "", map ".$_", @parts[-$_ .. -1]; + if (exists $smtproutes{$wildcard}) { + return undef if $smtproutes{$wildcard} eq ""; + return $smtproutes{$wildcard}; + } + } + return undef if not exists $smtproutes{""}; + return undef if $smtproutes{""} eq ""; + return $smtproutes{""}; +} + From d3787044fdc2d69a4b8e221abb2e2dbf5b5355ce Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 25 Jun 2012 03:38:17 -0400 Subject: [PATCH 069/352] resolveable_fromhost: updated tests --- t/plugin_tests/resolvable_fromhost | 65 ------------------------------ 1 file changed, 65 deletions(-) diff --git a/t/plugin_tests/resolvable_fromhost b/t/plugin_tests/resolvable_fromhost index 865e993..ebf4527 100644 --- a/t/plugin_tests/resolvable_fromhost +++ b/t/plugin_tests/resolvable_fromhost @@ -17,13 +17,11 @@ sub register_tests { 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); } @@ -51,48 +49,6 @@ sub test_hook_mail { 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; @@ -142,24 +98,3 @@ sub test_populate_invalid_networks { $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 ) ); -}; - - From b5d99eea05becdde6062778cc6ab641774f43853 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 25 Jun 2012 19:26:47 -0400 Subject: [PATCH 070/352] Qpsmtpd.pm: bump version --- lib/Qpsmtpd.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index fffecf0..b7a9932 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -7,7 +7,7 @@ use Qpsmtpd::Constants; #use DashProfiler; -$VERSION = "0.84"; +$VERSION = "0.90"; my $git; From e40994d13f6c67a07bc0e8044bef83cfd620e4f8 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Tue, 26 Jun 2012 01:03:00 -0400 Subject: [PATCH 071/352] rhsbl: added default reject settings --- plugins/rhsbl | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/plugins/rhsbl b/plugins/rhsbl index 3f08aac..a8708a2 100644 --- a/plugins/rhsbl +++ b/plugins/rhsbl @@ -46,6 +46,11 @@ sub register { else { $self->{_args} = { @_ }; }; + + if ( ! defined $self->{_args}{reject} ) { + $self->{_args}{reject} = 1; + }; + $self->{_args}{reject_type} ||= 'perm'; } sub hook_mail { @@ -94,17 +99,17 @@ sub hook_mail { $self->log(LOGDEBUG, "TXT record found: " . $rr->txtdata); }; - if ( $result ) { - $self->log(LOGINFO, "fail, $result"); + next if ! $result; - my $host = $transaction->sender->host; - if ($result =~ /^$host\./ ) { - return $self->get_reject( "Mail from $host rejected because it $result" ); - }; + $self->log(LOGINFO, "fail, $result"); - my $hello = $self->qp->connection->hello_host; - return $self->get_reject( "Mail from HELO $hello rejected because it $result" ); + my $host = $transaction->sender->host; + if ($result =~ /^$host\./ ) { + return $self->get_reject( "Mail from $host rejected because it $result" ); }; + + my $hello = $self->qp->connection->hello_host; + return $self->get_reject( "Mail from HELO $hello rejected because it $result" ); } } } From f43c9649ce786be28195e83e2c34e41543aada16 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Jun 2012 03:17:56 -0400 Subject: [PATCH 072/352] dnsbl: more refactoring, --- plugins/dnsbl | 83 +++++++++++++++++++++++++++++++-------------------- 1 file changed, 51 insertions(+), 32 deletions(-) diff --git a/plugins/dnsbl b/plugins/dnsbl index b417bd4..45135a9 100644 --- a/plugins/dnsbl +++ b/plugins/dnsbl @@ -154,47 +154,25 @@ sub register { sub hook_connect { my ($self, $transaction) = @_; - my $reject = $self->{_args}{reject}; - + # perform RBLSMTPD checks to mimic DJB's rblsmtpd # RBLSMTPD being non-empty means it contains the failure message to return if ( defined $ENV{'RBLSMTPD'} && $ENV{'RBLSMTPD'} ne '' ) { + my $reject = $self->{_args}{reject}; return $self->return_env_message() if $reject && $reject eq 'connect'; }; return DECLINED if $self->is_immune(); - - # perform RBLSMTPD checks to mimic Dan Bernstein's rblsmtpd return DECLINED if $self->is_set_rblsmtpd(); 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 zones"); - return DECLINED; - }; + my $dnsbl_zones = $self->get_dnsbl_zones() or return DECLINED; + my $resolv = $self->get_resolver() or return DECLINED; - my $remote_ip = $self->qp->connection->remote_ip; - my $reversed_ip = join('.', reverse(split(/\./, $remote_ip))); + for my $dnsbl ( keys %$dnsbl_zones ) { - my $res = new Net::DNS::Resolver; - $res->tcp_timeout(30); - $res->udp_timeout(30); - - for my $dnsbl (keys %dnsbl_zones) { -# fix to find A records, if the dnsbl_zones line has a second field 20/1/04 ++msp - my $query; - if ( defined $dnsbl_zones{$dnsbl} ) { - $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for A record"); - $query = $res->query("$reversed_ip.$dnsbl"); - } - else { - $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for TXT record"); - $query = $res->query("$reversed_ip.$dnsbl", "TXT"); - } - - if ( ! $query) { - if ( $res->errorstring ne "NXDOMAIN" ) { - $self->log(LOGERROR, "$dnsbl query failed: ", $res->errorstring); + my $query = $self->get_query( $dnsbl ) or do { + if ( $resolv->errorstring ne 'NXDOMAIN' ) { + $self->log(LOGERROR, "$dnsbl query failed: ", $resolv->errorstring); }; next; }; @@ -217,8 +195,9 @@ sub hook_connect { if ( ! $dnsbl ) { $dnsbl = $result; }; if ($a_record) { - if (defined $dnsbl_zones{$dnsbl}) { - my $smtp_msg = $dnsbl_zones{$dnsbl}; + if (defined $dnsbl_zones->{$dnsbl}) { + my $smtp_msg = $dnsbl_zones->{$dnsbl}; + my $remote_ip= $self->qp->connection->remote_ip; $smtp_msg =~ s/%IP%/$remote_ip/g; return $self->get_reject( $smtp_msg, $dnsbl ); } @@ -233,6 +212,35 @@ sub hook_connect { return DECLINED; }; +sub get_dnsbl_zones { + my $self = shift; + + my %dnsbl_zones = map { (split /:/, $_, 2)[0,1] } $self->qp->config('dnsbl_zones'); + if ( ! %dnsbl_zones ) { + $self->log( LOGDEBUG, "skip, no zones"); + return; + }; + + $self->{_dnsbl}{zones} = \%dnsbl_zones; + return \%dnsbl_zones; +}; + +sub get_query { + my ($self, $dnsbl) = @_; + + my $remote_ip = $self->qp->connection->remote_ip; + my $reversed_ip = join('.', reverse(split(/\./, $remote_ip))); + +# fix to find A records, if the dnsbl_zones line has a second field 20/1/04 ++msp + if ( defined $self->{_dnsbl}{zones}{$dnsbl} ) { + $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for A record"); + return $self->{_resolver}->query("$reversed_ip.$dnsbl"); + }; + + $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for TXT record"); + return $self->{_resolver}->query("$reversed_ip.$dnsbl", 'TXT'); +}; + sub is_set_rblsmtpd { my $self = shift; @@ -286,3 +294,14 @@ sub hook_rcpt { return DECLINED; } +sub get_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} || 30; + $self->{_resolver}->tcp_timeout($timeout); + $self->{_resolver}->udp_timeout($timeout); + return $self->{_resolver}; +}; + From bfa789f15f2c24a4cd2238376941695b31c40581 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Jun 2012 03:19:50 -0400 Subject: [PATCH 073/352] headers: added Received to POD header require list --- plugins/headers | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/headers b/plugins/headers index 14bef0d..4773ba1 100644 --- a/plugins/headers +++ b/plugins/headers @@ -24,7 +24,7 @@ The following optional settings exist: =head2 require - headers require [ From | Date | From,Date | From,Date,Subject,Message-ID ] + headers require [ From | Date | From,Date | From,Date,Subject,Message-ID,Received ] A comma separated list of headers to require. From c8cf830a8b419080297514b478aac5ff8bd9c736 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Jun 2012 03:20:49 -0400 Subject: [PATCH 074/352] naughty: POD additions --- plugins/naughty | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/plugins/naughty b/plugins/naughty index 5283367..f8ea233 100644 --- a/plugins/naughty +++ b/plugins/naughty @@ -16,7 +16,7 @@ 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. +work, oblivious to the fact that a connection is destined for the bit bucket. =head1 DESCRIPTION @@ -31,7 +31,7 @@ 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 +reduces the resources required to 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. @@ -41,6 +41,8 @@ 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. +For training spam filters, I is best. + =head2 simplicity Rather than having plugins split processing across hooks, they can run to @@ -55,7 +57,8 @@ deployment models. 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. +not get the chance to authenticate. To allow clients a chance to authenticate, +I works well. =head2 naughty @@ -109,7 +112,7 @@ Here's how to use naughty and get_reject in your plugin: my ($self, $transaction) = @_; ... do a bunch of stuff ... return DECLINED if is_okay(); - return $self->get_reject( $message ); + return $self->get_reject( $message, $optional_log_message ); }; =head1 AUTHOR @@ -153,7 +156,7 @@ sub register { sub naughty { my $self = shift; my $naughty = $self->connection->notes('naughty') or do { - $self->log(LOGINFO, "pass, clean"); + $self->log(LOGINFO, 'pass'); return DECLINED; }; $self->log(LOGINFO, "disconnecting"); From 0d911852ad04970ef93f08f772622f8d4c27e837 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Jun 2012 03:21:22 -0400 Subject: [PATCH 075/352] rhsbl: make sure $transaction->sender defined before accessing it --- plugins/rhsbl | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/plugins/rhsbl b/plugins/rhsbl index a8708a2..6f0a43a 100644 --- a/plugins/rhsbl +++ b/plugins/rhsbl @@ -103,9 +103,11 @@ sub hook_mail { $self->log(LOGINFO, "fail, $result"); - my $host = $transaction->sender->host; - if ($result =~ /^$host\./ ) { - return $self->get_reject( "Mail from $host rejected because it $result" ); + if ( $transaction->sender ) { + my $host = $transaction->sender->host; + if ($result =~ /^$host\./ ) { + return $self->get_reject( "Mail from $host rejected because it $result" ); + }; }; my $hello = $self->qp->connection->hello_host; From 4a622e3aff90c8990b400c0b946a38bf805dfa1f Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Jun 2012 03:23:27 -0400 Subject: [PATCH 076/352] uribl: ordered pragmas and dependencies --- plugins/uribl | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/plugins/uribl b/plugins/uribl index 7e5e677..b63a4c9 100644 --- a/plugins/uribl +++ b/plugins/uribl @@ -89,14 +89,14 @@ 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 strict; +use warnings; use Qpsmtpd::Constants; -use strict; -use warnings; +use Net::DNS::Resolver; +use Time::HiRes qw(time); +use IO::Select; # ccTLDs that allocate domain names within a strict two-level hierarchy, # as in *.co.uk From c2a5b8d42ecdbf531a8c7b58823e091cdc7e6ffa Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Jun 2012 03:26:38 -0400 Subject: [PATCH 077/352] dkim: new plugin --- plugins/dkim | 330 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 330 insertions(+) create mode 100644 plugins/dkim diff --git a/plugins/dkim b/plugins/dkim new file mode 100644 index 0000000..021d7a5 --- /dev/null +++ b/plugins/dkim @@ -0,0 +1,330 @@ +#!perl -w + +=head1 NAME + +dkim: validate DomainKeys and (DKIM) Domain Keys Indentified Messages + +=head1 SYNOPSIS + +Validate the DKIM and Domainkeys signatures of a message, and enforce DKIM +sending policies. + +=head1 CONFIGURATION + +=head2 reject [ 0 | 1 ] + + dkim reject 1 + +Reject is a boolean that toggles message rejection on or off. Messages failing +validation are rejected by default. + +Default: 1 + +=head2 reject_type + + dkim reject_type [ temp | perm ] + +Default: perm + +=head1 SEE ALSO + +http://www.dkim.org/ + +http://tools.ietf.org/html/rfc6376 - DKIM Signatures + +http://tools.ietf.org/html/rfc5863 - DKIM Development, Deployment, & Operations + +http://tools.ietf.org/html/rfc5617 - DKIM ADSP (Author Domain Signing Practices) + +http://tools.ietf.org/html/rfc5585 - DKIM Service Overview + +http://tools.ietf.org/html/rfc5016 - DKIM Signing Practices Protocol + +http://tools.ietf.org/html/rfc4871 - DKIM Signatures + +http://tools.ietf.org/html/rfc4870 - DomainKeys + +=head1 AUTHORS + + 2012 - Matt Simerson - initial plugin + +=head1 ACKNOWLEDGEMENTS + +David Summers - http://www.nntp.perl.org/group/perl.qpsmtpd/2010/08/msg9417.html + +Matthew Harrell - http://alecto.bittwiddlers.com/files/qpsmtpd/dkimcheck + +I first attempted to fix the dkimcheck plugin, but soon scrapped that effort and wrote this one. + +The nine 'if' brackets with 19 conditionals, and my inability to easily determine which of the 15 possible permutations (5 signature validation results x 3 possible policy results) were covered. + +The use of $dkim->fetch_author_policy, which is deprecated by Mail::DKIM. + +The paradim of a single policy, when DKIM supports 0 or many. Although I may yet implement the 'local' policy idea, so long as I'm confident it will never result in a false positive. + +The OBF programming style, which is nigh impossible to test. + +=cut + +use strict; +use warnings; + +use Qpsmtpd::Constants; + +# use Mail::DKIM::Verifier; # eval'ed in register() +use Socket qw(:DEFAULT :crlf); + +sub init { + my ($self, $qp) = (shift, shift); + + $self->{_args} = { @_ }; + + $self->{_args}{reject} = 1 if ! defined $self->{_args}{reject}; + $self->{_args}{reject_type} ||= 'perm'; +} + +sub register { + my $self = shift; + + eval "use Mail::DKIM::Verifier"; + if ( $@ ) { + warn "skip, plugin disabled, could not load Mail::DKIM::Verifier\n"; + $self->log(LOGERROR, "skip, plugin disabled, is Mail::DKIM installed?"); + return; + }; + + $self->register_hook('data_post', 'data_post_handler'); +}; + +sub data_post_handler { + my ($self, $transaction) = @_; + + return DECLINED if $self->is_immune(); + + my $dkim = Mail::DKIM::Verifier->new() or do { + $self->log(LOGERROR, "error, could not instantiate a new Mail::DKIM::Verifier"); + return DECLINED; + }; + + my $result = $self->get_dkim_result( $dkim, $transaction ); + my $mess = $self->get_details( $dkim ); + + foreach my $r ( qw/ pass fail invalid temperror none / ) { + my $handler = 'handle_sig_' . $r; + if ( $result eq $r && $self->can( $handler ) ) { + #$self->log(LOGINFO, "dispatching $result to $handler"); + return $self->$handler( $dkim, $mess ); + }; + }; + + $self->log( LOGERROR, "unknown result: $result, $mess" ); + return DECLINED; +} + +sub get_details { + my ($self, $dkim ) = @_; + + my @data; + my $string; + push @data, "domain: " . $dkim->signature->domain if $dkim->signature; + push @data, "selector: " . $dkim->signature->selector if $dkim->signature; + push @data, "result: " . $dkim->result_detail if $dkim->result_detail; + + foreach my $policy ( $dkim->policies ) { + next if ! $policy; + push @data, "policy: " . $policy->as_string; + push @data, "name: " . $policy->name; + push @data, "policy_location: " . $policy->location if $policy->location; + + my $policy_result; + $policy_result = $policy->apply($dkim); + $policy_result or next; + push @data, "policy_result: " . $policy_result if $policy_result; + }; + + return join(', ', @data); +}; + +sub handle_sig_fail { + my ( $self, $dkim, $mess ) = @_; + + return $self->get_reject( "DKIM signature invalid: " . $dkim->result_detail, $mess ); +}; + +sub handle_sig_temperror { + my ( $self, $dkim, $mess ) = @_; + + $self->log(LOGINFO, "error, $mess" ); + return ( DENYSOFT, "Please try again later - $dkim->result_detail" ); +}; + +sub handle_sig_invalid { + my ( $self, $dkim, $mess ) = @_; + + my ( $prs, $policies) = $self->get_policy_results( $dkim ); + + if ( ! $self->qp->connection->relay_client() ) { + foreach my $policy ( @$policies ) { + if ( $policy->signall && ! $policy->is_implied_default_policy ) { + $self->log(LOGINFO, $mess ); + return $self->get_reject( + "invalid DKIM signature with sign-all policy", + "invalid signature, sign-all policy" + ); + } + }; + }; + + $self->log(LOGINFO, $mess ); + + if ( $prs->{accept} ) { + $self->add_header( $mess ); + $self->log( LOGERROR, "error, invalid signature but accept policy!?" ); + return DECLINED; + } + elsif ( $prs->{neutral} ) { + $self->add_header( $mess ); + $self->log( LOGERROR, "error, invalid signature but neutral policy?!" ); + return DECLINED; + } + elsif ( $prs->{reject} ) { + return $self->get_reject( + "invalid DKIM signature: " . $dkim->result_detail, + "fail, invalid signature, reject policy" + ); + } + + # this should never happen + $self->log( LOGINFO, "error, invalid signature, unhandled" ); + $self->add_header( $mess ); + return DECLINED; +}; + +sub handle_sig_pass { + my ( $self, $dkim, $mess ) = @_; + + my ($prs) = $self->get_policy_results( $dkim ); + + if ( $prs->{accept} ) { + $self->add_header( $mess ); + $self->log(LOGINFO, "pass, valid signature, accept policy"); + return DECLINED; + } + elsif ( $prs->{neutral} ) { + $self->add_header( $mess ); + $self->log(LOGINFO, "pass, valid signature, neutral policy"); + $self->log(LOGINFO, $mess ); + return DECLINED; + } + elsif ( $prs->{reject} ) { + $self->log(LOGINFO, $mess ); + return $self->get_reject( + "DKIM signature valid but fails policy, $mess", + "fail, valid sig, reject policy" + ); + }; + + # this should never happen + $self->add_header( $mess ); + $self->log(LOGERROR, "pass, valid sig, no policy results" ); + $self->log(LOGINFO, $mess ); + return DECLINED; +}; + +sub handle_sig_none { + my ( $self, $dkim, $mess ) = @_; + + my ( $prs, $policies) = $self->get_policy_results( $dkim ); + + if ( ! $self->qp->connection->relay_client() ) { + foreach my $policy ( @$policies ) { + if ( $policy->signall && ! $policy->is_implied_default_policy ) { + $self->log(LOGINFO, $mess ); + return $self->get_reject( + "no DKIM signature with sign-all policy", + "no signature, sign-all policy" + ); + } + }; + }; + + + if ( $prs->{accept} ) { + $self->log( LOGINFO, "pass, no signature, accept policy" ); + return DECLINED; + } + elsif ( $prs->{neutral} ) { + $self->log( LOGINFO, "pass, no signature, neutral policy" ); + return DECLINED; + } + elsif ( $prs->{reject} ) { + $self->log(LOGINFO, $mess ); + $self->get_reject( + "no DKIM signature, policy says reject: " . $dkim->result_detail, + "no signature, reject policy" + ); + }; + + # should never happen + $self->log( LOGINFO, "error, no signature, no policy" ); + $self->log(LOGINFO, $mess ); + return DECLINED; +}; + +sub get_dkim_result { + my $self = shift; + my ($dkim, $transaction) = @_; + + foreach ( split ( /\n/s, $transaction->header->as_string ) ) { + $_ =~ s/\r?$//s; + eval { $dkim->PRINT ( $_ . CRLF ); }; + $self->log(LOGERROR, $@ ) if $@; + } + + $transaction->body_resetpos; + while (my $line = $transaction->body_getline) { + chomp $line; + s/\015$//; + eval { $dkim->PRINT($line . CRLF ); }; + $self->log(LOGERROR, $@ ) if $@; + }; + + $dkim->CLOSE; + + return $dkim->result; +}; + +sub get_policies { + my ($self, $dkim) = @_; + + my @policies; + eval { @policies = $dkim->policies }; + $self->log(LOGERROR, $@ ) if $@; + return @policies; +}; + +sub get_policy_results { + my ( $self, $dkim ) = @_; + + my %prs; + my @policies = $self->get_policies( $dkim ); + + foreach my $policy ( @policies ) { + my $policy_result; + eval { $policy_result = $policy->apply($dkim); }; # accept, reject, neutral + if ( $@ ) { + $self->log(LOGERROR, $@ ); + }; + $prs{$policy_result}++ if $policy_result; + }; + + return \%prs, \@policies; +}; + +sub add_header { + my $self = shift; + my $header = shift or return; + + $self->qp->transaction->header->add( 'X-DKIM-Authentication', $header, 0 ); +} + From 18d9165b1bda1910a82112ee3e05a56af5567bd6 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Jun 2012 03:27:35 -0400 Subject: [PATCH 078/352] log watching and processing tools --- log/log2sql.pl | 540 +++++++++++++++++++++++++++++++++++++++++++ log/summarize.pl | 313 +++++++++++++++++++++++++ log/watch.pl | 30 +++ plugins/registry.txt | 81 +++++++ 4 files changed, 964 insertions(+) create mode 100755 log/log2sql.pl create mode 100755 log/summarize.pl create mode 100755 log/watch.pl create mode 100644 plugins/registry.txt diff --git a/log/log2sql.pl b/log/log2sql.pl new file mode 100755 index 0000000..d654abb --- /dev/null +++ b/log/log2sql.pl @@ -0,0 +1,540 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Cwd; +use Data::Dumper; +use DBIx::Simple; +use File::stat; +use Time::TAI64 qw/ tai2unix /; + +$Data::Dumper::Sortkeys = 1; + +my $dsn = 'DBI:mysql:database=qpsmtpd;host=db;port=3306'; +my $user = 'qplog'; +my $pass = 't0ps3cret'; + +my $logdir = get_log_dir(); +my @logfiles = get_logfiles($logdir); + +my (%plugins, %os, %message_ids); +my $has_cleanup; +my $db = get_db(); + +foreach my $file ( @logfiles ) { + my ($fid, $offset) = check_logfile($file); + $fid or next; + parse_logfile( $file, $fid, $offset ); +}; + +exit; + +sub trim_message { + my $mess = shift; + + return '' if $mess eq 'skip, naughty'; + return '' if $mess eq 'skip, relay client'; + return '' if $mess eq 'skip, no match'; + return '' if $mess eq 'skip: unsigned'; + return '' if $mess eq 'skip, not a null sender'; + return '' if $mess eq 'pass'; + return '' if $mess eq 'pass, no record'; + return '' if $mess eq 'pass, Deliverable through vpopmail'; + return '' if $mess eq 'pass, clean'; + return '' if $mess =~ /^fail. NAUGHTY/; + return '' if $mess =~ /^PTR:\s/; + return '' if $mess eq 'TLS setup returning'; + + return $mess; +}; + +sub get_os_id { + my $p0f_string = shift or return; + + $p0f_string =~ s/\s+$//; + $p0f_string =~ s/^\s+//; + return if ! $p0f_string; + return if $p0f_string =~ /no match/; + return if $p0f_string =~ /^skip/; + return if $p0f_string =~ /^\d/; + return if $p0f_string =~ /^\(/; + return if $p0f_string !~ /\w/; + return if $p0f_string =~ /no longer in the cache/; + + if ( ! scalar keys %os ) { + my $ref = exec_query( 'SELECT * FROM os' ); + foreach my $o ( @$ref ) { + $os{ $o->{name} } = $o->{id}; + }; + }; + + if ( ! defined $os{$p0f_string} ) { + warn "missing OS for $p0f_string\n"; + }; + + return $os{$p0f_string}; +}; + +sub get_plugin_id { + my $plugin = shift; + + if ( ! scalar keys %plugins ) { + my $ref = exec_query( 'SELECT * FROM plugin' ); + foreach my $p ( @$ref ) { + $plugins{ $p->{name} } = $p->{id}; + $plugins{ $p->{id} } = $p->{name}; + }; + $ref = exec_query( 'SELECT * FROM plugin_aliases' ); + foreach my $pa ( @$ref ) { + $plugins{ $pa->{name} } = $pa->{plugin_id}; + }; + }; + + if ( ! defined $plugins{$plugin} ) { + #warn Dumper(\%plugins); + die "missing DB plugin $plugin\n"; + }; + + return $plugins{$plugin}; +}; + +sub get_msg_id { + my ( $fid, $pid ) = @_; + + return $message_ids{ "$fid-$pid" } if $message_ids{ "$fid-$pid" }; + + #print "searching for message $pid..."; + my $msgs = exec_query( + 'SELECT * FROM message WHERE file_id=? AND qp_pid=?', + [ $fid, $pid ] + ); + #print scalar @$msgs ? "y\n" : "n\n"; + if ( $msgs->[0]{id} ) { + $message_ids{ "$fid-$pid" } = $msgs->[0]{id}; + }; + return $msgs->[0]{id}; +}; + +sub create_message { + my ( $fid, $ts, $pid, $message ) = @_; + + my ($host, $ip) = split /\s/, $message; + $ip = substr $ip, 1, -1; # remote brackets + #print "new from $ip\n"; + + my $id = exec_query( + "INSERT INTO message SET file_id=?, connect_start=FROM_UNIXTIME(?), qp_pid=?, ip=INET_ATON(?)", + [ $fid, $ts, $pid, $ip ] + ); + + if ( $host && $host ne 'Unknown' ) { + exec_query( "UPDATE message SET hostname=? WHERE id=?", [ $host, $id ] ); + }; +}; + +sub insert_plugin { + my ( $msg_id, $plugin, $message ) = @_; + + my $plugin_id = get_plugin_id( $plugin ); + + if ( $plugin eq 'ident::geoip' ) { + my ($gip, $distance) = $message =~ /(.*?),\s+([\d]+)\skm/; + if ( $distance ) { + exec_query( 'UPDATE message SET distance=? WHERE id=?', [ $distance, $msg_id ] ); + $message = $gip; + } + } + elsif ( $plugin =~ /^ident::p0f/ ) { + my $os_id = get_os_id( $message ); + if ( $os_id ) { + exec_query( 'UPDATE message SET os_id=? WHERE id=?', [ $os_id, $msg_id ] ); + $message = 'pass'; + } + } + elsif ( $plugin eq 'connection_time' ) { + my ($seconds) = $message =~ /\s*([\d\.]+)\s/; + if ( $seconds ) { + exec_query( 'UPDATE message SET time=? WHERE id=?', [ $seconds, $msg_id ] ); + $message = 'pass'; + } + } + + my $result = get_score( $message ); + if ( $result ) { + $message = trim_message($message); + }; + + exec_query( 'INSERT INTO message_plugin SET msg_id=?, plugin_id=?, result=?, string=?', + [ $msg_id, $plugin_id, $result, $message ] + ); +}; + +sub parse_logfile { + my $file = shift; + my $fid = shift; + my $offset = shift || 0; + my $path = "$logdir/$file"; + + print "parsing file $file (id: $fid) from offset $offset\n"; + open my $F, '<', $path or die "could not open $path: $!"; + seek( $F, $offset, 0 ) if $offset; + + while ( defined (my $line = <$F> ) ) { + chomp $line; + next if ! $line; + my ( $type, $pid, $hook, $plugin, $message ) = parse_line( $line ); + + next if ! $type; + next if $type eq 'info'; + next if $type eq 'unknown'; + next if $type eq 'response'; + next if $type eq 'init'; # doesn't occur in all deployment models + next if $type eq 'cleanup'; + next if $type eq 'error'; + + my $ts = tai2unix( (split /\s/, $line)[0] ); # print "ts: $ts\n"; + + my $msg_id = get_msg_id( $fid, $pid ) or do { + create_message( $fid, $ts, $pid, $message ) if $type eq 'connect'; + next; + }; + + if ( $type eq 'plugin' ) { + next if $plugin eq 'naughty'; # housekeeping only + insert_plugin( $msg_id, $plugin, $message ); + } + elsif ( $type eq 'queue' ) { + exec_query('UPDATE message SET result=? WHERE id=?', [ 3, $msg_id ] ); + } + elsif ( $type eq 'reject' ) { + exec_query('UPDATE message SET result=? WHERE id=?', [ -3, $msg_id ] ); + } + elsif ( $type eq 'close' ) { + if ( $message eq 'Connection Timed Out' ) { + exec_query('UPDATE message SET result=? WHERE id=?', [ -1, $msg_id ] ); + }; + } + elsif ( $type eq 'connect' ) { } + elsif ( $type eq 'dispatch' ) { + if ( substr($message, 0, 21) eq 'dispatching MAIL FROM' ) { + my ($from) = $message =~ /<(.*?)>/; + exec_query('UPDATE message SET mail_from=? WHERE id=?', [ $from, $msg_id ] ); + } + elsif ( substr($message, 0, 19) eq 'dispatching RCPT TO' ) { + my ($to) = $message =~ /<(.*?)>/; + exec_query('UPDATE message SET rcpt_to=? WHERE id=? AND rcpt_to IS NULL', [ $to, $msg_id ] ); + } + elsif ( $message =~ m/dispatching (EHLO|HELO) (.*)/ ) { + exec_query('UPDATE message SET helo=? WHERE id=?', [ $2, $msg_id ] ); + } + elsif ( $message eq 'dispatching DATA' ) { } + elsif ( $message eq 'dispatching QUIT' ) { } + elsif ( $message eq 'dispatching STARTTLS' ) { } + elsif ( $message eq 'dispatching RSET' ) { } + else { + # anything here is likely an unrecognized command + #print "$message\n"; + }; + } + else { + print "$type $pid $hook $plugin $message\n"; + }; + }; + + close $F; +}; + +sub check_logfile { + my $file = shift; + my $path = "$logdir/$file"; + + die "missing file $logdir/$file" if ! -f "$logdir/$file"; + + my $inode = stat($path)->ino or die "unable to get inode for $path\n"; + my $size = stat($path)->size or die "unable to get size for $path\n"; + my $exists; + + # check if this tai file is in the DB as 'current' + if ( $file =~ /^\@/ ) { + $exists = exec_query( + 'SELECT * FROM log WHERE inode=? AND name=?', + [ $inode, 'current' ] + ); + if ( @$exists ) { + print "Updating current -> $file\n"; + exec_query( + 'UPDATE log SET name=? WHERE inode=? AND name=?', + [ $file, $inode, 'current' ] + ); + return ( $exists->[0]{id}, $exists->[0]{size} ); # continue parsing + }; + }; + + if ( $file eq 'current' ) { + $exists = exec_query( + 'SELECT * FROM log WHERE inode=? AND name=?', + [ $inode, $file ] + ); + if ( @$exists ) { + $exists = exec_query( + 'UPDATE log SET size=? WHERE inode=? AND name=?', + [ $size, $inode, 'current' ] + ); + return ( $exists->[0]{id}, $exists->[0]{size} ); # continue parsing + }; + }; + + $exists = exec_query( + 'SELECT * FROM log WHERE name=? AND size=?', + [ $file, $size ] + ); + return if @$exists; # log file hasn't changed, ignore it + #print Dumper($exists); + + # file is a new one we haven't seen, add to DB and parse + my $id = exec_query( + 'INSERT INTO log SET inode=?, size=?, name=?, created=FROM_UNIXTIME(?)', + [ $inode, $size, $file, stat($path)->ctime ] + ); + print "new file id: $id\n"; + return ( $id ); +}; + +sub get_log_dir { + + if ( -d "log/main" ) { + my $wd = Cwd::cwd(); + return "$wd/log/main"; + }; + + foreach my $user ( qw/ qpsmtpd smtpd / ) { + + my ($homedir) = (getpwnam( $user ))[7] or next; + + if ( -d "$homedir/log" ) { + return "$homedir/log/main"; + }; + if ( -d "$homedir/smtpd/log" ) { + return "$homedir/smtpd/log/main"; + }; + }; + +}; + +sub get_logfiles { + my $dir = shift; + + opendir my $D, $dir or die "unable to open log dir $dir\n"; + + my @files; + while ( defined( my $f = readdir($D) ) ) { + next if ! -f "$dir/$f"; # ignore anything that's not a file + if ( $f =~ /^\@.*s$/ ) { + push @files, $f; + }; + } + push @files, "current"; # always have this one last + + closedir $D; + return @files; +}; + +sub parse_line { + my $line = shift; + my ($tai, $pid, $message) = split /\s+/, $line, 3; + return if ! $message; # garbage in the log file + + # lines seen many times per connection + return parse_line_plugin( $line ) if substr($message, 0, 1) eq '('; + return ( 'dispatch', $pid, undef, undef, $message ) if substr($message, 0, 12) eq 'dispatching '; + return ( 'queue', $pid, undef, undef, $message ) if substr($message, 0, 11) eq '250 Queued!'; + return ( 'response', $pid, undef, undef, $message ) if $message =~ /^[2|3]\d\d/; + + # lines seen about once per connection + return ( 'init', $pid, undef, undef, $message ) if substr($message, 0, 19) eq 'Accepted connection'; + return ( 'connect', $pid, undef, undef, substr( $message, 16) ) if substr($message, 0, 15) eq 'Connection from'; + return ( 'connect', $pid, undef, undef, substr( $message, 16) ) if substr($message, 0, 8) eq 'connect '; + return ( 'close', $pid, undef, undef, $message ) if substr($message, 0, 6) eq 'close '; + return ( 'close', $pid, undef, undef, $message ) if $message eq 'Connection Timed Out'; + return ( 'close', $pid, undef, undef, $message ) if substr($message, 0, 20) eq 'click, disconnecting'; + return parse_line_cleanup( $line ) if substr($message, 0, 11) eq 'cleaning up'; + + # lines seen less than once per connection + return ( 'info', $pid, undef, undef, $message ) if $message eq 'spooling message to disk'; + return ( 'reject', $pid, undef, undef, $message ) if $message =~ /^[4|5]\d\d/; + return ( 'reject', $pid, undef, undef, $message ) if substr($message, 0, 14) eq 'deny mail from'; + return ( 'reject', $pid, undef, undef, $message ) if substr($message, 0, 18) eq 'denysoft mail from'; + return ( 'info', $pid, undef, undef, $message ) if substr($message, 0, 15) eq 'Lost connection'; + return ( 'info', $pid, undef, undef, $message ) if $message eq 'auth success cleared naughty'; + return ( 'info', $pid, undef, undef, $message ) if substr($message, 0, 15) eq 'Running as user'; + return ( 'info', $pid, undef, undef, $message ) if substr($message, 0, 16) eq 'Loaded Qpsmtpd::'; + return ( 'info', $pid, undef, undef, $message ) if substr($message, 0, 24) eq 'Permissions on spool_dir'; + return ( 'info', $pid, undef, undef, $message ) if substr($message, 0, 13) eq 'Listening on '; + return ( 'info', $pid, undef, undef, $message ) if substr($message, 0, 18) eq 'size_threshold set'; + return ( 'info', $pid, undef, undef, $message ) if substr($message, 0, 12) eq 'tls: ciphers'; + return ( 'error', $pid, undef, undef, $message ) if substr($message, 0, 22) eq 'of uninitialized value'; + return ( 'error', $pid, undef, undef, $message ) if substr($message, 0, 8) eq 'symbol "'; + return ( 'error', $pid, undef, undef, $message ) if substr($message, 0, 9) eq 'error at '; + return ( 'error', $pid, undef, undef, $message ) if substr($message, 0, 15) eq 'Could not print'; + + print "UNKNOWN LINE: $line\n"; + return ( 'unknown', $pid, undef, undef, $message ); +}; + +sub parse_line_plugin { + my ($line) = @_; + + # @tai 13486 (connect) ident::p0f: Windows (XP/2000 (RFC1323+, w, tstamp-)) + # @tai 13681 (connect) dnsbl: fail, NAUGHTY + # @tai 15787 (connect) karma: pass, no penalty (0 naughty, 3 nice, 3 connects) + # @tai 27500 (queue) queue::qmail_2dqueue: (for 27481) Queuing to /var/qmail/bin/qmail-queue + my ($tai, $pid, $hook, $plugin, $message ) = split /\s/, $line, 5; + $plugin =~ s/:$//; + + return parse_line_plugin_p0f( $line ) if $plugin =~ /^ident::p0f/; + return parse_line_plugin_dspam( $line ) if $plugin =~ /^dspam/; + return parse_line_plugin_spamassassin( $line ) if $plugin =~ /^spamassassin/; + + if ( $plugin eq 'sender_permitted_from' ) { + $message = 'pass' if $message =~ /^pass/; + $message = 'fail' if $message =~ /^fail/; + $message = 'skip' if $message =~ /^none/; + } + elsif ( $plugin eq 'queue::qmail_2dqueue' ) { + ($pid) = $message =~ /\(for ([\d]+)\)/; + $message = 'pass' if $message =~ /Queuing/; + } + elsif ( $plugin =~ /(?:early|karma|helo|rcpt_ok)/ ) { + $message = 'pass' if $message =~ /^pass/; + } + elsif ( $plugin =~ /resolvable_fromhost/ ) { + $message = 'pass' if $message =~ /^pass/; + }; + + return ( 'plugin', $pid, $hook, $plugin, $message ); +}; + +sub parse_line_plugin_dspam { + my $line = shift; + + my ($tai, $pid, $hook, $plugin, $message ) = split /\s/, $line, 5; + $plugin =~ s/:$//; + + if ( $message =~ /Innocent, (\d\.\d\d c)/ ) { + $message = "pass, $1"; + }; + if ( $message =~ /Spam, (\d\.\d\d c)/ ) { + $message = "fail, $1"; + }; + + return ( 'plugin', $pid, $hook, $plugin, $message ); +}; + +sub parse_line_plugin_spamassassin { + my $line = shift; + + my ($tai, $pid, $hook, $plugin, $message ) = split /\s/, $line, 5; + $plugin =~ s/:$//; + + if ( $message =~ /pass, Ham, ([\d\-\.]+)\s/ ) { + $message = "pass, $1"; + }; + if ( $message =~ /^fail, Spam,\s([\d\.]+)\s< 100/ ) { + $message = "fail, $1"; + }; + + return ( 'plugin', $pid, $hook, $plugin, $message ); +}; + +sub parse_line_plugin_p0f { + my $line = shift; + + my ($tai, $pid, $hook, $plugin, $message ) = split /\s/, $line, 5; + $plugin =~ s/:$//; + + if ( substr( $message, -5, 5) eq 'hops)' ) { + ($message) = split( /\s\(/, $message ); + }; + + $message = 'iOS' if $message =~ /^iOS/; + $message = 'Solaris' if $message =~ /^Solaris/; + $message = 'Mac OS X' if $message =~ /^Mac OS X/; + $message = 'FreeBSD' if $message =~ /^FreeBSD/; + $message = 'Linux' if $message =~ /^Linux/; + $message = 'OpenBSD' if $message =~ /^OpenBSD/; + $message = 'Windows NT' if $message =~ /^Windows \(?NT/; + $message = 'Windows 95' if $message =~ /^Windows \(?95/; + $message = 'Windows 98' if $message =~ /^Windows \(?98/; + $message = 'Windows XP' if $message =~ /^Windows \(?XP/; + $message = 'Windows 2000' if $message =~ /^Windows \(?2000/; + $message = 'Windows 2003' if $message =~ /^Windows \(?2003/; + $message = 'Windows 7 or 8' if $message =~ /^Windows 7/; + $message = 'Windows 7 or 8' if $message =~ /^Windows 8/; + $message = 'Google' if $message =~ /^Google/; + $message = 'HP-UX' if $message =~ /^HP\-UX/; + $message = 'NetCache' if $message =~ /^NetCache/i; + $message = 'Cisco' if $message =~ /^Cisco/i; + $message = 'Netware' if $message =~ /Netware/i; + + return ( 'plugin', $pid, $hook, $plugin, $message ); +}; + +sub parse_line_cleanup { + my ($line) = @_; + # @tai 85931 cleaning up after 3210 + my $pid = (split /\s+/, $line)[-1]; + $has_cleanup++; + return ( 'cleanup', $pid, undef, undef, $line ); +}; + +sub get_score { + my $mess = shift; + return 3 if $mess eq 'TLS setup returning'; + return 3 if $mess =~ /^pass/; + return -3 if $mess =~ /^fail/; + return -2 if $mess =~ /^negative/; + return 2 if $mess =~ /^positive/; + return 1 if $mess =~ /^skip/; + return 0; +}; + + +sub get_db { + + my $db = DBIx::Simple->connect( $dsn, $user, $pass ) + or die DBIx::Simple->error; + + return $db; +}; + +sub exec_query { + my $query = shift; + my $params = shift; + die "invalid arguments to exec_query!" if @_; + my @params; + if ( defined $params ) { + @params = ref $params eq 'ARRAY' ? @$params : $params; + }; + + my $err = "query failed: $query\n"; + if ( scalar @params ) { + $err .= join(',', @params); + }; + + if ( $query =~ /INSERT INTO/ ) { + my ( $table ) = $query =~ /INSERT INTO (\w+)\s/; + $db->query( $query, @params ); + die "$db->error\n$err" if $db->error ne 'DBI error: '; + my $id = $db->last_insert_id(undef,undef,$table,undef) or die $err; + return $id; + } + elsif ( $query =~ /DELETE/ ) { + $db->query( $query, @params )->hashes or die $err; + return $db->query("SELECT ROW_COUNT()")->list; + }; + + my $r = $db->query( $query, @params )->hashes or die $err; + return $r; +}; + diff --git a/log/summarize.pl b/log/summarize.pl new file mode 100755 index 0000000..04784cc --- /dev/null +++ b/log/summarize.pl @@ -0,0 +1,313 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Data::Dumper; +use File::Tail; + +$Data::Dumper::Sortkeys = 1; + +my (%plugins, %plugin_aliases, %seen_plugins, %pids); +my %hide_plugins = map { $_ => 1 } qw/ hostname /; + +my $qpdir = get_qp_dir(); +my $file = "$qpdir/log/main/current"; +populate_plugins_from_registry(); +my @sorted_plugins = sort { $plugins{$a}{id} <=> $plugins{$b}{id} } keys %plugins; + +my $fh = File::Tail->new(name=>$file, interval=>1, maxinterval=>1, debug =>1, tail =>1000 ); +my $printed = 0; +my $has_cleanup; + +my %formats = ( + ip => "%-15.15s", + hostname => "%-20.20s", + distance => "%5.5s", + + 'ident::geoip' => "%-20.20s", + 'ident::p0f' => "%-10.10s", + count_unrecognized_commands => "%-5.5s", + unrecognized_commands => "%-5.5s", + dnsbl => "%-3.3s", + rhsbl => "%-3.3s", + relay => "%-3.3s", + karma => "%-3.3s", + earlytalker => "%-3.3s", + check_earlytalker => "%-3.3s", + helo => "%-3.3s", + tls => "%-3.3s", + badmailfrom => "%-3.3s", + check_badmailfrom => "%-3.3s", + sender_permitted_from => "%-3.3s", + resolvable_fromhost => "%-3.3s", + 'queue::qmail-queue' => "%-3.3s", + connection_time => "%-4.4s", +); + +my %formats3 = ( + %formats, + badrcptto => "%-3.3s", + check_badrcptto => "%-3.3s", + qmail_deliverable => "%-3.3s", + rcpt_ok => "%-3.3s", + check_basicheaders => "%-3.3s", + headers => "%-3.3s", + uribl => "%-3.3s", + bogus_bounce => "%-3.3s", + check_bogus_bounce => "%-3.3s", + domainkeys => "%-3.3s", + dkim => "%-3.3s", + spamassassin => "%-3.3s", + dspam => "%-3.3s", + 'virus::clamdscan' => "%-3.3s", +); + + +while ( defined (my $line = $fh->read) ) { + chomp $line; + next if ! $line; + my ( $type, $pid, $hook, $plugin, $message ) = parse_line( $line ); + next if ! $type; + next if $type =~ /info|unknown|response/; + next if $type eq 'init'; # doesn't occur in all deployment models + + if ( ! $pids{$pid} ) { # haven't seen this pid + next if $type ne 'connect'; # ignore unless connect + my ($host, $ip) = split /\s/, $message; + $ip = substr $ip, 1, -1; + $pids{$pid}{ip} = $ip; + $pids{$pid}{hostname} = $host if $host ne 'Unknown'; + }; + + if ( $type eq 'close' ) { + next if $has_cleanup; # it'll get handled later + print_auto_format($pid, $line); + delete $pids{$pid}; + } + elsif ( $type eq 'cleanup' ) { + print_auto_format($pid, $line); + delete $pids{$pid}; + } + elsif ( $type eq 'plugin' ) { + next if $plugin eq 'naughty'; # housekeeping only + if ( ! $pids{$pid}{$plugin} ) { # first entry for this plugin + $pids{$pid}{$plugin} = $message; + } + else { # subsequent log entry for this plugin + if ( $pids{$pid}{$plugin} !~ /^(?:pass|fail|skip)/i ) { + $pids{$pid}{$plugin} = $message; # overwrite 1st + } + else { + #print "ignoring subsequent hit on $plugin: $message\n"; + }; + }; + + if ( $plugin eq 'ident::geoip' ) { + my ($gip, $distance) = $message =~ /(.*?),\s+([\d]+)\skm/; + if ( $distance ) { + $pids{$pid}{$plugin} = $gip; + $pids{$pid}{distance} = $distance; + }; + }; + } + elsif ( $type eq 'reject' ) { } + elsif ( $type eq 'connect' ) { } + elsif ( $type eq 'dispatch' ) { + if ( $message =~ /^dispatching MAIL FROM/i ) { + my ($from) = $message =~ /<(.*?)>/; + $pids{$pid}{from} = $from; + } + elsif ( $message =~ /^dispatching RCPT TO/i ) { + my ($to) = $message =~ /<(.*?)>/; + $pids{$pid}{to} = $to; + } + elsif ( $message =~ m/dispatching (EHLO|HELO) (.*)/ ) { + $pids{$pid}{helo_host} = $2; + } + elsif ( $message eq 'dispatching DATA' ) { } + elsif ( $message eq 'dispatching QUIT' ) { } + elsif ( $message eq 'dispatching STARTTLS' ) { } + elsif ( $message eq 'dispatching RSET' ) { + print_auto_format($pid, $line); + } + else { + # anything here is likely an unrecognized command + #print "$message\n"; + }; + } + else { + print "$type $pid $hook $plugin $message\n"; + }; +}; + +sub parse_line { + my $line = shift; + my ($tai, $pid, $message) = split /\s+/, $line, 3; + return if ! $message; # garbage in the log file + + # lines seen many times per connection + return parse_line_plugin( $line ) if substr($message, 0, 1) eq '('; + return ( 'dispatch', $pid, undef, undef, $message ) if substr($message, 0, 12) eq 'dispatching '; + return ( 'response', $pid, undef, undef, $message ) if $message =~ /^[2|3]\d\d/; + + # lines seen about once per connection + return ( 'init', $pid, undef, undef, $message ) if substr($message, 0, 19) eq 'Accepted connection'; + return ( 'connect', $pid, undef, undef, substr( $message, 16) ) if substr($message, 0, 15) eq 'Connection from'; + return ( 'close', $pid, undef, undef, $message ) if substr($message, 0, 6) eq 'close '; + return ( 'close', $pid, undef, undef, $message ) if substr($message, 0, 20) eq 'click, disconnecting'; + return parse_line_cleanup( $line ) if substr($message, 0, 11) eq 'cleaning up'; + + # lines seen less than once per connection + return ( 'info', $pid, undef, undef, $message ) if $message eq 'spooling message to disk'; + return ( 'reject', $pid, undef, undef, $message ) if $message =~ /^[4|5]\d\d/; + return ( 'reject', $pid, undef, undef, $message ) if substr($message, 0, 14) eq 'deny mail from'; + return ( 'reject', $pid, undef, undef, $message ) if substr($message, 0, 18) eq 'denysoft mail from'; + return ( 'info', $pid, undef, undef, $message ) if substr($message, 0, 15) eq 'Lost connection'; + return ( 'info', $pid, undef, undef, $message ) if $message eq 'auth success cleared naughty'; + return ( 'info', $pid, undef, undef, $message ) if substr($message, 0, 15) eq 'Running as user'; + return ( 'info', $pid, undef, undef, $message ) if substr($message, 0, 16) eq 'Loaded Qpsmtpd::'; + return ( 'info', $pid, undef, undef, $message ) if substr($message, 0, 24) eq 'Permissions on spool_dir'; + return ( 'info', $pid, undef, undef, $message ) if substr($message, 0, 13) eq 'Listening on '; + + print "UNKNOWN LINE: $line\n"; + return ( 'unknown', $pid, undef, undef, $message ); +}; + +sub parse_line_plugin { + my ($line) = @_; + + # @tai 13486 (connect) ident::p0f: Windows (XP/2000 (RFC1323+, w, tstamp-)) + # @tai 13681 (connect) dnsbl: fail, NAUGHTY + # @tai 15787 (connect) karma: pass, no penalty (0 naughty, 3 nice, 3 connects) + # @tai 77603 (queue) queue::qmail_2dqueue: (for 77590) Queuing to /var/qmail/bin/qmail-queue + my ($tai, $pid, $hook, $plugin, $message ) = split /\s/, $line, 5; + $plugin =~ s/:$//; + if ( $plugin =~ /_3a/ ) { + ($plugin) = split '_3a', $plugin; # trim :N off the plugin log entry + }; + $plugin =~ s/_2d/-/g; + + $plugin = $plugin_aliases{$plugin} if $plugin_aliases{$plugin}; # map alias to master + if ( $hook eq '(queue)' ) { + ($pid) = $message =~ /\(for ([\d]+)\)\s/; + $message = 'pass'; + }; + + return ( 'plugin', $pid, $hook, $plugin, $message ); +}; + +sub parse_line_cleanup { + my ($line) = @_; + # @tai 85931 cleaning up after 3210 + my $pid = (split /\s+/, $line)[-1]; + $has_cleanup++; + return ( 'cleanup', $pid, undef, undef, $line ); +}; + +sub print_auto_format { + my ($pid, $line) = @_; + + my $format; + my @headers; + my @values; + + foreach my $plugin ( qw/ ip hostname distance /, @sorted_plugins ) { + if ( defined $pids{$pid}{$plugin} ) { + if ( ! $seen_plugins{$plugin} ) { # first time seeing this plugin + $printed = 0; # force header print + }; + $seen_plugins{$plugin}++; + }; + + next if ! $seen_plugins{$plugin}; # hide plugins not used + if ( $hide_plugins{$plugin} ) { # user doesn't want to see + delete $pids{$pid}{$plugin}; + next; + }; + + if ( defined $pids{$pid}{helo_host} && $plugin =~ /helo/ ) { + $format .= " %-18.18s"; + push @values, delete $pids{$pid}{helo_host}; + push @headers, 'HELO'; + } + elsif ( defined $pids{$pid}{from} && $plugin =~ /from/ ) { + $format .= " %-20.20s"; + push @values, delete $pids{$pid}{from}; + push @headers, 'MAIL FROM'; + } + elsif ( defined $pids{$pid}{to} && $plugin =~ /to|rcpt|recipient/ ) { + $format .= " %-20.20s"; + push @values, delete $pids{$pid}{to}; + push @headers, 'RCPT TO'; + }; + + $format .= $formats3{$plugin} ? " $formats3{$plugin}" : " %-10.10s"; + + if ( defined $pids{$pid}{$plugin} ) { + push @values, show_symbol( delete $pids{$pid}{$plugin} ); + } + else { + push @values, ''; + }; + push @headers, ($plugins{$plugin}{abb3} ? $plugins{$plugin}{abb3} : $plugin); + } + $format .= "\n"; + printf( "\n$format", @headers ) if ( ! $printed || $printed % 20 == 0 ); + printf( $format, @values ); + print Data::Dumper::Dumper( $pids{$pid} ) if keys %{$pids{$pid}}; + $printed++; +}; + +sub show_symbol { + my $mess = shift; + return ' o' if $mess eq 'TLS setup returning'; + return ' -' if $mess eq 'skip'; + return ' -' if $mess =~ /^skip[,:\s]/i; + return ' o' if $mess eq 'pass'; + return ' o' if $mess =~ /^pass[,:\s]/i; + return ' X' if $mess =~ /^fail[,:\s]/i; + return ' x' if $mess =~ /^negative[,:\s]/i; + return ' o' if $mess =~ /^positive[,:\s]/i; + return ' !' if $mess =~ /^error[,:\s]/i; + $mess =~ s/\s\s/ /g; + return $mess; +}; + +sub get_qp_dir { + foreach my $user ( qw/ qpsmtpd smtpd / ) { + + my ($homedir) = (getpwnam( $user ))[7] or next; + + if ( -d "$homedir/plugins" ) { + return "$homedir"; + }; + if ( -d "$homedir/smtpd/plugins" ) { + return "$homedir/smtpd"; + }; + }; +}; + +sub populate_plugins_from_registry { + + my $file = "$qpdir/plugins/registry.txt"; + if ( ! -f $file ) { + die "unable to find plugin registry\n"; + }; + + open my $F, '<', $file; + while ( defined ( my $line = <$F> ) ) { + next if $line =~ /^#/; # discard comments + my ($id, $name, $abb3, $abb5, $aliases) = split /\s+/, $line; + next if ! defined $name; + $plugins{$name} = { id=>$id, abb3=>$abb3, abb5=>$abb5 }; + + next if ! $aliases; + $aliases =~ s/\s+//g; + $plugins{$name}{aliases} = $aliases; + foreach my $a ( split ',', $aliases ) { + $plugin_aliases{$a} = $name; + }; + }; +}; + diff --git a/log/watch.pl b/log/watch.pl new file mode 100755 index 0000000..b93ff6e --- /dev/null +++ b/log/watch.pl @@ -0,0 +1,30 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Data::Dumper; +use File::Tail; + +my $dir = find_qp_log_dir() or die "unable to find QP home dir"; +my $file = "$dir/main/current"; +my $fh = File::Tail->new(name=>$file, interval=>1, maxinterval=>1, debug =>1, tail =>100 ); + +while ( defined (my $line = $fh->read) ) { + my (undef, $line) = split /\s/, $line, 2; # strip off tai timestamps + print $line; +}; + +sub find_qp_log_dir { + foreach my $user ( qw/ qpsmtpd smtpd / ) { + + my ($homedir) = (getpwnam( $user ))[7] or next; + + if ( -d "$homedir/log" ) { + return "$homedir/log"; + }; + if ( -d "$homedir/smtpd/log" ) { + return "$homedir/smtpd/log"; + }; + }; +}; diff --git a/plugins/registry.txt b/plugins/registry.txt new file mode 100644 index 0000000..cedcd91 --- /dev/null +++ b/plugins/registry.txt @@ -0,0 +1,81 @@ +# This file contains a list of every plugin used on this server. If you have +# additional plugins running, add them here. +# Fields are whitespace delimited. Columns are ordered by numeric plugin ID. +# +#id name abb3 abb5 aliases +# +1 hosts_allow alw allow +2 ident::geoip geo geoip +3 ident::p0f p0f p0f +5 karma krm karma +6 dnsbl dbl dnsbl +7 relay rly relay +9 earlytalker ear early check_earlytalker +15 helo hlo helo check_spamhelo +16 tls tls tls +20 dont_require_anglebrackets rab drabs +21 unrecognized_commands cmd uncmd count_unrecognized_commands +22 noop nop noop noop_counter +23 random_error rnd rande +24 milter mlt mlter +25 content_log log colog +# +# Authentication +# +30 auth::vpopmail_sql aut vpsql +31 auth::vpopmaild vpd vpopd +32 auth::vpopmail vpo vpop +33 auth::checkpasswd ckp chkpw +34 auth::cvs_unix_local cvs cvsul +35 auth::flat_file flt aflat +36 auth::ldap_bind ldp aldap +# +# Sender / From +# +40 badmailfrom bmf badmf check_badmailfrom,check_badmailfrom_patterns +41 badmailfromto bmt bfrto +42 rhsbl rbl rhsbl +44 resolvable_fromhost rfh rsvfh require_resolvable_fromhost +45 sender_permitted_from spf spf +# +# Recipient +# +50 badrcptto bto badto check_badrcptto,check_badrcptto_patterns +51 rcpt_map rmp rcmap +52 rcpt_regex rcx rcrex +53 qmail_deliverable qmd qmd +55 rcpt_ok rok rcpok +58 bogus_bounce bog bogus check_bogus_bounce +59 greylisting gry greyl +# +# Content Filters +# +60 headers hdr headr check_basicheaders +61 loop lop loop +62 uribl uri uribl +63 domainkeys dky dkey +64 dkim dkm dkim +65 spamassassin spm spama +66 dspam dsp dspam +# +# Anti-Virus Plugins +# +70 virus::aveclient ave avirs +71 virus::bitdefender bit bitdf +72 virus::clamav cav clamv +73 virus::clamdscan cad clamd +74 virus::hbedv hbv hbedv +75 virus::kavscanner kav kavsc +76 virus::klez_filter klz vklez +77 virus::sophie sop sophe +78 virus::uvscan uvs uvscn +# +# Queue Plugins +# +80 queue::qmail-queue qqm queue +81 queue::maildir qdr qudir +82 queue::postfix-queue qpf qupfx +83 queue::smtp-forward qfw qufwd +84 queue::exim-bsmtp qxm qexim +98 quit_fortune for fortu +99 connection_time tim time From 1d3c5369b7042d04043df746ec3ccaf5c16f1126 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Jun 2012 03:35:32 -0400 Subject: [PATCH 079/352] log2sql: added SQL file --- log/log2sql.sql | 232 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 232 insertions(+) create mode 100644 log/log2sql.sql diff --git a/log/log2sql.sql b/log/log2sql.sql new file mode 100644 index 0000000..4f975eb --- /dev/null +++ b/log/log2sql.sql @@ -0,0 +1,232 @@ +/*!40101 SET @OLD_CHARACTER_SET_CLIENT=@@CHARACTER_SET_CLIENT */; +/*!40101 SET @OLD_CHARACTER_SET_RESULTS=@@CHARACTER_SET_RESULTS */; +/*!40101 SET @OLD_COLLATION_CONNECTION=@@COLLATION_CONNECTION */; +/*!40101 SET NAMES utf8 */; +/*!40014 SET @OLD_FOREIGN_KEY_CHECKS=@@FOREIGN_KEY_CHECKS, FOREIGN_KEY_CHECKS=0 */; +/*!40101 SET @OLD_SQL_MODE=@@SQL_MODE, SQL_MODE='NO_AUTO_VALUE_ON_ZERO' */; +/*!40111 SET @OLD_SQL_NOTES=@@SQL_NOTES, SQL_NOTES=0 */; + + +# Dump of table log +# ------------------------------------------------------------ + +DROP TABLE IF EXISTS `log`; + +CREATE TABLE `log` ( + `id` int(11) unsigned NOT NULL auto_increment, + `inode` int(11) unsigned NOT NULL, + `size` int(11) unsigned NOT NULL, + `name` varchar(30) NOT NULL default '', + `created` datetime default NULL, + PRIMARY KEY (`id`) +) ENGINE=InnoDB DEFAULT CHARSET=utf8; + + +# Dump of table message +# ------------------------------------------------------------ + +DROP TABLE IF EXISTS `message`; + +CREATE TABLE `message` ( + `id` int(11) unsigned NOT NULL auto_increment, + `file_id` int(10) unsigned NOT NULL, + `connect_start` datetime NOT NULL, + `ip` int(10) unsigned NOT NULL, + `qp_pid` int(10) unsigned NOT NULL, + `result` tinyint(3) NOT NULL default '0', + `distance` mediumint(8) unsigned default NULL, + `time` decimal(3,2) unsigned default NULL, + `os_id` tinyint(3) unsigned default NULL, + `hostname` varchar(128) default NULL, + `helo` varchar(128) default NULL, + `mail_from` varchar(128) default NULL, + `rcpt_to` varchar(128) default NULL, + PRIMARY KEY (`id`), + KEY `file_id` (`file_id`), + CONSTRAINT `message_ibfk_1` FOREIGN KEY (`file_id`) REFERENCES `log` (`id`) ON DELETE CASCADE ON UPDATE CASCADE +) ENGINE=InnoDB DEFAULT CHARSET=utf8; + + + +# Dump of table message_plugin +# ------------------------------------------------------------ + +DROP TABLE IF EXISTS `message_plugin`; + +CREATE TABLE `message_plugin` ( + `id` int(11) unsigned NOT NULL auto_increment, + `msg_id` int(11) unsigned NOT NULL, + `plugin_id` int(4) unsigned NOT NULL, + `result` tinyint(4) NOT NULL, + `string` varchar(128) default NULL, + PRIMARY KEY (`id`), + KEY `msg_id` (`msg_id`), + KEY `plugin_id` (`plugin_id`), + CONSTRAINT `message_plugin_ibfk_1` FOREIGN KEY (`plugin_id`) REFERENCES `plugin` (`id`) ON DELETE CASCADE ON UPDATE CASCADE, + CONSTRAINT `msg_id` FOREIGN KEY (`msg_id`) REFERENCES `message` (`id`) ON DELETE CASCADE ON UPDATE CASCADE +) ENGINE=InnoDB DEFAULT CHARSET=utf8; + + + +# Dump of table os +# ------------------------------------------------------------ + +DROP TABLE IF EXISTS `os`; + +CREATE TABLE `os` ( + `id` tinyint(3) unsigned NOT NULL auto_increment, + `name` varchar(36) default NULL, + PRIMARY KEY (`id`) +) ENGINE=InnoDB DEFAULT CHARSET=utf8; + +LOCK TABLES `os` WRITE; +/*!40000 ALTER TABLE `os` DISABLE KEYS */; + +INSERT INTO `os` (`id`, `name`) +VALUES + (1,'FreeBSD'), + (2,'Mac OS X'), + (3,'Solaris'), + (4,'Linux'), + (5,'OpenBSD'), + (6,'iOS'), + (7,'HP-UX'), + (8,'Windows 95'), + (9,'Windows 98'), + (10,'Windows NT'), + (11,'Windows XP'), + (12,'Windows XP/2000'), + (13,'Windows 2000'), + (14,'Windows 2003'), + (15,'Windows 7 or 8'), + (17,'Google'), + (18,'NetCache'), + (19,'Cisco'), + (20,'Netware'); + +/*!40000 ALTER TABLE `os` ENABLE KEYS */; +UNLOCK TABLES; + + +# Dump of table plugin +# ------------------------------------------------------------ + +DROP TABLE IF EXISTS `plugin`; + +CREATE TABLE `plugin` ( + `id` int(4) unsigned NOT NULL auto_increment, + `name` varchar(35) character set utf8 NOT NULL default '', + `abb3` char(3) character set utf8 default NULL, + `abb5` char(5) character set utf8 default NULL, + PRIMARY KEY (`id`), + UNIQUE KEY `abb3` (`abb3`), + UNIQUE KEY `abb5` (`abb5`) +) ENGINE=InnoDB DEFAULT CHARSET=utf8 COLLATE=utf8_bin; + +LOCK TABLES `plugin` WRITE; +/*!40000 ALTER TABLE `plugin` DISABLE KEYS */; + +INSERT INTO `plugin` (`id`, `name`, `abb3`, `abb5`) +VALUES + (1,'hosts_allow','alw','allow'), + (2,'ident::geoip','geo','geoip'), + (3,'ident::p0f','p0f',' p0f'), + (5,'karma','krm','karma'), + (6,'dnsbl','dbl','dnsbl'), + (7,'relay','rly','relay'), + (9,'earlytalker','ear','early'), + (15,'helo','hlo','helo'), + (16,'tls','tls',' tls'), + (20,'dont_require_anglebrackets','rab','drabs'), + (21,'unrecognized_commands','cmd','uncmd'), + (22,'noop','nop','noop'), + (23,'random_error','rnd','rande'), + (24,'milter','mtr','mlter'), + (25,'content_log','log','colog'), + (30,'auth::vpopmail_sql','aut','vpsql'), + (31,'auth::vpopmaild','vpd','vpopd'), + (32,'auth::vpopmail','vpo','vpop'), + (33,'auth::checkpasswd','ckp','chkpw'), + (34,'auth::cvs_unix_local','cvs','cvsul'), + (35,'auth::flat_file','flt','aflat'), + (36,'auth::ldap_bind','ldp','aldap'), + (40,'badmailfrom','bmf','badmf'), + (41,'badmailfromto','bmt','bfrto'), + (42,'rhsbl','rbl','rhsbl'), + (44,'resolvable_fromhost','rfh','rsvfh'), + (45,'sender_permitted_from','spf',' spf'), + (50,'badrcptto','bto','badto'), + (51,'rcpt_map','rmp','rcmap'), + (52,'rcpt_regex','rcx','rcrex'), + (53,'qmail_deliverable','qmd',' qmd'), + (55,'rcpt_ok','rok','rcpok'), + (58,'bogus_bounce','bog','bogus'), + (59,'greylisting','gry','greyl'), + (60,'headers','hdr','headr'), + (61,'loop','lop','loop'), + (62,'uribl','uri','uribl'), + (63,'domainkeys','dk','dkey'), + (64,'dkim','dkm','dkim'), + (65,'spamassassin','spm','spama'), + (66,'dspam','dsp','dspam'), + (70,'virus::aveclient','vav','avirs'), + (71,'virus::bitdefender','vbd','bitdf'), + (72,'virus::clamav','cav','clamv'), + (73,'virus::clamdscan','cad','clamd'), + (74,'virus::hbedv','hbv','hbedv'), + (75,'virus::kavscanner','kav','kavsc'), + (76,'virus::klez_filter','klz','vklez'), + (77,'virus::sophie','sop','sophe'), + (78,'virus::uvscan','uvs','uvscn'), + (80,'queue::qmail-queue','qqm','queue'), + (81,'queue::maildir','qdr','qudir'), + (82,'queue::postfix-queue','qpf','qupfx'), + (83,'queue::smtp-forward','qfw','qufwd'), + (84,'queue::exim-bsmtp','qxm','qexim'), + (98,'quit_fortune','for','fortu'), + (99,'connection_time','tim','time'); + +/*!40000 ALTER TABLE `plugin` ENABLE KEYS */; +UNLOCK TABLES; + + +# Dump of table plugin_aliases +# ------------------------------------------------------------ + +DROP TABLE IF EXISTS `plugin_aliases`; + +CREATE TABLE `plugin_aliases` ( + `plugin_id` int(11) unsigned NOT NULL, + `name` varchar(35) character set utf8 NOT NULL default '', + KEY `plugin_id` (`plugin_id`), + CONSTRAINT `plugin_id` FOREIGN KEY (`plugin_id`) REFERENCES `plugin` (`id`) ON UPDATE CASCADE +) ENGINE=InnoDB DEFAULT CHARSET=utf8 COLLATE=utf8_bin; + +LOCK TABLES `plugin_aliases` WRITE; +/*!40000 ALTER TABLE `plugin_aliases` DISABLE KEYS */; + +INSERT INTO `plugin_aliases` (`plugin_id`, `name`) +VALUES + (60,'check_basicheaders'), + (44,'require_resolvable_fromhost'), + (21,'count_unrecognized_commands'), + (9,'check_earlytalker'), + (40,'check_badmailfrom'), + (50,'check_badrcptto'), + (58,'check_bogus_bounce'), + (15,'check_spamhelo'), + (3,'ident::p0f_3a0'), + (80,'queue::qmail_2dqueue'), + (22,'noop_counter'); + +/*!40000 ALTER TABLE `plugin_aliases` ENABLE KEYS */; +UNLOCK TABLES; + + + +/*!40111 SET SQL_NOTES=@OLD_SQL_NOTES */; +/*!40101 SET SQL_MODE=@OLD_SQL_MODE */; +/*!40014 SET FOREIGN_KEY_CHECKS=@OLD_FOREIGN_KEY_CHECKS */; +/*!40101 SET CHARACTER_SET_CLIENT=@OLD_CHARACTER_SET_CLIENT */; +/*!40101 SET CHARACTER_SET_RESULTS=@OLD_CHARACTER_SET_RESULTS */; +/*!40101 SET COLLATION_CONNECTION=@OLD_COLLATION_CONNECTION */; From 98228cd38ca4e84fdd27cd81990fcd5c19ba92b0 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Jun 2012 14:42:34 -0700 Subject: [PATCH 080/352] dspam: check for dspam_bin during register --- plugins/dspam | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/plugins/dspam b/plugins/dspam index a71ee9b..22ac794 100644 --- a/plugins/dspam +++ b/plugins/dspam @@ -213,6 +213,11 @@ sub register { $self->{_args} = { @_ }; $self->{_args}{reject} = 1 if ! defined $self->{_args}{reject}; $self->{_args}{reject_type} ||= 'perm'; + $self->{_args}{dspam_bin} ||= '/usr/local/bin/dspam'; + + if ( ! -x $self->{_args}{dspam_bin} ) { + $self->log(LOGERROR, "dspam not found: "); + }; $self->register_hook('data_post', 'data_post_handler'); } @@ -228,9 +233,9 @@ sub data_post_handler { return (DECLINED); }; - my $username = $self->select_username( $transaction ); - my $dspam_bin = $self->{_args}{dspam_bin} || '/usr/local/bin/dspam'; - my $filtercmd = "$dspam_bin --user $username --mode=tum --process --deliver=summary --stdout"; + my $user = $self->select_username( $transaction ); + my $bin = $self->{_args}{dspam_bin}; + my $filtercmd = "$bin --user $user --mode=tum --process --deliver=summary --stdout"; $self->log(LOGDEBUG, $filtercmd); my $response = $self->dspam_process( $filtercmd, $transaction ); From 04d457480d8024b732515be7f9b36eae2943f192 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Jun 2012 14:43:17 -0700 Subject: [PATCH 081/352] dnsbl: restore dnsbl bypass for special recipients --- plugins/dnsbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/dnsbl b/plugins/dnsbl index 45135a9..7c869ee 100644 --- a/plugins/dnsbl +++ b/plugins/dnsbl @@ -288,7 +288,7 @@ sub hook_rcpt { $self->log(LOGWARN, "skip, don't blacklist special account: ".$rcpt->user); # clear the naughty connection note here, if desired. - #$self->connection->notes('naughty', 0 ); + $self->connection->notes('naughty', 0 ); } return DECLINED; From ee7121d1ce98f5a97516d1eb5f7aef890828dc33 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Jun 2012 14:47:02 -0700 Subject: [PATCH 082/352] dspam: added missing return --- plugins/dspam | 1 + 1 file changed, 1 insertion(+) diff --git a/plugins/dspam b/plugins/dspam index 22ac794..d92da7f 100644 --- a/plugins/dspam +++ b/plugins/dspam @@ -217,6 +217,7 @@ sub register { if ( ! -x $self->{_args}{dspam_bin} ) { $self->log(LOGERROR, "dspam not found: "); + return DECLINED; }; $self->register_hook('data_post', 'data_post_handler'); From 77e63e92ae1ba572206f7d4ffe717f7d8ff00b95 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Jun 2012 19:17:01 -0400 Subject: [PATCH 083/352] drop the check_ prefix from the last 3 plugins --- Changes | 8 ++++---- MANIFEST | 12 ++++++------ config.sample/plugins | 2 +- docs/hooks.pod | 2 +- plugins/async/{check_earlytalker => earlytalker} | 2 +- plugins/{check_bogus_bounce => bogus_bounce} | 2 +- plugins/{check_earlytalker => earlytalker} | 6 +++--- plugins/{check_loop => loop} | 2 +- t/config/plugins | 2 +- 9 files changed, 19 insertions(+), 19 deletions(-) rename plugins/async/{check_earlytalker => earlytalker} (97%) rename plugins/{check_bogus_bounce => bogus_bounce} (97%) rename plugins/{check_earlytalker => earlytalker} (97%) rename plugins/{check_loop => loop} (97%) diff --git a/Changes b/Changes index 4cba6eb..be8d88f 100644 --- a/Changes +++ b/Changes @@ -570,7 +570,7 @@ Next Version no longer exists for that sender (great for harassment cases). (John Peacock) - check_earlytalker and resolvable_fromhost - short circuit test if + earlytalker and resolvable_fromhost - short circuit test if whitelistclient is set. (Michael Toren) check_badmailfrom - Do not say why a given message is denied. @@ -642,7 +642,7 @@ Next Version Add a plugin hook for the DATA command - check_earlytalker - + earlytalker - + optionally react to an earlytalker by denying all MAIL-FROM commands rather than issuing a 4xx/5xx greeting and disconnecting. (Mark Powell) @@ -728,7 +728,7 @@ Next Version Use $ENV{QMAIL} to override /var/qmail for where to find the control/ directory. - Enable "check_earlytalker" in the default plugins config + Enable "earlytalker" in the default plugins config Added a milter plugin to allow use of sendmail milters @@ -792,7 +792,7 @@ Next Version unrecognized_command hook and a count_unrecognized_commands plugin. (Rasjid Wilcox) - check_earlytalker plugin. Deny the connection if the client talks + 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 diff --git a/MANIFEST b/MANIFEST index b9d30ca..991ffdd 100644 --- a/MANIFEST +++ b/MANIFEST @@ -59,7 +59,7 @@ Makefile.PL MANIFEST This list of files MANIFEST.SKIP META.yml Module meta-data (added by MakeMaker) -plugins/async/check_earlytalker +plugins/async/earlytalker plugins/async/dns_whitelist_soft plugins/async/dnsbl plugins/async/queue/smtp-forward @@ -77,9 +77,9 @@ plugins/auth/authdeny plugins/badmailfrom plugins/badmailfromto plugins/badrcptto -plugins/check_bogus_bounce -plugins/check_earlytalker -plugins/check_loop +plugins/bogus_bounce +plugins/earlytalker +plugins/loop plugins/connection_time plugins/content_log plugins/count_unrecognized_commands @@ -172,9 +172,9 @@ t/plugin_tests/auth/auth_vpopmaild t/plugin_tests/auth/authdeny t/plugin_tests/auth/authnull t/plugin_tests/badmailfrom -t/plugin_tests/check_badmailfromto +t/plugin_tests/badmailfromto t/plugin_tests/badrcptto -t/plugin_tests/check_earlytalker +t/plugin_tests/earlytalker t/plugin_tests/count_unrecognized_commands t/plugin_tests/dnsbl t/plugin_tests/dspam diff --git a/config.sample/plugins b/config.sample/plugins index 887a022..5fb03f8 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -30,7 +30,7 @@ dont_require_anglebrackets quit_fortune # tls should load before count_unrecognized_commands #tls -check_earlytalker +earlytalker count_unrecognized_commands 4 relay diff --git a/docs/hooks.pod b/docs/hooks.pod index 6423fc6..3dd7b5a 100644 --- a/docs/hooks.pod +++ b/docs/hooks.pod @@ -293,7 +293,7 @@ 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 +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 diff --git a/plugins/async/check_earlytalker b/plugins/async/earlytalker similarity index 97% rename from plugins/async/check_earlytalker rename to plugins/async/earlytalker index fa0266d..9e3fb22 100644 --- a/plugins/async/check_earlytalker +++ b/plugins/async/earlytalker @@ -2,7 +2,7 @@ =head1 NAME -check_earlytalker - Check that the client doesn't talk before we send the SMTP banner +earlytalker - Check that the client doesn't talk before we send the SMTP banner =head1 DESCRIPTION diff --git a/plugins/check_bogus_bounce b/plugins/bogus_bounce similarity index 97% rename from plugins/check_bogus_bounce rename to plugins/bogus_bounce index 70e5de0..2a97472 100644 --- a/plugins/check_bogus_bounce +++ b/plugins/bogus_bounce @@ -2,7 +2,7 @@ =head1 NAME -check_bogus_bounce - Check that a bounce message isn't bogus +bogus_bounce - Check that a bounce message isn't bogus =head1 DESCRIPTION diff --git a/plugins/check_earlytalker b/plugins/earlytalker similarity index 97% rename from plugins/check_earlytalker rename to plugins/earlytalker index 5a8ef3d..f75c8fe 100644 --- a/plugins/check_earlytalker +++ b/plugins/earlytalker @@ -2,7 +2,7 @@ =head1 NAME -check_earlytalker - Check that the client doesn't talk before we send the SMTP banner +earlytalker - Check that the client doesn't talk before we send the SMTP banner =head1 DESCRIPTION @@ -30,7 +30,7 @@ must also be allowed for. Do we reject/deny connections to early talkers? - check_earlytalker reject [ 0 | 1 ] + earlytalker reject [ 0 | 1 ] Default: I @@ -48,7 +48,7 @@ issued a deny or denysoft (depending on the value of I). The defaul 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 ] + earlytalker defer-reject [ 0 | 1 ] =head2 check-at [ CONNECT | DATA ] diff --git a/plugins/check_loop b/plugins/loop similarity index 97% rename from plugins/check_loop rename to plugins/loop index 634c126..1a3d264 100644 --- a/plugins/check_loop +++ b/plugins/loop @@ -2,7 +2,7 @@ =head1 NAME -check_loop - Detect mail loops +loop - Detect mail loops =head1 DESCRIPTION diff --git a/t/config/plugins b/t/config/plugins index 44bbe28..c4f25d6 100644 --- a/t/config/plugins +++ b/t/config/plugins @@ -30,7 +30,7 @@ parse_addr_withhelo quit_fortune # tls should load before count_unrecognized_commands #tls -check_earlytalker +earlytalker count_unrecognized_commands 4 relay From 8fd04a2621a1ce085f177ae0018185e4a15c2749 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Jun 2012 19:36:58 -0400 Subject: [PATCH 084/352] SPF: more logging additions --- plugins/sender_permitted_from | 56 ++++++++++++++++++++++++++--------- 1 file changed, 42 insertions(+), 14 deletions(-) diff --git a/plugins/sender_permitted_from b/plugins/sender_permitted_from index dabad55..d888701 100644 --- a/plugins/sender_permitted_from +++ b/plugins/sender_permitted_from @@ -143,28 +143,18 @@ sub mail_handler { }; # SPF result codes: pass fail softfail neutral none error permerror temperror + return $self->handle_code_none($reject, $why) if $code eq 'none'; + return $self->handle_code_fail($reject, $why) if $code eq 'fail'; + return $self->handle_code_softfail($reject, $why) if $code eq 'softfail'; + if ( $code eq 'pass' ) { $self->log(LOGINFO, "pass, $code: $why" ); return (DECLINED); } - elsif ( $code eq 'fail' ) { - $self->log(LOGINFO, "fail, $why" ); - return (DENY, "SPF - forgery: $why") if $reject >= 3; - return (DENYSOFT, "SPF - $code: $why") if $reject >= 2; - } - elsif ( $code eq 'softfail' ) { - $self->log(LOGINFO, "fail, $why" ); - return (DENY, "SPF - $code: $why") if $reject >= 4; - return (DENYSOFT, "SPF - $code: $why") if $reject >= 3; - } elsif ( $code eq 'neutral' ) { $self->log(LOGINFO, "fail, $code, $why" ); return (DENY, "SPF - $code: $why") if $reject >= 5; } - elsif ( $code eq 'none' ) { - $self->log(LOGINFO, "fail, $code, $why" ); - return (DENY, "SPF - $code: $why") if $reject >= 6; - } elsif ( $code eq 'error' ) { $self->log(LOGINFO, "fail, $code, $why" ); return (DENY, "SPF - $code: $why") if $reject >= 6; @@ -184,6 +174,44 @@ sub mail_handler { return (DECLINED); } +sub handle_code_none { + my ($self, $reject, $why ) = @_; + + if ( $reject >= 6 ) { + $self->log(LOGINFO, "fail, none, $why" ); + return (DENY, "SPF - none: $why"); + }; + + $self->log(LOGINFO, "pass, none, $why" ); + return DECLINED; +}; + +sub handle_code_fail { + my ($self, $reject, $why ) = @_; + + if ( $reject >= 2 ) { + $self->log(LOGINFO, "fail, $why" ); + return (DENY, "SPF - forgery: $why") if $reject >= 3; + return (DENYSOFT, "SPF - fail: $why") + }; + + $self->log(LOGINFO, "pass, fail tolerated, $why" ); + return DECLINED; +}; + +sub handle_code_softfail { + my ($self, $reject, $why ) = @_; + + if ( $reject >= 3 ) { + $self->log(LOGINFO, "fail, soft, $why" ); + return (DENY, "SPF - fail: $why") if $reject >= 4; + return (DENYSOFT, "SPF - fail: $why") if $reject >= 3; + }; + + $self->log(LOGINFO, "pass, softfail tolerated, $why" ); + return DECLINED; +}; + sub data_post_handler { my ($self, $transaction) = @_; From 0ca16d61a774a83703643eaced3792405e21eb78 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Jun 2012 20:15:13 -0400 Subject: [PATCH 085/352] summarize: check more locations to discover QP dir --- log/summarize.pl | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/log/summarize.pl b/log/summarize.pl index 04784cc..b506d82 100755 --- a/log/summarize.pl +++ b/log/summarize.pl @@ -3,6 +3,7 @@ use strict; use warnings; +use Cwd; use Data::Dumper; use File::Tail; @@ -276,16 +277,20 @@ sub show_symbol { sub get_qp_dir { foreach my $user ( qw/ qpsmtpd smtpd / ) { - my ($homedir) = (getpwnam( $user ))[7] or next; if ( -d "$homedir/plugins" ) { return "$homedir"; }; - if ( -d "$homedir/smtpd/plugins" ) { - return "$homedir/smtpd"; + foreach my $s ( qw/ smtpd qpsmtpd qpsmtpd-dev / ) { + if ( -d "$homedir/smtpd/plugins" ) { + return "$homedir/smtpd"; + }; }; }; + if ( -d "./plugins" ) { + return Cwd::getcwd(); + }; }; sub populate_plugins_from_registry { From ba854c471fca704cfd7c40a62b7e661070070866 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Jun 2012 20:16:11 -0400 Subject: [PATCH 086/352] log/run: removed spurious space --- log/run | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/log/run b/log/run index 5b3b4b6..e3a630c 100755 --- a/log/run +++ b/log/run @@ -1,4 +1,4 @@ -#! /bin/sh +#!/bin/sh export LOGDIR=./main mkdir -p $LOGDIR exec multilog t s10000000 n20 $LOGDIR From 6f34fbb6cdc34ebfd7aa92d6d9f45511e22724d6 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Jun 2012 20:16:34 -0400 Subject: [PATCH 087/352] dspam: better error message if dspam_bin is not found --- plugins/dspam | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/dspam b/plugins/dspam index d92da7f..d133dd8 100644 --- a/plugins/dspam +++ b/plugins/dspam @@ -216,7 +216,7 @@ sub register { $self->{_args}{dspam_bin} ||= '/usr/local/bin/dspam'; if ( ! -x $self->{_args}{dspam_bin} ) { - $self->log(LOGERROR, "dspam not found: "); + $self->log(LOGERROR, "dspam CLI binary not found: install dspam and/or set dspam_bin"); return DECLINED; }; From e3fcd08706778a084e39858b30f81e407a444856 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Jun 2012 20:17:00 -0400 Subject: [PATCH 088/352] qmail_deliverable: test variable if defined before accessing --- plugins/qmail_deliverable | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/qmail_deliverable b/plugins/qmail_deliverable index 0704b06..b22d221 100755 --- a/plugins/qmail_deliverable +++ b/plugins/qmail_deliverable @@ -77,7 +77,7 @@ sub register { $self->log(LOGWARN, "Odd number of arguments, using default config"); } else { my %args = @args; - if ($args{server} =~ /^smtproutes:/) { + if ($args{server} && $args{server} =~ /^smtproutes:/) { my ($fallback, $port) = $args{server} =~ /:(?:(.*?):?)(\d+)/; From c5fb92e64989c733886a8903c79d4f1676135159 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Jun 2012 20:18:16 -0400 Subject: [PATCH 089/352] spamassassin: further log message refinement --- plugins/spamassassin | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/plugins/spamassassin b/plugins/spamassassin index 7070d7f..3c6b0f9 100644 --- a/plugins/spamassassin +++ b/plugins/spamassassin @@ -369,11 +369,12 @@ sub reject { my ($self, $transaction) = @_; my $sa_results = $self->get_spam_results($transaction) or do { - $self->log(LOGNOTICE, "skip, no results"); + $self->log(LOGNOTICE, "error, no results"); return DECLINED; }; - my $score = $sa_results->{score} or do { - $self->log(LOGERROR, "skip, error getting score"); + my $score = $sa_results->{score}; + if ( ! defined $score ) { + $self->log(LOGERROR, "error, error getting score"); return DECLINED; }; @@ -385,7 +386,7 @@ sub reject { }; my $reject = $self->{_args}{reject} or do { - $self->log(LOGERROR, "skip, reject disabled ($status, $learn)"); + $self->log(LOGERROR, "pass, reject disabled ($status, $learn)"); return DECLINED; }; @@ -400,7 +401,7 @@ sub reject { } } - $self->connection->notes('karma', $self->connection->notes('karma') - 1); + $self->connection->notes('karma', ($self->connection->notes('karma') - 1)); # default of media_unsupported is DENY, so just change the message $self->log(LOGINFO, "fail, $status, > $reject, $learn"); return ($self->get_reject_type(), "spam score exceeded threshold"); From db206898875a188c33093a063a71bf11c1ab1e6a Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 29 Jun 2012 20:20:58 -0400 Subject: [PATCH 090/352] registry: added auth_ prefixes, relay aliases --- plugins/registry.txt | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/plugins/registry.txt b/plugins/registry.txt index cedcd91..0ecfb3a 100644 --- a/plugins/registry.txt +++ b/plugins/registry.txt @@ -9,7 +9,7 @@ 3 ident::p0f p0f p0f 5 karma krm karma 6 dnsbl dbl dnsbl -7 relay rly relay +7 relay rly relay check_relay,check_norelay,relay_only 9 earlytalker ear early check_earlytalker 15 helo hlo helo check_spamhelo 16 tls tls tls @@ -22,13 +22,14 @@ # # Authentication # -30 auth::vpopmail_sql aut vpsql -31 auth::vpopmaild vpd vpopd -32 auth::vpopmail vpo vpop -33 auth::checkpasswd ckp chkpw -34 auth::cvs_unix_local cvs cvsul -35 auth::flat_file flt aflat -36 auth::ldap_bind ldp aldap +30 auth::auth_vpopmail_sql aut vpsql +31 auth::auth_vpopmaild vpd vpopd +32 auth::auth_vpopmail vpo vpop +33 auth::auth_checkpasswd ckp chkpw +34 auth::auth_cvs_unix_local cvs cvsul +35 auth::auth_flat_file flt aflat +36 auth::auth_ldap_bind ldp aldap +37 auth::authdeny dny adeny # # Sender / From # From d239f394e9983e03062f91f473f056382c7511d7 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 29 Jun 2012 20:28:38 -0400 Subject: [PATCH 091/352] summarize: recognize tcpserver log entries --- log/summarize.pl | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/log/summarize.pl b/log/summarize.pl index b506d82..c4616ff 100755 --- a/log/summarize.pl +++ b/log/summarize.pl @@ -70,7 +70,7 @@ while ( defined (my $line = $fh->read) ) { next if ! $line; my ( $type, $pid, $hook, $plugin, $message ) = parse_line( $line ); next if ! $type; - next if $type =~ /info|unknown|response/; + next if $type =~ /^(info|unknown|response|tcpserver)$/; next if $type eq 'init'; # doesn't occur in all deployment models if ( ! $pids{$pid} ) { # haven't seen this pid @@ -151,6 +151,7 @@ sub parse_line { return parse_line_plugin( $line ) if substr($message, 0, 1) eq '('; return ( 'dispatch', $pid, undef, undef, $message ) if substr($message, 0, 12) eq 'dispatching '; return ( 'response', $pid, undef, undef, $message ) if $message =~ /^[2|3]\d\d/; + return ( 'tcpserver', $pid, undef, undef, undef ) if substr($pid, 0, 10) eq 'tcpserver:'; # lines seen about once per connection return ( 'init', $pid, undef, undef, $message ) if substr($message, 0, 19) eq 'Accepted connection'; From 5825c2c3c8c4378af2d181978a943ac0876730aa Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 29 Jun 2012 20:29:04 -0400 Subject: [PATCH 092/352] clamdscan: default is scan always, even authenticated --- plugins/virus/clamdscan | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/virus/clamdscan b/plugins/virus/clamdscan index 0af2929..72e64ea 100644 --- a/plugins/virus/clamdscan +++ b/plugins/virus/clamdscan @@ -140,7 +140,7 @@ sub data_post_handler { my $filename = $self->get_filename( $transaction ) or return DECLINED; - return (DECLINED) if $self->is_immune(); + #return (DECLINED) if $self->is_immune(); return (DECLINED) if $self->is_too_big( $transaction ); return (DECLINED) if $self->is_not_multipart( $transaction ); From c723c40670fbb1de813c5e9914a5e37d36b59e82 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 29 Jun 2012 20:30:06 -0400 Subject: [PATCH 093/352] run: define PORT variable --- run | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/run b/run index 22c6029..0e2ff84 100755 --- a/run +++ b/run @@ -11,6 +11,7 @@ PERL=/usr/bin/perl QMAILDUID=`id -u $QPUSER` NOFILESGID=`id -g $QPUSER` IP=`head -1 config/IP` +PORT=25 LANG=C # Remove the comments between the and tags to choose a @@ -19,7 +20,7 @@ LANG=C # exec $BIN/softlimit -m $MAXRAM \ $BIN/tcpserver -c 10 -v -R -p \ - -u $QMAILDUID -g $NOFILESGID $IP smtp \ + -u $QMAILDUID -g $NOFILESGID $IP $PORT \ ./qpsmtpd 2>&1 # @@ -30,7 +31,7 @@ exec $BIN/softlimit -m $MAXRAM \ # exec $BIN/softlimit -m $MAXRAM \ # $PERL -T ./qpsmtpd-forkserver \ # --listen-address $IP \ -# --port 25 \ +# --port $PORT \ # --limit-connections 15 \ # --max-from-ip 5 \ # --user $QPUSER From 3a50137b34f8a4b72752a6b9073de6faa8f0e049 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 29 Jun 2012 20:39:44 -0400 Subject: [PATCH 094/352] logs: improve ability to find logs --- log/summarize.pl | 4 ++-- log/watch.pl | 22 ++++++++++++++-------- 2 files changed, 16 insertions(+), 10 deletions(-) diff --git a/log/summarize.pl b/log/summarize.pl index c4616ff..1201aa0 100755 --- a/log/summarize.pl +++ b/log/summarize.pl @@ -284,8 +284,8 @@ sub get_qp_dir { return "$homedir"; }; foreach my $s ( qw/ smtpd qpsmtpd qpsmtpd-dev / ) { - if ( -d "$homedir/smtpd/plugins" ) { - return "$homedir/smtpd"; + if ( -d "$homedir/$s/plugins" ) { + return "$homedir/$s"; }; }; }; diff --git a/log/watch.pl b/log/watch.pl index b93ff6e..0514a3d 100755 --- a/log/watch.pl +++ b/log/watch.pl @@ -3,11 +3,12 @@ use strict; use warnings; +use Cwd; use Data::Dumper; use File::Tail; -my $dir = find_qp_log_dir() or die "unable to find QP home dir"; -my $file = "$dir/main/current"; +my $dir = get_qp_dir() or die "unable to find QP home dir"; +my $file = "$dir/log/main/current"; my $fh = File::Tail->new(name=>$file, interval=>1, maxinterval=>1, debug =>1, tail =>100 ); while ( defined (my $line = $fh->read) ) { @@ -15,16 +16,21 @@ while ( defined (my $line = $fh->read) ) { print $line; }; -sub find_qp_log_dir { +sub get_qp_dir { foreach my $user ( qw/ qpsmtpd smtpd / ) { - my ($homedir) = (getpwnam( $user ))[7] or next; - if ( -d "$homedir/log" ) { - return "$homedir/log"; + if ( -d "$homedir/plugins" ) { + return "$homedir"; }; - if ( -d "$homedir/smtpd/log" ) { - return "$homedir/smtpd/log"; + foreach my $s ( qw/ smtpd qpsmtpd qpsmtpd-dev / ) { + if ( -d "$homedir/$s/plugins" ) { + return "$homedir/$s"; + }; }; }; + if ( -d "./plugins" ) { + return Cwd::getcwd(); + }; }; + From 5bc212b890008ac6646148faff7add9ac2bfee0f Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 30 Jun 2012 14:18:16 -0400 Subject: [PATCH 095/352] helo: added is_plain_ip to lenient checks there's no excuse for a client to ever send a raw IP, and I have yet to see a valid client do it --- plugins/helo | 23 +++++++++++------------ 1 file changed, 11 insertions(+), 12 deletions(-) diff --git a/plugins/helo b/plugins/helo index 58748c7..10ee6b3 100644 --- a/plugins/helo +++ b/plugins/helo @@ -106,25 +106,25 @@ Default: lenient =head3 lenient -Reject failures of the following tests: is_in_badhelo, invalid_localhost, and -is_forged_literal. +Reject failures of the following tests: is_in_badhelo, invalid_localhost, +is_forged_literal, and is_plain_ip. 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. +support, the prevention of forged localhost, forged IP literals, and plain +IPs. =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. +the following are enforced: 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. +I without settings I and using the B +plugin. Windows PCs often send unqualified HELO names and will have trouble +sending mail. The B plugin defers the rejection, and if the user +subsequently authenticates, the rejection is be cancelled. =head3 strict @@ -259,11 +259,10 @@ sub populate_tests { my $self = shift; my $policy = $self->{_args}{policy}; - @{ $self->{_helo_tests} } = qw/ is_in_badhelo invalid_localhost is_forged_literal /; + @{ $self->{_helo_tests} } = qw/ is_in_badhelo invalid_localhost is_forged_literal is_plain_ip /; if ( $policy eq 'rfc' || $policy eq 'strict' ) { - push @{ $self->{_helo_tests} }, qw/ is_plain_ip is_not_fqdn - no_forward_dns no_reverse_dns /; + push @{ $self->{_helo_tests} }, qw/ is_not_fqdn no_forward_dns no_reverse_dns /; }; if ( $policy eq 'strict' ) { From 7d5edacf9be732c79f705d791500b7dfeb75d15d Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 30 Jun 2012 15:37:25 -0400 Subject: [PATCH 096/352] karma: added adjust_karma method makes it easier to set karma in plugins --- lib/Qpsmtpd/Plugin.pm | 9 ++ plugins/badmailfrom | 2 +- plugins/dspam | 9 +- plugins/earlytalker | 2 +- plugins/helo | 2 +- plugins/karma | 16 +-- plugins/qmail_deliverable | 4 +- plugins/spamassassin | 2 +- plugins/whitelist | 223 ++++++++++++++++++++++++++++++++++++++ 9 files changed, 248 insertions(+), 21 deletions(-) create mode 100644 plugins/whitelist diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm index 6b063b4..3086c20 100644 --- a/lib/Qpsmtpd/Plugin.pm +++ b/lib/Qpsmtpd/Plugin.pm @@ -282,6 +282,15 @@ sub is_immune { return; }; +sub adjust_karma { + my ( $self, $value ) = @_; + + my $karma = $self->connection->notes('karma') || 0 + $karma += $value; + $self->connection->notes('karma', $value); + return $value; +}; + sub _register_standard_hooks { my ($plugin, $qp) = @_; diff --git a/plugins/badmailfrom b/plugins/badmailfrom index 47aa425..1d1f36f 100644 --- a/plugins/badmailfrom +++ b/plugins/badmailfrom @@ -85,7 +85,7 @@ sub hook_mail { next unless $bad; next unless $self->is_match( $from, $bad, $host ); $reason ||= "Your envelope sender is in my badmailfrom list"; - $self->connection->notes('karma', ($self->connection->notes('karma') || 0) - 1); + $self->adjust_karma( -1 ); return $self->get_reject( $reason ); } diff --git a/plugins/dspam b/plugins/dspam index d133dd8..72aba48 100644 --- a/plugins/dspam +++ b/plugins/dspam @@ -478,9 +478,7 @@ sub reject_agree { 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->adjust_karma( -2 ); $self->log(LOGINFO, "fail, agree, $status"); my $reject = $self->get_reject_type(); return ($reject, 'we agree, no spam please'); @@ -493,9 +491,7 @@ sub reject_agree { 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->adjust_karma( 2 ); }; $self->log(LOGINFO, "pass, agree, $status"); return DECLINED; @@ -591,6 +587,7 @@ sub autolearn { defined $self->{_args}{autolearn} or return; + # only train once. $self->autolearn_naughty( $response, $transaction ) and return; $self->autolearn_karma( $response, $transaction ) and return; $self->autolearn_spamassassin( $response, $transaction ) and return; diff --git a/plugins/earlytalker b/plugins/earlytalker index f75c8fe..f7d38b2 100644 --- a/plugins/earlytalker +++ b/plugins/earlytalker @@ -173,7 +173,7 @@ sub connect_handler { }; $self->connection->notes('earlytalker', 1); - $self->connection->notes('karma', -1); + $self->adjust_karma( -1 ); return DECLINED; } diff --git a/plugins/helo b/plugins/helo index 10ee6b3..29a3633 100644 --- a/plugins/helo +++ b/plugins/helo @@ -430,7 +430,7 @@ sub no_matching_dns { 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 + $self->adjust_karma( 1 ); # whoppee, a match! return; }; diff --git a/plugins/karma b/plugins/karma index e46fdfb..18fc768 100644 --- a/plugins/karma +++ b/plugins/karma @@ -177,14 +177,14 @@ those senders haven't sent us any ham. As such, it's much safer to use. 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 +I is the number of 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! +To alter a connections karma based on its behavior, do this: + + $self->adjust_karma( -1 ); # lower karma (naughty) + $self->adjust_karma( 1 ); # raise karma (good) + =head1 EFFECTIVENESS @@ -194,7 +194,7 @@ 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. +reduces the resources they can waste. Of the connections that had previously passed all other checks and were caught only by spamassassin and/or dspam, B rejected 31 percent. Since @@ -207,7 +207,7 @@ 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. +karma_tool script. =head1 BUGS & LIMITATIONS diff --git a/plugins/qmail_deliverable b/plugins/qmail_deliverable index b22d221..04cf5aa 100755 --- a/plugins/qmail_deliverable +++ b/plugins/qmail_deliverable @@ -138,9 +138,7 @@ sub rcpt_handler { return DECLINED if $rv; - if ( defined $self->connection->notes('karma') ) { - $self->connection->notes('karma', ($self->connection->notes('karma') - 1)); - }; + $self->adjust_karma( -1 ); return (DENY, "fail, no mailbox by that name. qd (#5.1.1)" ); } diff --git a/plugins/spamassassin b/plugins/spamassassin index 3c6b0f9..6e81c7e 100644 --- a/plugins/spamassassin +++ b/plugins/spamassassin @@ -401,7 +401,7 @@ sub reject { } } - $self->connection->notes('karma', ($self->connection->notes('karma') - 1)); + $self->adjust_karma( -1 ); # default of media_unsupported is DENY, so just change the message $self->log(LOGINFO, "fail, $status, > $reject, $learn"); return ($self->get_reject_type(), "spam score exceeded threshold"); diff --git a/plugins/whitelist b/plugins/whitelist new file mode 100644 index 0000000..2e0ccb7 --- /dev/null +++ b/plugins/whitelist @@ -0,0 +1,223 @@ + +=head1 NAME + +whitelist - whitelist override for other qpsmtpd plugins + + +=head1 DESCRIPTION + +The B plugin allows selected hosts or senders or recipients +to be whitelisted as exceptions to later plugin processing. It is a more +conservative variant of Devin Carraway's 'whitelist' plugin. + + +=head1 CONFIGURATION + +To enable the plugin, add it to the qpsmtpd/config/plugins file as usual. +It should precede any plugins you might wish to whitelist for. + +Several configuration files are supported, corresponding to different +parts of the SMTP conversation: + +=over 4 + +=item whitelisthosts + +Any IP address (or start-anchored fragment thereof) listed in the +whitelisthosts file is exempted from any further validation during +'connect', and can be selectively exempted at other stages by +plugins testing for a 'whitelisthost' connection note. + +Similarly, if the environment variable $WHITELISTCLIENT is set +(which can be done by tcpserver), the connection will be exempt from +further 'connect' validation, and the host can be selectively +exempted by other plugins testing for a 'whitelistclient' connection +note. + +=item whitelisthelo + +Any host that issues a HELO matching an entry in whitelisthelo will +be exempted from further validation at the 'helo' stage. Subsequent +plugins can test for a 'whitelisthelo' connection note. Note that +this does not actually amount to an authentication in any meaningful +sense. + +=item whitelistsenders + +If the envelope sender of a mail (that which is sent as the MAIL FROM) +matches an entry in whitelistsenders, or if the hostname component +matches, the mail will be exempted from any further validation within +the 'mail' stage. Subsequent plugins can test for this exemption as a +'whitelistsender' transaction note. + +=item whitelistrcpt + +If any recipient of a mail (that sent as the RCPT TO) matches an +entry from whitelistrcpt, or if the hostname component matches, no +further validation will be required for this recipient. Subsequent +plugins can test for this exemption using a 'whitelistrcpt' +transaction note, which holds the count of whitelisted recipients. + +=back + +whitelist_soft also supports per-recipient whitelisting when using +the per_user_config plugin. To enable the per-recipient behaviour +(delaying all whitelisting until the rcpt part of the smtp +conversation, and using per-recipient whitelist configs, if +available), pass a true 'per_recipient' argument in the +config/plugins invocation i.e. + + whitelist_soft per_recipient 1 + +By default global and per-recipient whitelists are merged; to turn off +the merge behaviour pass a false 'merge' argument in the config/plugins +invocation i.e. + + whitelist_soft per_recipient 1 merge 0 + + +=head1 BUGS + +Whitelist lookups are all O(n) linear scans of configuration files, even +though they're all associative lookups. Something should be done about +this when CDB/DB/GDBM configs are supported. + + +=head1 AUTHOR + +Based on the 'whitelist' plugin by Devin Carraway . + +Modified by Gavin Carr to not inherit +whitelisting across hooks, but use per-hook whitelist notes instead. +This is a more conservative approach e.g. whitelisting an IP will not +automatically allow relaying from that IP. + +=cut + +my $VERSION = 0.02; + +# Default is to merge whitelists in per_recipient mode +my %MERGE = (merge => 1); + +sub register { + my ($self, $qp, %arg) = @_; + + $self->{_per_recipient} = 1 if $arg{per_recipient}; + $MERGE{merge} = $arg{merge} if defined $arg{merge}; + + # Normal mode - whitelist per hook + unless ($arg{per_recipient}) { + $self->register_hook("connect", "check_host"); + $self->register_hook("helo", "check_helo"); + $self->register_hook("ehlo", "check_helo"); + $self->register_hook("mail", "check_sender"); + $self->register_hook("rcpt", "check_rcpt"); + } + + # Per recipient mode - defer all whitelisting to rcpt hook + else { + $self->register_hook("rcpt", "check_host"); + $self->register_hook("helo", "helo_helper"); + $self->register_hook("ehlo", "helo_helper"); + $self->register_hook("rcpt", "check_helo"); + $self->register_hook("rcpt", "check_sender"); + $self->register_hook("rcpt", "check_rcpt"); + } +} + +sub check_host { + my ($self, $transaction, $rcpt) = @_; + my $ip = $self->qp->connection->remote_ip || return (DECLINED); + + # From tcpserver + if (exists $ENV{WHITELISTCLIENT}) { + $self->qp->connection->notes('whitelistclient', 1); + $self->log(2, "host $ip is a whitelisted client"); + return OK; + } + + my $config_arg = $self->{_per_recipient} ? {rcpt => $rcpt, %MERGE} : {}; + for my $h ($self->qp->config('whitelisthosts', $config_arg)) { + if ($h eq $ip or $ip =~ /^\Q$h\E/) { + $self->qp->connection->notes('whitelisthost', 1); + $self->log(2, "host $ip is a whitelisted host"); + return OK; + } + } + return DECLINED; +} + +sub helo_helper { + my ($self, $transaction, $helo) = @_; + $self->{_whitelist_soft_helo} = $helo; + return DECLINED; +} + +sub check_helo { + my ($self, $transaction, $helo) = @_; + + # If per_recipient will be rcpt hook, and helo actually rcpt + my $config_arg = {}; + if ($self->{_per_recipient}) { + $config_arg = {rcpt => $helo, %MERGE}; + $helo = $self->{_whitelist_soft_helo}; + } + + for my $h ($self->qp->config('whitelisthelo', $config_arg)) { + if ($helo and lc $h eq lc $helo) { + $self->qp->connection->notes('whitelisthelo', 1); + $self->log(2, "helo host $helo in whitelisthelo"); + return OK; + } + } + return DECLINED; +} + +sub check_sender { + my ($self, $transaction, $sender) = @_; + + # If per_recipient will be rcpt hook, and sender actually rcpt + my $config_arg = {}; + if ($self->{_per_recipient}) { + $config_arg = {rcpt => $sender, %MERGE}; + $sender = $transaction->sender; + } + + return DECLINED if $sender->format eq '<>'; + my $addr = lc $sender->address or return DECLINED; + my $host = lc $sender->host or return DECLINED; + + for my $h ($self->qp->config('whitelistsenders', $config_arg)) { + next unless $h; + $h = lc $h; + + if ($addr eq $h or $host eq $h) { + $transaction->notes('whitelistsender', 1); + $self->log(2, "envelope sender $addr in whitelistsenders"); + return OK; + } + } + return DECLINED; +} + +sub check_rcpt { + my ($self, $transaction, $rcpt) = @_; + + my $addr = lc $rcpt->address or return DECLINED; + my $host = lc $rcpt->host or return DECLINED; + + my $config_arg = $self->{_per_recipient} ? {rcpt => $rcpt, %MERGE} : {}; + for my $h ($self->qp->config('whitelistrcpt', $config_arg)) { + next unless $h; + $h = lc $h; + + if ($addr eq $h or $host eq $h) { + my $note = $transaction->notes('whitelistrcpt'); + $transaction->notes('whitelistrcpt', ++$note); + $self->log(2, "recipient $addr in whitelistrcpt"); + return OK; + } + } + return DECLINED; +} + From ad56587e798fc96df0178e4b8a15873e7fa5020b Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 30 Jun 2012 15:40:24 -0400 Subject: [PATCH 097/352] added log/show_message, dropped .pl suffix to be consistent with other QP scripts --- log/{log2sql.pl => log2sql} | 0 log/show_message | 72 +++++++++++++++++++++++++++++++++ log/{summarize.pl => summarize} | 0 log/{watch.pl => watch} | 0 4 files changed, 72 insertions(+) rename log/{log2sql.pl => log2sql} (100%) create mode 100755 log/show_message rename log/{summarize.pl => summarize} (100%) rename log/{watch.pl => watch} (100%) diff --git a/log/log2sql.pl b/log/log2sql similarity index 100% rename from log/log2sql.pl rename to log/log2sql diff --git a/log/show_message b/log/show_message new file mode 100755 index 0000000..932726a --- /dev/null +++ b/log/show_message @@ -0,0 +1,72 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Data::Dumper; + +my $QPDIR = '/usr/home/qpsmtpd/smtpd'; +my $logfile = "$QPDIR/log/main/current"; + +my $is_ip = 0; +my $search = $ARGV[0]; + +if ( ! $search ) { + die "\nusage: $0 [ ip_address | PID ]\n\n"; +}; + +if ( $search =~ /^(?:[0-9]{1,3}\.){3}[0-9]{1,3}$/ ) { + #print "it's an IP\n"; + $is_ip++; +}; + +open my $LOG, '<', $logfile; + +if ( $is_ip ) { # look for the connection start message for the IP + my $ip_matches; + while ( defined (my $line = <$LOG>) ) { + next if ! $line; + my ( $tai, $pid, $mess ) = split /\s/, $line, 3; + if ( 'Connection from ' eq substr( $mess, 0, 16 ) ) { + my ( $ip ) = (split /\s+/, $mess)[-1]; # IP is last word + $ip = substr $ip, 1, -1; # trim off brackets + if ( $ip eq $search ) { + $ip_matches++; + $search = $pid; + $is_ip = 0; + }; + }; + }; + seek $LOG, 0, 0; + die "no pid found for ip $search\n" if $is_ip; + print "showing the last of $ip_matches connnections from $ARGV[0]\n"; +}; + +print "showing QP message PID $search\n"; + +while ( defined (my $line = <$LOG>) ) { + next if ! $line; + my ( $tai, $pid, $mess ) = split /\s/, $line, 3; + next if ! $pid; + print $mess if ( $pid eq $search ); +}; +close $LOG; + + +sub get_qp_dir { + foreach my $user ( qw/ qpsmtpd smtpd / ) { + my ($homedir) = (getpwnam( $user ))[7] or next; + + if ( -d "$homedir/plugins" ) { + return "$homedir"; + }; + foreach my $s ( qw/ smtpd qpsmtpd qpsmtpd-dev / ) { + if ( -d "$homedir/$s/plugins" ) { + return "$homedir/$s"; + }; + }; + }; + if ( -d "./plugins" ) { + return Cwd::getcwd(); + }; +}; diff --git a/log/summarize.pl b/log/summarize similarity index 100% rename from log/summarize.pl rename to log/summarize diff --git a/log/watch.pl b/log/watch similarity index 100% rename from log/watch.pl rename to log/watch From 45da124f9ffd5d371814072f76258b9f8af12de2 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 30 Jun 2012 15:58:21 -0400 Subject: [PATCH 098/352] config: replace domainkeys with dkim dkim is the heir apparent the Mail::DomainKeys perl module is deprecated (per it's author) --- config.sample/plugins | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config.sample/plugins b/config.sample/plugins index 5fb03f8..25cf8bb 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -56,7 +56,7 @@ auth/authdeny rcpt_ok headers days 5 reject_type temp require From,Date -domainkeys +dkim # content filters #uribl From 2a85f3b8fbc88395e158ebcb894a2845f63d6a6e Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 30 Jun 2012 16:11:54 -0400 Subject: [PATCH 099/352] karma: added error keyword to error log messages --- plugins/karma | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/plugins/karma b/plugins/karma index 18fc768..b5a3a33 100644 --- a/plugins/karma +++ b/plugins/karma @@ -383,7 +383,7 @@ 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: $!"); + $self->log(LOGCRIT, "error, tie to database $db failed: $!"); close $lock; return; }; @@ -416,12 +416,12 @@ sub get_db_lock { # Check denysoft db open( my $lock, ">$db.lock" ) or do { - $self->log(LOGCRIT, "opening lockfile failed: $!"); + $self->log(LOGCRIT, "error, opening lockfile failed: $!"); return; }; flock( $lock, LOCK_EX ) or do { - $self->log(LOGCRIT, "flock of lockfile failed: $!"); + $self->log(LOGCRIT, "error, flock of lockfile failed: $!"); close $lock; return; }; @@ -441,12 +441,12 @@ sub get_db_lock_nfs { blocking_timeout => 10, # 10 sec stale_lock_timeout => 30 * 60, # 30 min } or do { - $self->log(LOGCRIT, "nfs lockfile failed: $!"); + $self->log(LOGCRIT, "error, nfs lockfile failed: $!"); return; }; open( my $lock, "+<$db.lock") or do { - $self->log(LOGCRIT, "opening nfs lockfile failed: $!"); + $self->log(LOGCRIT, "error, opening nfs lockfile failed: $!"); return; }; From 1d2192ba17b965e4f114880731cb69817437805c Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 30 Jun 2012 16:12:42 -0400 Subject: [PATCH 100/352] registry: renamed clamd abb3 from cad to clm --- plugins/registry.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/registry.txt b/plugins/registry.txt index 0ecfb3a..8d6f1ae 100644 --- a/plugins/registry.txt +++ b/plugins/registry.txt @@ -64,7 +64,7 @@ 70 virus::aveclient ave avirs 71 virus::bitdefender bit bitdf 72 virus::clamav cav clamv -73 virus::clamdscan cad clamd +73 virus::clamdscan clm clamd 74 virus::hbedv hbv hbedv 75 virus::kavscanner kav kavsc 76 virus::klez_filter klz vklez From c6b7b504bb98ecdc0273aa479d45623d1fe048f1 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 30 Jun 2012 16:28:54 -0400 Subject: [PATCH 101/352] added missing semicolon --- lib/Qpsmtpd/Plugin.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm index 3086c20..3bb4b73 100644 --- a/lib/Qpsmtpd/Plugin.pm +++ b/lib/Qpsmtpd/Plugin.pm @@ -285,7 +285,7 @@ sub is_immune { sub adjust_karma { my ( $self, $value ) = @_; - my $karma = $self->connection->notes('karma') || 0 + my $karma = $self->connection->notes('karma') || 0; $karma += $value; $self->connection->notes('karma', $value); return $value; From dc02055c96350b03248b08e8ab327b76cc745300 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 30 Jun 2012 16:40:51 -0400 Subject: [PATCH 102/352] log/summarize: added auth formats --- log/summarize | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/log/summarize b/log/summarize index 1201aa0..f1cf174 100755 --- a/log/summarize +++ b/log/summarize @@ -38,6 +38,10 @@ my %formats = ( check_earlytalker => "%-3.3s", helo => "%-3.3s", tls => "%-3.3s", + 'auth::auth_vpopmail' => "%-3.3s", + 'auth::auth_vpopmaild' => "%-3.3s", + 'auth::auth_vpopmail_sql' => "%-3.3s", + 'auth::auth_checkpassword' => "%-3.3s", badmailfrom => "%-3.3s", check_badmailfrom => "%-3.3s", sender_permitted_from => "%-3.3s", From ee7ae800b2eeb60baa24a80cccacedb7522881c5 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 30 Jun 2012 16:43:15 -0400 Subject: [PATCH 103/352] config/plugins: better defaults, additional entries --- config.sample/plugins | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/config.sample/plugins b/config.sample/plugins index 25cf8bb..7f19860 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -28,6 +28,8 @@ dont_require_anglebrackets # parse_addr_withhelo quit_fortune +#karma penalty_box 1 reject naughty + # tls should load before count_unrecognized_commands #tls earlytalker @@ -37,10 +39,10 @@ relay resolvable_fromhost rhsbl -dnsbl +dnsbl reject naughty reject_type disconnect badmailfrom badrcptto -helo +helo policy lenient # sender_permitted_from # greylisting p0f genre,windows @@ -65,18 +67,21 @@ virus/klez_filter # You can run the spamassassin plugin with options. See perldoc # plugins/spamassassin for details. # -spamassassin +spamassassin reject 12 # 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 +# spamassassin reject 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 +# virus/clamdscan deny_viruses yes scan_all 1 + +naughty reject data # You must enable a queue plugin - see the options in plugins/queue/ - for example: From 45a2116e8ea8b6ef0f7393b9bde3976301f2b9a5 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 30 Jun 2012 17:51:59 -0400 Subject: [PATCH 104/352] log/summarize: narrower column when no geoip city data present --- log/summarize | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/log/summarize b/log/summarize index f1cf174..b203cca 100755 --- a/log/summarize +++ b/log/summarize @@ -25,7 +25,6 @@ my %formats = ( ip => "%-15.15s", hostname => "%-20.20s", distance => "%5.5s", - 'ident::geoip' => "%-20.20s", 'ident::p0f' => "%-10.10s", count_unrecognized_commands => "%-5.5s", @@ -109,10 +108,16 @@ while ( defined (my $line = $fh->read) ) { }; if ( $plugin eq 'ident::geoip' ) { - my ($gip, $distance) = $message =~ /(.*?),\s+([\d]+)\skm/; - if ( $distance ) { - $pids{$pid}{$plugin} = $gip; - $pids{$pid}{distance} = $distance; + if ( length $message < 3 ) { + $formats{'ident::geoip'} = "%-3.3s"; + $formats3{'ident::geoip'} = "%-3.3s"; + } + else { + my ($gip, $distance) = $message =~ /(.*?),\s+([\d]+)\skm/; + if ( $distance ) { + $pids{$pid}{$plugin} = $gip; + $pids{$pid}{distance} = $distance; + }; }; }; } @@ -234,12 +239,12 @@ sub print_auto_format { if ( defined $pids{$pid}{helo_host} && $plugin =~ /helo/ ) { $format .= " %-18.18s"; - push @values, delete $pids{$pid}{helo_host}; + push @values, substr( delete $pids{$pid}{helo_host}, -18, 18); push @headers, 'HELO'; } elsif ( defined $pids{$pid}{from} && $plugin =~ /from/ ) { $format .= " %-20.20s"; - push @values, delete $pids{$pid}{from}; + push @values, substr( delete $pids{$pid}{from}, -20, 20); push @headers, 'MAIL FROM'; } elsif ( defined $pids{$pid}{to} && $plugin =~ /to|rcpt|recipient/ ) { From d0e9a010da9bc2fa5d7cd6a40aea941362584ae7 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 30 Jun 2012 19:04:42 -0400 Subject: [PATCH 105/352] log/show_message: fixed QP dir detection --- log/show_message | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/log/show_message b/log/show_message index 932726a..9ee2ef1 100755 --- a/log/show_message +++ b/log/show_message @@ -5,7 +5,7 @@ use warnings; use Data::Dumper; -my $QPDIR = '/usr/home/qpsmtpd/smtpd'; +my $QPDIR = get_qp_dir(); my $logfile = "$QPDIR/log/main/current"; my $is_ip = 0; @@ -20,7 +20,7 @@ if ( $search =~ /^(?:[0-9]{1,3}\.){3}[0-9]{1,3}$/ ) { $is_ip++; }; -open my $LOG, '<', $logfile; +open my $LOG, '<', $logfile or die "unable to open $logfile\n"; if ( $is_ip ) { # look for the connection start message for the IP my $ip_matches; From f5021a6d554ff2a78e2a0b6d9169913670a147f0 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 30 Jun 2012 19:10:14 -0400 Subject: [PATCH 106/352] resolvable_fromhost: additional logging --- plugins/resolvable_fromhost | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/plugins/resolvable_fromhost b/plugins/resolvable_fromhost index d65bece..3181470 100644 --- a/plugins/resolvable_fromhost +++ b/plugins/resolvable_fromhost @@ -68,6 +68,7 @@ Default: temp (temporary, aka soft, aka 4xx). use strict; use warnings; +use lib 'lib'; use Qpsmtpd::Constants; use Qpsmtpd::DSN; use Qpsmtpd::TcpServer; @@ -114,13 +115,14 @@ sub hook_mail { }; my $result = $transaction->notes('resolvable_fromhost') or do { + $self->log(LOGINFO, 'error, missing result' ); return Qpsmtpd::DSN->temp_resolver_failed( $self->get_reject_type(), '' ); }; return DECLINED if $result =~ /^(?:a|ip|mx)$/; # success return DECLINED if $result =~ /^(?:whitelist|null|naughty)$/; # immunity - $self->log(LOGINFO, $result ); # log error + $self->log(LOGINFO, "fail, $result" ); # log error return Qpsmtpd::DSN->addr_bad_from_system( $self->get_reject_type(), "FQDN required in the envelope sender"); From a8e793e0af92f889a86dd06b7966198b842dd67b Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 30 Jun 2012 22:35:17 -0400 Subject: [PATCH 107/352] earlytalker: lower karma for earlytalkers --- plugins/earlytalker | 1 + 1 file changed, 1 insertion(+) diff --git a/plugins/earlytalker b/plugins/earlytalker index f7d38b2..bcbad95 100644 --- a/plugins/earlytalker +++ b/plugins/earlytalker @@ -205,6 +205,7 @@ sub log_and_deny { my $ip = $self->qp->connection->remote_ip || 'remote host'; $self->connection->notes('earlytalker', 1); + $self->adjust_karma( -1 ); my $log_mess = "$ip started talking before we said hello"; my $smtp_msg = 'Connecting host started transmitting before SMTP greeting'; From b174bb0c4dd865312c264504935549e962004336 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 20 Jul 2012 11:35:20 -0400 Subject: [PATCH 108/352] allow messages with no body: Robin's patch This is Robin's patch from here: http://sources.gentoo.org/cgi-bin/viewvc.cgi/gentoo-x86/mail-mta/qpsmtpd/files/qpsmtpd-0.83-accept-empty-email.patch?view=markup --- lib/Qpsmtpd/SMTP.pm | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index 4247503..f1b48db 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -634,7 +634,10 @@ sub data_respond { my $timeout = $self->config('timeout'); while (defined($_ = $self->getline($timeout))) { - $complete++, last if $_ eq ".\r\n"; + if ( $_ eq ".\r\n" ) { + $complete++; + $_ eq ''; + }; $i++; # should probably use \012 and \015 in these checks instead of \r and \n ... @@ -650,7 +653,7 @@ sub data_respond { unless (($max_size and $size > $max_size)) { s/\r\n$/\n/; s/^\.\./\./; - if ($in_header and m/^$/) { + if ($in_header && (m/^$/ || $complete > 0)) { $in_header = 0; my @headers = split /^/m, $buffer; @@ -693,9 +696,10 @@ sub data_respond { # copy all lines into the spool file, including the headers # we will create a new header later before sending onwards - $self->transaction->body_write($_); + $self->transaction->body_write($_) if ! $complete; $size += length $_; } + last if $complete > 0; #$self->log(LOGDEBUG, "size is at $size\n") unless ($i % 300); } From 6baa6652124466a058613fe9140d2d4e4461d8b0 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 20 Jul 2012 11:41:09 -0400 Subject: [PATCH 109/352] change loglevel from 9 to 6 more appropriate loglevel for users --- config.sample/logging | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config.sample/logging b/config.sample/logging index a870643..578467a 100644 --- a/config.sample/logging +++ b/config.sample/logging @@ -5,7 +5,7 @@ # are included below. Just remove the # symbol to enable them. # default logging plugin -logging/warn 9 +logging/warn 6 #logging/adaptive [accept minlevel] [reject maxlevel] [prefix char] #logging/adaptive 4 6 From 8a4cb80d52e8940b467f51176cd6339936cc62e9 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 20 Jul 2012 11:43:20 -0400 Subject: [PATCH 110/352] dnsbl rejections handled by naughty plugin --- config.sample/plugins | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/config.sample/plugins b/config.sample/plugins index 887a022..4dc72d8 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -37,7 +37,7 @@ relay resolvable_fromhost rhsbl -dnsbl +dnsbl reject naughty badmailfrom badrcptto helo @@ -78,6 +78,8 @@ dspam learn_from_sa 7 reject 1 # run the clamav virus checking plugin # virus/clamav +naughty + # You must enable a queue plugin - see the options in plugins/queue/ - for example: # queue to a maildir From 0985535c91e96af3e3e6d5091bbd08c5654cd8aa Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 20 Jul 2012 11:43:59 -0400 Subject: [PATCH 111/352] added explicit spamassassin reject level --- config.sample/plugins | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config.sample/plugins b/config.sample/plugins index 4dc72d8..bdbdd54 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -65,7 +65,7 @@ virus/klez_filter # You can run the spamassassin plugin with options. See perldoc # plugins/spamassassin for details. # -spamassassin +spamassassin reject 12 # rejects mails with a SA score higher than 20 and munges the subject # of the score is higher than 10. From 3f62ac49beae9aad13bab22c05e5735f2bcdb3d7 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 20 Jul 2012 11:44:29 -0400 Subject: [PATCH 112/352] replaced domainkeys with dkim plugin --- config.sample/plugins | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config.sample/plugins b/config.sample/plugins index bdbdd54..50cf04a 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -56,7 +56,7 @@ auth/authdeny rcpt_ok headers days 5 reject_type temp require From,Date -domainkeys +dkim # content filters #uribl From 09a50f020bb132f2871c060b29af4aaa1325cb60 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 20 Jul 2012 11:48:36 -0400 Subject: [PATCH 113/352] decrement karma when detected --- plugins/earlytalker | 1 + 1 file changed, 1 insertion(+) diff --git a/plugins/earlytalker b/plugins/earlytalker index f7d38b2..bcbad95 100644 --- a/plugins/earlytalker +++ b/plugins/earlytalker @@ -205,6 +205,7 @@ sub log_and_deny { my $ip = $self->qp->connection->remote_ip || 'remote host'; $self->connection->notes('earlytalker', 1); + $self->adjust_karma( -1 ); my $log_mess = "$ip started talking before we said hello"; my $smtp_msg = 'Connecting host started transmitting before SMTP greeting'; From cfe81cddf8e2286bdded2aeba40eb0498600f296 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 20 Jul 2012 11:49:33 -0400 Subject: [PATCH 114/352] update plugin/headers config entry use future/past instead of days: -headers days 5 reject_type temp require From,Date +headers reject 1 reject_type temp require From,Date future 2 past 15 --- config.sample/plugins | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config.sample/plugins b/config.sample/plugins index 7f19860..94bcc4f 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -57,7 +57,7 @@ auth/authdeny # this plugin needs to run after all other "rcpt" plugins rcpt_ok -headers days 5 reject_type temp require From,Date +headers reject 1 reject_type temp require From,Date future 2 past 15 dkim # content filters From 425c25c7ac3419ceb25e76b73b64f47d2b211f5a Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 20 Jul 2012 11:54:56 -0400 Subject: [PATCH 115/352] removed duplicate naughty from config --- config.sample/plugins | 2 -- 1 file changed, 2 deletions(-) diff --git a/config.sample/plugins b/config.sample/plugins index 1e31418..7f19860 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -83,8 +83,6 @@ dspam learn_from_sa 7 reject 1 naughty reject data -naughty - # You must enable a queue plugin - see the options in plugins/queue/ - for example: # queue to a maildir From 3438fed859dcbc742997839e8037d9357a28ceec Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 20 Jul 2012 11:59:54 -0400 Subject: [PATCH 116/352] added vpopmail_ext to qmail_deliverable plugin --- plugins/qmail_deliverable | 89 +++++++++++++++++++++++++++++++++------ 1 file changed, 75 insertions(+), 14 deletions(-) diff --git a/plugins/qmail_deliverable b/plugins/qmail_deliverable index 04cf5aa..e4e0263 100755 --- a/plugins/qmail_deliverable +++ b/plugins/qmail_deliverable @@ -38,6 +38,13 @@ Example: Use "smtproutes:8998" (no second colon) to simply skip the deliverability check for domains not listed in smtproutes. +=item vpopmail_ext [ 0 | 1 ] + +Is vpopmail configured with the qmail-ext feature enabled? If so, this config +option must be enabled in order for user-ext@example.org addresses to work. + +Default: 0 + =back =head1 CAVEATS @@ -62,11 +69,57 @@ L, L, L =cut -use Qmail::Deliverable::Client qw(deliverable); +################################# +################################# + +BEGIN { + use FindBin qw($Bin $Script); + if (not $INC{'Qpsmtpd.pm'}) { + my $dir = '$PLUGINS_DIRECTORY'; + -d and $dir = $_ for qw( + /home/qpsmtpd/plugins + /home/smtp/qpsmtpd/plugins + /usr/local/qpsmtpd/plugins + /usr/local/share/qpsmtpd/plugins + /usr/share/qpsmtpd/plugins + ); + + my $file = "the 'plugins' configuration file"; + -f and $file = $_ for qw( + /home/qpsmtpd/config/plugins + /home/smtp/qpsmtpd/config/plugins + /usr/local/qpsmtpd/config/plugins + /usr/local/etc/qpsmtpd/plugins + /etc/qpsmtpd/plugins + ); + + # "die" would print "BEGIN failed" garbage + print STDERR <<"END"; + +This is a plugin for qpsmtpd and should not be run manually. + +To install the plugin: + + ln -s $Bin/$Script $dir/ + +And add "$Script server 127.0.0.1:8998" to $file, before rcpt_ok. +For configuration instructions, read "man $Script" + +(Paths may vary.) + +END + exit 255; + } +} + +################################# +################################# + use strict; use warnings; use Qpsmtpd::Constants; +use Qmail::Deliverable::Client qw(deliverable); my %smtproutes; my $shared_domain; # global variable to be closed over by the SERVER callback @@ -98,14 +151,18 @@ sub register { } elsif ($args{server}) { $Qmail::Deliverable::Client::SERVER = $args{server}; } + + if ( $args{vpopmail_ext} ) { + $Qmail::Deliverable::VPOPMAIL_EXT = $args{vpopmail_ext}; + }; } - $self->register_hook('rcpt', 'rcpt_handler'); + $self->register_hook("rcpt", "rcpt_handler"); } sub rcpt_handler { my ($self, $transaction, $rcpt) = @_; - return DECLINED if $self->is_immune(); + return DECLINED if $self->is_immune(); # requires QP 0.90+ my $address = $rcpt->address; $self->log(LOGDEBUG, "Checking deliverability for recipient '$address'"); @@ -115,31 +172,35 @@ sub rcpt_handler { my $rv = deliverable $address; if (not defined $rv or not length $rv) { - $self->log(LOGWARN, "Unknown error checking deliverability of '$address'"); + $self->log(LOGWARN, "error (unknown) checking '$address'"); return DECLINED; } my $k = 0; # known status code - $self->log(LOGINFO, "Permission failure"), $k++ if $rv == 0x11; + $self->log(LOGINFO, "error, permission failure"), $k++ if $rv == 0x11; $self->log(LOGINFO, "pass, qmail-command in dot-qmail"),$k++ if $rv == 0x12; - $self->log(LOGINFO, "bouncesaying with program"), $k++ if $rv == 0x13; + $self->log(LOGINFO, "pass, bouncesaying with program"), $k++ if $rv == 0x13; $self->log(LOGINFO, "Temporarily undeliverable: group/world writable"), $k++ if $rv == 0x21; $self->log(LOGINFO, "Temporarily undeliverable: sticky home directory"),$k++ if $rv == 0x22; - $self->log(LOGINFO, "error: $Qmail::Deliverable::Client::ERROR"), $k++ + $self->log(LOGINFO, "error, $Qmail::Deliverable::Client::ERROR"), $k++ if $rv == 0x2f; $self->log(LOGINFO, "pass, normal delivery"), $k++ if $rv == 0xf1; - $self->log(LOGINFO, "pass, deliverable through vpopmail"), $k++ if $rv == 0xf2; - $self->log(LOGINFO, "SHOULD NOT HAPPEN"), $k++ if $rv == 0xfe; + $self->log(LOGINFO, "pass, vpopmail dir"), $k++ if $rv == 0xf2; + $self->log(LOGINFO, "pass, vpopmail alias"), $k++ if $rv == 0xf3; + $self->log(LOGINFO, "pass, vpopmail catchall"), $k++ if $rv == 0xf4; + $self->log(LOGINFO, "pass, vpopmail vuser"), $k++ if $rv == 0xf5; + $self->log(LOGINFO, "pass, vpopmail qmail-ext"), $k++ if $rv == 0xf6; + $self->log(LOGINFO, "error, SHOULD NOT HAPPEN"), $k++ if $rv == 0xfe; $self->log(LOGINFO, "fail, address not local"), $k++ if $rv == 0xff; - $self->log(LOGINFO, sprintf("Unknown: 0x%02x", $rv)) if $rv and not $k; + if ( $rv ) { + $self->log(LOGINFO, sprintf("error, unknown: 0x%02x", $rv)) if not $k; + return DECLINED; + }; - return DECLINED if $rv; - - $self->adjust_karma( -1 ); - return (DENY, "fail, no mailbox by that name. qd (#5.1.1)" ); + return (DENY, "Sorry, no mailbox by that name. qd (#5.1.1)" ); } sub _smtproute { From 198625e162b2cef538ef36e02343720e04818786 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 14 Nov 2012 15:21:44 -0500 Subject: [PATCH 117/352] spamassassin: added 'headers none' option enables suppression of SA header insertion --- plugins/spamassassin | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/plugins/spamassassin b/plugins/spamassassin index 6e81c7e..d3b9710 100644 --- a/plugins/spamassassin +++ b/plugins/spamassassin @@ -18,7 +18,7 @@ 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 +spamassassin plugin will add relevant headers from spamd (X-Spam-Status etc). The format goes like @@ -67,6 +67,11 @@ 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 headers [none] + +By default, spamassasin headers are added to messages. To suppress header +insertion, use 'headers none'. + =item leave_old_headers [drop|rename|keep] Another mail server before might have checked this mail already and may have @@ -139,6 +144,7 @@ Make the "subject munge string" configurable use strict; use warnings; +use lib 'lib'; use Qpsmtpd::Constants; use Qpsmtpd::DSN; @@ -241,6 +247,12 @@ sub parse_spamd_response { sub insert_spam_headers { my ( $self, $transaction, $new_headers, $username ) = @_; + if ( $self->{_args}{headers} && $self->{_args}{headers} eq 'none' ) { + my $r = $self->parse_spam_header( $new_headers->{'X-Spam-Status'} ); + $transaction->notes('spamassassin', $r); + return; + }; + my $recipient_count = scalar $transaction->recipients; $self->_cleanup_spam_header($transaction, 'X-Spam-User'); # always clean up @@ -410,6 +422,8 @@ sub reject { sub munge_subject { my ($self, $transaction) = @_; + return if ($self->{_args}{headers} && $self->{_args}{headers} eq 'none'); + my $sa = $self->get_spam_results($transaction) or return; my $qp_num = $self->{_args}{munge_subject_threshold}; From 50cb88ba01bb863cd7124f208226dd4d1f7116d4 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 14 Nov 2012 15:24:06 -0500 Subject: [PATCH 118/352] whitelist: added debug log message & std plugin entries. --- plugins/whitelist | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/plugins/whitelist b/plugins/whitelist index 2e0ccb7..43aace4 100644 --- a/plugins/whitelist +++ b/plugins/whitelist @@ -94,6 +94,12 @@ automatically allow relaying from that IP. =cut +use strict; +use warnings; + +use lib 'lib'; +use Qpsmtpd::Constants; + my $VERSION = 0.02; # Default is to merge whitelists in per_recipient mode @@ -144,6 +150,7 @@ sub check_host { return OK; } } + $self->log(LOGDEBUG, "skip: $ip is not whitelisted"); return DECLINED; } From d1bb2d949ba4f570e087941820eb0baddc18ed23 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 14 Nov 2012 16:58:16 -0500 Subject: [PATCH 119/352] spf: improved support for IPv6 clients --- config.sample/relayclients | 6 ++++++ plugins/sender_permitted_from | 18 +++++++++++++++++- 2 files changed, 23 insertions(+), 1 deletion(-) diff --git a/config.sample/relayclients b/config.sample/relayclients index 792c76b..a0fbc4e 100644 --- a/config.sample/relayclients +++ b/config.sample/relayclients @@ -4,3 +4,9 @@ 127.0.0.1 # leading/trailing whitespace is ignored 192.0. +# +# IPv6 formats ends in a nibble (not a netmask, prefixlen, or colon) +# RFC 3849 example +2001:DB8 +2001:DB8::1 +2001:0DB8:0000:0000:0000:0000:0000:0001 diff --git a/plugins/sender_permitted_from b/plugins/sender_permitted_from index d888701..42f26d8 100644 --- a/plugins/sender_permitted_from +++ b/plugins/sender_permitted_from @@ -59,6 +59,8 @@ use warnings; #use Mail::SPF 2.000; # eval'ed in ->register use Qpsmtpd::Constants; +use Net::IP; + sub register { my ($self, $qp, %args) = @_; eval 'use Mail::SPF'; @@ -237,13 +239,27 @@ sub is_in_relayclients { my $more_relay_clients = $self->qp->config('morerelayclients', 'map'); my %relay_clients = map { $_ => 1 } @relay_clients; + my $ipv6 = $client_ip =~ /:/ ? 1 : 0; + + if ( $ipv6 && $client_ip =~ /::/ ) { # IPv6 compressed notation + $client_ip = Net::IP::ip_expand_address($client_ip,6); + }; + while ($client_ip) { if ( exists $relay_clients{$client_ip} || exists $more_relay_clients->{$client_ip} ) { $self->log( LOGDEBUG, "skip, IP in relayclients" ); return 1; }; - $client_ip =~ s/\d+\.?$// or last; # strip off another 8 bits + + # added IPv6 support (Michael Holzt - 2012-11-14) + if ( $ipv6 ) { + $client_ip =~ s/[0-9a-f]:*$//; # strip off another nibble + chop $client_ip if ':' eq substr($client_ip, -1, 1); + } + else { + $client_ip =~ s/\d+\.?$// or last; # strip off another 8 bits + } } return; }; From 161834f3f355fd7760d72b504b223077fd9d9013 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 14 Nov 2012 17:15:08 -0500 Subject: [PATCH 120/352] TcpServer, improve IPv6 support, by Michael Holzt --- lib/Qpsmtpd/TcpServer.pm | 2 +- qpsmtpd-forkserver | 4 ---- qpsmtpd-prefork | 4 ---- 3 files changed, 1 insertion(+), 9 deletions(-) diff --git a/lib/Qpsmtpd/TcpServer.pm b/lib/Qpsmtpd/TcpServer.pm index 42dad62..e4af474 100644 --- a/lib/Qpsmtpd/TcpServer.pm +++ b/lib/Qpsmtpd/TcpServer.pm @@ -14,7 +14,7 @@ if ( # INET6 prior to 2.01 will not work; sorry. eval {require IO::Socket::INET6; IO::Socket::INET6->VERSION("2.00");} ) { - import Socket6; + Socket6->import(qw(inet_ntop)); $has_ipv6=1; } diff --git a/qpsmtpd-forkserver b/qpsmtpd-forkserver index c281a4f..84000f3 100755 --- a/qpsmtpd-forkserver +++ b/qpsmtpd-forkserver @@ -20,10 +20,6 @@ $| = 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) diff --git a/qpsmtpd-prefork b/qpsmtpd-prefork index c176886..3d018a9 100755 --- a/qpsmtpd-prefork +++ b/qpsmtpd-prefork @@ -31,10 +31,6 @@ 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 From 675819557890de2cc06d647a7ad9c12dae5b47b0 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Jun 2012 19:36:58 -0400 Subject: [PATCH 121/352] SPF: more logging additions --- plugins/sender_permitted_from | 56 ++++++++++++++++++++++++++--------- 1 file changed, 42 insertions(+), 14 deletions(-) diff --git a/plugins/sender_permitted_from b/plugins/sender_permitted_from index dabad55..d888701 100644 --- a/plugins/sender_permitted_from +++ b/plugins/sender_permitted_from @@ -143,28 +143,18 @@ sub mail_handler { }; # SPF result codes: pass fail softfail neutral none error permerror temperror + return $self->handle_code_none($reject, $why) if $code eq 'none'; + return $self->handle_code_fail($reject, $why) if $code eq 'fail'; + return $self->handle_code_softfail($reject, $why) if $code eq 'softfail'; + if ( $code eq 'pass' ) { $self->log(LOGINFO, "pass, $code: $why" ); return (DECLINED); } - elsif ( $code eq 'fail' ) { - $self->log(LOGINFO, "fail, $why" ); - return (DENY, "SPF - forgery: $why") if $reject >= 3; - return (DENYSOFT, "SPF - $code: $why") if $reject >= 2; - } - elsif ( $code eq 'softfail' ) { - $self->log(LOGINFO, "fail, $why" ); - return (DENY, "SPF - $code: $why") if $reject >= 4; - return (DENYSOFT, "SPF - $code: $why") if $reject >= 3; - } elsif ( $code eq 'neutral' ) { $self->log(LOGINFO, "fail, $code, $why" ); return (DENY, "SPF - $code: $why") if $reject >= 5; } - elsif ( $code eq 'none' ) { - $self->log(LOGINFO, "fail, $code, $why" ); - return (DENY, "SPF - $code: $why") if $reject >= 6; - } elsif ( $code eq 'error' ) { $self->log(LOGINFO, "fail, $code, $why" ); return (DENY, "SPF - $code: $why") if $reject >= 6; @@ -184,6 +174,44 @@ sub mail_handler { return (DECLINED); } +sub handle_code_none { + my ($self, $reject, $why ) = @_; + + if ( $reject >= 6 ) { + $self->log(LOGINFO, "fail, none, $why" ); + return (DENY, "SPF - none: $why"); + }; + + $self->log(LOGINFO, "pass, none, $why" ); + return DECLINED; +}; + +sub handle_code_fail { + my ($self, $reject, $why ) = @_; + + if ( $reject >= 2 ) { + $self->log(LOGINFO, "fail, $why" ); + return (DENY, "SPF - forgery: $why") if $reject >= 3; + return (DENYSOFT, "SPF - fail: $why") + }; + + $self->log(LOGINFO, "pass, fail tolerated, $why" ); + return DECLINED; +}; + +sub handle_code_softfail { + my ($self, $reject, $why ) = @_; + + if ( $reject >= 3 ) { + $self->log(LOGINFO, "fail, soft, $why" ); + return (DENY, "SPF - fail: $why") if $reject >= 4; + return (DENYSOFT, "SPF - fail: $why") if $reject >= 3; + }; + + $self->log(LOGINFO, "pass, softfail tolerated, $why" ); + return DECLINED; +}; + sub data_post_handler { my ($self, $transaction) = @_; From e9cf061d716004710354ad7461e5febbc9863422 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Jun 2012 20:15:13 -0400 Subject: [PATCH 122/352] summarize: check more locations to discover QP dir --- log/summarize.pl | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/log/summarize.pl b/log/summarize.pl index 04784cc..b506d82 100755 --- a/log/summarize.pl +++ b/log/summarize.pl @@ -3,6 +3,7 @@ use strict; use warnings; +use Cwd; use Data::Dumper; use File::Tail; @@ -276,16 +277,20 @@ sub show_symbol { sub get_qp_dir { foreach my $user ( qw/ qpsmtpd smtpd / ) { - my ($homedir) = (getpwnam( $user ))[7] or next; if ( -d "$homedir/plugins" ) { return "$homedir"; }; - if ( -d "$homedir/smtpd/plugins" ) { - return "$homedir/smtpd"; + foreach my $s ( qw/ smtpd qpsmtpd qpsmtpd-dev / ) { + if ( -d "$homedir/smtpd/plugins" ) { + return "$homedir/smtpd"; + }; }; }; + if ( -d "./plugins" ) { + return Cwd::getcwd(); + }; }; sub populate_plugins_from_registry { From b0f5618d722808d479df179d44c1c04ae7f2e4aa Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Jun 2012 20:16:11 -0400 Subject: [PATCH 123/352] log/run: removed spurious space --- log/run | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/log/run b/log/run index 5b3b4b6..e3a630c 100755 --- a/log/run +++ b/log/run @@ -1,4 +1,4 @@ -#! /bin/sh +#!/bin/sh export LOGDIR=./main mkdir -p $LOGDIR exec multilog t s10000000 n20 $LOGDIR From 3127f4d4c52ac348d4546ae218a6869a84b9a648 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Jun 2012 20:16:34 -0400 Subject: [PATCH 124/352] dspam: better error message if dspam_bin is not found --- plugins/dspam | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/dspam b/plugins/dspam index d92da7f..d133dd8 100644 --- a/plugins/dspam +++ b/plugins/dspam @@ -216,7 +216,7 @@ sub register { $self->{_args}{dspam_bin} ||= '/usr/local/bin/dspam'; if ( ! -x $self->{_args}{dspam_bin} ) { - $self->log(LOGERROR, "dspam not found: "); + $self->log(LOGERROR, "dspam CLI binary not found: install dspam and/or set dspam_bin"); return DECLINED; }; From 74d97d312eb5574ae20ebab7ec72c591dd98b0a0 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Jun 2012 20:17:00 -0400 Subject: [PATCH 125/352] qmail_deliverable: test variable if defined before accessing --- plugins/qmail_deliverable | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/qmail_deliverable b/plugins/qmail_deliverable index 0704b06..b22d221 100755 --- a/plugins/qmail_deliverable +++ b/plugins/qmail_deliverable @@ -77,7 +77,7 @@ sub register { $self->log(LOGWARN, "Odd number of arguments, using default config"); } else { my %args = @args; - if ($args{server} =~ /^smtproutes:/) { + if ($args{server} && $args{server} =~ /^smtproutes:/) { my ($fallback, $port) = $args{server} =~ /:(?:(.*?):?)(\d+)/; From 4928792f87565a609ac93a427c53dfc852a44050 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Jun 2012 20:18:16 -0400 Subject: [PATCH 126/352] spamassassin: further log message refinement --- plugins/spamassassin | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/plugins/spamassassin b/plugins/spamassassin index 7070d7f..3c6b0f9 100644 --- a/plugins/spamassassin +++ b/plugins/spamassassin @@ -369,11 +369,12 @@ sub reject { my ($self, $transaction) = @_; my $sa_results = $self->get_spam_results($transaction) or do { - $self->log(LOGNOTICE, "skip, no results"); + $self->log(LOGNOTICE, "error, no results"); return DECLINED; }; - my $score = $sa_results->{score} or do { - $self->log(LOGERROR, "skip, error getting score"); + my $score = $sa_results->{score}; + if ( ! defined $score ) { + $self->log(LOGERROR, "error, error getting score"); return DECLINED; }; @@ -385,7 +386,7 @@ sub reject { }; my $reject = $self->{_args}{reject} or do { - $self->log(LOGERROR, "skip, reject disabled ($status, $learn)"); + $self->log(LOGERROR, "pass, reject disabled ($status, $learn)"); return DECLINED; }; @@ -400,7 +401,7 @@ sub reject { } } - $self->connection->notes('karma', $self->connection->notes('karma') - 1); + $self->connection->notes('karma', ($self->connection->notes('karma') - 1)); # default of media_unsupported is DENY, so just change the message $self->log(LOGINFO, "fail, $status, > $reject, $learn"); return ($self->get_reject_type(), "spam score exceeded threshold"); From 1cfd7df50e013daa6a3ebfc5fac94d0920e66dbe Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 29 Jun 2012 20:20:58 -0400 Subject: [PATCH 127/352] registry: added auth_ prefixes, relay aliases --- plugins/registry.txt | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/plugins/registry.txt b/plugins/registry.txt index cedcd91..0ecfb3a 100644 --- a/plugins/registry.txt +++ b/plugins/registry.txt @@ -9,7 +9,7 @@ 3 ident::p0f p0f p0f 5 karma krm karma 6 dnsbl dbl dnsbl -7 relay rly relay +7 relay rly relay check_relay,check_norelay,relay_only 9 earlytalker ear early check_earlytalker 15 helo hlo helo check_spamhelo 16 tls tls tls @@ -22,13 +22,14 @@ # # Authentication # -30 auth::vpopmail_sql aut vpsql -31 auth::vpopmaild vpd vpopd -32 auth::vpopmail vpo vpop -33 auth::checkpasswd ckp chkpw -34 auth::cvs_unix_local cvs cvsul -35 auth::flat_file flt aflat -36 auth::ldap_bind ldp aldap +30 auth::auth_vpopmail_sql aut vpsql +31 auth::auth_vpopmaild vpd vpopd +32 auth::auth_vpopmail vpo vpop +33 auth::auth_checkpasswd ckp chkpw +34 auth::auth_cvs_unix_local cvs cvsul +35 auth::auth_flat_file flt aflat +36 auth::auth_ldap_bind ldp aldap +37 auth::authdeny dny adeny # # Sender / From # From e46c6e39ad3c4c910b40d458d8bbd738588fd1a0 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 29 Jun 2012 20:28:38 -0400 Subject: [PATCH 128/352] summarize: recognize tcpserver log entries --- log/summarize.pl | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/log/summarize.pl b/log/summarize.pl index b506d82..c4616ff 100755 --- a/log/summarize.pl +++ b/log/summarize.pl @@ -70,7 +70,7 @@ while ( defined (my $line = $fh->read) ) { next if ! $line; my ( $type, $pid, $hook, $plugin, $message ) = parse_line( $line ); next if ! $type; - next if $type =~ /info|unknown|response/; + next if $type =~ /^(info|unknown|response|tcpserver)$/; next if $type eq 'init'; # doesn't occur in all deployment models if ( ! $pids{$pid} ) { # haven't seen this pid @@ -151,6 +151,7 @@ sub parse_line { return parse_line_plugin( $line ) if substr($message, 0, 1) eq '('; return ( 'dispatch', $pid, undef, undef, $message ) if substr($message, 0, 12) eq 'dispatching '; return ( 'response', $pid, undef, undef, $message ) if $message =~ /^[2|3]\d\d/; + return ( 'tcpserver', $pid, undef, undef, undef ) if substr($pid, 0, 10) eq 'tcpserver:'; # lines seen about once per connection return ( 'init', $pid, undef, undef, $message ) if substr($message, 0, 19) eq 'Accepted connection'; From 96f49c98ff5a82feb2ef6678d6a0f449106737b4 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 29 Jun 2012 20:29:04 -0400 Subject: [PATCH 129/352] clamdscan: default is scan always, even authenticated --- plugins/virus/clamdscan | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/virus/clamdscan b/plugins/virus/clamdscan index 0af2929..72e64ea 100644 --- a/plugins/virus/clamdscan +++ b/plugins/virus/clamdscan @@ -140,7 +140,7 @@ sub data_post_handler { my $filename = $self->get_filename( $transaction ) or return DECLINED; - return (DECLINED) if $self->is_immune(); + #return (DECLINED) if $self->is_immune(); return (DECLINED) if $self->is_too_big( $transaction ); return (DECLINED) if $self->is_not_multipart( $transaction ); From 6e731e86caa2d529c16b7d2856a2f1f1e6624692 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 29 Jun 2012 20:30:06 -0400 Subject: [PATCH 130/352] run: define PORT variable --- run | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/run b/run index 22c6029..0e2ff84 100755 --- a/run +++ b/run @@ -11,6 +11,7 @@ PERL=/usr/bin/perl QMAILDUID=`id -u $QPUSER` NOFILESGID=`id -g $QPUSER` IP=`head -1 config/IP` +PORT=25 LANG=C # Remove the comments between the and tags to choose a @@ -19,7 +20,7 @@ LANG=C # exec $BIN/softlimit -m $MAXRAM \ $BIN/tcpserver -c 10 -v -R -p \ - -u $QMAILDUID -g $NOFILESGID $IP smtp \ + -u $QMAILDUID -g $NOFILESGID $IP $PORT \ ./qpsmtpd 2>&1 # @@ -30,7 +31,7 @@ exec $BIN/softlimit -m $MAXRAM \ # exec $BIN/softlimit -m $MAXRAM \ # $PERL -T ./qpsmtpd-forkserver \ # --listen-address $IP \ -# --port 25 \ +# --port $PORT \ # --limit-connections 15 \ # --max-from-ip 5 \ # --user $QPUSER From 77c892d8a501e2b5a2006a8635ab4aeec950532d Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 29 Jun 2012 20:39:44 -0400 Subject: [PATCH 131/352] logs: improve ability to find logs --- log/summarize.pl | 4 ++-- log/watch.pl | 22 ++++++++++++++-------- 2 files changed, 16 insertions(+), 10 deletions(-) diff --git a/log/summarize.pl b/log/summarize.pl index c4616ff..1201aa0 100755 --- a/log/summarize.pl +++ b/log/summarize.pl @@ -284,8 +284,8 @@ sub get_qp_dir { return "$homedir"; }; foreach my $s ( qw/ smtpd qpsmtpd qpsmtpd-dev / ) { - if ( -d "$homedir/smtpd/plugins" ) { - return "$homedir/smtpd"; + if ( -d "$homedir/$s/plugins" ) { + return "$homedir/$s"; }; }; }; diff --git a/log/watch.pl b/log/watch.pl index b93ff6e..0514a3d 100755 --- a/log/watch.pl +++ b/log/watch.pl @@ -3,11 +3,12 @@ use strict; use warnings; +use Cwd; use Data::Dumper; use File::Tail; -my $dir = find_qp_log_dir() or die "unable to find QP home dir"; -my $file = "$dir/main/current"; +my $dir = get_qp_dir() or die "unable to find QP home dir"; +my $file = "$dir/log/main/current"; my $fh = File::Tail->new(name=>$file, interval=>1, maxinterval=>1, debug =>1, tail =>100 ); while ( defined (my $line = $fh->read) ) { @@ -15,16 +16,21 @@ while ( defined (my $line = $fh->read) ) { print $line; }; -sub find_qp_log_dir { +sub get_qp_dir { foreach my $user ( qw/ qpsmtpd smtpd / ) { - my ($homedir) = (getpwnam( $user ))[7] or next; - if ( -d "$homedir/log" ) { - return "$homedir/log"; + if ( -d "$homedir/plugins" ) { + return "$homedir"; }; - if ( -d "$homedir/smtpd/log" ) { - return "$homedir/smtpd/log"; + foreach my $s ( qw/ smtpd qpsmtpd qpsmtpd-dev / ) { + if ( -d "$homedir/$s/plugins" ) { + return "$homedir/$s"; + }; }; }; + if ( -d "./plugins" ) { + return Cwd::getcwd(); + }; }; + From ad558d5893d53e4a376cee9a44e7a4ba8852ac4b Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 30 Jun 2012 14:18:16 -0400 Subject: [PATCH 132/352] helo: added is_plain_ip to lenient checks there's no excuse for a client to ever send a raw IP, and I have yet to see a valid client do it --- plugins/helo | 23 +++++++++++------------ 1 file changed, 11 insertions(+), 12 deletions(-) diff --git a/plugins/helo b/plugins/helo index 58748c7..10ee6b3 100644 --- a/plugins/helo +++ b/plugins/helo @@ -106,25 +106,25 @@ Default: lenient =head3 lenient -Reject failures of the following tests: is_in_badhelo, invalid_localhost, and -is_forged_literal. +Reject failures of the following tests: is_in_badhelo, invalid_localhost, +is_forged_literal, and is_plain_ip. 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. +support, the prevention of forged localhost, forged IP literals, and plain +IPs. =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. +the following are enforced: 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. +I without settings I and using the B +plugin. Windows PCs often send unqualified HELO names and will have trouble +sending mail. The B plugin defers the rejection, and if the user +subsequently authenticates, the rejection is be cancelled. =head3 strict @@ -259,11 +259,10 @@ sub populate_tests { my $self = shift; my $policy = $self->{_args}{policy}; - @{ $self->{_helo_tests} } = qw/ is_in_badhelo invalid_localhost is_forged_literal /; + @{ $self->{_helo_tests} } = qw/ is_in_badhelo invalid_localhost is_forged_literal is_plain_ip /; if ( $policy eq 'rfc' || $policy eq 'strict' ) { - push @{ $self->{_helo_tests} }, qw/ is_plain_ip is_not_fqdn - no_forward_dns no_reverse_dns /; + push @{ $self->{_helo_tests} }, qw/ is_not_fqdn no_forward_dns no_reverse_dns /; }; if ( $policy eq 'strict' ) { From 477c5a6bdf68ac59ab7c7627893d84c2e9071e65 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 30 Jun 2012 15:37:25 -0400 Subject: [PATCH 133/352] karma: added adjust_karma method makes it easier to set karma in plugins --- lib/Qpsmtpd/Plugin.pm | 9 ++ plugins/badmailfrom | 2 +- plugins/dspam | 9 +- plugins/earlytalker | 2 +- plugins/helo | 2 +- plugins/karma | 16 +-- plugins/qmail_deliverable | 4 +- plugins/spamassassin | 2 +- plugins/whitelist | 223 ++++++++++++++++++++++++++++++++++++++ 9 files changed, 248 insertions(+), 21 deletions(-) create mode 100644 plugins/whitelist diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm index 6b063b4..3086c20 100644 --- a/lib/Qpsmtpd/Plugin.pm +++ b/lib/Qpsmtpd/Plugin.pm @@ -282,6 +282,15 @@ sub is_immune { return; }; +sub adjust_karma { + my ( $self, $value ) = @_; + + my $karma = $self->connection->notes('karma') || 0 + $karma += $value; + $self->connection->notes('karma', $value); + return $value; +}; + sub _register_standard_hooks { my ($plugin, $qp) = @_; diff --git a/plugins/badmailfrom b/plugins/badmailfrom index 47aa425..1d1f36f 100644 --- a/plugins/badmailfrom +++ b/plugins/badmailfrom @@ -85,7 +85,7 @@ sub hook_mail { next unless $bad; next unless $self->is_match( $from, $bad, $host ); $reason ||= "Your envelope sender is in my badmailfrom list"; - $self->connection->notes('karma', ($self->connection->notes('karma') || 0) - 1); + $self->adjust_karma( -1 ); return $self->get_reject( $reason ); } diff --git a/plugins/dspam b/plugins/dspam index d133dd8..72aba48 100644 --- a/plugins/dspam +++ b/plugins/dspam @@ -478,9 +478,7 @@ sub reject_agree { 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->adjust_karma( -2 ); $self->log(LOGINFO, "fail, agree, $status"); my $reject = $self->get_reject_type(); return ($reject, 'we agree, no spam please'); @@ -493,9 +491,7 @@ sub reject_agree { 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->adjust_karma( 2 ); }; $self->log(LOGINFO, "pass, agree, $status"); return DECLINED; @@ -591,6 +587,7 @@ sub autolearn { defined $self->{_args}{autolearn} or return; + # only train once. $self->autolearn_naughty( $response, $transaction ) and return; $self->autolearn_karma( $response, $transaction ) and return; $self->autolearn_spamassassin( $response, $transaction ) and return; diff --git a/plugins/earlytalker b/plugins/earlytalker index f75c8fe..f7d38b2 100644 --- a/plugins/earlytalker +++ b/plugins/earlytalker @@ -173,7 +173,7 @@ sub connect_handler { }; $self->connection->notes('earlytalker', 1); - $self->connection->notes('karma', -1); + $self->adjust_karma( -1 ); return DECLINED; } diff --git a/plugins/helo b/plugins/helo index 10ee6b3..29a3633 100644 --- a/plugins/helo +++ b/plugins/helo @@ -430,7 +430,7 @@ sub no_matching_dns { 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 + $self->adjust_karma( 1 ); # whoppee, a match! return; }; diff --git a/plugins/karma b/plugins/karma index e46fdfb..18fc768 100644 --- a/plugins/karma +++ b/plugins/karma @@ -177,14 +177,14 @@ those senders haven't sent us any ham. As such, it's much safer to use. 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 +I is the number of 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! +To alter a connections karma based on its behavior, do this: + + $self->adjust_karma( -1 ); # lower karma (naughty) + $self->adjust_karma( 1 ); # raise karma (good) + =head1 EFFECTIVENESS @@ -194,7 +194,7 @@ 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. +reduces the resources they can waste. Of the connections that had previously passed all other checks and were caught only by spamassassin and/or dspam, B rejected 31 percent. Since @@ -207,7 +207,7 @@ 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. +karma_tool script. =head1 BUGS & LIMITATIONS diff --git a/plugins/qmail_deliverable b/plugins/qmail_deliverable index b22d221..04cf5aa 100755 --- a/plugins/qmail_deliverable +++ b/plugins/qmail_deliverable @@ -138,9 +138,7 @@ sub rcpt_handler { return DECLINED if $rv; - if ( defined $self->connection->notes('karma') ) { - $self->connection->notes('karma', ($self->connection->notes('karma') - 1)); - }; + $self->adjust_karma( -1 ); return (DENY, "fail, no mailbox by that name. qd (#5.1.1)" ); } diff --git a/plugins/spamassassin b/plugins/spamassassin index 3c6b0f9..6e81c7e 100644 --- a/plugins/spamassassin +++ b/plugins/spamassassin @@ -401,7 +401,7 @@ sub reject { } } - $self->connection->notes('karma', ($self->connection->notes('karma') - 1)); + $self->adjust_karma( -1 ); # default of media_unsupported is DENY, so just change the message $self->log(LOGINFO, "fail, $status, > $reject, $learn"); return ($self->get_reject_type(), "spam score exceeded threshold"); diff --git a/plugins/whitelist b/plugins/whitelist new file mode 100644 index 0000000..2e0ccb7 --- /dev/null +++ b/plugins/whitelist @@ -0,0 +1,223 @@ + +=head1 NAME + +whitelist - whitelist override for other qpsmtpd plugins + + +=head1 DESCRIPTION + +The B plugin allows selected hosts or senders or recipients +to be whitelisted as exceptions to later plugin processing. It is a more +conservative variant of Devin Carraway's 'whitelist' plugin. + + +=head1 CONFIGURATION + +To enable the plugin, add it to the qpsmtpd/config/plugins file as usual. +It should precede any plugins you might wish to whitelist for. + +Several configuration files are supported, corresponding to different +parts of the SMTP conversation: + +=over 4 + +=item whitelisthosts + +Any IP address (or start-anchored fragment thereof) listed in the +whitelisthosts file is exempted from any further validation during +'connect', and can be selectively exempted at other stages by +plugins testing for a 'whitelisthost' connection note. + +Similarly, if the environment variable $WHITELISTCLIENT is set +(which can be done by tcpserver), the connection will be exempt from +further 'connect' validation, and the host can be selectively +exempted by other plugins testing for a 'whitelistclient' connection +note. + +=item whitelisthelo + +Any host that issues a HELO matching an entry in whitelisthelo will +be exempted from further validation at the 'helo' stage. Subsequent +plugins can test for a 'whitelisthelo' connection note. Note that +this does not actually amount to an authentication in any meaningful +sense. + +=item whitelistsenders + +If the envelope sender of a mail (that which is sent as the MAIL FROM) +matches an entry in whitelistsenders, or if the hostname component +matches, the mail will be exempted from any further validation within +the 'mail' stage. Subsequent plugins can test for this exemption as a +'whitelistsender' transaction note. + +=item whitelistrcpt + +If any recipient of a mail (that sent as the RCPT TO) matches an +entry from whitelistrcpt, or if the hostname component matches, no +further validation will be required for this recipient. Subsequent +plugins can test for this exemption using a 'whitelistrcpt' +transaction note, which holds the count of whitelisted recipients. + +=back + +whitelist_soft also supports per-recipient whitelisting when using +the per_user_config plugin. To enable the per-recipient behaviour +(delaying all whitelisting until the rcpt part of the smtp +conversation, and using per-recipient whitelist configs, if +available), pass a true 'per_recipient' argument in the +config/plugins invocation i.e. + + whitelist_soft per_recipient 1 + +By default global and per-recipient whitelists are merged; to turn off +the merge behaviour pass a false 'merge' argument in the config/plugins +invocation i.e. + + whitelist_soft per_recipient 1 merge 0 + + +=head1 BUGS + +Whitelist lookups are all O(n) linear scans of configuration files, even +though they're all associative lookups. Something should be done about +this when CDB/DB/GDBM configs are supported. + + +=head1 AUTHOR + +Based on the 'whitelist' plugin by Devin Carraway . + +Modified by Gavin Carr to not inherit +whitelisting across hooks, but use per-hook whitelist notes instead. +This is a more conservative approach e.g. whitelisting an IP will not +automatically allow relaying from that IP. + +=cut + +my $VERSION = 0.02; + +# Default is to merge whitelists in per_recipient mode +my %MERGE = (merge => 1); + +sub register { + my ($self, $qp, %arg) = @_; + + $self->{_per_recipient} = 1 if $arg{per_recipient}; + $MERGE{merge} = $arg{merge} if defined $arg{merge}; + + # Normal mode - whitelist per hook + unless ($arg{per_recipient}) { + $self->register_hook("connect", "check_host"); + $self->register_hook("helo", "check_helo"); + $self->register_hook("ehlo", "check_helo"); + $self->register_hook("mail", "check_sender"); + $self->register_hook("rcpt", "check_rcpt"); + } + + # Per recipient mode - defer all whitelisting to rcpt hook + else { + $self->register_hook("rcpt", "check_host"); + $self->register_hook("helo", "helo_helper"); + $self->register_hook("ehlo", "helo_helper"); + $self->register_hook("rcpt", "check_helo"); + $self->register_hook("rcpt", "check_sender"); + $self->register_hook("rcpt", "check_rcpt"); + } +} + +sub check_host { + my ($self, $transaction, $rcpt) = @_; + my $ip = $self->qp->connection->remote_ip || return (DECLINED); + + # From tcpserver + if (exists $ENV{WHITELISTCLIENT}) { + $self->qp->connection->notes('whitelistclient', 1); + $self->log(2, "host $ip is a whitelisted client"); + return OK; + } + + my $config_arg = $self->{_per_recipient} ? {rcpt => $rcpt, %MERGE} : {}; + for my $h ($self->qp->config('whitelisthosts', $config_arg)) { + if ($h eq $ip or $ip =~ /^\Q$h\E/) { + $self->qp->connection->notes('whitelisthost', 1); + $self->log(2, "host $ip is a whitelisted host"); + return OK; + } + } + return DECLINED; +} + +sub helo_helper { + my ($self, $transaction, $helo) = @_; + $self->{_whitelist_soft_helo} = $helo; + return DECLINED; +} + +sub check_helo { + my ($self, $transaction, $helo) = @_; + + # If per_recipient will be rcpt hook, and helo actually rcpt + my $config_arg = {}; + if ($self->{_per_recipient}) { + $config_arg = {rcpt => $helo, %MERGE}; + $helo = $self->{_whitelist_soft_helo}; + } + + for my $h ($self->qp->config('whitelisthelo', $config_arg)) { + if ($helo and lc $h eq lc $helo) { + $self->qp->connection->notes('whitelisthelo', 1); + $self->log(2, "helo host $helo in whitelisthelo"); + return OK; + } + } + return DECLINED; +} + +sub check_sender { + my ($self, $transaction, $sender) = @_; + + # If per_recipient will be rcpt hook, and sender actually rcpt + my $config_arg = {}; + if ($self->{_per_recipient}) { + $config_arg = {rcpt => $sender, %MERGE}; + $sender = $transaction->sender; + } + + return DECLINED if $sender->format eq '<>'; + my $addr = lc $sender->address or return DECLINED; + my $host = lc $sender->host or return DECLINED; + + for my $h ($self->qp->config('whitelistsenders', $config_arg)) { + next unless $h; + $h = lc $h; + + if ($addr eq $h or $host eq $h) { + $transaction->notes('whitelistsender', 1); + $self->log(2, "envelope sender $addr in whitelistsenders"); + return OK; + } + } + return DECLINED; +} + +sub check_rcpt { + my ($self, $transaction, $rcpt) = @_; + + my $addr = lc $rcpt->address or return DECLINED; + my $host = lc $rcpt->host or return DECLINED; + + my $config_arg = $self->{_per_recipient} ? {rcpt => $rcpt, %MERGE} : {}; + for my $h ($self->qp->config('whitelistrcpt', $config_arg)) { + next unless $h; + $h = lc $h; + + if ($addr eq $h or $host eq $h) { + my $note = $transaction->notes('whitelistrcpt'); + $transaction->notes('whitelistrcpt', ++$note); + $self->log(2, "recipient $addr in whitelistrcpt"); + return OK; + } + } + return DECLINED; +} + From be828a80357390addcf8693b6e072fa067445494 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 30 Jun 2012 15:40:24 -0400 Subject: [PATCH 134/352] added log/show_message, dropped .pl suffix to be consistent with other QP scripts --- log/{log2sql.pl => log2sql} | 0 log/show_message | 72 +++++++++++++++++++++++++++++++++ log/{summarize.pl => summarize} | 0 log/{watch.pl => watch} | 0 4 files changed, 72 insertions(+) rename log/{log2sql.pl => log2sql} (100%) create mode 100755 log/show_message rename log/{summarize.pl => summarize} (100%) rename log/{watch.pl => watch} (100%) diff --git a/log/log2sql.pl b/log/log2sql similarity index 100% rename from log/log2sql.pl rename to log/log2sql diff --git a/log/show_message b/log/show_message new file mode 100755 index 0000000..932726a --- /dev/null +++ b/log/show_message @@ -0,0 +1,72 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Data::Dumper; + +my $QPDIR = '/usr/home/qpsmtpd/smtpd'; +my $logfile = "$QPDIR/log/main/current"; + +my $is_ip = 0; +my $search = $ARGV[0]; + +if ( ! $search ) { + die "\nusage: $0 [ ip_address | PID ]\n\n"; +}; + +if ( $search =~ /^(?:[0-9]{1,3}\.){3}[0-9]{1,3}$/ ) { + #print "it's an IP\n"; + $is_ip++; +}; + +open my $LOG, '<', $logfile; + +if ( $is_ip ) { # look for the connection start message for the IP + my $ip_matches; + while ( defined (my $line = <$LOG>) ) { + next if ! $line; + my ( $tai, $pid, $mess ) = split /\s/, $line, 3; + if ( 'Connection from ' eq substr( $mess, 0, 16 ) ) { + my ( $ip ) = (split /\s+/, $mess)[-1]; # IP is last word + $ip = substr $ip, 1, -1; # trim off brackets + if ( $ip eq $search ) { + $ip_matches++; + $search = $pid; + $is_ip = 0; + }; + }; + }; + seek $LOG, 0, 0; + die "no pid found for ip $search\n" if $is_ip; + print "showing the last of $ip_matches connnections from $ARGV[0]\n"; +}; + +print "showing QP message PID $search\n"; + +while ( defined (my $line = <$LOG>) ) { + next if ! $line; + my ( $tai, $pid, $mess ) = split /\s/, $line, 3; + next if ! $pid; + print $mess if ( $pid eq $search ); +}; +close $LOG; + + +sub get_qp_dir { + foreach my $user ( qw/ qpsmtpd smtpd / ) { + my ($homedir) = (getpwnam( $user ))[7] or next; + + if ( -d "$homedir/plugins" ) { + return "$homedir"; + }; + foreach my $s ( qw/ smtpd qpsmtpd qpsmtpd-dev / ) { + if ( -d "$homedir/$s/plugins" ) { + return "$homedir/$s"; + }; + }; + }; + if ( -d "./plugins" ) { + return Cwd::getcwd(); + }; +}; diff --git a/log/summarize.pl b/log/summarize similarity index 100% rename from log/summarize.pl rename to log/summarize diff --git a/log/watch.pl b/log/watch similarity index 100% rename from log/watch.pl rename to log/watch From 710a838be75d791014f5f45be803d3c96a0fc65f Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 30 Jun 2012 15:58:21 -0400 Subject: [PATCH 135/352] config: replace domainkeys with dkim dkim is the heir apparent the Mail::DomainKeys perl module is deprecated (per it's author) --- config.sample/plugins | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config.sample/plugins b/config.sample/plugins index 5fb03f8..25cf8bb 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -56,7 +56,7 @@ auth/authdeny rcpt_ok headers days 5 reject_type temp require From,Date -domainkeys +dkim # content filters #uribl From aa4e10260674eb4b73030888524f02de74d152f1 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 30 Jun 2012 16:11:54 -0400 Subject: [PATCH 136/352] karma: added error keyword to error log messages --- plugins/karma | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/plugins/karma b/plugins/karma index 18fc768..b5a3a33 100644 --- a/plugins/karma +++ b/plugins/karma @@ -383,7 +383,7 @@ 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: $!"); + $self->log(LOGCRIT, "error, tie to database $db failed: $!"); close $lock; return; }; @@ -416,12 +416,12 @@ sub get_db_lock { # Check denysoft db open( my $lock, ">$db.lock" ) or do { - $self->log(LOGCRIT, "opening lockfile failed: $!"); + $self->log(LOGCRIT, "error, opening lockfile failed: $!"); return; }; flock( $lock, LOCK_EX ) or do { - $self->log(LOGCRIT, "flock of lockfile failed: $!"); + $self->log(LOGCRIT, "error, flock of lockfile failed: $!"); close $lock; return; }; @@ -441,12 +441,12 @@ sub get_db_lock_nfs { blocking_timeout => 10, # 10 sec stale_lock_timeout => 30 * 60, # 30 min } or do { - $self->log(LOGCRIT, "nfs lockfile failed: $!"); + $self->log(LOGCRIT, "error, nfs lockfile failed: $!"); return; }; open( my $lock, "+<$db.lock") or do { - $self->log(LOGCRIT, "opening nfs lockfile failed: $!"); + $self->log(LOGCRIT, "error, opening nfs lockfile failed: $!"); return; }; From 809390b12e41688e9944d3cfa854630b596c52d8 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 30 Jun 2012 16:12:42 -0400 Subject: [PATCH 137/352] registry: renamed clamd abb3 from cad to clm --- plugins/registry.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/registry.txt b/plugins/registry.txt index 0ecfb3a..8d6f1ae 100644 --- a/plugins/registry.txt +++ b/plugins/registry.txt @@ -64,7 +64,7 @@ 70 virus::aveclient ave avirs 71 virus::bitdefender bit bitdf 72 virus::clamav cav clamv -73 virus::clamdscan cad clamd +73 virus::clamdscan clm clamd 74 virus::hbedv hbv hbedv 75 virus::kavscanner kav kavsc 76 virus::klez_filter klz vklez From 7eedea87546ec50ad5e9344b4f7cf6d46b01d295 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 30 Jun 2012 16:28:54 -0400 Subject: [PATCH 138/352] added missing semicolon --- lib/Qpsmtpd/Plugin.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm index 3086c20..3bb4b73 100644 --- a/lib/Qpsmtpd/Plugin.pm +++ b/lib/Qpsmtpd/Plugin.pm @@ -285,7 +285,7 @@ sub is_immune { sub adjust_karma { my ( $self, $value ) = @_; - my $karma = $self->connection->notes('karma') || 0 + my $karma = $self->connection->notes('karma') || 0; $karma += $value; $self->connection->notes('karma', $value); return $value; From ba6a04ee4d7e7608f613b5e0faec4e73838b2d1f Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 30 Jun 2012 16:40:51 -0400 Subject: [PATCH 139/352] log/summarize: added auth formats --- log/summarize | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/log/summarize b/log/summarize index 1201aa0..f1cf174 100755 --- a/log/summarize +++ b/log/summarize @@ -38,6 +38,10 @@ my %formats = ( check_earlytalker => "%-3.3s", helo => "%-3.3s", tls => "%-3.3s", + 'auth::auth_vpopmail' => "%-3.3s", + 'auth::auth_vpopmaild' => "%-3.3s", + 'auth::auth_vpopmail_sql' => "%-3.3s", + 'auth::auth_checkpassword' => "%-3.3s", badmailfrom => "%-3.3s", check_badmailfrom => "%-3.3s", sender_permitted_from => "%-3.3s", From 3145a3713bea3ace0308ada6947eed3d93ce04da Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 30 Jun 2012 16:43:15 -0400 Subject: [PATCH 140/352] config/plugins: better defaults, additional entries --- config.sample/plugins | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/config.sample/plugins b/config.sample/plugins index 25cf8bb..7f19860 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -28,6 +28,8 @@ dont_require_anglebrackets # parse_addr_withhelo quit_fortune +#karma penalty_box 1 reject naughty + # tls should load before count_unrecognized_commands #tls earlytalker @@ -37,10 +39,10 @@ relay resolvable_fromhost rhsbl -dnsbl +dnsbl reject naughty reject_type disconnect badmailfrom badrcptto -helo +helo policy lenient # sender_permitted_from # greylisting p0f genre,windows @@ -65,18 +67,21 @@ virus/klez_filter # You can run the spamassassin plugin with options. See perldoc # plugins/spamassassin for details. # -spamassassin +spamassassin reject 12 # 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 +# spamassassin reject 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 +# virus/clamdscan deny_viruses yes scan_all 1 + +naughty reject data # You must enable a queue plugin - see the options in plugins/queue/ - for example: From 17abbfe1b013348fe8205cf3d7360a86013884ec Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 30 Jun 2012 17:51:59 -0400 Subject: [PATCH 141/352] log/summarize: narrower column when no geoip city data present --- log/summarize | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/log/summarize b/log/summarize index f1cf174..b203cca 100755 --- a/log/summarize +++ b/log/summarize @@ -25,7 +25,6 @@ my %formats = ( ip => "%-15.15s", hostname => "%-20.20s", distance => "%5.5s", - 'ident::geoip' => "%-20.20s", 'ident::p0f' => "%-10.10s", count_unrecognized_commands => "%-5.5s", @@ -109,10 +108,16 @@ while ( defined (my $line = $fh->read) ) { }; if ( $plugin eq 'ident::geoip' ) { - my ($gip, $distance) = $message =~ /(.*?),\s+([\d]+)\skm/; - if ( $distance ) { - $pids{$pid}{$plugin} = $gip; - $pids{$pid}{distance} = $distance; + if ( length $message < 3 ) { + $formats{'ident::geoip'} = "%-3.3s"; + $formats3{'ident::geoip'} = "%-3.3s"; + } + else { + my ($gip, $distance) = $message =~ /(.*?),\s+([\d]+)\skm/; + if ( $distance ) { + $pids{$pid}{$plugin} = $gip; + $pids{$pid}{distance} = $distance; + }; }; }; } @@ -234,12 +239,12 @@ sub print_auto_format { if ( defined $pids{$pid}{helo_host} && $plugin =~ /helo/ ) { $format .= " %-18.18s"; - push @values, delete $pids{$pid}{helo_host}; + push @values, substr( delete $pids{$pid}{helo_host}, -18, 18); push @headers, 'HELO'; } elsif ( defined $pids{$pid}{from} && $plugin =~ /from/ ) { $format .= " %-20.20s"; - push @values, delete $pids{$pid}{from}; + push @values, substr( delete $pids{$pid}{from}, -20, 20); push @headers, 'MAIL FROM'; } elsif ( defined $pids{$pid}{to} && $plugin =~ /to|rcpt|recipient/ ) { From 9ffdd14231b08c2caf8f1205dd317d68cd793678 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 30 Jun 2012 19:04:42 -0400 Subject: [PATCH 142/352] log/show_message: fixed QP dir detection --- log/show_message | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/log/show_message b/log/show_message index 932726a..9ee2ef1 100755 --- a/log/show_message +++ b/log/show_message @@ -5,7 +5,7 @@ use warnings; use Data::Dumper; -my $QPDIR = '/usr/home/qpsmtpd/smtpd'; +my $QPDIR = get_qp_dir(); my $logfile = "$QPDIR/log/main/current"; my $is_ip = 0; @@ -20,7 +20,7 @@ if ( $search =~ /^(?:[0-9]{1,3}\.){3}[0-9]{1,3}$/ ) { $is_ip++; }; -open my $LOG, '<', $logfile; +open my $LOG, '<', $logfile or die "unable to open $logfile\n"; if ( $is_ip ) { # look for the connection start message for the IP my $ip_matches; From 335a71e62d5c5d9286e1ed76cad25d3f7e72a757 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 30 Jun 2012 19:10:14 -0400 Subject: [PATCH 143/352] resolvable_fromhost: additional logging --- plugins/resolvable_fromhost | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/plugins/resolvable_fromhost b/plugins/resolvable_fromhost index d65bece..3181470 100644 --- a/plugins/resolvable_fromhost +++ b/plugins/resolvable_fromhost @@ -68,6 +68,7 @@ Default: temp (temporary, aka soft, aka 4xx). use strict; use warnings; +use lib 'lib'; use Qpsmtpd::Constants; use Qpsmtpd::DSN; use Qpsmtpd::TcpServer; @@ -114,13 +115,14 @@ sub hook_mail { }; my $result = $transaction->notes('resolvable_fromhost') or do { + $self->log(LOGINFO, 'error, missing result' ); return Qpsmtpd::DSN->temp_resolver_failed( $self->get_reject_type(), '' ); }; return DECLINED if $result =~ /^(?:a|ip|mx)$/; # success return DECLINED if $result =~ /^(?:whitelist|null|naughty)$/; # immunity - $self->log(LOGINFO, $result ); # log error + $self->log(LOGINFO, "fail, $result" ); # log error return Qpsmtpd::DSN->addr_bad_from_system( $self->get_reject_type(), "FQDN required in the envelope sender"); From 376bd492cd55b5094ff119b14745c823799e85a8 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 30 Jun 2012 22:35:17 -0400 Subject: [PATCH 144/352] earlytalker: lower karma for earlytalkers --- plugins/earlytalker | 1 + 1 file changed, 1 insertion(+) diff --git a/plugins/earlytalker b/plugins/earlytalker index f7d38b2..bcbad95 100644 --- a/plugins/earlytalker +++ b/plugins/earlytalker @@ -205,6 +205,7 @@ sub log_and_deny { my $ip = $self->qp->connection->remote_ip || 'remote host'; $self->connection->notes('earlytalker', 1); + $self->adjust_karma( -1 ); my $log_mess = "$ip started talking before we said hello"; my $smtp_msg = 'Connecting host started transmitting before SMTP greeting'; From df715db16b497007821c564ce27e2b307c3405c0 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 20 Jul 2012 11:35:20 -0400 Subject: [PATCH 145/352] allow messages with no body: Robin's patch This is Robin's patch from here: http://sources.gentoo.org/cgi-bin/viewvc.cgi/gentoo-x86/mail-mta/qpsmtpd/files/qpsmtpd-0.83-accept-empty-email.patch?view=markup --- lib/Qpsmtpd/SMTP.pm | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index 4247503..f1b48db 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -634,7 +634,10 @@ sub data_respond { my $timeout = $self->config('timeout'); while (defined($_ = $self->getline($timeout))) { - $complete++, last if $_ eq ".\r\n"; + if ( $_ eq ".\r\n" ) { + $complete++; + $_ eq ''; + }; $i++; # should probably use \012 and \015 in these checks instead of \r and \n ... @@ -650,7 +653,7 @@ sub data_respond { unless (($max_size and $size > $max_size)) { s/\r\n$/\n/; s/^\.\./\./; - if ($in_header and m/^$/) { + if ($in_header && (m/^$/ || $complete > 0)) { $in_header = 0; my @headers = split /^/m, $buffer; @@ -693,9 +696,10 @@ sub data_respond { # copy all lines into the spool file, including the headers # we will create a new header later before sending onwards - $self->transaction->body_write($_); + $self->transaction->body_write($_) if ! $complete; $size += length $_; } + last if $complete > 0; #$self->log(LOGDEBUG, "size is at $size\n") unless ($i % 300); } From a5eda100b2a9bab20d6175f6d8c5a37ca9e0ca05 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 20 Jul 2012 11:41:09 -0400 Subject: [PATCH 146/352] change loglevel from 9 to 6 more appropriate loglevel for users --- config.sample/logging | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config.sample/logging b/config.sample/logging index a870643..578467a 100644 --- a/config.sample/logging +++ b/config.sample/logging @@ -5,7 +5,7 @@ # are included below. Just remove the # symbol to enable them. # default logging plugin -logging/warn 9 +logging/warn 6 #logging/adaptive [accept minlevel] [reject maxlevel] [prefix char] #logging/adaptive 4 6 From 2b02f6b781e26a1f487e577b3dcaedd57d7d3797 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 20 Jul 2012 11:43:20 -0400 Subject: [PATCH 147/352] dnsbl rejections handled by naughty plugin --- config.sample/plugins | 2 ++ 1 file changed, 2 insertions(+) diff --git a/config.sample/plugins b/config.sample/plugins index 7f19860..1e31418 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -83,6 +83,8 @@ dspam learn_from_sa 7 reject 1 naughty reject data +naughty + # You must enable a queue plugin - see the options in plugins/queue/ - for example: # queue to a maildir From deca40a6fb162b72d956936d2cab635e5d1c04f0 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 20 Jul 2012 11:49:33 -0400 Subject: [PATCH 148/352] update plugin/headers config entry use future/past instead of days: -headers days 5 reject_type temp require From,Date +headers reject 1 reject_type temp require From,Date future 2 past 15 --- config.sample/plugins | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config.sample/plugins b/config.sample/plugins index 1e31418..b76de5b 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -57,7 +57,7 @@ auth/authdeny # this plugin needs to run after all other "rcpt" plugins rcpt_ok -headers days 5 reject_type temp require From,Date +headers reject 1 reject_type temp require From,Date future 2 past 15 dkim # content filters From 000db0ab14e98ade5fdbf78484d2e2fa0f51999e Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 20 Jul 2012 11:54:56 -0400 Subject: [PATCH 149/352] removed duplicate naughty from config --- config.sample/plugins | 2 -- 1 file changed, 2 deletions(-) diff --git a/config.sample/plugins b/config.sample/plugins index b76de5b..94bcc4f 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -83,8 +83,6 @@ dspam learn_from_sa 7 reject 1 naughty reject data -naughty - # You must enable a queue plugin - see the options in plugins/queue/ - for example: # queue to a maildir From ab1b2114461e419862204c7430f563e1e3f9d92a Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 20 Jul 2012 11:59:54 -0400 Subject: [PATCH 150/352] added vpopmail_ext to qmail_deliverable plugin --- plugins/qmail_deliverable | 89 +++++++++++++++++++++++++++++++++------ 1 file changed, 75 insertions(+), 14 deletions(-) diff --git a/plugins/qmail_deliverable b/plugins/qmail_deliverable index 04cf5aa..e4e0263 100755 --- a/plugins/qmail_deliverable +++ b/plugins/qmail_deliverable @@ -38,6 +38,13 @@ Example: Use "smtproutes:8998" (no second colon) to simply skip the deliverability check for domains not listed in smtproutes. +=item vpopmail_ext [ 0 | 1 ] + +Is vpopmail configured with the qmail-ext feature enabled? If so, this config +option must be enabled in order for user-ext@example.org addresses to work. + +Default: 0 + =back =head1 CAVEATS @@ -62,11 +69,57 @@ L, L, L =cut -use Qmail::Deliverable::Client qw(deliverable); +################################# +################################# + +BEGIN { + use FindBin qw($Bin $Script); + if (not $INC{'Qpsmtpd.pm'}) { + my $dir = '$PLUGINS_DIRECTORY'; + -d and $dir = $_ for qw( + /home/qpsmtpd/plugins + /home/smtp/qpsmtpd/plugins + /usr/local/qpsmtpd/plugins + /usr/local/share/qpsmtpd/plugins + /usr/share/qpsmtpd/plugins + ); + + my $file = "the 'plugins' configuration file"; + -f and $file = $_ for qw( + /home/qpsmtpd/config/plugins + /home/smtp/qpsmtpd/config/plugins + /usr/local/qpsmtpd/config/plugins + /usr/local/etc/qpsmtpd/plugins + /etc/qpsmtpd/plugins + ); + + # "die" would print "BEGIN failed" garbage + print STDERR <<"END"; + +This is a plugin for qpsmtpd and should not be run manually. + +To install the plugin: + + ln -s $Bin/$Script $dir/ + +And add "$Script server 127.0.0.1:8998" to $file, before rcpt_ok. +For configuration instructions, read "man $Script" + +(Paths may vary.) + +END + exit 255; + } +} + +################################# +################################# + use strict; use warnings; use Qpsmtpd::Constants; +use Qmail::Deliverable::Client qw(deliverable); my %smtproutes; my $shared_domain; # global variable to be closed over by the SERVER callback @@ -98,14 +151,18 @@ sub register { } elsif ($args{server}) { $Qmail::Deliverable::Client::SERVER = $args{server}; } + + if ( $args{vpopmail_ext} ) { + $Qmail::Deliverable::VPOPMAIL_EXT = $args{vpopmail_ext}; + }; } - $self->register_hook('rcpt', 'rcpt_handler'); + $self->register_hook("rcpt", "rcpt_handler"); } sub rcpt_handler { my ($self, $transaction, $rcpt) = @_; - return DECLINED if $self->is_immune(); + return DECLINED if $self->is_immune(); # requires QP 0.90+ my $address = $rcpt->address; $self->log(LOGDEBUG, "Checking deliverability for recipient '$address'"); @@ -115,31 +172,35 @@ sub rcpt_handler { my $rv = deliverable $address; if (not defined $rv or not length $rv) { - $self->log(LOGWARN, "Unknown error checking deliverability of '$address'"); + $self->log(LOGWARN, "error (unknown) checking '$address'"); return DECLINED; } my $k = 0; # known status code - $self->log(LOGINFO, "Permission failure"), $k++ if $rv == 0x11; + $self->log(LOGINFO, "error, permission failure"), $k++ if $rv == 0x11; $self->log(LOGINFO, "pass, qmail-command in dot-qmail"),$k++ if $rv == 0x12; - $self->log(LOGINFO, "bouncesaying with program"), $k++ if $rv == 0x13; + $self->log(LOGINFO, "pass, bouncesaying with program"), $k++ if $rv == 0x13; $self->log(LOGINFO, "Temporarily undeliverable: group/world writable"), $k++ if $rv == 0x21; $self->log(LOGINFO, "Temporarily undeliverable: sticky home directory"),$k++ if $rv == 0x22; - $self->log(LOGINFO, "error: $Qmail::Deliverable::Client::ERROR"), $k++ + $self->log(LOGINFO, "error, $Qmail::Deliverable::Client::ERROR"), $k++ if $rv == 0x2f; $self->log(LOGINFO, "pass, normal delivery"), $k++ if $rv == 0xf1; - $self->log(LOGINFO, "pass, deliverable through vpopmail"), $k++ if $rv == 0xf2; - $self->log(LOGINFO, "SHOULD NOT HAPPEN"), $k++ if $rv == 0xfe; + $self->log(LOGINFO, "pass, vpopmail dir"), $k++ if $rv == 0xf2; + $self->log(LOGINFO, "pass, vpopmail alias"), $k++ if $rv == 0xf3; + $self->log(LOGINFO, "pass, vpopmail catchall"), $k++ if $rv == 0xf4; + $self->log(LOGINFO, "pass, vpopmail vuser"), $k++ if $rv == 0xf5; + $self->log(LOGINFO, "pass, vpopmail qmail-ext"), $k++ if $rv == 0xf6; + $self->log(LOGINFO, "error, SHOULD NOT HAPPEN"), $k++ if $rv == 0xfe; $self->log(LOGINFO, "fail, address not local"), $k++ if $rv == 0xff; - $self->log(LOGINFO, sprintf("Unknown: 0x%02x", $rv)) if $rv and not $k; + if ( $rv ) { + $self->log(LOGINFO, sprintf("error, unknown: 0x%02x", $rv)) if not $k; + return DECLINED; + }; - return DECLINED if $rv; - - $self->adjust_karma( -1 ); - return (DENY, "fail, no mailbox by that name. qd (#5.1.1)" ); + return (DENY, "Sorry, no mailbox by that name. qd (#5.1.1)" ); } sub _smtproute { From c1694b2e81a625b43f44e91c58c4265b658937dd Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 14 Nov 2012 15:21:44 -0500 Subject: [PATCH 151/352] spamassassin: added 'headers none' option enables suppression of SA header insertion --- plugins/spamassassin | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/plugins/spamassassin b/plugins/spamassassin index 6e81c7e..d3b9710 100644 --- a/plugins/spamassassin +++ b/plugins/spamassassin @@ -18,7 +18,7 @@ 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 +spamassassin plugin will add relevant headers from spamd (X-Spam-Status etc). The format goes like @@ -67,6 +67,11 @@ 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 headers [none] + +By default, spamassasin headers are added to messages. To suppress header +insertion, use 'headers none'. + =item leave_old_headers [drop|rename|keep] Another mail server before might have checked this mail already and may have @@ -139,6 +144,7 @@ Make the "subject munge string" configurable use strict; use warnings; +use lib 'lib'; use Qpsmtpd::Constants; use Qpsmtpd::DSN; @@ -241,6 +247,12 @@ sub parse_spamd_response { sub insert_spam_headers { my ( $self, $transaction, $new_headers, $username ) = @_; + if ( $self->{_args}{headers} && $self->{_args}{headers} eq 'none' ) { + my $r = $self->parse_spam_header( $new_headers->{'X-Spam-Status'} ); + $transaction->notes('spamassassin', $r); + return; + }; + my $recipient_count = scalar $transaction->recipients; $self->_cleanup_spam_header($transaction, 'X-Spam-User'); # always clean up @@ -410,6 +422,8 @@ sub reject { sub munge_subject { my ($self, $transaction) = @_; + return if ($self->{_args}{headers} && $self->{_args}{headers} eq 'none'); + my $sa = $self->get_spam_results($transaction) or return; my $qp_num = $self->{_args}{munge_subject_threshold}; From 51f5c887db4a77b2babf5caf073f19ddd1e788dc Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 14 Nov 2012 15:24:06 -0500 Subject: [PATCH 152/352] whitelist: added debug log message & std plugin entries. --- plugins/whitelist | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/plugins/whitelist b/plugins/whitelist index 2e0ccb7..43aace4 100644 --- a/plugins/whitelist +++ b/plugins/whitelist @@ -94,6 +94,12 @@ automatically allow relaying from that IP. =cut +use strict; +use warnings; + +use lib 'lib'; +use Qpsmtpd::Constants; + my $VERSION = 0.02; # Default is to merge whitelists in per_recipient mode @@ -144,6 +150,7 @@ sub check_host { return OK; } } + $self->log(LOGDEBUG, "skip: $ip is not whitelisted"); return DECLINED; } From b8baa4b91b2c07d08c7e22344e3d364858a42cf9 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 14 Nov 2012 16:58:16 -0500 Subject: [PATCH 153/352] spf: improved support for IPv6 clients --- config.sample/relayclients | 6 ++++++ plugins/sender_permitted_from | 18 +++++++++++++++++- 2 files changed, 23 insertions(+), 1 deletion(-) diff --git a/config.sample/relayclients b/config.sample/relayclients index 792c76b..a0fbc4e 100644 --- a/config.sample/relayclients +++ b/config.sample/relayclients @@ -4,3 +4,9 @@ 127.0.0.1 # leading/trailing whitespace is ignored 192.0. +# +# IPv6 formats ends in a nibble (not a netmask, prefixlen, or colon) +# RFC 3849 example +2001:DB8 +2001:DB8::1 +2001:0DB8:0000:0000:0000:0000:0000:0001 diff --git a/plugins/sender_permitted_from b/plugins/sender_permitted_from index d888701..42f26d8 100644 --- a/plugins/sender_permitted_from +++ b/plugins/sender_permitted_from @@ -59,6 +59,8 @@ use warnings; #use Mail::SPF 2.000; # eval'ed in ->register use Qpsmtpd::Constants; +use Net::IP; + sub register { my ($self, $qp, %args) = @_; eval 'use Mail::SPF'; @@ -237,13 +239,27 @@ sub is_in_relayclients { my $more_relay_clients = $self->qp->config('morerelayclients', 'map'); my %relay_clients = map { $_ => 1 } @relay_clients; + my $ipv6 = $client_ip =~ /:/ ? 1 : 0; + + if ( $ipv6 && $client_ip =~ /::/ ) { # IPv6 compressed notation + $client_ip = Net::IP::ip_expand_address($client_ip,6); + }; + while ($client_ip) { if ( exists $relay_clients{$client_ip} || exists $more_relay_clients->{$client_ip} ) { $self->log( LOGDEBUG, "skip, IP in relayclients" ); return 1; }; - $client_ip =~ s/\d+\.?$// or last; # strip off another 8 bits + + # added IPv6 support (Michael Holzt - 2012-11-14) + if ( $ipv6 ) { + $client_ip =~ s/[0-9a-f]:*$//; # strip off another nibble + chop $client_ip if ':' eq substr($client_ip, -1, 1); + } + else { + $client_ip =~ s/\d+\.?$// or last; # strip off another 8 bits + } } return; }; From 61f7ea00e0f96665e25c3d195d99609aa06f2527 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 14 Nov 2012 17:15:08 -0500 Subject: [PATCH 154/352] TcpServer, improve IPv6 support, by Michael Holzt --- lib/Qpsmtpd/TcpServer.pm | 2 +- qpsmtpd-forkserver | 4 ---- qpsmtpd-prefork | 4 ---- 3 files changed, 1 insertion(+), 9 deletions(-) diff --git a/lib/Qpsmtpd/TcpServer.pm b/lib/Qpsmtpd/TcpServer.pm index 42dad62..e4af474 100644 --- a/lib/Qpsmtpd/TcpServer.pm +++ b/lib/Qpsmtpd/TcpServer.pm @@ -14,7 +14,7 @@ if ( # INET6 prior to 2.01 will not work; sorry. eval {require IO::Socket::INET6; IO::Socket::INET6->VERSION("2.00");} ) { - import Socket6; + Socket6->import(qw(inet_ntop)); $has_ipv6=1; } diff --git a/qpsmtpd-forkserver b/qpsmtpd-forkserver index c281a4f..84000f3 100755 --- a/qpsmtpd-forkserver +++ b/qpsmtpd-forkserver @@ -20,10 +20,6 @@ $| = 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) diff --git a/qpsmtpd-prefork b/qpsmtpd-prefork index c176886..3d018a9 100755 --- a/qpsmtpd-prefork +++ b/qpsmtpd-prefork @@ -31,10 +31,6 @@ 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 From 4f181c51535c1237b2582feca49ecd39f657463f Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 14 Nov 2012 17:37:38 -0500 Subject: [PATCH 155/352] SMTP.pm: fixed invalid operator which produced this warning: Useless use of string eq in void context at lib/Qpsmtpd/SMTP.pm line 639. --- lib/Qpsmtpd/SMTP.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index f1b48db..fd6dcf4 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -636,7 +636,7 @@ sub data_respond { while (defined($_ = $self->getline($timeout))) { if ( $_ eq ".\r\n" ) { $complete++; - $_ eq ''; + $_ = ''; }; $i++; From f0c01a04127a9821499e5d9d508bc5075e5943a5 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 14 Nov 2012 17:57:56 -0500 Subject: [PATCH 156/352] fix relayclient test after commit b8baa4b91b which added example IPv6 IPs to the config file --- t/config.t | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/t/config.t b/t/config.t index 8b6b11e..975e8d5 100644 --- a/t/config.t +++ b/t/config.t @@ -25,7 +25,9 @@ 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'); +is($relayclients, + '127.0.0.1,192.0.,2001:0DB8:0000:0000:0000:0000:0000:0001,2001:DB8,2001:DB8::1', + 'config("relayclients") are trimmed'); foreach my $f ( @mes ) { unlink $f if -f $f; From 427e92ee7b1eeef55451ae15b81a3eb715796266 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 14 Nov 2012 18:00:30 -0500 Subject: [PATCH 157/352] SA: suppress undefined variable warnings --- plugins/spamassassin | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/spamassassin b/plugins/spamassassin index d3b9710..082f44d 100644 --- a/plugins/spamassassin +++ b/plugins/spamassassin @@ -392,7 +392,7 @@ sub reject { my $ham_or_spam = $sa_results->{is_spam} eq 'Yes' ? 'Spam' : 'Ham'; my $status = "$ham_or_spam, $score"; - my $learn; + my $learn = ''; if ( $sa_results->{autolearn} ) { $learn = "learn=". $sa_results->{autolearn}; }; From 01b623dc8319c088683a8daba5adf0b6c87f13e0 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 14 Nov 2012 18:21:21 -0500 Subject: [PATCH 158/352] dnsbl: fixed plugin test failure --- t/plugin_tests/dnsbl | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/t/plugin_tests/dnsbl b/t/plugin_tests/dnsbl index 517c220..28bd775 100644 --- a/t/plugin_tests/dnsbl +++ b/t/plugin_tests/dnsbl @@ -48,8 +48,12 @@ sub test_is_set_rblsmtpd { sub test_hook_connect { my $self = shift; + # reset values that other tests may have fiddled with my $conn = $self->qp->connection; $conn->relay_client(0); # other tests may leave it enabled + $conn->notes('whitelisthost', '' ); + $conn->notes('whitelistsender', ''); + $conn->notes('naughty', ''); $conn->remote_ip('127.0.0.2'); # standard dnsbl test value my ($rc, $mess) = $self->hook_connect($self->qp->transaction); From eb154f20693b85cdba0a92930d0f58fb61f8f473 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 14 Nov 2012 19:31:18 -0500 Subject: [PATCH 159/352] dnsbl test: don't cry about test failures that depend on working network & DNS. --- t/plugin_tests/dnsbl | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/t/plugin_tests/dnsbl b/t/plugin_tests/dnsbl index 28bd775..e115090 100644 --- a/t/plugin_tests/dnsbl +++ b/t/plugin_tests/dnsbl @@ -51,13 +51,18 @@ sub test_hook_connect { # reset values that other tests may have fiddled with my $conn = $self->qp->connection; $conn->relay_client(0); # other tests may leave it enabled - $conn->notes('whitelisthost', '' ); - $conn->notes('whitelistsender', ''); - $conn->notes('naughty', ''); + $conn->notes('whitelisthost', undef ); + $conn->notes('whitelistsender', undef); + $conn->notes('naughty', undef); $conn->remote_ip('127.0.0.2'); # standard dnsbl test value my ($rc, $mess) = $self->hook_connect($self->qp->transaction); - cmp_ok( $rc, '==', DENY, "connect +"); + if ( $rc == DENY ) { + cmp_ok( $rc, '==', DENY, "connect +"); + } + else { + ok( 1, "connect +, skipped (is DNS working?)" ); + }; } sub test_reject_type { From 78cab525826cdca4367553b6fb5293e9ff2f04e2 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 14 Nov 2012 23:21:20 -0500 Subject: [PATCH 160/352] SPF: use $conn->relay_client instead of duplicated is_in_relayclients method. Expects relay plugin to have set relay_client, a reasonable assumption. --- config.sample/relayclients | 10 +++++---- plugins/relay | 23 ++++++++++++++++----- plugins/sender_permitted_from | 39 ++--------------------------------- t/config.t | 2 +- 4 files changed, 27 insertions(+), 47 deletions(-) diff --git a/config.sample/relayclients b/config.sample/relayclients index a0fbc4e..31fcaeb 100644 --- a/config.sample/relayclients +++ b/config.sample/relayclients @@ -1,12 +1,14 @@ # used by plugins/relay -# Format is IP, or IP part with trailing dot +# IPv4 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. # -# IPv6 formats ends in a nibble (not a netmask, prefixlen, or colon) -# RFC 3849 example -2001:DB8 +# IPv6 formats can be compressed or expanded, may include a prefixlen, +# and can end on any nibble boundary. Nibble boundaries must be expressed +# in expanded format. (RFC 3849 example) +2001:0DB8 2001:DB8::1 +2001:DB8::1/32 2001:0DB8:0000:0000:0000:0000:0000:0001 diff --git a/plugins/relay b/plugins/relay index e8b0743..84658cf 100644 --- a/plugins/relay +++ b/plugins/relay @@ -37,12 +37,12 @@ Each line in I is one of: - partial IP address terminated by a dot or colon for matching whole networks 192.168.42. - fdda:b13d:e431:ae06: + 2001:db8:e431:ae06: ... - a network/mask, aka a CIDR block 10.1.0.0/24 - fdda:b13d:e431:ae06::/64 + 2001:db8:e431:ae06::/64 ... =head2 morerelayclients @@ -175,15 +175,20 @@ sub is_octet_match { my $self = shift; my $ip = $self->qp->connection->remote_ip; - $ip =~ s/::/:/; - if ( $ip eq ':1' ) { + if ( $ip eq '::1' ) { $self->log(LOGINFO, "pass, octet matched localhost ($ip)"); return 1; }; my $more_relay_clients = $self->qp->config('morerelayclients', 'map'); + my $ipv6 = $ip =~ /:/ ? 1 : 0; + + if ( $ipv6 && $ip =~ /::/ ) { # IPv6 compressed notation + $ip = Net::IP::ip_expand_address($ip,6); + }; + while ($ip) { if ( exists $self->{_octets}{$ip} ) { $self->log(LOGINFO, "pass, octet match in relayclients ($ip)"); @@ -194,7 +199,15 @@ sub is_octet_match { $self->log(LOGINFO, "pass, octet match in morerelayclients ($ip)"); return 1; }; - $ip =~ s/(\d|\w)+(:|\.)?$// or last; # strip off another 8 bits + + # added IPv6 support (Michael Holzt - 2012-11-14) + if ( $ipv6 ) { + $ip =~ s/[0-9a-f]:?$//; # strip off another nibble + chop $ip if ':' eq substr($ip, -1, 1); + } + else { + $ip =~ s/\d+\.?$// or last; # strip off another 8 bits + } } $self->log(LOGDEBUG, "no octet match" ); diff --git a/plugins/sender_permitted_from b/plugins/sender_permitted_from index 42f26d8..05044d8 100644 --- a/plugins/sender_permitted_from +++ b/plugins/sender_permitted_from @@ -59,8 +59,6 @@ use warnings; #use Mail::SPF 2.000; # eval'ed in ->register use Qpsmtpd::Constants; -use Net::IP; - sub register { my ($self, $qp, %args) = @_; eval 'use Mail::SPF'; @@ -92,8 +90,8 @@ sub mail_handler { return (DECLINED, "SPF - null sender"); }; - if ( $self->is_in_relayclients() ) { - $self->log( LOGINFO, "skip, in relayclients" ); + if ( $self->qp->connection->relay_client ) { + $self->log( LOGINFO, "skip, relay_client" ); return (DECLINED, "SPF - relaying permitted"); }; @@ -231,39 +229,6 @@ sub data_post_handler { return DECLINED; } -sub is_in_relayclients { - my $self = shift; - - 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; - - my $ipv6 = $client_ip =~ /:/ ? 1 : 0; - - if ( $ipv6 && $client_ip =~ /::/ ) { # IPv6 compressed notation - $client_ip = Net::IP::ip_expand_address($client_ip,6); - }; - - while ($client_ip) { - if ( exists $relay_clients{$client_ip} || - exists $more_relay_clients->{$client_ip} ) { - $self->log( LOGDEBUG, "skip, IP in relayclients" ); - return 1; - }; - - # added IPv6 support (Michael Holzt - 2012-11-14) - if ( $ipv6 ) { - $client_ip =~ s/[0-9a-f]:*$//; # strip off another nibble - chop $client_ip if ':' eq substr($client_ip, -1, 1); - } - else { - $client_ip =~ s/\d+\.?$// or last; # strip off another 8 bits - } - } - return; -}; - sub is_special_recipient { my ($self, $rcpt) = @_; diff --git a/t/config.t b/t/config.t index 975e8d5..e82e185 100644 --- a/t/config.t +++ b/t/config.t @@ -26,7 +26,7 @@ is($smtpd->config('me'), 'some.host.example.org', 'config("me")'); # line with both) my $relayclients = join ",", sort $smtpd->config('relayclients'); is($relayclients, - '127.0.0.1,192.0.,2001:0DB8:0000:0000:0000:0000:0000:0001,2001:DB8,2001:DB8::1', + '127.0.0.1,192.0.,2001:0DB8:0000:0000:0000:0000:0000:0001,2001:DB8::1/32,2001:DB8,2001:DB8::1', 'config("relayclients") are trimmed'); foreach my $f ( @mes ) { From c77e304cc7662818aa48ad30d23ed473851da617 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 14 Nov 2012 23:25:44 -0500 Subject: [PATCH 161/352] fixed test for commit 78cab52582 --- t/config.t | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/t/config.t b/t/config.t index e82e185..5e674b8 100644 --- a/t/config.t +++ b/t/config.t @@ -26,7 +26,7 @@ is($smtpd->config('me'), 'some.host.example.org', 'config("me")'); # line with both) my $relayclients = join ",", sort $smtpd->config('relayclients'); is($relayclients, - '127.0.0.1,192.0.,2001:0DB8:0000:0000:0000:0000:0000:0001,2001:DB8::1/32,2001:DB8,2001:DB8::1', + '127.0.0.1,192.0.,2001:0DB8,2001:0DB8:0000:0000:0000:0000:0000:0001,2001:DB8::1,2001:DB8::1/32', 'config("relayclients") are trimmed'); foreach my $f ( @mes ) { From d75ce706781526b2bfc3b4f3addd3c680e8ce07b Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 14 Nov 2012 23:27:49 -0500 Subject: [PATCH 162/352] SPF: removed test for removed is_in_relayclients() --- t/plugin_tests/sender_permitted_from | 14 -------------- 1 file changed, 14 deletions(-) diff --git a/t/plugin_tests/sender_permitted_from b/t/plugin_tests/sender_permitted_from index 342586c..7aface6 100644 --- a/t/plugin_tests/sender_permitted_from +++ b/t/plugin_tests/sender_permitted_from @@ -13,23 +13,9 @@ sub register_tests { eval 'use Mail::SPF'; return if $@; - $self->register_test('test_is_in_relayclients', 2); $self->register_test('test_is_special_recipient', 5); } -sub test_is_in_relayclients { - my $self = shift; - - my $transaction = $self->qp->transaction; - $self->qp->connection->remote_ip('192.1.7.8'); - ok( ! $self->is_in_relayclients( $transaction ), "is_in_relayclients -"); - - $self->qp->connection->relay_client(0); - $self->qp->connection->remote_ip('192.0.7.5'); - my $client_ip = $self->qp->connection->remote_ip; - ok( $client_ip, "relayclients ($client_ip)"); -}; - sub test_is_special_recipient { my $self = shift; From 60d0c8b8538d821850827ba87c1b597b2b0db598 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Thu, 15 Nov 2012 01:35:15 -0500 Subject: [PATCH 163/352] headers: simplify required headers logic --- plugins/headers | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/plugins/headers b/plugins/headers index 4773ba1..ae7accb 100644 --- a/plugins/headers +++ b/plugins/headers @@ -132,11 +132,8 @@ sub hook_data_post { 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" - ); - }; + next if $header->get($h); + return $self->get_reject( "We require a valid $h header", "no $h header"); }; foreach my $h ( @singular_headers ) { From 81aa6a699007cedf1055e9ae317bb6b2cf470dad Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 16 Nov 2012 14:35:19 -0500 Subject: [PATCH 164/352] dkim: added some missing POD text --- plugins/dkim | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/plugins/dkim b/plugins/dkim index 021d7a5..549dc2c 100644 --- a/plugins/dkim +++ b/plugins/dkim @@ -54,7 +54,9 @@ David Summers - http://www.nntp.perl.org/group/perl.qpsmtpd/2010/08/msg9417.html Matthew Harrell - http://alecto.bittwiddlers.com/files/qpsmtpd/dkimcheck -I first attempted to fix the dkimcheck plugin, but soon scrapped that effort and wrote this one. +I first attempted to fix the dkimcheck plugin, but soon scrapped that effort and wrote this one. Why? + +=over 4 The nine 'if' brackets with 19 conditionals, and my inability to easily determine which of the 15 possible permutations (5 signature validation results x 3 possible policy results) were covered. @@ -64,6 +66,8 @@ The paradim of a single policy, when DKIM supports 0 or many. Although I may yet The OBF programming style, which is nigh impossible to test. +=back + =cut use strict; From d0e47a9dc767b34c3fc289141b420673e24b87aa Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 16 Nov 2012 18:02:13 -0500 Subject: [PATCH 165/352] arrange sample plugins by SMTP phase and add comments to that effect, provides the uninitiated with clues about which data each plugin actions upon --- config.sample/plugins | 52 ++++++++++++++++++++++++++----------------- 1 file changed, 31 insertions(+), 21 deletions(-) diff --git a/config.sample/plugins b/config.sample/plugins index 94bcc4f..004dca6 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -15,38 +15,33 @@ # from one IP! hosts_allow -# information plugins +# connection / informational plugins +#connection_time 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 -#karma penalty_box 1 reject naughty - # tls should load before count_unrecognized_commands #tls earlytalker count_unrecognized_commands 4 + relay - -resolvable_fromhost - -rhsbl +#whitelist +#karma penalty_box 1 reject naughty dnsbl reject naughty reject_type disconnect -badmailfrom -badrcptto +rhsbl +# greylisting reject 0 p0f genre,windows + + +# HELO plugins helo policy lenient +# 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 -# sender_permitted_from -# greylisting p0f genre,windows +# AUTH plugins #auth/auth_checkpassword checkpw /usr/local/vpopmail/bin/vchkpw true /usr/bin/true #auth/auth_vpopmail #auth/auth_vpopmaild @@ -54,14 +49,29 @@ helo policy lenient auth/auth_flat_file auth/authdeny +# enable to accept MAIL FROM:/RCPT TO: addresses without surrounding <> +dont_require_anglebrackets + +# MAIL FROM plugins +badmailfrom +#badmailfromto +resolvable_fromhost +# sender_permitted_from + +# RCPT TO plugins +badrcptto +#qmail_deliverable # this plugin needs to run after all other "rcpt" plugins rcpt_ok +# DATA plugins +#uribl headers reject 1 reject_type temp require From,Date future 2 past 15 +#bogus_bounce +#loop dkim # content filters -#uribl virus/klez_filter # You can run the spamassassin plugin with options. See perldoc @@ -75,7 +85,7 @@ spamassassin reject 12 # spamassassin reject 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 +dspam autolearn spamassassin reject agree # run the clamav virus checking plugin # virus/clamav From b89272c48045bc7a1c182a573ca1733e5cf6a1e1 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 16 Nov 2012 19:01:34 -0500 Subject: [PATCH 166/352] dspam: change reject 'agree' to .95 score --- config.sample/plugins | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config.sample/plugins b/config.sample/plugins index 004dca6..5e95731 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -85,7 +85,7 @@ spamassassin reject 12 # spamassassin reject 20 munge_subject_threshold 10 # dspam must run after spamassassin for the learn_from_sa feature to work -dspam autolearn spamassassin reject agree +dspam autolearn spamassassin reject 0.95 # run the clamav virus checking plugin # virus/clamav From f56c200e91ac48703666691b5711d807412c8cc8 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 16 Nov 2012 20:03:10 -0500 Subject: [PATCH 167/352] several adjustments for tests --- t/config/relayclients | 11 ++++++++++- t/plugin_tests/dspam | 1 + t/plugin_tests/{check_earlytalker => earlytalker} | 0 t/plugin_tests/headers | 1 + 4 files changed, 12 insertions(+), 1 deletion(-) rename t/plugin_tests/{check_earlytalker => earlytalker} (100%) diff --git a/t/config/relayclients b/t/config/relayclients index 13c9be7..31fcaeb 100644 --- a/t/config/relayclients +++ b/t/config/relayclients @@ -1,5 +1,14 @@ -# Format is IP, or IP part with trailing dot +# used by plugins/relay +# IPv4 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. +# +# IPv6 formats can be compressed or expanded, may include a prefixlen, +# and can end on any nibble boundary. Nibble boundaries must be expressed +# in expanded format. (RFC 3849 example) +2001:0DB8 +2001:DB8::1 +2001:DB8::1/32 +2001:0DB8:0000:0000:0000:0000:0000:0001 diff --git a/t/plugin_tests/dspam b/t/plugin_tests/dspam index 4752ec8..8e0645c 100644 --- a/t/plugin_tests/dspam +++ b/t/plugin_tests/dspam @@ -22,6 +22,7 @@ sub test_log_and_return { my $transaction = $self->qp->transaction; # reject not set + $self->{_args}{reject} = undef; $transaction->notes('dspam', { class=> 'Spam', probability => .99, confidence=>1 } ); ($r) = $self->log_and_return( $transaction ); cmp_ok( $r, '==', DECLINED, "($r)"); diff --git a/t/plugin_tests/check_earlytalker b/t/plugin_tests/earlytalker similarity index 100% rename from t/plugin_tests/check_earlytalker rename to t/plugin_tests/earlytalker diff --git a/t/plugin_tests/headers b/t/plugin_tests/headers index 3470164..7cf9e7e 100644 --- a/t/plugin_tests/headers +++ b/t/plugin_tests/headers @@ -86,6 +86,7 @@ sub test_hook_data_post { my $transaction = $self->qp->transaction; my ($code, $mess) = $self->hook_data_post( $transaction ); + $mess ||= ''; # avoid undef warning cmp_ok( DECLINED, '==', $code, "okay $code, $mess" ); $transaction->header->delete('Date'); From 3355d5c00007292a758b90fc53c5969d916079f8 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 19 Nov 2012 00:09:08 -0500 Subject: [PATCH 168/352] run: added commented example for port 587 --- run | 1 + 1 file changed, 1 insertion(+) diff --git a/run b/run index 0e2ff84..1bbd0a6 100755 --- a/run +++ b/run @@ -32,6 +32,7 @@ exec $BIN/softlimit -m $MAXRAM \ # $PERL -T ./qpsmtpd-forkserver \ # --listen-address $IP \ # --port $PORT \ +# --port 587 \ # --limit-connections 15 \ # --max-from-ip 5 \ # --user $QPUSER From 588126737d210d3771f4a926d1a7607a4e7802aa Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 19 Nov 2012 00:14:46 -0500 Subject: [PATCH 169/352] MANIFEST: packaging update --- MANIFEST | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/MANIFEST b/MANIFEST index 991ffdd..7c46ef1 100644 --- a/MANIFEST +++ b/MANIFEST @@ -54,14 +54,19 @@ lib/Qpsmtpd/TcpServer/Prefork.pm lib/Qpsmtpd/Transaction.pm lib/Qpsmtpd/Utils.pm LICENSE +log/log2sql +log/log2sql.sql log/run +log/show_message +log/summarize +log/watch Makefile.PL MANIFEST This list of files MANIFEST.SKIP META.yml Module meta-data (added by MakeMaker) -plugins/async/earlytalker plugins/async/dns_whitelist_soft plugins/async/dnsbl +plugins/async/earlytalker plugins/async/queue/smtp-forward plugins/async/resolvable_fromhost plugins/async/rhsbl @@ -78,16 +83,16 @@ plugins/badmailfrom plugins/badmailfromto plugins/badrcptto plugins/bogus_bounce -plugins/earlytalker -plugins/loop plugins/connection_time plugins/content_log plugins/count_unrecognized_commands +plugins/dkim plugins/dns_whitelist_soft plugins/dnsbl plugins/domainkeys plugins/dont_require_anglebrackets plugins/dspam +plugins/earlytalker plugins/greylisting plugins/headers plugins/helo @@ -106,10 +111,12 @@ plugins/logging/file plugins/logging/syslog plugins/logging/transaction_id plugins/logging/warn +plugins/loop plugins/milter plugins/naughty plugins/noop_counter plugins/parse_addr_withhelo +plugins/qmail_deliverable plugins/queue/exim-bsmtp plugins/queue/maildir plugins/queue/postfix-queue @@ -120,9 +127,9 @@ plugins/random_error plugins/rcpt_map plugins/rcpt_ok plugins/rcpt_regexp +plugins/registry.txt plugins/relay plugins/resolvable_fromhost -plugins/resolvable_fromhost plugins/rhsbl plugins/sender_permitted_from plugins/spamassassin @@ -138,6 +145,7 @@ plugins/virus/kavscanner plugins/virus/klez_filter plugins/virus/sophie plugins/virus/uvscan +plugins/whitelist qpsmtpd qpsmtpd-async qpsmtpd-forkserver @@ -174,7 +182,6 @@ t/plugin_tests/auth/authnull t/plugin_tests/badmailfrom t/plugin_tests/badmailfromto t/plugin_tests/badrcptto -t/plugin_tests/earlytalker t/plugin_tests/count_unrecognized_commands t/plugin_tests/dnsbl t/plugin_tests/dspam From 1081461d36e567f48bdd6421b4c71f8d23ecfd61 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 19 Nov 2012 00:29:33 -0500 Subject: [PATCH 170/352] qmail_deliverable: reject null sender to ezmlm lis --- plugins/qmail_deliverable | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/plugins/qmail_deliverable b/plugins/qmail_deliverable index e4e0263..58e8288 100755 --- a/plugins/qmail_deliverable +++ b/plugins/qmail_deliverable @@ -180,6 +180,12 @@ sub rcpt_handler { $self->log(LOGINFO, "error, permission failure"), $k++ if $rv == 0x11; $self->log(LOGINFO, "pass, qmail-command in dot-qmail"),$k++ if $rv == 0x12; $self->log(LOGINFO, "pass, bouncesaying with program"), $k++ if $rv == 0x13; + if ( $rv == 0x14 ) { + my $s = $transaction->sender->address; + return (DENY, "fail, mailing lists do not accept null senders") + if ( ! $s || $s eq '<>'); + $self->log(LOGINFO, "pass, ezmlm list"); $k++; + }; $self->log(LOGINFO, "Temporarily undeliverable: group/world writable"), $k++ if $rv == 0x21; $self->log(LOGINFO, "Temporarily undeliverable: sticky home directory"),$k++ From bf7c66366220b16678a8498c493f0e00d8511922 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 19 Nov 2012 00:30:36 -0500 Subject: [PATCH 171/352] clamdscan: replace immunity check with naught test immunity check was disabled by default, as it wasn't a good policy. OTOH, a naughty check is a sensible default, as we can skip processing on messages we already decided to reject. --- plugins/virus/clamdscan | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/plugins/virus/clamdscan b/plugins/virus/clamdscan index 72e64ea..ab35ab0 100644 --- a/plugins/virus/clamdscan +++ b/plugins/virus/clamdscan @@ -140,7 +140,10 @@ sub data_post_handler { my $filename = $self->get_filename( $transaction ) or return DECLINED; - #return (DECLINED) if $self->is_immune(); + if ( $self->connection->notes('naughty') ) { + $self->log( LOGINFO, "skip, naughty" ); + return (DECLINED); + }; return (DECLINED) if $self->is_too_big( $transaction ); return (DECLINED) if $self->is_not_multipart( $transaction ); From e9b582e63c432c65a79f1af596b38c6bcf3fcdf8 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 19 Nov 2012 00:40:29 -0500 Subject: [PATCH 172/352] relay: better error handling and logging detect failures in calls to Net::IP for relayclient entries that don't parse. --- plugins/relay | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/plugins/relay b/plugins/relay index 84658cf..7cba450 100644 --- a/plugins/relay +++ b/plugins/relay @@ -149,7 +149,10 @@ sub populate_relayclients { sub is_in_cidr_block { my $self = shift; - my $ip = $self->qp->connection->remote_ip; + my $ip = $self->qp->connection->remote_ip or do { + $self->log(LOGINFO, "err, no remote_ip?"); + return; + }; my $cversion = ip_get_version($ip); for ( @{ $self->{_cidr_blocks} } ) { my ($network, $mask) = ip_splitprefix($_); # split IP & CIDR range @@ -157,7 +160,10 @@ sub is_in_cidr_block { 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); + my $bin_ip = ip_iptobin(ip_expand_address($ip, $cversion), $cversion) + or next; + + next if ! $begin || ! $end; # probably not a netmask entry if ( ip_bincomp($bin_ip, 'gt', ip_iptobin($begin, $rversion)) && ip_bincomp($bin_ip, 'lt', ip_iptobin($end, $rversion)) From 37cb63c6f75d020932919250faca5edaec25745a Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 19 Nov 2012 00:43:12 -0500 Subject: [PATCH 173/352] dspam: improve logging and config error reporting --- plugins/dspam | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/plugins/dspam b/plugins/dspam index 72aba48..9f36032 100644 --- a/plugins/dspam +++ b/plugins/dspam @@ -587,6 +587,15 @@ sub autolearn { defined $self->{_args}{autolearn} or return; + if ( $self->{_args}{autolearn} ne 'any' + && $self->{_args}{autolearn} ne 'karma' + && $self->{_args}{autolearn} ne 'naughty' + && $self->{_args}{autolearn} ne 'spamassassin' + ) { + $self->log(LOGERROR, "bad autolearn setting! Read 'perldoc plugins/dspam' again!"); + return; + }; + # only train once. $self->autolearn_naughty( $response, $transaction ) and return; $self->autolearn_karma( $response, $transaction ) and return; @@ -598,7 +607,10 @@ sub autolearn_naughty { my $learn = $self->{_args}{autolearn} or return; - return if ( $learn ne 'naughty' && $learn ne 'any' ); + if ( $learn ne 'naughty' && $learn ne 'any' ) { + $self->log(LOGINFO, "skipping naughty autolearn"); + return; + }; if ( $self->connection->notes('naughty') && $response->{result} eq 'Innocent' ) { $self->log(LOGINFO, "training naughty FN message as spam"); @@ -606,6 +618,7 @@ sub autolearn_naughty { return 1; }; + $self->log(LOGDEBUG, "falling through naughty autolearn"); return; }; From df577ff3febb66f53d0ddd59aa3c93e55da5b51a Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 19 Nov 2012 12:32:21 -0500 Subject: [PATCH 174/352] replace all instances of split '' with split // newer versions of perl don't accept split '' syntax any longer --- lib/Qpsmtpd/Address.pm | 4 ++-- lib/Qpsmtpd/Auth.pm | 4 ++-- lib/Qpsmtpd/PollServer.pm | 4 ++-- plugins/helo | 10 ++++++---- 4 files changed, 12 insertions(+), 10 deletions(-) diff --git a/lib/Qpsmtpd/Address.pm b/lib/Qpsmtpd/Address.pm index 50d008d..5800be2 100644 --- a/lib/Qpsmtpd/Address.pm +++ b/lib/Qpsmtpd/Address.pm @@ -342,8 +342,8 @@ sub _addr_cmp { } #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; + ($left = join( '=', reverse( split(/@/, $left->format))) ) =~ tr/[<>]//d; + ($right = join( '=', reverse( split(/@/,$right->format))) ) =~ tr/[<>]//d; if ( $swap ) { ($right, $left) = ($left, $right); diff --git a/lib/Qpsmtpd/Auth.pm b/lib/Qpsmtpd/Auth.pm index e55a30a..509069c 100644 --- a/lib/Qpsmtpd/Auth.pm +++ b/lib/Qpsmtpd/Auth.pm @@ -144,7 +144,7 @@ sub get_auth_details_cram_md5 { return; }; - my ( $user, $passHash ) = split( ' ', decode_base64($line) ); + my ( $user, $passHash ) = split( / /, decode_base64($line) ); unless ( $user && $passHash ) { $session->respond(504, "Invalid authentication string"); return; @@ -170,7 +170,7 @@ sub validate_password { my ( $self, %a ) = @_; my ($pkg, $file, $line) = caller(); - $file = (split '/', $file)[-1]; # strip off the path + $file = (split /\//, $file)[-1]; # strip off the path my $src_clear = $a{src_clear}; my $src_crypt = $a{src_crypt}; diff --git a/lib/Qpsmtpd/PollServer.pm b/lib/Qpsmtpd/PollServer.pm index 9d91af7..f987c3f 100644 --- a/lib/Qpsmtpd/PollServer.pm +++ b/lib/Qpsmtpd/PollServer.pm @@ -174,12 +174,12 @@ sub start_conversation { my $conn = $self->connection; # set remote_host, remote_ip and remote_port - my ($ip, $port) = split(':', $self->peer_addr_string); + 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); + my ($lip,$lport) = split(/:/, $self->local_addr_string); $conn->local_ip($lip); $conn->local_port($lport); diff --git a/plugins/helo b/plugins/helo index 29a3633..1692b4d 100644 --- a/plugins/helo +++ b/plugins/helo @@ -457,8 +457,8 @@ sub check_ip_match { return; }; - my $dns_net = join('.', (split('\.', $ip))[0,1,2] ); - my $rem_net = join('.', (split('\.', $self->qp->connection->remote_ip))[0,1,2] ); + 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" ); @@ -470,14 +470,16 @@ sub check_name_match { my $self = shift; my ($dns_name, $helo_name) = @_; + return if ! $dns_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] ); + 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" ); From 77182ec6e297c1824501eaa50744dcbfa1f9679d Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 19 Nov 2012 13:12:48 -0500 Subject: [PATCH 175/352] helo: avoid undef warning when rDNS is invalid specifically, when rDNS returns an invalid FQDN like 'null.', which doesn't have a domain part. --- plugins/helo | 1 + 1 file changed, 1 insertion(+) diff --git a/plugins/helo b/plugins/helo index 1692b4d..8e7d5a2 100644 --- a/plugins/helo +++ b/plugins/helo @@ -471,6 +471,7 @@ sub check_name_match { my ($dns_name, $helo_name) = @_; return if ! $dns_name; + return if split(/\./, $dns_name) < 2; # not a FQDN if ( $dns_name eq $helo_name ) { $self->log( LOGDEBUG, "reverse name match" ); From 4a745d6baf05151774458358b9064322d42e1bd7 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Tue, 20 Nov 2012 01:40:57 -0500 Subject: [PATCH 176/352] updated more split '' syntax to split // --- lib/Qpsmtpd.pm | 2 +- lib/Qpsmtpd/Postfix/pf2qp.pl | 2 +- log/summarize | 4 ++-- plugins/auth/auth_flat_file | 2 +- plugins/auth/auth_vpopmail | 2 +- plugins/auth/auth_vpopmail_sql | 2 +- plugins/dspam | 18 ++++++++++-------- plugins/hosts_allow | 2 +- plugins/rcpt_map | 2 +- 9 files changed, 19 insertions(+), 17 deletions(-) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index b7a9932..133a6a8 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -354,7 +354,7 @@ sub _load_plugin { my $self = shift; my ($plugin_line, @plugin_dirs) = @_; - my ($plugin, @args) = split ' ', $plugin_line; + my ($plugin, @args) = split / /, $plugin_line; my $package; diff --git a/lib/Qpsmtpd/Postfix/pf2qp.pl b/lib/Qpsmtpd/Postfix/pf2qp.pl index 0cd7894..3f8f55d 100755 --- a/lib/Qpsmtpd/Postfix/pf2qp.pl +++ b/lib/Qpsmtpd/Postfix/pf2qp.pl @@ -67,7 +67,7 @@ while () { next if /^_/; s#(/\*.*\*/)##; my $comment = $1 || ""; - my @words = split ' ', $_; + my @words = split / /, $_; my $const = shift @words; if ($const eq "CLEANUP_STAT_OK") { push @out, ""; diff --git a/log/summarize b/log/summarize index b203cca..b14dd3f 100755 --- a/log/summarize +++ b/log/summarize @@ -195,7 +195,7 @@ sub parse_line_plugin { my ($tai, $pid, $hook, $plugin, $message ) = split /\s/, $line, 5; $plugin =~ s/:$//; if ( $plugin =~ /_3a/ ) { - ($plugin) = split '_3a', $plugin; # trim :N off the plugin log entry + ($plugin) = split /_3a/, $plugin; # trim :N off the plugin log entry }; $plugin =~ s/_2d/-/g; @@ -320,7 +320,7 @@ sub populate_plugins_from_registry { next if ! $aliases; $aliases =~ s/\s+//g; $plugins{$name}{aliases} = $aliases; - foreach my $a ( split ',', $aliases ) { + foreach my $a ( split /,/, $aliases ) { $plugin_aliases{$a} = $name; }; }; diff --git a/plugins/auth/auth_flat_file b/plugins/auth/auth_flat_file index a17d051..2045009 100644 --- a/plugins/auth/auth_flat_file +++ b/plugins/auth/auth_flat_file @@ -53,7 +53,7 @@ sub auth_flat_file { return ( DENY, "authflat - missing password" ); } - my ( $pw_name, $pw_domain ) = split '@', lc($user); + my ( $pw_name, $pw_domain ) = split /@/, lc($user); unless ( defined $pw_domain ) { $self->log(LOGINFO, "fail: missing domain"); diff --git a/plugins/auth/auth_vpopmail b/plugins/auth/auth_vpopmail index 91a5ac6..e1dc423 100644 --- a/plugins/auth/auth_vpopmail +++ b/plugins/auth/auth_vpopmail @@ -61,7 +61,7 @@ sub auth_vpopmail { my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) = @_; - my $pw = vauth_getpw( split '@', lc($user) ); + my $pw = vauth_getpw( split /@/, lc($user) ); my $pw_clear_passwd = $pw->{pw_clear_passwd}; my $pw_passwd = $pw->{pw_passwd}; diff --git a/plugins/auth/auth_vpopmail_sql b/plugins/auth/auth_vpopmail_sql index dd9b3cb..90f08e8 100644 --- a/plugins/auth/auth_vpopmail_sql +++ b/plugins/auth/auth_vpopmail_sql @@ -104,7 +104,7 @@ sub get_db_handle { sub get_vpopmail_user { my ( $self, $dbh, $user ) = @_; - my ( $pw_name, $pw_domain ) = split '@', lc($user); + my ( $pw_name, $pw_domain ) = split /@/, lc($user); if ( ! defined $pw_domain ) { $self->log(LOGINFO, "skip: missing domain: " . lc $user ); diff --git a/plugins/dspam b/plugins/dspam index 9f36032..6812451 100644 --- a/plugins/dspam +++ b/plugins/dspam @@ -260,7 +260,7 @@ sub select_username { $self->log(LOGDEBUG, "Message has $recipient_count recipients"); if ( $recipient_count > 1 ) { - $self->log(LOGINFO, "skipping user prefs, $recipient_count recipients detected."); + $self->log(LOGINFO, "multiple recipients ($recipient_count), ignoring user prefs"); return getpwuid($>); }; @@ -296,13 +296,13 @@ sub parse_response { #return $self->parse_response_regexp( $response ); # probably slower - my ($user, $result, $class, $prob, $conf, $sig) = split '; ', $response; + my ($user, $result, $class, $prob, $conf, $sig) = split /; /, $response; - (undef, $result) = split '=', $result; - (undef, $class ) = split '=', $class; - (undef, $prob ) = split '=', $prob; - (undef, $conf ) = split '=', $conf; - (undef, $sig ) = split '=', $sig; + (undef, $result) = split /=/, $result; + (undef, $class ) = split /=/, $class; + (undef, $prob ) = split /=/, $prob; + (undef, $conf ) = split /=/, $conf; + (undef, $sig ) = split /=/, $sig; $result = substr($result, 1, -1); # strip off quotes $class = substr($class, 1, -1); @@ -656,7 +656,9 @@ sub autolearn_spamassassin { my $sa = $transaction->notes('spamassassin' ); if ( ! $sa || ! $sa->{is_spam} ) { - $self->log(LOGERROR, "SA results missing"); + if ( ! $self->connection->notes('naughty') ) { + $self->log(LOGERROR, "SA results missing"); # SA skips naughty + }; return; }; diff --git a/plugins/hosts_allow b/plugins/hosts_allow index 550504c..6661ec1 100644 --- a/plugins/hosts_allow +++ b/plugins/hosts_allow @@ -98,7 +98,7 @@ sub in_hosts_allow { my ($ipmask, $const, $message) = split /\s+/, $_, 3; next unless defined $const; - my ($net,$mask) = split '/', $ipmask, 2; + 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) { diff --git a/plugins/rcpt_map b/plugins/rcpt_map index 32c0a3b..e18d168 100644 --- a/plugins/rcpt_map +++ b/plugins/rcpt_map @@ -153,7 +153,7 @@ sub read_map { s/^\s*//; next if /^#/; next unless $_; - my ($addr, $code, $msg) = split ' ', $_, 3; + my ($addr, $code, $msg) = split / /, $_, 3; next unless $addr; unless ($code) { From aaaf69de5c78e0de94595fbb70fc19b8108054d6 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Tue, 20 Nov 2012 03:31:25 -0500 Subject: [PATCH 177/352] log/summarize: improve formatting so vertical columns are consistent, regardless of when the connection is ended. --- log/summarize | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/log/summarize b/log/summarize index b14dd3f..acf3c94 100755 --- a/log/summarize +++ b/log/summarize @@ -80,6 +80,7 @@ while ( defined (my $line = $fh->read) ) { next if $type ne 'connect'; # ignore unless connect my ($host, $ip) = split /\s/, $message; $ip = substr $ip, 1, -1; + foreach ( keys %seen_plugins, qw/ helo_host from to / ) { $pids{$pid}{$_} = ''; }; $pids{$pid}{ip} = $ip; $pids{$pid}{hostname} = $host if $host ne 'Unknown'; }; @@ -231,11 +232,11 @@ sub print_auto_format { $seen_plugins{$plugin}++; }; - next if ! $seen_plugins{$plugin}; # hide plugins not used + next if ! $seen_plugins{$plugin}; # hide unused plugins if ( $hide_plugins{$plugin} ) { # user doesn't want to see delete $pids{$pid}{$plugin}; next; - }; + }; if ( defined $pids{$pid}{helo_host} && $plugin =~ /helo/ ) { $format .= " %-18.18s"; From 5758412c530eb9f08f4cd8455e70ea9982b767fc Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Tue, 20 Nov 2012 03:33:08 -0500 Subject: [PATCH 178/352] v0.91 bump for release --- Changes | 70 +++++++++++++++++++++++++++++++++++++++++++++++--- MANIFEST | 1 + lib/Qpsmtpd.pm | 2 +- 3 files changed, 69 insertions(+), 4 deletions(-) diff --git a/Changes b/Changes index be8d88f..d77e22f 100644 --- a/Changes +++ b/Changes @@ -1,6 +1,70 @@ -Next Version +0.91 Nov 20, 2012 + a handful of minor changes to log messages, similar to v0.90 + + replace all instances of split '' with split // (required for 5.1?+) + + clamdscan: skip processing of naughty messages + + TcpServer: improved IPv6 support (Michael Holzt) + + SPF: improved support for IPv6, removed is_in_relayclient in favor + of checking if relayclient() note is set. + + spamassassin: added 'headers none' option + + qmail_deliverable: added vpopmail extension support, reject null + senders to ezmlm mailing lists. + + dnsbl rejections handled by naughty plugin + + changed default loglevel from 9 to 6 + + allow messages with no body: (Robin's patch) + + ordered config.sample/plugins roughly in SMTP phase order + + added Plugins::adjust_karma, reduces code requirements in other plugins + + added whitelist plugin + + helo: added is_plain_ip to lenient checks + + dspam improvements + + added log2sql, log/watch.pl, log/summarize.pl, and plugins/registry.txt + + new dkim plugin added (deprecates domainkeys plugin). + +0.90 Jun 27, 2012 + + Many logging adjustments for plugins, to achieve the goal of emitting + a single message per plugin that provides a summary of that plugins + action(s) and/or outcome(s). + + qmail_deliverable plugin added (depends on Qmail::Deliverable). + + karma plugin added. + + naughty plugin added. + + count_unrecognized_commands: corrected variable assignment error + + connection_time: added tcpserver deployment compatibility + + loop: max_hops was sometimes unset + + dnsbl,rhsbl: process DNS queries syncronously to improve overall efficiency + + insert headers at top of message (consistent SMTP behavior) in uribl + domainkeys, spamassassin plugins. + + spamassassin: consolidated two data_post methods (more linear, simpler) + + rewrote check_basicheaders -> headers + + renamed check_loop -> loop renamed check_badrcptto -> badrcptto renamed check_badmailfromto -> badmailfromto renamed check_badmailfrom -> badmailfrom @@ -27,7 +91,7 @@ Next Version new plugin check_bogus_bounce (Steve Kemp) - clamav: added ClamAV version to the X-Virus-Checked header, + 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) @@ -49,7 +113,7 @@ Next Version Note Net::IP dependency (Larry Nedry) - Various minor spelling cleanups and such (Steve Kemp, Devin Carraway) + 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) diff --git a/MANIFEST b/MANIFEST index 7c46ef1..8c60bdf 100644 --- a/MANIFEST +++ b/MANIFEST @@ -185,6 +185,7 @@ t/plugin_tests/badrcptto t/plugin_tests/count_unrecognized_commands t/plugin_tests/dnsbl t/plugin_tests/dspam +t/plugin_tests/earlytalker t/plugin_tests/greylisting t/plugin_tests/headers t/plugin_tests/helo diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index 133a6a8..6d7bc12 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -7,7 +7,7 @@ use Qpsmtpd::Constants; #use DashProfiler; -$VERSION = "0.90"; +$VERSION = "0.91"; my $git; From d06eac3dc145c225c49709979b5e8c5462a44be6 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 12 Dec 2012 14:07:19 -0500 Subject: [PATCH 179/352] uribl plugin: added 'pass' prefix to log message --- plugins/uribl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/uribl b/plugins/uribl index b63a4c9..25ee88d 100644 --- a/plugins/uribl +++ b/plugins/uribl @@ -486,7 +486,7 @@ sub data_handler { }); unless ($queries) { - $self->log(LOGINFO, "No URIs found in mail"); + $self->log(LOGINFO, "pass, No URIs found in mail"); return DECLINED; } From 2661e083a3ff046f2bc33cf00bfd0a4cd6906fd2 Mon Sep 17 00:00:00 2001 From: Markus Ullmann Date: Mon, 11 Mar 2013 03:33:42 +0100 Subject: [PATCH 180/352] Update qpsmtpd-forkserver MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Drop block as it breaks with Net::DNS and should be safe according to http://www.nntp.perl.org/group/perl.qpsmtpd/2012/12/msg9980.html --- qpsmtpd-forkserver | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/qpsmtpd-forkserver b/qpsmtpd-forkserver index 84000f3..2e33618 100755 --- a/qpsmtpd-forkserver +++ b/qpsmtpd-forkserver @@ -277,13 +277,7 @@ while (1) { 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; From 22d16037a238c9151e39f8d5408aeec79e58937b Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sun, 10 Mar 2013 23:22:44 -0400 Subject: [PATCH 181/352] plugins/helo: added RFC 5321 notes --- plugins/helo | 23 ++++++++++++++++++++--- 1 file changed, 20 insertions(+), 3 deletions(-) diff --git a/plugins/helo b/plugins/helo index 8e7d5a2..ef06dcc 100644 --- a/plugins/helo +++ b/plugins/helo @@ -75,6 +75,9 @@ 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. +Per RFC 5321 section 4.1.4, it is impermissible to block a message I +on the basis of the HELO hostname not matching the senders IP. + 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 @@ -121,10 +124,10 @@ address literal. When I is selected, all the lenient checks and the following are enforced: 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 settings I and using the B +I without setting I and using the B plugin. Windows PCs often send unqualified HELO names and will have trouble -sending mail. The B plugin defers the rejection, and if the user -subsequently authenticates, the rejection is be cancelled. +sending mail. The B plugin defers the rejection, giving the user +the opportunity to authenticate and bypass the rejection. =head3 strict @@ -187,6 +190,20 @@ that is not in FQDN form is no more than a local alias. Local aliases MUST NOT appear in any SMTP transaction. +=head1 RFC 5321 + +=head2 4.1.4 + +An SMTP server MAY verify that the domain name argument in the EHLO +command actually corresponds to the IP address of the client. +However, if the verification fails, the server MUST NOT refuse to +accept a message on that basis. Information captured in the +verification attempt is for logging and tracing purposes. Note that +this prohibition applies to the matching of the parameter to its IP +address only; see Section 7.9 for a more extensive discussion of +rejecting incoming connections or mail messages. + + =head1 AUTHOR 2012 - Matt Simerson From c31074bef6f4d209ab228eb93583f7466f478289 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sun, 10 Mar 2013 23:38:03 -0400 Subject: [PATCH 182/352] plugins/bogus_bounce: add Return-Path check make sure return path is empty, per RFC 3834 --- plugins/bogus_bounce | 47 ++++++++++++++++---------------------------- 1 file changed, 17 insertions(+), 30 deletions(-) diff --git a/plugins/bogus_bounce b/plugins/bogus_bounce index 2a97472..79863a0 100644 --- a/plugins/bogus_bounce +++ b/plugins/bogus_bounce @@ -36,16 +36,11 @@ Deny with a soft error code. 2010 - Steve Kemp - http://steve.org.uk/Software/qpsmtpd/ -=cut - -=begin doc - -Look for our single expected argument and configure "action" appropriately. - -=end doc +2013 - Matt Simerson - added Return Path check =cut + sub register { my ($self, $qp) = (shift, shift); @@ -66,21 +61,11 @@ sub register { } } -=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. + # Find the sender, quit processing if this isn't a bounce. # my $sender = $transaction->sender->address || undef; if ( $sender && $sender ne '<>') { @@ -88,22 +73,24 @@ sub hook_data_post { return DECLINED; }; + # at this point we know it is a bounce, via the null-envelope. # - # Get the recipients. + # Count the recipients. Valid bounces have a single recipient # my @to = $transaction->recipients || (); - if (scalar @to == 1) { - $self->log(LOGINFO, "pass, only 1 recipient"); - return DECLINED; + if (scalar @to != 1) { + $self->log(LOGINFO, "fail, bogus bounce to: " . join(',', @to)); + return $self->get_reject( "fail, this bounce message does not have 1 recipient" ); }; - # - # 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. - # - $self->log(LOGINFO, "fail, bogus bounce for :" . join(',', @to)); + # validate that Return-Path is empty, RFC 3834 - $self->get_reject( "fail, this is a bogus bounce" ); + my $rp = $transaction->header->get('Return-Path'); + if ( $rp && $rp ne '<>' ) { + $self->log(LOGINFO, "fail, bounce messages must not have a Return-Path"); + return $self->get_reject( "a bounce return path must be empty (RFC 3834)" ); + }; + + $self->log(LOGINFO, "pass, single recipient, empty Return-Path"); + return DECLINED; } From 0a6f23d06dc6d7c43844ef5bf53c3c4884b03d02 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 11 Mar 2013 00:14:38 -0400 Subject: [PATCH 183/352] p0f: added path to socket in error message if p0f cannot connect, provide a more descriptive error message. Particularly useful for a p0f plugin developer that runs both p0f v2 and v3 at the same time. --- plugins/ident/p0f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/ident/p0f b/plugins/ident/p0f index 06c2da4..0493e77 100644 --- a/plugins/ident/p0f +++ b/plugins/ident/p0f @@ -256,7 +256,7 @@ sub query_p0f_v2 { socket(SOCK, PF_UNIX, SOCK_STREAM, 0) or $self->log(LOGERROR, "socket: $!"), return; connect(SOCK, sockaddr_un($p0f_socket)) - or $self->log(LOGERROR, "connect: $!"), return; + or $self->log(LOGERROR, "connect: $! ($p0f_socket)"), return; defined syswrite SOCK, $query or $self->log(LOGERROR, "write: $!"), close SOCK, return; From b37a0462aeaa9646be687da730099db06d61e82d Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 11 Mar 2013 00:24:11 -0400 Subject: [PATCH 184/352] karma_tool: release didn't. fixed. also, preserve karma history when using karma_tool to capture/release --- plugins/karma_tool | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/plugins/karma_tool b/plugins/karma_tool index eb3d921..bc841ee 100755 --- a/plugins/karma_tool +++ b/plugins/karma_tool @@ -21,7 +21,7 @@ elsif ( $command eq 'capture' ) { $self->capture( $ARGV[1] ); } elsif ( $command eq 'release' ) { - $self->capture( $ARGV[1] ); + $self->release( $ARGV[1] ); } elsif ( $command eq 'prune' ) { $self->prune_db( $ARGV[1] || 7 ); @@ -67,7 +67,9 @@ sub capture { my $tied = $self->get_db_tie( $db, $lock ) or return; my $key = $self->get_db_key( $ip ); - $tied->{$key} = join(':', time, 1, 0, 1); + my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/, $tied->{$key}; + + $tied->{$key} = join(':', time, $naughty+1, $nice, $connects); return $self->cleanup_and_return( $tied, $lock ); }; @@ -84,7 +86,9 @@ sub release { my $tied = $self->get_db_tie( $db, $lock ) or return; my $key = $self->get_db_key( $ip ); - $tied->{$key} = join(':', 0, 1, 0, 1); + my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/, $tied->{$key}; + + $tied->{$key} = join(':', 0, 0, $nice, $connects); return $self->cleanup_and_return( $tied, $lock ); }; @@ -124,7 +128,7 @@ sub main { }; my $hostname = ''; if ( $naughty && $nice ) { - $hostname = `dig +short -x $ip`; chomp $hostname; + #$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; From 30b7662a6386f6cdf442342bb0638cd0d1508807 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 11 Mar 2013 00:25:28 -0400 Subject: [PATCH 185/352] qmail_deliverable: remove fail prefix from SMTP er prefix should only be logged, not emitted during SMTP --- plugins/qmail_deliverable | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/qmail_deliverable b/plugins/qmail_deliverable index 58e8288..91f6813 100755 --- a/plugins/qmail_deliverable +++ b/plugins/qmail_deliverable @@ -182,7 +182,7 @@ sub rcpt_handler { $self->log(LOGINFO, "pass, bouncesaying with program"), $k++ if $rv == 0x13; if ( $rv == 0x14 ) { my $s = $transaction->sender->address; - return (DENY, "fail, mailing lists do not accept null senders") + return (DENY, "mailing lists do not accept null senders") if ( ! $s || $s eq '<>'); $self->log(LOGINFO, "pass, ezmlm list"); $k++; }; From a0212347bf2e6bca31007b81c7910af7c3e9fd7b Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 13 Mar 2013 02:02:41 -0400 Subject: [PATCH 186/352] whitelist: added pass prefix to log entries --- plugins/whitelist | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/whitelist b/plugins/whitelist index 43aace4..549dea1 100644 --- a/plugins/whitelist +++ b/plugins/whitelist @@ -138,7 +138,7 @@ sub check_host { # From tcpserver if (exists $ENV{WHITELISTCLIENT}) { $self->qp->connection->notes('whitelistclient', 1); - $self->log(2, "host $ip is a whitelisted client"); + $self->log(2, "pass, host $ip is a whitelisted client"); return OK; } @@ -146,7 +146,7 @@ sub check_host { for my $h ($self->qp->config('whitelisthosts', $config_arg)) { if ($h eq $ip or $ip =~ /^\Q$h\E/) { $self->qp->connection->notes('whitelisthost', 1); - $self->log(2, "host $ip is a whitelisted host"); + $self->log(2, "pass, host $ip is a whitelisted host"); return OK; } } From 548415ea244fd2d8f5f6a151f9d3b2600b0a6dba Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 13 Mar 2013 02:26:25 -0400 Subject: [PATCH 187/352] headers: added section # to RFC citation --- plugins/headers | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/headers b/plugins/headers index ae7accb..959be55 100644 --- a/plugins/headers +++ b/plugins/headers @@ -126,7 +126,7 @@ sub hook_data_post { }; my $header = $transaction->header or do { - return $self->get_reject( "missing headers", "missing headers" ); + return $self->get_reject( "Headers are missing", "missing headers" ); }; return (DECLINED, "immune") if $self->is_immune(); @@ -140,7 +140,7 @@ sub hook_data_post { 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"); + return $self->get_reject("Only one $h header allowed. See RFC 5322, Section 3.6", "too many $h headers"); }; my $err_msg = $self->invalid_date_range(); From 57a2f68564f598e4044c42fadcf6553decc27a21 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 13 Mar 2013 03:19:48 -0400 Subject: [PATCH 188/352] karma: general improvements skip earlytalker checks for positive senders limit negative karma senders to 1 concurrent connection (hosts_allow) added karma::hook_pre_connection, to make hosts_allow change possible added karma score to log entries --- plugins/earlytalker | 3 ++ plugins/hosts_allow | 11 +++++++ plugins/karma | 70 +++++++++++++++++++++++++++-------------- plugins/virus/clamdscan | 5 +-- 4 files changed, 61 insertions(+), 28 deletions(-) diff --git a/plugins/earlytalker b/plugins/earlytalker index bcbad95..cb31010 100644 --- a/plugins/earlytalker +++ b/plugins/earlytalker @@ -163,6 +163,9 @@ sub connect_handler { return DECLINED unless $self->{_args}{'check-at'}{CONNECT}; return DECLINED if $self->is_immune(); + my $karma = $self->connection->notes('karma_history'); + return DECLINED if (defined $karma && $karma > 5); + $in->add(\*STDIN) or return DECLINED; if (! $in->can_read($self->{_args}{'wait'})) { return $self->log_and_pass(); diff --git a/plugins/hosts_allow b/plugins/hosts_allow index 6661ec1..d226578 100644 --- a/plugins/hosts_allow +++ b/plugins/hosts_allow @@ -68,6 +68,7 @@ sub hook_pre_connection { my $remote = $args{remote_ip}; my $max = $args{max_conn_ip}; + my $karma = $self->connection->notes('karma_history'); if ( $max ) { my $num_conn = 1; # seed with current value @@ -75,6 +76,7 @@ sub hook_pre_connection { foreach my $rip (@{$args{child_addrs}}) { ++$num_conn if (defined $rip && $rip eq $raddr); } + $max = $self->karma_bump( $karma, $max ) if defined $karma; if ($num_conn > $max ) { my $err_mess = "too many connections from $remote"; $self->log(LOGINFO, "fail: $err_mess ($num_conn > $max)"); @@ -113,3 +115,12 @@ sub in_hosts_allow { return; }; + +sub karma_bump { + my ($self, $karma, $max) = @_; + if ( $karma <= 0 ) { + $self->log(LOGINFO, "limiting max connects to 1 for negative karma ($karma)"); + return 1; + }; + return $max; +}; diff --git a/plugins/karma b/plugins/karma index b5a3a33..723d17c 100644 --- a/plugins/karma +++ b/plugins/karma @@ -6,7 +6,7 @@ karma - reward nice and penalize naughty mail senders =head1 SYNOPSIS -Karma tracks sender history, providing the ability to deliver differing levels +Karma tracks sender history, allowing us to provide differing levels of service to naughty, nice, and unknown senders. =head1 DESCRIPTION @@ -14,7 +14,7 @@ of service to naughty, nice, and unknown senders. 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. +from senders in the penalty box are rejected per the settings in I. Karma provides other plugins with a karma value they can use to be more lenient, strict, or skip processing entirely. @@ -24,10 +24,9 @@ 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, well behaved sender. Please help yourself to greater concurrency, multiple recipients, no delays, and other privileges. -Hi there, naughty sender. Enjoy this poke in the eye with a sharp stick. Bye. +Hi there, naughty sender. You get a max concurrency of 1, and SMTP delays. =back @@ -114,13 +113,7 @@ run before B for that to work. 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 - }; +karma and lower it for bad karma. See B. 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 @@ -133,7 +126,7 @@ an example connection from an IP in the penalty box: 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 550 You were naughty. You are cannot connect for 0.99 more days. 73122 click, disconnecting 73122 (post-connection) connection_time: 1.048 s. @@ -211,12 +204,11 @@ karma_tool 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. +This plugin is reactionary. Like the FBI, it doesn't do anything until +after a crime has been committed. 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 +blacklists, send to invalid users, earlytalkers, etc. Those already have very lightweight tests. =head1 AUTHOR @@ -255,6 +247,32 @@ sub register { $self->register_hook('disconnect', 'disconnect_handler'); } +sub hook_pre_connection { + my ($self,$transaction,%args) = @_; + + $self->connection->notes('karma_history', 0); + + my $remote_ip = $args{remote_ip}; + #my $max_conn = $args{max_conn_ip}; + + 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( $remote_ip ) or do { + $self->log( LOGINFO, "skip, unable to get DB key" ); + return DECLINED; + }; + + 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} ); + $self->calc_karma($naughty, $nice); + return $self->cleanup_and_return($tied, $lock ); +}; + sub connect_handler { my $self = shift; @@ -294,7 +312,7 @@ sub connect_handler { $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."; + my $mess = "You were naughty. You cannot connect for $left more days."; return $self->get_reject( $mess, $karma ); } @@ -313,11 +331,11 @@ sub disconnect_handler { my $key = $self->get_db_key(); my ($penalty_start_ts, $naughty, $nice, $connects) = $self->parse_value( $tied->{$key} ); + my $history = ($nice || 0) - $naughty; if ( $karma < 0 ) { - $naughty++; + $history--; 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!"); @@ -326,15 +344,15 @@ sub disconnect_handler { else { $penalty_start_ts = sprintf "%s", time; }; - $self->log(LOGINFO, "negative, sent to penalty box ($history)"); + $self->log(LOGINFO, "negative, sent to penalty box (k: $karma, h: $history)"); } else { - $self->log(LOGINFO, "negative"); + $self->log(LOGINFO, "negative (k: $karma, h: $history)"); }; } elsif ($karma > 1) { $nice++; - $self->log(LOGINFO, "positive"); + $self->log(LOGINFO, "positive (k: $karma, h: $history)"); } $tied->{$key} = join(':', $penalty_start_ts, $naughty, $nice, ++$connects); @@ -375,7 +393,11 @@ sub cleanup_and_return { sub get_db_key { my $self = shift; - my $nip = Net::IP->new( $self->qp->connection->remote_ip ) or return; + my $ip = shift || $self->qp->connection->remote_ip; + my $nip = Net::IP->new( $ip ) or do { + $self->log(LOGERROR, "skip, unable to determine remote IP"); + return; + }; return $nip->intip; # convert IP to an int }; diff --git a/plugins/virus/clamdscan b/plugins/virus/clamdscan index ab35ab0..4148bd8 100644 --- a/plugins/virus/clamdscan +++ b/plugins/virus/clamdscan @@ -168,10 +168,7 @@ sub data_post_handler { $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)); - }; + $self->adjust_karma( -1 ); if ( $self->{_args}{deny_viruses} ) { return ( DENY, "Virus found: $found" ); From 537af7c095ae5317eff73adc70936a2168698957 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 15 Mar 2013 22:12:50 -0700 Subject: [PATCH 189/352] dspam: added use lib, removed some parens --- plugins/dspam | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/plugins/dspam b/plugins/dspam index 6812451..7cef1f7 100644 --- a/plugins/dspam +++ b/plugins/dspam @@ -200,6 +200,8 @@ ie, (Trust smtpd). use strict; use warnings; +use lib 'lib'; + use Qpsmtpd::Constants; use Qpsmtpd::DSN; use IO::Handle; @@ -279,7 +281,7 @@ sub assemble_message { $transaction->body_resetpos; while (my $line = $transaction->body_getline) { $message .= $line; }; - $message = join(CRLF, split/\n/, $message); + $message = join(CRLF, split /\n/, $message); return $message . CRLF; }; @@ -517,11 +519,11 @@ sub get_dspam_results { return; }; - my @bits = split(/,\s+/, $string); chomp @bits; + my @bits = split /,\s+/, $string; chomp @bits; my $class = shift @bits; my %d; foreach (@bits) { - my ($key,$val) = split(/=/, $_); + my ($key,$val) = split /=/, $_; $d{$key} = $val; }; $d{class} = $class; From a1086298f569750f28726487f9008a3cf36f43d8 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 15 Mar 2013 22:16:06 -0700 Subject: [PATCH 190/352] helo: added comments --- plugins/helo | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/plugins/helo b/plugins/helo index ef06dcc..aace329 100644 --- a/plugins/helo +++ b/plugins/helo @@ -368,6 +368,7 @@ sub is_forged_literal { my ( $self, $host ) = @_; return if $host !~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/; +# should we add exceptions for reserved internal IP space? (192.168,10., etc?) $host = substr $host, 1, -1; return if $host eq $self->qp->connection->remote_ip; return ("Forged IPs not accepted here", "forged IP literal"); @@ -444,6 +445,9 @@ sub no_reverse_dns { sub no_matching_dns { my ( $self, $host ) = @_; +# this is called iprev, or "Forward-confirmed reverse DNS" and is discussed in RFC 5451 +# consider adding header: Authentication-Results + if ( $self->connection->notes('helo_forward_match') && $self->connection->notes('helo_reverse_match') ) { $self->log( LOGDEBUG, "foward and reverse match" ); From f198157e92709961122f8689b64eb13e036dcfc0 Mon Sep 17 00:00:00 2001 From: Markus Ullmann Date: Wed, 20 Mar 2013 01:16:09 +0100 Subject: [PATCH 191/352] Sanitize spamd_sock path for perl taint mode --- plugins/spamassassin | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/plugins/spamassassin b/plugins/spamassassin index 082f44d..be5c2ef 100644 --- a/plugins/spamassassin +++ b/plugins/spamassassin @@ -314,6 +314,10 @@ sub connect_to_spamd_socket { return; }; + # Sanitize for use with taint mode + $socket =~ /^([\w\/.-]+)$/; + $socket = $1; + socket(my $SPAMD, PF_UNIX, SOCK_STREAM, 0) or do { $self->log(LOGERROR, "Could not open socket: $!"); return; From 5f9aed1162aef9570a8e29fa87e9cfc899d8f3a2 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Mar 2013 00:51:00 -0400 Subject: [PATCH 192/352] adjust_karma now increments properly --- lib/Qpsmtpd/Plugin.pm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm index 3bb4b73..6d8e1c1 100644 --- a/lib/Qpsmtpd/Plugin.pm +++ b/lib/Qpsmtpd/Plugin.pm @@ -287,7 +287,8 @@ sub adjust_karma { my $karma = $self->connection->notes('karma') || 0; $karma += $value; - $self->connection->notes('karma', $value); + $self->log(LOGDEBUG, "karma adjust: $value ($karma)"); + $self->connection->notes('karma', $karma); return $value; }; From 170fdc93f8f605eb6f85668f78e00486d58a70d5 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Mar 2013 00:52:06 -0400 Subject: [PATCH 193/352] log/watch: raise default # of log lines to parse --- log/watch | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/log/watch b/log/watch index 0514a3d..427f58f 100755 --- a/log/watch +++ b/log/watch @@ -9,7 +9,7 @@ use File::Tail; my $dir = get_qp_dir() or die "unable to find QP home dir"; my $file = "$dir/log/main/current"; -my $fh = File::Tail->new(name=>$file, interval=>1, maxinterval=>1, debug =>1, tail =>100 ); +my $fh = File::Tail->new(name=>$file, interval=>1, maxinterval=>1, debug =>1, tail =>300 ); while ( defined (my $line = $fh->read) ) { my (undef, $line) = split /\s/, $line, 2; # strip off tai timestamps From 03641b32aea5e1e793d044a919de42e44b513f19 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Mar 2013 00:54:16 -0400 Subject: [PATCH 194/352] logs: suppress perl errors in summary output --- log/summarize | 1 + 1 file changed, 1 insertion(+) diff --git a/log/summarize b/log/summarize index acf3c94..2956221 100755 --- a/log/summarize +++ b/log/summarize @@ -182,6 +182,7 @@ sub parse_line { return ( 'info', $pid, undef, undef, $message ) if substr($message, 0, 24) eq 'Permissions on spool_dir'; return ( 'info', $pid, undef, undef, $message ) if substr($message, 0, 13) eq 'Listening on '; + return ( 'err', $pid, undef, undef, $message ) if $line =~ /at [\S]+ line \d/; # generic perl error print "UNKNOWN LINE: $line\n"; return ( 'unknown', $pid, undef, undef, $message ); }; From 7b804c70c93a5f1696df1ecc2cd5480c0c2f4ff8 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Mar 2013 01:01:13 -0400 Subject: [PATCH 195/352] karma_tool: optimized for speedy IP search, IPv6 fixed one IPv6 issue --- plugins/karma_tool | 35 ++++++++++++++++++++++++++++------- 1 file changed, 28 insertions(+), 7 deletions(-) diff --git a/plugins/karma_tool b/plugins/karma_tool index bc841ee..627725c 100755 --- a/plugins/karma_tool +++ b/plugins/karma_tool @@ -26,6 +26,9 @@ elsif ( $command eq 'release' ) { elsif ( $command eq 'prune' ) { $self->prune_db( $ARGV[1] || 7 ); } +elsif ( $command eq 'search' && is_ip( $ARGV[1] ) ) { + $self->show_ip( $ARGV[1] ); +} elsif ( $command eq 'list' | $command eq 'search' ) { $self->main(); }; @@ -76,10 +79,7 @@ sub capture { sub release { my $self = shift; my $ip = shift or return; - is_ip( $ip ) or do { - warn "not an IP: $ip\n"; - 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; @@ -92,6 +92,27 @@ sub release { return $self->cleanup_and_return( $tied, $lock ); }; +sub show_ip { + my $self = shift; + my $ip = shift or 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 ); + + my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/, $tied->{$key}; + $naughty ||= 0; + $nice ||= 0; + $connects ||= 0; + my $time_human = ''; + if ( $penalty_start_ts ) { + $time_human = strftime "%a %b %e %H:%M", localtime $penalty_start_ts; + }; + my $hostname = `dig +short -x $ip` || ''; chomp $hostname; + print " IP Address Penalty Naughty Nice Connects Hostname\n"; + printf(" %-18s %24s %3s %3s %3s %-30s\n", $ip, $time_human, $naughty, $nice, $connects, $hostname); +}; + sub main { my $self = shift; @@ -140,8 +161,8 @@ sub main { sub is_ip { my $ip = shift || $ARGV[0]; - return 1 if $ip =~ /^(\d{1,3}\.){3}\d{1,3}$/; - return; + new Net::IP( $ip ) or return; + return 1; }; sub cleanup_and_return { @@ -152,7 +173,7 @@ sub cleanup_and_return { sub get_db_key { my $self = shift; - my $nip = Net::IP->new( shift ); + my $nip = Net::IP->new( shift ) or return; return $nip->intip; # convert IP to an int }; From 79a5c3d7ae3365ac6e6bec0d948115968e990e19 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Mar 2013 01:03:28 -0400 Subject: [PATCH 196/352] geoip: added too_far option --- plugins/ident/geoip | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/plugins/ident/geoip b/plugins/ident/geoip index 2f6b635..9964457 100644 --- a/plugins/ident/geoip +++ b/plugins/ident/geoip @@ -58,6 +58,12 @@ IP of your mail server. Default: none. (no distance calculations) +=head2 too_far + +Assign negative karma to connections further than this many km. + +Default: none + =head2 db_dir The path to the GeoIP database directory. @@ -159,7 +165,12 @@ sub connect_handler { push @msg_parts, $c_code if $c_code; #push @msg_parts, $c_name if $c_name; push @msg_parts, $city if $city; - push @msg_parts, "\t$distance km" if $distance; + if ( $distance ) { + push @msg_parts, "\t$distance km"; + if ( $self->{_args}{too_far} && $distance > $self->{_args}{too_far} ) { + $self->adjust_karma( -1 ); + }; + }; $self->log(LOGINFO, join( ", ", @msg_parts) ); return DECLINED; From 3b71f066824b8b064c8625d06c609540a568c088 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Mar 2013 01:04:03 -0400 Subject: [PATCH 197/352] badrcptto: smite matches with -2 karma useful for (reject=>naughty) + spam filter training --- plugins/badrcptto | 1 + 1 file changed, 1 insertion(+) diff --git a/plugins/badrcptto b/plugins/badrcptto index 8787974..3d15776 100644 --- a/plugins/badrcptto +++ b/plugins/badrcptto @@ -64,6 +64,7 @@ sub hook_rcpt { my ($bad, $reason) = split /\s+/, $line, 2; next if ! $bad; if ( $self->is_match( $to, lc($bad), $host ) ) { + $self->adjust_karma( -2 ); if ( $reason ) { return (DENY, "mail to $bad not accepted here"); } From d427f43f54a02b851346e4c5c096f0f3cf6019ee Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Mar 2013 01:05:15 -0400 Subject: [PATCH 198/352] dnsbl: smite blacklisted IPs with -1 karma --- plugins/dnsbl | 2 ++ 1 file changed, 2 insertions(+) diff --git a/plugins/dnsbl b/plugins/dnsbl index 7c869ee..4a055fc 100644 --- a/plugins/dnsbl +++ b/plugins/dnsbl @@ -191,6 +191,8 @@ sub hook_connect { next if ! $result; + $self->adjust_karma( -1 ); + if ( ! $dnsbl ) { ($dnsbl) = ($result =~ m/(?:\d+\.){4}(.*)/); }; if ( ! $dnsbl ) { $dnsbl = $result; }; From d37f875992112f673f09afc716cdac1f8a89473e Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Mar 2013 01:07:01 -0400 Subject: [PATCH 199/352] dspam: be more conservative with karma awards previous settings were reasonable for a well trained dspam. After starting with a fresh dspam, the settings were not optimal for the amount of naive that a default dspam is. --- plugins/dspam | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/plugins/dspam b/plugins/dspam index 6812451..9d8ec43 100644 --- a/plugins/dspam +++ b/plugins/dspam @@ -491,7 +491,7 @@ sub reject_agree { if ( $d->{class} eq 'Innocent' ) { if ( $sa->{is_spam} eq 'No' ) { if ( $d->{confidence} > .9 ) { - $self->adjust_karma( 2 ); + $self->adjust_karma( 1 ); }; $self->log(LOGINFO, "pass, agree, $status"); return DECLINED; @@ -632,14 +632,14 @@ sub autolearn_karma { my $karma = $self->connection->notes('karma'); return if ! defined $karma; - if ( $karma <= -1 && $response->{result} eq 'Innocent' ) { - $self->log(LOGINFO, "training bad karma FN as spam"); + if ( $karma < -1 && $response->{result} eq 'Innocent' ) { + $self->log(LOGINFO, "training bad karma ($karma) FN as spam"); $self->train_error_as_spam( $transaction ); return 1; }; - if ( $karma >= 1 && $response->{result} eq 'Spam' ) { - $self->log(LOGINFO, "training good karma FP as ham"); + if ( $karma > 1 && $response->{result} eq 'Spam' ) { + $self->log(LOGINFO, "training good karma ($karma) FP as ham"); $self->train_error_as_ham( $transaction ); return 1; }; From c4fc2ecea31569c0bb33dd2608c98f0677083293 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Mar 2013 01:24:02 -0400 Subject: [PATCH 200/352] spamassassin: assign karma for autolearn message also removed 'use lib', to be consistent with most other plugins and improved grammar --- plugins/spamassassin | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/plugins/spamassassin b/plugins/spamassassin index be5c2ef..1279681 100644 --- a/plugins/spamassassin +++ b/plugins/spamassassin @@ -134,7 +134,7 @@ Make the "subject munge string" configurable * 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 + preserved. Admins 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 @@ -144,7 +144,6 @@ Make the "subject munge string" configurable use strict; use warnings; -use lib 'lib'; use Qpsmtpd::Constants; use Qpsmtpd::DSN; @@ -398,6 +397,8 @@ sub reject { my $status = "$ham_or_spam, $score"; my $learn = ''; if ( $sa_results->{autolearn} ) { + $self->adjust_karma( 1 ) if $ham_or_spam eq 'Ham'; + $self->adjust_karma( -1 ) if $ham_or_spam eq 'Spam'; $learn = "learn=". $sa_results->{autolearn}; }; @@ -417,8 +418,6 @@ sub reject { } } - $self->adjust_karma( -1 ); -# default of media_unsupported is DENY, so just change the message $self->log(LOGINFO, "fail, $status, > $reject, $learn"); return ($self->get_reject_type(), "spam score exceeded threshold"); } @@ -477,7 +476,7 @@ sub parse_spam_header { } $r{is_spam} = $is_spam; - # backwards compatibility for SA versions < 3 + # compatibility for SA versions < 3 if ( defined $r{hits} && ! defined $r{score} ) { $r{score} = delete $r{hits}; }; From 279a43f26ad5ba3ef878b7af55a70634566f414f Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Mar 2013 01:38:47 -0400 Subject: [PATCH 201/352] earlytalker: if we skip for +karma, log it and remove IP from log (not IPv6 optimal) --- plugins/earlytalker | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/plugins/earlytalker b/plugins/earlytalker index cb31010..33cbf19 100644 --- a/plugins/earlytalker +++ b/plugins/earlytalker @@ -163,8 +163,12 @@ sub connect_handler { return DECLINED unless $self->{_args}{'check-at'}{CONNECT}; return DECLINED if $self->is_immune(); + # senders with good karma skip the delay my $karma = $self->connection->notes('karma_history'); - return DECLINED if (defined $karma && $karma > 5); + if (defined $karma && $karma > 5) { + $self->log(LOGINFO, "skip, karma $karma"); + return DECLINED; + }; $in->add(\*STDIN) or return DECLINED; if (! $in->can_read($self->{_args}{'wait'})) { @@ -198,7 +202,7 @@ sub data_handler { sub log_and_pass { my $self = shift; my $ip = $self->qp->connection->remote_ip || 'remote host'; - $self->log(LOGINFO, "pass, $ip said nothing spontaneous"); + $self->log(LOGINFO, "pass, not spontaneous"); return DECLINED; } @@ -210,7 +214,7 @@ sub log_and_deny { $self->connection->notes('earlytalker', 1); $self->adjust_karma( -1 ); - my $log_mess = "$ip started talking before we said hello"; + my $log_mess = "remote started talking before we said hello"; my $smtp_msg = 'Connecting host started transmitting before SMTP greeting'; return $self->get_reject( $smtp_msg, $log_mess ); From e01843f6f939b10c8e3fa8211a3e31de882f77e2 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Mar 2013 01:42:10 -0400 Subject: [PATCH 202/352] headers: smite poorly behaved senders with -karma --- plugins/headers | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/plugins/headers b/plugins/headers index 959be55..deb5b70 100644 --- a/plugins/headers +++ b/plugins/headers @@ -133,6 +133,7 @@ sub hook_data_post { foreach my $h ( @required_headers ) { next if $header->get($h); + $self->adjust_karma( -1 ); return $self->get_reject( "We require a valid $h header", "no $h header"); }; @@ -140,11 +141,18 @@ sub hook_data_post { 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, Section 3.6", "too many $h headers"); + $self->adjust_karma( -1 ); + return $self->get_reject( + "Only one $h header allowed. See RFC 5322, Section 3.6", + "too many $h headers", + ); }; my $err_msg = $self->invalid_date_range(); - return $self->get_reject($err_msg, $err_msg) if $err_msg; + if ( $err_msg ) { + $self->adjust_karma( -1 ); + return $self->get_reject($err_msg, $err_msg); + }; $self->log( LOGINFO, 'pass' ); return (DECLINED); From 6a41d1ea0de58120aa3f1129e253006b0295d923 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Mar 2013 01:43:32 -0400 Subject: [PATCH 203/352] helo: smite senders that fail the selected tests and made log entries more terse --- plugins/helo | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/plugins/helo b/plugins/helo index ef06dcc..1299d78 100644 --- a/plugins/helo +++ b/plugins/helo @@ -256,7 +256,10 @@ sub helo_handler { foreach my $test ( @{ $self->{_helo_tests} } ) { my @err = $self->$test( $host ); - return $self->get_reject( @err ) if scalar @err; + if ( scalar @err ) { + $self->adjust_karma( -1 ); + return $self->get_reject( @err ); + }; }; $self->log(LOGINFO, "pass"); @@ -388,6 +391,8 @@ sub is_not_fqdn { sub no_forward_dns { my ( $self, $host ) = @_; + return if $self->is_address_literal( $host ); + my $res = $self->init_resolver(); $host = "$host." if $host !~ /\.$/; # fully qualify name @@ -395,7 +400,7 @@ sub no_forward_dns { if (! $query) { if ( $res->errorstring eq 'NXDOMAIN' ) { - return ("HELO hostname does not exist", "HELO hostname does not exist"); + return ("HELO hostname does not exist", "no such host"); } $self->log(LOGERROR, "skip, query failed (", $res->errorstring, ")" ); return; @@ -410,7 +415,7 @@ sub no_forward_dns { $self->log(LOGDEBUG, "pass, forward DNS") if $hits; return; }; - return ("helo hostname did not resolve", "fail, HELO forward DNS"); + return ("HELO hostname did not resolve", "no forward DNS"); }; sub no_reverse_dns { @@ -447,7 +452,7 @@ sub no_matching_dns { if ( $self->connection->notes('helo_forward_match') && $self->connection->notes('helo_reverse_match') ) { $self->log( LOGDEBUG, "foward and reverse match" ); - $self->adjust_karma( 1 ); # whoppee, a match! + $self->adjust_karma( 1 ); # a perfect match return; }; @@ -461,7 +466,7 @@ sub no_matching_dns { }; $self->log( LOGINFO, "fail, no forward or reverse DNS match" ); - return ("That HELO hostname fails forward and reverse DNS checks", "no matching DNS"); + return ("That HELO hostname fails FCrDNS", "no matching DNS"); }; sub check_ip_match { From 1dfa55c230508219d34af902d2a124f106de8ce5 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Mar 2013 01:47:34 -0400 Subject: [PATCH 204/352] hosts_allow: allow +karma senders +3 concurrents this is really useful if you set max-per-ip to <= 3. --- plugins/hosts_allow | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/plugins/hosts_allow b/plugins/hosts_allow index d226578..2e3be5f 100644 --- a/plugins/hosts_allow +++ b/plugins/hosts_allow @@ -80,14 +80,14 @@ sub hook_pre_connection { 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"); + return (DENYSOFT, "$err_mess, try again later"); } } my @r = $self->in_hosts_allow( $remote ); return @r if scalar @r; - $self->log( LOGDEBUG, "pass" ); + $self->log(LOGDEBUG, "pass" ); return (DECLINED); } @@ -118,8 +118,13 @@ sub in_hosts_allow { sub karma_bump { my ($self, $karma, $max) = @_; + + if ( $karma > 5 ) { + $self->log(LOGDEBUG, "increasing max connects for positive karma"); + return $max + 3; + }; if ( $karma <= 0 ) { - $self->log(LOGINFO, "limiting max connects to 1 for negative karma ($karma)"); + $self->log(LOGINFO, "limiting max connects to 1 (karma $karma)"); return 1; }; return $max; From aaa2241cb84ac447b212336a69346e584b3be042 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Mar 2013 01:56:49 -0400 Subject: [PATCH 205/352] p0f: added smite_os, assign -karma by OS --- plugins/ident/p0f | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/plugins/ident/p0f b/plugins/ident/p0f index 0493e77..d3a1c2b 100644 --- a/plugins/ident/p0f +++ b/plugins/ident/p0f @@ -99,6 +99,14 @@ Example entry specifying p0f version 2 ident/p0f /tmp/.p0f_socket version 2 +=head2 smite_os + +Assign -1 karma to senders whose OS match the regex pattern supplied. I only recommend using with this p0f 3, as it's OS database is far more reliable than p0f v2. + +Example entry: + + ident/p0f /tmp/.p0f_socket smite_os windows + =head1 Environment requirements p0f v3 requires only the remote IP. @@ -119,7 +127,7 @@ Version 2 code heavily based upon the p0fq.pl included with the p0f distribution 2010 - Matt Simerson - added local_ip option -2012 - Matt Simerson - refactored, v3 support +2012 - Matt Simerson - refactored, added v3 support =cut @@ -284,7 +292,7 @@ sub test_v2_response { return; } elsif ($type == 2) { - $self->log(LOGWARN, "skip, this connection is no longer in the cache"); + $self->log(LOGWARN, "skip, connection not in the cache"); return; } return 1; @@ -358,6 +366,10 @@ sub store_v3_results { $r{uptime} = $r{uptime_min} if $r{uptime_min}; }; + if ( $r{genre} && $self->{_args}{smite_os} ) { + my $sos = $self->{_args}{smite_os}; + $self->adjust_karma( -1 ) if $r{genre} =~ /$sos/i; + }; $self->connection->notes('p0f', \%r); $self->log(LOGINFO, "$r{os_name} $r{os_flavor}"); $self->log(LOGDEBUG, join(' ', @values )); From 309fdbe4b4519202740b7bcd72d6f52a7374f02f Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Mar 2013 02:06:57 -0400 Subject: [PATCH 206/352] relay: give +2 karma boost to relay IPs --- plugins/relay | 1 + 1 file changed, 1 insertion(+) diff --git a/plugins/relay b/plugins/relay index 7cba450..979ef94 100644 --- a/plugins/relay +++ b/plugins/relay @@ -241,6 +241,7 @@ sub hook_connect { # 95586 (connect) relay: pass, octet match in relayclients (127.0.0.) if ( $self->is_in_cidr_block() || $self->is_octet_match() ) { + $self->adjust_karma( 2 ); # big karma boost! $self->qp->connection->relay_client(1); return (DECLINED); }; From a639fc794a6b7692d1f9990c8a162e2a118fb1ce Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Mar 2013 02:12:06 -0400 Subject: [PATCH 207/352] whitelist: add +5 karma to whitelisted IPs --- plugins/whitelist | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/plugins/whitelist b/plugins/whitelist index 549dea1..76797ce 100644 --- a/plugins/whitelist +++ b/plugins/whitelist @@ -1,3 +1,4 @@ +#!perl -w =head1 NAME @@ -97,7 +98,6 @@ automatically allow relaying from that IP. use strict; use warnings; -use lib 'lib'; use Qpsmtpd::Constants; my $VERSION = 0.02; @@ -138,7 +138,8 @@ sub check_host { # From tcpserver if (exists $ENV{WHITELISTCLIENT}) { $self->qp->connection->notes('whitelistclient', 1); - $self->log(2, "pass, host $ip is a whitelisted client"); + $self->log(2, "pass, is whitelisted client"); + $self->adjust_karma( 5 ); return OK; } @@ -146,7 +147,8 @@ sub check_host { for my $h ($self->qp->config('whitelisthosts', $config_arg)) { if ($h eq $ip or $ip =~ /^\Q$h\E/) { $self->qp->connection->notes('whitelisthost', 1); - $self->log(2, "pass, host $ip is a whitelisted host"); + $self->log(2, "pass, is a whitelisted host"); + $self->adjust_karma( 5 ); return OK; } } From a5b3cc33aeccaf34f5ece24c561645a42685c132 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Mar 2013 02:15:24 -0400 Subject: [PATCH 208/352] karma: be a bit more conservative require at least -2 karma before smiting also, add +1 karma to senders with karma_history > 10 --- plugins/karma | 37 +++++++++++++++++++++---------------- 1 file changed, 21 insertions(+), 16 deletions(-) diff --git a/plugins/karma b/plugins/karma index 723d17c..6dce939 100644 --- a/plugins/karma +++ b/plugins/karma @@ -98,7 +98,7 @@ 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 +virus filters) set the B connection 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. @@ -110,10 +110,9 @@ 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. See B. +No attempt is made by this plugin to determine karma. It is up to other +plugins to reward well behaved senders with positive karma and smite poorly +behaved senders with negative karma. See B 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 @@ -141,11 +140,11 @@ the time if we are careful to also set positive karma. 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. +send. 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. +penalty. The next offense gets a 7 day penalty, and so on. =head1 USING KARMA @@ -164,7 +163,7 @@ ident plugins. 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. +those senders have sent us more spam than ham. =head1 USING KARMA IN OTHER PLUGINS @@ -196,8 +195,8 @@ 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 +Connection summaries are stored in a database. The database key is the integer +value of the remote IP. The DB 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_tool script. @@ -264,7 +263,7 @@ sub hook_pre_connection { }; if ( ! $tied->{$key} ) { - $self->log(LOGINFO, "pass, no record"); + $self->log(LOGDEBUG, "pass, no record"); return $self->cleanup_and_return($tied, $lock ); }; @@ -332,28 +331,33 @@ sub disconnect_handler { my ($penalty_start_ts, $naughty, $nice, $connects) = $self->parse_value( $tied->{$key} ); my $history = ($nice || 0) - $naughty; + my $log_mess = ''; - if ( $karma < 0 ) { + if ( $karma < -1 ) { # they achieved at least 2 strikes $history--; my $negative_limit = 0 - $self->{_args}{negative}; if ( $history <= $negative_limit ) { if ( $nice == 0 && $history < -5 ) { - $self->log(LOGINFO, "penalty box bonus!"); + $log_mess = ", 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 (k: $karma, h: $history)"); + $log_mess = "negative, sent to penalty box" . $log_mess; } else { - $self->log(LOGINFO, "negative (k: $karma, h: $history)"); + $log_mess = "negative"; }; } elsif ($karma > 1) { $nice++; - $self->log(LOGINFO, "positive (k: $karma, h: $history)"); + $log_mess = "positive"; } + else { + $log_mess = "neutral"; + } + $self->log(LOGINFO, $log_mess . ", (msg: $karma, his: $history)" ); $tied->{$key} = join(':', $penalty_start_ts, $naughty, $nice, ++$connects); return $self->cleanup_and_return($tied, $lock ); @@ -379,6 +383,7 @@ sub calc_karma { my $karma = ( $nice || 0 ) - ( $naughty || 0 ); $self->connection->notes('karma_history', $karma ); + $self->adjust_karma( 1 ) if $karma > 10; return $karma; }; From 4e3b33870a02f49506ef78e4937160af3f7fc4a9 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Mar 2013 02:16:49 -0400 Subject: [PATCH 209/352] naughty: improve POD --- plugins/naughty | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/plugins/naughty b/plugins/naughty index f8ea233..491bb8a 100644 --- a/plugins/naughty +++ b/plugins/naughty @@ -30,8 +30,8 @@ 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 resources required to disposing of them. Over 80% of my +Since many connections are from blacklisted IPs, naughty significantly +reduces the resources required to dispose 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. @@ -56,7 +56,7 @@ deployment models. 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 +as B. Note that if I is set, connections will not get the chance to authenticate. To allow clients a chance to authenticate, I works well. @@ -86,7 +86,7 @@ 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 +any recipient is accepted for naughty connections, which inhibits spammers from detecting address validity. =head2 reject_type [ temp | perm | disconnect ] From a5856d2e4a528ae8fa44314216ab7bf43d210037 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Mar 2013 02:17:45 -0400 Subject: [PATCH 210/352] qm_deliverable: added reject option, karma smite award senders -1 karma to senders to invalid addresses --- plugins/qmail_deliverable | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) diff --git a/plugins/qmail_deliverable b/plugins/qmail_deliverable index 91f6813..ec45024 100755 --- a/plugins/qmail_deliverable +++ b/plugins/qmail_deliverable @@ -45,6 +45,19 @@ option must be enabled in order for user-ext@example.org addresses to work. Default: 0 +=item 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. + =back =head1 CAVEATS @@ -155,6 +168,9 @@ sub register { if ( $args{vpopmail_ext} ) { $Qmail::Deliverable::VPOPMAIL_EXT = $args{vpopmail_ext}; }; + if ( $args{reject} ) { + $self->{_args}{reject} = $args{reject}; + }; } $self->register_hook("rcpt", "rcpt_handler"); } @@ -206,7 +222,8 @@ sub rcpt_handler { return DECLINED; }; - return (DENY, "Sorry, no mailbox by that name. qd (#5.1.1)" ); + $self->adjust_karma( -1 ); + return $self->get_reject( "Sorry, no mailbox by that name. qd (#5.1.1)" ); } sub _smtproute { From 12f1de22be030bf43b4d40b65c114fe48a4c3b4d Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 23 Mar 2013 02:22:20 -0400 Subject: [PATCH 211/352] fcrdns: new plugin for Forward Confirmed rDNS --- log/summarize | 1 + plugins/fcrdns | 280 +++++++++++++++++++++++++++++++++++++++++++ plugins/registry.txt | 1 + 3 files changed, 282 insertions(+) create mode 100644 plugins/fcrdns diff --git a/log/summarize b/log/summarize index 2956221..d658f55 100755 --- a/log/summarize +++ b/log/summarize @@ -33,6 +33,7 @@ my %formats = ( rhsbl => "%-3.3s", relay => "%-3.3s", karma => "%-3.3s", + fcrdns => "%-3.3s", earlytalker => "%-3.3s", check_earlytalker => "%-3.3s", helo => "%-3.3s", diff --git a/plugins/fcrdns b/plugins/fcrdns new file mode 100644 index 0000000..388f57b --- /dev/null +++ b/plugins/fcrdns @@ -0,0 +1,280 @@ +#!perl -w + +=head1 NAME + +Forward Confirmed RDNS - http://en.wikipedia.org/wiki/FCrDNS + +=head1 DESCRIPTION + +Determine if the SMTP sender has matching forward and reverse DNS. + +Sets the connection note fcrdns. + +=head1 WHY IT WORKS + +The reverse DNS of zombie PCs is out of the spam operators control. Their +only way to pass this test is to limit themselves to hosts with matching +forward and reverse DNS. At present, this presents a significant hurdle. + +=head1 VALIDATION TESTS + +=over 4 + +=item has_reverse_dns + +Determine if the senders IP address resolves to a hostname. + +=item has_forward_dns + +If the remote IP has a PTR hostname(s), see if that host has an A or AAAA. If +so, see if any of the host IPs (A or AAAA records) match the remote IP. + +Since the dawn of SMTP, having matching DNS has been a standard expected and +oft required of mail servers. While requiring matching DNS is prudent, +requiring an exact match will reject valid email. This often hinders the +use of FcRDNS. While testing this plugin, I noticed that mx0.slc.paypal.com +sends mail from an IP that reverses to mx1.slc.paypal.com. While that's +technically an error, so too would rejecting that connection. + +To avoid 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 FcRDNS 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, etc. + +=back + +=head1 CONFIGURATION + +=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 1912, RFC 5451 + +From Wikipedia summary: + +1. First a reverse DNS lookup (PTR query) is performed on the IP address, which returns a list of zero or more PTR records. (has_reverse_dns) + +2. For each domain name returned in the PTR query results, a regular 'forward' DNS lookup (type A or AAAA query) is then performed on that domain name. (has_forward_dns) + +3. Any A or AAAA record returned by the second query is then compared against the original IP address (check_ip_match), and if there is a match, then the FCrDNS check passes. + + +=head1 AUTHOR + +2013 - Matt Simerson + +=cut + +use strict; +use warnings; + +use Qpsmtpd::Constants; + +use Net::DNS; + +sub register { + my ($self, $qp) = (shift, shift); + $self->{_args} = { @_ }; + $self->{_args}{reject_type} = 'temp'; + $self->{_args}{timeout} ||= 5; + $self->{_args}{ptr_hosts} = {}; + + if ( ! defined $self->{_args}{reject} ) { + $self->{_args}{reject} = 0; + }; + + $self->init_resolver(); + + $self->register_hook('connect', 'connect_handler'); + $self->register_hook('data_post', 'data_post_handler'); +}; + +sub connect_handler { + my ($self) = @_; + + return DECLINED if $self->is_immune(); + + # run a couple cheap tests before the more expensive DNS tests + foreach my $test ( qw/ invalid_localhost is_not_fqdn / ) { + $self->$test() or return DECLINED; + }; + + $self->has_reverse_dns() or return DECLINED; + $self->has_forward_dns() or return DECLINED; + + $self->log(LOGINFO, "pass"); + return DECLINED; +} + +sub data_post_handler { + my ($self, $transaction) = @_; + + my $match = $self->connection->notes('fcrdns_match') || 0; + $transaction->header->add('X-Fcrdns', $match ? 'Yes' : 'No', 0 ); + return (DECLINED); +}; + +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 invalid_localhost { + my ( $self ) = @_; + return 1 if lc $self->qp->connection->remote_host ne 'localhost'; + if ( $self->qp->connection->remote_ip ne '127.0.0.1' + && $self->qp->connection->remote_ip ne '::1' ) { + $self->adjust_karma( -1 ); + $self->log( LOGINFO, "fail, not localhost" ); + return; + }; + $self->adjust_karma( 1 ); + $self->log( LOGDEBUG, "pass, is localhost" ); + return 1; +}; + +sub is_not_fqdn { + my ($self) = @_; + my $host = $self->qp->connection->remote_host or return 1; + return 1 if $host eq 'Unknown'; # QP assigns this to a "no DNS result" + + # Since QP looked it up, perform some quick validation + if ( $host !~ /\./ ) { # has no dots + $self->adjust_karma( -1 ); + $self->log(LOGINFO, "fail, not FQDN"); + return; + }; + if ( $host =~ /[^a-zA-Z0-9\-\.]/ ) { + $self->adjust_karma( -1 ); + $self->log(LOGINFO, "fail, invalid FQDN chars"); + return; + }; + return 1; +}; + +sub has_reverse_dns { + my ( $self ) = @_; + + my $res = $self->init_resolver(); + my $ip = $self->qp->connection->remote_ip; + + my $query = $res->query( $ip ) or do { + if ( $res->errorstring eq 'NXDOMAIN' ) { + $self->adjust_karma( -1 ); + $self->log( LOGINFO, "fail, no rDNS: ".$res->errorstring ); + return; + }; + $self->log( LOGINFO, "fail, error getting rDNS: ".$res->errorstring ); + return; + }; + + my $hits = 0; + $self->{_args}{ptr_hosts} = {}; # reset hash + for my $rr ($query->answer) { + next if $rr->type ne 'PTR'; + $hits++; + $self->{_args}{ptr_hosts}{ $rr->ptrdname } = 1; + $self->log(LOGDEBUG, "PTR: " . $rr->ptrdname ); + }; + if ( ! $hits ) { + $self->adjust_karma( -1 ); + $self->log( LOGINFO, "fail, no PTR records"); + return; + }; + + $self->log(LOGDEBUG, "has rDNS"); + return 1; +}; + +sub has_forward_dns { + my ( $self ) = @_; + + my $res = $self->init_resolver(); + + foreach my $host ( keys %{ $self->{_args}{ptr_hosts} } ) { + + $host .= '.' if '.' ne substr( $host, -1, 1); # fully qualify name + my $query = $res->search($host) or do { + if ( $res->errorstring eq 'NXDOMAIN' ) { + $self->log(LOGDEBUG, "host $host does not exist" ); + next; + } + $self->log(LOGDEBUG, "query for $host failed (", $res->errorstring, ")" ); + next; + }; + + my $hits = 0; + foreach my $rr ($query->answer) { + next unless $rr->type =~ /^(?:A|AAAA)$/; + $hits++; + $self->check_ip_match( $rr->address ) and return 1; + } + if ( $hits ) { + $self->log(LOGDEBUG, "PTR host has forward DNS") if $hits; + return 1; + }; + }; + $self->adjust_karma( -1 ); + $self->log(LOGINFO, "fail, no PTR hosts have forward DNS"); + return; +}; + +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('fcrdns_match', 1); + $self->adjust_karma( 1 ); + return 1; + }; + +# TODO: make this IPv6 compatible + 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('fcrdns_match', 1); + return 1; + }; + return; +}; + diff --git a/plugins/registry.txt b/plugins/registry.txt index 8d6f1ae..a276584 100644 --- a/plugins/registry.txt +++ b/plugins/registry.txt @@ -10,6 +10,7 @@ 5 karma krm karma 6 dnsbl dbl dnsbl 7 relay rly relay check_relay,check_norelay,relay_only +8 fcrdns dns fcrdn 9 earlytalker ear early check_earlytalker 15 helo hlo helo check_spamhelo 16 tls tls tls From 31609e36435428fff70dbd7b401f210c79e20b4a Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 25 Mar 2013 01:46:34 -0400 Subject: [PATCH 212/352] badmailfrom: fix reject message typo --- plugins/badmailfrom | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/badmailfrom b/plugins/badmailfrom index 1d1f36f..4aea3fe 100644 --- a/plugins/badmailfrom +++ b/plugins/badmailfrom @@ -44,7 +44,7 @@ is a Perl pattern expression. Don't forget to anchor the pattern 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 + ^return.*@.*\.pidplate\.biz$ I don't want it regardless of subdomain ^admin.*\.ppoonn400\.com$ From b0ebb75be4688b85d29d0ee2b2c448971b2036e8 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 25 Mar 2013 01:48:40 -0400 Subject: [PATCH 213/352] added karma awards for SPF pass/fail --- plugins/sender_permitted_from | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/plugins/sender_permitted_from b/plugins/sender_permitted_from index 05044d8..dcefe99 100644 --- a/plugins/sender_permitted_from +++ b/plugins/sender_permitted_from @@ -144,10 +144,16 @@ sub mail_handler { # SPF result codes: pass fail softfail neutral none error permerror temperror return $self->handle_code_none($reject, $why) if $code eq 'none'; - return $self->handle_code_fail($reject, $why) if $code eq 'fail'; - return $self->handle_code_softfail($reject, $why) if $code eq 'softfail'; - - if ( $code eq 'pass' ) { + if ( $code eq 'fail' ) { + $self->adjust_karma( -1 ); + return $self->handle_code_fail($reject, $why); + } + elsif ( $code eq 'softfail' ) { + $self->adjust_karma( -1 ); + return $self->handle_code_softfail($reject, $why); + } + elsif ( $code eq 'pass' ) { + $self->adjust_karma( 1 ); $self->log(LOGINFO, "pass, $code: $why" ); return (DECLINED); } @@ -158,12 +164,12 @@ sub mail_handler { elsif ( $code eq 'error' ) { $self->log(LOGINFO, "fail, $code, $why" ); return (DENY, "SPF - $code: $why") if $reject >= 6; - return (DENYSOFT, "SPF - $code: $why") if $reject >= 2; + return (DENYSOFT, "SPF - $code: $why") if $reject > 3; } elsif ( $code eq 'permerror' ) { $self->log(LOGINFO, "fail, $code, $why" ); return (DENY, "SPF - $code: $why") if $reject >= 6; - return (DENYSOFT, "SPF - $code: $why") if $reject >= 3; + return (DENYSOFT, "SPF - $code: $why") if $reject > 3; } elsif ( $code eq 'temperror' ) { $self->log(LOGINFO, "fail, $code, $why" ); From 37f4c95175d6b7e0dd2b1623c63356fa4bbcbacf Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 25 Mar 2013 01:53:16 -0400 Subject: [PATCH 214/352] spamassassin: karma scoring is dependent on the sessage learn status, not SA (global) autolearn setting. So, karma learning follows SA learning rules. --- plugins/spamassassin | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/plugins/spamassassin b/plugins/spamassassin index 1279681..6455d8f 100644 --- a/plugins/spamassassin +++ b/plugins/spamassassin @@ -396,10 +396,11 @@ sub reject { my $ham_or_spam = $sa_results->{is_spam} eq 'Yes' ? 'Spam' : 'Ham'; my $status = "$ham_or_spam, $score"; my $learn = ''; - if ( $sa_results->{autolearn} ) { - $self->adjust_karma( 1 ) if $ham_or_spam eq 'Ham'; - $self->adjust_karma( -1 ) if $ham_or_spam eq 'Spam'; - $learn = "learn=". $sa_results->{autolearn}; + my $al = $sa_results->{autolearn}; + if ( $al ) { + $self->adjust_karma( 1 ) if $al eq 'ham'; + $self->adjust_karma( -1 ) if $al eq 'spam'; + $learn = "learn=". $al; }; my $reject = $self->{_args}{reject} or do { From 278107f7fc7d470e7216563e53f276bba203428c Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Tue, 26 Mar 2013 17:52:41 -0400 Subject: [PATCH 215/352] resolvable_fromhost: added karma smites --- plugins/resolvable_fromhost | 30 ++++++++++++++++++++---------- 1 file changed, 20 insertions(+), 10 deletions(-) diff --git a/plugins/resolvable_fromhost b/plugins/resolvable_fromhost index 3181470..56ca10c 100644 --- a/plugins/resolvable_fromhost +++ b/plugins/resolvable_fromhost @@ -109,21 +109,26 @@ sub hook_mail { return DECLINED if $resolved; # success, no need to continue #return DECLINED if $sender->host; # reject later - if ( ! $self->{_args}{reject} ) {; - $self->log(LOGINFO, 'skip, reject disabled' ); - return DECLINED; - }; - my $result = $transaction->notes('resolvable_fromhost') or do { - $self->log(LOGINFO, 'error, missing result' ); - return Qpsmtpd::DSN->temp_resolver_failed( $self->get_reject_type(), '' ); + if ( $self->{_args}{reject} ) {; + $self->log(LOGINFO, 'error, missing result' ); + return Qpsmtpd::DSN->temp_resolver_failed( $self->get_reject_type(), '' ); + }; + $self->log(LOGINFO, 'error, missing result, reject disabled' ); + return DECLINED; }; return DECLINED if $result =~ /^(?:a|ip|mx)$/; # success return DECLINED if $result =~ /^(?:whitelist|null|naughty)$/; # immunity - $self->log(LOGINFO, "fail, $result" ); # log error + $self->adjust_karma( -1 ); + if ( ! $self->{_args}{reject} ) {; + $self->log(LOGINFO, "fail, reject disabled, $result" ); + return DECLINED; + }; + + $self->log(LOGINFO, "fail, $result" ); # log error return Qpsmtpd::DSN->addr_bad_from_system( $self->get_reject_type(), "FQDN required in the envelope sender"); } @@ -134,6 +139,7 @@ sub check_dns { # we can't even parse a hostname out of the address if ( ! $host ) { $transaction->notes('resolvable_fromhost', 'unparsable host'); + $self->adjust_karma( -1 ); return; }; @@ -142,6 +148,7 @@ sub check_dns { if ( $host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/ ) { $self->log(LOGINFO, "skip, $host is an IP"); $transaction->notes('resolvable_fromhost', 'ip'); + $self->adjust_karma( -1 ); return 1; }; @@ -150,8 +157,9 @@ sub check_dns { $res->udp_timeout(30); my $has_mx = $self->get_and_validate_mx( $res, $host, $transaction ); - return 1 if $has_mx == 1; # success! + return 1 if $has_mx == 1; # success, has MX! return if $has_mx == -1; # has invalid MX records + # at this point, no MX for fh is resolvable my @host_answers = $self->get_host_records( $res, $host, $transaction ); foreach my $rr (@host_answers) { @@ -189,6 +197,7 @@ sub get_and_validate_mx { my @mx = mx($res, $host); if ( ! scalar @mx ) { # no mx records + $self->adjust_karma( -1 ); $self->log(LOGINFO, "$host has no MX"); return 0; }; @@ -203,8 +212,9 @@ sub get_and_validate_mx { } # if there are MX records, and we got here, none are valid - $self->log(LOGINFO, "fail, invalid MX for $host"); + #$self->log(LOGINFO, "fail, invalid MX for $host"); $transaction->notes('resolvable_fromhost', "invalid MX for $host"); + $self->adjust_karma( -1 ); return -1; }; From 9bea21bc756f56f703bc94e1828e2874a2447b60 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Tue, 26 Mar 2013 18:12:11 -0400 Subject: [PATCH 216/352] config/plugins: added fcrdns, do not reject by def set plugins behavior in sample config file to not reject by default --- config.sample/plugins | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/config.sample/plugins b/config.sample/plugins index 5e95731..24177b8 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -17,8 +17,10 @@ hosts_allow # connection / informational plugins #connection_time +#karma penalty_box 1 reject naughty ident/geoip #ident/p0f /tmp/.p0f_socket version 3 +fcrdns quit_fortune # tls should load before count_unrecognized_commands @@ -28,14 +30,13 @@ count_unrecognized_commands 4 relay #whitelist -#karma penalty_box 1 reject naughty dnsbl reject naughty reject_type disconnect rhsbl # greylisting reject 0 p0f genre,windows # HELO plugins -helo policy lenient +helo policy strict reject 0 # 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 @@ -53,10 +54,10 @@ auth/authdeny dont_require_anglebrackets # MAIL FROM plugins -badmailfrom +badmailfrom reject naughty #badmailfromto -resolvable_fromhost -# sender_permitted_from +resolvable_fromhost reject 0 +# sender_permitted_from reject 2 # RCPT TO plugins badrcptto @@ -66,10 +67,10 @@ rcpt_ok # DATA plugins #uribl -headers reject 1 reject_type temp require From,Date future 2 past 15 -#bogus_bounce +headers reject 0 reject_type temp require From,Date future 2 past 15 +bogus_bounce log #loop -dkim +dkim reject 0 # content filters virus/klez_filter From 3ba8e1215596afba6ec272521636e7fd2c53f2a5 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Tue, 26 Mar 2013 22:14:26 -0400 Subject: [PATCH 217/352] helo: stop processing after first match --- plugins/helo | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/plugins/helo b/plugins/helo index 1299d78..55a4285 100644 --- a/plugins/helo +++ b/plugins/helo @@ -371,6 +371,7 @@ sub is_forged_literal { my ( $self, $host ) = @_; return if $host !~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/; +# should we add exceptions for reserved internal IP space? (192.168,10., etc?) $host = substr $host, 1, -1; return if $host eq $self->qp->connection->remote_ip; return ("Forged IPs not accepted here", "forged IP literal"); @@ -410,6 +411,7 @@ sub no_forward_dns { next unless $rr->type =~ /^(?:A|AAAA)$/; $self->check_ip_match( $rr->address ); $hits++; + last if $self->connection->notes('helo_forward_match'); } if ( $hits ) { $self->log(LOGDEBUG, "pass, forward DNS") if $hits; @@ -449,6 +451,9 @@ sub no_reverse_dns { sub no_matching_dns { my ( $self, $host ) = @_; +# this is called iprev, or "Forward-confirmed reverse DNS" and is discussed in RFC 5451 +# consider adding header: Authentication-Results + if ( $self->connection->notes('helo_forward_match') && $self->connection->notes('helo_reverse_match') ) { $self->log( LOGDEBUG, "foward and reverse match" ); From b146e0cd7e00fc0b9d3a220f389a58a7ad63a1c6 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Tue, 26 Mar 2013 22:15:13 -0400 Subject: [PATCH 218/352] dkim: added karma for dkim results (allow/reject) --- plugins/dkim | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/plugins/dkim b/plugins/dkim index 549dc2c..4155df6 100644 --- a/plugins/dkim +++ b/plugins/dkim @@ -152,6 +152,7 @@ sub get_details { sub handle_sig_fail { my ( $self, $dkim, $mess ) = @_; + $self->adjust_karma( -1 ); return $self->get_reject( "DKIM signature invalid: " . $dkim->result_detail, $mess ); }; @@ -179,6 +180,7 @@ sub handle_sig_invalid { }; }; + $self->adjust_karma( -1 ); $self->log(LOGINFO, $mess ); if ( $prs->{accept} ) { @@ -212,6 +214,7 @@ sub handle_sig_pass { if ( $prs->{accept} ) { $self->add_header( $mess ); $self->log(LOGINFO, "pass, valid signature, accept policy"); + $self->adjust_karma( 1 ); return DECLINED; } elsif ( $prs->{neutral} ) { @@ -222,6 +225,7 @@ sub handle_sig_pass { } elsif ( $prs->{reject} ) { $self->log(LOGINFO, $mess ); + $self->adjust_karma( -1 ); return $self->get_reject( "DKIM signature valid but fails policy, $mess", "fail, valid sig, reject policy" @@ -252,7 +256,6 @@ sub handle_sig_none { }; }; - if ( $prs->{accept} ) { $self->log( LOGINFO, "pass, no signature, accept policy" ); return DECLINED; From 34b9a7c0b3f2c743a08315057008a72171bd4a43 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Tue, 26 Mar 2013 23:37:08 -0700 Subject: [PATCH 219/352] moved FAQ to github wiki --- MANIFEST | 1 - README | 2 ++ docs/FAQ.pod | 47 ----------------------------------------------- 3 files changed, 2 insertions(+), 48 deletions(-) delete mode 100644 docs/FAQ.pod diff --git a/MANIFEST b/MANIFEST index 8c60bdf..4de05e0 100644 --- a/MANIFEST +++ b/MANIFEST @@ -25,7 +25,6 @@ docs/advanced.pod docs/authentication.pod docs/config.pod docs/development.pod -docs/FAQ.pod docs/hooks.pod docs/logging.pod docs/plugins.pod diff --git a/README b/README index 421e7d4..d394af5 100644 --- a/README +++ b/README @@ -12,6 +12,8 @@ web: mailinglist: qpsmtpd-subscribe@perl.org +FAQ: + https://github.com/qpsmtpd-dev/qpsmtpd-dev/wiki/faq =head1 DESCRIPTION diff --git a/docs/FAQ.pod b/docs/FAQ.pod deleted file mode 100644 index 68e8806..0000000 --- a/docs/FAQ.pod +++ /dev/null @@ -1,47 +0,0 @@ -# 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 From b79f952b36888ddd90a9b87c6969c8d7a0c9a81a Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Tue, 26 Mar 2013 23:55:09 -0700 Subject: [PATCH 220/352] moved author tests from t/ to xt/ --- {t => xt}/01-syntax.t | 0 {t => xt}/02-pod.t | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename {t => xt}/01-syntax.t (100%) rename {t => xt}/02-pod.t (100%) diff --git a/t/01-syntax.t b/xt/01-syntax.t similarity index 100% rename from t/01-syntax.t rename to xt/01-syntax.t diff --git a/t/02-pod.t b/xt/02-pod.t similarity index 100% rename from t/02-pod.t rename to xt/02-pod.t From 55e9664824e23817bf5761e9e94c1dfa31c33561 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Mar 2013 00:02:33 -0700 Subject: [PATCH 221/352] test fixes for badmailfrom,headers plugins --- t/plugin_tests/badmailfrom | 1 + t/plugin_tests/headers | 1 + 2 files changed, 2 insertions(+) diff --git a/t/plugin_tests/badmailfrom b/t/plugin_tests/badmailfrom index 463d5f7..e6ccded 100644 --- a/t/plugin_tests/badmailfrom +++ b/t/plugin_tests/badmailfrom @@ -52,6 +52,7 @@ sub test_badmailfrom_hook_mail { $transaction->sender($address); $self->{_badmailfrom_config} = ['matt@test.net','matt@test.com']; + $self->{_args}{reject} = 1; $transaction->notes('naughty', ''); my ($r, $err) = $self->hook_mail( $transaction, $address ); cmp_ok( $r, '==', DENY, "hook_mail rc"); diff --git a/t/plugin_tests/headers b/t/plugin_tests/headers index 7cf9e7e..c5cea99 100644 --- a/t/plugin_tests/headers +++ b/t/plugin_tests/headers @@ -79,6 +79,7 @@ sub test_invalid_date_range { sub test_hook_data_post { my $self = shift; + $self->{_args}{reject} = 1; my $reject = $self->{_args}{reject_type}; my $deny = $reject =~ /^temp|soft$/i ? DENYSOFT : DENY; From 63701ca65f749f67c689f2e7b24a6c8eb669afa3 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Mar 2013 18:14:23 -0400 Subject: [PATCH 222/352] log2sql: added UPDATE support to exec_query --- log/log2sql | 41 +++++++++++++++++++++++------------------ 1 file changed, 23 insertions(+), 18 deletions(-) diff --git a/log/log2sql b/log/log2sql index d654abb..cd1f4f3 100755 --- a/log/log2sql +++ b/log/log2sql @@ -32,7 +32,7 @@ exit; sub trim_message { my $mess = shift; - + return '' if $mess eq 'skip, naughty'; return '' if $mess eq 'skip, relay client'; return '' if $mess eq 'skip, no match'; @@ -120,10 +120,9 @@ sub create_message { my ( $fid, $ts, $pid, $message ) = @_; my ($host, $ip) = split /\s/, $message; - $ip = substr $ip, 1, -1; # remote brackets - #print "new from $ip\n"; + $ip = substr $ip, 1, -1; # remove brackets - my $id = exec_query( + my $id = exec_query( "INSERT INTO message SET file_id=?, connect_start=FROM_UNIXTIME(?), qp_pid=?, ip=INET_ATON(?)", [ $fid, $ts, $pid, $ip ] ); @@ -131,6 +130,7 @@ sub create_message { if ( $host && $host ne 'Unknown' ) { exec_query( "UPDATE message SET hostname=? WHERE id=?", [ $host, $id ] ); }; + #warn "host updated: $host\n"; }; sub insert_plugin { @@ -200,6 +200,7 @@ sub parse_logfile { next; }; + #warn "type: $type\n"; if ( $type eq 'plugin' ) { next if $plugin eq 'naughty'; # housekeeping only insert_plugin( $msg_id, $plugin, $message ); @@ -255,45 +256,45 @@ sub check_logfile { my $size = stat($path)->size or die "unable to get size for $path\n"; my $exists; - # check if this tai file is in the DB as 'current' + #warn "check if file $file is in the DB as 'current'\n"; if ( $file =~ /^\@/ ) { - $exists = exec_query( + $exists = exec_query( 'SELECT * FROM log WHERE inode=? AND name=?', - [ $inode, 'current' ] + [ $inode, 'current' ] ); if ( @$exists ) { print "Updating current -> $file\n"; exec_query( 'UPDATE log SET name=? WHERE inode=? AND name=?', - [ $file, $inode, 'current' ] + [ $file, $inode, 'current' ] ); return ( $exists->[0]{id}, $exists->[0]{size} ); # continue parsing }; }; if ( $file eq 'current' ) { - $exists = exec_query( + $exists = exec_query( 'SELECT * FROM log WHERE inode=? AND name=?', - [ $inode, $file ] + [ $inode, $file ] ); if ( @$exists ) { - $exists = exec_query( + exec_query( 'UPDATE log SET size=? WHERE inode=? AND name=?', - [ $size, $inode, 'current' ] + [ $size, $inode, 'current' ] ); return ( $exists->[0]{id}, $exists->[0]{size} ); # continue parsing }; }; - $exists = exec_query( + $exists = exec_query( 'SELECT * FROM log WHERE name=? AND size=?', - [ $file, $size ] + [ $file, $size ] ); return if @$exists; # log file hasn't changed, ignore it #print Dumper($exists); # file is a new one we haven't seen, add to DB and parse - my $id = exec_query( + my $id = exec_query( 'INSERT INTO log SET inode=?, size=?, name=?, created=FROM_UNIXTIME(?)', [ $inode, $size, $file, stat($path)->ctime ] ); @@ -443,7 +444,7 @@ sub parse_line_plugin_spamassassin { if ( $message =~ /^fail, Spam,\s([\d\.]+)\s< 100/ ) { $message = "fail, $1"; }; - + return ( 'plugin', $pid, $hook, $plugin, $message ); }; @@ -483,7 +484,7 @@ sub parse_line_plugin_p0f { sub parse_line_cleanup { my ($line) = @_; # @tai 85931 cleaning up after 3210 - my $pid = (split /\s+/, $line)[-1]; + my $pid = (split /\s+/, $line)[-1]; $has_cleanup++; return ( 'cleanup', $pid, undef, undef, $line ); }; @@ -522,6 +523,7 @@ sub exec_query { $err .= join(',', @params); }; + #warn "err: $err\n"; if ( $query =~ /INSERT INTO/ ) { my ( $table ) = $query =~ /INSERT INTO (\w+)\s/; $db->query( $query, @params ); @@ -529,8 +531,11 @@ sub exec_query { my $id = $db->last_insert_id(undef,undef,$table,undef) or die $err; return $id; } + elsif ( $query =~ /^UPDATE/i ) { + return $db->query( $query, @params ); + } elsif ( $query =~ /DELETE/ ) { - $db->query( $query, @params )->hashes or die $err; + $db->query( $query, @params ) or die $err; return $db->query("SELECT ROW_COUNT()")->list; }; From a1ab386779d6badc2c2fad6011a311dc7e9c3727 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Mar 2013 18:16:43 -0400 Subject: [PATCH 223/352] Q:Plugin.pm: abstracted out store_deferred_reject --- lib/Qpsmtpd/Plugin.pm | 26 +++++++++++++++++++------- 1 file changed, 19 insertions(+), 7 deletions(-) diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm index 6d8e1c1..83ae43b 100644 --- a/lib/Qpsmtpd/Plugin.pm +++ b/lib/Qpsmtpd/Plugin.pm @@ -225,13 +225,7 @@ sub get_reject { # the naughty plugin will reject later if ( $reject eq 'naughty' ) { $self->log(LOGINFO, "fail, NAUGHTY" . $log_mess); - if ( ! $self->connection->notes('naughty') ) { - $self->connection->notes('naughty', $smtp_mess); - }; - if ( ! $self->connection->notes('naughty_reject_type') ) { - $self->connection->notes('naughty_reject_type', $self->{_args}{reject_type} ); - } - return (DECLINED); + return $self->store_deferred_reject( $smtp_mess ); }; # they asked for reject, we give them reject @@ -251,6 +245,24 @@ sub get_reject_type { : $default; }; +sub store_deferred_reject { + my ($self, $smtp_mess) = @_; + + # store the reject message that the naughty plugin will return later + if ( ! $self->connection->notes('naughty') ) { + $self->connection->notes('naughty', $smtp_mess); + } + else { + # append this reject message to the message + my $prev = $self->connection->notes('naughty'); + $self->connection->notes('naughty', "$prev\015\012$smtp_mess"); + }; + if ( ! $self->connection->notes('naughty_reject_type') ) { + $self->connection->notes('naughty_reject_type', $self->{_args}{reject_type} ); + } + return (DECLINED); +}; + sub is_immune { my $self = shift; From 23332dc71b9bfa99324cc20f454c894f76d16943 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Mar 2013 19:03:13 -0400 Subject: [PATCH 224/352] moved triplicated init_resolver into Plugin.pm --- lib/Qpsmtpd/Plugin.pm | 13 +++++++++++++ plugins/fcrdns | 15 +-------------- plugins/helo | 35 ++++++++++++----------------------- plugins/rhsbl | 35 +++++++++++++---------------------- 4 files changed, 39 insertions(+), 59 deletions(-) diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm index 83ae43b..4e3a08d 100644 --- a/lib/Qpsmtpd/Plugin.pm +++ b/lib/Qpsmtpd/Plugin.pm @@ -3,6 +3,8 @@ package Qpsmtpd::Plugin; use strict; use warnings; +use Net::DNS; + use Qpsmtpd::Constants; # more or less in the order they will fire @@ -263,6 +265,17 @@ sub store_deferred_reject { return (DECLINED); }; +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}{dns_timeout} || 5; + $self->{_resolver}->tcp_timeout($timeout); + $self->{_resolver}->udp_timeout($timeout); + return $self->{_resolver}; +}; + sub is_immune { my $self = shift; diff --git a/plugins/fcrdns b/plugins/fcrdns index 388f57b..c1f2e56 100644 --- a/plugins/fcrdns +++ b/plugins/fcrdns @@ -100,8 +100,6 @@ use warnings; use Qpsmtpd::Constants; -use Net::DNS; - sub register { my ($self, $qp) = (shift, shift); $self->{_args} = { @_ }; @@ -113,7 +111,7 @@ sub register { $self->{_args}{reject} = 0; }; - $self->init_resolver(); + $self->init_resolver() or return; $self->register_hook('connect', 'connect_handler'); $self->register_hook('data_post', 'data_post_handler'); @@ -144,17 +142,6 @@ sub data_post_handler { return (DECLINED); }; -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 invalid_localhost { my ( $self ) = @_; return 1 if lc $self->qp->connection->remote_host ne 'localhost'; diff --git a/plugins/helo b/plugins/helo index 55a4285..a4c5404 100644 --- a/plugins/helo +++ b/plugins/helo @@ -109,7 +109,7 @@ Default: lenient =head3 lenient -Reject failures of the following tests: is_in_badhelo, invalid_localhost, +Runs the following tests: is_in_badhelo, invalid_localhost, is_forged_literal, and is_plain_ip. This setting is lenient enough not to cause problems for your Windows users. @@ -121,11 +121,11 @@ IPs. 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_not_fqdn, no_forward_dns, and no_reverse_dns. +the following are tested: 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 setting I and using the B -plugin. Windows PCs often send unqualified HELO names and will have trouble +I without setting I to 0 or naughty. +Windows PCs often send unqualified HELO names and will have trouble sending mail. The B plugin defers the rejection, giving the user the opportunity to authenticate and bypass the rejection. @@ -138,7 +138,7 @@ 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. +examine your logs for false positives. =head2 badhelo @@ -223,21 +223,19 @@ 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; + $self->{_args}{dns_timeout} ||= $self->{_args}{timeout} || 5; if ( ! defined $self->{_args}{reject} ) { $self->{_args}{reject} = 1; }; - $self->populate_tests(); - $self->init_resolver(); + $self->init_resolver() or return; $self->register_hook('helo', 'helo_handler'); $self->register_hook('ehlo', 'helo_handler'); @@ -290,17 +288,6 @@ sub populate_tests { }; }; -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 ) = @_; @@ -451,8 +438,10 @@ sub no_reverse_dns { sub no_matching_dns { my ( $self, $host ) = @_; -# this is called iprev, or "Forward-confirmed reverse DNS" and is discussed in RFC 5451 -# consider adding header: Authentication-Results +# this is called iprev, or "Forward-confirmed reverse DNS" and is discussed +# in RFC 5451. FCrDNS is done for the remote IP in the fcrdns plugin. Here +# we do it on the HELO hostname. +# consider adding status to Authentication-Results header if ( $self->connection->notes('helo_forward_match') && $self->connection->notes('helo_reverse_match') ) { diff --git a/plugins/rhsbl b/plugins/rhsbl index 6f0a43a..eea19f5 100644 --- a/plugins/rhsbl +++ b/plugins/rhsbl @@ -33,26 +33,28 @@ use Qpsmtpd::Constants; sub register { my ($self, $qp ) = (shift, shift); - my $denial; if ( @_ == 1 ) { - $denial = shift; - if ( defined $denial && $denial =~ /^disconnect$/i ) { - $self->{_args}{reject_type} = 'disconnect'; - } - else { - $self->{_args}{reject_type} = 'perm'; - } + $self->legacy_positional_args( @_ ); } else { $self->{_args} = { @_ }; }; - if ( ! defined $self->{_args}{reject} ) { - $self->{_args}{reject} = 1; - }; + $self->{_args}{reject} = 1 if ! defined $self->{_args}{reject}; $self->{_args}{reject_type} ||= 'perm'; } +sub legacy_positional_args { + my ($self, $denial) = @_; + + if ( defined $denial && $denial =~ /^disconnect$/i ) { + $self->{_args}{reject_type} = 'disconnect'; + } + else { + $self->{_args}{reject_type} = 'perm'; + } +}; + sub hook_mail { my ($self, $transaction, $sender, %param) = @_; @@ -135,14 +137,3 @@ sub populate_zones { return %rhsbl_zones; }; -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} || 8; - $self->{_resolver}->tcp_timeout($timeout); - $self->{_resolver}->udp_timeout($timeout); - return $self->{_resolver}; -}; - From 133cd29acc9d9b67ec7f11e3d0d484b2e93ace7f Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Mar 2013 19:04:38 -0400 Subject: [PATCH 225/352] dspam/spamassassin: adjust karma awards dspam: be more conservative when learning from karma sa: added an SA autolearn bonus --- plugins/dspam | 4 ++-- plugins/spamassassin | 7 +++++-- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/plugins/dspam b/plugins/dspam index bab7c76..a7b7013 100644 --- a/plugins/dspam +++ b/plugins/dspam @@ -634,13 +634,13 @@ sub autolearn_karma { my $karma = $self->connection->notes('karma'); return if ! defined $karma; - if ( $karma < -1 && $response->{result} eq 'Innocent' ) { + if ( $karma < -2 && $response->{result} eq 'Innocent' ) { $self->log(LOGINFO, "training bad karma ($karma) FN as spam"); $self->train_error_as_spam( $transaction ); return 1; }; - if ( $karma > 1 && $response->{result} eq 'Spam' ) { + if ( $karma > 2 && $response->{result} eq 'Spam' ) { $self->log(LOGINFO, "training good karma ($karma) FP as ham"); $self->train_error_as_ham( $transaction ); return 1; diff --git a/plugins/spamassassin b/plugins/spamassassin index 6455d8f..6d0a559 100644 --- a/plugins/spamassassin +++ b/plugins/spamassassin @@ -394,9 +394,12 @@ sub reject { }; my $ham_or_spam = $sa_results->{is_spam} eq 'Yes' ? 'Spam' : 'Ham'; + if ( $ham_or_spam eq 'Spam' ) { + $self->adjust_karma( -1 ); + }; my $status = "$ham_or_spam, $score"; my $learn = ''; - my $al = $sa_results->{autolearn}; + my $al = $sa_results->{autolearn}; # subject to local SA learn scores if ( $al ) { $self->adjust_karma( 1 ) if $al eq 'ham'; $self->adjust_karma( -1 ) if $al eq 'spam'; @@ -404,7 +407,7 @@ sub reject { }; my $reject = $self->{_args}{reject} or do { - $self->log(LOGERROR, "pass, reject disabled ($status, $learn)"); + $self->log(LOGERROR, "error, reject disabled ($status, $learn)"); return DECLINED; }; From 08c2f080efd31b973d6d7c3ded42fdb19c086cb5 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Mar 2013 19:06:06 -0400 Subject: [PATCH 226/352] random_error: fixed typo, added std pragmas --- plugins/random_error | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/plugins/random_error b/plugins/random_error index 3faf890..780ee06 100644 --- a/plugins/random_error +++ b/plugins/random_error @@ -1,4 +1,10 @@ #!perl -w + +use strict; +use warnings; + +use Qpsmtpd::Constants; + =head1 NAME random_error @@ -12,7 +18,7 @@ This plugin randomly disconnects and issues DENYSOFTs. 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. +2/5 of failures are DENYSOFT_DISCONNECT, 3/5 simply DENYSOFT. For use with other plugins, scribble the revised failure rate to From d8ef3056644345be0a6566fba5c062dfac8fca51 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Mar 2013 19:06:52 -0400 Subject: [PATCH 227/352] resolvable_fromhost: documented reject naughty --- plugins/resolvable_fromhost | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/resolvable_fromhost b/plugins/resolvable_fromhost index 56ca10c..12bd333 100644 --- a/plugins/resolvable_fromhost +++ b/plugins/resolvable_fromhost @@ -32,12 +32,12 @@ I, making it accessible when $sender is not. =head1 CONFIGURATION -=head2 reject +=head2 reject < 0 | 1 | naughty > If I is set, the old require_resolvable_fromhost plugin behavior of temporary rejection is the default. - resolvable_fromhost reject [ 0 | 1 ] + resolvable_fromhost reject [ 0 | 1 | naughty ] Default: 1 From 21db884d8e1fcbc61fbe087f84e5b0d7312c4cd0 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Mar 2013 19:07:23 -0400 Subject: [PATCH 228/352] spf: add comment re: Authentication-Results header --- plugins/sender_permitted_from | 1 + 1 file changed, 1 insertion(+) diff --git a/plugins/sender_permitted_from b/plugins/sender_permitted_from index dcefe99..a527b25 100644 --- a/plugins/sender_permitted_from +++ b/plugins/sender_permitted_from @@ -231,6 +231,7 @@ sub data_post_handler { }; $transaction->header->add('Received-SPF', $result->received_spf_header, 0); +# consider also adding SPF status to Authentication-Results header return DECLINED; } From eae10519ee167d6127207afe282a31318b47f386 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Mar 2013 19:26:21 -0400 Subject: [PATCH 229/352] bogus_bounce: suppress undefined var error --- plugins/bogus_bounce | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/bogus_bounce b/plugins/bogus_bounce index 79863a0..a05a5a2 100644 --- a/plugins/bogus_bounce +++ b/plugins/bogus_bounce @@ -56,7 +56,7 @@ sub register { }; # we only need to check for deferral, default is DENY - if ( $self->{_args}{action} =~ /soft/i ) { + if ( $self->{_args}{action} && $self->{_args}{action} =~ /soft/i ) { $self->{_args}{reject_type} = 'temp'; } } From b9501855ff3987ec9009db9fc0b747e1bf929813 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Mar 2013 19:37:40 -0400 Subject: [PATCH 230/352] dspam: catch error where QP user lacks x on dspam x = execute privileges --- plugins/dspam | 20 ++++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) diff --git a/plugins/dspam b/plugins/dspam index a7b7013..fe353ca 100644 --- a/plugins/dspam +++ b/plugins/dspam @@ -217,14 +217,26 @@ sub register { $self->{_args}{reject_type} ||= 'perm'; $self->{_args}{dspam_bin} ||= '/usr/local/bin/dspam'; - if ( ! -x $self->{_args}{dspam_bin} ) { - $self->log(LOGERROR, "dspam CLI binary not found: install dspam and/or set dspam_bin"); - return DECLINED; - }; + $self->get_dspam_bin() or return DECLINED; $self->register_hook('data_post', 'data_post_handler'); } +sub get_dspam_bin { + my $self = shift; + + my $bin = $self->{_args}{dspam_bin}; + if ( ! -e $bin ) { + $self->log(LOGERROR, "error, dspam CLI binary not found: install dspam and/or set dspam_bin"); + return; + }; + if ( ! -x $bin ) { + $self->log(LOGERROR, "error, no permission to run $bin"); + return; + }; + return $bin; +}; + sub data_post_handler { my $self = shift; my $transaction = shift || $self->qp->transaction; From 9fdf741a209f3c9f9a7fd2e0cb2aba2219ecc4a3 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Mar 2013 19:50:10 -0400 Subject: [PATCH 231/352] dspam: raise loglevel on debug log message --- plugins/dspam | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/dspam b/plugins/dspam index fe353ca..593a129 100644 --- a/plugins/dspam +++ b/plugins/dspam @@ -622,7 +622,7 @@ sub autolearn_naughty { my $learn = $self->{_args}{autolearn} or return; if ( $learn ne 'naughty' && $learn ne 'any' ) { - $self->log(LOGINFO, "skipping naughty autolearn"); + $self->log(LOGDEBUG, "skipping naughty autolearn"); return; }; From 00a6d61c437f8b5aa922880863031e47c575a0e9 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 27 Mar 2013 20:09:42 -0400 Subject: [PATCH 232/352] dkim: corrected log entry, added comment --- plugins/dkim | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/plugins/dkim b/plugins/dkim index 4155df6..0633141 100644 --- a/plugins/dkim +++ b/plugins/dkim @@ -80,9 +80,7 @@ use Socket qw(:DEFAULT :crlf); sub init { my ($self, $qp) = (shift, shift); - $self->{_args} = { @_ }; - $self->{_args}{reject} = 1 if ! defined $self->{_args}{reject}; $self->{_args}{reject_type} ||= 'perm'; } @@ -196,7 +194,7 @@ sub handle_sig_invalid { elsif ( $prs->{reject} ) { return $self->get_reject( "invalid DKIM signature: " . $dkim->result_detail, - "fail, invalid signature, reject policy" + "invalid signature, reject policy" ); } @@ -332,6 +330,7 @@ sub add_header { my $self = shift; my $header = shift or return; +# consider adding Authentication-Results header here as well $self->qp->transaction->header->add( 'X-DKIM-Authentication', $header, 0 ); } From cd48146c28b15f2756f6ddbf6b58bd488e48482e Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Thu, 28 Mar 2013 17:30:25 -0400 Subject: [PATCH 233/352] karma,relay: karma plugin awards karma later by detecting during DATA if relay_client is set --- plugins/karma | 9 +++++++++ plugins/relay | 1 - 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/plugins/karma b/plugins/karma index 6dce939..ae1bead 100644 --- a/plugins/karma +++ b/plugins/karma @@ -243,6 +243,7 @@ sub register { }; #$self->prune_db(); # keep the DB compact $self->register_hook('connect', 'connect_handler'); + $self->register_hook('data', 'data_handler' ); $self->register_hook('disconnect', 'disconnect_handler'); } @@ -316,6 +317,14 @@ sub connect_handler { return $self->get_reject( $mess, $karma ); } +sub data_handler { + my ($self, $transaction) = @_; + return DECLINED if ! $self->qp->connection->relay_client; + + $self->adjust_karma( 5 ); # big karma boost for authenticated user/IP + return DECLINED; +}; + sub disconnect_handler { my $self = shift; diff --git a/plugins/relay b/plugins/relay index 979ef94..7cba450 100644 --- a/plugins/relay +++ b/plugins/relay @@ -241,7 +241,6 @@ sub hook_connect { # 95586 (connect) relay: pass, octet match in relayclients (127.0.0.) if ( $self->is_in_cidr_block() || $self->is_octet_match() ) { - $self->adjust_karma( 2 ); # big karma boost! $self->qp->connection->relay_client(1); return (DECLINED); }; From eed4d5e79173a89d5154fa78cc01eec930eeef9f Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Thu, 28 Mar 2013 17:47:02 -0400 Subject: [PATCH 234/352] domainkeys: added deprecation comment --- plugins/domainkeys | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/plugins/domainkeys b/plugins/domainkeys index d59cff1..016cc08 100644 --- a/plugins/domainkeys +++ b/plugins/domainkeys @@ -10,6 +10,10 @@ domainkeys: validate a DomainKeys signature on an incoming mail Performs a DomainKeys validation on the message. +=head1 DEPRECATION + +You should probably not be using this plugin. DomainKeys has been deprecated in favor of DKIM. That being said, it's March 2013 and I'll still seeing quite a few hams arrive with DomainKeys signatures. + =head1 CONFIGURATION =head2 reject From b8df80d3988043f9feaf0e82978307dcd1b2c3af Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Thu, 28 Mar 2013 17:47:18 -0400 Subject: [PATCH 235/352] dkim: added message signing feature --- plugins/dkim | 226 +++++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 182 insertions(+), 44 deletions(-) diff --git a/plugins/dkim b/plugins/dkim index 0633141..354d1f8 100644 --- a/plugins/dkim +++ b/plugins/dkim @@ -6,17 +6,17 @@ dkim: validate DomainKeys and (DKIM) Domain Keys Indentified Messages =head1 SYNOPSIS -Validate the DKIM and Domainkeys signatures of a message, and enforce DKIM -sending policies. +Validate the DKIM and Domainkeys signatures of a message, enforce DKIM +sending policies, and DKIM sign outgoing messages. =head1 CONFIGURATION -=head2 reject [ 0 | 1 ] +=head2 reject [ 0 | 1 | naughty ] - dkim reject 1 + dkim reject 0 -Reject is a boolean that toggles message rejection on or off. Messages failing -validation are rejected by default. +Reject is a boolean that toggles message rejection on or off, or naughty, +which offloads a deferred rejection to the B plugin. Default: 1 @@ -26,11 +26,72 @@ Default: 1 Default: perm +=head1 HOW TO SIGN + +=head2 generate DKIM key(s) + + mkdir -p ~smtpd/config/dkim/example.org + cd ~smtpd/config/dkim/example.org + echo 'mar2013' > selector + openssl genrsa -out private 2048 + chmod 400 private + openssl rsa -in private -out public -pubout + chown -R smtpd:smtpd ~smtpd/config/dkim/example.org + +After running the commands, you'll have a directory with three files: + + example.org + example.org/selector + example.org/private + example.org/public + +=head3 selector + +The selector can be any value that is a valid DNS label. + +=head3 key length + +The minimum recommended key length for short duration keys (ones that will be replaced within a few months) is 1024. If you are unlikely to rotate your keys frequently, go with 2048, at the expense of more CPU. + +=head2 publish public key in DNS + + mar2013._domainkey TXT "v=DKIM1;p=[public key stripped of whitespace];" + + hash: h=[ sha1 | sha256 ] + test; t=[ s | s:y ] + granularity: g=[ ] + notes: n=[ ] + services: s=[email] + keytypes: [ rsa ] + +Prepare the DNS record with these commands: + + cd ~smtpd/config/dkim/example.org + cat selector | tr -d "\n" > dns + echo -n '._domainkey TXT "v=DKIM1;p=' >> dns + grep -v -e '^-' public | tr -d "\n" >> dns + echo '"' >> dns + +The contents of I are ready to be copy/pasted into a BIND zone file, or better yet, NicTool, and published to most any DNS server. + +=head2 testing + +After confirming that the DKIM public key can be fetched with DNS, send test messages via QP to a Gmail box and check the Authentication-Results header. There are also DKIM relays (check-auth@verifier.port25.com, checkmyauth@auth.returnpath.net) that provide more debugging information in a nice email report. + +=head2 Sign for others + +Following the directions above will configure QP to DKIM sign messages from authenticated senders from example.org. Suppose you host client.com and would like to DKIM sign their messages too? Do that as follows: + + cd ~smtpd/config/dkim/example.org + ln -s example.org client.com + +QP will follow the symlink target and sign client.com emails with the example.org DKIM key. + =head1 SEE ALSO http://www.dkim.org/ -http://tools.ietf.org/html/rfc6376 - DKIM Signatures +http://tools.ietf.org/html/rfc6376 - DKIM Signatures http://tools.ietf.org/html/rfc5863 - DKIM Development, Deployment, & Operations @@ -40,10 +101,14 @@ http://tools.ietf.org/html/rfc5585 - DKIM Service Overview http://tools.ietf.org/html/rfc5016 - DKIM Signing Practices Protocol -http://tools.ietf.org/html/rfc4871 - DKIM Signatures +http://tools.ietf.org/html/rfc4871 - DKIM Signatures http://tools.ietf.org/html/rfc4870 - DomainKeys +http://dkimcore.org/tools/ + +http://www.protodave.com/tools/dkim-key-checker/ + =head1 AUTHORS 2012 - Matt Simerson - initial plugin @@ -88,11 +153,13 @@ sub init { sub register { my $self = shift; - eval "use Mail::DKIM::Verifier"; - if ( $@ ) { - warn "skip, plugin disabled, could not load Mail::DKIM::Verifier\n"; - $self->log(LOGERROR, "skip, plugin disabled, is Mail::DKIM installed?"); - return; + foreach my $mod ( qw/ Mail::DKIM::Verifier Mail::DKIM::Signer Mail::DKIM::TextWrap / ) { + eval "use $mod"; + if ( $@ ) { + warn "error, plugin disabled, could not load $mod\n"; + $self->log(LOGERROR, "skip, plugin disabled, is Mail::DKIM installed?"); + return; + }; }; $self->register_hook('data_post', 'data_post_handler'); @@ -101,14 +168,27 @@ sub register { sub data_post_handler { my ($self, $transaction) = @_; + if ( $self->qp->connection->relay_client() ) { + # this is one of our authenticated users sending a message. + return $self->sign_it( $transaction ); + }; + return DECLINED if $self->is_immune(); + return $self->validate_it( $transaction ); +}; + +sub validate_it { + my ($self, $transaction) = @_; + + # Incoming message, perform DKIM validation my $dkim = Mail::DKIM::Verifier->new() or do { $self->log(LOGERROR, "error, could not instantiate a new Mail::DKIM::Verifier"); return DECLINED; }; - my $result = $self->get_dkim_result( $dkim, $transaction ); + $self->send_message_to_dkim( $dkim, $transaction ); + my $result = $dkim->result; my $mess = $self->get_details( $dkim ); foreach my $r ( qw/ pass fail invalid temperror none / ) { @@ -123,6 +203,30 @@ sub data_post_handler { return DECLINED; } +sub sign_it { + my ($self, $transaction) = @_; + + my ($domain, $keydir) = $self->get_keydir($transaction) or return DECLINED; + my $selector = $self->get_selector($keydir); + + my $dkim = Mail::DKIM::Signer->new( + Algorithm => "rsa-sha256", + Method => "relaxed", + Domain => $domain, + Selector => $selector, + KeyFile => "$keydir/private", + ); + + $self->send_message_to_dkim( $dkim, $transaction ); + + my $signature = $dkim->signature; # what is the signature result? + $self->qp->transaction->header->add( + 'DKIM-Signature', $signature->as_string, 0 ); + + $self->log(LOGINFO, "pass, signed message, ", $signature->as_string ); + return DECLINED; +}; + sub get_details { my ($self, $dkim ) = @_; @@ -166,16 +270,14 @@ sub handle_sig_invalid { my ( $prs, $policies) = $self->get_policy_results( $dkim ); - if ( ! $self->qp->connection->relay_client() ) { - foreach my $policy ( @$policies ) { - if ( $policy->signall && ! $policy->is_implied_default_policy ) { - $self->log(LOGINFO, $mess ); - return $self->get_reject( - "invalid DKIM signature with sign-all policy", - "invalid signature, sign-all policy" - ); - } - }; + foreach my $policy ( @$policies ) { + if ( $policy->signall && ! $policy->is_implied_default_policy ) { + $self->log(LOGINFO, $mess ); + return $self->get_reject( + "invalid DKIM signature with sign-all policy", + "invalid signature, sign-all policy" + ); + } }; $self->adjust_karma( -1 ); @@ -192,9 +294,9 @@ sub handle_sig_invalid { return DECLINED; } elsif ( $prs->{reject} ) { - return $self->get_reject( + return $self->get_reject( "invalid DKIM signature: " . $dkim->result_detail, - "invalid signature, reject policy" + "fail, invalid signature, reject policy" ); } @@ -242,16 +344,14 @@ sub handle_sig_none { my ( $prs, $policies) = $self->get_policy_results( $dkim ); - if ( ! $self->qp->connection->relay_client() ) { - foreach my $policy ( @$policies ) { - if ( $policy->signall && ! $policy->is_implied_default_policy ) { - $self->log(LOGINFO, $mess ); - return $self->get_reject( - "no DKIM signature with sign-all policy", - "no signature, sign-all policy" - ); - } - }; + foreach my $policy ( @$policies ) { + if ( $policy->signall && ! $policy->is_implied_default_policy ) { + $self->log(LOGINFO, $mess ); + return $self->get_reject( + "no DKIM signature with sign-all policy", + "no signature, sign-all policy" + ); + } }; if ( $prs->{accept} ) { @@ -264,7 +364,7 @@ sub handle_sig_none { } elsif ( $prs->{reject} ) { $self->log(LOGINFO, $mess ); - $self->get_reject( + $self->get_reject( "no DKIM signature, policy says reject: " . $dkim->result_detail, "no signature, reject policy" ); @@ -276,9 +376,35 @@ sub handle_sig_none { return DECLINED; }; -sub get_dkim_result { - my $self = shift; - my ($dkim, $transaction) = @_; +sub get_keydir { + my ($self, $transaction) = @_; + + my $domain = $transaction->sender->host; + my $dir = "config/dkim/$domain"; + + if ( -l $dir ) { + $dir = readlink($dir); + $dir = "config/dkim/$dir" if $dir !~ /\//; # no /, relative path + ($domain) = (split /\//, $dir)[-1]; + }; + + if ( ! -d $dir ) { + $self->log(LOGINFO, "skip, DKIM not configured for $domain"); + return; + }; + if ( ! -r $dir ) { + $self->log(LOGINFO, "error, unable to read key from $dir"); + return; + }; + if ( ! -r "$dir/private" ) { + $self->log(LOGINFO, "error, unable to read dkim key from $dir/private"); + return; + }; + return ($domain, $dir); +}; + +sub send_message_to_dkim { + my ($self, $dkim, $transaction) = @_; foreach ( split ( /\n/s, $transaction->header->as_string ) ) { $_ =~ s/\r?$//s; @@ -289,14 +415,12 @@ sub get_dkim_result { $transaction->body_resetpos; while (my $line = $transaction->body_getline) { chomp $line; - s/\015$//; + $line =~ s/\015$//; eval { $dkim->PRINT($line . CRLF ); }; $self->log(LOGERROR, $@ ) if $@; }; $dkim->CLOSE; - - return $dkim->result; }; sub get_policies { @@ -326,11 +450,25 @@ sub get_policy_results { return \%prs, \@policies; }; +sub get_selector { + my ($self, $keydir) = @_; + + open my $SFH, '<', "$keydir/selector" or do { + $self->log(LOGINFO, "error, unable to read selector from $keydir/selector"); + return DECLINED; + }; + my $selector = <$SFH>; + chomp $selector; + close $SFH; + $self->log(LOGINFO, "info, selector: $selector"); + return $selector; +}; + sub add_header { my $self = shift; my $header = shift or return; -# consider adding Authentication-Results header here as well +# consider adding Authentication-Results header, (RFC 5451) $self->qp->transaction->header->add( 'X-DKIM-Authentication', $header, 0 ); } From 2f72f419c3c2162c42518c49bb1788a6aafd1394 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sun, 14 Apr 2013 21:42:21 -0400 Subject: [PATCH 236/352] dkim: improve POD, add dkim_key_gen.sh --- config.sample/dkim/dkim_key_gen.sh | 60 +++++++++++++++++++++++++ plugins/dkim | 71 ++++++++++++++++++++---------- 2 files changed, 108 insertions(+), 23 deletions(-) create mode 100755 config.sample/dkim/dkim_key_gen.sh diff --git a/config.sample/dkim/dkim_key_gen.sh b/config.sample/dkim/dkim_key_gen.sh new file mode 100755 index 0000000..759ffe8 --- /dev/null +++ b/config.sample/dkim/dkim_key_gen.sh @@ -0,0 +1,60 @@ +#!/bin/sh + +usage() { + echo " usage: $0 [qpsmtpd username]" + echo " " + exit +} + +if [ -z $1 ]; +then + usage +fi + +DOMAIN=$1 +SMTPD=$2 +if [ -z $SMTPD ]; +then + SMTPD="smtpd" +fi + +# create a directory for each DKIM signing domain +mkdir -p $DOMAIN +cd $DOMAIN + +# create a selector in the format mmmYYYY (apr2013) +date '+%h%Y' | tr "[:upper:]" "[:lower:]" > selector + +# generate a private and public keys +openssl genrsa -out private 2048 +chmod 400 private +openssl rsa -in private -out public -pubout + +# make it really easy to publish the public key in DNS +cat > dns < plugin. + 0 - do not reject + 1 - reject messages that fail DKIM policy + naughty - defer rejection to the B plugin Default: 1 @@ -28,22 +29,23 @@ Default: perm =head1 HOW TO SIGN -=head2 generate DKIM key(s) +=head2 generate DKIM keys + +=head3 the easy way + + cd ~smtpd/config/dkim; ./dkim_key_gen.sh example.org + +=head3 the manual way mkdir -p ~smtpd/config/dkim/example.org cd ~smtpd/config/dkim/example.org - echo 'mar2013' > selector + echo 'may2013' > selector openssl genrsa -out private 2048 chmod 400 private openssl rsa -in private -out public -pubout - chown -R smtpd:smtpd ~smtpd/config/dkim/example.org + chown -R smtpd:smtpd ../example.org -After running the commands, you'll have a directory with three files: - - example.org - example.org/selector - example.org/private - example.org/public +After generating the keys, there will be three files in the example.org directory: selector, private, and public. =head3 selector @@ -51,11 +53,19 @@ The selector can be any value that is a valid DNS label. =head3 key length -The minimum recommended key length for short duration keys (ones that will be replaced within a few months) is 1024. If you are unlikely to rotate your keys frequently, go with 2048, at the expense of more CPU. +The minimum recommended key length for short duration keys (ones that will be replaced within a few months) is 1024. If you are unlikely to rotate your keys frequently, go with 2048, at the expense of a bit more CPU. =head2 publish public key in DNS - mar2013._domainkey TXT "v=DKIM1;p=[public key stripped of whitespace];" +If the DKIM keys were generated the easy way, there will be a fourth file named I. The contents contain the DNS formatted record of the public key, as well as suggestions for DKIM, SPF, and DMARC policy records. The records are ready to be copy/pasted into a BIND zone file, or better yet, NicTool, and published to most any DNS server. If you didn't create your keys the easy way, look inside the dkim_key_gen.sh script to see the commands used to format the DKIM public key. + +The example DKIM, SPF, and DMARC policy records in the I file are strict, telling other mail servers that if a sender claims to be from example.org, but the message is not DKIM signed and not SPF aligned, then the message should be rejected. Many email servers, including the largest email providers (Gmail, Yahoo, Outlook/Live/Hotmail) will refuse to accept such messages, greatly reducing the harm caused by miscreants who send out spam with your domain name in the From header. + +The DKIM record will look like this: + + may2013._domainkey TXT "v=DKIM1;p=[public key stripped of whitespace];" + +And the values in the address have the following meaning: hash: h=[ sha1 | sha256 ] test; t=[ s | s:y ] @@ -64,19 +74,30 @@ The minimum recommended key length for short duration keys (ones that will be re services: s=[email] keytypes: [ rsa ] -Prepare the DNS record with these commands: - - cd ~smtpd/config/dkim/example.org - cat selector | tr -d "\n" > dns - echo -n '._domainkey TXT "v=DKIM1;p=' >> dns - grep -v -e '^-' public | tr -d "\n" >> dns - echo '"' >> dns - -The contents of I are ready to be copy/pasted into a BIND zone file, or better yet, NicTool, and published to most any DNS server. =head2 testing -After confirming that the DKIM public key can be fetched with DNS, send test messages via QP to a Gmail box and check the Authentication-Results header. There are also DKIM relays (check-auth@verifier.port25.com, checkmyauth@auth.returnpath.net) that provide more debugging information in a nice email report. +After confirming that the DKIM public key can be fetched with DNS (dig TXT may2013._domainkey.example.org. @ns1.example.org.), send test messages. There are a number of ways to test your DKIM: + + * email to a Gmail address and inspect the Authentication-Results header. + * email to check-auth@verifier.port25.com + * email to checkmyauth@auth.returnpath.net + +The two DKIM relays provide a nice email report with additional debugging information. + +=head2 publish DKIM policy in DNS + +_domainkey TXT "o=~; t=y; r=postmaster@example.org" + + o=- - all are signed + o=~ - some are signed + t=y - test mode + r=[email] - responsible email address + n=[notes] + +Once DKIM and SPF are tested and working, update the policy, changing o=~ to o=-, so that other mail servers reject unsigned messages claiming to be from your domain. + +As of this writing, most mail servers do not reject messages that fail DKIM policy, unless they also fail SPF, and no DMARC policy is published. The same holds true for SPF. There are technical reasons for this. See DMARC for more information, how you can control change that behavior, as well as receiving feedback from remote servers about messages they have accepted and rejected from senders claiming the identity of your domain(s). =head2 Sign for others @@ -87,6 +108,8 @@ Following the directions above will configure QP to DKIM sign messages from auth QP will follow the symlink target and sign client.com emails with the example.org DKIM key. +CAUTION: just because you can, doesn't mean you should. Even with a relaxed DKIM policy, if you don't have a suitable DMARC record published for client.com, they may encounter deliverability problems. It is better to have keys generated and published for each domain. + =head1 SEE ALSO http://www.dkim.org/ @@ -111,6 +134,8 @@ http://www.protodave.com/tools/dkim-key-checker/ =head1 AUTHORS + 2013 - Matt Simerson - added DKIM signing and key creation script + 2012 - Matt Simerson - initial plugin =head1 ACKNOWLEDGEMENTS From a49a45fd10f68d6941d84cec6c0625fe954c51a1 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sun, 14 Apr 2013 21:42:42 -0400 Subject: [PATCH 237/352] SPF: POD formatting fix --- plugins/sender_permitted_from | 1 + 1 file changed, 1 insertion(+) diff --git a/plugins/sender_permitted_from b/plugins/sender_permitted_from index a527b25..fba7e32 100644 --- a/plugins/sender_permitted_from +++ b/plugins/sender_permitted_from @@ -47,6 +47,7 @@ The reject options are modeled after, and aim to match the functionality of thos =head1 AUTHOR Matt Simerson - 2012 - increased policy options from 3 to 6 + Matt Simerson - 2011 - rewrote using Mail::SPF Matt Sergeant - 2003 - initial plugin From 9715e00187770a2698175cafa510d060393dcd54 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 20 Apr 2013 16:08:19 -0400 Subject: [PATCH 238/352] a collection of DKIM enhancements * disable Mail::DKIM::TextWrap (causes mangled messages for some clients) * pod improvements * don't log the entire DKIM signature when signing * add dkim_pass_domains connection note with DKIM signer domains that pass * enable dkim tests --- config.sample/dkim/dkim_key_gen.sh | 10 ++-- plugins/dkim | 86 ++++++++++++++++++++---------- t/config/plugins | 1 + 3 files changed, 64 insertions(+), 33 deletions(-) diff --git a/config.sample/dkim/dkim_key_gen.sh b/config.sample/dkim/dkim_key_gen.sh index 759ffe8..586f30e 100755 --- a/config.sample/dkim/dkim_key_gen.sh +++ b/config.sample/dkim/dkim_key_gen.sh @@ -35,9 +35,7 @@ cat > dns < plugin + 0 - do not reject + 1 - reject messages that fail DKIM policy + naughty - defer rejection to the B plugin Default: 1 @@ -53,13 +53,13 @@ The selector can be any value that is a valid DNS label. =head3 key length -The minimum recommended key length for short duration keys (ones that will be replaced within a few months) is 1024. If you are unlikely to rotate your keys frequently, go with 2048, at the expense of a bit more CPU. +The minimum recommended key length for short duration keys (ones that will be replaced within a few months) is 1024. If you are unlikely to rotate your keys frequently, choose 2048, at the expense of a bit more CPU. =head2 publish public key in DNS -If the DKIM keys were generated the easy way, there will be a fourth file named I. The contents contain the DNS formatted record of the public key, as well as suggestions for DKIM, SPF, and DMARC policy records. The records are ready to be copy/pasted into a BIND zone file, or better yet, NicTool, and published to most any DNS server. If you didn't create your keys the easy way, look inside the dkim_key_gen.sh script to see the commands used to format the DKIM public key. +If the DKIM keys were generated the easy way, there will be a fourth file named I. The contents contain the DNS formatted record of the public key, as well as suggestions for DKIM, SPF, and DMARC policy records. The records are ready to be copy/pasted into a BIND zone file, or better yet, NicTool. If you created your keys manually, look in the dkim_key_gen.sh script to see the commands used to format the DKIM public key. -The example DKIM, SPF, and DMARC policy records in the I file are strict, telling other mail servers that if a sender claims to be from example.org, but the message is not DKIM signed and not SPF aligned, then the message should be rejected. Many email servers, including the largest email providers (Gmail, Yahoo, Outlook/Live/Hotmail) will refuse to accept such messages, greatly reducing the harm caused by miscreants who send out spam with your domain name in the From header. +The combination of the three example DKIM, SPF, and DMARC policy records in the I file tell other mail servers that if a sender claims to be from example.org, but the message is not DKIM nor SPF aligned, then the message should be rejected. Many email servers, including the largest email providers (Gmail, Yahoo, Outlook/Live/Hotmail) will refuse to accept such messages, greatly reducing the harm caused by miscreants who forge your domain(s) in the From header of their spam. The DKIM record will look like this: @@ -74,14 +74,13 @@ And the values in the address have the following meaning: services: s=[email] keytypes: [ rsa ] - =head2 testing -After confirming that the DKIM public key can be fetched with DNS (dig TXT may2013._domainkey.example.org. @ns1.example.org.), send test messages. There are a number of ways to test your DKIM: +After confirming that the DKIM public key can be fetched with DNS (dig TXT may2013._domainkey.example.org. @ns1.example.org.), send test messages. You can testing DKIM by sending an email to: - * email to a Gmail address and inspect the Authentication-Results header. - * email to check-auth@verifier.port25.com - * email to checkmyauth@auth.returnpath.net + * a Gmail address and inspect the Authentication-Results header. + * check-auth@verifier.port25.com + * checkmyauth@auth.returnpath.net The two DKIM relays provide a nice email report with additional debugging information. @@ -95,20 +94,22 @@ _domainkey TXT "o=~; t=y; r=postmaster@example.org" r=[email] - responsible email address n=[notes] -Once DKIM and SPF are tested and working, update the policy, changing o=~ to o=-, so that other mail servers reject unsigned messages claiming to be from your domain. +After DKIM and SPF are tested and working, update the policy, changing o=~ to o=-, so that other mail servers reject unsigned messages claiming to be from your domain. As of this writing, most mail servers do not reject messages that fail DKIM policy, unless they also fail SPF, and no DMARC policy is published. The same holds true for SPF. There are technical reasons for this. See DMARC for more information, how you can control change that behavior, as well as receiving feedback from remote servers about messages they have accepted and rejected from senders claiming the identity of your domain(s). =head2 Sign for others -Following the directions above will configure QP to DKIM sign messages from authenticated senders from example.org. Suppose you host client.com and would like to DKIM sign their messages too? Do that as follows: +Following the directions above will configure QP to DKIM sign messages from authenticated senders of example.org. Suppose you host client.com and would like to DKIM sign their messages too? Do that as follows: - cd ~smtpd/config/dkim/example.org + cd ~smtpd/config/dkim ln -s example.org client.com QP will follow the symlink target and sign client.com emails with the example.org DKIM key. -CAUTION: just because you can, doesn't mean you should. Even with a relaxed DKIM policy, if you don't have a suitable DMARC record published for client.com, they may encounter deliverability problems. It is better to have keys generated and published for each domain. +This is B necessary for hosts or subdomains. If the DKIM key for host.example.com does not exist, and a key for example.com does exist, the parent DKIM key will be used to sign the message. So long as your DKIM and DMARC policies are set to relaxed alignment, these signed messages for subdomains will pass. + +CAUTION: just because you can sign for other domains, doesn't mean you should. Even with a relaxed DKIM policy, if the other domain doesn't have a suitable DMARC record for client.com, they may encounter deliverability problems. It is better to have keys generated and published for each domain. =head1 SEE ALSO @@ -148,14 +149,14 @@ I first attempted to fix the dkimcheck plugin, but soon scrapped that effort and =over 4 -The nine 'if' brackets with 19 conditionals, and my inability to easily determine which of the 15 possible permutations (5 signature validation results x 3 possible policy results) were covered. - The use of $dkim->fetch_author_policy, which is deprecated by Mail::DKIM. -The paradim of a single policy, when DKIM supports 0 or many. Although I may yet implement the 'local' policy idea, so long as I'm confident it will never result in a false positive. +The paradim of a single policy, when DKIM supports 0 or many. The OBF programming style, which is nigh impossible to test. +The nine 'if' brackets with 19 conditionals, and my inability to easily determine which of the 15 possible permutations (5 signature validation results x 3 possible policy results) were covered. + =back =cut @@ -166,6 +167,7 @@ use warnings; use Qpsmtpd::Constants; # use Mail::DKIM::Verifier; # eval'ed in register() +# use Mail::DKIM::Signer; use Socket qw(:DEFAULT :crlf); sub init { @@ -178,7 +180,8 @@ sub init { sub register { my $self = shift; - foreach my $mod ( qw/ Mail::DKIM::Verifier Mail::DKIM::Signer Mail::DKIM::TextWrap / ) { + # Mail::DKIM::TextWrap - nice idea, clients get mangled headers though + foreach my $mod ( qw/ Mail::DKIM::Verifier Mail::DKIM::Signer / ) { eval "use $mod"; if ( $@ ) { warn "error, plugin disabled, could not load $mod\n"; @@ -194,7 +197,7 @@ sub data_post_handler { my ($self, $transaction) = @_; if ( $self->qp->connection->relay_client() ) { - # this is one of our authenticated users sending a message. + # this is an authenticated user sending a message. return $self->sign_it( $transaction ); }; @@ -216,15 +219,14 @@ sub validate_it { my $result = $dkim->result; my $mess = $self->get_details( $dkim ); - foreach my $r ( qw/ pass fail invalid temperror none / ) { - my $handler = 'handle_sig_' . $r; - if ( $result eq $r && $self->can( $handler ) ) { - #$self->log(LOGINFO, "dispatching $result to $handler"); - return $self->$handler( $dkim, $mess ); - }; + foreach my $t ( qw/ pass fail invalid temperror none / ) { + next if $t ne $result; + my $handler = 'handle_sig_' . $t; + $self->log(LOGDEBUG, "dispatching $result to $handler"); + return $self->$handler( $dkim, $mess ); }; - $self->log( LOGERROR, "unknown result: $result, $mess" ); + $self->log( LOGERROR, "error, unknown result: $result, $mess" ); return DECLINED; } @@ -248,7 +250,7 @@ sub sign_it { $self->qp->transaction->header->add( 'DKIM-Signature', $signature->as_string, 0 ); - $self->log(LOGINFO, "pass, signed message, ", $signature->as_string ); + $self->log(LOGINFO, "pass, we signed the message" ); return DECLINED; }; @@ -334,6 +336,8 @@ sub handle_sig_invalid { sub handle_sig_pass { my ( $self, $dkim, $mess ) = @_; + $self->save_signatures_to_note( $dkim ); + my ($prs) = $self->get_policy_results( $dkim ); if ( $prs->{accept} ) { @@ -407,6 +411,18 @@ sub get_keydir { my $domain = $transaction->sender->host; my $dir = "config/dkim/$domain"; + if ( ! -e $dir ) { # the dkim key dir doesn't exist + my @labels = split /\./, $domain; # split the domain into labels + while ( @labels > 1 ) { + shift @labels; # remove the first label (ie: www) + my $zone = join '.', @labels; # reassemble the labels + if ( -e "config/dkim/$zone" ) { # if the directory exists + $dir = "config/dkim/$zone"; # use the parent domain's key + $self->log(LOGINFO, "info, using $zone key for $domain"); + }; + }; + }; + if ( -l $dir ) { $dir = readlink($dir); $dir = "config/dkim/$dir" if $dir !~ /\//; # no /, relative path @@ -428,6 +444,18 @@ sub get_keydir { return ($domain, $dir); }; +sub save_signatures_to_note { + my ( $self, $dkim ) = @_; + + foreach my $sig ( $dkim->signatures ) { + next if $sig->result ne 'pass'; + my $doms = $self->connection->notes('dkim_pass_domains') || []; + push @$doms, $sig->domain; + $self->connection->notes('dkim_pass_domains', $doms); + $self->log(LOGINFO, "info, added " . $sig->domain ); + }; +}; + sub send_message_to_dkim { my ($self, $dkim, $transaction) = @_; diff --git a/t/config/plugins b/t/config/plugins index c4f25d6..0c3ea77 100644 --- a/t/config/plugins +++ b/t/config/plugins @@ -58,6 +58,7 @@ rcpt_ok headers days 5 reject_type temp require From,Date domainkeys +dkim # content filters virus/klez_filter From 5b6f2b96281bd3aed5aa522e91e89664acc3520a Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 20 Apr 2013 16:11:52 -0400 Subject: [PATCH 239/352] watch: set OUTPUT_AUTOFLUSH, disabled buffering --- log/watch | 2 ++ 1 file changed, 2 insertions(+) diff --git a/log/watch b/log/watch index 427f58f..6ba3cdd 100755 --- a/log/watch +++ b/log/watch @@ -3,6 +3,8 @@ use strict; use warnings; +$|++; # OUTPUT_AUTOFLUSH + use Cwd; use Data::Dumper; use File::Tail; From 0a542c51b5ca96131825139e9779ff1907489ee4 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 20 Apr 2013 16:13:51 -0400 Subject: [PATCH 240/352] domainkeys: fixed pod grammar error --- plugins/domainkeys | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/domainkeys b/plugins/domainkeys index 016cc08..b01a814 100644 --- a/plugins/domainkeys +++ b/plugins/domainkeys @@ -12,7 +12,7 @@ Performs a DomainKeys validation on the message. =head1 DEPRECATION -You should probably not be using this plugin. DomainKeys has been deprecated in favor of DKIM. That being said, it's March 2013 and I'll still seeing quite a few hams arrive with DomainKeys signatures. +You should probably NOT be using this plugin. DomainKeys has been deprecated in favor of DKIM. That being said, it's March 2013 and I'm still seeing ham arrive with DomainKeys signatures. =head1 CONFIGURATION From ca38ff5d6fc1bbbc29f7c01b5bde59821327c2e0 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 20 Apr 2013 16:23:05 -0400 Subject: [PATCH 241/352] SPF: add trans. note spf_pass_host if SPF=pass --- plugins/sender_permitted_from | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/plugins/sender_permitted_from b/plugins/sender_permitted_from index fba7e32..fc78217 100644 --- a/plugins/sender_permitted_from +++ b/plugins/sender_permitted_from @@ -40,17 +40,20 @@ SPF levels above 4 are for crusaders who don't mind rejecting some valid mail wh http://spf.pobox.com/ http://en.wikipedia.org/wiki/Sender_Policy_Framework +=head1 TODO + +Check the scope of the SPF policy. If it's too broad (ie, the whole internet is valid), apply karma penalty +Examples of too broad: +all, + =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 - 2012 - increased policy options from 3 to 6 - -Matt Simerson - 2011 - rewrote using Mail::SPF - -Matt Sergeant - 2003 - initial plugin + Matt Simerson - 2012 - increased policy options from 3 to 6 + Matt Simerson - 2011 - rewrote using Mail::SPF + Matt Sergeant - 2003 - initial plugin =cut @@ -155,6 +158,7 @@ sub mail_handler { } elsif ( $code eq 'pass' ) { $self->adjust_karma( 1 ); + $transaction->notes('spf_pass_host', lc $sender->host); $self->log(LOGINFO, "pass, $code: $why" ); return (DECLINED); } @@ -224,6 +228,9 @@ sub data_post_handler { my $result = $transaction->notes('spfquery') or return DECLINED; +# if we skipped processing in mail_handler, we should skip here too + return (DECLINED) if $self->is_immune(); + $self->log(LOGDEBUG, "result was $result->code"); if ( ! $transaction->header ) { From c58404c3c47046df422d3e0c1e4078ad21d6cb36 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 20 Apr 2013 16:25:04 -0400 Subject: [PATCH 242/352] SPF: add pod, documenting spf_pass_host note --- plugins/sender_permitted_from | 2 ++ 1 file changed, 2 insertions(+) diff --git a/plugins/sender_permitted_from b/plugins/sender_permitted_from index fc78217..1978f91 100644 --- a/plugins/sender_permitted_from +++ b/plugins/sender_permitted_from @@ -8,6 +8,8 @@ SPF - implement Sender Permitted From Prevents email sender address spoofing by checking the SPF policy of the purported senders domain. +Sets the transaction note spf_pass_host if the SPF result is pass. + =head1 DESCRIPTION Sender Policy Framework (SPF) is an email validation system designed to prevent source address spoofing. SPF allows administrators to specify which hosts are allowed to send email from a given domain by creating a specific SPF record in the public DNS. Mail exchangers then use the DNS to verify that mail is being sent by a host sanctioned by a given domain administrators. -- http://en.wikipedia.org/wiki/Sender_Policy_Framework From 42296b950c6e2eb0ecb487fa096f58ea40a2f8bc Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 20 Apr 2013 16:27:14 -0400 Subject: [PATCH 243/352] tls: added ability to store certs in config/ssl was hard coded to ./ssl --- plugins/tls | 33 +++++++++++++++++---------------- 1 file changed, 17 insertions(+), 16 deletions(-) diff --git a/plugins/tls b/plugins/tls index 8991230..75c6751 100644 --- a/plugins/tls +++ b/plugins/tls @@ -45,7 +45,7 @@ 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 +give absolute pathnames to the certificate, key, and the CA root cert used to sign that certificate. =head1 CIPHERS and COMPATIBILITY @@ -63,9 +63,10 @@ use IO::Socket::SSL 0.98; sub init { my ($self, $qp, $cert, $key, $ca) = @_; - $cert ||= 'ssl/qpsmtpd-server.crt'; - $key ||= 'ssl/qpsmtpd-server.key'; - $ca ||= 'ssl/qpsmtpd-ca.crt'; + my $dir = -d 'ssl' ? 'ssl' : 'config/ssl'; + $cert ||= "$dir/qpsmtpd-server.crt"; + $key ||= "$dir/qpsmtpd-server.key"; + $ca ||= "$dir/qpsmtpd-ca.crt"; unless ( -f $cert && -f $key && -f $ca ) { $self->log(LOGERROR, "Cannot locate cert/key! Run plugins/tls_cert to generate"); return; @@ -74,7 +75,7 @@ sub init { $self->tls_key($key); $self->tls_ca($ca); $self->tls_ciphers($self->qp->config('tls_ciphers') || 'HIGH'); - + $self->log(LOGDEBUG, "ciphers: ".$self->tls_ciphers); local $^W; # this bit is very noisy... @@ -87,9 +88,9 @@ sub init { 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'; @@ -120,20 +121,20 @@ sub hook_ehlo { sub hook_unrecognized_command { my ($self, $transaction, $cmd, @args) = @_; - return DECLINED unless $cmd eq 'starttls'; + return DECLINED unless lc $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; } @@ -143,7 +144,7 @@ sub hook_connect { 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"); } @@ -182,7 +183,7 @@ sub _convert_to_ssl { 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; @@ -283,18 +284,18 @@ sub upgrade_socket { 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; From 74edee110146c859c6f7c450f07f6f43efb3cde5 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 20 Apr 2013 16:30:06 -0400 Subject: [PATCH 244/352] new plugin: dmarc --- config.sample/plugins | 1 + config.sample/public_suffix_list | 6998 ++++++++++++++++++++++++++++++ log/summarize | 1 + plugins/dmarc | 401 ++ plugins/registry.txt | 1 + t/config/public_suffix_list | 6998 ++++++++++++++++++++++++++++++ t/plugin_tests/dmarc | 68 + 7 files changed, 14468 insertions(+) create mode 100644 config.sample/public_suffix_list create mode 100644 plugins/dmarc create mode 100644 t/config/public_suffix_list create mode 100644 t/plugin_tests/dmarc diff --git a/config.sample/plugins b/config.sample/plugins index 24177b8..e59bcae 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -71,6 +71,7 @@ headers reject 0 reject_type temp require From,Date future 2 past 15 bogus_bounce log #loop dkim reject 0 +dmarc # content filters virus/klez_filter diff --git a/config.sample/public_suffix_list b/config.sample/public_suffix_list new file mode 100644 index 0000000..fdcd84e --- /dev/null +++ b/config.sample/public_suffix_list @@ -0,0 +1,6998 @@ +// This Source Code Form is subject to the terms of the Mozilla Public +// License, v. 2.0. If a copy of the MPL was not distributed with this +// file, You can obtain one at http://mozilla.org/MPL/2.0/. + +// ===BEGIN ICANN DOMAINS=== + +// ac : http://en.wikipedia.org/wiki/.ac +ac +com.ac +edu.ac +gov.ac +net.ac +mil.ac +org.ac + +// ad : http://en.wikipedia.org/wiki/.ad +ad +nom.ad + +// ae : http://en.wikipedia.org/wiki/.ae +// see also: "Domain Name Eligibility Policy" at http://www.aeda.ae/eng/aepolicy.php +ae +co.ae +net.ae +org.ae +sch.ae +ac.ae +gov.ae +mil.ae + +// aero : see http://www.information.aero/index.php?id=66 +aero +accident-investigation.aero +accident-prevention.aero +aerobatic.aero +aeroclub.aero +aerodrome.aero +agents.aero +aircraft.aero +airline.aero +airport.aero +air-surveillance.aero +airtraffic.aero +air-traffic-control.aero +ambulance.aero +amusement.aero +association.aero +author.aero +ballooning.aero +broker.aero +caa.aero +cargo.aero +catering.aero +certification.aero +championship.aero +charter.aero +civilaviation.aero +club.aero +conference.aero +consultant.aero +consulting.aero +control.aero +council.aero +crew.aero +design.aero +dgca.aero +educator.aero +emergency.aero +engine.aero +engineer.aero +entertainment.aero +equipment.aero +exchange.aero +express.aero +federation.aero +flight.aero +freight.aero +fuel.aero +gliding.aero +government.aero +groundhandling.aero +group.aero +hanggliding.aero +homebuilt.aero +insurance.aero +journal.aero +journalist.aero +leasing.aero +logistics.aero +magazine.aero +maintenance.aero +marketplace.aero +media.aero +microlight.aero +modelling.aero +navigation.aero +parachuting.aero +paragliding.aero +passenger-association.aero +pilot.aero +press.aero +production.aero +recreation.aero +repbody.aero +res.aero +research.aero +rotorcraft.aero +safety.aero +scientist.aero +services.aero +show.aero +skydiving.aero +software.aero +student.aero +taxi.aero +trader.aero +trading.aero +trainer.aero +union.aero +workinggroup.aero +works.aero + +// af : http://www.nic.af/help.jsp +af +gov.af +com.af +org.af +net.af +edu.af + +// ag : http://www.nic.ag/prices.htm +ag +com.ag +org.ag +net.ag +co.ag +nom.ag + +// ai : http://nic.com.ai/ +ai +off.ai +com.ai +net.ai +org.ai + +// al : http://www.ert.gov.al/ert_alb/faq_det.html?Id=31 +al +com.al +edu.al +gov.al +mil.al +net.al +org.al + +// am : http://en.wikipedia.org/wiki/.am +am + +// an : http://www.una.an/an_domreg/default.asp +an +com.an +net.an +org.an +edu.an + +// ao : http://en.wikipedia.org/wiki/.ao +// http://www.dns.ao/REGISTR.DOC +ao +ed.ao +gv.ao +og.ao +co.ao +pb.ao +it.ao + +// aq : http://en.wikipedia.org/wiki/.aq +aq + +// ar : http://en.wikipedia.org/wiki/.ar +*.ar +!congresodelalengua3.ar +!educ.ar +!gobiernoelectronico.ar +!mecon.ar +!nacion.ar +!nic.ar +!promocion.ar +!retina.ar +!uba.ar + +// arpa : http://en.wikipedia.org/wiki/.arpa +// Confirmed by registry 2008-06-18 +e164.arpa +in-addr.arpa +ip6.arpa +iris.arpa +uri.arpa +urn.arpa + +// as : http://en.wikipedia.org/wiki/.as +as +gov.as + +// asia : http://en.wikipedia.org/wiki/.asia +asia + +// at : http://en.wikipedia.org/wiki/.at +// Confirmed by registry 2008-06-17 +at +ac.at +co.at +gv.at +or.at + +// au : http://en.wikipedia.org/wiki/.au +// http://www.auda.org.au/ +// 2LDs +com.au +net.au +org.au +edu.au +gov.au +asn.au +id.au +// Historic 2LDs (closed to new registration, but sites still exist) +info.au +conf.au +oz.au +// CGDNs - http://www.cgdn.org.au/ +act.au +nsw.au +nt.au +qld.au +sa.au +tas.au +vic.au +wa.au +// 3LDs +act.edu.au +nsw.edu.au +nt.edu.au +qld.edu.au +sa.edu.au +tas.edu.au +vic.edu.au +wa.edu.au +act.gov.au +// Removed at request of Shae.Donelan@services.nsw.gov.au, 2010-03-04 +// nsw.gov.au +nt.gov.au +qld.gov.au +sa.gov.au +tas.gov.au +vic.gov.au +wa.gov.au + +// aw : http://en.wikipedia.org/wiki/.aw +aw +com.aw + +// ax : http://en.wikipedia.org/wiki/.ax +ax + +// az : http://en.wikipedia.org/wiki/.az +az +com.az +net.az +int.az +gov.az +org.az +edu.az +info.az +pp.az +mil.az +name.az +pro.az +biz.az + +// ba : http://en.wikipedia.org/wiki/.ba +ba +org.ba +net.ba +edu.ba +gov.ba +mil.ba +unsa.ba +unbi.ba +co.ba +com.ba +rs.ba + +// bb : http://en.wikipedia.org/wiki/.bb +bb +biz.bb +com.bb +edu.bb +gov.bb +info.bb +net.bb +org.bb +store.bb + +// bd : http://en.wikipedia.org/wiki/.bd +*.bd + +// be : http://en.wikipedia.org/wiki/.be +// Confirmed by registry 2008-06-08 +be +ac.be + +// bf : http://en.wikipedia.org/wiki/.bf +bf +gov.bf + +// bg : http://en.wikipedia.org/wiki/.bg +// https://www.register.bg/user/static/rules/en/index.html +bg +a.bg +b.bg +c.bg +d.bg +e.bg +f.bg +g.bg +h.bg +i.bg +j.bg +k.bg +l.bg +m.bg +n.bg +o.bg +p.bg +q.bg +r.bg +s.bg +t.bg +u.bg +v.bg +w.bg +x.bg +y.bg +z.bg +0.bg +1.bg +2.bg +3.bg +4.bg +5.bg +6.bg +7.bg +8.bg +9.bg + +// bh : http://en.wikipedia.org/wiki/.bh +bh +com.bh +edu.bh +net.bh +org.bh +gov.bh + +// bi : http://en.wikipedia.org/wiki/.bi +// http://whois.nic.bi/ +bi +co.bi +com.bi +edu.bi +or.bi +org.bi + +// biz : http://en.wikipedia.org/wiki/.biz +biz + +// bj : http://en.wikipedia.org/wiki/.bj +bj +asso.bj +barreau.bj +gouv.bj + +// bm : http://www.bermudanic.bm/dnr-text.txt +bm +com.bm +edu.bm +gov.bm +net.bm +org.bm + +// bn : http://en.wikipedia.org/wiki/.bn +*.bn + +// bo : http://www.nic.bo/ +bo +com.bo +edu.bo +gov.bo +gob.bo +int.bo +org.bo +net.bo +mil.bo +tv.bo + +// br : http://registro.br/dominio/dpn.html +// Updated by registry 2011-03-01 +br +adm.br +adv.br +agr.br +am.br +arq.br +art.br +ato.br +b.br +bio.br +blog.br +bmd.br +cim.br +cng.br +cnt.br +com.br +coop.br +ecn.br +eco.br +edu.br +emp.br +eng.br +esp.br +etc.br +eti.br +far.br +flog.br +fm.br +fnd.br +fot.br +fst.br +g12.br +ggf.br +gov.br +imb.br +ind.br +inf.br +jor.br +jus.br +leg.br +lel.br +mat.br +med.br +mil.br +mus.br +net.br +nom.br +not.br +ntr.br +odo.br +org.br +ppg.br +pro.br +psc.br +psi.br +qsl.br +radio.br +rec.br +slg.br +srv.br +taxi.br +teo.br +tmp.br +trd.br +tur.br +tv.br +vet.br +vlog.br +wiki.br +zlg.br + +// bs : http://www.nic.bs/rules.html +bs +com.bs +net.bs +org.bs +edu.bs +gov.bs + +// bt : http://en.wikipedia.org/wiki/.bt +bt +com.bt +edu.bt +gov.bt +net.bt +org.bt + +// bv : No registrations at this time. +// Submitted by registry 2006-06-16 + +// bw : http://en.wikipedia.org/wiki/.bw +// http://www.gobin.info/domainname/bw.doc +// list of other 2nd level tlds ? +bw +co.bw +org.bw + +// by : http://en.wikipedia.org/wiki/.by +// http://tld.by/rules_2006_en.html +// list of other 2nd level tlds ? +by +gov.by +mil.by +// Official information does not indicate that com.by is a reserved +// second-level domain, but it's being used as one (see www.google.com.by and +// www.yahoo.com.by, for example), so we list it here for safety's sake. +com.by + +// http://hoster.by/ +of.by + +// bz : http://en.wikipedia.org/wiki/.bz +// http://www.belizenic.bz/ +bz +com.bz +net.bz +org.bz +edu.bz +gov.bz + +// ca : http://en.wikipedia.org/wiki/.ca +ca +// ca geographical names +ab.ca +bc.ca +mb.ca +nb.ca +nf.ca +nl.ca +ns.ca +nt.ca +nu.ca +on.ca +pe.ca +qc.ca +sk.ca +yk.ca +// gc.ca: http://en.wikipedia.org/wiki/.gc.ca +// see also: http://registry.gc.ca/en/SubdomainFAQ +gc.ca + +// cat : http://en.wikipedia.org/wiki/.cat +cat + +// cc : http://en.wikipedia.org/wiki/.cc +cc + +// cd : http://en.wikipedia.org/wiki/.cd +// see also: https://www.nic.cd/domain/insertDomain_2.jsp?act=1 +cd +gov.cd + +// cf : http://en.wikipedia.org/wiki/.cf +cf + +// cg : http://en.wikipedia.org/wiki/.cg +cg + +// ch : http://en.wikipedia.org/wiki/.ch +ch + +// ci : http://en.wikipedia.org/wiki/.ci +// http://www.nic.ci/index.php?page=charte +ci +org.ci +or.ci +com.ci +co.ci +edu.ci +ed.ci +ac.ci +net.ci +go.ci +asso.ci +aéroport.ci +int.ci +presse.ci +md.ci +gouv.ci + +// ck : http://en.wikipedia.org/wiki/.ck +*.ck +!www.ck + +// cl : http://en.wikipedia.org/wiki/.cl +cl +gov.cl +gob.cl +co.cl +mil.cl + +// cm : http://en.wikipedia.org/wiki/.cm +cm +gov.cm + +// cn : http://en.wikipedia.org/wiki/.cn +// Submitted by registry 2008-06-11 +cn +ac.cn +com.cn +edu.cn +gov.cn +net.cn +org.cn +mil.cn +公司.cn +网络.cn +網絡.cn +// cn geographic names +ah.cn +bj.cn +cq.cn +fj.cn +gd.cn +gs.cn +gz.cn +gx.cn +ha.cn +hb.cn +he.cn +hi.cn +hl.cn +hn.cn +jl.cn +js.cn +jx.cn +ln.cn +nm.cn +nx.cn +qh.cn +sc.cn +sd.cn +sh.cn +sn.cn +sx.cn +tj.cn +xj.cn +xz.cn +yn.cn +zj.cn +hk.cn +mo.cn +tw.cn + +// co : http://en.wikipedia.org/wiki/.co +// Submitted by registry 2008-06-11 +co +arts.co +com.co +edu.co +firm.co +gov.co +info.co +int.co +mil.co +net.co +nom.co +org.co +rec.co +web.co + +// com : http://en.wikipedia.org/wiki/.com +com + +// coop : http://en.wikipedia.org/wiki/.coop +coop + +// cr : http://www.nic.cr/niccr_publico/showRegistroDominiosScreen.do +cr +ac.cr +co.cr +ed.cr +fi.cr +go.cr +or.cr +sa.cr + +// cu : http://en.wikipedia.org/wiki/.cu +cu +com.cu +edu.cu +org.cu +net.cu +gov.cu +inf.cu + +// cv : http://en.wikipedia.org/wiki/.cv +cv + +// cw : http://www.una.cw/cw_registry/ +// Confirmed by registry 2013-03-26 +cw +com.cw +edu.cw +net.cw +org.cw + +// cx : http://en.wikipedia.org/wiki/.cx +// list of other 2nd level tlds ? +cx +gov.cx + +// cy : http://en.wikipedia.org/wiki/.cy +*.cy + +// cz : http://en.wikipedia.org/wiki/.cz +cz + +// de : http://en.wikipedia.org/wiki/.de +// Confirmed by registry (with technical +// reservations) 2008-07-01 +de + +// dj : http://en.wikipedia.org/wiki/.dj +dj + +// dk : http://en.wikipedia.org/wiki/.dk +// Confirmed by registry 2008-06-17 +dk + +// dm : http://en.wikipedia.org/wiki/.dm +dm +com.dm +net.dm +org.dm +edu.dm +gov.dm + +// do : http://en.wikipedia.org/wiki/.do +do +art.do +com.do +edu.do +gob.do +gov.do +mil.do +net.do +org.do +sld.do +web.do + +// dz : http://en.wikipedia.org/wiki/.dz +dz +com.dz +org.dz +net.dz +gov.dz +edu.dz +asso.dz +pol.dz +art.dz + +// ec : http://www.nic.ec/reg/paso1.asp +// Submitted by registry 2008-07-04 +ec +com.ec +info.ec +net.ec +fin.ec +k12.ec +med.ec +pro.ec +org.ec +edu.ec +gov.ec +gob.ec +mil.ec + +// edu : http://en.wikipedia.org/wiki/.edu +edu + +// ee : http://www.eenet.ee/EENet/dom_reeglid.html#lisa_B +ee +edu.ee +gov.ee +riik.ee +lib.ee +med.ee +com.ee +pri.ee +aip.ee +org.ee +fie.ee + +// eg : http://en.wikipedia.org/wiki/.eg +eg +com.eg +edu.eg +eun.eg +gov.eg +mil.eg +name.eg +net.eg +org.eg +sci.eg + +// er : http://en.wikipedia.org/wiki/.er +*.er + +// es : https://www.nic.es/site_ingles/ingles/dominios/index.html +es +com.es +nom.es +org.es +gob.es +edu.es + +// et : http://en.wikipedia.org/wiki/.et +*.et + +// eu : http://en.wikipedia.org/wiki/.eu +eu + +// fi : http://en.wikipedia.org/wiki/.fi +fi +// aland.fi : http://en.wikipedia.org/wiki/.ax +// This domain is being phased out in favor of .ax. As there are still many +// domains under aland.fi, we still keep it on the list until aland.fi is +// completely removed. +// TODO: Check for updates (expected to be phased out around Q1/2009) +aland.fi + +// fj : http://en.wikipedia.org/wiki/.fj +*.fj + +// fk : http://en.wikipedia.org/wiki/.fk +*.fk + +// fm : http://en.wikipedia.org/wiki/.fm +fm + +// fo : http://en.wikipedia.org/wiki/.fo +fo + +// fr : http://www.afnic.fr/ +// domaines descriptifs : http://www.afnic.fr/obtenir/chartes/nommage-fr/annexe-descriptifs +fr +com.fr +asso.fr +nom.fr +prd.fr +presse.fr +tm.fr +// domaines sectoriels : http://www.afnic.fr/obtenir/chartes/nommage-fr/annexe-sectoriels +aeroport.fr +assedic.fr +avocat.fr +avoues.fr +cci.fr +chambagri.fr +chirurgiens-dentistes.fr +experts-comptables.fr +geometre-expert.fr +gouv.fr +greta.fr +huissier-justice.fr +medecin.fr +notaires.fr +pharmacien.fr +port.fr +veterinaire.fr + +// ga : http://en.wikipedia.org/wiki/.ga +ga + +// gb : This registry is effectively dormant +// Submitted by registry 2008-06-12 + +// gd : http://en.wikipedia.org/wiki/.gd +gd + +// ge : http://www.nic.net.ge/policy_en.pdf +ge +com.ge +edu.ge +gov.ge +org.ge +mil.ge +net.ge +pvt.ge + +// gf : http://en.wikipedia.org/wiki/.gf +gf + +// gg : http://www.channelisles.net/applic/avextn.shtml +gg +co.gg +org.gg +net.gg +sch.gg +gov.gg + +// gh : http://en.wikipedia.org/wiki/.gh +// see also: http://www.nic.gh/reg_now.php +// Although domains directly at second level are not possible at the moment, +// they have been possible for some time and may come back. +gh +com.gh +edu.gh +gov.gh +org.gh +mil.gh + +// gi : http://www.nic.gi/rules.html +gi +com.gi +ltd.gi +gov.gi +mod.gi +edu.gi +org.gi + +// gl : http://en.wikipedia.org/wiki/.gl +// http://nic.gl +gl + +// gm : http://www.nic.gm/htmlpages%5Cgm-policy.htm +gm + +// gn : http://psg.com/dns/gn/gn.txt +// Submitted by registry 2008-06-17 +ac.gn +com.gn +edu.gn +gov.gn +org.gn +net.gn + +// gov : http://en.wikipedia.org/wiki/.gov +gov + +// gp : http://www.nic.gp/index.php?lang=en +gp +com.gp +net.gp +mobi.gp +edu.gp +org.gp +asso.gp + +// gq : http://en.wikipedia.org/wiki/.gq +gq + +// gr : https://grweb.ics.forth.gr/english/1617-B-2005.html +// Submitted by registry 2008-06-09 +gr +com.gr +edu.gr +net.gr +org.gr +gov.gr + +// gs : http://en.wikipedia.org/wiki/.gs +gs + +// gt : http://www.gt/politicas_de_registro.html +gt +com.gt +edu.gt +gob.gt +ind.gt +mil.gt +net.gt +org.gt + +// gu : http://gadao.gov.gu/registration.txt +*.gu + +// gw : http://en.wikipedia.org/wiki/.gw +gw + +// gy : http://en.wikipedia.org/wiki/.gy +// http://registry.gy/ +gy +co.gy +com.gy +net.gy + +// hk : https://www.hkdnr.hk +// Submitted by registry 2008-06-11 +hk +com.hk +edu.hk +gov.hk +idv.hk +net.hk +org.hk +公司.hk +教育.hk +敎育.hk +政府.hk +個人.hk +个人.hk +箇人.hk +網络.hk +网络.hk +组織.hk +網絡.hk +网絡.hk +组织.hk +組織.hk +組织.hk + +// hm : http://en.wikipedia.org/wiki/.hm +hm + +// hn : http://www.nic.hn/politicas/ps02,,05.html +hn +com.hn +edu.hn +org.hn +net.hn +mil.hn +gob.hn + +// hr : http://www.dns.hr/documents/pdf/HRTLD-regulations.pdf +hr +iz.hr +from.hr +name.hr +com.hr + +// ht : http://www.nic.ht/info/charte.cfm +ht +com.ht +shop.ht +firm.ht +info.ht +adult.ht +net.ht +pro.ht +org.ht +med.ht +art.ht +coop.ht +pol.ht +asso.ht +edu.ht +rel.ht +gouv.ht +perso.ht + +// hu : http://www.domain.hu/domain/English/sld.html +// Confirmed by registry 2008-06-12 +hu +co.hu +info.hu +org.hu +priv.hu +sport.hu +tm.hu +2000.hu +agrar.hu +bolt.hu +casino.hu +city.hu +erotica.hu +erotika.hu +film.hu +forum.hu +games.hu +hotel.hu +ingatlan.hu +jogasz.hu +konyvelo.hu +lakas.hu +media.hu +news.hu +reklam.hu +sex.hu +shop.hu +suli.hu +szex.hu +tozsde.hu +utazas.hu +video.hu + +// id : https://register.pandi.or.id/ +id +ac.id +biz.id +co.id +go.id +mil.id +my.id +net.id +or.id +sch.id +web.id + +// ie : http://en.wikipedia.org/wiki/.ie +ie +gov.ie + +// il : http://en.wikipedia.org/wiki/.il +*.il + +// im : https://www.nic.im/pdfs/imfaqs.pdf +im +co.im +ltd.co.im +plc.co.im +net.im +gov.im +org.im +nic.im +ac.im + +// in : http://en.wikipedia.org/wiki/.in +// see also: http://www.inregistry.in/policies/ +// Please note, that nic.in is not an offical eTLD, but used by most +// government institutions. +in +co.in +firm.in +net.in +org.in +gen.in +ind.in +nic.in +ac.in +edu.in +res.in +gov.in +mil.in + +// info : http://en.wikipedia.org/wiki/.info +info + +// int : http://en.wikipedia.org/wiki/.int +// Confirmed by registry 2008-06-18 +int +eu.int + +// io : http://www.nic.io/rules.html +// list of other 2nd level tlds ? +io +com.io + +// iq : http://www.cmc.iq/english/iq/iqregister1.htm +iq +gov.iq +edu.iq +mil.iq +com.iq +org.iq +net.iq + +// ir : http://www.nic.ir/Terms_and_Conditions_ir,_Appendix_1_Domain_Rules +// Also see http://www.nic.ir/Internationalized_Domain_Names +// Two .ir entries added at request of , 2010-04-16 +ir +ac.ir +co.ir +gov.ir +id.ir +net.ir +org.ir +sch.ir +// xn--mgba3a4f16a.ir (.ir, Persian YEH) +ایران.ir +// xn--mgba3a4fra.ir (.ir, Arabic YEH) +ايران.ir + +// is : http://www.isnic.is/domain/rules.php +// Confirmed by registry 2008-12-06 +is +net.is +com.is +edu.is +gov.is +org.is +int.is + +// it : http://en.wikipedia.org/wiki/.it +it +gov.it +edu.it +// list of reserved geo-names : +// http://www.nic.it/documenti/regolamenti-e-linee-guida/regolamento-assegnazione-versione-6.0.pdf +// (There is also a list of reserved geo-names corresponding to Italian +// municipalities : http://www.nic.it/documenti/appendice-c.pdf , but it is +// not included here.) +agrigento.it +ag.it +alessandria.it +al.it +ancona.it +an.it +aosta.it +aoste.it +ao.it +arezzo.it +ar.it +ascoli-piceno.it +ascolipiceno.it +ap.it +asti.it +at.it +avellino.it +av.it +bari.it +ba.it +andria-barletta-trani.it +andriabarlettatrani.it +trani-barletta-andria.it +tranibarlettaandria.it +barletta-trani-andria.it +barlettatraniandria.it +andria-trani-barletta.it +andriatranibarletta.it +trani-andria-barletta.it +traniandriabarletta.it +bt.it +belluno.it +bl.it +benevento.it +bn.it +bergamo.it +bg.it +biella.it +bi.it +bologna.it +bo.it +bolzano.it +bozen.it +balsan.it +alto-adige.it +altoadige.it +suedtirol.it +bz.it +brescia.it +bs.it +brindisi.it +br.it +cagliari.it +ca.it +caltanissetta.it +cl.it +campobasso.it +cb.it +carboniaiglesias.it +carbonia-iglesias.it +iglesias-carbonia.it +iglesiascarbonia.it +ci.it +caserta.it +ce.it +catania.it +ct.it +catanzaro.it +cz.it +chieti.it +ch.it +como.it +co.it +cosenza.it +cs.it +cremona.it +cr.it +crotone.it +kr.it +cuneo.it +cn.it +dell-ogliastra.it +dellogliastra.it +ogliastra.it +og.it +enna.it +en.it +ferrara.it +fe.it +fermo.it +fm.it +firenze.it +florence.it +fi.it +foggia.it +fg.it +forli-cesena.it +forlicesena.it +cesena-forli.it +cesenaforli.it +fc.it +frosinone.it +fr.it +genova.it +genoa.it +ge.it +gorizia.it +go.it +grosseto.it +gr.it +imperia.it +im.it +isernia.it +is.it +laquila.it +aquila.it +aq.it +la-spezia.it +laspezia.it +sp.it +latina.it +lt.it +lecce.it +le.it +lecco.it +lc.it +livorno.it +li.it +lodi.it +lo.it +lucca.it +lu.it +macerata.it +mc.it +mantova.it +mn.it +massa-carrara.it +massacarrara.it +carrara-massa.it +carraramassa.it +ms.it +matera.it +mt.it +medio-campidano.it +mediocampidano.it +campidano-medio.it +campidanomedio.it +vs.it +messina.it +me.it +milano.it +milan.it +mi.it +modena.it +mo.it +monza.it +monza-brianza.it +monzabrianza.it +monzaebrianza.it +monzaedellabrianza.it +monza-e-della-brianza.it +mb.it +napoli.it +naples.it +na.it +novara.it +no.it +nuoro.it +nu.it +oristano.it +or.it +padova.it +padua.it +pd.it +palermo.it +pa.it +parma.it +pr.it +pavia.it +pv.it +perugia.it +pg.it +pescara.it +pe.it +pesaro-urbino.it +pesarourbino.it +urbino-pesaro.it +urbinopesaro.it +pu.it +piacenza.it +pc.it +pisa.it +pi.it +pistoia.it +pt.it +pordenone.it +pn.it +potenza.it +pz.it +prato.it +po.it +ragusa.it +rg.it +ravenna.it +ra.it +reggio-calabria.it +reggiocalabria.it +rc.it +reggio-emilia.it +reggioemilia.it +re.it +rieti.it +ri.it +rimini.it +rn.it +roma.it +rome.it +rm.it +rovigo.it +ro.it +salerno.it +sa.it +sassari.it +ss.it +savona.it +sv.it +siena.it +si.it +siracusa.it +sr.it +sondrio.it +so.it +taranto.it +ta.it +tempio-olbia.it +tempioolbia.it +olbia-tempio.it +olbiatempio.it +ot.it +teramo.it +te.it +terni.it +tr.it +torino.it +turin.it +to.it +trapani.it +tp.it +trento.it +trentino.it +tn.it +treviso.it +tv.it +trieste.it +ts.it +udine.it +ud.it +varese.it +va.it +venezia.it +venice.it +ve.it +verbania.it +vb.it +vercelli.it +vc.it +verona.it +vr.it +vibo-valentia.it +vibovalentia.it +vv.it +vicenza.it +vi.it +viterbo.it +vt.it + +// je : http://www.channelisles.net/applic/avextn.shtml +je +co.je +org.je +net.je +sch.je +gov.je + +// jm : http://www.com.jm/register.html +*.jm + +// jo : http://www.dns.jo/Registration_policy.aspx +jo +com.jo +org.jo +net.jo +edu.jo +sch.jo +gov.jo +mil.jo +name.jo + +// jobs : http://en.wikipedia.org/wiki/.jobs +jobs + +// jp : http://en.wikipedia.org/wiki/.jp +// http://jprs.co.jp/en/jpdomain.html +// Updated by registry 2012-05-28 +jp +// jp organizational type names +ac.jp +ad.jp +co.jp +ed.jp +go.jp +gr.jp +lg.jp +ne.jp +or.jp +// jp preficture type names +aichi.jp +akita.jp +aomori.jp +chiba.jp +ehime.jp +fukui.jp +fukuoka.jp +fukushima.jp +gifu.jp +gunma.jp +hiroshima.jp +hokkaido.jp +hyogo.jp +ibaraki.jp +ishikawa.jp +iwate.jp +kagawa.jp +kagoshima.jp +kanagawa.jp +kochi.jp +kumamoto.jp +kyoto.jp +mie.jp +miyagi.jp +miyazaki.jp +nagano.jp +nagasaki.jp +nara.jp +niigata.jp +oita.jp +okayama.jp +okinawa.jp +osaka.jp +saga.jp +saitama.jp +shiga.jp +shimane.jp +shizuoka.jp +tochigi.jp +tokushima.jp +tokyo.jp +tottori.jp +toyama.jp +wakayama.jp +yamagata.jp +yamaguchi.jp +yamanashi.jp +// jp geographic type names +// http://jprs.jp/doc/rule/saisoku-1.html +*.kawasaki.jp +*.kitakyushu.jp +*.kobe.jp +*.nagoya.jp +*.sapporo.jp +*.sendai.jp +*.yokohama.jp +!city.kawasaki.jp +!city.kitakyushu.jp +!city.kobe.jp +!city.nagoya.jp +!city.sapporo.jp +!city.sendai.jp +!city.yokohama.jp +// 4th level registration +aisai.aichi.jp +ama.aichi.jp +anjo.aichi.jp +asuke.aichi.jp +chiryu.aichi.jp +chita.aichi.jp +fuso.aichi.jp +gamagori.aichi.jp +handa.aichi.jp +hazu.aichi.jp +hekinan.aichi.jp +higashiura.aichi.jp +ichinomiya.aichi.jp +inazawa.aichi.jp +inuyama.aichi.jp +isshiki.aichi.jp +iwakura.aichi.jp +kanie.aichi.jp +kariya.aichi.jp +kasugai.aichi.jp +kira.aichi.jp +kiyosu.aichi.jp +komaki.aichi.jp +konan.aichi.jp +kota.aichi.jp +mihama.aichi.jp +miyoshi.aichi.jp +nagakute.aichi.jp +nishio.aichi.jp +nisshin.aichi.jp +obu.aichi.jp +oguchi.aichi.jp +oharu.aichi.jp +okazaki.aichi.jp +owariasahi.aichi.jp +seto.aichi.jp +shikatsu.aichi.jp +shinshiro.aichi.jp +shitara.aichi.jp +tahara.aichi.jp +takahama.aichi.jp +tobishima.aichi.jp +toei.aichi.jp +togo.aichi.jp +tokai.aichi.jp +tokoname.aichi.jp +toyoake.aichi.jp +toyohashi.aichi.jp +toyokawa.aichi.jp +toyone.aichi.jp +toyota.aichi.jp +tsushima.aichi.jp +yatomi.aichi.jp +akita.akita.jp +daisen.akita.jp +fujisato.akita.jp +gojome.akita.jp +hachirogata.akita.jp +happou.akita.jp +higashinaruse.akita.jp +honjo.akita.jp +honjyo.akita.jp +ikawa.akita.jp +kamikoani.akita.jp +kamioka.akita.jp +katagami.akita.jp +kazuno.akita.jp +kitaakita.akita.jp +kosaka.akita.jp +kyowa.akita.jp +misato.akita.jp +mitane.akita.jp +moriyoshi.akita.jp +nikaho.akita.jp +noshiro.akita.jp +odate.akita.jp +oga.akita.jp +ogata.akita.jp +semboku.akita.jp +yokote.akita.jp +yurihonjo.akita.jp +aomori.aomori.jp +gonohe.aomori.jp +hachinohe.aomori.jp +hashikami.aomori.jp +hiranai.aomori.jp +hirosaki.aomori.jp +itayanagi.aomori.jp +kuroishi.aomori.jp +misawa.aomori.jp +mutsu.aomori.jp +nakadomari.aomori.jp +noheji.aomori.jp +oirase.aomori.jp +owani.aomori.jp +rokunohe.aomori.jp +sannohe.aomori.jp +shichinohe.aomori.jp +shingo.aomori.jp +takko.aomori.jp +towada.aomori.jp +tsugaru.aomori.jp +tsuruta.aomori.jp +abiko.chiba.jp +asahi.chiba.jp +chonan.chiba.jp +chosei.chiba.jp +choshi.chiba.jp +chuo.chiba.jp +funabashi.chiba.jp +futtsu.chiba.jp +hanamigawa.chiba.jp +ichihara.chiba.jp +ichikawa.chiba.jp +ichinomiya.chiba.jp +inzai.chiba.jp +isumi.chiba.jp +kamagaya.chiba.jp +kamogawa.chiba.jp +kashiwa.chiba.jp +katori.chiba.jp +katsuura.chiba.jp +kimitsu.chiba.jp +kisarazu.chiba.jp +kozaki.chiba.jp +kujukuri.chiba.jp +kyonan.chiba.jp +matsudo.chiba.jp +midori.chiba.jp +mihama.chiba.jp +minamiboso.chiba.jp +mobara.chiba.jp +mutsuzawa.chiba.jp +nagara.chiba.jp +nagareyama.chiba.jp +narashino.chiba.jp +narita.chiba.jp +noda.chiba.jp +oamishirasato.chiba.jp +omigawa.chiba.jp +onjuku.chiba.jp +otaki.chiba.jp +sakae.chiba.jp +sakura.chiba.jp +shimofusa.chiba.jp +shirako.chiba.jp +shiroi.chiba.jp +shisui.chiba.jp +sodegaura.chiba.jp +sosa.chiba.jp +tako.chiba.jp +tateyama.chiba.jp +togane.chiba.jp +tohnosho.chiba.jp +tomisato.chiba.jp +urayasu.chiba.jp +yachimata.chiba.jp +yachiyo.chiba.jp +yokaichiba.chiba.jp +yokoshibahikari.chiba.jp +yotsukaido.chiba.jp +ainan.ehime.jp +honai.ehime.jp +ikata.ehime.jp +imabari.ehime.jp +iyo.ehime.jp +kamijima.ehime.jp +kihoku.ehime.jp +kumakogen.ehime.jp +masaki.ehime.jp +matsuno.ehime.jp +matsuyama.ehime.jp +namikata.ehime.jp +niihama.ehime.jp +ozu.ehime.jp +saijo.ehime.jp +seiyo.ehime.jp +shikokuchuo.ehime.jp +tobe.ehime.jp +toon.ehime.jp +uchiko.ehime.jp +uwajima.ehime.jp +yawatahama.ehime.jp +echizen.fukui.jp +eiheiji.fukui.jp +fukui.fukui.jp +ikeda.fukui.jp +katsuyama.fukui.jp +mihama.fukui.jp +minamiechizen.fukui.jp +obama.fukui.jp +ohi.fukui.jp +ono.fukui.jp +sabae.fukui.jp +sakai.fukui.jp +takahama.fukui.jp +tsuruga.fukui.jp +wakasa.fukui.jp +ashiya.fukuoka.jp +buzen.fukuoka.jp +chikugo.fukuoka.jp +chikuho.fukuoka.jp +chikujo.fukuoka.jp +chikushino.fukuoka.jp +chikuzen.fukuoka.jp +chuo.fukuoka.jp +dazaifu.fukuoka.jp +fukuchi.fukuoka.jp +hakata.fukuoka.jp +higashi.fukuoka.jp +hirokawa.fukuoka.jp +hisayama.fukuoka.jp +iizuka.fukuoka.jp +inatsuki.fukuoka.jp +kaho.fukuoka.jp +kasuga.fukuoka.jp +kasuya.fukuoka.jp +kawara.fukuoka.jp +keisen.fukuoka.jp +koga.fukuoka.jp +kurate.fukuoka.jp +kurogi.fukuoka.jp +kurume.fukuoka.jp +minami.fukuoka.jp +miyako.fukuoka.jp +miyama.fukuoka.jp +miyawaka.fukuoka.jp +mizumaki.fukuoka.jp +munakata.fukuoka.jp +nakagawa.fukuoka.jp +nakama.fukuoka.jp +nishi.fukuoka.jp +nogata.fukuoka.jp +ogori.fukuoka.jp +okagaki.fukuoka.jp +okawa.fukuoka.jp +oki.fukuoka.jp +omuta.fukuoka.jp +onga.fukuoka.jp +onojo.fukuoka.jp +oto.fukuoka.jp +saigawa.fukuoka.jp +sasaguri.fukuoka.jp +shingu.fukuoka.jp +shinyoshitomi.fukuoka.jp +shonai.fukuoka.jp +soeda.fukuoka.jp +sue.fukuoka.jp +tachiarai.fukuoka.jp +tagawa.fukuoka.jp +takata.fukuoka.jp +toho.fukuoka.jp +toyotsu.fukuoka.jp +tsuiki.fukuoka.jp +ukiha.fukuoka.jp +umi.fukuoka.jp +usui.fukuoka.jp +yamada.fukuoka.jp +yame.fukuoka.jp +yanagawa.fukuoka.jp +yukuhashi.fukuoka.jp +aizubange.fukushima.jp +aizumisato.fukushima.jp +aizuwakamatsu.fukushima.jp +asakawa.fukushima.jp +bandai.fukushima.jp +date.fukushima.jp +fukushima.fukushima.jp +furudono.fukushima.jp +futaba.fukushima.jp +hanawa.fukushima.jp +higashi.fukushima.jp +hirata.fukushima.jp +hirono.fukushima.jp +iitate.fukushima.jp +inawashiro.fukushima.jp +ishikawa.fukushima.jp +iwaki.fukushima.jp +izumizaki.fukushima.jp +kagamiishi.fukushima.jp +kaneyama.fukushima.jp +kawamata.fukushima.jp +kitakata.fukushima.jp +kitashiobara.fukushima.jp +koori.fukushima.jp +koriyama.fukushima.jp +kunimi.fukushima.jp +miharu.fukushima.jp +mishima.fukushima.jp +namie.fukushima.jp +nango.fukushima.jp +nishiaizu.fukushima.jp +nishigo.fukushima.jp +okuma.fukushima.jp +omotego.fukushima.jp +ono.fukushima.jp +otama.fukushima.jp +samegawa.fukushima.jp +shimogo.fukushima.jp +shirakawa.fukushima.jp +showa.fukushima.jp +soma.fukushima.jp +sukagawa.fukushima.jp +taishin.fukushima.jp +tamakawa.fukushima.jp +tanagura.fukushima.jp +tenei.fukushima.jp +yabuki.fukushima.jp +yamato.fukushima.jp +yamatsuri.fukushima.jp +yanaizu.fukushima.jp +yugawa.fukushima.jp +anpachi.gifu.jp +ena.gifu.jp +gifu.gifu.jp +ginan.gifu.jp +godo.gifu.jp +gujo.gifu.jp +hashima.gifu.jp +hichiso.gifu.jp +hida.gifu.jp +higashishirakawa.gifu.jp +ibigawa.gifu.jp +ikeda.gifu.jp +kakamigahara.gifu.jp +kani.gifu.jp +kasahara.gifu.jp +kasamatsu.gifu.jp +kawaue.gifu.jp +kitagata.gifu.jp +mino.gifu.jp +minokamo.gifu.jp +mitake.gifu.jp +mizunami.gifu.jp +motosu.gifu.jp +nakatsugawa.gifu.jp +ogaki.gifu.jp +sakahogi.gifu.jp +seki.gifu.jp +sekigahara.gifu.jp +shirakawa.gifu.jp +tajimi.gifu.jp +takayama.gifu.jp +tarui.gifu.jp +toki.gifu.jp +tomika.gifu.jp +wanouchi.gifu.jp +yamagata.gifu.jp +yaotsu.gifu.jp +yoro.gifu.jp +annaka.gunma.jp +chiyoda.gunma.jp +fujioka.gunma.jp +higashiagatsuma.gunma.jp +isesaki.gunma.jp +itakura.gunma.jp +kanna.gunma.jp +kanra.gunma.jp +katashina.gunma.jp +kawaba.gunma.jp +kiryu.gunma.jp +kusatsu.gunma.jp +maebashi.gunma.jp +meiwa.gunma.jp +midori.gunma.jp +minakami.gunma.jp +naganohara.gunma.jp +nakanojo.gunma.jp +nanmoku.gunma.jp +numata.gunma.jp +oizumi.gunma.jp +ora.gunma.jp +ota.gunma.jp +shibukawa.gunma.jp +shimonita.gunma.jp +shinto.gunma.jp +showa.gunma.jp +takasaki.gunma.jp +takayama.gunma.jp +tamamura.gunma.jp +tatebayashi.gunma.jp +tomioka.gunma.jp +tsukiyono.gunma.jp +tsumagoi.gunma.jp +ueno.gunma.jp +yoshioka.gunma.jp +asaminami.hiroshima.jp +daiwa.hiroshima.jp +etajima.hiroshima.jp +fuchu.hiroshima.jp +fukuyama.hiroshima.jp +hatsukaichi.hiroshima.jp +higashihiroshima.hiroshima.jp +hongo.hiroshima.jp +jinsekikogen.hiroshima.jp +kaita.hiroshima.jp +kui.hiroshima.jp +kumano.hiroshima.jp +kure.hiroshima.jp +mihara.hiroshima.jp +miyoshi.hiroshima.jp +naka.hiroshima.jp +onomichi.hiroshima.jp +osakikamijima.hiroshima.jp +otake.hiroshima.jp +saka.hiroshima.jp +sera.hiroshima.jp +seranishi.hiroshima.jp +shinichi.hiroshima.jp +shobara.hiroshima.jp +takehara.hiroshima.jp +abashiri.hokkaido.jp +abira.hokkaido.jp +aibetsu.hokkaido.jp +akabira.hokkaido.jp +akkeshi.hokkaido.jp +asahikawa.hokkaido.jp +ashibetsu.hokkaido.jp +ashoro.hokkaido.jp +assabu.hokkaido.jp +atsuma.hokkaido.jp +bibai.hokkaido.jp +biei.hokkaido.jp +bifuka.hokkaido.jp +bihoro.hokkaido.jp +biratori.hokkaido.jp +chippubetsu.hokkaido.jp +chitose.hokkaido.jp +date.hokkaido.jp +ebetsu.hokkaido.jp +embetsu.hokkaido.jp +eniwa.hokkaido.jp +erimo.hokkaido.jp +esan.hokkaido.jp +esashi.hokkaido.jp +fukagawa.hokkaido.jp +fukushima.hokkaido.jp +furano.hokkaido.jp +furubira.hokkaido.jp +haboro.hokkaido.jp +hakodate.hokkaido.jp +hamatonbetsu.hokkaido.jp +hidaka.hokkaido.jp +higashikagura.hokkaido.jp +higashikawa.hokkaido.jp +hiroo.hokkaido.jp +hokuryu.hokkaido.jp +hokuto.hokkaido.jp +honbetsu.hokkaido.jp +horokanai.hokkaido.jp +horonobe.hokkaido.jp +ikeda.hokkaido.jp +imakane.hokkaido.jp +ishikari.hokkaido.jp +iwamizawa.hokkaido.jp +iwanai.hokkaido.jp +kamifurano.hokkaido.jp +kamikawa.hokkaido.jp +kamishihoro.hokkaido.jp +kamisunagawa.hokkaido.jp +kamoenai.hokkaido.jp +kayabe.hokkaido.jp +kembuchi.hokkaido.jp +kikonai.hokkaido.jp +kimobetsu.hokkaido.jp +kitahiroshima.hokkaido.jp +kitami.hokkaido.jp +kiyosato.hokkaido.jp +koshimizu.hokkaido.jp +kunneppu.hokkaido.jp +kuriyama.hokkaido.jp +kuromatsunai.hokkaido.jp +kushiro.hokkaido.jp +kutchan.hokkaido.jp +kyowa.hokkaido.jp +mashike.hokkaido.jp +matsumae.hokkaido.jp +mikasa.hokkaido.jp +minamifurano.hokkaido.jp +mombetsu.hokkaido.jp +moseushi.hokkaido.jp +mukawa.hokkaido.jp +muroran.hokkaido.jp +naie.hokkaido.jp +nakagawa.hokkaido.jp +nakasatsunai.hokkaido.jp +nakatombetsu.hokkaido.jp +nanae.hokkaido.jp +nanporo.hokkaido.jp +nayoro.hokkaido.jp +nemuro.hokkaido.jp +niikappu.hokkaido.jp +niki.hokkaido.jp +nishiokoppe.hokkaido.jp +noboribetsu.hokkaido.jp +numata.hokkaido.jp +obihiro.hokkaido.jp +obira.hokkaido.jp +oketo.hokkaido.jp +okoppe.hokkaido.jp +otaru.hokkaido.jp +otobe.hokkaido.jp +otofuke.hokkaido.jp +otoineppu.hokkaido.jp +oumu.hokkaido.jp +ozora.hokkaido.jp +pippu.hokkaido.jp +rankoshi.hokkaido.jp +rebun.hokkaido.jp +rikubetsu.hokkaido.jp +rishiri.hokkaido.jp +rishirifuji.hokkaido.jp +saroma.hokkaido.jp +sarufutsu.hokkaido.jp +shakotan.hokkaido.jp +shari.hokkaido.jp +shibecha.hokkaido.jp +shibetsu.hokkaido.jp +shikabe.hokkaido.jp +shikaoi.hokkaido.jp +shimamaki.hokkaido.jp +shimizu.hokkaido.jp +shimokawa.hokkaido.jp +shinshinotsu.hokkaido.jp +shintoku.hokkaido.jp +shiranuka.hokkaido.jp +shiraoi.hokkaido.jp +shiriuchi.hokkaido.jp +sobetsu.hokkaido.jp +sunagawa.hokkaido.jp +taiki.hokkaido.jp +takasu.hokkaido.jp +takikawa.hokkaido.jp +takinoue.hokkaido.jp +teshikaga.hokkaido.jp +tobetsu.hokkaido.jp +tohma.hokkaido.jp +tomakomai.hokkaido.jp +tomari.hokkaido.jp +toya.hokkaido.jp +toyako.hokkaido.jp +toyotomi.hokkaido.jp +toyoura.hokkaido.jp +tsubetsu.hokkaido.jp +tsukigata.hokkaido.jp +urakawa.hokkaido.jp +urausu.hokkaido.jp +uryu.hokkaido.jp +utashinai.hokkaido.jp +wakkanai.hokkaido.jp +wassamu.hokkaido.jp +yakumo.hokkaido.jp +yoichi.hokkaido.jp +aioi.hyogo.jp +akashi.hyogo.jp +ako.hyogo.jp +amagasaki.hyogo.jp +aogaki.hyogo.jp +asago.hyogo.jp +ashiya.hyogo.jp +awaji.hyogo.jp +fukusaki.hyogo.jp +goshiki.hyogo.jp +harima.hyogo.jp +himeji.hyogo.jp +ichikawa.hyogo.jp +inagawa.hyogo.jp +itami.hyogo.jp +kakogawa.hyogo.jp +kamigori.hyogo.jp +kamikawa.hyogo.jp +kasai.hyogo.jp +kasuga.hyogo.jp +kawanishi.hyogo.jp +miki.hyogo.jp +minamiawaji.hyogo.jp +nishinomiya.hyogo.jp +nishiwaki.hyogo.jp +ono.hyogo.jp +sanda.hyogo.jp +sannan.hyogo.jp +sasayama.hyogo.jp +sayo.hyogo.jp +shingu.hyogo.jp +shinonsen.hyogo.jp +shiso.hyogo.jp +sumoto.hyogo.jp +taishi.hyogo.jp +taka.hyogo.jp +takarazuka.hyogo.jp +takasago.hyogo.jp +takino.hyogo.jp +tamba.hyogo.jp +tatsuno.hyogo.jp +toyooka.hyogo.jp +yabu.hyogo.jp +yashiro.hyogo.jp +yoka.hyogo.jp +yokawa.hyogo.jp +ami.ibaraki.jp +asahi.ibaraki.jp +bando.ibaraki.jp +chikusei.ibaraki.jp +daigo.ibaraki.jp +fujishiro.ibaraki.jp +hitachi.ibaraki.jp +hitachinaka.ibaraki.jp +hitachiomiya.ibaraki.jp +hitachiota.ibaraki.jp +ibaraki.ibaraki.jp +ina.ibaraki.jp +inashiki.ibaraki.jp +itako.ibaraki.jp +iwama.ibaraki.jp +joso.ibaraki.jp +kamisu.ibaraki.jp +kasama.ibaraki.jp +kashima.ibaraki.jp +kasumigaura.ibaraki.jp +koga.ibaraki.jp +miho.ibaraki.jp +mito.ibaraki.jp +moriya.ibaraki.jp +naka.ibaraki.jp +namegata.ibaraki.jp +oarai.ibaraki.jp +ogawa.ibaraki.jp +omitama.ibaraki.jp +ryugasaki.ibaraki.jp +sakai.ibaraki.jp +sakuragawa.ibaraki.jp +shimodate.ibaraki.jp +shimotsuma.ibaraki.jp +shirosato.ibaraki.jp +sowa.ibaraki.jp +suifu.ibaraki.jp +takahagi.ibaraki.jp +tamatsukuri.ibaraki.jp +tokai.ibaraki.jp +tomobe.ibaraki.jp +tone.ibaraki.jp +toride.ibaraki.jp +tsuchiura.ibaraki.jp +tsukuba.ibaraki.jp +uchihara.ibaraki.jp +ushiku.ibaraki.jp +yachiyo.ibaraki.jp +yamagata.ibaraki.jp +yawara.ibaraki.jp +yuki.ibaraki.jp +anamizu.ishikawa.jp +hakui.ishikawa.jp +hakusan.ishikawa.jp +kaga.ishikawa.jp +kahoku.ishikawa.jp +kanazawa.ishikawa.jp +kawakita.ishikawa.jp +komatsu.ishikawa.jp +nakanoto.ishikawa.jp +nanao.ishikawa.jp +nomi.ishikawa.jp +nonoichi.ishikawa.jp +noto.ishikawa.jp +shika.ishikawa.jp +suzu.ishikawa.jp +tsubata.ishikawa.jp +tsurugi.ishikawa.jp +uchinada.ishikawa.jp +wajima.ishikawa.jp +fudai.iwate.jp +fujisawa.iwate.jp +hanamaki.iwate.jp +hiraizumi.iwate.jp +hirono.iwate.jp +ichinohe.iwate.jp +ichinoseki.iwate.jp +iwaizumi.iwate.jp +iwate.iwate.jp +joboji.iwate.jp +kamaishi.iwate.jp +kanegasaki.iwate.jp +karumai.iwate.jp +kawai.iwate.jp +kitakami.iwate.jp +kuji.iwate.jp +kunohe.iwate.jp +kuzumaki.iwate.jp +miyako.iwate.jp +mizusawa.iwate.jp +morioka.iwate.jp +ninohe.iwate.jp +noda.iwate.jp +ofunato.iwate.jp +oshu.iwate.jp +otsuchi.iwate.jp +rikuzentakata.iwate.jp +shiwa.iwate.jp +shizukuishi.iwate.jp +sumita.iwate.jp +takizawa.iwate.jp +tanohata.iwate.jp +tono.iwate.jp +yahaba.iwate.jp +yamada.iwate.jp +ayagawa.kagawa.jp +higashikagawa.kagawa.jp +kanonji.kagawa.jp +kotohira.kagawa.jp +manno.kagawa.jp +marugame.kagawa.jp +mitoyo.kagawa.jp +naoshima.kagawa.jp +sanuki.kagawa.jp +tadotsu.kagawa.jp +takamatsu.kagawa.jp +tonosho.kagawa.jp +uchinomi.kagawa.jp +utazu.kagawa.jp +zentsuji.kagawa.jp +akune.kagoshima.jp +amami.kagoshima.jp +hioki.kagoshima.jp +isa.kagoshima.jp +isen.kagoshima.jp +izumi.kagoshima.jp +kagoshima.kagoshima.jp +kanoya.kagoshima.jp +kawanabe.kagoshima.jp +kinko.kagoshima.jp +kouyama.kagoshima.jp +makurazaki.kagoshima.jp +matsumoto.kagoshima.jp +minamitane.kagoshima.jp +nakatane.kagoshima.jp +nishinoomote.kagoshima.jp +satsumasendai.kagoshima.jp +soo.kagoshima.jp +tarumizu.kagoshima.jp +yusui.kagoshima.jp +aikawa.kanagawa.jp +atsugi.kanagawa.jp +ayase.kanagawa.jp +chigasaki.kanagawa.jp +ebina.kanagawa.jp +fujisawa.kanagawa.jp +hadano.kanagawa.jp +hakone.kanagawa.jp +hiratsuka.kanagawa.jp +isehara.kanagawa.jp +kaisei.kanagawa.jp +kamakura.kanagawa.jp +kiyokawa.kanagawa.jp +matsuda.kanagawa.jp +minamiashigara.kanagawa.jp +miura.kanagawa.jp +nakai.kanagawa.jp +ninomiya.kanagawa.jp +odawara.kanagawa.jp +oi.kanagawa.jp +oiso.kanagawa.jp +sagamihara.kanagawa.jp +samukawa.kanagawa.jp +tsukui.kanagawa.jp +yamakita.kanagawa.jp +yamato.kanagawa.jp +yokosuka.kanagawa.jp +yugawara.kanagawa.jp +zama.kanagawa.jp +zushi.kanagawa.jp +aki.kochi.jp +geisei.kochi.jp +hidaka.kochi.jp +higashitsuno.kochi.jp +ino.kochi.jp +kagami.kochi.jp +kami.kochi.jp +kitagawa.kochi.jp +kochi.kochi.jp +mihara.kochi.jp +motoyama.kochi.jp +muroto.kochi.jp +nahari.kochi.jp +nakamura.kochi.jp +nankoku.kochi.jp +nishitosa.kochi.jp +niyodogawa.kochi.jp +ochi.kochi.jp +okawa.kochi.jp +otoyo.kochi.jp +otsuki.kochi.jp +sakawa.kochi.jp +sukumo.kochi.jp +susaki.kochi.jp +tosa.kochi.jp +tosashimizu.kochi.jp +toyo.kochi.jp +tsuno.kochi.jp +umaji.kochi.jp +yasuda.kochi.jp +yusuhara.kochi.jp +amakusa.kumamoto.jp +arao.kumamoto.jp +aso.kumamoto.jp +choyo.kumamoto.jp +gyokuto.kumamoto.jp +hitoyoshi.kumamoto.jp +kamiamakusa.kumamoto.jp +kashima.kumamoto.jp +kikuchi.kumamoto.jp +kosa.kumamoto.jp +kumamoto.kumamoto.jp +mashiki.kumamoto.jp +mifune.kumamoto.jp +minamata.kumamoto.jp +minamioguni.kumamoto.jp +nagasu.kumamoto.jp +nishihara.kumamoto.jp +oguni.kumamoto.jp +ozu.kumamoto.jp +sumoto.kumamoto.jp +takamori.kumamoto.jp +uki.kumamoto.jp +uto.kumamoto.jp +yamaga.kumamoto.jp +yamato.kumamoto.jp +yatsushiro.kumamoto.jp +ayabe.kyoto.jp +fukuchiyama.kyoto.jp +higashiyama.kyoto.jp +ide.kyoto.jp +ine.kyoto.jp +joyo.kyoto.jp +kameoka.kyoto.jp +kamo.kyoto.jp +kita.kyoto.jp +kizu.kyoto.jp +kumiyama.kyoto.jp +kyotamba.kyoto.jp +kyotanabe.kyoto.jp +kyotango.kyoto.jp +maizuru.kyoto.jp +minami.kyoto.jp +minamiyamashiro.kyoto.jp +miyazu.kyoto.jp +muko.kyoto.jp +nagaokakyo.kyoto.jp +nakagyo.kyoto.jp +nantan.kyoto.jp +oyamazaki.kyoto.jp +sakyo.kyoto.jp +seika.kyoto.jp +tanabe.kyoto.jp +uji.kyoto.jp +ujitawara.kyoto.jp +wazuka.kyoto.jp +yamashina.kyoto.jp +yawata.kyoto.jp +asahi.mie.jp +inabe.mie.jp +ise.mie.jp +kameyama.mie.jp +kawagoe.mie.jp +kiho.mie.jp +kisosaki.mie.jp +kiwa.mie.jp +komono.mie.jp +kumano.mie.jp +kuwana.mie.jp +matsusaka.mie.jp +meiwa.mie.jp +mihama.mie.jp +minamiise.mie.jp +misugi.mie.jp +miyama.mie.jp +nabari.mie.jp +shima.mie.jp +suzuka.mie.jp +tado.mie.jp +taiki.mie.jp +taki.mie.jp +tamaki.mie.jp +toba.mie.jp +tsu.mie.jp +udono.mie.jp +ureshino.mie.jp +watarai.mie.jp +yokkaichi.mie.jp +furukawa.miyagi.jp +higashimatsushima.miyagi.jp +ishinomaki.miyagi.jp +iwanuma.miyagi.jp +kakuda.miyagi.jp +kami.miyagi.jp +kawasaki.miyagi.jp +kesennuma.miyagi.jp +marumori.miyagi.jp +matsushima.miyagi.jp +minamisanriku.miyagi.jp +misato.miyagi.jp +murata.miyagi.jp +natori.miyagi.jp +ogawara.miyagi.jp +ohira.miyagi.jp +onagawa.miyagi.jp +osaki.miyagi.jp +rifu.miyagi.jp +semine.miyagi.jp +shibata.miyagi.jp +shichikashuku.miyagi.jp +shikama.miyagi.jp +shiogama.miyagi.jp +shiroishi.miyagi.jp +tagajo.miyagi.jp +taiwa.miyagi.jp +tome.miyagi.jp +tomiya.miyagi.jp +wakuya.miyagi.jp +watari.miyagi.jp +yamamoto.miyagi.jp +zao.miyagi.jp +aya.miyazaki.jp +ebino.miyazaki.jp +gokase.miyazaki.jp +hyuga.miyazaki.jp +kadogawa.miyazaki.jp +kawaminami.miyazaki.jp +kijo.miyazaki.jp +kitagawa.miyazaki.jp +kitakata.miyazaki.jp +kitaura.miyazaki.jp +kobayashi.miyazaki.jp +kunitomi.miyazaki.jp +kushima.miyazaki.jp +mimata.miyazaki.jp +miyakonojo.miyazaki.jp +miyazaki.miyazaki.jp +morotsuka.miyazaki.jp +nichinan.miyazaki.jp +nishimera.miyazaki.jp +nobeoka.miyazaki.jp +saito.miyazaki.jp +shiiba.miyazaki.jp +shintomi.miyazaki.jp +takaharu.miyazaki.jp +takanabe.miyazaki.jp +takazaki.miyazaki.jp +tsuno.miyazaki.jp +achi.nagano.jp +agematsu.nagano.jp +anan.nagano.jp +aoki.nagano.jp +asahi.nagano.jp +azumino.nagano.jp +chikuhoku.nagano.jp +chikuma.nagano.jp +chino.nagano.jp +fujimi.nagano.jp +hakuba.nagano.jp +hara.nagano.jp +hiraya.nagano.jp +iida.nagano.jp +iijima.nagano.jp +iiyama.nagano.jp +iizuna.nagano.jp +ikeda.nagano.jp +ikusaka.nagano.jp +ina.nagano.jp +karuizawa.nagano.jp +kawakami.nagano.jp +kiso.nagano.jp +kisofukushima.nagano.jp +kitaaiki.nagano.jp +komagane.nagano.jp +komoro.nagano.jp +matsukawa.nagano.jp +matsumoto.nagano.jp +miasa.nagano.jp +minamiaiki.nagano.jp +minamimaki.nagano.jp +minamiminowa.nagano.jp +minowa.nagano.jp +miyada.nagano.jp +miyota.nagano.jp +mochizuki.nagano.jp +nagano.nagano.jp +nagawa.nagano.jp +nagiso.nagano.jp +nakagawa.nagano.jp +nakano.nagano.jp +nozawaonsen.nagano.jp +obuse.nagano.jp +ogawa.nagano.jp +okaya.nagano.jp +omachi.nagano.jp +omi.nagano.jp +ookuwa.nagano.jp +ooshika.nagano.jp +otaki.nagano.jp +otari.nagano.jp +sakae.nagano.jp +sakaki.nagano.jp +saku.nagano.jp +sakuho.nagano.jp +shimosuwa.nagano.jp +shinanomachi.nagano.jp +shiojiri.nagano.jp +suwa.nagano.jp +suzaka.nagano.jp +takagi.nagano.jp +takamori.nagano.jp +takayama.nagano.jp +tateshina.nagano.jp +tatsuno.nagano.jp +togakushi.nagano.jp +togura.nagano.jp +tomi.nagano.jp +ueda.nagano.jp +wada.nagano.jp +yamagata.nagano.jp +yamanouchi.nagano.jp +yasaka.nagano.jp +yasuoka.nagano.jp +chijiwa.nagasaki.jp +futsu.nagasaki.jp +goto.nagasaki.jp +hasami.nagasaki.jp +hirado.nagasaki.jp +iki.nagasaki.jp +isahaya.nagasaki.jp +kawatana.nagasaki.jp +kuchinotsu.nagasaki.jp +matsuura.nagasaki.jp +nagasaki.nagasaki.jp +obama.nagasaki.jp +omura.nagasaki.jp +oseto.nagasaki.jp +saikai.nagasaki.jp +sasebo.nagasaki.jp +seihi.nagasaki.jp +shimabara.nagasaki.jp +shinkamigoto.nagasaki.jp +togitsu.nagasaki.jp +tsushima.nagasaki.jp +unzen.nagasaki.jp +ando.nara.jp +gose.nara.jp +heguri.nara.jp +higashiyoshino.nara.jp +ikaruga.nara.jp +ikoma.nara.jp +kamikitayama.nara.jp +kanmaki.nara.jp +kashiba.nara.jp +kashihara.nara.jp +katsuragi.nara.jp +kawai.nara.jp +kawakami.nara.jp +kawanishi.nara.jp +koryo.nara.jp +kurotaki.nara.jp +mitsue.nara.jp +miyake.nara.jp +nara.nara.jp +nosegawa.nara.jp +oji.nara.jp +ouda.nara.jp +oyodo.nara.jp +sakurai.nara.jp +sango.nara.jp +shimoichi.nara.jp +shimokitayama.nara.jp +shinjo.nara.jp +soni.nara.jp +takatori.nara.jp +tawaramoto.nara.jp +tenkawa.nara.jp +tenri.nara.jp +uda.nara.jp +yamatokoriyama.nara.jp +yamatotakada.nara.jp +yamazoe.nara.jp +yoshino.nara.jp +aga.niigata.jp +agano.niigata.jp +gosen.niigata.jp +itoigawa.niigata.jp +izumozaki.niigata.jp +joetsu.niigata.jp +kamo.niigata.jp +kariwa.niigata.jp +kashiwazaki.niigata.jp +minamiuonuma.niigata.jp +mitsuke.niigata.jp +muika.niigata.jp +murakami.niigata.jp +myoko.niigata.jp +nagaoka.niigata.jp +niigata.niigata.jp +ojiya.niigata.jp +omi.niigata.jp +sado.niigata.jp +sanjo.niigata.jp +seiro.niigata.jp +seirou.niigata.jp +sekikawa.niigata.jp +shibata.niigata.jp +tagami.niigata.jp +tainai.niigata.jp +tochio.niigata.jp +tokamachi.niigata.jp +tsubame.niigata.jp +tsunan.niigata.jp +uonuma.niigata.jp +yahiko.niigata.jp +yoita.niigata.jp +yuzawa.niigata.jp +beppu.oita.jp +bungoono.oita.jp +bungotakada.oita.jp +hasama.oita.jp +hiji.oita.jp +himeshima.oita.jp +hita.oita.jp +kamitsue.oita.jp +kokonoe.oita.jp +kuju.oita.jp +kunisaki.oita.jp +kusu.oita.jp +oita.oita.jp +saiki.oita.jp +taketa.oita.jp +tsukumi.oita.jp +usa.oita.jp +usuki.oita.jp +yufu.oita.jp +akaiwa.okayama.jp +asakuchi.okayama.jp +bizen.okayama.jp +hayashima.okayama.jp +ibara.okayama.jp +kagamino.okayama.jp +kasaoka.okayama.jp +kibichuo.okayama.jp +kumenan.okayama.jp +kurashiki.okayama.jp +maniwa.okayama.jp +misaki.okayama.jp +nagi.okayama.jp +niimi.okayama.jp +nishiawakura.okayama.jp +okayama.okayama.jp +satosho.okayama.jp +setouchi.okayama.jp +shinjo.okayama.jp +shoo.okayama.jp +soja.okayama.jp +takahashi.okayama.jp +tamano.okayama.jp +tsuyama.okayama.jp +wake.okayama.jp +yakage.okayama.jp +aguni.okinawa.jp +ginowan.okinawa.jp +ginoza.okinawa.jp +gushikami.okinawa.jp +haebaru.okinawa.jp +higashi.okinawa.jp +hirara.okinawa.jp +iheya.okinawa.jp +ishigaki.okinawa.jp +ishikawa.okinawa.jp +itoman.okinawa.jp +izena.okinawa.jp +kadena.okinawa.jp +kin.okinawa.jp +kitadaito.okinawa.jp +kitanakagusuku.okinawa.jp +kumejima.okinawa.jp +kunigami.okinawa.jp +minamidaito.okinawa.jp +motobu.okinawa.jp +nago.okinawa.jp +naha.okinawa.jp +nakagusuku.okinawa.jp +nakijin.okinawa.jp +nanjo.okinawa.jp +nishihara.okinawa.jp +ogimi.okinawa.jp +okinawa.okinawa.jp +onna.okinawa.jp +shimoji.okinawa.jp +taketomi.okinawa.jp +tarama.okinawa.jp +tokashiki.okinawa.jp +tomigusuku.okinawa.jp +tonaki.okinawa.jp +urasoe.okinawa.jp +uruma.okinawa.jp +yaese.okinawa.jp +yomitan.okinawa.jp +yonabaru.okinawa.jp +yonaguni.okinawa.jp +zamami.okinawa.jp +abeno.osaka.jp +chihayaakasaka.osaka.jp +chuo.osaka.jp +daito.osaka.jp +fujiidera.osaka.jp +habikino.osaka.jp +hannan.osaka.jp +higashiosaka.osaka.jp +higashisumiyoshi.osaka.jp +higashiyodogawa.osaka.jp +hirakata.osaka.jp +ibaraki.osaka.jp +ikeda.osaka.jp +izumi.osaka.jp +izumiotsu.osaka.jp +izumisano.osaka.jp +kadoma.osaka.jp +kaizuka.osaka.jp +kanan.osaka.jp +kashiwara.osaka.jp +katano.osaka.jp +kawachinagano.osaka.jp +kishiwada.osaka.jp +kita.osaka.jp +kumatori.osaka.jp +matsubara.osaka.jp +minato.osaka.jp +minoh.osaka.jp +misaki.osaka.jp +moriguchi.osaka.jp +neyagawa.osaka.jp +nishi.osaka.jp +nose.osaka.jp +osakasayama.osaka.jp +sakai.osaka.jp +sayama.osaka.jp +sennan.osaka.jp +settsu.osaka.jp +shijonawate.osaka.jp +shimamoto.osaka.jp +suita.osaka.jp +tadaoka.osaka.jp +taishi.osaka.jp +tajiri.osaka.jp +takaishi.osaka.jp +takatsuki.osaka.jp +tondabayashi.osaka.jp +toyonaka.osaka.jp +toyono.osaka.jp +yao.osaka.jp +ariake.saga.jp +arita.saga.jp +fukudomi.saga.jp +genkai.saga.jp +hamatama.saga.jp +hizen.saga.jp +imari.saga.jp +kamimine.saga.jp +kanzaki.saga.jp +karatsu.saga.jp +kashima.saga.jp +kitagata.saga.jp +kitahata.saga.jp +kiyama.saga.jp +kouhoku.saga.jp +kyuragi.saga.jp +nishiarita.saga.jp +ogi.saga.jp +omachi.saga.jp +ouchi.saga.jp +saga.saga.jp +shiroishi.saga.jp +taku.saga.jp +tara.saga.jp +tosu.saga.jp +yoshinogari.saga.jp +arakawa.saitama.jp +asaka.saitama.jp +chichibu.saitama.jp +fujimi.saitama.jp +fujimino.saitama.jp +fukaya.saitama.jp +hanno.saitama.jp +hanyu.saitama.jp +hasuda.saitama.jp +hatogaya.saitama.jp +hatoyama.saitama.jp +hidaka.saitama.jp +higashichichibu.saitama.jp +higashimatsuyama.saitama.jp +honjo.saitama.jp +ina.saitama.jp +iruma.saitama.jp +iwatsuki.saitama.jp +kamiizumi.saitama.jp +kamikawa.saitama.jp +kamisato.saitama.jp +kasukabe.saitama.jp +kawagoe.saitama.jp +kawaguchi.saitama.jp +kawajima.saitama.jp +kazo.saitama.jp +kitamoto.saitama.jp +koshigaya.saitama.jp +kounosu.saitama.jp +kuki.saitama.jp +kumagaya.saitama.jp +matsubushi.saitama.jp +minano.saitama.jp +misato.saitama.jp +miyashiro.saitama.jp +miyoshi.saitama.jp +moroyama.saitama.jp +nagatoro.saitama.jp +namegawa.saitama.jp +niiza.saitama.jp +ogano.saitama.jp +ogawa.saitama.jp +ogose.saitama.jp +okegawa.saitama.jp +omiya.saitama.jp +otaki.saitama.jp +ranzan.saitama.jp +ryokami.saitama.jp +saitama.saitama.jp +sakado.saitama.jp +satte.saitama.jp +sayama.saitama.jp +shiki.saitama.jp +shiraoka.saitama.jp +soka.saitama.jp +sugito.saitama.jp +toda.saitama.jp +tokigawa.saitama.jp +tokorozawa.saitama.jp +tsurugashima.saitama.jp +urawa.saitama.jp +warabi.saitama.jp +yashio.saitama.jp +yokoze.saitama.jp +yono.saitama.jp +yorii.saitama.jp +yoshida.saitama.jp +yoshikawa.saitama.jp +yoshimi.saitama.jp +aisho.shiga.jp +gamo.shiga.jp +higashiomi.shiga.jp +hikone.shiga.jp +koka.shiga.jp +konan.shiga.jp +kosei.shiga.jp +koto.shiga.jp +kusatsu.shiga.jp +maibara.shiga.jp +moriyama.shiga.jp +nagahama.shiga.jp +nishiazai.shiga.jp +notogawa.shiga.jp +omihachiman.shiga.jp +otsu.shiga.jp +ritto.shiga.jp +ryuoh.shiga.jp +takashima.shiga.jp +takatsuki.shiga.jp +torahime.shiga.jp +toyosato.shiga.jp +yasu.shiga.jp +akagi.shimane.jp +ama.shimane.jp +gotsu.shimane.jp +hamada.shimane.jp +higashiizumo.shimane.jp +hikawa.shimane.jp +hikimi.shimane.jp +izumo.shimane.jp +kakinoki.shimane.jp +masuda.shimane.jp +matsue.shimane.jp +misato.shimane.jp +nishinoshima.shimane.jp +ohda.shimane.jp +okinoshima.shimane.jp +okuizumo.shimane.jp +shimane.shimane.jp +tamayu.shimane.jp +tsuwano.shimane.jp +unnan.shimane.jp +yakumo.shimane.jp +yasugi.shimane.jp +yatsuka.shimane.jp +arai.shizuoka.jp +atami.shizuoka.jp +fuji.shizuoka.jp +fujieda.shizuoka.jp +fujikawa.shizuoka.jp +fujinomiya.shizuoka.jp +fukuroi.shizuoka.jp +gotemba.shizuoka.jp +haibara.shizuoka.jp +hamamatsu.shizuoka.jp +higashiizu.shizuoka.jp +ito.shizuoka.jp +iwata.shizuoka.jp +izu.shizuoka.jp +izunokuni.shizuoka.jp +kakegawa.shizuoka.jp +kannami.shizuoka.jp +kawanehon.shizuoka.jp +kawazu.shizuoka.jp +kikugawa.shizuoka.jp +kosai.shizuoka.jp +makinohara.shizuoka.jp +matsuzaki.shizuoka.jp +minamiizu.shizuoka.jp +mishima.shizuoka.jp +morimachi.shizuoka.jp +nishiizu.shizuoka.jp +numazu.shizuoka.jp +omaezaki.shizuoka.jp +shimada.shizuoka.jp +shimizu.shizuoka.jp +shimoda.shizuoka.jp +shizuoka.shizuoka.jp +susono.shizuoka.jp +yaizu.shizuoka.jp +yoshida.shizuoka.jp +ashikaga.tochigi.jp +bato.tochigi.jp +haga.tochigi.jp +ichikai.tochigi.jp +iwafune.tochigi.jp +kaminokawa.tochigi.jp +kanuma.tochigi.jp +karasuyama.tochigi.jp +kuroiso.tochigi.jp +mashiko.tochigi.jp +mibu.tochigi.jp +moka.tochigi.jp +motegi.tochigi.jp +nasu.tochigi.jp +nasushiobara.tochigi.jp +nikko.tochigi.jp +nishikata.tochigi.jp +nogi.tochigi.jp +ohira.tochigi.jp +ohtawara.tochigi.jp +oyama.tochigi.jp +sakura.tochigi.jp +sano.tochigi.jp +shimotsuke.tochigi.jp +shioya.tochigi.jp +takanezawa.tochigi.jp +tochigi.tochigi.jp +tsuga.tochigi.jp +ujiie.tochigi.jp +utsunomiya.tochigi.jp +yaita.tochigi.jp +aizumi.tokushima.jp +anan.tokushima.jp +ichiba.tokushima.jp +itano.tokushima.jp +kainan.tokushima.jp +komatsushima.tokushima.jp +matsushige.tokushima.jp +mima.tokushima.jp +minami.tokushima.jp +miyoshi.tokushima.jp +mugi.tokushima.jp +nakagawa.tokushima.jp +naruto.tokushima.jp +sanagochi.tokushima.jp +shishikui.tokushima.jp +tokushima.tokushima.jp +wajiki.tokushima.jp +adachi.tokyo.jp +akiruno.tokyo.jp +akishima.tokyo.jp +aogashima.tokyo.jp +arakawa.tokyo.jp +bunkyo.tokyo.jp +chiyoda.tokyo.jp +chofu.tokyo.jp +chuo.tokyo.jp +edogawa.tokyo.jp +fuchu.tokyo.jp +fussa.tokyo.jp +hachijo.tokyo.jp +hachioji.tokyo.jp +hamura.tokyo.jp +higashikurume.tokyo.jp +higashimurayama.tokyo.jp +higashiyamato.tokyo.jp +hino.tokyo.jp +hinode.tokyo.jp +hinohara.tokyo.jp +inagi.tokyo.jp +itabashi.tokyo.jp +katsushika.tokyo.jp +kita.tokyo.jp +kiyose.tokyo.jp +kodaira.tokyo.jp +koganei.tokyo.jp +kokubunji.tokyo.jp +komae.tokyo.jp +koto.tokyo.jp +kouzushima.tokyo.jp +kunitachi.tokyo.jp +machida.tokyo.jp +meguro.tokyo.jp +minato.tokyo.jp +mitaka.tokyo.jp +mizuho.tokyo.jp +musashimurayama.tokyo.jp +musashino.tokyo.jp +nakano.tokyo.jp +nerima.tokyo.jp +ogasawara.tokyo.jp +okutama.tokyo.jp +ome.tokyo.jp +oshima.tokyo.jp +ota.tokyo.jp +setagaya.tokyo.jp +shibuya.tokyo.jp +shinagawa.tokyo.jp +shinjuku.tokyo.jp +suginami.tokyo.jp +sumida.tokyo.jp +tachikawa.tokyo.jp +taito.tokyo.jp +tama.tokyo.jp +toshima.tokyo.jp +chizu.tottori.jp +hino.tottori.jp +kawahara.tottori.jp +koge.tottori.jp +kotoura.tottori.jp +misasa.tottori.jp +nanbu.tottori.jp +nichinan.tottori.jp +sakaiminato.tottori.jp +tottori.tottori.jp +wakasa.tottori.jp +yazu.tottori.jp +yonago.tottori.jp +asahi.toyama.jp +fuchu.toyama.jp +fukumitsu.toyama.jp +funahashi.toyama.jp +himi.toyama.jp +imizu.toyama.jp +inami.toyama.jp +johana.toyama.jp +kamiichi.toyama.jp +kurobe.toyama.jp +nakaniikawa.toyama.jp +namerikawa.toyama.jp +nanto.toyama.jp +nyuzen.toyama.jp +oyabe.toyama.jp +taira.toyama.jp +takaoka.toyama.jp +tateyama.toyama.jp +toga.toyama.jp +tonami.toyama.jp +toyama.toyama.jp +unazuki.toyama.jp +uozu.toyama.jp +yamada.toyama.jp +arida.wakayama.jp +aridagawa.wakayama.jp +gobo.wakayama.jp +hashimoto.wakayama.jp +hidaka.wakayama.jp +hirogawa.wakayama.jp +inami.wakayama.jp +iwade.wakayama.jp +kainan.wakayama.jp +kamitonda.wakayama.jp +katsuragi.wakayama.jp +kimino.wakayama.jp +kinokawa.wakayama.jp +kitayama.wakayama.jp +koya.wakayama.jp +koza.wakayama.jp +kozagawa.wakayama.jp +kudoyama.wakayama.jp +kushimoto.wakayama.jp +mihama.wakayama.jp +misato.wakayama.jp +nachikatsuura.wakayama.jp +shingu.wakayama.jp +shirahama.wakayama.jp +taiji.wakayama.jp +tanabe.wakayama.jp +wakayama.wakayama.jp +yuasa.wakayama.jp +yura.wakayama.jp +asahi.yamagata.jp +funagata.yamagata.jp +higashine.yamagata.jp +iide.yamagata.jp +kahoku.yamagata.jp +kaminoyama.yamagata.jp +kaneyama.yamagata.jp +kawanishi.yamagata.jp +mamurogawa.yamagata.jp +mikawa.yamagata.jp +murayama.yamagata.jp +nagai.yamagata.jp +nakayama.yamagata.jp +nanyo.yamagata.jp +nishikawa.yamagata.jp +obanazawa.yamagata.jp +oe.yamagata.jp +oguni.yamagata.jp +ohkura.yamagata.jp +oishida.yamagata.jp +sagae.yamagata.jp +sakata.yamagata.jp +sakegawa.yamagata.jp +shinjo.yamagata.jp +shirataka.yamagata.jp +shonai.yamagata.jp +takahata.yamagata.jp +tendo.yamagata.jp +tozawa.yamagata.jp +tsuruoka.yamagata.jp +yamagata.yamagata.jp +yamanobe.yamagata.jp +yonezawa.yamagata.jp +yuza.yamagata.jp +abu.yamaguchi.jp +hagi.yamaguchi.jp +hikari.yamaguchi.jp +hofu.yamaguchi.jp +iwakuni.yamaguchi.jp +kudamatsu.yamaguchi.jp +mitou.yamaguchi.jp +nagato.yamaguchi.jp +oshima.yamaguchi.jp +shimonoseki.yamaguchi.jp +shunan.yamaguchi.jp +tabuse.yamaguchi.jp +tokuyama.yamaguchi.jp +toyota.yamaguchi.jp +ube.yamaguchi.jp +yuu.yamaguchi.jp +chuo.yamanashi.jp +doshi.yamanashi.jp +fuefuki.yamanashi.jp +fujikawa.yamanashi.jp +fujikawaguchiko.yamanashi.jp +fujiyoshida.yamanashi.jp +hayakawa.yamanashi.jp +hokuto.yamanashi.jp +ichikawamisato.yamanashi.jp +kai.yamanashi.jp +kofu.yamanashi.jp +koshu.yamanashi.jp +kosuge.yamanashi.jp +minami-alps.yamanashi.jp +minobu.yamanashi.jp +nakamichi.yamanashi.jp +nanbu.yamanashi.jp +narusawa.yamanashi.jp +nirasaki.yamanashi.jp +nishikatsura.yamanashi.jp +oshino.yamanashi.jp +otsuki.yamanashi.jp +showa.yamanashi.jp +tabayama.yamanashi.jp +tsuru.yamanashi.jp +uenohara.yamanashi.jp +yamanakako.yamanashi.jp +yamanashi.yamanashi.jp + +// ke : http://www.kenic.or.ke/index.php?option=com_content&task=view&id=117&Itemid=145 +*.ke + +// kg : http://www.domain.kg/dmn_n.html +kg +org.kg +net.kg +com.kg +edu.kg +gov.kg +mil.kg + +// kh : http://www.mptc.gov.kh/dns_registration.htm +*.kh + +// ki : http://www.ki/dns/index.html +ki +edu.ki +biz.ki +net.ki +org.ki +gov.ki +info.ki +com.ki + +// km : http://en.wikipedia.org/wiki/.km +// http://www.domaine.km/documents/charte.doc +km +org.km +nom.km +gov.km +prd.km +tm.km +edu.km +mil.km +ass.km +com.km +// These are only mentioned as proposed suggestions at domaine.km, but +// http://en.wikipedia.org/wiki/.km says they're available for registration: +coop.km +asso.km +presse.km +medecin.km +notaires.km +pharmaciens.km +veterinaire.km +gouv.km + +// kn : http://en.wikipedia.org/wiki/.kn +// http://www.dot.kn/domainRules.html +kn +net.kn +org.kn +edu.kn +gov.kn + +// kp : http://www.kcce.kp/en_index.php +com.kp +edu.kp +gov.kp +org.kp +rep.kp +tra.kp + +// kr : http://en.wikipedia.org/wiki/.kr +// see also: http://domain.nida.or.kr/eng/registration.jsp +kr +ac.kr +co.kr +es.kr +go.kr +hs.kr +kg.kr +mil.kr +ms.kr +ne.kr +or.kr +pe.kr +re.kr +sc.kr +// kr geographical names +busan.kr +chungbuk.kr +chungnam.kr +daegu.kr +daejeon.kr +gangwon.kr +gwangju.kr +gyeongbuk.kr +gyeonggi.kr +gyeongnam.kr +incheon.kr +jeju.kr +jeonbuk.kr +jeonnam.kr +seoul.kr +ulsan.kr + +// kw : http://en.wikipedia.org/wiki/.kw +*.kw + +// ky : http://www.icta.ky/da_ky_reg_dom.php +// Confirmed by registry 2008-06-17 +ky +edu.ky +gov.ky +com.ky +org.ky +net.ky + +// kz : http://en.wikipedia.org/wiki/.kz +// see also: http://www.nic.kz/rules/index.jsp +kz +org.kz +edu.kz +net.kz +gov.kz +mil.kz +com.kz + +// la : http://en.wikipedia.org/wiki/.la +// Submitted by registry 2008-06-10 +la +int.la +net.la +info.la +edu.la +gov.la +per.la +com.la +org.la + +// lb : http://en.wikipedia.org/wiki/.lb +// Submitted by registry 2008-06-17 +com.lb +edu.lb +gov.lb +net.lb +org.lb + +// lc : http://en.wikipedia.org/wiki/.lc +// see also: http://www.nic.lc/rules.htm +lc +com.lc +net.lc +co.lc +org.lc +edu.lc +gov.lc + +// li : http://en.wikipedia.org/wiki/.li +li + +// lk : http://www.nic.lk/seclevpr.html +lk +gov.lk +sch.lk +net.lk +int.lk +com.lk +org.lk +edu.lk +ngo.lk +soc.lk +web.lk +ltd.lk +assn.lk +grp.lk +hotel.lk + +// lr : http://psg.com/dns/lr/lr.txt +// Submitted by registry 2008-06-17 +com.lr +edu.lr +gov.lr +org.lr +net.lr + +// ls : http://en.wikipedia.org/wiki/.ls +ls +co.ls +org.ls + +// lt : http://en.wikipedia.org/wiki/.lt +lt +// gov.lt : http://www.gov.lt/index_en.php +gov.lt + +// lu : http://www.dns.lu/en/ +lu + +// lv : http://www.nic.lv/DNS/En/generic.php +lv +com.lv +edu.lv +gov.lv +org.lv +mil.lv +id.lv +net.lv +asn.lv +conf.lv + +// ly : http://www.nic.ly/regulations.php +ly +com.ly +net.ly +gov.ly +plc.ly +edu.ly +sch.ly +med.ly +org.ly +id.ly + +// ma : http://en.wikipedia.org/wiki/.ma +// http://www.anrt.ma/fr/admin/download/upload/file_fr782.pdf +ma +co.ma +net.ma +gov.ma +org.ma +ac.ma +press.ma + +// mc : http://www.nic.mc/ +mc +tm.mc +asso.mc + +// md : http://en.wikipedia.org/wiki/.md +md + +// me : http://en.wikipedia.org/wiki/.me +me +co.me +net.me +org.me +edu.me +ac.me +gov.me +its.me +priv.me + +// mg : http://www.nic.mg/tarif.htm +mg +org.mg +nom.mg +gov.mg +prd.mg +tm.mg +edu.mg +mil.mg +com.mg + +// mh : http://en.wikipedia.org/wiki/.mh +mh + +// mil : http://en.wikipedia.org/wiki/.mil +mil + +// mk : http://en.wikipedia.org/wiki/.mk +// see also: http://dns.marnet.net.mk/postapka.php +mk +com.mk +org.mk +net.mk +edu.mk +gov.mk +inf.mk +name.mk + +// ml : http://www.gobin.info/domainname/ml-template.doc +// see also: http://en.wikipedia.org/wiki/.ml +ml +com.ml +edu.ml +gouv.ml +gov.ml +net.ml +org.ml +presse.ml + +// mm : http://en.wikipedia.org/wiki/.mm +*.mm + +// mn : http://en.wikipedia.org/wiki/.mn +mn +gov.mn +edu.mn +org.mn + +// mo : http://www.monic.net.mo/ +mo +com.mo +net.mo +org.mo +edu.mo +gov.mo + +// mobi : http://en.wikipedia.org/wiki/.mobi +mobi + +// mp : http://www.dot.mp/ +// Confirmed by registry 2008-06-17 +mp + +// mq : http://en.wikipedia.org/wiki/.mq +mq + +// mr : http://en.wikipedia.org/wiki/.mr +mr +gov.mr + +// ms : http://en.wikipedia.org/wiki/.ms +ms + +// mt : https://www.nic.org.mt/dotmt/ +*.mt + +// mu : http://en.wikipedia.org/wiki/.mu +mu +com.mu +net.mu +org.mu +gov.mu +ac.mu +co.mu +or.mu + +// museum : http://about.museum/naming/ +// http://index.museum/ +museum +academy.museum +agriculture.museum +air.museum +airguard.museum +alabama.museum +alaska.museum +amber.museum +ambulance.museum +american.museum +americana.museum +americanantiques.museum +americanart.museum +amsterdam.museum +and.museum +annefrank.museum +anthro.museum +anthropology.museum +antiques.museum +aquarium.museum +arboretum.museum +archaeological.museum +archaeology.museum +architecture.museum +art.museum +artanddesign.museum +artcenter.museum +artdeco.museum +arteducation.museum +artgallery.museum +arts.museum +artsandcrafts.museum +asmatart.museum +assassination.museum +assisi.museum +association.museum +astronomy.museum +atlanta.museum +austin.museum +australia.museum +automotive.museum +aviation.museum +axis.museum +badajoz.museum +baghdad.museum +bahn.museum +bale.museum +baltimore.museum +barcelona.museum +baseball.museum +basel.museum +baths.museum +bauern.museum +beauxarts.museum +beeldengeluid.museum +bellevue.museum +bergbau.museum +berkeley.museum +berlin.museum +bern.museum +bible.museum +bilbao.museum +bill.museum +birdart.museum +birthplace.museum +bonn.museum +boston.museum +botanical.museum +botanicalgarden.museum +botanicgarden.museum +botany.museum +brandywinevalley.museum +brasil.museum +bristol.museum +british.museum +britishcolumbia.museum +broadcast.museum +brunel.museum +brussel.museum +brussels.museum +bruxelles.museum +building.museum +burghof.museum +bus.museum +bushey.museum +cadaques.museum +california.museum +cambridge.museum +can.museum +canada.museum +capebreton.museum +carrier.museum +cartoonart.museum +casadelamoneda.museum +castle.museum +castres.museum +celtic.museum +center.museum +chattanooga.museum +cheltenham.museum +chesapeakebay.museum +chicago.museum +children.museum +childrens.museum +childrensgarden.museum +chiropractic.museum +chocolate.museum +christiansburg.museum +cincinnati.museum +cinema.museum +circus.museum +civilisation.museum +civilization.museum +civilwar.museum +clinton.museum +clock.museum +coal.museum +coastaldefence.museum +cody.museum +coldwar.museum +collection.museum +colonialwilliamsburg.museum +coloradoplateau.museum +columbia.museum +columbus.museum +communication.museum +communications.museum +community.museum +computer.museum +computerhistory.museum +comunicações.museum +contemporary.museum +contemporaryart.museum +convent.museum +copenhagen.museum +corporation.museum +correios-e-telecomunicações.museum +corvette.museum +costume.museum +countryestate.museum +county.museum +crafts.museum +cranbrook.museum +creation.museum +cultural.museum +culturalcenter.museum +culture.museum +cyber.museum +cymru.museum +dali.museum +dallas.museum +database.museum +ddr.museum +decorativearts.museum +delaware.museum +delmenhorst.museum +denmark.museum +depot.museum +design.museum +detroit.museum +dinosaur.museum +discovery.museum +dolls.museum +donostia.museum +durham.museum +eastafrica.museum +eastcoast.museum +education.museum +educational.museum +egyptian.museum +eisenbahn.museum +elburg.museum +elvendrell.museum +embroidery.museum +encyclopedic.museum +england.museum +entomology.museum +environment.museum +environmentalconservation.museum +epilepsy.museum +essex.museum +estate.museum +ethnology.museum +exeter.museum +exhibition.museum +family.museum +farm.museum +farmequipment.museum +farmers.museum +farmstead.museum +field.museum +figueres.museum +filatelia.museum +film.museum +fineart.museum +finearts.museum +finland.museum +flanders.museum +florida.museum +force.museum +fortmissoula.museum +fortworth.museum +foundation.museum +francaise.museum +frankfurt.museum +franziskaner.museum +freemasonry.museum +freiburg.museum +fribourg.museum +frog.museum +fundacio.museum +furniture.museum +gallery.museum +garden.museum +gateway.museum +geelvinck.museum +gemological.museum +geology.museum +georgia.museum +giessen.museum +glas.museum +glass.museum +gorge.museum +grandrapids.museum +graz.museum +guernsey.museum +halloffame.museum +hamburg.museum +handson.museum +harvestcelebration.museum +hawaii.museum +health.museum +heimatunduhren.museum +hellas.museum +helsinki.museum +hembygdsforbund.museum +heritage.museum +histoire.museum +historical.museum +historicalsociety.museum +historichouses.museum +historisch.museum +historisches.museum +history.museum +historyofscience.museum +horology.museum +house.museum +humanities.museum +illustration.museum +imageandsound.museum +indian.museum +indiana.museum +indianapolis.museum +indianmarket.museum +intelligence.museum +interactive.museum +iraq.museum +iron.museum +isleofman.museum +jamison.museum +jefferson.museum +jerusalem.museum +jewelry.museum +jewish.museum +jewishart.museum +jfk.museum +journalism.museum +judaica.museum +judygarland.museum +juedisches.museum +juif.museum +karate.museum +karikatur.museum +kids.museum +koebenhavn.museum +koeln.museum +kunst.museum +kunstsammlung.museum +kunstunddesign.museum +labor.museum +labour.museum +lajolla.museum +lancashire.museum +landes.museum +lans.museum +läns.museum +larsson.museum +lewismiller.museum +lincoln.museum +linz.museum +living.museum +livinghistory.museum +localhistory.museum +london.museum +losangeles.museum +louvre.museum +loyalist.museum +lucerne.museum +luxembourg.museum +luzern.museum +mad.museum +madrid.museum +mallorca.museum +manchester.museum +mansion.museum +mansions.museum +manx.museum +marburg.museum +maritime.museum +maritimo.museum +maryland.museum +marylhurst.museum +media.museum +medical.museum +medizinhistorisches.museum +meeres.museum +memorial.museum +mesaverde.museum +michigan.museum +midatlantic.museum +military.museum +mill.museum +miners.museum +mining.museum +minnesota.museum +missile.museum +missoula.museum +modern.museum +moma.museum +money.museum +monmouth.museum +monticello.museum +montreal.museum +moscow.museum +motorcycle.museum +muenchen.museum +muenster.museum +mulhouse.museum +muncie.museum +museet.museum +museumcenter.museum +museumvereniging.museum +music.museum +national.museum +nationalfirearms.museum +nationalheritage.museum +nativeamerican.museum +naturalhistory.museum +naturalhistorymuseum.museum +naturalsciences.museum +nature.museum +naturhistorisches.museum +natuurwetenschappen.museum +naumburg.museum +naval.museum +nebraska.museum +neues.museum +newhampshire.museum +newjersey.museum +newmexico.museum +newport.museum +newspaper.museum +newyork.museum +niepce.museum +norfolk.museum +north.museum +nrw.museum +nuernberg.museum +nuremberg.museum +nyc.museum +nyny.museum +oceanographic.museum +oceanographique.museum +omaha.museum +online.museum +ontario.museum +openair.museum +oregon.museum +oregontrail.museum +otago.museum +oxford.museum +pacific.museum +paderborn.museum +palace.museum +paleo.museum +palmsprings.museum +panama.museum +paris.museum +pasadena.museum +pharmacy.museum +philadelphia.museum +philadelphiaarea.museum +philately.museum +phoenix.museum +photography.museum +pilots.museum +pittsburgh.museum +planetarium.museum +plantation.museum +plants.museum +plaza.museum +portal.museum +portland.museum +portlligat.museum +posts-and-telecommunications.museum +preservation.museum +presidio.museum +press.museum +project.museum +public.museum +pubol.museum +quebec.museum +railroad.museum +railway.museum +research.museum +resistance.museum +riodejaneiro.museum +rochester.museum +rockart.museum +roma.museum +russia.museum +saintlouis.museum +salem.museum +salvadordali.museum +salzburg.museum +sandiego.museum +sanfrancisco.museum +santabarbara.museum +santacruz.museum +santafe.museum +saskatchewan.museum +satx.museum +savannahga.museum +schlesisches.museum +schoenbrunn.museum +schokoladen.museum +school.museum +schweiz.museum +science.museum +scienceandhistory.museum +scienceandindustry.museum +sciencecenter.museum +sciencecenters.museum +science-fiction.museum +sciencehistory.museum +sciences.museum +sciencesnaturelles.museum +scotland.museum +seaport.museum +settlement.museum +settlers.museum +shell.museum +sherbrooke.museum +sibenik.museum +silk.museum +ski.museum +skole.museum +society.museum +sologne.museum +soundandvision.museum +southcarolina.museum +southwest.museum +space.museum +spy.museum +square.museum +stadt.museum +stalbans.museum +starnberg.museum +state.museum +stateofdelaware.museum +station.museum +steam.museum +steiermark.museum +stjohn.museum +stockholm.museum +stpetersburg.museum +stuttgart.museum +suisse.museum +surgeonshall.museum +surrey.museum +svizzera.museum +sweden.museum +sydney.museum +tank.museum +tcm.museum +technology.museum +telekommunikation.museum +television.museum +texas.museum +textile.museum +theater.museum +time.museum +timekeeping.museum +topology.museum +torino.museum +touch.museum +town.museum +transport.museum +tree.museum +trolley.museum +trust.museum +trustee.museum +uhren.museum +ulm.museum +undersea.museum +university.museum +usa.museum +usantiques.museum +usarts.museum +uscountryestate.museum +usculture.museum +usdecorativearts.museum +usgarden.museum +ushistory.museum +ushuaia.museum +uslivinghistory.museum +utah.museum +uvic.museum +valley.museum +vantaa.museum +versailles.museum +viking.museum +village.museum +virginia.museum +virtual.museum +virtuel.museum +vlaanderen.museum +volkenkunde.museum +wales.museum +wallonie.museum +war.museum +washingtondc.museum +watchandclock.museum +watch-and-clock.museum +western.museum +westfalen.museum +whaling.museum +wildlife.museum +williamsburg.museum +windmill.museum +workshop.museum +york.museum +yorkshire.museum +yosemite.museum +youth.museum +zoological.museum +zoology.museum +ירושלים.museum +иком.museum + +// mv : http://en.wikipedia.org/wiki/.mv +// "mv" included because, contra Wikipedia, google.mv exists. +mv +aero.mv +biz.mv +com.mv +coop.mv +edu.mv +gov.mv +info.mv +int.mv +mil.mv +museum.mv +name.mv +net.mv +org.mv +pro.mv + +// mw : http://www.registrar.mw/ +mw +ac.mw +biz.mw +co.mw +com.mw +coop.mw +edu.mw +gov.mw +int.mw +museum.mw +net.mw +org.mw + +// mx : http://www.nic.mx/ +// Submitted by registry 2008-06-19 +mx +com.mx +org.mx +gob.mx +edu.mx +net.mx + +// my : http://www.mynic.net.my/ +my +com.my +net.my +org.my +gov.my +edu.my +mil.my +name.my + +// mz : http://www.gobin.info/domainname/mz-template.doc +*.mz +!teledata.mz + +// na : http://www.na-nic.com.na/ +// http://www.info.na/domain/ +na +info.na +pro.na +name.na +school.na +or.na +dr.na +us.na +mx.na +ca.na +in.na +cc.na +tv.na +ws.na +mobi.na +co.na +com.na +org.na + +// name : has 2nd-level tlds, but there's no list of them +name + +// nc : http://www.cctld.nc/ +nc +asso.nc + +// ne : http://en.wikipedia.org/wiki/.ne +ne + +// net : http://en.wikipedia.org/wiki/.net +net + +// nf : http://en.wikipedia.org/wiki/.nf +nf +com.nf +net.nf +per.nf +rec.nf +web.nf +arts.nf +firm.nf +info.nf +other.nf +store.nf + +// ng : http://psg.com/dns/ng/ +// Submitted by registry 2008-06-17 +ac.ng +com.ng +edu.ng +gov.ng +net.ng +org.ng + +// ni : http://www.nic.ni/dominios.htm +*.ni + +// nl : http://www.domain-registry.nl/ace.php/c,728,122,,,,Home.html +// Confirmed by registry (with technical +// reservations) 2008-06-08 +nl + +// BV.nl will be a registry for dutch BV's (besloten vennootschap) +bv.nl + +// no : http://www.norid.no/regelverk/index.en.html +// The Norwegian registry has declined to notify us of updates. The web pages +// referenced below are the official source of the data. There is also an +// announce mailing list: +// https://postlister.uninett.no/sympa/info/norid-diskusjon +no +// Norid generic domains : http://www.norid.no/regelverk/vedlegg-c.en.html +fhs.no +vgs.no +fylkesbibl.no +folkebibl.no +museum.no +idrett.no +priv.no +// Non-Norid generic domains : http://www.norid.no/regelverk/vedlegg-d.en.html +mil.no +stat.no +dep.no +kommune.no +herad.no +// no geographical names : http://www.norid.no/regelverk/vedlegg-b.en.html +// counties +aa.no +ah.no +bu.no +fm.no +hl.no +hm.no +jan-mayen.no +mr.no +nl.no +nt.no +of.no +ol.no +oslo.no +rl.no +sf.no +st.no +svalbard.no +tm.no +tr.no +va.no +vf.no +// primary and lower secondary schools per county +gs.aa.no +gs.ah.no +gs.bu.no +gs.fm.no +gs.hl.no +gs.hm.no +gs.jan-mayen.no +gs.mr.no +gs.nl.no +gs.nt.no +gs.of.no +gs.ol.no +gs.oslo.no +gs.rl.no +gs.sf.no +gs.st.no +gs.svalbard.no +gs.tm.no +gs.tr.no +gs.va.no +gs.vf.no +// cities +akrehamn.no +åkrehamn.no +algard.no +ålgård.no +arna.no +brumunddal.no +bryne.no +bronnoysund.no +brønnøysund.no +drobak.no +drøbak.no +egersund.no +fetsund.no +floro.no +florø.no +fredrikstad.no +hokksund.no +honefoss.no +hønefoss.no +jessheim.no +jorpeland.no +jørpeland.no +kirkenes.no +kopervik.no +krokstadelva.no +langevag.no +langevåg.no +leirvik.no +mjondalen.no +mjøndalen.no +mo-i-rana.no +mosjoen.no +mosjøen.no +nesoddtangen.no +orkanger.no +osoyro.no +osøyro.no +raholt.no +råholt.no +sandnessjoen.no +sandnessjøen.no +skedsmokorset.no +slattum.no +spjelkavik.no +stathelle.no +stavern.no +stjordalshalsen.no +stjørdalshalsen.no +tananger.no +tranby.no +vossevangen.no +// communities +afjord.no +åfjord.no +agdenes.no +al.no +ål.no +alesund.no +ålesund.no +alstahaug.no +alta.no +áltá.no +alaheadju.no +álaheadju.no +alvdal.no +amli.no +åmli.no +amot.no +åmot.no +andebu.no +andoy.no +andøy.no +andasuolo.no +ardal.no +årdal.no +aremark.no +arendal.no +ås.no +aseral.no +åseral.no +asker.no +askim.no +askvoll.no +askoy.no +askøy.no +asnes.no +åsnes.no +audnedaln.no +aukra.no +aure.no +aurland.no +aurskog-holand.no +aurskog-høland.no +austevoll.no +austrheim.no +averoy.no +averøy.no +balestrand.no +ballangen.no +balat.no +bálát.no +balsfjord.no +bahccavuotna.no +báhccavuotna.no +bamble.no +bardu.no +beardu.no +beiarn.no +bajddar.no +bájddar.no +baidar.no +báidár.no +berg.no +bergen.no +berlevag.no +berlevåg.no +bearalvahki.no +bearalváhki.no +bindal.no +birkenes.no +bjarkoy.no +bjarkøy.no +bjerkreim.no +bjugn.no +bodo.no +bodø.no +badaddja.no +bådåddjå.no +budejju.no +bokn.no +bremanger.no +bronnoy.no +brønnøy.no +bygland.no +bykle.no +barum.no +bærum.no +bo.telemark.no +bø.telemark.no +bo.nordland.no +bø.nordland.no +bievat.no +bievát.no +bomlo.no +bømlo.no +batsfjord.no +båtsfjord.no +bahcavuotna.no +báhcavuotna.no +dovre.no +drammen.no +drangedal.no +dyroy.no +dyrøy.no +donna.no +dønna.no +eid.no +eidfjord.no +eidsberg.no +eidskog.no +eidsvoll.no +eigersund.no +elverum.no +enebakk.no +engerdal.no +etne.no +etnedal.no +evenes.no +evenassi.no +evenášši.no +evje-og-hornnes.no +farsund.no +fauske.no +fuossko.no +fuoisku.no +fedje.no +fet.no +finnoy.no +finnøy.no +fitjar.no +fjaler.no +fjell.no +flakstad.no +flatanger.no +flekkefjord.no +flesberg.no +flora.no +fla.no +flå.no +folldal.no +forsand.no +fosnes.no +frei.no +frogn.no +froland.no +frosta.no +frana.no +fræna.no +froya.no +frøya.no +fusa.no +fyresdal.no +forde.no +førde.no +gamvik.no +gangaviika.no +gáŋgaviika.no +gaular.no +gausdal.no +gildeskal.no +gildeskål.no +giske.no +gjemnes.no +gjerdrum.no +gjerstad.no +gjesdal.no +gjovik.no +gjøvik.no +gloppen.no +gol.no +gran.no +grane.no +granvin.no +gratangen.no +grimstad.no +grong.no +kraanghke.no +kråanghke.no +grue.no +gulen.no +hadsel.no +halden.no +halsa.no +hamar.no +hamaroy.no +habmer.no +hábmer.no +hapmir.no +hápmir.no +hammerfest.no +hammarfeasta.no +hámmárfeasta.no +haram.no +hareid.no +harstad.no +hasvik.no +aknoluokta.no +ákŋoluokta.no +hattfjelldal.no +aarborte.no +haugesund.no +hemne.no +hemnes.no +hemsedal.no +heroy.more-og-romsdal.no +herøy.møre-og-romsdal.no +heroy.nordland.no +herøy.nordland.no +hitra.no +hjartdal.no +hjelmeland.no +hobol.no +hobøl.no +hof.no +hol.no +hole.no +holmestrand.no +holtalen.no +holtålen.no +hornindal.no +horten.no +hurdal.no +hurum.no +hvaler.no +hyllestad.no +hagebostad.no +hægebostad.no +hoyanger.no +høyanger.no +hoylandet.no +høylandet.no +ha.no +hå.no +ibestad.no +inderoy.no +inderøy.no +iveland.no +jevnaker.no +jondal.no +jolster.no +jølster.no +karasjok.no +karasjohka.no +kárášjohka.no +karlsoy.no +galsa.no +gálsá.no +karmoy.no +karmøy.no +kautokeino.no +guovdageaidnu.no +klepp.no +klabu.no +klæbu.no +kongsberg.no +kongsvinger.no +kragero.no +kragerø.no +kristiansand.no +kristiansund.no +krodsherad.no +krødsherad.no +kvalsund.no +rahkkeravju.no +ráhkkerávju.no +kvam.no +kvinesdal.no +kvinnherad.no +kviteseid.no +kvitsoy.no +kvitsøy.no +kvafjord.no +kvæfjord.no +giehtavuoatna.no +kvanangen.no +kvænangen.no +navuotna.no +návuotna.no +kafjord.no +kåfjord.no +gaivuotna.no +gáivuotna.no +larvik.no +lavangen.no +lavagis.no +loabat.no +loabát.no +lebesby.no +davvesiida.no +leikanger.no +leirfjord.no +leka.no +leksvik.no +lenvik.no +leangaviika.no +leaŋgaviika.no +lesja.no +levanger.no +lier.no +lierne.no +lillehammer.no +lillesand.no +lindesnes.no +lindas.no +lindås.no +lom.no +loppa.no +lahppi.no +láhppi.no +lund.no +lunner.no +luroy.no +lurøy.no +luster.no +lyngdal.no +lyngen.no +ivgu.no +lardal.no +lerdal.no +lærdal.no +lodingen.no +lødingen.no +lorenskog.no +lørenskog.no +loten.no +løten.no +malvik.no +masoy.no +måsøy.no +muosat.no +muosát.no +mandal.no +marker.no +marnardal.no +masfjorden.no +meland.no +meldal.no +melhus.no +meloy.no +meløy.no +meraker.no +meråker.no +moareke.no +moåreke.no +midsund.no +midtre-gauldal.no +modalen.no +modum.no +molde.no +moskenes.no +moss.no +mosvik.no +malselv.no +målselv.no +malatvuopmi.no +málatvuopmi.no +namdalseid.no +aejrie.no +namsos.no +namsskogan.no +naamesjevuemie.no +nååmesjevuemie.no +laakesvuemie.no +nannestad.no +narvik.no +narviika.no +naustdal.no +nedre-eiker.no +nes.akershus.no +nes.buskerud.no +nesna.no +nesodden.no +nesseby.no +unjarga.no +unjárga.no +nesset.no +nissedal.no +nittedal.no +nord-aurdal.no +nord-fron.no +nord-odal.no +norddal.no +nordkapp.no +davvenjarga.no +davvenjárga.no +nordre-land.no +nordreisa.no +raisa.no +ráisa.no +nore-og-uvdal.no +notodden.no +naroy.no +nærøy.no +notteroy.no +nøtterøy.no +odda.no +oksnes.no +øksnes.no +oppdal.no +oppegard.no +oppegård.no +orkdal.no +orland.no +ørland.no +orskog.no +ørskog.no +orsta.no +ørsta.no +os.hedmark.no +os.hordaland.no +osen.no +osteroy.no +osterøy.no +ostre-toten.no +østre-toten.no +overhalla.no +ovre-eiker.no +øvre-eiker.no +oyer.no +øyer.no +oygarden.no +øygarden.no +oystre-slidre.no +øystre-slidre.no +porsanger.no +porsangu.no +porsáŋgu.no +porsgrunn.no +radoy.no +radøy.no +rakkestad.no +rana.no +ruovat.no +randaberg.no +rauma.no +rendalen.no +rennebu.no +rennesoy.no +rennesøy.no +rindal.no +ringebu.no +ringerike.no +ringsaker.no +rissa.no +risor.no +risør.no +roan.no +rollag.no +rygge.no +ralingen.no +rælingen.no +rodoy.no +rødøy.no +romskog.no +rømskog.no +roros.no +røros.no +rost.no +røst.no +royken.no +røyken.no +royrvik.no +røyrvik.no +rade.no +råde.no +salangen.no +siellak.no +saltdal.no +salat.no +sálát.no +sálat.no +samnanger.no +sande.more-og-romsdal.no +sande.møre-og-romsdal.no +sande.vestfold.no +sandefjord.no +sandnes.no +sandoy.no +sandøy.no +sarpsborg.no +sauda.no +sauherad.no +sel.no +selbu.no +selje.no +seljord.no +sigdal.no +siljan.no +sirdal.no +skaun.no +skedsmo.no +ski.no +skien.no +skiptvet.no +skjervoy.no +skjervøy.no +skierva.no +skiervá.no +skjak.no +skjåk.no +skodje.no +skanland.no +skånland.no +skanit.no +skánit.no +smola.no +smøla.no +snillfjord.no +snasa.no +snåsa.no +snoasa.no +snaase.no +snåase.no +sogndal.no +sokndal.no +sola.no +solund.no +songdalen.no +sortland.no +spydeberg.no +stange.no +stavanger.no +steigen.no +steinkjer.no +stjordal.no +stjørdal.no +stokke.no +stor-elvdal.no +stord.no +stordal.no +storfjord.no +omasvuotna.no +strand.no +stranda.no +stryn.no +sula.no +suldal.no +sund.no +sunndal.no +surnadal.no +sveio.no +svelvik.no +sykkylven.no +sogne.no +søgne.no +somna.no +sømna.no +sondre-land.no +søndre-land.no +sor-aurdal.no +sør-aurdal.no +sor-fron.no +sør-fron.no +sor-odal.no +sør-odal.no +sor-varanger.no +sør-varanger.no +matta-varjjat.no +mátta-várjjat.no +sorfold.no +sørfold.no +sorreisa.no +sørreisa.no +sorum.no +sørum.no +tana.no +deatnu.no +time.no +tingvoll.no +tinn.no +tjeldsund.no +dielddanuorri.no +tjome.no +tjøme.no +tokke.no +tolga.no +torsken.no +tranoy.no +tranøy.no +tromso.no +tromsø.no +tromsa.no +romsa.no +trondheim.no +troandin.no +trysil.no +trana.no +træna.no +trogstad.no +trøgstad.no +tvedestrand.no +tydal.no +tynset.no +tysfjord.no +divtasvuodna.no +divttasvuotna.no +tysnes.no +tysvar.no +tysvær.no +tonsberg.no +tønsberg.no +ullensaker.no +ullensvang.no +ulvik.no +utsira.no +vadso.no +vadsø.no +cahcesuolo.no +čáhcesuolo.no +vaksdal.no +valle.no +vang.no +vanylven.no +vardo.no +vardø.no +varggat.no +várggát.no +vefsn.no +vaapste.no +vega.no +vegarshei.no +vegårshei.no +vennesla.no +verdal.no +verran.no +vestby.no +vestnes.no +vestre-slidre.no +vestre-toten.no +vestvagoy.no +vestvågøy.no +vevelstad.no +vik.no +vikna.no +vindafjord.no +volda.no +voss.no +varoy.no +værøy.no +vagan.no +vågan.no +voagat.no +vagsoy.no +vågsøy.no +vaga.no +vågå.no +valer.ostfold.no +våler.østfold.no +valer.hedmark.no +våler.hedmark.no + +// np : http://www.mos.com.np/register.html +*.np + +// nr : http://cenpac.net.nr/dns/index.html +// Confirmed by registry 2008-06-17 +nr +biz.nr +info.nr +gov.nr +edu.nr +org.nr +net.nr +com.nr + +// nu : http://en.wikipedia.org/wiki/.nu +nu + +// nz : http://en.wikipedia.org/wiki/.nz +*.nz + +// om : http://en.wikipedia.org/wiki/.om +*.om +!mediaphone.om +!nawrastelecom.om +!nawras.om +!omanmobile.om +!omanpost.om +!omantel.om +!rakpetroleum.om +!siemens.om +!songfest.om +!statecouncil.om + +// org : http://en.wikipedia.org/wiki/.org +org + +// pa : http://www.nic.pa/ +// Some additional second level "domains" resolve directly as hostnames, such as +// pannet.pa, so we add a rule for "pa". +pa +ac.pa +gob.pa +com.pa +org.pa +sld.pa +edu.pa +net.pa +ing.pa +abo.pa +med.pa +nom.pa + +// pe : https://www.nic.pe/InformeFinalComision.pdf +pe +edu.pe +gob.pe +nom.pe +mil.pe +org.pe +com.pe +net.pe + +// pf : http://www.gobin.info/domainname/formulaire-pf.pdf +pf +com.pf +org.pf +edu.pf + +// pg : http://en.wikipedia.org/wiki/.pg +*.pg + +// ph : http://www.domains.ph/FAQ2.asp +// Submitted by registry 2008-06-13 +ph +com.ph +net.ph +org.ph +gov.ph +edu.ph +ngo.ph +mil.ph +i.ph + +// pk : http://pk5.pknic.net.pk/pk5/msgNamepk.PK +pk +com.pk +net.pk +edu.pk +org.pk +fam.pk +biz.pk +web.pk +gov.pk +gob.pk +gok.pk +gon.pk +gop.pk +gos.pk +info.pk + +// pl : http://www.dns.pl/english/ +pl +// NASK functional domains (nask.pl / dns.pl) : http://www.dns.pl/english/dns-funk.html +aid.pl +agro.pl +atm.pl +auto.pl +biz.pl +com.pl +edu.pl +gmina.pl +gsm.pl +info.pl +mail.pl +miasta.pl +media.pl +mil.pl +net.pl +nieruchomosci.pl +nom.pl +org.pl +pc.pl +powiat.pl +priv.pl +realestate.pl +rel.pl +sex.pl +shop.pl +sklep.pl +sos.pl +szkola.pl +targi.pl +tm.pl +tourism.pl +travel.pl +turystyka.pl +// ICM functional domains (icm.edu.pl) +6bone.pl +art.pl +mbone.pl +// Government domains (administred by ippt.gov.pl) +gov.pl +uw.gov.pl +um.gov.pl +ug.gov.pl +upow.gov.pl +starostwo.gov.pl +so.gov.pl +sr.gov.pl +po.gov.pl +pa.gov.pl +// other functional domains +ngo.pl +irc.pl +usenet.pl +// NASK geographical domains : http://www.dns.pl/english/dns-regiony.html +augustow.pl +babia-gora.pl +bedzin.pl +beskidy.pl +bialowieza.pl +bialystok.pl +bielawa.pl +bieszczady.pl +boleslawiec.pl +bydgoszcz.pl +bytom.pl +cieszyn.pl +czeladz.pl +czest.pl +dlugoleka.pl +elblag.pl +elk.pl +glogow.pl +gniezno.pl +gorlice.pl +grajewo.pl +ilawa.pl +jaworzno.pl +jelenia-gora.pl +jgora.pl +kalisz.pl +kazimierz-dolny.pl +karpacz.pl +kartuzy.pl +kaszuby.pl +katowice.pl +kepno.pl +ketrzyn.pl +klodzko.pl +kobierzyce.pl +kolobrzeg.pl +konin.pl +konskowola.pl +kutno.pl +lapy.pl +lebork.pl +legnica.pl +lezajsk.pl +limanowa.pl +lomza.pl +lowicz.pl +lubin.pl +lukow.pl +malbork.pl +malopolska.pl +mazowsze.pl +mazury.pl +mielec.pl +mielno.pl +mragowo.pl +naklo.pl +nowaruda.pl +nysa.pl +olawa.pl +olecko.pl +olkusz.pl +olsztyn.pl +opoczno.pl +opole.pl +ostroda.pl +ostroleka.pl +ostrowiec.pl +ostrowwlkp.pl +pila.pl +pisz.pl +podhale.pl +podlasie.pl +polkowice.pl +pomorze.pl +pomorskie.pl +prochowice.pl +pruszkow.pl +przeworsk.pl +pulawy.pl +radom.pl +rawa-maz.pl +rybnik.pl +rzeszow.pl +sanok.pl +sejny.pl +siedlce.pl +slask.pl +slupsk.pl +sosnowiec.pl +stalowa-wola.pl +skoczow.pl +starachowice.pl +stargard.pl +suwalki.pl +swidnica.pl +swiebodzin.pl +swinoujscie.pl +szczecin.pl +szczytno.pl +tarnobrzeg.pl +tgory.pl +turek.pl +tychy.pl +ustka.pl +walbrzych.pl +warmia.pl +warszawa.pl +waw.pl +wegrow.pl +wielun.pl +wlocl.pl +wloclawek.pl +wodzislaw.pl +wolomin.pl +wroclaw.pl +zachpomor.pl +zagan.pl +zarow.pl +zgora.pl +zgorzelec.pl +// TASK geographical domains (www.task.gda.pl/uslugi/dns) +gda.pl +gdansk.pl +gdynia.pl +med.pl +sopot.pl +// other geographical domains +gliwice.pl +krakow.pl +poznan.pl +wroc.pl +zakopane.pl + +// pm : http://www.afnic.fr/medias/documents/AFNIC-naming-policy2012.pdf +pm + +// pn : http://www.government.pn/PnRegistry/policies.htm +pn +gov.pn +co.pn +org.pn +edu.pn +net.pn + +// post : http://en.wikipedia.org/wiki/.post +post + +// pr : http://www.nic.pr/index.asp?f=1 +pr +com.pr +net.pr +org.pr +gov.pr +edu.pr +isla.pr +pro.pr +biz.pr +info.pr +name.pr +// these aren't mentioned on nic.pr, but on http://en.wikipedia.org/wiki/.pr +est.pr +prof.pr +ac.pr + +// pro : http://www.nic.pro/support_faq.htm +pro +aca.pro +bar.pro +cpa.pro +jur.pro +law.pro +med.pro +eng.pro + +// ps : http://en.wikipedia.org/wiki/.ps +// http://www.nic.ps/registration/policy.html#reg +ps +edu.ps +gov.ps +sec.ps +plo.ps +com.ps +org.ps +net.ps + +// pt : http://online.dns.pt/dns/start_dns +pt +net.pt +gov.pt +org.pt +edu.pt +int.pt +publ.pt +com.pt +nome.pt + +// pw : http://en.wikipedia.org/wiki/.pw +pw +co.pw +ne.pw +or.pw +ed.pw +go.pw +belau.pw + +// py : http://www.nic.py/pautas.html#seccion_9 +// Confirmed by registry 2012-10-03 +py +com.py +coop.py +edu.py +gov.py +mil.py +net.py +org.py + +// qa : http://domains.qa/en/ +qa +com.qa +edu.qa +gov.qa +mil.qa +name.qa +net.qa +org.qa +sch.qa + +// re : http://www.afnic.re/obtenir/chartes/nommage-re/annexe-descriptifs +re +com.re +asso.re +nom.re + +// ro : http://www.rotld.ro/ +ro +com.ro +org.ro +tm.ro +nt.ro +nom.ro +info.ro +rec.ro +arts.ro +firm.ro +store.ro +www.ro + +// rs : http://en.wikipedia.org/wiki/.rs +rs +co.rs +org.rs +edu.rs +ac.rs +gov.rs +in.rs + +// ru : http://www.cctld.ru/ru/docs/aktiv_8.php +// Industry domains +ru +ac.ru +com.ru +edu.ru +int.ru +net.ru +org.ru +pp.ru +// Geographical domains +adygeya.ru +altai.ru +amur.ru +arkhangelsk.ru +astrakhan.ru +bashkiria.ru +belgorod.ru +bir.ru +bryansk.ru +buryatia.ru +cbg.ru +chel.ru +chelyabinsk.ru +chita.ru +chukotka.ru +chuvashia.ru +dagestan.ru +dudinka.ru +e-burg.ru +grozny.ru +irkutsk.ru +ivanovo.ru +izhevsk.ru +jar.ru +joshkar-ola.ru +kalmykia.ru +kaluga.ru +kamchatka.ru +karelia.ru +kazan.ru +kchr.ru +kemerovo.ru +khabarovsk.ru +khakassia.ru +khv.ru +kirov.ru +koenig.ru +komi.ru +kostroma.ru +krasnoyarsk.ru +kuban.ru +kurgan.ru +kursk.ru +lipetsk.ru +magadan.ru +mari.ru +mari-el.ru +marine.ru +mordovia.ru +mosreg.ru +msk.ru +murmansk.ru +nalchik.ru +nnov.ru +nov.ru +novosibirsk.ru +nsk.ru +omsk.ru +orenburg.ru +oryol.ru +palana.ru +penza.ru +perm.ru +pskov.ru +ptz.ru +rnd.ru +ryazan.ru +sakhalin.ru +samara.ru +saratov.ru +simbirsk.ru +smolensk.ru +spb.ru +stavropol.ru +stv.ru +surgut.ru +tambov.ru +tatarstan.ru +tom.ru +tomsk.ru +tsaritsyn.ru +tsk.ru +tula.ru +tuva.ru +tver.ru +tyumen.ru +udm.ru +udmurtia.ru +ulan-ude.ru +vladikavkaz.ru +vladimir.ru +vladivostok.ru +volgograd.ru +vologda.ru +voronezh.ru +vrn.ru +vyatka.ru +yakutia.ru +yamal.ru +yaroslavl.ru +yekaterinburg.ru +yuzhno-sakhalinsk.ru +// More geographical domains +amursk.ru +baikal.ru +cmw.ru +fareast.ru +jamal.ru +kms.ru +k-uralsk.ru +kustanai.ru +kuzbass.ru +magnitka.ru +mytis.ru +nakhodka.ru +nkz.ru +norilsk.ru +oskol.ru +pyatigorsk.ru +rubtsovsk.ru +snz.ru +syzran.ru +vdonsk.ru +zgrad.ru +// State domains +gov.ru +mil.ru +// Technical domains +test.ru + +// rw : http://www.nic.rw/cgi-bin/policy.pl +rw +gov.rw +net.rw +edu.rw +ac.rw +com.rw +co.rw +int.rw +mil.rw +gouv.rw + +// sa : http://www.nic.net.sa/ +sa +com.sa +net.sa +org.sa +gov.sa +med.sa +pub.sa +edu.sa +sch.sa + +// sb : http://www.sbnic.net.sb/ +// Submitted by registry 2008-06-08 +sb +com.sb +edu.sb +gov.sb +net.sb +org.sb + +// sc : http://www.nic.sc/ +sc +com.sc +gov.sc +net.sc +org.sc +edu.sc + +// sd : http://www.isoc.sd/sudanic.isoc.sd/billing_pricing.htm +// Submitted by registry 2008-06-17 +sd +com.sd +net.sd +org.sd +edu.sd +med.sd +tv.sd +gov.sd +info.sd + +// se : http://en.wikipedia.org/wiki/.se +// Submitted by registry 2008-06-24 +se +a.se +ac.se +b.se +bd.se +brand.se +c.se +d.se +e.se +f.se +fh.se +fhsk.se +fhv.se +g.se +h.se +i.se +k.se +komforb.se +kommunalforbund.se +komvux.se +l.se +lanbib.se +m.se +n.se +naturbruksgymn.se +o.se +org.se +p.se +parti.se +pp.se +press.se +r.se +s.se +sshn.se +t.se +tm.se +u.se +w.se +x.se +y.se +z.se + +// sg : http://www.nic.net.sg/page/registration-policies-procedures-and-guidelines +sg +com.sg +net.sg +org.sg +gov.sg +edu.sg +per.sg + +// sh : http://www.nic.sh/registrar.html +sh +com.sh +net.sh +gov.sh +org.sh +mil.sh + +// si : http://en.wikipedia.org/wiki/.si +si + +// sj : No registrations at this time. +// Submitted by registry 2008-06-16 + +// sk : http://en.wikipedia.org/wiki/.sk +// list of 2nd level domains ? +sk + +// sl : http://www.nic.sl +// Submitted by registry 2008-06-12 +sl +com.sl +net.sl +edu.sl +gov.sl +org.sl + +// sm : http://en.wikipedia.org/wiki/.sm +sm + +// sn : http://en.wikipedia.org/wiki/.sn +sn +art.sn +com.sn +edu.sn +gouv.sn +org.sn +perso.sn +univ.sn + +// so : http://www.soregistry.com/ +so +com.so +net.so +org.so + +// sr : http://en.wikipedia.org/wiki/.sr +sr + +// st : http://www.nic.st/html/policyrules/ +st +co.st +com.st +consulado.st +edu.st +embaixada.st +gov.st +mil.st +net.st +org.st +principe.st +saotome.st +store.st + +// su : http://en.wikipedia.org/wiki/.su +su + +// sv : http://www.svnet.org.sv/svpolicy.html +*.sv + +// sx : http://en.wikipedia.org/wiki/.sx +// Confirmed by registry 2012-05-31 +sx +gov.sx + +// sy : http://en.wikipedia.org/wiki/.sy +// see also: http://www.gobin.info/domainname/sy.doc +sy +edu.sy +gov.sy +net.sy +mil.sy +com.sy +org.sy + +// sz : http://en.wikipedia.org/wiki/.sz +// http://www.sispa.org.sz/ +sz +co.sz +ac.sz +org.sz + +// tc : http://en.wikipedia.org/wiki/.tc +tc + +// td : http://en.wikipedia.org/wiki/.td +td + +// tel: http://en.wikipedia.org/wiki/.tel +// http://www.telnic.org/ +tel + +// tf : http://en.wikipedia.org/wiki/.tf +tf + +// tg : http://en.wikipedia.org/wiki/.tg +// http://www.nic.tg/ +tg + +// th : http://en.wikipedia.org/wiki/.th +// Submitted by registry 2008-06-17 +th +ac.th +co.th +go.th +in.th +mi.th +net.th +or.th + +// tj : http://www.nic.tj/policy.html +tj +ac.tj +biz.tj +co.tj +com.tj +edu.tj +go.tj +gov.tj +int.tj +mil.tj +name.tj +net.tj +nic.tj +org.tj +test.tj +web.tj + +// tk : http://en.wikipedia.org/wiki/.tk +tk + +// tl : http://en.wikipedia.org/wiki/.tl +tl +gov.tl + +// tm : http://www.nic.tm/local.html +tm +com.tm +co.tm +org.tm +net.tm +nom.tm +gov.tm +mil.tm +edu.tm + +// tn : http://en.wikipedia.org/wiki/.tn +// http://whois.ati.tn/ +tn +com.tn +ens.tn +fin.tn +gov.tn +ind.tn +intl.tn +nat.tn +net.tn +org.tn +info.tn +perso.tn +tourism.tn +edunet.tn +rnrt.tn +rns.tn +rnu.tn +mincom.tn +agrinet.tn +defense.tn +turen.tn + +// to : http://en.wikipedia.org/wiki/.to +// Submitted by registry 2008-06-17 +to +com.to +gov.to +net.to +org.to +edu.to +mil.to + +// tr : http://en.wikipedia.org/wiki/.tr +*.tr +!nic.tr +// Used by government in the TRNC +// http://en.wikipedia.org/wiki/.nc.tr +gov.nc.tr + +// travel : http://en.wikipedia.org/wiki/.travel +travel + +// tt : http://www.nic.tt/ +tt +co.tt +com.tt +org.tt +net.tt +biz.tt +info.tt +pro.tt +int.tt +coop.tt +jobs.tt +mobi.tt +travel.tt +museum.tt +aero.tt +name.tt +gov.tt +edu.tt + +// tv : http://en.wikipedia.org/wiki/.tv +// Not listing any 2LDs as reserved since none seem to exist in practice, +// Wikipedia notwithstanding. +tv + +// tw : http://en.wikipedia.org/wiki/.tw +tw +edu.tw +gov.tw +mil.tw +com.tw +net.tw +org.tw +idv.tw +game.tw +ebiz.tw +club.tw +網路.tw +組織.tw +商業.tw + +// tz : http://www.tznic.or.tz/index.php/domains +// Confirmed by registry 2013-01-22 +ac.tz +co.tz +go.tz +hotel.tz +info.tz +me.tz +mil.tz +mobi.tz +ne.tz +or.tz +sc.tz +tv.tz + +// ua : https://hostmaster.ua/policy/?ua +// Submitted by registry 2012-04-27 +ua +// ua 2LD +com.ua +edu.ua +gov.ua +in.ua +net.ua +org.ua +// ua geographic names +// https://hostmaster.ua/2ld/ +cherkassy.ua +cherkasy.ua +chernigov.ua +chernihiv.ua +chernivtsi.ua +chernovtsy.ua +ck.ua +cn.ua +cr.ua +crimea.ua +cv.ua +dn.ua +dnepropetrovsk.ua +dnipropetrovsk.ua +dominic.ua +donetsk.ua +dp.ua +if.ua +ivano-frankivsk.ua +kh.ua +kharkiv.ua +kharkov.ua +kherson.ua +khmelnitskiy.ua +khmelnytskyi.ua +kiev.ua +kirovograd.ua +km.ua +kr.ua +krym.ua +ks.ua +kv.ua +kyiv.ua +lg.ua +lt.ua +lugansk.ua +lutsk.ua +lv.ua +lviv.ua +mk.ua +mykolaiv.ua +nikolaev.ua +od.ua +odesa.ua +odessa.ua +pl.ua +poltava.ua +rivne.ua +rovno.ua +rv.ua +sb.ua +sebastopol.ua +sevastopol.ua +sm.ua +sumy.ua +te.ua +ternopil.ua +uz.ua +uzhgorod.ua +vinnica.ua +vinnytsia.ua +vn.ua +volyn.ua +yalta.ua +zaporizhzhe.ua +zaporizhzhia.ua +zhitomir.ua +zhytomyr.ua +zp.ua +zt.ua + +// Private registries in .ua +co.ua +pp.ua + +// ug : https://www.registry.co.ug/ +ug +co.ug +or.ug +ac.ug +sc.ug +go.ug +ne.ug +com.ug +org.ug + +// uk : http://en.wikipedia.org/wiki/.uk +// Submitted by registry 2012-10-02 +// and tweaked by us pending further consultation. +*.uk +*.sch.uk +!bl.uk +!british-library.uk +!jet.uk +!mod.uk +!national-library-scotland.uk +!nel.uk +!nic.uk +!nls.uk +!parliament.uk + +// us : http://en.wikipedia.org/wiki/.us +us +dni.us +fed.us +isa.us +kids.us +nsn.us +// us geographic names +ak.us +al.us +ar.us +as.us +az.us +ca.us +co.us +ct.us +dc.us +de.us +fl.us +ga.us +gu.us +hi.us +ia.us +id.us +il.us +in.us +ks.us +ky.us +la.us +ma.us +md.us +me.us +mi.us +mn.us +mo.us +ms.us +mt.us +nc.us +nd.us +ne.us +nh.us +nj.us +nm.us +nv.us +ny.us +oh.us +ok.us +or.us +pa.us +pr.us +ri.us +sc.us +sd.us +tn.us +tx.us +ut.us +vi.us +vt.us +va.us +wa.us +wi.us +wv.us +wy.us +// The registrar notes several more specific domains available in each state, +// such as state.*.us, dst.*.us, etc., but resolution of these is somewhat +// haphazard; in some states these domains resolve as addresses, while in others +// only subdomains are available, or even nothing at all. We include the +// most common ones where it's clear that different sites are different +// entities. +k12.ak.us +k12.al.us +k12.ar.us +k12.as.us +k12.az.us +k12.ca.us +k12.co.us +k12.ct.us +k12.dc.us +k12.de.us +k12.fl.us +k12.ga.us +k12.gu.us +// k12.hi.us Hawaii has a state-wide DOE login: bug 614565 +k12.ia.us +k12.id.us +k12.il.us +k12.in.us +k12.ks.us +k12.ky.us +k12.la.us +k12.ma.us +k12.md.us +k12.me.us +k12.mi.us +k12.mn.us +k12.mo.us +k12.ms.us +k12.mt.us +k12.nc.us +k12.nd.us +k12.ne.us +k12.nh.us +k12.nj.us +k12.nm.us +k12.nv.us +k12.ny.us +k12.oh.us +k12.ok.us +k12.or.us +k12.pa.us +k12.pr.us +k12.ri.us +k12.sc.us +k12.sd.us +k12.tn.us +k12.tx.us +k12.ut.us +k12.vi.us +k12.vt.us +k12.va.us +k12.wa.us +k12.wi.us +k12.wv.us +k12.wy.us + +cc.ak.us +cc.al.us +cc.ar.us +cc.as.us +cc.az.us +cc.ca.us +cc.co.us +cc.ct.us +cc.dc.us +cc.de.us +cc.fl.us +cc.ga.us +cc.gu.us +cc.hi.us +cc.ia.us +cc.id.us +cc.il.us +cc.in.us +cc.ks.us +cc.ky.us +cc.la.us +cc.ma.us +cc.md.us +cc.me.us +cc.mi.us +cc.mn.us +cc.mo.us +cc.ms.us +cc.mt.us +cc.nc.us +cc.nd.us +cc.ne.us +cc.nh.us +cc.nj.us +cc.nm.us +cc.nv.us +cc.ny.us +cc.oh.us +cc.ok.us +cc.or.us +cc.pa.us +cc.pr.us +cc.ri.us +cc.sc.us +cc.sd.us +cc.tn.us +cc.tx.us +cc.ut.us +cc.vi.us +cc.vt.us +cc.va.us +cc.wa.us +cc.wi.us +cc.wv.us +cc.wy.us + +lib.ak.us +lib.al.us +lib.ar.us +lib.as.us +lib.az.us +lib.ca.us +lib.co.us +lib.ct.us +lib.dc.us +lib.de.us +lib.fl.us +lib.ga.us +lib.gu.us +lib.hi.us +lib.ia.us +lib.id.us +lib.il.us +lib.in.us +lib.ks.us +lib.ky.us +lib.la.us +lib.ma.us +lib.md.us +lib.me.us +lib.mi.us +lib.mn.us +lib.mo.us +lib.ms.us +lib.mt.us +lib.nc.us +lib.nd.us +lib.ne.us +lib.nh.us +lib.nj.us +lib.nm.us +lib.nv.us +lib.ny.us +lib.oh.us +lib.ok.us +lib.or.us +lib.pa.us +lib.pr.us +lib.ri.us +lib.sc.us +lib.sd.us +lib.tn.us +lib.tx.us +lib.ut.us +lib.vi.us +lib.vt.us +lib.va.us +lib.wa.us +lib.wi.us +lib.wv.us +lib.wy.us + +// k12.ma.us contains school districts in Massachusetts. The 4LDs are +// managed indepedently except for private (PVT), charter (CHTR) and +// parochial (PAROCH) schools. Those are delegated dorectly to the +// 5LD operators. +pvt.k12.ma.us +chtr.k12.ma.us +paroch.k12.ma.us + +// uy : http://www.nic.org.uy/ +uy +com.uy +edu.uy +gub.uy +mil.uy +net.uy +org.uy + +// uz : http://www.reg.uz/ +uz +co.uz +com.uz +net.uz +org.uz + +// va : http://en.wikipedia.org/wiki/.va +va + +// vc : http://en.wikipedia.org/wiki/.vc +// Submitted by registry 2008-06-13 +vc +com.vc +net.vc +org.vc +gov.vc +mil.vc +edu.vc + +// ve : https://registro.nic.ve/ +// Confirmed by registry 2012-10-04 +ve +co.ve +com.ve +e12.ve +edu.ve +gov.ve +info.ve +mil.ve +net.ve +org.ve +web.ve + +// vg : http://en.wikipedia.org/wiki/.vg +vg + +// vi : http://www.nic.vi/newdomainform.htm +// http://www.nic.vi/Domain_Rules/body_domain_rules.html indicates some other +// TLDs are "reserved", such as edu.vi and gov.vi, but doesn't actually say they +// are available for registration (which they do not seem to be). +vi +co.vi +com.vi +k12.vi +net.vi +org.vi + +// vn : https://www.dot.vn/vnnic/vnnic/domainregistration.jsp +vn +com.vn +net.vn +org.vn +edu.vn +gov.vn +int.vn +ac.vn +biz.vn +info.vn +name.vn +pro.vn +health.vn + +// vu : http://en.wikipedia.org/wiki/.vu +// list of 2nd level tlds ? +vu + +// wf : http://www.afnic.fr/medias/documents/AFNIC-naming-policy2012.pdf +wf + +// ws : http://en.wikipedia.org/wiki/.ws +// http://samoanic.ws/index.dhtml +ws +com.ws +net.ws +org.ws +gov.ws +edu.ws + +// yt : http://www.afnic.fr/medias/documents/AFNIC-naming-policy2012.pdf +yt + +// IDN ccTLDs +// Please sort by ISO 3166 ccTLD, then punicode string +// when submitting patches and follow this format: +// ("" ) : +// [optional sponsoring org] +// + +// xn--mgbaam7a8h ("Emerat" Arabic) : AE +// http://nic.ae/english/arabicdomain/rules.jsp +امارات + +// xn--54b7fta0cc ("Bangla" Bangla) : BD +বাংলা + +// xn--fiqs8s ("China" Chinese-Han-Simplified <.Zhonggou>) : CN +// CNNIC +// http://cnnic.cn/html/Dir/2005/10/11/3218.htm +中国 + +// xn--fiqz9s ("China" Chinese-Han-Traditional <.Zhonggou>) : CN +// CNNIC +// http://cnnic.cn/html/Dir/2005/10/11/3218.htm +中國 + +// xn--lgbbat1ad8j ("Algeria / Al Jazair" Arabic) : DZ +الجزائر + +// xn--wgbh1c ("Egypt" Arabic .masr) : EG +// http://www.dotmasr.eg/ +مصر + +// xn--node ("ge" Georgian (Mkhedruli)) : GE +გე + +// xn--j6w193g ("Hong Kong" Chinese-Han) : HK +// https://www2.hkirc.hk/register/rules.jsp +香港 + +// xn--h2brj9c ("Bharat" Devanagari) : IN +// India +भारत + +// xn--mgbbh1a71e ("Bharat" Arabic) : IN +// India +بھارت + +// xn--fpcrj9c3d ("Bharat" Telugu) : IN +// India +భారత్ + +// xn--gecrj9c ("Bharat" Gujarati) : IN +// India +ભારત + +// xn--s9brj9c ("Bharat" Gurmukhi) : IN +// India +ਭਾਰਤ + +// xn--45brj9c ("Bharat" Bengali) : IN +// India +ভারত + +// xn--xkc2dl3a5ee0h ("India" Tamil) : IN +// India +இந்தியா + +// xn--mgba3a4f16a ("Iran" Persian) : IR +ایران + +// xn--mgba3a4fra ("Iran" Arabic) : IR +ايران + +// xn--mgbayh7gpa ("al-Ordon" Arabic) : JO +// National Information Technology Center (NITC) +// Royal Scientific Society, Al-Jubeiha +الاردن + +// xn--3e0b707e ("Republic of Korea" Hangul) : KR +한국 + +// xn--fzc2c9e2c ("Lanka" Sinhalese-Sinhala) : LK +// http://nic.lk +ලංකා + +// xn--xkc2al3hye2a ("Ilangai" Tamil) : LK +// http://nic.lk +இலங்கை + +// xn--mgbc0a9azcg ("Morocco / al-Maghrib" Arabic) : MA +المغرب + +// xn--mgb9awbf ("Oman" Arabic) : OM +عمان + +// xn--ygbi2ammx ("Falasteen" Arabic) : PS +// The Palestinian National Internet Naming Authority (PNINA) +// http://www.pnina.ps +فلسطين + +// xn--90a3ac ("srb" Cyrillic) : RS +срб + +// xn--p1ai ("rf" Russian-Cyrillic) : RU +// http://www.cctld.ru/en/docs/rulesrf.php +рф + +// xn--wgbl6a ("Qatar" Arabic) : QA +// http://www.ict.gov.qa/ +قطر + +// xn--mgberp4a5d4ar ("AlSaudiah" Arabic) : SA +// http://www.nic.net.sa/ +السعودية + +// xn--mgberp4a5d4a87g ("AlSaudiah" Arabic) variant : SA +السعودیة + +// xn--mgbqly7c0a67fbc ("AlSaudiah" Arabic) variant : SA +السعودیۃ + +// xn--mgbqly7cvafr ("AlSaudiah" Arabic) variant : SA +السعوديه + +// xn--ogbpf8fl ("Syria" Arabic) : SY +سورية + +// xn--mgbtf8fl ("Syria" Arabic) variant : SY +سوريا + +// xn--yfro4i67o Singapore ("Singapore" Chinese-Han) : SG +新加坡 + +// xn--clchc0ea0b2g2a9gcd ("Singapore" Tamil) : SG +சிங்கப்பூர் + +// xn--o3cw4h ("Thai" Thai) : TH +// http://www.thnic.co.th +ไทย + +// xn--pgbs0dh ("Tunis") : TN +// http://nic.tn +تونس + +// xn--kpry57d ("Taiwan" Chinese-Han-Traditional) : TW +// http://www.twnic.net/english/dn/dn_07a.htm +台灣 + +// xn--kprw13d ("Taiwan" Chinese-Han-Simplified) : TW +// http://www.twnic.net/english/dn/dn_07a.htm +台湾 + +// xn--nnx388a ("Taiwan") variant : TW +臺灣 + +// xn--j1amh ("ukr" Cyrillic) : UA +укр + +// xn--mgb2ddes ("AlYemen" Arabic) : YE +اليمن + +// xxx : http://icmregistry.com +xxx + +// ye : http://www.y.net.ye/services/domain_name.htm +*.ye + +// za : http://www.zadna.org.za/slds.html +*.za + +// zm : http://en.wikipedia.org/wiki/.zm +*.zm + +// zw : http://en.wikipedia.org/wiki/.zw +*.zw + +// ===END ICANN DOMAINS=== +// ===BEGIN PRIVATE DOMAINS=== + +// Amazon CloudFront : https://aws.amazon.com/cloudfront/ +// Requested by Donavan Miller 2013-03-22 +cloudfront.net + +// Amazon Elastic Load Balancing : https://aws.amazon.com/elasticloadbalancing/ +// Requested by Scott Vidmar 2013-03-27 +elb.amazonaws.com + +// Amazon S3 : https://aws.amazon.com/s3/ +// Requested by Courtney Eckhardt 2013-03-22 +s3.amazonaws.com +s3-us-west-2.amazonaws.com +s3-us-west-1.amazonaws.com +s3-eu-west-1.amazonaws.com +s3-ap-southeast-1.amazonaws.com +s3-ap-southeast-2.amazonaws.com +s3-ap-northeast-1.amazonaws.com +s3-sa-east-1.amazonaws.com +s3-us-gov-west-1.amazonaws.com +s3-fips-us-gov-west-1.amazonaws.com +s3-website-us-east-1.amazonaws.com +s3-website-us-west-2.amazonaws.com +s3-website-us-west-1.amazonaws.com +s3-website-eu-west-1.amazonaws.com +s3-website-ap-southeast-1.amazonaws.com +s3-website-ap-southeast-2.amazonaws.com +s3-website-ap-northeast-1.amazonaws.com +s3-website-sa-east-1.amazonaws.com +s3-website-us-gov-west-1.amazonaws.com + +// BetaInABox +// Requested by adrian@betainabox.com 2012-09-13 +betainabox.com + +// CentralNic : http://www.centralnic.com/names/domains +// Requested by registry 2012-09-27 +ae.org +ar.com +br.com +cn.com +com.de +de.com +eu.com +gb.com +gb.net +gr.com +hu.com +hu.net +jp.net +jpn.com +kr.com +no.com +qc.com +ru.com +sa.com +se.com +se.net +uk.com +uk.net +us.com +us.org +uy.com +za.com + +// c.la : http://www.c.la/ +c.la + +// co.ca : http://registry.co.ca/ +co.ca + +// CoDNS B.V. +co.nl +co.no + +// DreamHost : http://www.dreamhost.com/ +// Requested by Andrew Farmer 2012-10-02 +dreamhosters.com + +// DynDNS.com : http://www.dyndns.com/services/dns/dyndns/ +dyndns-at-home.com +dyndns-at-work.com +dyndns-blog.com +dyndns-free.com +dyndns-home.com +dyndns-ip.com +dyndns-mail.com +dyndns-office.com +dyndns-pics.com +dyndns-remote.com +dyndns-server.com +dyndns-web.com +dyndns-wiki.com +dyndns-work.com +dyndns.biz +dyndns.info +dyndns.org +dyndns.tv +at-band-camp.net +ath.cx +barrel-of-knowledge.info +barrell-of-knowledge.info +better-than.tv +blogdns.com +blogdns.net +blogdns.org +blogsite.org +boldlygoingnowhere.org +broke-it.net +buyshouses.net +cechire.com +dnsalias.com +dnsalias.net +dnsalias.org +dnsdojo.com +dnsdojo.net +dnsdojo.org +does-it.net +doesntexist.com +doesntexist.org +dontexist.com +dontexist.net +dontexist.org +doomdns.com +doomdns.org +dvrdns.org +dyn-o-saur.com +dynalias.com +dynalias.net +dynalias.org +dynathome.net +dyndns.ws +endofinternet.net +endofinternet.org +endoftheinternet.org +est-a-la-maison.com +est-a-la-masion.com +est-le-patron.com +est-mon-blogueur.com +for-better.biz +for-more.biz +for-our.info +for-some.biz +for-the.biz +forgot.her.name +forgot.his.name +from-ak.com +from-al.com +from-ar.com +from-az.net +from-ca.com +from-co.net +from-ct.com +from-dc.com +from-de.com +from-fl.com +from-ga.com +from-hi.com +from-ia.com +from-id.com +from-il.com +from-in.com +from-ks.com +from-ky.com +from-la.net +from-ma.com +from-md.com +from-me.org +from-mi.com +from-mn.com +from-mo.com +from-ms.com +from-mt.com +from-nc.com +from-nd.com +from-ne.com +from-nh.com +from-nj.com +from-nm.com +from-nv.com +from-ny.net +from-oh.com +from-ok.com +from-or.com +from-pa.com +from-pr.com +from-ri.com +from-sc.com +from-sd.com +from-tn.com +from-tx.com +from-ut.com +from-va.com +from-vt.com +from-wa.com +from-wi.com +from-wv.com +from-wy.com +ftpaccess.cc +fuettertdasnetz.de +game-host.org +game-server.cc +getmyip.com +gets-it.net +go.dyndns.org +gotdns.com +gotdns.org +groks-the.info +groks-this.info +ham-radio-op.net +here-for-more.info +hobby-site.com +hobby-site.org +home.dyndns.org +homedns.org +homeftp.net +homeftp.org +homeip.net +homelinux.com +homelinux.net +homelinux.org +homeunix.com +homeunix.net +homeunix.org +iamallama.com +in-the-band.net +is-a-anarchist.com +is-a-blogger.com +is-a-bookkeeper.com +is-a-bruinsfan.org +is-a-bulls-fan.com +is-a-candidate.org +is-a-caterer.com +is-a-celticsfan.org +is-a-chef.com +is-a-chef.net +is-a-chef.org +is-a-conservative.com +is-a-cpa.com +is-a-cubicle-slave.com +is-a-democrat.com +is-a-designer.com +is-a-doctor.com +is-a-financialadvisor.com +is-a-geek.com +is-a-geek.net +is-a-geek.org +is-a-green.com +is-a-guru.com +is-a-hard-worker.com +is-a-hunter.com +is-a-knight.org +is-a-landscaper.com +is-a-lawyer.com +is-a-liberal.com +is-a-libertarian.com +is-a-linux-user.org +is-a-llama.com +is-a-musician.com +is-a-nascarfan.com +is-a-nurse.com +is-a-painter.com +is-a-patsfan.org +is-a-personaltrainer.com +is-a-photographer.com +is-a-player.com +is-a-republican.com +is-a-rockstar.com +is-a-socialist.com +is-a-soxfan.org +is-a-student.com +is-a-teacher.com +is-a-techie.com +is-a-therapist.com +is-an-accountant.com +is-an-actor.com +is-an-actress.com +is-an-anarchist.com +is-an-artist.com +is-an-engineer.com +is-an-entertainer.com +is-by.us +is-certified.com +is-found.org +is-gone.com +is-into-anime.com +is-into-cars.com +is-into-cartoons.com +is-into-games.com +is-leet.com +is-lost.org +is-not-certified.com +is-saved.org +is-slick.com +is-uberleet.com +is-very-bad.org +is-very-evil.org +is-very-good.org +is-very-nice.org +is-very-sweet.org +is-with-theband.com +isa-geek.com +isa-geek.net +isa-geek.org +isa-hockeynut.com +issmarterthanyou.com +isteingeek.de +istmein.de +kicks-ass.net +kicks-ass.org +knowsitall.info +land-4-sale.us +lebtimnetz.de +leitungsen.de +likes-pie.com +likescandy.com +merseine.nu +mine.nu +misconfused.org +mypets.ws +myphotos.cc +neat-url.com +office-on-the.net +on-the-web.tv +podzone.net +podzone.org +readmyblog.org +saves-the-whales.com +scrapper-site.net +scrapping.cc +selfip.biz +selfip.com +selfip.info +selfip.net +selfip.org +sells-for-less.com +sells-for-u.com +sells-it.net +sellsyourhome.org +servebbs.com +servebbs.net +servebbs.org +serveftp.net +serveftp.org +servegame.org +shacknet.nu +simple-url.com +space-to-rent.com +stuff-4-sale.org +stuff-4-sale.us +teaches-yoga.com +thruhere.net +traeumtgerade.de +webhop.biz +webhop.info +webhop.net +webhop.org +worse-than.tv +writesthisblog.com + +// Google, Inc. +// Requested by Eduardo Vela 2012-10-24 +appspot.com +blogspot.be +blogspot.bj +blogspot.ca +blogspot.cf +blogspot.ch +blogspot.co.at +blogspot.co.il +blogspot.co.nz +blogspot.co.uk +blogspot.com +blogspot.com.ar +blogspot.com.au +blogspot.com.br +blogspot.com.es +blogspot.cv +blogspot.cz +blogspot.de +blogspot.dk +blogspot.fi +blogspot.fr +blogspot.gr +blogspot.hk +blogspot.hu +blogspot.ie +blogspot.in +blogspot.it +blogspot.jp +blogspot.kr +blogspot.mr +blogspot.mx +blogspot.nl +blogspot.no +blogspot.pt +blogspot.re +blogspot.ro +blogspot.se +blogspot.sg +blogspot.sk +blogspot.td +blogspot.tw +codespot.com +googleapis.com +googlecode.com + +// iki.fi +// Requested by Hannu Aronsson 2009-11-05 +iki.fi + +// info.at : http://www.info.at/ +biz.at +info.at + +// Michau Enterprises Limited : http://www.co.pl/ +co.pl + +// NYC.mn : http://www.information.nyc.mn +// Requested by Matthew Brown 2013-03-11 +nyc.mn + +// Opera Software, A.S.A. +// Requested by Yngve Pettersen 2009-11-26 +operaunite.com + +// Red Hat, Inc. OpenShift : https://openshift.redhat.com/ +// Requested by Tim Kramer 2012-10-24 +rhcloud.com + +// priv.at : http://www.nic.priv.at/ +// Requested by registry 2008-06-09 +priv.at + +// ZaNiC : http://www.za.net/ +// Requested by registry 2009-10-03 +za.net +za.org + +// ===END PRIVATE DOMAINS=== diff --git a/log/summarize b/log/summarize index d658f55..208707b 100755 --- a/log/summarize +++ b/log/summarize @@ -63,6 +63,7 @@ my %formats3 = ( check_bogus_bounce => "%-3.3s", domainkeys => "%-3.3s", dkim => "%-3.3s", + dmarc => "%-3.3s", spamassassin => "%-3.3s", dspam => "%-3.3s", 'virus::clamdscan' => "%-3.3s", diff --git a/plugins/dmarc b/plugins/dmarc new file mode 100644 index 0000000..a664e72 --- /dev/null +++ b/plugins/dmarc @@ -0,0 +1,401 @@ +#!perl -w + +=head1 NAME + +Domain-based Message Authentication, Reporting and Conformance + +=head1 SYNOPSIS + +From the DMARC Draft: "DMARC operates as a policy layer atop DKIM and SPF. These technologies are the building blocks of DMARC as each is widely deployed, supported by mature tools, and is readily available to both senders and receivers. They are complementary, as each is resilient to many of the failure modes of the other." + +DMARC provides a way to exchange authentication information and policies among mail servers. + +DMARC benefits domain owners by preventing others from impersonating them. A domain owner can reliably tell other mail servers that "it it doesn't originate from this list of servers (SPF) and it is not signed (DKIM), then reject it!" DMARC also provides domain owners with a means to receive feedback and determine that their policies are working as desired. + +DMARC benefits mail server operators by providing them with an extremely reliable (as opposed to DKIM or SPF, which both have reliability issues when used independently) means to block forged emails. Is that message really from PayPal, Chase, Gmail, or Facebook? Since those organizations, and many more, publish DMARC policies, operators have a definitive means to know. + +=head1 HOW IT WORKS + +=head1 HOWTO + +See Section 10 of the draft: Domain Owner Actions + +1. Deploy DKIM & SPF +2. Ensure identifier alignment. +3. Publish a "monitor" record, ask for data reports +4. Roll policies from monitor to reject + +=head2 Publish a DMARC policy + + v=DMARC1; (version) + p=none; (disposition policy : reject, quarantine, none (monitor)) + sp=reject; (subdomain policy: default, same as p) + rua + adkim=s; (dkim alignment: s=strict, r=relaxed) + aspf=r; (spf alignment: s=strict, r=relaxed) + rua=mailto: dmarc-feedback\@$zone; (aggregate reports) + ruf=mailto: dmarc-feedback\@$zone.com; (forensic reports) + rf=afrf; (report format: afrf, iodef) + ri=8400; (report interval) + pct=50; (percent of messages to filter) + + +=head2 + +=head1 DRAFT + +http://www.dmarc.org/draft-dmarc-base-00-02.txt + +=head1 TODO + + 1. run dmarc before SPF, if DMARC policy is discovered, ignore SPF + + 2. provide dmarc feedback to domains that request it + + 3. If a message has multiple 'From' recipients, reject it + + 4. Rejections with a 550 (perm) or 450 (temp) + +=head1 IMPLEMENTATION + +1. Primary identifier is RFC5322.From field + +2. Senders can specify strict or relaxed mode + +3. policies available: reject, quarantine, no action + +4. DMARC overrides other public auth mechanisms + +5. senders can specify a percentage of messages to which policy applies + +6. Receivers should endeavour to reject or quarantine email if the + RFC5322.From purports to be from a domain that appears to be + either non-existent or incapable of receiving mail. + +=head2 Reports should include + +The report SHOULD include the following data: + + o Enough information for the report consumer to re-calculate DMARC + disposition based on the published policy, message dispositon, and + SPF, DKIM, and identifier alignment results. {R12} + + o Data for each sender subdomain separately from mail from the + sender's organizational domain, even if no subdomain policy is + applied. {R13} + + o Sending and receiving domains {R17} + + o The policy requested by the Domain Owner and the policy actually + applied (if different) {R18} + + o The number of successful authentications {R19} + + o The counts of messages based on all messages received even if + their delivery is ultimately blocked by other filtering agents + {R20} + +=cut + +use strict; +use warnings; + +use Qpsmtpd::Constants; + +#use Socket qw(:DEFAULT :crlf); + +sub init { + my ($self, $qp) = (shift, shift); + $self->{_args} = { @_ }; + $self->{_args}{reject} = 1 if ! defined $self->{_args}{reject}; + $self->{_args}{reject_type} ||= 'perm'; + $self->{_args}{p_vals} = { map { $_ => 1 } qw/ none reject quarantine / }; +} + +sub register { + my $self = shift; + + $self->register_hook('data_post', 'data_post_handler'); +}; + +sub data_post_handler { + my ($self, $transaction) = @_; + + return DECLINED if $self->is_immune(); + +# 11.1. Extract Author Domain + +# TODO: check exists_in_dns result, and possibly reject here if domain non-exist + my $from_host = $self->get_from_host( $transaction ) or return DECLINED; + if ( ! $self->exists_in_dns( $from_host ) ) { + my $org_host = $self->get_organizational_domain( $from_host ); + if ( ! $self->exists_in_dns( $org_host ) ) { + $self->log( LOGINFO, "fail, domain/org not in DNS" ); + #return $self->get_reject(); + return DECLINED; + }; + }; + +# 11.2. Determine Handling Policy + my $policy = $self->discover_policy( $from_host ) + or return DECLINED; + +# 3. Perform DKIM signature verification checks. A single email may +# contain multiple DKIM signatures. The results of this step are +# passed to the remainder of the algorithm and MUST include the +# value of the "d=" tag from all DKIM signatures that successfully +# validated. + my $dkim_sigs = $self->connection->notes('dkim_pass_domains') || []; + +# 4. Perform SPF validation checks. The results of this step are +# passed to the remainder of the algorithm and MUST include the +# domain name from the RFC5321.MailFrom if SPF evaluation returned +# a "pass" result. + my $spf_dom = $transaction->notes('spf_pass_host'); + +# 5. Conduct identifier alignment checks. With authentication checks +# and policy discovery performed, the Mail Receiver checks if +# Authenticated Identifiers fall into alignment as decribed in +# Section 4. If one or more of the Authenticated Identifiers align +# with the RFC5322.From domain, the message is considered to pass +# the DMARC mechanism check. All other conditions (authentication +# failures, identifier mismatches) are considered to be DMARC +# mechanism check failures. + foreach ( @$dkim_sigs ) { + if ( $_ eq $from_host ) { # strict alignment + $self->log(LOGINFO, "pass, DKIM alignment"); + $self->adjust_karma( 2 ); # big karma boost + return DECLINED; + }; + }; + + if ( $spf_dom && $spf_dom eq $from_host ) { + $self->adjust_karma( 2 ); # big karma boost + $self->log(LOGINFO, "pass, SPF alignment"); + return DECLINED; + }; + +# 6. Apply policy. Emails that fail the DMARC mechanism check are +# disposed of in accordance with the discovered DMARC policy of the +# Domain Owner. See Section 6.2 for details. + + $self->log(LOGINFO, "skip, NEED RELAXED alignment"); + return DECLINED; +}; + +sub discover_policy { + my ($self, $from_host) = @_; + +# 1. Mail Receivers MUST query the DNS for a DMARC TXT record at the +# DNS domain matching the one found in the RFC5322.From domain in +# the message. A possibly empty set of records is returned. + my @matches = $self->fetch_dmarc_record($from_host); # 2. within + if ( 0 == scalar @matches ) { +# 3. If the set is now empty, the Mail Receiver MUST query the DNS for +# a DMARC TXT record at the DNS domain matching the Organizational +# Domain in place of the RFC5322.From domain in the message (if +# different). This record can contain policy to be asserted for +# subdomains of the Organizational Domain. + + my $org_dom = $self->get_organizational_domain( $from_host ) or return; + if ( $org_dom eq $from_host ) { + $self->log( LOGINFO, "skip, no policy for $from_host (same org)" ); + return; + }; + @matches = $self->fetch_dmarc_record($org_dom); + + if ( 0 == scalar @matches ) { + $self->log( LOGINFO, "skip, no policy for $from_host" ); + return; + }; + }; + +# 4. Records that do not include a "v=" tag that identifies the +# current version of DMARC are discarded. + @matches = grep /v=DMARC1/i, @matches; + if ( 0 == scalar @matches ) { + $self->log( LOGINFO, "skip, no valid record for $from_host" ); + return; + }; + +# 5. If the remaining set contains multiple records, processing +# terminates and the Mail Receiver takes no action. + if ( @matches > 1 ) { + $self->log( LOGINFO, "skip, too many records" ); + return; + }; + +# 6. If a retrieved policy record does not contain a valid "p" tag, or +# contains an "sp" tag that is not valid, then: + my %policy = $self->parse_policy( $matches[0] ); + if ( ! $self->has_valid_p(\%policy) || $self->has_invalid_sp(\%policy) ) { + +# A. if an "rua" tag is present and contains at least one +# syntactically valid reporting URI, the Mail Receiver SHOULD +# act as if a record containing a valid "v" tag and "p=none" +# was retrieved, and continue processing; +# B. otherwise, the Mail Receiver SHOULD take no action. + my $rua = $policy{rua}; + if ( ! $rua || ! $self->has_valid_reporting_uri($rua) ) { + $self->log( LOGINFO, "skip, no valid reporting rua" ); + return; + }; + $policy{v} = 'DMARC1'; + $policy{p} = 'none'; + }; + + return \%policy; +}; + +sub has_valid_p { + my ($self, $policy) = @_; + return 1 if $self->{_args}{p_vals}{$policy}; + return 0; +}; + +sub has_invalid_sp { + my ($self, $policy) = @_; + return 0 if ! $self->{_args}{p_vals}{$policy}; + return 1; +}; + +sub has_valid_reporting_uri { + my ($self, $rua) = @_; + return 1 if 'mailto:' eq lc substr($rua, 0, 7); + return 0; +}; + +sub get_organizational_domain { + my ($self, $from_host) = @_; + +# 1. Acquire a "public suffix" list, i.e., a list of DNS domain +# names reserved for registrations. http://publicsuffix.org/list/ +# $self->qp->config('public_suffix_list') + +# 2. Break the subject DNS domain name into a set of "n" ordered +# labels. Number these labels from right-to-left; e.g. for +# "example.com", "com" would be label 1 and "example" would be +# label 2.; + my @labels = reverse split /\./, $from_host; + +# 3. Search the public suffix list for the name that matches the +# largest number of labels found in the subject DNS domain. Let +# that number be "x". + my $greatest = 0; + for ( my $i = 0; $i <= scalar @labels; $i++ ) { + next if ! $labels[$i]; + my $tld = join '.', reverse( (@labels)[0..$i] ); +# $self->log( LOGINFO, "i: $i, $tld" ); +#warn "i: $i - tld: $tld\n"; + if ( grep /$tld/, $self->qp->config('public_suffix_list') ) { + $greatest = $i + 1; + }; + }; + + return $from_host if $greatest == scalar @labels; # same + +# 4. Construct a new DNS domain name using the name that matched +# from the public suffix list and prefixing to it the "x+1"th +# label from the subject domain. This new name is the +# Organizational Domain. + return join '.', reverse( (@labels)[0..$greatest]); +}; + +sub exists_in_dns { + my ($self, $domain) = @_; + my $res = $self->init_resolver(); + my $query = $res->send( $domain, 'NS' ) or do { + if ( $res->errorstring eq 'NXDOMAIN' ) { + $self->log( LOGDEBUG, "fail, non-existent domain: $domain" ); + return; + }; + $self->log( LOGINFO, "error, looking up NS for $domain: " . $res->errorstring ); + return; + }; + my @matches; + for my $rr ($query->answer) { + next if $rr->type ne 'NS'; + push @matches, $rr->nsdname; + }; + if ( 0 == scalar @matches ) { + $self->log( LOGDEBUG, "fail, zero NS for $domain" ); + }; + return @matches; +}; + +sub fetch_dmarc_record { + my ($self, $zone) = @_; + my $res = $self->init_resolver(); + my $query = $res->send( '_dmarc.' . $zone, 'TXT' ); + my @matches; + for my $rr ($query->answer) { + next if $rr->type ne 'TXT'; +# 2. Records that do not start with a "v=" tag that identifies the +# current version of DMARC are discarded. + next if 'v=' ne substr( $rr->txtdata, 0, 2); + $self->log( LOGINFO, $rr->txtdata ); + push @matches, join('', $rr->txtdata); + }; + return @matches; +}; + +sub get_from_host { + my ($self, $transaction) = @_; + + my $from = $transaction->header->get('From') or do { + $self->log( LOGINFO, "error, unable to retrieve From header!" ); + return; + }; + my ($from_host) = (split /@/, $from)[-1]; # grab everything after the @ + ($from_host) = split /\s+/, $from_host; # remove any trailing cruft + chomp $from_host; + chop $from_host if '>' eq substr($from_host,-1,1); + $self->log( LOGDEBUG, "info, from_host is $from_host" ); + return $from_host; +}; + +sub parse_policy { + my ($self, $str) = @_; + $str =~ s/\s//g; # remove all whitespace + my %dmarc = map { split /=/, $_ } split /;/, $str; +#warn Data::Dumper::Dumper(\%dmarc); + return %dmarc; +}; + +sub verify_external_reporting { + +=head2 Verify External Destinations + + 1. Extract the host portion of the authority component of the URI. + Call this the "destination host". + + 2. Prepend the string "_report._dmarc". + + 3. Prepend the domain name from which the policy was retrieved. + + 4. Query the DNS for a TXT record at the constructed name. If the + result of this request is a temporary DNS error of some kind + (e.g., a timeout), the Mail Receiver MAY elect to temporarily + fail the delivery so the verification test can be repeated later. + + 5. If the result includes no TXT resource records or multiple TXT + resource records, a positive determination of the external + reporting relationship cannot be made; stop. + + 6. Parse the result, if any, as a series of "tag=value" pairs, i.e., + the same overall format as the policy record. In particular, the + "v=DMARC1" tag is mandatory and MUST appear first in the list. + If at least that tag is present and the record overall is + syntactically valid per Section 6.3, then the external reporting + arrangement was authorized by the destination ADMD. + + 7. If a "rua" or "ruf" tag is thus discovered, replace the + corresponding value extracted from the domain's DMARC policy + record with the one found in this record. This permits the + report receiver to override the report destination. However, to + prevent loops or indirect abuse, the overriding URI MUST use the + same destination host from the first step. + +=cut + +}; diff --git a/plugins/registry.txt b/plugins/registry.txt index a276584..f59a962 100644 --- a/plugins/registry.txt +++ b/plugins/registry.txt @@ -59,6 +59,7 @@ 64 dkim dkm dkim 65 spamassassin spm spama 66 dspam dsp dspam +67 dmarc dmc dmarc # # Anti-Virus Plugins # diff --git a/t/config/public_suffix_list b/t/config/public_suffix_list new file mode 100644 index 0000000..fdcd84e --- /dev/null +++ b/t/config/public_suffix_list @@ -0,0 +1,6998 @@ +// This Source Code Form is subject to the terms of the Mozilla Public +// License, v. 2.0. If a copy of the MPL was not distributed with this +// file, You can obtain one at http://mozilla.org/MPL/2.0/. + +// ===BEGIN ICANN DOMAINS=== + +// ac : http://en.wikipedia.org/wiki/.ac +ac +com.ac +edu.ac +gov.ac +net.ac +mil.ac +org.ac + +// ad : http://en.wikipedia.org/wiki/.ad +ad +nom.ad + +// ae : http://en.wikipedia.org/wiki/.ae +// see also: "Domain Name Eligibility Policy" at http://www.aeda.ae/eng/aepolicy.php +ae +co.ae +net.ae +org.ae +sch.ae +ac.ae +gov.ae +mil.ae + +// aero : see http://www.information.aero/index.php?id=66 +aero +accident-investigation.aero +accident-prevention.aero +aerobatic.aero +aeroclub.aero +aerodrome.aero +agents.aero +aircraft.aero +airline.aero +airport.aero +air-surveillance.aero +airtraffic.aero +air-traffic-control.aero +ambulance.aero +amusement.aero +association.aero +author.aero +ballooning.aero +broker.aero +caa.aero +cargo.aero +catering.aero +certification.aero +championship.aero +charter.aero +civilaviation.aero +club.aero +conference.aero +consultant.aero +consulting.aero +control.aero +council.aero +crew.aero +design.aero +dgca.aero +educator.aero +emergency.aero +engine.aero +engineer.aero +entertainment.aero +equipment.aero +exchange.aero +express.aero +federation.aero +flight.aero +freight.aero +fuel.aero +gliding.aero +government.aero +groundhandling.aero +group.aero +hanggliding.aero +homebuilt.aero +insurance.aero +journal.aero +journalist.aero +leasing.aero +logistics.aero +magazine.aero +maintenance.aero +marketplace.aero +media.aero +microlight.aero +modelling.aero +navigation.aero +parachuting.aero +paragliding.aero +passenger-association.aero +pilot.aero +press.aero +production.aero +recreation.aero +repbody.aero +res.aero +research.aero +rotorcraft.aero +safety.aero +scientist.aero +services.aero +show.aero +skydiving.aero +software.aero +student.aero +taxi.aero +trader.aero +trading.aero +trainer.aero +union.aero +workinggroup.aero +works.aero + +// af : http://www.nic.af/help.jsp +af +gov.af +com.af +org.af +net.af +edu.af + +// ag : http://www.nic.ag/prices.htm +ag +com.ag +org.ag +net.ag +co.ag +nom.ag + +// ai : http://nic.com.ai/ +ai +off.ai +com.ai +net.ai +org.ai + +// al : http://www.ert.gov.al/ert_alb/faq_det.html?Id=31 +al +com.al +edu.al +gov.al +mil.al +net.al +org.al + +// am : http://en.wikipedia.org/wiki/.am +am + +// an : http://www.una.an/an_domreg/default.asp +an +com.an +net.an +org.an +edu.an + +// ao : http://en.wikipedia.org/wiki/.ao +// http://www.dns.ao/REGISTR.DOC +ao +ed.ao +gv.ao +og.ao +co.ao +pb.ao +it.ao + +// aq : http://en.wikipedia.org/wiki/.aq +aq + +// ar : http://en.wikipedia.org/wiki/.ar +*.ar +!congresodelalengua3.ar +!educ.ar +!gobiernoelectronico.ar +!mecon.ar +!nacion.ar +!nic.ar +!promocion.ar +!retina.ar +!uba.ar + +// arpa : http://en.wikipedia.org/wiki/.arpa +// Confirmed by registry 2008-06-18 +e164.arpa +in-addr.arpa +ip6.arpa +iris.arpa +uri.arpa +urn.arpa + +// as : http://en.wikipedia.org/wiki/.as +as +gov.as + +// asia : http://en.wikipedia.org/wiki/.asia +asia + +// at : http://en.wikipedia.org/wiki/.at +// Confirmed by registry 2008-06-17 +at +ac.at +co.at +gv.at +or.at + +// au : http://en.wikipedia.org/wiki/.au +// http://www.auda.org.au/ +// 2LDs +com.au +net.au +org.au +edu.au +gov.au +asn.au +id.au +// Historic 2LDs (closed to new registration, but sites still exist) +info.au +conf.au +oz.au +// CGDNs - http://www.cgdn.org.au/ +act.au +nsw.au +nt.au +qld.au +sa.au +tas.au +vic.au +wa.au +// 3LDs +act.edu.au +nsw.edu.au +nt.edu.au +qld.edu.au +sa.edu.au +tas.edu.au +vic.edu.au +wa.edu.au +act.gov.au +// Removed at request of Shae.Donelan@services.nsw.gov.au, 2010-03-04 +// nsw.gov.au +nt.gov.au +qld.gov.au +sa.gov.au +tas.gov.au +vic.gov.au +wa.gov.au + +// aw : http://en.wikipedia.org/wiki/.aw +aw +com.aw + +// ax : http://en.wikipedia.org/wiki/.ax +ax + +// az : http://en.wikipedia.org/wiki/.az +az +com.az +net.az +int.az +gov.az +org.az +edu.az +info.az +pp.az +mil.az +name.az +pro.az +biz.az + +// ba : http://en.wikipedia.org/wiki/.ba +ba +org.ba +net.ba +edu.ba +gov.ba +mil.ba +unsa.ba +unbi.ba +co.ba +com.ba +rs.ba + +// bb : http://en.wikipedia.org/wiki/.bb +bb +biz.bb +com.bb +edu.bb +gov.bb +info.bb +net.bb +org.bb +store.bb + +// bd : http://en.wikipedia.org/wiki/.bd +*.bd + +// be : http://en.wikipedia.org/wiki/.be +// Confirmed by registry 2008-06-08 +be +ac.be + +// bf : http://en.wikipedia.org/wiki/.bf +bf +gov.bf + +// bg : http://en.wikipedia.org/wiki/.bg +// https://www.register.bg/user/static/rules/en/index.html +bg +a.bg +b.bg +c.bg +d.bg +e.bg +f.bg +g.bg +h.bg +i.bg +j.bg +k.bg +l.bg +m.bg +n.bg +o.bg +p.bg +q.bg +r.bg +s.bg +t.bg +u.bg +v.bg +w.bg +x.bg +y.bg +z.bg +0.bg +1.bg +2.bg +3.bg +4.bg +5.bg +6.bg +7.bg +8.bg +9.bg + +// bh : http://en.wikipedia.org/wiki/.bh +bh +com.bh +edu.bh +net.bh +org.bh +gov.bh + +// bi : http://en.wikipedia.org/wiki/.bi +// http://whois.nic.bi/ +bi +co.bi +com.bi +edu.bi +or.bi +org.bi + +// biz : http://en.wikipedia.org/wiki/.biz +biz + +// bj : http://en.wikipedia.org/wiki/.bj +bj +asso.bj +barreau.bj +gouv.bj + +// bm : http://www.bermudanic.bm/dnr-text.txt +bm +com.bm +edu.bm +gov.bm +net.bm +org.bm + +// bn : http://en.wikipedia.org/wiki/.bn +*.bn + +// bo : http://www.nic.bo/ +bo +com.bo +edu.bo +gov.bo +gob.bo +int.bo +org.bo +net.bo +mil.bo +tv.bo + +// br : http://registro.br/dominio/dpn.html +// Updated by registry 2011-03-01 +br +adm.br +adv.br +agr.br +am.br +arq.br +art.br +ato.br +b.br +bio.br +blog.br +bmd.br +cim.br +cng.br +cnt.br +com.br +coop.br +ecn.br +eco.br +edu.br +emp.br +eng.br +esp.br +etc.br +eti.br +far.br +flog.br +fm.br +fnd.br +fot.br +fst.br +g12.br +ggf.br +gov.br +imb.br +ind.br +inf.br +jor.br +jus.br +leg.br +lel.br +mat.br +med.br +mil.br +mus.br +net.br +nom.br +not.br +ntr.br +odo.br +org.br +ppg.br +pro.br +psc.br +psi.br +qsl.br +radio.br +rec.br +slg.br +srv.br +taxi.br +teo.br +tmp.br +trd.br +tur.br +tv.br +vet.br +vlog.br +wiki.br +zlg.br + +// bs : http://www.nic.bs/rules.html +bs +com.bs +net.bs +org.bs +edu.bs +gov.bs + +// bt : http://en.wikipedia.org/wiki/.bt +bt +com.bt +edu.bt +gov.bt +net.bt +org.bt + +// bv : No registrations at this time. +// Submitted by registry 2006-06-16 + +// bw : http://en.wikipedia.org/wiki/.bw +// http://www.gobin.info/domainname/bw.doc +// list of other 2nd level tlds ? +bw +co.bw +org.bw + +// by : http://en.wikipedia.org/wiki/.by +// http://tld.by/rules_2006_en.html +// list of other 2nd level tlds ? +by +gov.by +mil.by +// Official information does not indicate that com.by is a reserved +// second-level domain, but it's being used as one (see www.google.com.by and +// www.yahoo.com.by, for example), so we list it here for safety's sake. +com.by + +// http://hoster.by/ +of.by + +// bz : http://en.wikipedia.org/wiki/.bz +// http://www.belizenic.bz/ +bz +com.bz +net.bz +org.bz +edu.bz +gov.bz + +// ca : http://en.wikipedia.org/wiki/.ca +ca +// ca geographical names +ab.ca +bc.ca +mb.ca +nb.ca +nf.ca +nl.ca +ns.ca +nt.ca +nu.ca +on.ca +pe.ca +qc.ca +sk.ca +yk.ca +// gc.ca: http://en.wikipedia.org/wiki/.gc.ca +// see also: http://registry.gc.ca/en/SubdomainFAQ +gc.ca + +// cat : http://en.wikipedia.org/wiki/.cat +cat + +// cc : http://en.wikipedia.org/wiki/.cc +cc + +// cd : http://en.wikipedia.org/wiki/.cd +// see also: https://www.nic.cd/domain/insertDomain_2.jsp?act=1 +cd +gov.cd + +// cf : http://en.wikipedia.org/wiki/.cf +cf + +// cg : http://en.wikipedia.org/wiki/.cg +cg + +// ch : http://en.wikipedia.org/wiki/.ch +ch + +// ci : http://en.wikipedia.org/wiki/.ci +// http://www.nic.ci/index.php?page=charte +ci +org.ci +or.ci +com.ci +co.ci +edu.ci +ed.ci +ac.ci +net.ci +go.ci +asso.ci +aéroport.ci +int.ci +presse.ci +md.ci +gouv.ci + +// ck : http://en.wikipedia.org/wiki/.ck +*.ck +!www.ck + +// cl : http://en.wikipedia.org/wiki/.cl +cl +gov.cl +gob.cl +co.cl +mil.cl + +// cm : http://en.wikipedia.org/wiki/.cm +cm +gov.cm + +// cn : http://en.wikipedia.org/wiki/.cn +// Submitted by registry 2008-06-11 +cn +ac.cn +com.cn +edu.cn +gov.cn +net.cn +org.cn +mil.cn +公司.cn +网络.cn +網絡.cn +// cn geographic names +ah.cn +bj.cn +cq.cn +fj.cn +gd.cn +gs.cn +gz.cn +gx.cn +ha.cn +hb.cn +he.cn +hi.cn +hl.cn +hn.cn +jl.cn +js.cn +jx.cn +ln.cn +nm.cn +nx.cn +qh.cn +sc.cn +sd.cn +sh.cn +sn.cn +sx.cn +tj.cn +xj.cn +xz.cn +yn.cn +zj.cn +hk.cn +mo.cn +tw.cn + +// co : http://en.wikipedia.org/wiki/.co +// Submitted by registry 2008-06-11 +co +arts.co +com.co +edu.co +firm.co +gov.co +info.co +int.co +mil.co +net.co +nom.co +org.co +rec.co +web.co + +// com : http://en.wikipedia.org/wiki/.com +com + +// coop : http://en.wikipedia.org/wiki/.coop +coop + +// cr : http://www.nic.cr/niccr_publico/showRegistroDominiosScreen.do +cr +ac.cr +co.cr +ed.cr +fi.cr +go.cr +or.cr +sa.cr + +// cu : http://en.wikipedia.org/wiki/.cu +cu +com.cu +edu.cu +org.cu +net.cu +gov.cu +inf.cu + +// cv : http://en.wikipedia.org/wiki/.cv +cv + +// cw : http://www.una.cw/cw_registry/ +// Confirmed by registry 2013-03-26 +cw +com.cw +edu.cw +net.cw +org.cw + +// cx : http://en.wikipedia.org/wiki/.cx +// list of other 2nd level tlds ? +cx +gov.cx + +// cy : http://en.wikipedia.org/wiki/.cy +*.cy + +// cz : http://en.wikipedia.org/wiki/.cz +cz + +// de : http://en.wikipedia.org/wiki/.de +// Confirmed by registry (with technical +// reservations) 2008-07-01 +de + +// dj : http://en.wikipedia.org/wiki/.dj +dj + +// dk : http://en.wikipedia.org/wiki/.dk +// Confirmed by registry 2008-06-17 +dk + +// dm : http://en.wikipedia.org/wiki/.dm +dm +com.dm +net.dm +org.dm +edu.dm +gov.dm + +// do : http://en.wikipedia.org/wiki/.do +do +art.do +com.do +edu.do +gob.do +gov.do +mil.do +net.do +org.do +sld.do +web.do + +// dz : http://en.wikipedia.org/wiki/.dz +dz +com.dz +org.dz +net.dz +gov.dz +edu.dz +asso.dz +pol.dz +art.dz + +// ec : http://www.nic.ec/reg/paso1.asp +// Submitted by registry 2008-07-04 +ec +com.ec +info.ec +net.ec +fin.ec +k12.ec +med.ec +pro.ec +org.ec +edu.ec +gov.ec +gob.ec +mil.ec + +// edu : http://en.wikipedia.org/wiki/.edu +edu + +// ee : http://www.eenet.ee/EENet/dom_reeglid.html#lisa_B +ee +edu.ee +gov.ee +riik.ee +lib.ee +med.ee +com.ee +pri.ee +aip.ee +org.ee +fie.ee + +// eg : http://en.wikipedia.org/wiki/.eg +eg +com.eg +edu.eg +eun.eg +gov.eg +mil.eg +name.eg +net.eg +org.eg +sci.eg + +// er : http://en.wikipedia.org/wiki/.er +*.er + +// es : https://www.nic.es/site_ingles/ingles/dominios/index.html +es +com.es +nom.es +org.es +gob.es +edu.es + +// et : http://en.wikipedia.org/wiki/.et +*.et + +// eu : http://en.wikipedia.org/wiki/.eu +eu + +// fi : http://en.wikipedia.org/wiki/.fi +fi +// aland.fi : http://en.wikipedia.org/wiki/.ax +// This domain is being phased out in favor of .ax. As there are still many +// domains under aland.fi, we still keep it on the list until aland.fi is +// completely removed. +// TODO: Check for updates (expected to be phased out around Q1/2009) +aland.fi + +// fj : http://en.wikipedia.org/wiki/.fj +*.fj + +// fk : http://en.wikipedia.org/wiki/.fk +*.fk + +// fm : http://en.wikipedia.org/wiki/.fm +fm + +// fo : http://en.wikipedia.org/wiki/.fo +fo + +// fr : http://www.afnic.fr/ +// domaines descriptifs : http://www.afnic.fr/obtenir/chartes/nommage-fr/annexe-descriptifs +fr +com.fr +asso.fr +nom.fr +prd.fr +presse.fr +tm.fr +// domaines sectoriels : http://www.afnic.fr/obtenir/chartes/nommage-fr/annexe-sectoriels +aeroport.fr +assedic.fr +avocat.fr +avoues.fr +cci.fr +chambagri.fr +chirurgiens-dentistes.fr +experts-comptables.fr +geometre-expert.fr +gouv.fr +greta.fr +huissier-justice.fr +medecin.fr +notaires.fr +pharmacien.fr +port.fr +veterinaire.fr + +// ga : http://en.wikipedia.org/wiki/.ga +ga + +// gb : This registry is effectively dormant +// Submitted by registry 2008-06-12 + +// gd : http://en.wikipedia.org/wiki/.gd +gd + +// ge : http://www.nic.net.ge/policy_en.pdf +ge +com.ge +edu.ge +gov.ge +org.ge +mil.ge +net.ge +pvt.ge + +// gf : http://en.wikipedia.org/wiki/.gf +gf + +// gg : http://www.channelisles.net/applic/avextn.shtml +gg +co.gg +org.gg +net.gg +sch.gg +gov.gg + +// gh : http://en.wikipedia.org/wiki/.gh +// see also: http://www.nic.gh/reg_now.php +// Although domains directly at second level are not possible at the moment, +// they have been possible for some time and may come back. +gh +com.gh +edu.gh +gov.gh +org.gh +mil.gh + +// gi : http://www.nic.gi/rules.html +gi +com.gi +ltd.gi +gov.gi +mod.gi +edu.gi +org.gi + +// gl : http://en.wikipedia.org/wiki/.gl +// http://nic.gl +gl + +// gm : http://www.nic.gm/htmlpages%5Cgm-policy.htm +gm + +// gn : http://psg.com/dns/gn/gn.txt +// Submitted by registry 2008-06-17 +ac.gn +com.gn +edu.gn +gov.gn +org.gn +net.gn + +// gov : http://en.wikipedia.org/wiki/.gov +gov + +// gp : http://www.nic.gp/index.php?lang=en +gp +com.gp +net.gp +mobi.gp +edu.gp +org.gp +asso.gp + +// gq : http://en.wikipedia.org/wiki/.gq +gq + +// gr : https://grweb.ics.forth.gr/english/1617-B-2005.html +// Submitted by registry 2008-06-09 +gr +com.gr +edu.gr +net.gr +org.gr +gov.gr + +// gs : http://en.wikipedia.org/wiki/.gs +gs + +// gt : http://www.gt/politicas_de_registro.html +gt +com.gt +edu.gt +gob.gt +ind.gt +mil.gt +net.gt +org.gt + +// gu : http://gadao.gov.gu/registration.txt +*.gu + +// gw : http://en.wikipedia.org/wiki/.gw +gw + +// gy : http://en.wikipedia.org/wiki/.gy +// http://registry.gy/ +gy +co.gy +com.gy +net.gy + +// hk : https://www.hkdnr.hk +// Submitted by registry 2008-06-11 +hk +com.hk +edu.hk +gov.hk +idv.hk +net.hk +org.hk +公司.hk +教育.hk +敎育.hk +政府.hk +個人.hk +个人.hk +箇人.hk +網络.hk +网络.hk +组織.hk +網絡.hk +网絡.hk +组织.hk +組織.hk +組织.hk + +// hm : http://en.wikipedia.org/wiki/.hm +hm + +// hn : http://www.nic.hn/politicas/ps02,,05.html +hn +com.hn +edu.hn +org.hn +net.hn +mil.hn +gob.hn + +// hr : http://www.dns.hr/documents/pdf/HRTLD-regulations.pdf +hr +iz.hr +from.hr +name.hr +com.hr + +// ht : http://www.nic.ht/info/charte.cfm +ht +com.ht +shop.ht +firm.ht +info.ht +adult.ht +net.ht +pro.ht +org.ht +med.ht +art.ht +coop.ht +pol.ht +asso.ht +edu.ht +rel.ht +gouv.ht +perso.ht + +// hu : http://www.domain.hu/domain/English/sld.html +// Confirmed by registry 2008-06-12 +hu +co.hu +info.hu +org.hu +priv.hu +sport.hu +tm.hu +2000.hu +agrar.hu +bolt.hu +casino.hu +city.hu +erotica.hu +erotika.hu +film.hu +forum.hu +games.hu +hotel.hu +ingatlan.hu +jogasz.hu +konyvelo.hu +lakas.hu +media.hu +news.hu +reklam.hu +sex.hu +shop.hu +suli.hu +szex.hu +tozsde.hu +utazas.hu +video.hu + +// id : https://register.pandi.or.id/ +id +ac.id +biz.id +co.id +go.id +mil.id +my.id +net.id +or.id +sch.id +web.id + +// ie : http://en.wikipedia.org/wiki/.ie +ie +gov.ie + +// il : http://en.wikipedia.org/wiki/.il +*.il + +// im : https://www.nic.im/pdfs/imfaqs.pdf +im +co.im +ltd.co.im +plc.co.im +net.im +gov.im +org.im +nic.im +ac.im + +// in : http://en.wikipedia.org/wiki/.in +// see also: http://www.inregistry.in/policies/ +// Please note, that nic.in is not an offical eTLD, but used by most +// government institutions. +in +co.in +firm.in +net.in +org.in +gen.in +ind.in +nic.in +ac.in +edu.in +res.in +gov.in +mil.in + +// info : http://en.wikipedia.org/wiki/.info +info + +// int : http://en.wikipedia.org/wiki/.int +// Confirmed by registry 2008-06-18 +int +eu.int + +// io : http://www.nic.io/rules.html +// list of other 2nd level tlds ? +io +com.io + +// iq : http://www.cmc.iq/english/iq/iqregister1.htm +iq +gov.iq +edu.iq +mil.iq +com.iq +org.iq +net.iq + +// ir : http://www.nic.ir/Terms_and_Conditions_ir,_Appendix_1_Domain_Rules +// Also see http://www.nic.ir/Internationalized_Domain_Names +// Two .ir entries added at request of , 2010-04-16 +ir +ac.ir +co.ir +gov.ir +id.ir +net.ir +org.ir +sch.ir +// xn--mgba3a4f16a.ir (.ir, Persian YEH) +ایران.ir +// xn--mgba3a4fra.ir (.ir, Arabic YEH) +ايران.ir + +// is : http://www.isnic.is/domain/rules.php +// Confirmed by registry 2008-12-06 +is +net.is +com.is +edu.is +gov.is +org.is +int.is + +// it : http://en.wikipedia.org/wiki/.it +it +gov.it +edu.it +// list of reserved geo-names : +// http://www.nic.it/documenti/regolamenti-e-linee-guida/regolamento-assegnazione-versione-6.0.pdf +// (There is also a list of reserved geo-names corresponding to Italian +// municipalities : http://www.nic.it/documenti/appendice-c.pdf , but it is +// not included here.) +agrigento.it +ag.it +alessandria.it +al.it +ancona.it +an.it +aosta.it +aoste.it +ao.it +arezzo.it +ar.it +ascoli-piceno.it +ascolipiceno.it +ap.it +asti.it +at.it +avellino.it +av.it +bari.it +ba.it +andria-barletta-trani.it +andriabarlettatrani.it +trani-barletta-andria.it +tranibarlettaandria.it +barletta-trani-andria.it +barlettatraniandria.it +andria-trani-barletta.it +andriatranibarletta.it +trani-andria-barletta.it +traniandriabarletta.it +bt.it +belluno.it +bl.it +benevento.it +bn.it +bergamo.it +bg.it +biella.it +bi.it +bologna.it +bo.it +bolzano.it +bozen.it +balsan.it +alto-adige.it +altoadige.it +suedtirol.it +bz.it +brescia.it +bs.it +brindisi.it +br.it +cagliari.it +ca.it +caltanissetta.it +cl.it +campobasso.it +cb.it +carboniaiglesias.it +carbonia-iglesias.it +iglesias-carbonia.it +iglesiascarbonia.it +ci.it +caserta.it +ce.it +catania.it +ct.it +catanzaro.it +cz.it +chieti.it +ch.it +como.it +co.it +cosenza.it +cs.it +cremona.it +cr.it +crotone.it +kr.it +cuneo.it +cn.it +dell-ogliastra.it +dellogliastra.it +ogliastra.it +og.it +enna.it +en.it +ferrara.it +fe.it +fermo.it +fm.it +firenze.it +florence.it +fi.it +foggia.it +fg.it +forli-cesena.it +forlicesena.it +cesena-forli.it +cesenaforli.it +fc.it +frosinone.it +fr.it +genova.it +genoa.it +ge.it +gorizia.it +go.it +grosseto.it +gr.it +imperia.it +im.it +isernia.it +is.it +laquila.it +aquila.it +aq.it +la-spezia.it +laspezia.it +sp.it +latina.it +lt.it +lecce.it +le.it +lecco.it +lc.it +livorno.it +li.it +lodi.it +lo.it +lucca.it +lu.it +macerata.it +mc.it +mantova.it +mn.it +massa-carrara.it +massacarrara.it +carrara-massa.it +carraramassa.it +ms.it +matera.it +mt.it +medio-campidano.it +mediocampidano.it +campidano-medio.it +campidanomedio.it +vs.it +messina.it +me.it +milano.it +milan.it +mi.it +modena.it +mo.it +monza.it +monza-brianza.it +monzabrianza.it +monzaebrianza.it +monzaedellabrianza.it +monza-e-della-brianza.it +mb.it +napoli.it +naples.it +na.it +novara.it +no.it +nuoro.it +nu.it +oristano.it +or.it +padova.it +padua.it +pd.it +palermo.it +pa.it +parma.it +pr.it +pavia.it +pv.it +perugia.it +pg.it +pescara.it +pe.it +pesaro-urbino.it +pesarourbino.it +urbino-pesaro.it +urbinopesaro.it +pu.it +piacenza.it +pc.it +pisa.it +pi.it +pistoia.it +pt.it +pordenone.it +pn.it +potenza.it +pz.it +prato.it +po.it +ragusa.it +rg.it +ravenna.it +ra.it +reggio-calabria.it +reggiocalabria.it +rc.it +reggio-emilia.it +reggioemilia.it +re.it +rieti.it +ri.it +rimini.it +rn.it +roma.it +rome.it +rm.it +rovigo.it +ro.it +salerno.it +sa.it +sassari.it +ss.it +savona.it +sv.it +siena.it +si.it +siracusa.it +sr.it +sondrio.it +so.it +taranto.it +ta.it +tempio-olbia.it +tempioolbia.it +olbia-tempio.it +olbiatempio.it +ot.it +teramo.it +te.it +terni.it +tr.it +torino.it +turin.it +to.it +trapani.it +tp.it +trento.it +trentino.it +tn.it +treviso.it +tv.it +trieste.it +ts.it +udine.it +ud.it +varese.it +va.it +venezia.it +venice.it +ve.it +verbania.it +vb.it +vercelli.it +vc.it +verona.it +vr.it +vibo-valentia.it +vibovalentia.it +vv.it +vicenza.it +vi.it +viterbo.it +vt.it + +// je : http://www.channelisles.net/applic/avextn.shtml +je +co.je +org.je +net.je +sch.je +gov.je + +// jm : http://www.com.jm/register.html +*.jm + +// jo : http://www.dns.jo/Registration_policy.aspx +jo +com.jo +org.jo +net.jo +edu.jo +sch.jo +gov.jo +mil.jo +name.jo + +// jobs : http://en.wikipedia.org/wiki/.jobs +jobs + +// jp : http://en.wikipedia.org/wiki/.jp +// http://jprs.co.jp/en/jpdomain.html +// Updated by registry 2012-05-28 +jp +// jp organizational type names +ac.jp +ad.jp +co.jp +ed.jp +go.jp +gr.jp +lg.jp +ne.jp +or.jp +// jp preficture type names +aichi.jp +akita.jp +aomori.jp +chiba.jp +ehime.jp +fukui.jp +fukuoka.jp +fukushima.jp +gifu.jp +gunma.jp +hiroshima.jp +hokkaido.jp +hyogo.jp +ibaraki.jp +ishikawa.jp +iwate.jp +kagawa.jp +kagoshima.jp +kanagawa.jp +kochi.jp +kumamoto.jp +kyoto.jp +mie.jp +miyagi.jp +miyazaki.jp +nagano.jp +nagasaki.jp +nara.jp +niigata.jp +oita.jp +okayama.jp +okinawa.jp +osaka.jp +saga.jp +saitama.jp +shiga.jp +shimane.jp +shizuoka.jp +tochigi.jp +tokushima.jp +tokyo.jp +tottori.jp +toyama.jp +wakayama.jp +yamagata.jp +yamaguchi.jp +yamanashi.jp +// jp geographic type names +// http://jprs.jp/doc/rule/saisoku-1.html +*.kawasaki.jp +*.kitakyushu.jp +*.kobe.jp +*.nagoya.jp +*.sapporo.jp +*.sendai.jp +*.yokohama.jp +!city.kawasaki.jp +!city.kitakyushu.jp +!city.kobe.jp +!city.nagoya.jp +!city.sapporo.jp +!city.sendai.jp +!city.yokohama.jp +// 4th level registration +aisai.aichi.jp +ama.aichi.jp +anjo.aichi.jp +asuke.aichi.jp +chiryu.aichi.jp +chita.aichi.jp +fuso.aichi.jp +gamagori.aichi.jp +handa.aichi.jp +hazu.aichi.jp +hekinan.aichi.jp +higashiura.aichi.jp +ichinomiya.aichi.jp +inazawa.aichi.jp +inuyama.aichi.jp +isshiki.aichi.jp +iwakura.aichi.jp +kanie.aichi.jp +kariya.aichi.jp +kasugai.aichi.jp +kira.aichi.jp +kiyosu.aichi.jp +komaki.aichi.jp +konan.aichi.jp +kota.aichi.jp +mihama.aichi.jp +miyoshi.aichi.jp +nagakute.aichi.jp +nishio.aichi.jp +nisshin.aichi.jp +obu.aichi.jp +oguchi.aichi.jp +oharu.aichi.jp +okazaki.aichi.jp +owariasahi.aichi.jp +seto.aichi.jp +shikatsu.aichi.jp +shinshiro.aichi.jp +shitara.aichi.jp +tahara.aichi.jp +takahama.aichi.jp +tobishima.aichi.jp +toei.aichi.jp +togo.aichi.jp +tokai.aichi.jp +tokoname.aichi.jp +toyoake.aichi.jp +toyohashi.aichi.jp +toyokawa.aichi.jp +toyone.aichi.jp +toyota.aichi.jp +tsushima.aichi.jp +yatomi.aichi.jp +akita.akita.jp +daisen.akita.jp +fujisato.akita.jp +gojome.akita.jp +hachirogata.akita.jp +happou.akita.jp +higashinaruse.akita.jp +honjo.akita.jp +honjyo.akita.jp +ikawa.akita.jp +kamikoani.akita.jp +kamioka.akita.jp +katagami.akita.jp +kazuno.akita.jp +kitaakita.akita.jp +kosaka.akita.jp +kyowa.akita.jp +misato.akita.jp +mitane.akita.jp +moriyoshi.akita.jp +nikaho.akita.jp +noshiro.akita.jp +odate.akita.jp +oga.akita.jp +ogata.akita.jp +semboku.akita.jp +yokote.akita.jp +yurihonjo.akita.jp +aomori.aomori.jp +gonohe.aomori.jp +hachinohe.aomori.jp +hashikami.aomori.jp +hiranai.aomori.jp +hirosaki.aomori.jp +itayanagi.aomori.jp +kuroishi.aomori.jp +misawa.aomori.jp +mutsu.aomori.jp +nakadomari.aomori.jp +noheji.aomori.jp +oirase.aomori.jp +owani.aomori.jp +rokunohe.aomori.jp +sannohe.aomori.jp +shichinohe.aomori.jp +shingo.aomori.jp +takko.aomori.jp +towada.aomori.jp +tsugaru.aomori.jp +tsuruta.aomori.jp +abiko.chiba.jp +asahi.chiba.jp +chonan.chiba.jp +chosei.chiba.jp +choshi.chiba.jp +chuo.chiba.jp +funabashi.chiba.jp +futtsu.chiba.jp +hanamigawa.chiba.jp +ichihara.chiba.jp +ichikawa.chiba.jp +ichinomiya.chiba.jp +inzai.chiba.jp +isumi.chiba.jp +kamagaya.chiba.jp +kamogawa.chiba.jp +kashiwa.chiba.jp +katori.chiba.jp +katsuura.chiba.jp +kimitsu.chiba.jp +kisarazu.chiba.jp +kozaki.chiba.jp +kujukuri.chiba.jp +kyonan.chiba.jp +matsudo.chiba.jp +midori.chiba.jp +mihama.chiba.jp +minamiboso.chiba.jp +mobara.chiba.jp +mutsuzawa.chiba.jp +nagara.chiba.jp +nagareyama.chiba.jp +narashino.chiba.jp +narita.chiba.jp +noda.chiba.jp +oamishirasato.chiba.jp +omigawa.chiba.jp +onjuku.chiba.jp +otaki.chiba.jp +sakae.chiba.jp +sakura.chiba.jp +shimofusa.chiba.jp +shirako.chiba.jp +shiroi.chiba.jp +shisui.chiba.jp +sodegaura.chiba.jp +sosa.chiba.jp +tako.chiba.jp +tateyama.chiba.jp +togane.chiba.jp +tohnosho.chiba.jp +tomisato.chiba.jp +urayasu.chiba.jp +yachimata.chiba.jp +yachiyo.chiba.jp +yokaichiba.chiba.jp +yokoshibahikari.chiba.jp +yotsukaido.chiba.jp +ainan.ehime.jp +honai.ehime.jp +ikata.ehime.jp +imabari.ehime.jp +iyo.ehime.jp +kamijima.ehime.jp +kihoku.ehime.jp +kumakogen.ehime.jp +masaki.ehime.jp +matsuno.ehime.jp +matsuyama.ehime.jp +namikata.ehime.jp +niihama.ehime.jp +ozu.ehime.jp +saijo.ehime.jp +seiyo.ehime.jp +shikokuchuo.ehime.jp +tobe.ehime.jp +toon.ehime.jp +uchiko.ehime.jp +uwajima.ehime.jp +yawatahama.ehime.jp +echizen.fukui.jp +eiheiji.fukui.jp +fukui.fukui.jp +ikeda.fukui.jp +katsuyama.fukui.jp +mihama.fukui.jp +minamiechizen.fukui.jp +obama.fukui.jp +ohi.fukui.jp +ono.fukui.jp +sabae.fukui.jp +sakai.fukui.jp +takahama.fukui.jp +tsuruga.fukui.jp +wakasa.fukui.jp +ashiya.fukuoka.jp +buzen.fukuoka.jp +chikugo.fukuoka.jp +chikuho.fukuoka.jp +chikujo.fukuoka.jp +chikushino.fukuoka.jp +chikuzen.fukuoka.jp +chuo.fukuoka.jp +dazaifu.fukuoka.jp +fukuchi.fukuoka.jp +hakata.fukuoka.jp +higashi.fukuoka.jp +hirokawa.fukuoka.jp +hisayama.fukuoka.jp +iizuka.fukuoka.jp +inatsuki.fukuoka.jp +kaho.fukuoka.jp +kasuga.fukuoka.jp +kasuya.fukuoka.jp +kawara.fukuoka.jp +keisen.fukuoka.jp +koga.fukuoka.jp +kurate.fukuoka.jp +kurogi.fukuoka.jp +kurume.fukuoka.jp +minami.fukuoka.jp +miyako.fukuoka.jp +miyama.fukuoka.jp +miyawaka.fukuoka.jp +mizumaki.fukuoka.jp +munakata.fukuoka.jp +nakagawa.fukuoka.jp +nakama.fukuoka.jp +nishi.fukuoka.jp +nogata.fukuoka.jp +ogori.fukuoka.jp +okagaki.fukuoka.jp +okawa.fukuoka.jp +oki.fukuoka.jp +omuta.fukuoka.jp +onga.fukuoka.jp +onojo.fukuoka.jp +oto.fukuoka.jp +saigawa.fukuoka.jp +sasaguri.fukuoka.jp +shingu.fukuoka.jp +shinyoshitomi.fukuoka.jp +shonai.fukuoka.jp +soeda.fukuoka.jp +sue.fukuoka.jp +tachiarai.fukuoka.jp +tagawa.fukuoka.jp +takata.fukuoka.jp +toho.fukuoka.jp +toyotsu.fukuoka.jp +tsuiki.fukuoka.jp +ukiha.fukuoka.jp +umi.fukuoka.jp +usui.fukuoka.jp +yamada.fukuoka.jp +yame.fukuoka.jp +yanagawa.fukuoka.jp +yukuhashi.fukuoka.jp +aizubange.fukushima.jp +aizumisato.fukushima.jp +aizuwakamatsu.fukushima.jp +asakawa.fukushima.jp +bandai.fukushima.jp +date.fukushima.jp +fukushima.fukushima.jp +furudono.fukushima.jp +futaba.fukushima.jp +hanawa.fukushima.jp +higashi.fukushima.jp +hirata.fukushima.jp +hirono.fukushima.jp +iitate.fukushima.jp +inawashiro.fukushima.jp +ishikawa.fukushima.jp +iwaki.fukushima.jp +izumizaki.fukushima.jp +kagamiishi.fukushima.jp +kaneyama.fukushima.jp +kawamata.fukushima.jp +kitakata.fukushima.jp +kitashiobara.fukushima.jp +koori.fukushima.jp +koriyama.fukushima.jp +kunimi.fukushima.jp +miharu.fukushima.jp +mishima.fukushima.jp +namie.fukushima.jp +nango.fukushima.jp +nishiaizu.fukushima.jp +nishigo.fukushima.jp +okuma.fukushima.jp +omotego.fukushima.jp +ono.fukushima.jp +otama.fukushima.jp +samegawa.fukushima.jp +shimogo.fukushima.jp +shirakawa.fukushima.jp +showa.fukushima.jp +soma.fukushima.jp +sukagawa.fukushima.jp +taishin.fukushima.jp +tamakawa.fukushima.jp +tanagura.fukushima.jp +tenei.fukushima.jp +yabuki.fukushima.jp +yamato.fukushima.jp +yamatsuri.fukushima.jp +yanaizu.fukushima.jp +yugawa.fukushima.jp +anpachi.gifu.jp +ena.gifu.jp +gifu.gifu.jp +ginan.gifu.jp +godo.gifu.jp +gujo.gifu.jp +hashima.gifu.jp +hichiso.gifu.jp +hida.gifu.jp +higashishirakawa.gifu.jp +ibigawa.gifu.jp +ikeda.gifu.jp +kakamigahara.gifu.jp +kani.gifu.jp +kasahara.gifu.jp +kasamatsu.gifu.jp +kawaue.gifu.jp +kitagata.gifu.jp +mino.gifu.jp +minokamo.gifu.jp +mitake.gifu.jp +mizunami.gifu.jp +motosu.gifu.jp +nakatsugawa.gifu.jp +ogaki.gifu.jp +sakahogi.gifu.jp +seki.gifu.jp +sekigahara.gifu.jp +shirakawa.gifu.jp +tajimi.gifu.jp +takayama.gifu.jp +tarui.gifu.jp +toki.gifu.jp +tomika.gifu.jp +wanouchi.gifu.jp +yamagata.gifu.jp +yaotsu.gifu.jp +yoro.gifu.jp +annaka.gunma.jp +chiyoda.gunma.jp +fujioka.gunma.jp +higashiagatsuma.gunma.jp +isesaki.gunma.jp +itakura.gunma.jp +kanna.gunma.jp +kanra.gunma.jp +katashina.gunma.jp +kawaba.gunma.jp +kiryu.gunma.jp +kusatsu.gunma.jp +maebashi.gunma.jp +meiwa.gunma.jp +midori.gunma.jp +minakami.gunma.jp +naganohara.gunma.jp +nakanojo.gunma.jp +nanmoku.gunma.jp +numata.gunma.jp +oizumi.gunma.jp +ora.gunma.jp +ota.gunma.jp +shibukawa.gunma.jp +shimonita.gunma.jp +shinto.gunma.jp +showa.gunma.jp +takasaki.gunma.jp +takayama.gunma.jp +tamamura.gunma.jp +tatebayashi.gunma.jp +tomioka.gunma.jp +tsukiyono.gunma.jp +tsumagoi.gunma.jp +ueno.gunma.jp +yoshioka.gunma.jp +asaminami.hiroshima.jp +daiwa.hiroshima.jp +etajima.hiroshima.jp +fuchu.hiroshima.jp +fukuyama.hiroshima.jp +hatsukaichi.hiroshima.jp +higashihiroshima.hiroshima.jp +hongo.hiroshima.jp +jinsekikogen.hiroshima.jp +kaita.hiroshima.jp +kui.hiroshima.jp +kumano.hiroshima.jp +kure.hiroshima.jp +mihara.hiroshima.jp +miyoshi.hiroshima.jp +naka.hiroshima.jp +onomichi.hiroshima.jp +osakikamijima.hiroshima.jp +otake.hiroshima.jp +saka.hiroshima.jp +sera.hiroshima.jp +seranishi.hiroshima.jp +shinichi.hiroshima.jp +shobara.hiroshima.jp +takehara.hiroshima.jp +abashiri.hokkaido.jp +abira.hokkaido.jp +aibetsu.hokkaido.jp +akabira.hokkaido.jp +akkeshi.hokkaido.jp +asahikawa.hokkaido.jp +ashibetsu.hokkaido.jp +ashoro.hokkaido.jp +assabu.hokkaido.jp +atsuma.hokkaido.jp +bibai.hokkaido.jp +biei.hokkaido.jp +bifuka.hokkaido.jp +bihoro.hokkaido.jp +biratori.hokkaido.jp +chippubetsu.hokkaido.jp +chitose.hokkaido.jp +date.hokkaido.jp +ebetsu.hokkaido.jp +embetsu.hokkaido.jp +eniwa.hokkaido.jp +erimo.hokkaido.jp +esan.hokkaido.jp +esashi.hokkaido.jp +fukagawa.hokkaido.jp +fukushima.hokkaido.jp +furano.hokkaido.jp +furubira.hokkaido.jp +haboro.hokkaido.jp +hakodate.hokkaido.jp +hamatonbetsu.hokkaido.jp +hidaka.hokkaido.jp +higashikagura.hokkaido.jp +higashikawa.hokkaido.jp +hiroo.hokkaido.jp +hokuryu.hokkaido.jp +hokuto.hokkaido.jp +honbetsu.hokkaido.jp +horokanai.hokkaido.jp +horonobe.hokkaido.jp +ikeda.hokkaido.jp +imakane.hokkaido.jp +ishikari.hokkaido.jp +iwamizawa.hokkaido.jp +iwanai.hokkaido.jp +kamifurano.hokkaido.jp +kamikawa.hokkaido.jp +kamishihoro.hokkaido.jp +kamisunagawa.hokkaido.jp +kamoenai.hokkaido.jp +kayabe.hokkaido.jp +kembuchi.hokkaido.jp +kikonai.hokkaido.jp +kimobetsu.hokkaido.jp +kitahiroshima.hokkaido.jp +kitami.hokkaido.jp +kiyosato.hokkaido.jp +koshimizu.hokkaido.jp +kunneppu.hokkaido.jp +kuriyama.hokkaido.jp +kuromatsunai.hokkaido.jp +kushiro.hokkaido.jp +kutchan.hokkaido.jp +kyowa.hokkaido.jp +mashike.hokkaido.jp +matsumae.hokkaido.jp +mikasa.hokkaido.jp +minamifurano.hokkaido.jp +mombetsu.hokkaido.jp +moseushi.hokkaido.jp +mukawa.hokkaido.jp +muroran.hokkaido.jp +naie.hokkaido.jp +nakagawa.hokkaido.jp +nakasatsunai.hokkaido.jp +nakatombetsu.hokkaido.jp +nanae.hokkaido.jp +nanporo.hokkaido.jp +nayoro.hokkaido.jp +nemuro.hokkaido.jp +niikappu.hokkaido.jp +niki.hokkaido.jp +nishiokoppe.hokkaido.jp +noboribetsu.hokkaido.jp +numata.hokkaido.jp +obihiro.hokkaido.jp +obira.hokkaido.jp +oketo.hokkaido.jp +okoppe.hokkaido.jp +otaru.hokkaido.jp +otobe.hokkaido.jp +otofuke.hokkaido.jp +otoineppu.hokkaido.jp +oumu.hokkaido.jp +ozora.hokkaido.jp +pippu.hokkaido.jp +rankoshi.hokkaido.jp +rebun.hokkaido.jp +rikubetsu.hokkaido.jp +rishiri.hokkaido.jp +rishirifuji.hokkaido.jp +saroma.hokkaido.jp +sarufutsu.hokkaido.jp +shakotan.hokkaido.jp +shari.hokkaido.jp +shibecha.hokkaido.jp +shibetsu.hokkaido.jp +shikabe.hokkaido.jp +shikaoi.hokkaido.jp +shimamaki.hokkaido.jp +shimizu.hokkaido.jp +shimokawa.hokkaido.jp +shinshinotsu.hokkaido.jp +shintoku.hokkaido.jp +shiranuka.hokkaido.jp +shiraoi.hokkaido.jp +shiriuchi.hokkaido.jp +sobetsu.hokkaido.jp +sunagawa.hokkaido.jp +taiki.hokkaido.jp +takasu.hokkaido.jp +takikawa.hokkaido.jp +takinoue.hokkaido.jp +teshikaga.hokkaido.jp +tobetsu.hokkaido.jp +tohma.hokkaido.jp +tomakomai.hokkaido.jp +tomari.hokkaido.jp +toya.hokkaido.jp +toyako.hokkaido.jp +toyotomi.hokkaido.jp +toyoura.hokkaido.jp +tsubetsu.hokkaido.jp +tsukigata.hokkaido.jp +urakawa.hokkaido.jp +urausu.hokkaido.jp +uryu.hokkaido.jp +utashinai.hokkaido.jp +wakkanai.hokkaido.jp +wassamu.hokkaido.jp +yakumo.hokkaido.jp +yoichi.hokkaido.jp +aioi.hyogo.jp +akashi.hyogo.jp +ako.hyogo.jp +amagasaki.hyogo.jp +aogaki.hyogo.jp +asago.hyogo.jp +ashiya.hyogo.jp +awaji.hyogo.jp +fukusaki.hyogo.jp +goshiki.hyogo.jp +harima.hyogo.jp +himeji.hyogo.jp +ichikawa.hyogo.jp +inagawa.hyogo.jp +itami.hyogo.jp +kakogawa.hyogo.jp +kamigori.hyogo.jp +kamikawa.hyogo.jp +kasai.hyogo.jp +kasuga.hyogo.jp +kawanishi.hyogo.jp +miki.hyogo.jp +minamiawaji.hyogo.jp +nishinomiya.hyogo.jp +nishiwaki.hyogo.jp +ono.hyogo.jp +sanda.hyogo.jp +sannan.hyogo.jp +sasayama.hyogo.jp +sayo.hyogo.jp +shingu.hyogo.jp +shinonsen.hyogo.jp +shiso.hyogo.jp +sumoto.hyogo.jp +taishi.hyogo.jp +taka.hyogo.jp +takarazuka.hyogo.jp +takasago.hyogo.jp +takino.hyogo.jp +tamba.hyogo.jp +tatsuno.hyogo.jp +toyooka.hyogo.jp +yabu.hyogo.jp +yashiro.hyogo.jp +yoka.hyogo.jp +yokawa.hyogo.jp +ami.ibaraki.jp +asahi.ibaraki.jp +bando.ibaraki.jp +chikusei.ibaraki.jp +daigo.ibaraki.jp +fujishiro.ibaraki.jp +hitachi.ibaraki.jp +hitachinaka.ibaraki.jp +hitachiomiya.ibaraki.jp +hitachiota.ibaraki.jp +ibaraki.ibaraki.jp +ina.ibaraki.jp +inashiki.ibaraki.jp +itako.ibaraki.jp +iwama.ibaraki.jp +joso.ibaraki.jp +kamisu.ibaraki.jp +kasama.ibaraki.jp +kashima.ibaraki.jp +kasumigaura.ibaraki.jp +koga.ibaraki.jp +miho.ibaraki.jp +mito.ibaraki.jp +moriya.ibaraki.jp +naka.ibaraki.jp +namegata.ibaraki.jp +oarai.ibaraki.jp +ogawa.ibaraki.jp +omitama.ibaraki.jp +ryugasaki.ibaraki.jp +sakai.ibaraki.jp +sakuragawa.ibaraki.jp +shimodate.ibaraki.jp +shimotsuma.ibaraki.jp +shirosato.ibaraki.jp +sowa.ibaraki.jp +suifu.ibaraki.jp +takahagi.ibaraki.jp +tamatsukuri.ibaraki.jp +tokai.ibaraki.jp +tomobe.ibaraki.jp +tone.ibaraki.jp +toride.ibaraki.jp +tsuchiura.ibaraki.jp +tsukuba.ibaraki.jp +uchihara.ibaraki.jp +ushiku.ibaraki.jp +yachiyo.ibaraki.jp +yamagata.ibaraki.jp +yawara.ibaraki.jp +yuki.ibaraki.jp +anamizu.ishikawa.jp +hakui.ishikawa.jp +hakusan.ishikawa.jp +kaga.ishikawa.jp +kahoku.ishikawa.jp +kanazawa.ishikawa.jp +kawakita.ishikawa.jp +komatsu.ishikawa.jp +nakanoto.ishikawa.jp +nanao.ishikawa.jp +nomi.ishikawa.jp +nonoichi.ishikawa.jp +noto.ishikawa.jp +shika.ishikawa.jp +suzu.ishikawa.jp +tsubata.ishikawa.jp +tsurugi.ishikawa.jp +uchinada.ishikawa.jp +wajima.ishikawa.jp +fudai.iwate.jp +fujisawa.iwate.jp +hanamaki.iwate.jp +hiraizumi.iwate.jp +hirono.iwate.jp +ichinohe.iwate.jp +ichinoseki.iwate.jp +iwaizumi.iwate.jp +iwate.iwate.jp +joboji.iwate.jp +kamaishi.iwate.jp +kanegasaki.iwate.jp +karumai.iwate.jp +kawai.iwate.jp +kitakami.iwate.jp +kuji.iwate.jp +kunohe.iwate.jp +kuzumaki.iwate.jp +miyako.iwate.jp +mizusawa.iwate.jp +morioka.iwate.jp +ninohe.iwate.jp +noda.iwate.jp +ofunato.iwate.jp +oshu.iwate.jp +otsuchi.iwate.jp +rikuzentakata.iwate.jp +shiwa.iwate.jp +shizukuishi.iwate.jp +sumita.iwate.jp +takizawa.iwate.jp +tanohata.iwate.jp +tono.iwate.jp +yahaba.iwate.jp +yamada.iwate.jp +ayagawa.kagawa.jp +higashikagawa.kagawa.jp +kanonji.kagawa.jp +kotohira.kagawa.jp +manno.kagawa.jp +marugame.kagawa.jp +mitoyo.kagawa.jp +naoshima.kagawa.jp +sanuki.kagawa.jp +tadotsu.kagawa.jp +takamatsu.kagawa.jp +tonosho.kagawa.jp +uchinomi.kagawa.jp +utazu.kagawa.jp +zentsuji.kagawa.jp +akune.kagoshima.jp +amami.kagoshima.jp +hioki.kagoshima.jp +isa.kagoshima.jp +isen.kagoshima.jp +izumi.kagoshima.jp +kagoshima.kagoshima.jp +kanoya.kagoshima.jp +kawanabe.kagoshima.jp +kinko.kagoshima.jp +kouyama.kagoshima.jp +makurazaki.kagoshima.jp +matsumoto.kagoshima.jp +minamitane.kagoshima.jp +nakatane.kagoshima.jp +nishinoomote.kagoshima.jp +satsumasendai.kagoshima.jp +soo.kagoshima.jp +tarumizu.kagoshima.jp +yusui.kagoshima.jp +aikawa.kanagawa.jp +atsugi.kanagawa.jp +ayase.kanagawa.jp +chigasaki.kanagawa.jp +ebina.kanagawa.jp +fujisawa.kanagawa.jp +hadano.kanagawa.jp +hakone.kanagawa.jp +hiratsuka.kanagawa.jp +isehara.kanagawa.jp +kaisei.kanagawa.jp +kamakura.kanagawa.jp +kiyokawa.kanagawa.jp +matsuda.kanagawa.jp +minamiashigara.kanagawa.jp +miura.kanagawa.jp +nakai.kanagawa.jp +ninomiya.kanagawa.jp +odawara.kanagawa.jp +oi.kanagawa.jp +oiso.kanagawa.jp +sagamihara.kanagawa.jp +samukawa.kanagawa.jp +tsukui.kanagawa.jp +yamakita.kanagawa.jp +yamato.kanagawa.jp +yokosuka.kanagawa.jp +yugawara.kanagawa.jp +zama.kanagawa.jp +zushi.kanagawa.jp +aki.kochi.jp +geisei.kochi.jp +hidaka.kochi.jp +higashitsuno.kochi.jp +ino.kochi.jp +kagami.kochi.jp +kami.kochi.jp +kitagawa.kochi.jp +kochi.kochi.jp +mihara.kochi.jp +motoyama.kochi.jp +muroto.kochi.jp +nahari.kochi.jp +nakamura.kochi.jp +nankoku.kochi.jp +nishitosa.kochi.jp +niyodogawa.kochi.jp +ochi.kochi.jp +okawa.kochi.jp +otoyo.kochi.jp +otsuki.kochi.jp +sakawa.kochi.jp +sukumo.kochi.jp +susaki.kochi.jp +tosa.kochi.jp +tosashimizu.kochi.jp +toyo.kochi.jp +tsuno.kochi.jp +umaji.kochi.jp +yasuda.kochi.jp +yusuhara.kochi.jp +amakusa.kumamoto.jp +arao.kumamoto.jp +aso.kumamoto.jp +choyo.kumamoto.jp +gyokuto.kumamoto.jp +hitoyoshi.kumamoto.jp +kamiamakusa.kumamoto.jp +kashima.kumamoto.jp +kikuchi.kumamoto.jp +kosa.kumamoto.jp +kumamoto.kumamoto.jp +mashiki.kumamoto.jp +mifune.kumamoto.jp +minamata.kumamoto.jp +minamioguni.kumamoto.jp +nagasu.kumamoto.jp +nishihara.kumamoto.jp +oguni.kumamoto.jp +ozu.kumamoto.jp +sumoto.kumamoto.jp +takamori.kumamoto.jp +uki.kumamoto.jp +uto.kumamoto.jp +yamaga.kumamoto.jp +yamato.kumamoto.jp +yatsushiro.kumamoto.jp +ayabe.kyoto.jp +fukuchiyama.kyoto.jp +higashiyama.kyoto.jp +ide.kyoto.jp +ine.kyoto.jp +joyo.kyoto.jp +kameoka.kyoto.jp +kamo.kyoto.jp +kita.kyoto.jp +kizu.kyoto.jp +kumiyama.kyoto.jp +kyotamba.kyoto.jp +kyotanabe.kyoto.jp +kyotango.kyoto.jp +maizuru.kyoto.jp +minami.kyoto.jp +minamiyamashiro.kyoto.jp +miyazu.kyoto.jp +muko.kyoto.jp +nagaokakyo.kyoto.jp +nakagyo.kyoto.jp +nantan.kyoto.jp +oyamazaki.kyoto.jp +sakyo.kyoto.jp +seika.kyoto.jp +tanabe.kyoto.jp +uji.kyoto.jp +ujitawara.kyoto.jp +wazuka.kyoto.jp +yamashina.kyoto.jp +yawata.kyoto.jp +asahi.mie.jp +inabe.mie.jp +ise.mie.jp +kameyama.mie.jp +kawagoe.mie.jp +kiho.mie.jp +kisosaki.mie.jp +kiwa.mie.jp +komono.mie.jp +kumano.mie.jp +kuwana.mie.jp +matsusaka.mie.jp +meiwa.mie.jp +mihama.mie.jp +minamiise.mie.jp +misugi.mie.jp +miyama.mie.jp +nabari.mie.jp +shima.mie.jp +suzuka.mie.jp +tado.mie.jp +taiki.mie.jp +taki.mie.jp +tamaki.mie.jp +toba.mie.jp +tsu.mie.jp +udono.mie.jp +ureshino.mie.jp +watarai.mie.jp +yokkaichi.mie.jp +furukawa.miyagi.jp +higashimatsushima.miyagi.jp +ishinomaki.miyagi.jp +iwanuma.miyagi.jp +kakuda.miyagi.jp +kami.miyagi.jp +kawasaki.miyagi.jp +kesennuma.miyagi.jp +marumori.miyagi.jp +matsushima.miyagi.jp +minamisanriku.miyagi.jp +misato.miyagi.jp +murata.miyagi.jp +natori.miyagi.jp +ogawara.miyagi.jp +ohira.miyagi.jp +onagawa.miyagi.jp +osaki.miyagi.jp +rifu.miyagi.jp +semine.miyagi.jp +shibata.miyagi.jp +shichikashuku.miyagi.jp +shikama.miyagi.jp +shiogama.miyagi.jp +shiroishi.miyagi.jp +tagajo.miyagi.jp +taiwa.miyagi.jp +tome.miyagi.jp +tomiya.miyagi.jp +wakuya.miyagi.jp +watari.miyagi.jp +yamamoto.miyagi.jp +zao.miyagi.jp +aya.miyazaki.jp +ebino.miyazaki.jp +gokase.miyazaki.jp +hyuga.miyazaki.jp +kadogawa.miyazaki.jp +kawaminami.miyazaki.jp +kijo.miyazaki.jp +kitagawa.miyazaki.jp +kitakata.miyazaki.jp +kitaura.miyazaki.jp +kobayashi.miyazaki.jp +kunitomi.miyazaki.jp +kushima.miyazaki.jp +mimata.miyazaki.jp +miyakonojo.miyazaki.jp +miyazaki.miyazaki.jp +morotsuka.miyazaki.jp +nichinan.miyazaki.jp +nishimera.miyazaki.jp +nobeoka.miyazaki.jp +saito.miyazaki.jp +shiiba.miyazaki.jp +shintomi.miyazaki.jp +takaharu.miyazaki.jp +takanabe.miyazaki.jp +takazaki.miyazaki.jp +tsuno.miyazaki.jp +achi.nagano.jp +agematsu.nagano.jp +anan.nagano.jp +aoki.nagano.jp +asahi.nagano.jp +azumino.nagano.jp +chikuhoku.nagano.jp +chikuma.nagano.jp +chino.nagano.jp +fujimi.nagano.jp +hakuba.nagano.jp +hara.nagano.jp +hiraya.nagano.jp +iida.nagano.jp +iijima.nagano.jp +iiyama.nagano.jp +iizuna.nagano.jp +ikeda.nagano.jp +ikusaka.nagano.jp +ina.nagano.jp +karuizawa.nagano.jp +kawakami.nagano.jp +kiso.nagano.jp +kisofukushima.nagano.jp +kitaaiki.nagano.jp +komagane.nagano.jp +komoro.nagano.jp +matsukawa.nagano.jp +matsumoto.nagano.jp +miasa.nagano.jp +minamiaiki.nagano.jp +minamimaki.nagano.jp +minamiminowa.nagano.jp +minowa.nagano.jp +miyada.nagano.jp +miyota.nagano.jp +mochizuki.nagano.jp +nagano.nagano.jp +nagawa.nagano.jp +nagiso.nagano.jp +nakagawa.nagano.jp +nakano.nagano.jp +nozawaonsen.nagano.jp +obuse.nagano.jp +ogawa.nagano.jp +okaya.nagano.jp +omachi.nagano.jp +omi.nagano.jp +ookuwa.nagano.jp +ooshika.nagano.jp +otaki.nagano.jp +otari.nagano.jp +sakae.nagano.jp +sakaki.nagano.jp +saku.nagano.jp +sakuho.nagano.jp +shimosuwa.nagano.jp +shinanomachi.nagano.jp +shiojiri.nagano.jp +suwa.nagano.jp +suzaka.nagano.jp +takagi.nagano.jp +takamori.nagano.jp +takayama.nagano.jp +tateshina.nagano.jp +tatsuno.nagano.jp +togakushi.nagano.jp +togura.nagano.jp +tomi.nagano.jp +ueda.nagano.jp +wada.nagano.jp +yamagata.nagano.jp +yamanouchi.nagano.jp +yasaka.nagano.jp +yasuoka.nagano.jp +chijiwa.nagasaki.jp +futsu.nagasaki.jp +goto.nagasaki.jp +hasami.nagasaki.jp +hirado.nagasaki.jp +iki.nagasaki.jp +isahaya.nagasaki.jp +kawatana.nagasaki.jp +kuchinotsu.nagasaki.jp +matsuura.nagasaki.jp +nagasaki.nagasaki.jp +obama.nagasaki.jp +omura.nagasaki.jp +oseto.nagasaki.jp +saikai.nagasaki.jp +sasebo.nagasaki.jp +seihi.nagasaki.jp +shimabara.nagasaki.jp +shinkamigoto.nagasaki.jp +togitsu.nagasaki.jp +tsushima.nagasaki.jp +unzen.nagasaki.jp +ando.nara.jp +gose.nara.jp +heguri.nara.jp +higashiyoshino.nara.jp +ikaruga.nara.jp +ikoma.nara.jp +kamikitayama.nara.jp +kanmaki.nara.jp +kashiba.nara.jp +kashihara.nara.jp +katsuragi.nara.jp +kawai.nara.jp +kawakami.nara.jp +kawanishi.nara.jp +koryo.nara.jp +kurotaki.nara.jp +mitsue.nara.jp +miyake.nara.jp +nara.nara.jp +nosegawa.nara.jp +oji.nara.jp +ouda.nara.jp +oyodo.nara.jp +sakurai.nara.jp +sango.nara.jp +shimoichi.nara.jp +shimokitayama.nara.jp +shinjo.nara.jp +soni.nara.jp +takatori.nara.jp +tawaramoto.nara.jp +tenkawa.nara.jp +tenri.nara.jp +uda.nara.jp +yamatokoriyama.nara.jp +yamatotakada.nara.jp +yamazoe.nara.jp +yoshino.nara.jp +aga.niigata.jp +agano.niigata.jp +gosen.niigata.jp +itoigawa.niigata.jp +izumozaki.niigata.jp +joetsu.niigata.jp +kamo.niigata.jp +kariwa.niigata.jp +kashiwazaki.niigata.jp +minamiuonuma.niigata.jp +mitsuke.niigata.jp +muika.niigata.jp +murakami.niigata.jp +myoko.niigata.jp +nagaoka.niigata.jp +niigata.niigata.jp +ojiya.niigata.jp +omi.niigata.jp +sado.niigata.jp +sanjo.niigata.jp +seiro.niigata.jp +seirou.niigata.jp +sekikawa.niigata.jp +shibata.niigata.jp +tagami.niigata.jp +tainai.niigata.jp +tochio.niigata.jp +tokamachi.niigata.jp +tsubame.niigata.jp +tsunan.niigata.jp +uonuma.niigata.jp +yahiko.niigata.jp +yoita.niigata.jp +yuzawa.niigata.jp +beppu.oita.jp +bungoono.oita.jp +bungotakada.oita.jp +hasama.oita.jp +hiji.oita.jp +himeshima.oita.jp +hita.oita.jp +kamitsue.oita.jp +kokonoe.oita.jp +kuju.oita.jp +kunisaki.oita.jp +kusu.oita.jp +oita.oita.jp +saiki.oita.jp +taketa.oita.jp +tsukumi.oita.jp +usa.oita.jp +usuki.oita.jp +yufu.oita.jp +akaiwa.okayama.jp +asakuchi.okayama.jp +bizen.okayama.jp +hayashima.okayama.jp +ibara.okayama.jp +kagamino.okayama.jp +kasaoka.okayama.jp +kibichuo.okayama.jp +kumenan.okayama.jp +kurashiki.okayama.jp +maniwa.okayama.jp +misaki.okayama.jp +nagi.okayama.jp +niimi.okayama.jp +nishiawakura.okayama.jp +okayama.okayama.jp +satosho.okayama.jp +setouchi.okayama.jp +shinjo.okayama.jp +shoo.okayama.jp +soja.okayama.jp +takahashi.okayama.jp +tamano.okayama.jp +tsuyama.okayama.jp +wake.okayama.jp +yakage.okayama.jp +aguni.okinawa.jp +ginowan.okinawa.jp +ginoza.okinawa.jp +gushikami.okinawa.jp +haebaru.okinawa.jp +higashi.okinawa.jp +hirara.okinawa.jp +iheya.okinawa.jp +ishigaki.okinawa.jp +ishikawa.okinawa.jp +itoman.okinawa.jp +izena.okinawa.jp +kadena.okinawa.jp +kin.okinawa.jp +kitadaito.okinawa.jp +kitanakagusuku.okinawa.jp +kumejima.okinawa.jp +kunigami.okinawa.jp +minamidaito.okinawa.jp +motobu.okinawa.jp +nago.okinawa.jp +naha.okinawa.jp +nakagusuku.okinawa.jp +nakijin.okinawa.jp +nanjo.okinawa.jp +nishihara.okinawa.jp +ogimi.okinawa.jp +okinawa.okinawa.jp +onna.okinawa.jp +shimoji.okinawa.jp +taketomi.okinawa.jp +tarama.okinawa.jp +tokashiki.okinawa.jp +tomigusuku.okinawa.jp +tonaki.okinawa.jp +urasoe.okinawa.jp +uruma.okinawa.jp +yaese.okinawa.jp +yomitan.okinawa.jp +yonabaru.okinawa.jp +yonaguni.okinawa.jp +zamami.okinawa.jp +abeno.osaka.jp +chihayaakasaka.osaka.jp +chuo.osaka.jp +daito.osaka.jp +fujiidera.osaka.jp +habikino.osaka.jp +hannan.osaka.jp +higashiosaka.osaka.jp +higashisumiyoshi.osaka.jp +higashiyodogawa.osaka.jp +hirakata.osaka.jp +ibaraki.osaka.jp +ikeda.osaka.jp +izumi.osaka.jp +izumiotsu.osaka.jp +izumisano.osaka.jp +kadoma.osaka.jp +kaizuka.osaka.jp +kanan.osaka.jp +kashiwara.osaka.jp +katano.osaka.jp +kawachinagano.osaka.jp +kishiwada.osaka.jp +kita.osaka.jp +kumatori.osaka.jp +matsubara.osaka.jp +minato.osaka.jp +minoh.osaka.jp +misaki.osaka.jp +moriguchi.osaka.jp +neyagawa.osaka.jp +nishi.osaka.jp +nose.osaka.jp +osakasayama.osaka.jp +sakai.osaka.jp +sayama.osaka.jp +sennan.osaka.jp +settsu.osaka.jp +shijonawate.osaka.jp +shimamoto.osaka.jp +suita.osaka.jp +tadaoka.osaka.jp +taishi.osaka.jp +tajiri.osaka.jp +takaishi.osaka.jp +takatsuki.osaka.jp +tondabayashi.osaka.jp +toyonaka.osaka.jp +toyono.osaka.jp +yao.osaka.jp +ariake.saga.jp +arita.saga.jp +fukudomi.saga.jp +genkai.saga.jp +hamatama.saga.jp +hizen.saga.jp +imari.saga.jp +kamimine.saga.jp +kanzaki.saga.jp +karatsu.saga.jp +kashima.saga.jp +kitagata.saga.jp +kitahata.saga.jp +kiyama.saga.jp +kouhoku.saga.jp +kyuragi.saga.jp +nishiarita.saga.jp +ogi.saga.jp +omachi.saga.jp +ouchi.saga.jp +saga.saga.jp +shiroishi.saga.jp +taku.saga.jp +tara.saga.jp +tosu.saga.jp +yoshinogari.saga.jp +arakawa.saitama.jp +asaka.saitama.jp +chichibu.saitama.jp +fujimi.saitama.jp +fujimino.saitama.jp +fukaya.saitama.jp +hanno.saitama.jp +hanyu.saitama.jp +hasuda.saitama.jp +hatogaya.saitama.jp +hatoyama.saitama.jp +hidaka.saitama.jp +higashichichibu.saitama.jp +higashimatsuyama.saitama.jp +honjo.saitama.jp +ina.saitama.jp +iruma.saitama.jp +iwatsuki.saitama.jp +kamiizumi.saitama.jp +kamikawa.saitama.jp +kamisato.saitama.jp +kasukabe.saitama.jp +kawagoe.saitama.jp +kawaguchi.saitama.jp +kawajima.saitama.jp +kazo.saitama.jp +kitamoto.saitama.jp +koshigaya.saitama.jp +kounosu.saitama.jp +kuki.saitama.jp +kumagaya.saitama.jp +matsubushi.saitama.jp +minano.saitama.jp +misato.saitama.jp +miyashiro.saitama.jp +miyoshi.saitama.jp +moroyama.saitama.jp +nagatoro.saitama.jp +namegawa.saitama.jp +niiza.saitama.jp +ogano.saitama.jp +ogawa.saitama.jp +ogose.saitama.jp +okegawa.saitama.jp +omiya.saitama.jp +otaki.saitama.jp +ranzan.saitama.jp +ryokami.saitama.jp +saitama.saitama.jp +sakado.saitama.jp +satte.saitama.jp +sayama.saitama.jp +shiki.saitama.jp +shiraoka.saitama.jp +soka.saitama.jp +sugito.saitama.jp +toda.saitama.jp +tokigawa.saitama.jp +tokorozawa.saitama.jp +tsurugashima.saitama.jp +urawa.saitama.jp +warabi.saitama.jp +yashio.saitama.jp +yokoze.saitama.jp +yono.saitama.jp +yorii.saitama.jp +yoshida.saitama.jp +yoshikawa.saitama.jp +yoshimi.saitama.jp +aisho.shiga.jp +gamo.shiga.jp +higashiomi.shiga.jp +hikone.shiga.jp +koka.shiga.jp +konan.shiga.jp +kosei.shiga.jp +koto.shiga.jp +kusatsu.shiga.jp +maibara.shiga.jp +moriyama.shiga.jp +nagahama.shiga.jp +nishiazai.shiga.jp +notogawa.shiga.jp +omihachiman.shiga.jp +otsu.shiga.jp +ritto.shiga.jp +ryuoh.shiga.jp +takashima.shiga.jp +takatsuki.shiga.jp +torahime.shiga.jp +toyosato.shiga.jp +yasu.shiga.jp +akagi.shimane.jp +ama.shimane.jp +gotsu.shimane.jp +hamada.shimane.jp +higashiizumo.shimane.jp +hikawa.shimane.jp +hikimi.shimane.jp +izumo.shimane.jp +kakinoki.shimane.jp +masuda.shimane.jp +matsue.shimane.jp +misato.shimane.jp +nishinoshima.shimane.jp +ohda.shimane.jp +okinoshima.shimane.jp +okuizumo.shimane.jp +shimane.shimane.jp +tamayu.shimane.jp +tsuwano.shimane.jp +unnan.shimane.jp +yakumo.shimane.jp +yasugi.shimane.jp +yatsuka.shimane.jp +arai.shizuoka.jp +atami.shizuoka.jp +fuji.shizuoka.jp +fujieda.shizuoka.jp +fujikawa.shizuoka.jp +fujinomiya.shizuoka.jp +fukuroi.shizuoka.jp +gotemba.shizuoka.jp +haibara.shizuoka.jp +hamamatsu.shizuoka.jp +higashiizu.shizuoka.jp +ito.shizuoka.jp +iwata.shizuoka.jp +izu.shizuoka.jp +izunokuni.shizuoka.jp +kakegawa.shizuoka.jp +kannami.shizuoka.jp +kawanehon.shizuoka.jp +kawazu.shizuoka.jp +kikugawa.shizuoka.jp +kosai.shizuoka.jp +makinohara.shizuoka.jp +matsuzaki.shizuoka.jp +minamiizu.shizuoka.jp +mishima.shizuoka.jp +morimachi.shizuoka.jp +nishiizu.shizuoka.jp +numazu.shizuoka.jp +omaezaki.shizuoka.jp +shimada.shizuoka.jp +shimizu.shizuoka.jp +shimoda.shizuoka.jp +shizuoka.shizuoka.jp +susono.shizuoka.jp +yaizu.shizuoka.jp +yoshida.shizuoka.jp +ashikaga.tochigi.jp +bato.tochigi.jp +haga.tochigi.jp +ichikai.tochigi.jp +iwafune.tochigi.jp +kaminokawa.tochigi.jp +kanuma.tochigi.jp +karasuyama.tochigi.jp +kuroiso.tochigi.jp +mashiko.tochigi.jp +mibu.tochigi.jp +moka.tochigi.jp +motegi.tochigi.jp +nasu.tochigi.jp +nasushiobara.tochigi.jp +nikko.tochigi.jp +nishikata.tochigi.jp +nogi.tochigi.jp +ohira.tochigi.jp +ohtawara.tochigi.jp +oyama.tochigi.jp +sakura.tochigi.jp +sano.tochigi.jp +shimotsuke.tochigi.jp +shioya.tochigi.jp +takanezawa.tochigi.jp +tochigi.tochigi.jp +tsuga.tochigi.jp +ujiie.tochigi.jp +utsunomiya.tochigi.jp +yaita.tochigi.jp +aizumi.tokushima.jp +anan.tokushima.jp +ichiba.tokushima.jp +itano.tokushima.jp +kainan.tokushima.jp +komatsushima.tokushima.jp +matsushige.tokushima.jp +mima.tokushima.jp +minami.tokushima.jp +miyoshi.tokushima.jp +mugi.tokushima.jp +nakagawa.tokushima.jp +naruto.tokushima.jp +sanagochi.tokushima.jp +shishikui.tokushima.jp +tokushima.tokushima.jp +wajiki.tokushima.jp +adachi.tokyo.jp +akiruno.tokyo.jp +akishima.tokyo.jp +aogashima.tokyo.jp +arakawa.tokyo.jp +bunkyo.tokyo.jp +chiyoda.tokyo.jp +chofu.tokyo.jp +chuo.tokyo.jp +edogawa.tokyo.jp +fuchu.tokyo.jp +fussa.tokyo.jp +hachijo.tokyo.jp +hachioji.tokyo.jp +hamura.tokyo.jp +higashikurume.tokyo.jp +higashimurayama.tokyo.jp +higashiyamato.tokyo.jp +hino.tokyo.jp +hinode.tokyo.jp +hinohara.tokyo.jp +inagi.tokyo.jp +itabashi.tokyo.jp +katsushika.tokyo.jp +kita.tokyo.jp +kiyose.tokyo.jp +kodaira.tokyo.jp +koganei.tokyo.jp +kokubunji.tokyo.jp +komae.tokyo.jp +koto.tokyo.jp +kouzushima.tokyo.jp +kunitachi.tokyo.jp +machida.tokyo.jp +meguro.tokyo.jp +minato.tokyo.jp +mitaka.tokyo.jp +mizuho.tokyo.jp +musashimurayama.tokyo.jp +musashino.tokyo.jp +nakano.tokyo.jp +nerima.tokyo.jp +ogasawara.tokyo.jp +okutama.tokyo.jp +ome.tokyo.jp +oshima.tokyo.jp +ota.tokyo.jp +setagaya.tokyo.jp +shibuya.tokyo.jp +shinagawa.tokyo.jp +shinjuku.tokyo.jp +suginami.tokyo.jp +sumida.tokyo.jp +tachikawa.tokyo.jp +taito.tokyo.jp +tama.tokyo.jp +toshima.tokyo.jp +chizu.tottori.jp +hino.tottori.jp +kawahara.tottori.jp +koge.tottori.jp +kotoura.tottori.jp +misasa.tottori.jp +nanbu.tottori.jp +nichinan.tottori.jp +sakaiminato.tottori.jp +tottori.tottori.jp +wakasa.tottori.jp +yazu.tottori.jp +yonago.tottori.jp +asahi.toyama.jp +fuchu.toyama.jp +fukumitsu.toyama.jp +funahashi.toyama.jp +himi.toyama.jp +imizu.toyama.jp +inami.toyama.jp +johana.toyama.jp +kamiichi.toyama.jp +kurobe.toyama.jp +nakaniikawa.toyama.jp +namerikawa.toyama.jp +nanto.toyama.jp +nyuzen.toyama.jp +oyabe.toyama.jp +taira.toyama.jp +takaoka.toyama.jp +tateyama.toyama.jp +toga.toyama.jp +tonami.toyama.jp +toyama.toyama.jp +unazuki.toyama.jp +uozu.toyama.jp +yamada.toyama.jp +arida.wakayama.jp +aridagawa.wakayama.jp +gobo.wakayama.jp +hashimoto.wakayama.jp +hidaka.wakayama.jp +hirogawa.wakayama.jp +inami.wakayama.jp +iwade.wakayama.jp +kainan.wakayama.jp +kamitonda.wakayama.jp +katsuragi.wakayama.jp +kimino.wakayama.jp +kinokawa.wakayama.jp +kitayama.wakayama.jp +koya.wakayama.jp +koza.wakayama.jp +kozagawa.wakayama.jp +kudoyama.wakayama.jp +kushimoto.wakayama.jp +mihama.wakayama.jp +misato.wakayama.jp +nachikatsuura.wakayama.jp +shingu.wakayama.jp +shirahama.wakayama.jp +taiji.wakayama.jp +tanabe.wakayama.jp +wakayama.wakayama.jp +yuasa.wakayama.jp +yura.wakayama.jp +asahi.yamagata.jp +funagata.yamagata.jp +higashine.yamagata.jp +iide.yamagata.jp +kahoku.yamagata.jp +kaminoyama.yamagata.jp +kaneyama.yamagata.jp +kawanishi.yamagata.jp +mamurogawa.yamagata.jp +mikawa.yamagata.jp +murayama.yamagata.jp +nagai.yamagata.jp +nakayama.yamagata.jp +nanyo.yamagata.jp +nishikawa.yamagata.jp +obanazawa.yamagata.jp +oe.yamagata.jp +oguni.yamagata.jp +ohkura.yamagata.jp +oishida.yamagata.jp +sagae.yamagata.jp +sakata.yamagata.jp +sakegawa.yamagata.jp +shinjo.yamagata.jp +shirataka.yamagata.jp +shonai.yamagata.jp +takahata.yamagata.jp +tendo.yamagata.jp +tozawa.yamagata.jp +tsuruoka.yamagata.jp +yamagata.yamagata.jp +yamanobe.yamagata.jp +yonezawa.yamagata.jp +yuza.yamagata.jp +abu.yamaguchi.jp +hagi.yamaguchi.jp +hikari.yamaguchi.jp +hofu.yamaguchi.jp +iwakuni.yamaguchi.jp +kudamatsu.yamaguchi.jp +mitou.yamaguchi.jp +nagato.yamaguchi.jp +oshima.yamaguchi.jp +shimonoseki.yamaguchi.jp +shunan.yamaguchi.jp +tabuse.yamaguchi.jp +tokuyama.yamaguchi.jp +toyota.yamaguchi.jp +ube.yamaguchi.jp +yuu.yamaguchi.jp +chuo.yamanashi.jp +doshi.yamanashi.jp +fuefuki.yamanashi.jp +fujikawa.yamanashi.jp +fujikawaguchiko.yamanashi.jp +fujiyoshida.yamanashi.jp +hayakawa.yamanashi.jp +hokuto.yamanashi.jp +ichikawamisato.yamanashi.jp +kai.yamanashi.jp +kofu.yamanashi.jp +koshu.yamanashi.jp +kosuge.yamanashi.jp +minami-alps.yamanashi.jp +minobu.yamanashi.jp +nakamichi.yamanashi.jp +nanbu.yamanashi.jp +narusawa.yamanashi.jp +nirasaki.yamanashi.jp +nishikatsura.yamanashi.jp +oshino.yamanashi.jp +otsuki.yamanashi.jp +showa.yamanashi.jp +tabayama.yamanashi.jp +tsuru.yamanashi.jp +uenohara.yamanashi.jp +yamanakako.yamanashi.jp +yamanashi.yamanashi.jp + +// ke : http://www.kenic.or.ke/index.php?option=com_content&task=view&id=117&Itemid=145 +*.ke + +// kg : http://www.domain.kg/dmn_n.html +kg +org.kg +net.kg +com.kg +edu.kg +gov.kg +mil.kg + +// kh : http://www.mptc.gov.kh/dns_registration.htm +*.kh + +// ki : http://www.ki/dns/index.html +ki +edu.ki +biz.ki +net.ki +org.ki +gov.ki +info.ki +com.ki + +// km : http://en.wikipedia.org/wiki/.km +// http://www.domaine.km/documents/charte.doc +km +org.km +nom.km +gov.km +prd.km +tm.km +edu.km +mil.km +ass.km +com.km +// These are only mentioned as proposed suggestions at domaine.km, but +// http://en.wikipedia.org/wiki/.km says they're available for registration: +coop.km +asso.km +presse.km +medecin.km +notaires.km +pharmaciens.km +veterinaire.km +gouv.km + +// kn : http://en.wikipedia.org/wiki/.kn +// http://www.dot.kn/domainRules.html +kn +net.kn +org.kn +edu.kn +gov.kn + +// kp : http://www.kcce.kp/en_index.php +com.kp +edu.kp +gov.kp +org.kp +rep.kp +tra.kp + +// kr : http://en.wikipedia.org/wiki/.kr +// see also: http://domain.nida.or.kr/eng/registration.jsp +kr +ac.kr +co.kr +es.kr +go.kr +hs.kr +kg.kr +mil.kr +ms.kr +ne.kr +or.kr +pe.kr +re.kr +sc.kr +// kr geographical names +busan.kr +chungbuk.kr +chungnam.kr +daegu.kr +daejeon.kr +gangwon.kr +gwangju.kr +gyeongbuk.kr +gyeonggi.kr +gyeongnam.kr +incheon.kr +jeju.kr +jeonbuk.kr +jeonnam.kr +seoul.kr +ulsan.kr + +// kw : http://en.wikipedia.org/wiki/.kw +*.kw + +// ky : http://www.icta.ky/da_ky_reg_dom.php +// Confirmed by registry 2008-06-17 +ky +edu.ky +gov.ky +com.ky +org.ky +net.ky + +// kz : http://en.wikipedia.org/wiki/.kz +// see also: http://www.nic.kz/rules/index.jsp +kz +org.kz +edu.kz +net.kz +gov.kz +mil.kz +com.kz + +// la : http://en.wikipedia.org/wiki/.la +// Submitted by registry 2008-06-10 +la +int.la +net.la +info.la +edu.la +gov.la +per.la +com.la +org.la + +// lb : http://en.wikipedia.org/wiki/.lb +// Submitted by registry 2008-06-17 +com.lb +edu.lb +gov.lb +net.lb +org.lb + +// lc : http://en.wikipedia.org/wiki/.lc +// see also: http://www.nic.lc/rules.htm +lc +com.lc +net.lc +co.lc +org.lc +edu.lc +gov.lc + +// li : http://en.wikipedia.org/wiki/.li +li + +// lk : http://www.nic.lk/seclevpr.html +lk +gov.lk +sch.lk +net.lk +int.lk +com.lk +org.lk +edu.lk +ngo.lk +soc.lk +web.lk +ltd.lk +assn.lk +grp.lk +hotel.lk + +// lr : http://psg.com/dns/lr/lr.txt +// Submitted by registry 2008-06-17 +com.lr +edu.lr +gov.lr +org.lr +net.lr + +// ls : http://en.wikipedia.org/wiki/.ls +ls +co.ls +org.ls + +// lt : http://en.wikipedia.org/wiki/.lt +lt +// gov.lt : http://www.gov.lt/index_en.php +gov.lt + +// lu : http://www.dns.lu/en/ +lu + +// lv : http://www.nic.lv/DNS/En/generic.php +lv +com.lv +edu.lv +gov.lv +org.lv +mil.lv +id.lv +net.lv +asn.lv +conf.lv + +// ly : http://www.nic.ly/regulations.php +ly +com.ly +net.ly +gov.ly +plc.ly +edu.ly +sch.ly +med.ly +org.ly +id.ly + +// ma : http://en.wikipedia.org/wiki/.ma +// http://www.anrt.ma/fr/admin/download/upload/file_fr782.pdf +ma +co.ma +net.ma +gov.ma +org.ma +ac.ma +press.ma + +// mc : http://www.nic.mc/ +mc +tm.mc +asso.mc + +// md : http://en.wikipedia.org/wiki/.md +md + +// me : http://en.wikipedia.org/wiki/.me +me +co.me +net.me +org.me +edu.me +ac.me +gov.me +its.me +priv.me + +// mg : http://www.nic.mg/tarif.htm +mg +org.mg +nom.mg +gov.mg +prd.mg +tm.mg +edu.mg +mil.mg +com.mg + +// mh : http://en.wikipedia.org/wiki/.mh +mh + +// mil : http://en.wikipedia.org/wiki/.mil +mil + +// mk : http://en.wikipedia.org/wiki/.mk +// see also: http://dns.marnet.net.mk/postapka.php +mk +com.mk +org.mk +net.mk +edu.mk +gov.mk +inf.mk +name.mk + +// ml : http://www.gobin.info/domainname/ml-template.doc +// see also: http://en.wikipedia.org/wiki/.ml +ml +com.ml +edu.ml +gouv.ml +gov.ml +net.ml +org.ml +presse.ml + +// mm : http://en.wikipedia.org/wiki/.mm +*.mm + +// mn : http://en.wikipedia.org/wiki/.mn +mn +gov.mn +edu.mn +org.mn + +// mo : http://www.monic.net.mo/ +mo +com.mo +net.mo +org.mo +edu.mo +gov.mo + +// mobi : http://en.wikipedia.org/wiki/.mobi +mobi + +// mp : http://www.dot.mp/ +// Confirmed by registry 2008-06-17 +mp + +// mq : http://en.wikipedia.org/wiki/.mq +mq + +// mr : http://en.wikipedia.org/wiki/.mr +mr +gov.mr + +// ms : http://en.wikipedia.org/wiki/.ms +ms + +// mt : https://www.nic.org.mt/dotmt/ +*.mt + +// mu : http://en.wikipedia.org/wiki/.mu +mu +com.mu +net.mu +org.mu +gov.mu +ac.mu +co.mu +or.mu + +// museum : http://about.museum/naming/ +// http://index.museum/ +museum +academy.museum +agriculture.museum +air.museum +airguard.museum +alabama.museum +alaska.museum +amber.museum +ambulance.museum +american.museum +americana.museum +americanantiques.museum +americanart.museum +amsterdam.museum +and.museum +annefrank.museum +anthro.museum +anthropology.museum +antiques.museum +aquarium.museum +arboretum.museum +archaeological.museum +archaeology.museum +architecture.museum +art.museum +artanddesign.museum +artcenter.museum +artdeco.museum +arteducation.museum +artgallery.museum +arts.museum +artsandcrafts.museum +asmatart.museum +assassination.museum +assisi.museum +association.museum +astronomy.museum +atlanta.museum +austin.museum +australia.museum +automotive.museum +aviation.museum +axis.museum +badajoz.museum +baghdad.museum +bahn.museum +bale.museum +baltimore.museum +barcelona.museum +baseball.museum +basel.museum +baths.museum +bauern.museum +beauxarts.museum +beeldengeluid.museum +bellevue.museum +bergbau.museum +berkeley.museum +berlin.museum +bern.museum +bible.museum +bilbao.museum +bill.museum +birdart.museum +birthplace.museum +bonn.museum +boston.museum +botanical.museum +botanicalgarden.museum +botanicgarden.museum +botany.museum +brandywinevalley.museum +brasil.museum +bristol.museum +british.museum +britishcolumbia.museum +broadcast.museum +brunel.museum +brussel.museum +brussels.museum +bruxelles.museum +building.museum +burghof.museum +bus.museum +bushey.museum +cadaques.museum +california.museum +cambridge.museum +can.museum +canada.museum +capebreton.museum +carrier.museum +cartoonart.museum +casadelamoneda.museum +castle.museum +castres.museum +celtic.museum +center.museum +chattanooga.museum +cheltenham.museum +chesapeakebay.museum +chicago.museum +children.museum +childrens.museum +childrensgarden.museum +chiropractic.museum +chocolate.museum +christiansburg.museum +cincinnati.museum +cinema.museum +circus.museum +civilisation.museum +civilization.museum +civilwar.museum +clinton.museum +clock.museum +coal.museum +coastaldefence.museum +cody.museum +coldwar.museum +collection.museum +colonialwilliamsburg.museum +coloradoplateau.museum +columbia.museum +columbus.museum +communication.museum +communications.museum +community.museum +computer.museum +computerhistory.museum +comunicações.museum +contemporary.museum +contemporaryart.museum +convent.museum +copenhagen.museum +corporation.museum +correios-e-telecomunicações.museum +corvette.museum +costume.museum +countryestate.museum +county.museum +crafts.museum +cranbrook.museum +creation.museum +cultural.museum +culturalcenter.museum +culture.museum +cyber.museum +cymru.museum +dali.museum +dallas.museum +database.museum +ddr.museum +decorativearts.museum +delaware.museum +delmenhorst.museum +denmark.museum +depot.museum +design.museum +detroit.museum +dinosaur.museum +discovery.museum +dolls.museum +donostia.museum +durham.museum +eastafrica.museum +eastcoast.museum +education.museum +educational.museum +egyptian.museum +eisenbahn.museum +elburg.museum +elvendrell.museum +embroidery.museum +encyclopedic.museum +england.museum +entomology.museum +environment.museum +environmentalconservation.museum +epilepsy.museum +essex.museum +estate.museum +ethnology.museum +exeter.museum +exhibition.museum +family.museum +farm.museum +farmequipment.museum +farmers.museum +farmstead.museum +field.museum +figueres.museum +filatelia.museum +film.museum +fineart.museum +finearts.museum +finland.museum +flanders.museum +florida.museum +force.museum +fortmissoula.museum +fortworth.museum +foundation.museum +francaise.museum +frankfurt.museum +franziskaner.museum +freemasonry.museum +freiburg.museum +fribourg.museum +frog.museum +fundacio.museum +furniture.museum +gallery.museum +garden.museum +gateway.museum +geelvinck.museum +gemological.museum +geology.museum +georgia.museum +giessen.museum +glas.museum +glass.museum +gorge.museum +grandrapids.museum +graz.museum +guernsey.museum +halloffame.museum +hamburg.museum +handson.museum +harvestcelebration.museum +hawaii.museum +health.museum +heimatunduhren.museum +hellas.museum +helsinki.museum +hembygdsforbund.museum +heritage.museum +histoire.museum +historical.museum +historicalsociety.museum +historichouses.museum +historisch.museum +historisches.museum +history.museum +historyofscience.museum +horology.museum +house.museum +humanities.museum +illustration.museum +imageandsound.museum +indian.museum +indiana.museum +indianapolis.museum +indianmarket.museum +intelligence.museum +interactive.museum +iraq.museum +iron.museum +isleofman.museum +jamison.museum +jefferson.museum +jerusalem.museum +jewelry.museum +jewish.museum +jewishart.museum +jfk.museum +journalism.museum +judaica.museum +judygarland.museum +juedisches.museum +juif.museum +karate.museum +karikatur.museum +kids.museum +koebenhavn.museum +koeln.museum +kunst.museum +kunstsammlung.museum +kunstunddesign.museum +labor.museum +labour.museum +lajolla.museum +lancashire.museum +landes.museum +lans.museum +läns.museum +larsson.museum +lewismiller.museum +lincoln.museum +linz.museum +living.museum +livinghistory.museum +localhistory.museum +london.museum +losangeles.museum +louvre.museum +loyalist.museum +lucerne.museum +luxembourg.museum +luzern.museum +mad.museum +madrid.museum +mallorca.museum +manchester.museum +mansion.museum +mansions.museum +manx.museum +marburg.museum +maritime.museum +maritimo.museum +maryland.museum +marylhurst.museum +media.museum +medical.museum +medizinhistorisches.museum +meeres.museum +memorial.museum +mesaverde.museum +michigan.museum +midatlantic.museum +military.museum +mill.museum +miners.museum +mining.museum +minnesota.museum +missile.museum +missoula.museum +modern.museum +moma.museum +money.museum +monmouth.museum +monticello.museum +montreal.museum +moscow.museum +motorcycle.museum +muenchen.museum +muenster.museum +mulhouse.museum +muncie.museum +museet.museum +museumcenter.museum +museumvereniging.museum +music.museum +national.museum +nationalfirearms.museum +nationalheritage.museum +nativeamerican.museum +naturalhistory.museum +naturalhistorymuseum.museum +naturalsciences.museum +nature.museum +naturhistorisches.museum +natuurwetenschappen.museum +naumburg.museum +naval.museum +nebraska.museum +neues.museum +newhampshire.museum +newjersey.museum +newmexico.museum +newport.museum +newspaper.museum +newyork.museum +niepce.museum +norfolk.museum +north.museum +nrw.museum +nuernberg.museum +nuremberg.museum +nyc.museum +nyny.museum +oceanographic.museum +oceanographique.museum +omaha.museum +online.museum +ontario.museum +openair.museum +oregon.museum +oregontrail.museum +otago.museum +oxford.museum +pacific.museum +paderborn.museum +palace.museum +paleo.museum +palmsprings.museum +panama.museum +paris.museum +pasadena.museum +pharmacy.museum +philadelphia.museum +philadelphiaarea.museum +philately.museum +phoenix.museum +photography.museum +pilots.museum +pittsburgh.museum +planetarium.museum +plantation.museum +plants.museum +plaza.museum +portal.museum +portland.museum +portlligat.museum +posts-and-telecommunications.museum +preservation.museum +presidio.museum +press.museum +project.museum +public.museum +pubol.museum +quebec.museum +railroad.museum +railway.museum +research.museum +resistance.museum +riodejaneiro.museum +rochester.museum +rockart.museum +roma.museum +russia.museum +saintlouis.museum +salem.museum +salvadordali.museum +salzburg.museum +sandiego.museum +sanfrancisco.museum +santabarbara.museum +santacruz.museum +santafe.museum +saskatchewan.museum +satx.museum +savannahga.museum +schlesisches.museum +schoenbrunn.museum +schokoladen.museum +school.museum +schweiz.museum +science.museum +scienceandhistory.museum +scienceandindustry.museum +sciencecenter.museum +sciencecenters.museum +science-fiction.museum +sciencehistory.museum +sciences.museum +sciencesnaturelles.museum +scotland.museum +seaport.museum +settlement.museum +settlers.museum +shell.museum +sherbrooke.museum +sibenik.museum +silk.museum +ski.museum +skole.museum +society.museum +sologne.museum +soundandvision.museum +southcarolina.museum +southwest.museum +space.museum +spy.museum +square.museum +stadt.museum +stalbans.museum +starnberg.museum +state.museum +stateofdelaware.museum +station.museum +steam.museum +steiermark.museum +stjohn.museum +stockholm.museum +stpetersburg.museum +stuttgart.museum +suisse.museum +surgeonshall.museum +surrey.museum +svizzera.museum +sweden.museum +sydney.museum +tank.museum +tcm.museum +technology.museum +telekommunikation.museum +television.museum +texas.museum +textile.museum +theater.museum +time.museum +timekeeping.museum +topology.museum +torino.museum +touch.museum +town.museum +transport.museum +tree.museum +trolley.museum +trust.museum +trustee.museum +uhren.museum +ulm.museum +undersea.museum +university.museum +usa.museum +usantiques.museum +usarts.museum +uscountryestate.museum +usculture.museum +usdecorativearts.museum +usgarden.museum +ushistory.museum +ushuaia.museum +uslivinghistory.museum +utah.museum +uvic.museum +valley.museum +vantaa.museum +versailles.museum +viking.museum +village.museum +virginia.museum +virtual.museum +virtuel.museum +vlaanderen.museum +volkenkunde.museum +wales.museum +wallonie.museum +war.museum +washingtondc.museum +watchandclock.museum +watch-and-clock.museum +western.museum +westfalen.museum +whaling.museum +wildlife.museum +williamsburg.museum +windmill.museum +workshop.museum +york.museum +yorkshire.museum +yosemite.museum +youth.museum +zoological.museum +zoology.museum +ירושלים.museum +иком.museum + +// mv : http://en.wikipedia.org/wiki/.mv +// "mv" included because, contra Wikipedia, google.mv exists. +mv +aero.mv +biz.mv +com.mv +coop.mv +edu.mv +gov.mv +info.mv +int.mv +mil.mv +museum.mv +name.mv +net.mv +org.mv +pro.mv + +// mw : http://www.registrar.mw/ +mw +ac.mw +biz.mw +co.mw +com.mw +coop.mw +edu.mw +gov.mw +int.mw +museum.mw +net.mw +org.mw + +// mx : http://www.nic.mx/ +// Submitted by registry 2008-06-19 +mx +com.mx +org.mx +gob.mx +edu.mx +net.mx + +// my : http://www.mynic.net.my/ +my +com.my +net.my +org.my +gov.my +edu.my +mil.my +name.my + +// mz : http://www.gobin.info/domainname/mz-template.doc +*.mz +!teledata.mz + +// na : http://www.na-nic.com.na/ +// http://www.info.na/domain/ +na +info.na +pro.na +name.na +school.na +or.na +dr.na +us.na +mx.na +ca.na +in.na +cc.na +tv.na +ws.na +mobi.na +co.na +com.na +org.na + +// name : has 2nd-level tlds, but there's no list of them +name + +// nc : http://www.cctld.nc/ +nc +asso.nc + +// ne : http://en.wikipedia.org/wiki/.ne +ne + +// net : http://en.wikipedia.org/wiki/.net +net + +// nf : http://en.wikipedia.org/wiki/.nf +nf +com.nf +net.nf +per.nf +rec.nf +web.nf +arts.nf +firm.nf +info.nf +other.nf +store.nf + +// ng : http://psg.com/dns/ng/ +// Submitted by registry 2008-06-17 +ac.ng +com.ng +edu.ng +gov.ng +net.ng +org.ng + +// ni : http://www.nic.ni/dominios.htm +*.ni + +// nl : http://www.domain-registry.nl/ace.php/c,728,122,,,,Home.html +// Confirmed by registry (with technical +// reservations) 2008-06-08 +nl + +// BV.nl will be a registry for dutch BV's (besloten vennootschap) +bv.nl + +// no : http://www.norid.no/regelverk/index.en.html +// The Norwegian registry has declined to notify us of updates. The web pages +// referenced below are the official source of the data. There is also an +// announce mailing list: +// https://postlister.uninett.no/sympa/info/norid-diskusjon +no +// Norid generic domains : http://www.norid.no/regelverk/vedlegg-c.en.html +fhs.no +vgs.no +fylkesbibl.no +folkebibl.no +museum.no +idrett.no +priv.no +// Non-Norid generic domains : http://www.norid.no/regelverk/vedlegg-d.en.html +mil.no +stat.no +dep.no +kommune.no +herad.no +// no geographical names : http://www.norid.no/regelverk/vedlegg-b.en.html +// counties +aa.no +ah.no +bu.no +fm.no +hl.no +hm.no +jan-mayen.no +mr.no +nl.no +nt.no +of.no +ol.no +oslo.no +rl.no +sf.no +st.no +svalbard.no +tm.no +tr.no +va.no +vf.no +// primary and lower secondary schools per county +gs.aa.no +gs.ah.no +gs.bu.no +gs.fm.no +gs.hl.no +gs.hm.no +gs.jan-mayen.no +gs.mr.no +gs.nl.no +gs.nt.no +gs.of.no +gs.ol.no +gs.oslo.no +gs.rl.no +gs.sf.no +gs.st.no +gs.svalbard.no +gs.tm.no +gs.tr.no +gs.va.no +gs.vf.no +// cities +akrehamn.no +åkrehamn.no +algard.no +ålgård.no +arna.no +brumunddal.no +bryne.no +bronnoysund.no +brønnøysund.no +drobak.no +drøbak.no +egersund.no +fetsund.no +floro.no +florø.no +fredrikstad.no +hokksund.no +honefoss.no +hønefoss.no +jessheim.no +jorpeland.no +jørpeland.no +kirkenes.no +kopervik.no +krokstadelva.no +langevag.no +langevåg.no +leirvik.no +mjondalen.no +mjøndalen.no +mo-i-rana.no +mosjoen.no +mosjøen.no +nesoddtangen.no +orkanger.no +osoyro.no +osøyro.no +raholt.no +råholt.no +sandnessjoen.no +sandnessjøen.no +skedsmokorset.no +slattum.no +spjelkavik.no +stathelle.no +stavern.no +stjordalshalsen.no +stjørdalshalsen.no +tananger.no +tranby.no +vossevangen.no +// communities +afjord.no +åfjord.no +agdenes.no +al.no +ål.no +alesund.no +ålesund.no +alstahaug.no +alta.no +áltá.no +alaheadju.no +álaheadju.no +alvdal.no +amli.no +åmli.no +amot.no +åmot.no +andebu.no +andoy.no +andøy.no +andasuolo.no +ardal.no +årdal.no +aremark.no +arendal.no +ås.no +aseral.no +åseral.no +asker.no +askim.no +askvoll.no +askoy.no +askøy.no +asnes.no +åsnes.no +audnedaln.no +aukra.no +aure.no +aurland.no +aurskog-holand.no +aurskog-høland.no +austevoll.no +austrheim.no +averoy.no +averøy.no +balestrand.no +ballangen.no +balat.no +bálát.no +balsfjord.no +bahccavuotna.no +báhccavuotna.no +bamble.no +bardu.no +beardu.no +beiarn.no +bajddar.no +bájddar.no +baidar.no +báidár.no +berg.no +bergen.no +berlevag.no +berlevåg.no +bearalvahki.no +bearalváhki.no +bindal.no +birkenes.no +bjarkoy.no +bjarkøy.no +bjerkreim.no +bjugn.no +bodo.no +bodø.no +badaddja.no +bådåddjå.no +budejju.no +bokn.no +bremanger.no +bronnoy.no +brønnøy.no +bygland.no +bykle.no +barum.no +bærum.no +bo.telemark.no +bø.telemark.no +bo.nordland.no +bø.nordland.no +bievat.no +bievát.no +bomlo.no +bømlo.no +batsfjord.no +båtsfjord.no +bahcavuotna.no +báhcavuotna.no +dovre.no +drammen.no +drangedal.no +dyroy.no +dyrøy.no +donna.no +dønna.no +eid.no +eidfjord.no +eidsberg.no +eidskog.no +eidsvoll.no +eigersund.no +elverum.no +enebakk.no +engerdal.no +etne.no +etnedal.no +evenes.no +evenassi.no +evenášši.no +evje-og-hornnes.no +farsund.no +fauske.no +fuossko.no +fuoisku.no +fedje.no +fet.no +finnoy.no +finnøy.no +fitjar.no +fjaler.no +fjell.no +flakstad.no +flatanger.no +flekkefjord.no +flesberg.no +flora.no +fla.no +flå.no +folldal.no +forsand.no +fosnes.no +frei.no +frogn.no +froland.no +frosta.no +frana.no +fræna.no +froya.no +frøya.no +fusa.no +fyresdal.no +forde.no +førde.no +gamvik.no +gangaviika.no +gáŋgaviika.no +gaular.no +gausdal.no +gildeskal.no +gildeskål.no +giske.no +gjemnes.no +gjerdrum.no +gjerstad.no +gjesdal.no +gjovik.no +gjøvik.no +gloppen.no +gol.no +gran.no +grane.no +granvin.no +gratangen.no +grimstad.no +grong.no +kraanghke.no +kråanghke.no +grue.no +gulen.no +hadsel.no +halden.no +halsa.no +hamar.no +hamaroy.no +habmer.no +hábmer.no +hapmir.no +hápmir.no +hammerfest.no +hammarfeasta.no +hámmárfeasta.no +haram.no +hareid.no +harstad.no +hasvik.no +aknoluokta.no +ákŋoluokta.no +hattfjelldal.no +aarborte.no +haugesund.no +hemne.no +hemnes.no +hemsedal.no +heroy.more-og-romsdal.no +herøy.møre-og-romsdal.no +heroy.nordland.no +herøy.nordland.no +hitra.no +hjartdal.no +hjelmeland.no +hobol.no +hobøl.no +hof.no +hol.no +hole.no +holmestrand.no +holtalen.no +holtålen.no +hornindal.no +horten.no +hurdal.no +hurum.no +hvaler.no +hyllestad.no +hagebostad.no +hægebostad.no +hoyanger.no +høyanger.no +hoylandet.no +høylandet.no +ha.no +hå.no +ibestad.no +inderoy.no +inderøy.no +iveland.no +jevnaker.no +jondal.no +jolster.no +jølster.no +karasjok.no +karasjohka.no +kárášjohka.no +karlsoy.no +galsa.no +gálsá.no +karmoy.no +karmøy.no +kautokeino.no +guovdageaidnu.no +klepp.no +klabu.no +klæbu.no +kongsberg.no +kongsvinger.no +kragero.no +kragerø.no +kristiansand.no +kristiansund.no +krodsherad.no +krødsherad.no +kvalsund.no +rahkkeravju.no +ráhkkerávju.no +kvam.no +kvinesdal.no +kvinnherad.no +kviteseid.no +kvitsoy.no +kvitsøy.no +kvafjord.no +kvæfjord.no +giehtavuoatna.no +kvanangen.no +kvænangen.no +navuotna.no +návuotna.no +kafjord.no +kåfjord.no +gaivuotna.no +gáivuotna.no +larvik.no +lavangen.no +lavagis.no +loabat.no +loabát.no +lebesby.no +davvesiida.no +leikanger.no +leirfjord.no +leka.no +leksvik.no +lenvik.no +leangaviika.no +leaŋgaviika.no +lesja.no +levanger.no +lier.no +lierne.no +lillehammer.no +lillesand.no +lindesnes.no +lindas.no +lindås.no +lom.no +loppa.no +lahppi.no +láhppi.no +lund.no +lunner.no +luroy.no +lurøy.no +luster.no +lyngdal.no +lyngen.no +ivgu.no +lardal.no +lerdal.no +lærdal.no +lodingen.no +lødingen.no +lorenskog.no +lørenskog.no +loten.no +løten.no +malvik.no +masoy.no +måsøy.no +muosat.no +muosát.no +mandal.no +marker.no +marnardal.no +masfjorden.no +meland.no +meldal.no +melhus.no +meloy.no +meløy.no +meraker.no +meråker.no +moareke.no +moåreke.no +midsund.no +midtre-gauldal.no +modalen.no +modum.no +molde.no +moskenes.no +moss.no +mosvik.no +malselv.no +målselv.no +malatvuopmi.no +málatvuopmi.no +namdalseid.no +aejrie.no +namsos.no +namsskogan.no +naamesjevuemie.no +nååmesjevuemie.no +laakesvuemie.no +nannestad.no +narvik.no +narviika.no +naustdal.no +nedre-eiker.no +nes.akershus.no +nes.buskerud.no +nesna.no +nesodden.no +nesseby.no +unjarga.no +unjárga.no +nesset.no +nissedal.no +nittedal.no +nord-aurdal.no +nord-fron.no +nord-odal.no +norddal.no +nordkapp.no +davvenjarga.no +davvenjárga.no +nordre-land.no +nordreisa.no +raisa.no +ráisa.no +nore-og-uvdal.no +notodden.no +naroy.no +nærøy.no +notteroy.no +nøtterøy.no +odda.no +oksnes.no +øksnes.no +oppdal.no +oppegard.no +oppegård.no +orkdal.no +orland.no +ørland.no +orskog.no +ørskog.no +orsta.no +ørsta.no +os.hedmark.no +os.hordaland.no +osen.no +osteroy.no +osterøy.no +ostre-toten.no +østre-toten.no +overhalla.no +ovre-eiker.no +øvre-eiker.no +oyer.no +øyer.no +oygarden.no +øygarden.no +oystre-slidre.no +øystre-slidre.no +porsanger.no +porsangu.no +porsáŋgu.no +porsgrunn.no +radoy.no +radøy.no +rakkestad.no +rana.no +ruovat.no +randaberg.no +rauma.no +rendalen.no +rennebu.no +rennesoy.no +rennesøy.no +rindal.no +ringebu.no +ringerike.no +ringsaker.no +rissa.no +risor.no +risør.no +roan.no +rollag.no +rygge.no +ralingen.no +rælingen.no +rodoy.no +rødøy.no +romskog.no +rømskog.no +roros.no +røros.no +rost.no +røst.no +royken.no +røyken.no +royrvik.no +røyrvik.no +rade.no +råde.no +salangen.no +siellak.no +saltdal.no +salat.no +sálát.no +sálat.no +samnanger.no +sande.more-og-romsdal.no +sande.møre-og-romsdal.no +sande.vestfold.no +sandefjord.no +sandnes.no +sandoy.no +sandøy.no +sarpsborg.no +sauda.no +sauherad.no +sel.no +selbu.no +selje.no +seljord.no +sigdal.no +siljan.no +sirdal.no +skaun.no +skedsmo.no +ski.no +skien.no +skiptvet.no +skjervoy.no +skjervøy.no +skierva.no +skiervá.no +skjak.no +skjåk.no +skodje.no +skanland.no +skånland.no +skanit.no +skánit.no +smola.no +smøla.no +snillfjord.no +snasa.no +snåsa.no +snoasa.no +snaase.no +snåase.no +sogndal.no +sokndal.no +sola.no +solund.no +songdalen.no +sortland.no +spydeberg.no +stange.no +stavanger.no +steigen.no +steinkjer.no +stjordal.no +stjørdal.no +stokke.no +stor-elvdal.no +stord.no +stordal.no +storfjord.no +omasvuotna.no +strand.no +stranda.no +stryn.no +sula.no +suldal.no +sund.no +sunndal.no +surnadal.no +sveio.no +svelvik.no +sykkylven.no +sogne.no +søgne.no +somna.no +sømna.no +sondre-land.no +søndre-land.no +sor-aurdal.no +sør-aurdal.no +sor-fron.no +sør-fron.no +sor-odal.no +sør-odal.no +sor-varanger.no +sør-varanger.no +matta-varjjat.no +mátta-várjjat.no +sorfold.no +sørfold.no +sorreisa.no +sørreisa.no +sorum.no +sørum.no +tana.no +deatnu.no +time.no +tingvoll.no +tinn.no +tjeldsund.no +dielddanuorri.no +tjome.no +tjøme.no +tokke.no +tolga.no +torsken.no +tranoy.no +tranøy.no +tromso.no +tromsø.no +tromsa.no +romsa.no +trondheim.no +troandin.no +trysil.no +trana.no +træna.no +trogstad.no +trøgstad.no +tvedestrand.no +tydal.no +tynset.no +tysfjord.no +divtasvuodna.no +divttasvuotna.no +tysnes.no +tysvar.no +tysvær.no +tonsberg.no +tønsberg.no +ullensaker.no +ullensvang.no +ulvik.no +utsira.no +vadso.no +vadsø.no +cahcesuolo.no +čáhcesuolo.no +vaksdal.no +valle.no +vang.no +vanylven.no +vardo.no +vardø.no +varggat.no +várggát.no +vefsn.no +vaapste.no +vega.no +vegarshei.no +vegårshei.no +vennesla.no +verdal.no +verran.no +vestby.no +vestnes.no +vestre-slidre.no +vestre-toten.no +vestvagoy.no +vestvågøy.no +vevelstad.no +vik.no +vikna.no +vindafjord.no +volda.no +voss.no +varoy.no +værøy.no +vagan.no +vågan.no +voagat.no +vagsoy.no +vågsøy.no +vaga.no +vågå.no +valer.ostfold.no +våler.østfold.no +valer.hedmark.no +våler.hedmark.no + +// np : http://www.mos.com.np/register.html +*.np + +// nr : http://cenpac.net.nr/dns/index.html +// Confirmed by registry 2008-06-17 +nr +biz.nr +info.nr +gov.nr +edu.nr +org.nr +net.nr +com.nr + +// nu : http://en.wikipedia.org/wiki/.nu +nu + +// nz : http://en.wikipedia.org/wiki/.nz +*.nz + +// om : http://en.wikipedia.org/wiki/.om +*.om +!mediaphone.om +!nawrastelecom.om +!nawras.om +!omanmobile.om +!omanpost.om +!omantel.om +!rakpetroleum.om +!siemens.om +!songfest.om +!statecouncil.om + +// org : http://en.wikipedia.org/wiki/.org +org + +// pa : http://www.nic.pa/ +// Some additional second level "domains" resolve directly as hostnames, such as +// pannet.pa, so we add a rule for "pa". +pa +ac.pa +gob.pa +com.pa +org.pa +sld.pa +edu.pa +net.pa +ing.pa +abo.pa +med.pa +nom.pa + +// pe : https://www.nic.pe/InformeFinalComision.pdf +pe +edu.pe +gob.pe +nom.pe +mil.pe +org.pe +com.pe +net.pe + +// pf : http://www.gobin.info/domainname/formulaire-pf.pdf +pf +com.pf +org.pf +edu.pf + +// pg : http://en.wikipedia.org/wiki/.pg +*.pg + +// ph : http://www.domains.ph/FAQ2.asp +// Submitted by registry 2008-06-13 +ph +com.ph +net.ph +org.ph +gov.ph +edu.ph +ngo.ph +mil.ph +i.ph + +// pk : http://pk5.pknic.net.pk/pk5/msgNamepk.PK +pk +com.pk +net.pk +edu.pk +org.pk +fam.pk +biz.pk +web.pk +gov.pk +gob.pk +gok.pk +gon.pk +gop.pk +gos.pk +info.pk + +// pl : http://www.dns.pl/english/ +pl +// NASK functional domains (nask.pl / dns.pl) : http://www.dns.pl/english/dns-funk.html +aid.pl +agro.pl +atm.pl +auto.pl +biz.pl +com.pl +edu.pl +gmina.pl +gsm.pl +info.pl +mail.pl +miasta.pl +media.pl +mil.pl +net.pl +nieruchomosci.pl +nom.pl +org.pl +pc.pl +powiat.pl +priv.pl +realestate.pl +rel.pl +sex.pl +shop.pl +sklep.pl +sos.pl +szkola.pl +targi.pl +tm.pl +tourism.pl +travel.pl +turystyka.pl +// ICM functional domains (icm.edu.pl) +6bone.pl +art.pl +mbone.pl +// Government domains (administred by ippt.gov.pl) +gov.pl +uw.gov.pl +um.gov.pl +ug.gov.pl +upow.gov.pl +starostwo.gov.pl +so.gov.pl +sr.gov.pl +po.gov.pl +pa.gov.pl +// other functional domains +ngo.pl +irc.pl +usenet.pl +// NASK geographical domains : http://www.dns.pl/english/dns-regiony.html +augustow.pl +babia-gora.pl +bedzin.pl +beskidy.pl +bialowieza.pl +bialystok.pl +bielawa.pl +bieszczady.pl +boleslawiec.pl +bydgoszcz.pl +bytom.pl +cieszyn.pl +czeladz.pl +czest.pl +dlugoleka.pl +elblag.pl +elk.pl +glogow.pl +gniezno.pl +gorlice.pl +grajewo.pl +ilawa.pl +jaworzno.pl +jelenia-gora.pl +jgora.pl +kalisz.pl +kazimierz-dolny.pl +karpacz.pl +kartuzy.pl +kaszuby.pl +katowice.pl +kepno.pl +ketrzyn.pl +klodzko.pl +kobierzyce.pl +kolobrzeg.pl +konin.pl +konskowola.pl +kutno.pl +lapy.pl +lebork.pl +legnica.pl +lezajsk.pl +limanowa.pl +lomza.pl +lowicz.pl +lubin.pl +lukow.pl +malbork.pl +malopolska.pl +mazowsze.pl +mazury.pl +mielec.pl +mielno.pl +mragowo.pl +naklo.pl +nowaruda.pl +nysa.pl +olawa.pl +olecko.pl +olkusz.pl +olsztyn.pl +opoczno.pl +opole.pl +ostroda.pl +ostroleka.pl +ostrowiec.pl +ostrowwlkp.pl +pila.pl +pisz.pl +podhale.pl +podlasie.pl +polkowice.pl +pomorze.pl +pomorskie.pl +prochowice.pl +pruszkow.pl +przeworsk.pl +pulawy.pl +radom.pl +rawa-maz.pl +rybnik.pl +rzeszow.pl +sanok.pl +sejny.pl +siedlce.pl +slask.pl +slupsk.pl +sosnowiec.pl +stalowa-wola.pl +skoczow.pl +starachowice.pl +stargard.pl +suwalki.pl +swidnica.pl +swiebodzin.pl +swinoujscie.pl +szczecin.pl +szczytno.pl +tarnobrzeg.pl +tgory.pl +turek.pl +tychy.pl +ustka.pl +walbrzych.pl +warmia.pl +warszawa.pl +waw.pl +wegrow.pl +wielun.pl +wlocl.pl +wloclawek.pl +wodzislaw.pl +wolomin.pl +wroclaw.pl +zachpomor.pl +zagan.pl +zarow.pl +zgora.pl +zgorzelec.pl +// TASK geographical domains (www.task.gda.pl/uslugi/dns) +gda.pl +gdansk.pl +gdynia.pl +med.pl +sopot.pl +// other geographical domains +gliwice.pl +krakow.pl +poznan.pl +wroc.pl +zakopane.pl + +// pm : http://www.afnic.fr/medias/documents/AFNIC-naming-policy2012.pdf +pm + +// pn : http://www.government.pn/PnRegistry/policies.htm +pn +gov.pn +co.pn +org.pn +edu.pn +net.pn + +// post : http://en.wikipedia.org/wiki/.post +post + +// pr : http://www.nic.pr/index.asp?f=1 +pr +com.pr +net.pr +org.pr +gov.pr +edu.pr +isla.pr +pro.pr +biz.pr +info.pr +name.pr +// these aren't mentioned on nic.pr, but on http://en.wikipedia.org/wiki/.pr +est.pr +prof.pr +ac.pr + +// pro : http://www.nic.pro/support_faq.htm +pro +aca.pro +bar.pro +cpa.pro +jur.pro +law.pro +med.pro +eng.pro + +// ps : http://en.wikipedia.org/wiki/.ps +// http://www.nic.ps/registration/policy.html#reg +ps +edu.ps +gov.ps +sec.ps +plo.ps +com.ps +org.ps +net.ps + +// pt : http://online.dns.pt/dns/start_dns +pt +net.pt +gov.pt +org.pt +edu.pt +int.pt +publ.pt +com.pt +nome.pt + +// pw : http://en.wikipedia.org/wiki/.pw +pw +co.pw +ne.pw +or.pw +ed.pw +go.pw +belau.pw + +// py : http://www.nic.py/pautas.html#seccion_9 +// Confirmed by registry 2012-10-03 +py +com.py +coop.py +edu.py +gov.py +mil.py +net.py +org.py + +// qa : http://domains.qa/en/ +qa +com.qa +edu.qa +gov.qa +mil.qa +name.qa +net.qa +org.qa +sch.qa + +// re : http://www.afnic.re/obtenir/chartes/nommage-re/annexe-descriptifs +re +com.re +asso.re +nom.re + +// ro : http://www.rotld.ro/ +ro +com.ro +org.ro +tm.ro +nt.ro +nom.ro +info.ro +rec.ro +arts.ro +firm.ro +store.ro +www.ro + +// rs : http://en.wikipedia.org/wiki/.rs +rs +co.rs +org.rs +edu.rs +ac.rs +gov.rs +in.rs + +// ru : http://www.cctld.ru/ru/docs/aktiv_8.php +// Industry domains +ru +ac.ru +com.ru +edu.ru +int.ru +net.ru +org.ru +pp.ru +// Geographical domains +adygeya.ru +altai.ru +amur.ru +arkhangelsk.ru +astrakhan.ru +bashkiria.ru +belgorod.ru +bir.ru +bryansk.ru +buryatia.ru +cbg.ru +chel.ru +chelyabinsk.ru +chita.ru +chukotka.ru +chuvashia.ru +dagestan.ru +dudinka.ru +e-burg.ru +grozny.ru +irkutsk.ru +ivanovo.ru +izhevsk.ru +jar.ru +joshkar-ola.ru +kalmykia.ru +kaluga.ru +kamchatka.ru +karelia.ru +kazan.ru +kchr.ru +kemerovo.ru +khabarovsk.ru +khakassia.ru +khv.ru +kirov.ru +koenig.ru +komi.ru +kostroma.ru +krasnoyarsk.ru +kuban.ru +kurgan.ru +kursk.ru +lipetsk.ru +magadan.ru +mari.ru +mari-el.ru +marine.ru +mordovia.ru +mosreg.ru +msk.ru +murmansk.ru +nalchik.ru +nnov.ru +nov.ru +novosibirsk.ru +nsk.ru +omsk.ru +orenburg.ru +oryol.ru +palana.ru +penza.ru +perm.ru +pskov.ru +ptz.ru +rnd.ru +ryazan.ru +sakhalin.ru +samara.ru +saratov.ru +simbirsk.ru +smolensk.ru +spb.ru +stavropol.ru +stv.ru +surgut.ru +tambov.ru +tatarstan.ru +tom.ru +tomsk.ru +tsaritsyn.ru +tsk.ru +tula.ru +tuva.ru +tver.ru +tyumen.ru +udm.ru +udmurtia.ru +ulan-ude.ru +vladikavkaz.ru +vladimir.ru +vladivostok.ru +volgograd.ru +vologda.ru +voronezh.ru +vrn.ru +vyatka.ru +yakutia.ru +yamal.ru +yaroslavl.ru +yekaterinburg.ru +yuzhno-sakhalinsk.ru +// More geographical domains +amursk.ru +baikal.ru +cmw.ru +fareast.ru +jamal.ru +kms.ru +k-uralsk.ru +kustanai.ru +kuzbass.ru +magnitka.ru +mytis.ru +nakhodka.ru +nkz.ru +norilsk.ru +oskol.ru +pyatigorsk.ru +rubtsovsk.ru +snz.ru +syzran.ru +vdonsk.ru +zgrad.ru +// State domains +gov.ru +mil.ru +// Technical domains +test.ru + +// rw : http://www.nic.rw/cgi-bin/policy.pl +rw +gov.rw +net.rw +edu.rw +ac.rw +com.rw +co.rw +int.rw +mil.rw +gouv.rw + +// sa : http://www.nic.net.sa/ +sa +com.sa +net.sa +org.sa +gov.sa +med.sa +pub.sa +edu.sa +sch.sa + +// sb : http://www.sbnic.net.sb/ +// Submitted by registry 2008-06-08 +sb +com.sb +edu.sb +gov.sb +net.sb +org.sb + +// sc : http://www.nic.sc/ +sc +com.sc +gov.sc +net.sc +org.sc +edu.sc + +// sd : http://www.isoc.sd/sudanic.isoc.sd/billing_pricing.htm +// Submitted by registry 2008-06-17 +sd +com.sd +net.sd +org.sd +edu.sd +med.sd +tv.sd +gov.sd +info.sd + +// se : http://en.wikipedia.org/wiki/.se +// Submitted by registry 2008-06-24 +se +a.se +ac.se +b.se +bd.se +brand.se +c.se +d.se +e.se +f.se +fh.se +fhsk.se +fhv.se +g.se +h.se +i.se +k.se +komforb.se +kommunalforbund.se +komvux.se +l.se +lanbib.se +m.se +n.se +naturbruksgymn.se +o.se +org.se +p.se +parti.se +pp.se +press.se +r.se +s.se +sshn.se +t.se +tm.se +u.se +w.se +x.se +y.se +z.se + +// sg : http://www.nic.net.sg/page/registration-policies-procedures-and-guidelines +sg +com.sg +net.sg +org.sg +gov.sg +edu.sg +per.sg + +// sh : http://www.nic.sh/registrar.html +sh +com.sh +net.sh +gov.sh +org.sh +mil.sh + +// si : http://en.wikipedia.org/wiki/.si +si + +// sj : No registrations at this time. +// Submitted by registry 2008-06-16 + +// sk : http://en.wikipedia.org/wiki/.sk +// list of 2nd level domains ? +sk + +// sl : http://www.nic.sl +// Submitted by registry 2008-06-12 +sl +com.sl +net.sl +edu.sl +gov.sl +org.sl + +// sm : http://en.wikipedia.org/wiki/.sm +sm + +// sn : http://en.wikipedia.org/wiki/.sn +sn +art.sn +com.sn +edu.sn +gouv.sn +org.sn +perso.sn +univ.sn + +// so : http://www.soregistry.com/ +so +com.so +net.so +org.so + +// sr : http://en.wikipedia.org/wiki/.sr +sr + +// st : http://www.nic.st/html/policyrules/ +st +co.st +com.st +consulado.st +edu.st +embaixada.st +gov.st +mil.st +net.st +org.st +principe.st +saotome.st +store.st + +// su : http://en.wikipedia.org/wiki/.su +su + +// sv : http://www.svnet.org.sv/svpolicy.html +*.sv + +// sx : http://en.wikipedia.org/wiki/.sx +// Confirmed by registry 2012-05-31 +sx +gov.sx + +// sy : http://en.wikipedia.org/wiki/.sy +// see also: http://www.gobin.info/domainname/sy.doc +sy +edu.sy +gov.sy +net.sy +mil.sy +com.sy +org.sy + +// sz : http://en.wikipedia.org/wiki/.sz +// http://www.sispa.org.sz/ +sz +co.sz +ac.sz +org.sz + +// tc : http://en.wikipedia.org/wiki/.tc +tc + +// td : http://en.wikipedia.org/wiki/.td +td + +// tel: http://en.wikipedia.org/wiki/.tel +// http://www.telnic.org/ +tel + +// tf : http://en.wikipedia.org/wiki/.tf +tf + +// tg : http://en.wikipedia.org/wiki/.tg +// http://www.nic.tg/ +tg + +// th : http://en.wikipedia.org/wiki/.th +// Submitted by registry 2008-06-17 +th +ac.th +co.th +go.th +in.th +mi.th +net.th +or.th + +// tj : http://www.nic.tj/policy.html +tj +ac.tj +biz.tj +co.tj +com.tj +edu.tj +go.tj +gov.tj +int.tj +mil.tj +name.tj +net.tj +nic.tj +org.tj +test.tj +web.tj + +// tk : http://en.wikipedia.org/wiki/.tk +tk + +// tl : http://en.wikipedia.org/wiki/.tl +tl +gov.tl + +// tm : http://www.nic.tm/local.html +tm +com.tm +co.tm +org.tm +net.tm +nom.tm +gov.tm +mil.tm +edu.tm + +// tn : http://en.wikipedia.org/wiki/.tn +// http://whois.ati.tn/ +tn +com.tn +ens.tn +fin.tn +gov.tn +ind.tn +intl.tn +nat.tn +net.tn +org.tn +info.tn +perso.tn +tourism.tn +edunet.tn +rnrt.tn +rns.tn +rnu.tn +mincom.tn +agrinet.tn +defense.tn +turen.tn + +// to : http://en.wikipedia.org/wiki/.to +// Submitted by registry 2008-06-17 +to +com.to +gov.to +net.to +org.to +edu.to +mil.to + +// tr : http://en.wikipedia.org/wiki/.tr +*.tr +!nic.tr +// Used by government in the TRNC +// http://en.wikipedia.org/wiki/.nc.tr +gov.nc.tr + +// travel : http://en.wikipedia.org/wiki/.travel +travel + +// tt : http://www.nic.tt/ +tt +co.tt +com.tt +org.tt +net.tt +biz.tt +info.tt +pro.tt +int.tt +coop.tt +jobs.tt +mobi.tt +travel.tt +museum.tt +aero.tt +name.tt +gov.tt +edu.tt + +// tv : http://en.wikipedia.org/wiki/.tv +// Not listing any 2LDs as reserved since none seem to exist in practice, +// Wikipedia notwithstanding. +tv + +// tw : http://en.wikipedia.org/wiki/.tw +tw +edu.tw +gov.tw +mil.tw +com.tw +net.tw +org.tw +idv.tw +game.tw +ebiz.tw +club.tw +網路.tw +組織.tw +商業.tw + +// tz : http://www.tznic.or.tz/index.php/domains +// Confirmed by registry 2013-01-22 +ac.tz +co.tz +go.tz +hotel.tz +info.tz +me.tz +mil.tz +mobi.tz +ne.tz +or.tz +sc.tz +tv.tz + +// ua : https://hostmaster.ua/policy/?ua +// Submitted by registry 2012-04-27 +ua +// ua 2LD +com.ua +edu.ua +gov.ua +in.ua +net.ua +org.ua +// ua geographic names +// https://hostmaster.ua/2ld/ +cherkassy.ua +cherkasy.ua +chernigov.ua +chernihiv.ua +chernivtsi.ua +chernovtsy.ua +ck.ua +cn.ua +cr.ua +crimea.ua +cv.ua +dn.ua +dnepropetrovsk.ua +dnipropetrovsk.ua +dominic.ua +donetsk.ua +dp.ua +if.ua +ivano-frankivsk.ua +kh.ua +kharkiv.ua +kharkov.ua +kherson.ua +khmelnitskiy.ua +khmelnytskyi.ua +kiev.ua +kirovograd.ua +km.ua +kr.ua +krym.ua +ks.ua +kv.ua +kyiv.ua +lg.ua +lt.ua +lugansk.ua +lutsk.ua +lv.ua +lviv.ua +mk.ua +mykolaiv.ua +nikolaev.ua +od.ua +odesa.ua +odessa.ua +pl.ua +poltava.ua +rivne.ua +rovno.ua +rv.ua +sb.ua +sebastopol.ua +sevastopol.ua +sm.ua +sumy.ua +te.ua +ternopil.ua +uz.ua +uzhgorod.ua +vinnica.ua +vinnytsia.ua +vn.ua +volyn.ua +yalta.ua +zaporizhzhe.ua +zaporizhzhia.ua +zhitomir.ua +zhytomyr.ua +zp.ua +zt.ua + +// Private registries in .ua +co.ua +pp.ua + +// ug : https://www.registry.co.ug/ +ug +co.ug +or.ug +ac.ug +sc.ug +go.ug +ne.ug +com.ug +org.ug + +// uk : http://en.wikipedia.org/wiki/.uk +// Submitted by registry 2012-10-02 +// and tweaked by us pending further consultation. +*.uk +*.sch.uk +!bl.uk +!british-library.uk +!jet.uk +!mod.uk +!national-library-scotland.uk +!nel.uk +!nic.uk +!nls.uk +!parliament.uk + +// us : http://en.wikipedia.org/wiki/.us +us +dni.us +fed.us +isa.us +kids.us +nsn.us +// us geographic names +ak.us +al.us +ar.us +as.us +az.us +ca.us +co.us +ct.us +dc.us +de.us +fl.us +ga.us +gu.us +hi.us +ia.us +id.us +il.us +in.us +ks.us +ky.us +la.us +ma.us +md.us +me.us +mi.us +mn.us +mo.us +ms.us +mt.us +nc.us +nd.us +ne.us +nh.us +nj.us +nm.us +nv.us +ny.us +oh.us +ok.us +or.us +pa.us +pr.us +ri.us +sc.us +sd.us +tn.us +tx.us +ut.us +vi.us +vt.us +va.us +wa.us +wi.us +wv.us +wy.us +// The registrar notes several more specific domains available in each state, +// such as state.*.us, dst.*.us, etc., but resolution of these is somewhat +// haphazard; in some states these domains resolve as addresses, while in others +// only subdomains are available, or even nothing at all. We include the +// most common ones where it's clear that different sites are different +// entities. +k12.ak.us +k12.al.us +k12.ar.us +k12.as.us +k12.az.us +k12.ca.us +k12.co.us +k12.ct.us +k12.dc.us +k12.de.us +k12.fl.us +k12.ga.us +k12.gu.us +// k12.hi.us Hawaii has a state-wide DOE login: bug 614565 +k12.ia.us +k12.id.us +k12.il.us +k12.in.us +k12.ks.us +k12.ky.us +k12.la.us +k12.ma.us +k12.md.us +k12.me.us +k12.mi.us +k12.mn.us +k12.mo.us +k12.ms.us +k12.mt.us +k12.nc.us +k12.nd.us +k12.ne.us +k12.nh.us +k12.nj.us +k12.nm.us +k12.nv.us +k12.ny.us +k12.oh.us +k12.ok.us +k12.or.us +k12.pa.us +k12.pr.us +k12.ri.us +k12.sc.us +k12.sd.us +k12.tn.us +k12.tx.us +k12.ut.us +k12.vi.us +k12.vt.us +k12.va.us +k12.wa.us +k12.wi.us +k12.wv.us +k12.wy.us + +cc.ak.us +cc.al.us +cc.ar.us +cc.as.us +cc.az.us +cc.ca.us +cc.co.us +cc.ct.us +cc.dc.us +cc.de.us +cc.fl.us +cc.ga.us +cc.gu.us +cc.hi.us +cc.ia.us +cc.id.us +cc.il.us +cc.in.us +cc.ks.us +cc.ky.us +cc.la.us +cc.ma.us +cc.md.us +cc.me.us +cc.mi.us +cc.mn.us +cc.mo.us +cc.ms.us +cc.mt.us +cc.nc.us +cc.nd.us +cc.ne.us +cc.nh.us +cc.nj.us +cc.nm.us +cc.nv.us +cc.ny.us +cc.oh.us +cc.ok.us +cc.or.us +cc.pa.us +cc.pr.us +cc.ri.us +cc.sc.us +cc.sd.us +cc.tn.us +cc.tx.us +cc.ut.us +cc.vi.us +cc.vt.us +cc.va.us +cc.wa.us +cc.wi.us +cc.wv.us +cc.wy.us + +lib.ak.us +lib.al.us +lib.ar.us +lib.as.us +lib.az.us +lib.ca.us +lib.co.us +lib.ct.us +lib.dc.us +lib.de.us +lib.fl.us +lib.ga.us +lib.gu.us +lib.hi.us +lib.ia.us +lib.id.us +lib.il.us +lib.in.us +lib.ks.us +lib.ky.us +lib.la.us +lib.ma.us +lib.md.us +lib.me.us +lib.mi.us +lib.mn.us +lib.mo.us +lib.ms.us +lib.mt.us +lib.nc.us +lib.nd.us +lib.ne.us +lib.nh.us +lib.nj.us +lib.nm.us +lib.nv.us +lib.ny.us +lib.oh.us +lib.ok.us +lib.or.us +lib.pa.us +lib.pr.us +lib.ri.us +lib.sc.us +lib.sd.us +lib.tn.us +lib.tx.us +lib.ut.us +lib.vi.us +lib.vt.us +lib.va.us +lib.wa.us +lib.wi.us +lib.wv.us +lib.wy.us + +// k12.ma.us contains school districts in Massachusetts. The 4LDs are +// managed indepedently except for private (PVT), charter (CHTR) and +// parochial (PAROCH) schools. Those are delegated dorectly to the +// 5LD operators. +pvt.k12.ma.us +chtr.k12.ma.us +paroch.k12.ma.us + +// uy : http://www.nic.org.uy/ +uy +com.uy +edu.uy +gub.uy +mil.uy +net.uy +org.uy + +// uz : http://www.reg.uz/ +uz +co.uz +com.uz +net.uz +org.uz + +// va : http://en.wikipedia.org/wiki/.va +va + +// vc : http://en.wikipedia.org/wiki/.vc +// Submitted by registry 2008-06-13 +vc +com.vc +net.vc +org.vc +gov.vc +mil.vc +edu.vc + +// ve : https://registro.nic.ve/ +// Confirmed by registry 2012-10-04 +ve +co.ve +com.ve +e12.ve +edu.ve +gov.ve +info.ve +mil.ve +net.ve +org.ve +web.ve + +// vg : http://en.wikipedia.org/wiki/.vg +vg + +// vi : http://www.nic.vi/newdomainform.htm +// http://www.nic.vi/Domain_Rules/body_domain_rules.html indicates some other +// TLDs are "reserved", such as edu.vi and gov.vi, but doesn't actually say they +// are available for registration (which they do not seem to be). +vi +co.vi +com.vi +k12.vi +net.vi +org.vi + +// vn : https://www.dot.vn/vnnic/vnnic/domainregistration.jsp +vn +com.vn +net.vn +org.vn +edu.vn +gov.vn +int.vn +ac.vn +biz.vn +info.vn +name.vn +pro.vn +health.vn + +// vu : http://en.wikipedia.org/wiki/.vu +// list of 2nd level tlds ? +vu + +// wf : http://www.afnic.fr/medias/documents/AFNIC-naming-policy2012.pdf +wf + +// ws : http://en.wikipedia.org/wiki/.ws +// http://samoanic.ws/index.dhtml +ws +com.ws +net.ws +org.ws +gov.ws +edu.ws + +// yt : http://www.afnic.fr/medias/documents/AFNIC-naming-policy2012.pdf +yt + +// IDN ccTLDs +// Please sort by ISO 3166 ccTLD, then punicode string +// when submitting patches and follow this format: +// ("" ) : +// [optional sponsoring org] +// + +// xn--mgbaam7a8h ("Emerat" Arabic) : AE +// http://nic.ae/english/arabicdomain/rules.jsp +امارات + +// xn--54b7fta0cc ("Bangla" Bangla) : BD +বাংলা + +// xn--fiqs8s ("China" Chinese-Han-Simplified <.Zhonggou>) : CN +// CNNIC +// http://cnnic.cn/html/Dir/2005/10/11/3218.htm +中国 + +// xn--fiqz9s ("China" Chinese-Han-Traditional <.Zhonggou>) : CN +// CNNIC +// http://cnnic.cn/html/Dir/2005/10/11/3218.htm +中國 + +// xn--lgbbat1ad8j ("Algeria / Al Jazair" Arabic) : DZ +الجزائر + +// xn--wgbh1c ("Egypt" Arabic .masr) : EG +// http://www.dotmasr.eg/ +مصر + +// xn--node ("ge" Georgian (Mkhedruli)) : GE +გე + +// xn--j6w193g ("Hong Kong" Chinese-Han) : HK +// https://www2.hkirc.hk/register/rules.jsp +香港 + +// xn--h2brj9c ("Bharat" Devanagari) : IN +// India +भारत + +// xn--mgbbh1a71e ("Bharat" Arabic) : IN +// India +بھارت + +// xn--fpcrj9c3d ("Bharat" Telugu) : IN +// India +భారత్ + +// xn--gecrj9c ("Bharat" Gujarati) : IN +// India +ભારત + +// xn--s9brj9c ("Bharat" Gurmukhi) : IN +// India +ਭਾਰਤ + +// xn--45brj9c ("Bharat" Bengali) : IN +// India +ভারত + +// xn--xkc2dl3a5ee0h ("India" Tamil) : IN +// India +இந்தியா + +// xn--mgba3a4f16a ("Iran" Persian) : IR +ایران + +// xn--mgba3a4fra ("Iran" Arabic) : IR +ايران + +// xn--mgbayh7gpa ("al-Ordon" Arabic) : JO +// National Information Technology Center (NITC) +// Royal Scientific Society, Al-Jubeiha +الاردن + +// xn--3e0b707e ("Republic of Korea" Hangul) : KR +한국 + +// xn--fzc2c9e2c ("Lanka" Sinhalese-Sinhala) : LK +// http://nic.lk +ලංකා + +// xn--xkc2al3hye2a ("Ilangai" Tamil) : LK +// http://nic.lk +இலங்கை + +// xn--mgbc0a9azcg ("Morocco / al-Maghrib" Arabic) : MA +المغرب + +// xn--mgb9awbf ("Oman" Arabic) : OM +عمان + +// xn--ygbi2ammx ("Falasteen" Arabic) : PS +// The Palestinian National Internet Naming Authority (PNINA) +// http://www.pnina.ps +فلسطين + +// xn--90a3ac ("srb" Cyrillic) : RS +срб + +// xn--p1ai ("rf" Russian-Cyrillic) : RU +// http://www.cctld.ru/en/docs/rulesrf.php +рф + +// xn--wgbl6a ("Qatar" Arabic) : QA +// http://www.ict.gov.qa/ +قطر + +// xn--mgberp4a5d4ar ("AlSaudiah" Arabic) : SA +// http://www.nic.net.sa/ +السعودية + +// xn--mgberp4a5d4a87g ("AlSaudiah" Arabic) variant : SA +السعودیة + +// xn--mgbqly7c0a67fbc ("AlSaudiah" Arabic) variant : SA +السعودیۃ + +// xn--mgbqly7cvafr ("AlSaudiah" Arabic) variant : SA +السعوديه + +// xn--ogbpf8fl ("Syria" Arabic) : SY +سورية + +// xn--mgbtf8fl ("Syria" Arabic) variant : SY +سوريا + +// xn--yfro4i67o Singapore ("Singapore" Chinese-Han) : SG +新加坡 + +// xn--clchc0ea0b2g2a9gcd ("Singapore" Tamil) : SG +சிங்கப்பூர் + +// xn--o3cw4h ("Thai" Thai) : TH +// http://www.thnic.co.th +ไทย + +// xn--pgbs0dh ("Tunis") : TN +// http://nic.tn +تونس + +// xn--kpry57d ("Taiwan" Chinese-Han-Traditional) : TW +// http://www.twnic.net/english/dn/dn_07a.htm +台灣 + +// xn--kprw13d ("Taiwan" Chinese-Han-Simplified) : TW +// http://www.twnic.net/english/dn/dn_07a.htm +台湾 + +// xn--nnx388a ("Taiwan") variant : TW +臺灣 + +// xn--j1amh ("ukr" Cyrillic) : UA +укр + +// xn--mgb2ddes ("AlYemen" Arabic) : YE +اليمن + +// xxx : http://icmregistry.com +xxx + +// ye : http://www.y.net.ye/services/domain_name.htm +*.ye + +// za : http://www.zadna.org.za/slds.html +*.za + +// zm : http://en.wikipedia.org/wiki/.zm +*.zm + +// zw : http://en.wikipedia.org/wiki/.zw +*.zw + +// ===END ICANN DOMAINS=== +// ===BEGIN PRIVATE DOMAINS=== + +// Amazon CloudFront : https://aws.amazon.com/cloudfront/ +// Requested by Donavan Miller 2013-03-22 +cloudfront.net + +// Amazon Elastic Load Balancing : https://aws.amazon.com/elasticloadbalancing/ +// Requested by Scott Vidmar 2013-03-27 +elb.amazonaws.com + +// Amazon S3 : https://aws.amazon.com/s3/ +// Requested by Courtney Eckhardt 2013-03-22 +s3.amazonaws.com +s3-us-west-2.amazonaws.com +s3-us-west-1.amazonaws.com +s3-eu-west-1.amazonaws.com +s3-ap-southeast-1.amazonaws.com +s3-ap-southeast-2.amazonaws.com +s3-ap-northeast-1.amazonaws.com +s3-sa-east-1.amazonaws.com +s3-us-gov-west-1.amazonaws.com +s3-fips-us-gov-west-1.amazonaws.com +s3-website-us-east-1.amazonaws.com +s3-website-us-west-2.amazonaws.com +s3-website-us-west-1.amazonaws.com +s3-website-eu-west-1.amazonaws.com +s3-website-ap-southeast-1.amazonaws.com +s3-website-ap-southeast-2.amazonaws.com +s3-website-ap-northeast-1.amazonaws.com +s3-website-sa-east-1.amazonaws.com +s3-website-us-gov-west-1.amazonaws.com + +// BetaInABox +// Requested by adrian@betainabox.com 2012-09-13 +betainabox.com + +// CentralNic : http://www.centralnic.com/names/domains +// Requested by registry 2012-09-27 +ae.org +ar.com +br.com +cn.com +com.de +de.com +eu.com +gb.com +gb.net +gr.com +hu.com +hu.net +jp.net +jpn.com +kr.com +no.com +qc.com +ru.com +sa.com +se.com +se.net +uk.com +uk.net +us.com +us.org +uy.com +za.com + +// c.la : http://www.c.la/ +c.la + +// co.ca : http://registry.co.ca/ +co.ca + +// CoDNS B.V. +co.nl +co.no + +// DreamHost : http://www.dreamhost.com/ +// Requested by Andrew Farmer 2012-10-02 +dreamhosters.com + +// DynDNS.com : http://www.dyndns.com/services/dns/dyndns/ +dyndns-at-home.com +dyndns-at-work.com +dyndns-blog.com +dyndns-free.com +dyndns-home.com +dyndns-ip.com +dyndns-mail.com +dyndns-office.com +dyndns-pics.com +dyndns-remote.com +dyndns-server.com +dyndns-web.com +dyndns-wiki.com +dyndns-work.com +dyndns.biz +dyndns.info +dyndns.org +dyndns.tv +at-band-camp.net +ath.cx +barrel-of-knowledge.info +barrell-of-knowledge.info +better-than.tv +blogdns.com +blogdns.net +blogdns.org +blogsite.org +boldlygoingnowhere.org +broke-it.net +buyshouses.net +cechire.com +dnsalias.com +dnsalias.net +dnsalias.org +dnsdojo.com +dnsdojo.net +dnsdojo.org +does-it.net +doesntexist.com +doesntexist.org +dontexist.com +dontexist.net +dontexist.org +doomdns.com +doomdns.org +dvrdns.org +dyn-o-saur.com +dynalias.com +dynalias.net +dynalias.org +dynathome.net +dyndns.ws +endofinternet.net +endofinternet.org +endoftheinternet.org +est-a-la-maison.com +est-a-la-masion.com +est-le-patron.com +est-mon-blogueur.com +for-better.biz +for-more.biz +for-our.info +for-some.biz +for-the.biz +forgot.her.name +forgot.his.name +from-ak.com +from-al.com +from-ar.com +from-az.net +from-ca.com +from-co.net +from-ct.com +from-dc.com +from-de.com +from-fl.com +from-ga.com +from-hi.com +from-ia.com +from-id.com +from-il.com +from-in.com +from-ks.com +from-ky.com +from-la.net +from-ma.com +from-md.com +from-me.org +from-mi.com +from-mn.com +from-mo.com +from-ms.com +from-mt.com +from-nc.com +from-nd.com +from-ne.com +from-nh.com +from-nj.com +from-nm.com +from-nv.com +from-ny.net +from-oh.com +from-ok.com +from-or.com +from-pa.com +from-pr.com +from-ri.com +from-sc.com +from-sd.com +from-tn.com +from-tx.com +from-ut.com +from-va.com +from-vt.com +from-wa.com +from-wi.com +from-wv.com +from-wy.com +ftpaccess.cc +fuettertdasnetz.de +game-host.org +game-server.cc +getmyip.com +gets-it.net +go.dyndns.org +gotdns.com +gotdns.org +groks-the.info +groks-this.info +ham-radio-op.net +here-for-more.info +hobby-site.com +hobby-site.org +home.dyndns.org +homedns.org +homeftp.net +homeftp.org +homeip.net +homelinux.com +homelinux.net +homelinux.org +homeunix.com +homeunix.net +homeunix.org +iamallama.com +in-the-band.net +is-a-anarchist.com +is-a-blogger.com +is-a-bookkeeper.com +is-a-bruinsfan.org +is-a-bulls-fan.com +is-a-candidate.org +is-a-caterer.com +is-a-celticsfan.org +is-a-chef.com +is-a-chef.net +is-a-chef.org +is-a-conservative.com +is-a-cpa.com +is-a-cubicle-slave.com +is-a-democrat.com +is-a-designer.com +is-a-doctor.com +is-a-financialadvisor.com +is-a-geek.com +is-a-geek.net +is-a-geek.org +is-a-green.com +is-a-guru.com +is-a-hard-worker.com +is-a-hunter.com +is-a-knight.org +is-a-landscaper.com +is-a-lawyer.com +is-a-liberal.com +is-a-libertarian.com +is-a-linux-user.org +is-a-llama.com +is-a-musician.com +is-a-nascarfan.com +is-a-nurse.com +is-a-painter.com +is-a-patsfan.org +is-a-personaltrainer.com +is-a-photographer.com +is-a-player.com +is-a-republican.com +is-a-rockstar.com +is-a-socialist.com +is-a-soxfan.org +is-a-student.com +is-a-teacher.com +is-a-techie.com +is-a-therapist.com +is-an-accountant.com +is-an-actor.com +is-an-actress.com +is-an-anarchist.com +is-an-artist.com +is-an-engineer.com +is-an-entertainer.com +is-by.us +is-certified.com +is-found.org +is-gone.com +is-into-anime.com +is-into-cars.com +is-into-cartoons.com +is-into-games.com +is-leet.com +is-lost.org +is-not-certified.com +is-saved.org +is-slick.com +is-uberleet.com +is-very-bad.org +is-very-evil.org +is-very-good.org +is-very-nice.org +is-very-sweet.org +is-with-theband.com +isa-geek.com +isa-geek.net +isa-geek.org +isa-hockeynut.com +issmarterthanyou.com +isteingeek.de +istmein.de +kicks-ass.net +kicks-ass.org +knowsitall.info +land-4-sale.us +lebtimnetz.de +leitungsen.de +likes-pie.com +likescandy.com +merseine.nu +mine.nu +misconfused.org +mypets.ws +myphotos.cc +neat-url.com +office-on-the.net +on-the-web.tv +podzone.net +podzone.org +readmyblog.org +saves-the-whales.com +scrapper-site.net +scrapping.cc +selfip.biz +selfip.com +selfip.info +selfip.net +selfip.org +sells-for-less.com +sells-for-u.com +sells-it.net +sellsyourhome.org +servebbs.com +servebbs.net +servebbs.org +serveftp.net +serveftp.org +servegame.org +shacknet.nu +simple-url.com +space-to-rent.com +stuff-4-sale.org +stuff-4-sale.us +teaches-yoga.com +thruhere.net +traeumtgerade.de +webhop.biz +webhop.info +webhop.net +webhop.org +worse-than.tv +writesthisblog.com + +// Google, Inc. +// Requested by Eduardo Vela 2012-10-24 +appspot.com +blogspot.be +blogspot.bj +blogspot.ca +blogspot.cf +blogspot.ch +blogspot.co.at +blogspot.co.il +blogspot.co.nz +blogspot.co.uk +blogspot.com +blogspot.com.ar +blogspot.com.au +blogspot.com.br +blogspot.com.es +blogspot.cv +blogspot.cz +blogspot.de +blogspot.dk +blogspot.fi +blogspot.fr +blogspot.gr +blogspot.hk +blogspot.hu +blogspot.ie +blogspot.in +blogspot.it +blogspot.jp +blogspot.kr +blogspot.mr +blogspot.mx +blogspot.nl +blogspot.no +blogspot.pt +blogspot.re +blogspot.ro +blogspot.se +blogspot.sg +blogspot.sk +blogspot.td +blogspot.tw +codespot.com +googleapis.com +googlecode.com + +// iki.fi +// Requested by Hannu Aronsson 2009-11-05 +iki.fi + +// info.at : http://www.info.at/ +biz.at +info.at + +// Michau Enterprises Limited : http://www.co.pl/ +co.pl + +// NYC.mn : http://www.information.nyc.mn +// Requested by Matthew Brown 2013-03-11 +nyc.mn + +// Opera Software, A.S.A. +// Requested by Yngve Pettersen 2009-11-26 +operaunite.com + +// Red Hat, Inc. OpenShift : https://openshift.redhat.com/ +// Requested by Tim Kramer 2012-10-24 +rhcloud.com + +// priv.at : http://www.nic.priv.at/ +// Requested by registry 2008-06-09 +priv.at + +// ZaNiC : http://www.za.net/ +// Requested by registry 2009-10-03 +za.net +za.org + +// ===END PRIVATE DOMAINS=== diff --git a/t/plugin_tests/dmarc b/t/plugin_tests/dmarc new file mode 100644 index 0000000..14cc73e --- /dev/null +++ b/t/plugin_tests/dmarc @@ -0,0 +1,68 @@ +#!perl -w + +use strict; +use Data::Dumper; +use POSIX qw(strftime); + +use Qpsmtpd::Address; +use Qpsmtpd::Constants; + +my $test_email = 'matt@tnpi.net'; + +sub register_tests { + my $self = shift; + + $self->register_test('test_get_organizational_domain', 2); + $self->register_test("test_fetch_dmarc_record", 3); + $self->register_test("test_discover_policy", 3); +} + +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 " ); + + $self->qp->connection->relay_client(0); +}; + +sub test_fetch_dmarc_record { + my $self = shift; + + foreach ( qw/ tnpi.net nictool.com / ) { + my @matches = $self->fetch_dmarc_record($_); +#warn Data::Dumper::Dumper(\@matches); + cmp_ok( scalar @matches, '==', 1, 'fetch_dmarc_record'); + }; + foreach ( qw/ example.com / ) { + my @matches = $self->fetch_dmarc_record($_); + cmp_ok( scalar @matches, '==', 0, 'fetch_dmarc_record'); + }; +}; + +sub test_get_organizational_domain { + my $self = shift; + + $self->setup_test_headers(); + my $transaction = $self->qp->transaction; + + cmp_ok( $self->get_organizational_domain('test.www.tnpi.net'), 'eq', 'tnpi.net' ); + cmp_ok( $self->get_organizational_domain('www.example.co.uk'), 'eq', 'example.co.uk' ) +}; + +sub test_discover_policy { + my $self = shift; + + $self->setup_test_headers(); + my $transaction = $self->qp->transaction; + + ok( $self->discover_policy( $transaction ), 'discover_policy' ); +}; From bd3b0de882352e0ac47a6a2bd1f6d3d325688b02 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 20 Apr 2013 17:53:03 -0400 Subject: [PATCH 245/352] fix dmarc plugin tests --- t/config/plugins | 1 + t/plugin_tests/dmarc | 5 ++--- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/t/config/plugins b/t/config/plugins index 0c3ea77..7e7ce5b 100644 --- a/t/config/plugins +++ b/t/config/plugins @@ -59,6 +59,7 @@ rcpt_ok headers days 5 reject_type temp require From,Date domainkeys dkim +dmarc # content filters virus/klez_filter diff --git a/t/plugin_tests/dmarc b/t/plugin_tests/dmarc index 14cc73e..4c8ef1c 100644 --- a/t/plugin_tests/dmarc +++ b/t/plugin_tests/dmarc @@ -14,7 +14,7 @@ sub register_tests { $self->register_test('test_get_organizational_domain', 2); $self->register_test("test_fetch_dmarc_record", 3); - $self->register_test("test_discover_policy", 3); + $self->register_test("test_discover_policy", 1); } sub setup_test_headers { @@ -62,7 +62,6 @@ sub test_discover_policy { my $self = shift; $self->setup_test_headers(); - my $transaction = $self->qp->transaction; - ok( $self->discover_policy( $transaction ), 'discover_policy' ); + ok( $self->discover_policy( 'tnpi.net' ), 'discover_policy' ); }; From 322bd634acb113efe2da6fa0775f0bf666b95c35 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 20 Apr 2013 17:53:24 -0400 Subject: [PATCH 246/352] MANIFEST: bring up-to-date --- MANIFEST | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/MANIFEST b/MANIFEST index 4de05e0..55b4ef9 100644 --- a/MANIFEST +++ b/MANIFEST @@ -4,6 +4,7 @@ Changes config.sample/badhelo config.sample/badmailfrom config.sample/badrcptto +config.sample/dkim/dkim_key_gen.sh config.sample/dnsbl_allow config.sample/dnsbl_zones config.sample/flat_auth_pw @@ -13,6 +14,7 @@ config.sample/logging config.sample/loglevel config.sample/norelayclients config.sample/plugins +config.sample/public_suffix_list config.sample/rcpthosts config.sample/relayclients config.sample/rhsbl_zones @@ -86,12 +88,14 @@ plugins/connection_time plugins/content_log plugins/count_unrecognized_commands plugins/dkim +plugins/dmarc plugins/dns_whitelist_soft plugins/dnsbl plugins/domainkeys plugins/dont_require_anglebrackets plugins/dspam plugins/earlytalker +plugins/fcrdns plugins/greylisting plugins/headers plugins/helo @@ -153,8 +157,6 @@ README README.plugins run STATUS -t/01-syntax.t -t/02-pod.t t/addresses.t t/auth.t t/config.t @@ -166,6 +168,7 @@ t/config/flat_auth_pw t/config/invalid_resolvable_fromhost t/config/norelayclients t/config/plugins +t/config/public_suffix_list t/config/rcpthosts t/config/relayclients t/helo.t @@ -182,6 +185,7 @@ t/plugin_tests/badmailfrom t/plugin_tests/badmailfromto t/plugin_tests/badrcptto t/plugin_tests/count_unrecognized_commands +t/plugin_tests/dmarc t/plugin_tests/dnsbl t/plugin_tests/dspam t/plugin_tests/earlytalker @@ -202,3 +206,5 @@ t/tempstuff.t t/Test/Qpsmtpd.pm t/Test/Qpsmtpd/Plugin.pm UPGRADING +xt/01-syntax.t +xt/02-pod.t From 6511406915e311775b0f2b98d673bc8790e5ec36 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 20 Apr 2013 17:58:49 -0400 Subject: [PATCH 247/352] added MYMETA.* to MANIFEST.SKIP these are added new newer versions of ExtUtils::MakeMaker --- MANIFEST.SKIP | 1 + 1 file changed, 1 insertion(+) diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP index 6369d37..6cbde86 100644 --- a/MANIFEST.SKIP +++ b/MANIFEST.SKIP @@ -21,6 +21,7 @@ output/.* ^pm_to_blib$ ~$ ^MANIFEST\.bak +^MYMETA\. ^tv\.log$ ^MakeMaker-\d \#$ From 0a9f6a5d2fa9e859948876968ad2052a9b96b30d Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 20 Apr 2013 20:11:03 -0400 Subject: [PATCH 248/352] naughty: improve POD --- plugins/naughty | 60 +++++++++++++++++-------------------------------- 1 file changed, 20 insertions(+), 40 deletions(-) diff --git a/plugins/naughty b/plugins/naughty index 491bb8a..b1f4441 100644 --- a/plugins/naughty +++ b/plugins/naughty @@ -4,67 +4,47 @@ naughty - dispose of naughty connections +=head1 SYNOPSIS + +Rather than immediately terminating naughty connections, plugins can flag the connection and dispose of it later. Examples are B, B, B, B, B, and B. + =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. +Historically, deferred rejection was based on the belief that malware will retry less if we disconnect after RCPT. Observations in 2012 suggest it makes no measurable difference when we disconnect. -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 early will block connections from your users who are roaming, or whose IP space is voluntarily listed by their ISP. Deferring rejection until after the remote has had the ability to authenticate allows RBLs to be safely used on port 25 and 587. -Disconnecting later is inefficient because other plugins continue to do their -work, oblivious to the fact that a connection is destined for the bit bucket. +Some (much older) RFCs suggest deferring later. + +For these and other reasons, a few plugins implemented deferred rejection on their own. By having naughty, other plugins can be much simpler. =head1 DESCRIPTION Naughty provides the following: +=head2 consistency + +With one change to the config of naughty, all plugins can reject their messages at the preferred time. I use this feature for spam filter training. When setting up a new server, I use 'naughty reject data_post' until after dspam is trained. Once the bayesian filters are trained, I change to 'naughty reject data', and avoid processing the message bodies. + =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. +After a connection is marked as naughty, subsequent plugins can detect that and skip processing. Plugins like SpamAssassin and DSPAM can benefit from using naughty connections to train their filters. -Since many connections are from blacklisted IPs, naughty significantly -reduces the resources required to dispose 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. - -For training spam filters, I is best. +Since many connections are from blacklisted IPs, naughty significantly reduces the resources required to dispose 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 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. +Rather than having plugins split processing across hooks, plugins 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. +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. Note that if I is set, connections will -not get the chance to authenticate. To allow clients a chance to authenticate, -I works well. +When a user authenticates, the naughty flag on their connection is cleared. This allows users to send email from IPs that fail connection tests such as B. Note that if I is set, connections will not get the chance to authenticate. To allow clients a chance to authenticate, I works well. -=head2 naughty +=head1 HOW TO USE - 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. +Set the connection note I to the message you wish to send the naughty sender during rejection. $self->connection->notes('naughty', $message); From 4393f02aa4c6b2815bc3f12e04a0e7042bd2c1c9 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 20 Apr 2013 20:11:48 -0400 Subject: [PATCH 249/352] Changes: add changes since 0.91 --- Changes | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/Changes b/Changes index d77e22f..74b91e2 100644 --- a/Changes +++ b/Changes @@ -1,4 +1,32 @@ +0.92 Apr 20, 2013 + + new plugins: dmarc, fcrdns + + new feature: DKIM message signing. See 'perldoc plugins/dkim' for details. + includes script for generating DKIM selectors, keys, and DNS records + + tls: added ability to store SSL keys in config/ssl + + log2sql: added UPDATE query support + + removed FAQ to: https://github.com/qpsmtpd-dev/qpsmtpd-dev/wiki/faq + + helo: cease processing DNS records after first positive match + + karma: sprinkled karma awards throughout other plugins + - limit poor karma hosts to 1 concurrent connection + - allow +3 conncurrent connections to hosts with good karma + + Sanitize spamd_sock path for perl taint mode - Markus Ullmann + + geo_ip: added too_far option (deduct karma from distant senders) + + bogus_bounce: add Return-Path check, per RFC 3834 + + Fix for Net::DNS break - Markus Ullmann + + 0.91 Nov 20, 2012 a handful of minor changes to log messages, similar to v0.90 From 268cd1137ca473beb856219c4874f1410bedb73a Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 20 Apr 2013 20:12:21 -0400 Subject: [PATCH 250/352] STATUS: removed links to dead Google Code, add links to github project page, and goals of qpsmtpd-dev --- STATUS | 36 +++++++++++++++++++++--------------- 1 file changed, 21 insertions(+), 15 deletions(-) diff --git a/STATUS b/STATUS index 78ef005..50407ad 100644 --- a/STATUS +++ b/STATUS @@ -1,16 +1,30 @@ -New Name Suggestions -==================== -ignite -flare(mta) -quench -pez (or pezmail) +Qpsmtpd-dev is a fork of Qpsmtpd. Qpsmtpd is a very good SMTP daemon for +developers and hackers (admittedly, its focus). It is difficult to install +and administer for the typical sysadmin/user. + +The primary focus of the -dev branch is improving the consistency and +behavior of the plugins. After using one plugin, the knowledge gained +should carry over to other plugins. + +Secondary goals are reducing code duplication and complexity. Anything +covered in Perl Best Practices is also fair game. + +So far, the main changes between the release and dev branches have focused +on these goals: + + - plugins emit a single entry summarizing their disposition + - plugin logs prefixed with keywords: pass, fail, skip, error + - plugins use 'reject' and 'reject_type' settings. + - plugins support deferred rejection via 'naughty' plugin + - plugins get a resolver via $self->init_resolver + Roadmap ======= - - http://code.google.com/p/smtpd/issues + - https://github.com/qpsmtpd-dev/qpsmtpd-dev/issues - Bugfixes - qpsmtpd is extremely stable (in production since 2001), but there are always more things to fix. @@ -24,17 +38,9 @@ Roadmap 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 From a0dba4774164d0c5ea1d55aae4c8fa9c21e3b06d Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 20 Apr 2013 20:14:07 -0400 Subject: [PATCH 251/352] dmarc: remove useless comment --- plugins/dmarc | 2 -- 1 file changed, 2 deletions(-) diff --git a/plugins/dmarc b/plugins/dmarc index a664e72..c74776b 100644 --- a/plugins/dmarc +++ b/plugins/dmarc @@ -102,8 +102,6 @@ use warnings; use Qpsmtpd::Constants; -#use Socket qw(:DEFAULT :crlf); - sub init { my ($self, $qp) = (shift, shift); $self->{_args} = { @_ }; From f573a3010566c5f53e8f88bcbf46a55a8e29b474 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 20 Apr 2013 20:31:13 -0400 Subject: [PATCH 252/352] summarize: add match for bareword 'fail' --- log/summarize | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/log/summarize b/log/summarize index 208707b..cca2651 100755 --- a/log/summarize +++ b/log/summarize @@ -277,9 +277,10 @@ sub print_auto_format { sub show_symbol { my $mess = shift; return ' o' if $mess eq 'TLS setup returning'; - return ' -' if $mess eq 'skip'; - return ' -' if $mess =~ /^skip[,:\s]/i; return ' o' if $mess eq 'pass'; + return ' -' if $mess eq 'skip'; + return ' X' if $mess eq 'fail'; + return ' -' if $mess =~ /^skip[,:\s]/i; return ' o' if $mess =~ /^pass[,:\s]/i; return ' X' if $mess =~ /^fail[,:\s]/i; return ' x' if $mess =~ /^negative[,:\s]/i; From 4034f1281d366faa468d4855cd1cd40ed885f3df Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 20 Apr 2013 20:33:52 -0400 Subject: [PATCH 253/352] registry: renumber with big spaces between plugin types. So there's plenty of room to insert future plugins with having to renumber, which impacts log2sql --- plugins/registry.txt | 131 +++++++++++++++++++++++-------------------- 1 file changed, 69 insertions(+), 62 deletions(-) diff --git a/plugins/registry.txt b/plugins/registry.txt index f59a962..f02709c 100644 --- a/plugins/registry.txt +++ b/plugins/registry.txt @@ -4,81 +4,88 @@ # #id name abb3 abb5 aliases # -1 hosts_allow alw allow -2 ident::geoip geo geoip -3 ident::p0f p0f p0f -5 karma krm karma -6 dnsbl dbl dnsbl -7 relay rly relay check_relay,check_norelay,relay_only -8 fcrdns dns fcrdn -9 earlytalker ear early check_earlytalker -15 helo hlo helo check_spamhelo -16 tls tls tls -20 dont_require_anglebrackets rab drabs -21 unrecognized_commands cmd uncmd count_unrecognized_commands -22 noop nop noop noop_counter -23 random_error rnd rande -24 milter mlt mlter -25 content_log log colog +201 hosts_allow alw allow +202 ident::geoip geo geoip +203 ident::p0f p0f p0f +204 ident::p0f_3a0 p0f p0f +205 karma krm karma +206 dnsbl dbl dnsbl +207 relay rly relay check_relay,check_norelay,relay_only +208 fcrdns dns fcrdn + +300 earlytalker ear early check_earlytalker +301 helo hlo helo check_spamhelo +302 tls tls tls + +320 dont_require_anglebrackets rab drabs +321 unrecognized_commands cmd uncmd count_unrecognized_commands +322 noop nop noop noop_counter +323 random_error rnd rande +324 milter mlt mlter +325 content_log log colog # # Authentication # -30 auth::auth_vpopmail_sql aut vpsql -31 auth::auth_vpopmaild vpd vpopd -32 auth::auth_vpopmail vpo vpop -33 auth::auth_checkpasswd ckp chkpw -34 auth::auth_cvs_unix_local cvs cvsul -35 auth::auth_flat_file flt aflat -36 auth::auth_ldap_bind ldp aldap -37 auth::authdeny dny adeny +400 auth::auth_vpopmail_sql aut vpsql +401 auth::auth_vpopmaild vpd vpopd +402 auth::auth_vpopmail vpo vpop +403 auth::auth_checkpasswd ckp chkpw +404 auth::auth_cvs_unix_local cvs cvsul +405 auth::auth_flat_file flt aflat +406 auth::auth_ldap_bind ldp aldap +407 auth::authdeny dny adeny # -# Sender / From +# Sender / Envelope From # -40 badmailfrom bmf badmf check_badmailfrom,check_badmailfrom_patterns -41 badmailfromto bmt bfrto -42 rhsbl rbl rhsbl -44 resolvable_fromhost rfh rsvfh require_resolvable_fromhost -45 sender_permitted_from spf spf +500 badmailfrom bmf badmf check_badmailfrom,check_badmailfrom_patterns +501 badmailfromto bmt bfrto +502 rhsbl rbl rhsbl +504 resolvable_fromhost rfh rsvfh require_resolvable_fromhost +505 sender_permitted_from spf spf # -# Recipient +# Recipient / Envelope To # -50 badrcptto bto badto check_badrcptto,check_badrcptto_patterns -51 rcpt_map rmp rcmap -52 rcpt_regex rcx rcrex -53 qmail_deliverable qmd qmd -55 rcpt_ok rok rcpok -58 bogus_bounce bog bogus check_bogus_bounce -59 greylisting gry greyl +600 badrcptto bto badto check_badrcptto,check_badrcptto_patterns +601 rcpt_map rmp rcmap +602 rcpt_regex rcx rcrex +603 qmail_deliverable qmd qmd +605 rcpt_ok rok rcpok +608 bogus_bounce bog bogus check_bogus_bounce +609 greylisting gry greyl # # Content Filters # -60 headers hdr headr check_basicheaders -61 loop lop loop -62 uribl uri uribl -63 domainkeys dky dkey -64 dkim dkm dkim -65 spamassassin spm spama -66 dspam dsp dspam -67 dmarc dmc dmarc +700 headers hdr headr check_basicheaders +701 loop lop loop +702 uribl uri uribl + +710 domainkeys dky dkey +711 dkim dkm dkim +712 dmarc dmc dmarc + +720 spamassassin spm spama +721 dspam dsp dspam # # Anti-Virus Plugins # -70 virus::aveclient ave avirs -71 virus::bitdefender bit bitdf -72 virus::clamav cav clamv -73 virus::clamdscan clm clamd -74 virus::hbedv hbv hbedv -75 virus::kavscanner kav kavsc -76 virus::klez_filter klz vklez -77 virus::sophie sop sophe -78 virus::uvscan uvs uvscn +770 virus::aveclient ave avirs +771 virus::bitdefender bit bitdf +772 virus::clamav cav clamv +773 virus::clamdscan clm clamd +774 virus::hbedv hbv hbedv +775 virus::kavscanner kav kavsc +776 virus::klez_filter klz vklez +777 virus::sophie sop sophe +778 virus::uvscan uvs uvscn # # Queue Plugins # -80 queue::qmail-queue qqm queue -81 queue::maildir qdr qudir -82 queue::postfix-queue qpf qupfx -83 queue::smtp-forward qfw qufwd -84 queue::exim-bsmtp qxm qexim -98 quit_fortune for fortu -99 connection_time tim time +800 queue::qmail-queue qqm queue +801 queue::maildir qdr qudir +802 queue::postfix-queue qpf qupfx +803 queue::smtp-forward qfw qufwd +804 queue::exim-bsmtp qxm qexim + +900 quit_fortune for fortu + +999 connection_time tim time From 7152a8c4d452a7f66d659032242f07e52667ee64 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 20 Apr 2013 23:47:53 -0400 Subject: [PATCH 254/352] STATUS: explain qpdev motivation and direction --- STATUS | 23 +++++++++++++++++------ 1 file changed, 17 insertions(+), 6 deletions(-) diff --git a/STATUS b/STATUS index 50407ad..98050a6 100644 --- a/STATUS +++ b/STATUS @@ -1,24 +1,35 @@ Qpsmtpd-dev is a fork of Qpsmtpd. Qpsmtpd is a very good SMTP daemon for -developers and hackers (admittedly, its focus). It is difficult to install -and administer for the typical sysadmin/user. +developers and hackers (admittedly, its focus). The plugin system is great +but the plugin organization, documentation, and consistency left much +to be desired. The primary focus of the -dev branch is improving the consistency and behavior of the plugins. After using one plugin, the knowledge gained should carry over to other plugins. -Secondary goals are reducing code duplication and complexity. Anything -covered in Perl Best Practices is also fair game. +Secondary goals are making it easier to install, reducing code duplication, +reducing complexity, and cooperation between plugins. Anything covered +in Perl Best Practices is also fair game. So far, the main changes between the release and dev branches have focused on these goals: - - plugins emit a single entry summarizing their disposition + - plugins log a single entry summarizing their disposition - plugin logs prefixed with keywords: pass, fail, skip, error - - plugins use 'reject' and 'reject_type' settings. + - plugins use 'reject' and 'reject_type' settings - plugins support deferred rejection via 'naughty' plugin - plugins get a resolver via $self->init_resolver + - new plugins: fcrdns, dmarc, naughty, karma +An example of plugin cooperation is karma. Karma is a scorekeeper that aggregates bits of information from many plugins. Those bits alone are insufficient for acting on. Examples of such data are: + + FcRDNS - whether or not hostname has Forward confirmed reverse DNS + GeoIP distance - how many km away the sender is + p0f - senders Operating System + helo - helo hostname validity + +For most sites, even DNSBL, SPF, DKIM, and SpamAssassin tests alone are insufficient rejection criteria. But when these bits are combined, they can create an extremely reliable means to block spam. Roadmap From 1cd1486d3710190538fa0732740d384b9f08f1e1 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 20 Apr 2013 23:48:24 -0400 Subject: [PATCH 255/352] hosts_allow: more succinct log message --- plugins/hosts_allow | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/hosts_allow b/plugins/hosts_allow index 2e3be5f..1ea62df 100644 --- a/plugins/hosts_allow +++ b/plugins/hosts_allow @@ -120,11 +120,11 @@ sub karma_bump { my ($self, $karma, $max) = @_; if ( $karma > 5 ) { - $self->log(LOGDEBUG, "increasing max connects for positive karma"); + $self->log(LOGDEBUG, "connect limit +3 for positive karma"); return $max + 3; }; if ( $karma <= 0 ) { - $self->log(LOGINFO, "limiting max connects to 1 (karma $karma)"); + $self->log(LOGINFO, "connect limit 1, karma $karma"); return 1; }; return $max; From 5881f2a662ee790e497c96254d49d1f73cbf745c Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 20 Apr 2013 23:53:27 -0400 Subject: [PATCH 256/352] karma: add recipient limits for bad senders --- plugins/karma | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/plugins/karma b/plugins/karma index ae1bead..f83a679 100644 --- a/plugins/karma +++ b/plugins/karma @@ -24,9 +24,9 @@ custom connection policies such as these two examples: =over 4 -Hi there, well behaved sender. Please help yourself to greater concurrency, multiple recipients, no delays, and other privileges. +Hi there, well known and well behaved sender. Please help yourself to greater concurrency (hosts_allow), multiple recipients (karma), and no delays (early_sender). -Hi there, naughty sender. You get a max concurrency of 1, and SMTP delays. +Hi there, naughty sender. You get a max concurrency of 1, max recipients of 2, and SMTP delays. =back @@ -245,6 +245,7 @@ sub register { $self->register_hook('connect', 'connect_handler'); $self->register_hook('data', 'data_handler' ); $self->register_hook('disconnect', 'disconnect_handler'); + $self->register_hook('received_line', 'rcpt_handler'); } sub hook_pre_connection { @@ -317,6 +318,19 @@ sub connect_handler { return $self->get_reject( $mess, $karma ); } +sub rcpt_handler { + my ($self, $transaction, $recipient, %args) = @_; + + my $recipients = scalar $self->transaction->recipients; + return DECLINED if $recipients < 2; # only one recipient + + my $karma = $self->connection->notes('karma_history'); + return DECLINED if $karma > 0; # good karma, no limit + +# limit # of recipients if host has negative or unknown karma + return $self->get_reject( "too many recipients"); +}; + sub data_handler { my ($self, $transaction) = @_; return DECLINED if ! $self->qp->connection->relay_client; From 8536a9937901bdad5668d99cf24961655f06c83e Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sat, 20 Apr 2013 23:54:17 -0400 Subject: [PATCH 257/352] resolvable_fromhost: adjust log message prefix --- plugins/resolvable_fromhost | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/resolvable_fromhost b/plugins/resolvable_fromhost index 12bd333..6d4ed0a 100644 --- a/plugins/resolvable_fromhost +++ b/plugins/resolvable_fromhost @@ -111,10 +111,10 @@ sub hook_mail { my $result = $transaction->notes('resolvable_fromhost') or do { if ( $self->{_args}{reject} ) {; - $self->log(LOGINFO, 'error, missing result' ); + $self->log(LOGINFO, 'fail, missing result' ); return Qpsmtpd::DSN->temp_resolver_failed( $self->get_reject_type(), '' ); }; - $self->log(LOGINFO, 'error, missing result, reject disabled' ); + $self->log(LOGINFO, 'fail, missing result, reject disabled' ); return DECLINED; }; From 73c988ac05e9ec520d6c1d38224cfe25cc005442 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sun, 21 Apr 2013 00:08:43 -0400 Subject: [PATCH 258/352] find . -name '*.pm' -exec perltidy -b {} \; --- lib/Apache/Qpsmtpd.pm | 96 +-- lib/Danga/Client.pm | 88 ++- lib/Danga/TimeoutSocket.pm | 16 +- lib/Qpsmtpd.pm | 850 +++++++++++---------- lib/Qpsmtpd/Address.pm | 116 +-- lib/Qpsmtpd/Auth.pm | 204 ++--- lib/Qpsmtpd/Command.pm | 40 +- lib/Qpsmtpd/ConfigServer.pm | 176 +++-- lib/Qpsmtpd/Connection.pm | 139 ++-- lib/Qpsmtpd/Constants.pm | 74 +- lib/Qpsmtpd/DSN.pm | 234 +++--- lib/Qpsmtpd/Plugin.pm | 298 ++++---- lib/Qpsmtpd/PollServer.pm | 224 +++--- lib/Qpsmtpd/Postfix.pm | 275 +++---- lib/Qpsmtpd/Postfix/Constants.pm | 129 ++-- lib/Qpsmtpd/SMTP.pm | 1197 ++++++++++++++++-------------- lib/Qpsmtpd/SMTP/Prefork.pm | 39 +- lib/Qpsmtpd/TcpServer.pm | 205 ++--- lib/Qpsmtpd/TcpServer/Prefork.pm | 96 +-- lib/Qpsmtpd/Transaction.pm | 294 ++++---- lib/Qpsmtpd/Utils.pm | 1 - t/Test/Qpsmtpd.pm | 67 +- t/Test/Qpsmtpd/Plugin.pm | 61 +- 23 files changed, 2602 insertions(+), 2317 deletions(-) diff --git a/lib/Apache/Qpsmtpd.pm b/lib/Apache/Qpsmtpd.pm index d85d608..9ad82ef 100644 --- a/lib/Apache/Qpsmtpd.pm +++ b/lib/Apache/Qpsmtpd.pm @@ -7,13 +7,13 @@ 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 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 (); +use ModPerl::Util (); our $VERSION = '0.02'; @@ -22,15 +22,15 @@ sub handler { $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, - ); - + ip => $c->remote_ip, + host => $c->remote_host, + info => undef, + conn => $c, + ); + $qpsmtpd->run($c); $qpsmtpd->run_hooks("post-connection"); $qpsmtpd->connection->reset; @@ -46,20 +46,21 @@ use base qw(Qpsmtpd::SMTP); my %cdir_memo; sub config_dir { - my ($self, $config) = @_; - if (exists $cdir_memo{$config}) { - return $cdir_memo{$config}; - } + 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}; + 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 { @@ -67,23 +68,26 @@ sub start_connection { 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); + $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_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, - @_ - ); + remote_info => $remote_info, + remote_ip => $remote_ip, + remote_host => $remote_host, + local_ip => $opts{conn}->local_ip, + @_ + ); } sub config { @@ -117,31 +121,32 @@ sub getline { return if $c->aborted; my $bb = $self->{bb_in}; - + while (1) { - my $rc = $c->input_filters->get_brigade($bb, Apache2::Const::MODE_GETLINE); + 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}; + my $c = $self->{conn}; while (defined(my $data = $self->getline)) { - $data =~ s/\r?\n$//s; # advanced chomp + $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'"); + or $self->respond(502, "command unrecognized: '$data'"); last if $self->{_quitting}; } } @@ -151,11 +156,12 @@ sub respond { my $c = $self->{conn}; while (my $msg = shift @messages) { my $bb = $self->{bb_out}; - my $line = $code . (@messages?"-":" ").$msg; + 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; } diff --git a/lib/Danga/Client.pm b/lib/Danga/Client.pm index 25fe6dd..1e10499 100644 --- a/lib/Danga/Client.pm +++ b/lib/Danga/Client.pm @@ -3,26 +3,26 @@ package Danga::Client; use base 'Danga::TimeoutSocket'; use fields qw( - line - pause_count - read_bytes - data_bytes - callback - get_chunks - reader_object - ); + 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 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->SUPER::new(@_); $self->reset_for_next_message; return $self; @@ -30,13 +30,13 @@ sub new { sub reset_for_next_message { my Danga::Client $self = shift; - $self->{line} = ''; - $self->{pause_count} = 0; - $self->{read_bytes} = 0; - $self->{callback} = undef; + $self->{line} = ''; + $self->{pause_count} = 0; + $self->{read_bytes} = 0; + $self->{callback} = undef; $self->{reader_object} = undef; - $self->{data_bytes} = ''; - $self->{get_chunks} = 0; + $self->{data_bytes} = ''; + $self->{get_chunks} = 0; return $self; } @@ -52,10 +52,12 @@ sub get_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 + $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; @@ -91,14 +93,14 @@ sub get_chunks { } $self->{read_bytes} = $bytes; $self->process_chunk($callback) if length($self->{line}); - $self->{callback} = $callback; + $self->{callback} = $callback; $self->{get_chunks} = 1; } sub end_get_chunks { my Danga::Client $self = shift; my $remaining = shift; - $self->{callback} = undef; + $self->{callback} = undef; $self->{get_chunks} = 0; if (defined($remaining)) { $self->process_read_buf(\$remaining); @@ -132,6 +134,7 @@ sub event_read { $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; @@ -150,21 +153,29 @@ sub process_read_buf { 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) } + 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 + $self->AddTimer( + 0, + sub { + if (length($self->{line}) && !$self->paused) { + $self->process_read_buf(\"") + ; # " for bad syntax highlighters + } } - }); + ); } } @@ -188,6 +199,7 @@ sub paused { sub pause_read { my Danga::Client $self = shift; $self->{pause_count}++; + # $self->watch_read(0); } @@ -196,11 +208,15 @@ sub continue_read { $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 + $self->AddTimer( + 0, + sub { + if (length($self->{line}) && !$self->paused) { + $self->process_read_buf(\"") + ; # " for bad syntax highlighters + } } - }); + ); } } @@ -216,6 +232,10 @@ sub close { } sub event_err { my Danga::Client $self = shift; $self->close("Error") } -sub event_hup { my Danga::Client $self = shift; $self->close("Disconnect (HUP)") } + +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 index c15aab6..030514d 100644 --- a/lib/Danga/TimeoutSocket.pm +++ b/lib/Danga/TimeoutSocket.pm @@ -22,8 +22,8 @@ sub new { } # overload these in a subclass -sub max_idle_time { 0 } -sub max_connect_time { 0 } +sub max_idle_time { 0 } +sub max_connect_time { 0 } sub Reset { Danga::Socket->Reset; @@ -32,21 +32,21 @@ sub Reset { 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 %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; + $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) { diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index 6d7bc12..ec7c0ef 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -19,9 +19,9 @@ if (-e ".git") { my $hooks = {}; my %defaults = ( - me => hostname, - timeout => 1200, - ); + me => hostname, + timeout => 1200, + ); my $_config_cache = {}; my %config_dir_memo; @@ -30,111 +30,115 @@ my %config_dir_memo; 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; - } + 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 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" ); - } + # 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'); - my @loaded; - for my $logger (@loggers) { - push @loaded, $self->_load_plugin($logger, @plugin_dirs); - } + $configdir = $self->config_dir('plugin_dirs'); + $configfile = "$configdir/plugin_dirs"; + my @plugin_dirs = $self->_config_from_file($configfile, 'plugin_dirs'); + unless (@plugin_dirs) { + my ($name) = ($0 =~ m!(.*?)/([^/]+)$!); + @plugin_dirs = ("$name/plugins"); + } - foreach my $logger (@loaded) { - $self->log(LOGINFO, "Loaded $logger"); - } + my @loaded; + for my $logger (@loggers) { + push @loaded, $self->_load_plugin($logger, @plugin_dirs); + } - $configdir = $self->config_dir("loglevel"); - $configfile = "$configdir/loglevel"; - $TraceLevel = $self->_config_from_file($configfile,'loglevel'); + foreach my $logger (@loaded) { + $self->log(LOGINFO, "Loaded $logger"); + } - unless (defined($TraceLevel) and $TraceLevel =~ /^\d+$/) { - $TraceLevel = LOGWARN; # Default if no loglevel file found. - } + $configdir = $self->config_dir("loglevel"); + $configfile = "$configdir/loglevel"; + $TraceLevel = $self->_config_from_file($configfile, 'loglevel'); - $LOGGING_LOADED = 1; + unless (defined($TraceLevel) and $TraceLevel =~ /^\d+$/) { + $TraceLevel = LOGWARN; # Default if no loglevel file found. + } - return @loggers; + $LOGGING_LOADED = 1; + + return @loggers; } sub trace_level { - my $self = shift; - return $TraceLevel; + my $self = shift; + return $TraceLevel; } -sub init_logger { # needed for compatibility purposes - shift->trace_level(); +sub init_logger { # needed for compatibility purposes + shift->trace_level(); } sub log { - my ($self, $trace, @log) = @_; - $self->varlog($trace,join(" ",@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) = @_; - } + 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 + $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; + my ($rc) = + $self->run_hooks_no_respond("logging", $trace, $hook, $plugin, @log) + or return; - return if $rc == DECLINED || $rc == OK; # plugin success + 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:" : ''; + my $prefix = + defined $plugin && defined $hook ? " ($hook) $plugin:" + : defined $plugin ? " $plugin:" + : defined $hook ? " ($hook) running plugin:" + : ''; warn join(' ', $$ . $prefix, @log), "\n"; } @@ -149,280 +153,301 @@ sub clear_config_cache { # database or whatever. # sub config { - my ($self, $c, $type) = @_; + my ($self, $c, $type) = @_; - $self->log(LOGDEBUG, "in config($c)"); + $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]; - } + # 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]; - } + # 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]; - } + # 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; + # 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; + 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 $self = shift; my @plugin_dirs = $self->config('plugin_dirs'); unless (@plugin_dirs) { my ($path) = ($ENV{PROCESS} ? $ENV{PROCESS} : $0) =~ m!(.*?)/([^/]+)$!; - @plugin_dirs = ( "$path/plugins" ); + @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 ($self, $config, $type) = @_; + $self->log(LOGDEBUG, "trying to get config for $config"); + my $configdir = $self->config_dir($config); - my $configfile = "$configdir/$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 }; + # 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 +{}; + 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; } - 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); + 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++; + my ($self, $configfile, $config, $visited) = @_; + unless (-e $configfile) { + $_config_cache->{$config} ||= []; + return; } - } - $_config_cache->{$config} = \@config; + $visited ||= []; + push @{$visited}, $configfile; - return wantarray ? @config : $config[0]; + 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; + my $self = shift; + my $inclusion = shift; + my $context = shift; + my @includes; - if (-d $inclusion) { - $self->log(LOGDEBUG, "inclusion of directory $inclusion from $context"); + 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 ($!)"); + 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; + else { + $self->log(LOGDEBUG, "inclusion of file $inclusion from $context"); + @includes = ($inclusion); + } + return @includes; } - sub load_plugins { - my $self = shift; + my $self = shift; - my @plugins = $self->config('plugins'); - my @loaded; + my @plugins = $self->config('plugins'); + my @loaded; - if ($hooks->{queue}) { - #$self->log(LOGWARN, "Plugins already loaded"); - return @plugins; - } + if ($hooks->{queue}) { - for my $plugin_line (@plugins) { - my $this_plugin = $self->_load_plugin($plugin_line, $self->plugin_dirs); - push @loaded, $this_plugin if $this_plugin; - } + #$self->log(LOGWARN, "Plugins already loaded"); + return @plugins; + } - return @loaded; + 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 $self = shift; + my ($plugin_line, @plugin_dirs) = @_; - my ($plugin, @args) = split / /, $plugin_line; + my ($plugin, @args) = split / /, $plugin_line; - my $package; + 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 + if ($plugin =~ m/::/) { - # Escape everything into valid perl identifiers - $plugin_name =~ s/([^A-Za-z0-9_\/])/sprintf("_%2x",unpack("C",$1))/eg; + # "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 - # second pass cares for slashes and words starting with a digit - $plugin_name =~ s{ + # 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"; + $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; + # 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"}; } - } - 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); + my $plug = $package->new(); + $plug->_register($self, @args); - return $plug; + return $plug; } -sub transaction { return {}; } # base class implements empty transaction +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, ''], [@_]); + 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 { @@ -431,7 +456,9 @@ sub run_hooks_no_respond { my @r; for my $code (@{$hooks->{$hook}}) { eval { (@r) = $code->{code}->($self, $self->transaction, @_); }; - $@ and warn("FATAL PLUGIN ERROR [" . $code->{name} . "]: ", $@) and next; + $@ + and warn("FATAL PLUGIN ERROR [" . $code->{name} . "]: ", $@) + and next; if ($r[0] == YIELD) { die "YIELD not valid from $hook hook"; } @@ -443,125 +470,151 @@ sub run_hooks_no_respond { return (0, ''); } -sub continue_read {} # subclassed in -async +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; + my $self = shift; - !defined $r[0] - and $self->log(LOGERROR, "plugin ".$code->{name} - ." running the $hook hook returned undef!") - and next; + #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; - # 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"); - } + while (@$todo) { + my $code = shift @$todo; - 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"); - } + #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; - 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); + !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 ($self, $hook, $msg, $args) = @_; - #my $t1 = $SAMPLER->("hook_responder", undef, 1); - my $code = shift @$msg; + #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; + 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) = @_; + my $self = shift; + my ($hook, $code, $unshift) = @_; - if ($unshift) { - unshift @{$hooks->{$hook}}, $code; - } - else { - push @{$hooks->{$hook}}, $code; - } + if ($unshift) { + unshift @{$hooks->{$hook}}, $code; + } + else { + push @{$hooks->{$hook}}, $code; + } } sub spool_dir { - my $self = shift; + 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/'); + 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 .= "/" 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'; + $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); - } + 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: $!"; + } - return $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 @@ -569,43 +622,44 @@ sub spool_dir { my $transaction_counter = 0; sub temp_file { - my $self = shift; - my $filename = $self->spool_dir() - . join(":", time, $$, $transaction_counter++); - return $filename; + 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; + 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(LOGDEBUG, "size_threshold set to $Size_threshold"); - } - return $Size_threshold; + my $self = shift; + unless (defined $Size_threshold) { + $Size_threshold = $self->config('size_threshold') || 0; + $self->log(LOGDEBUG, "size_threshold set to $Size_threshold"); + } + return $Size_threshold; } sub authenticated { - my $self = shift; - return (defined $self->{_auth} ? $self->{_auth} : "" ); + my $self = shift; + return (defined $self->{_auth} ? $self->{_auth} : ""); } sub auth_user { - my $self = shift; - return (defined $self->{_auth_user} ? $self->{_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} : "" ); + my $self = shift; + return (defined $self->{_auth_mechanism} ? $self->{_auth_mechanism} : ""); } 1; diff --git a/lib/Qpsmtpd/Address.pm b/lib/Qpsmtpd/Address.pm index 5800be2..a0f6b50 100644 --- a/lib/Qpsmtpd/Address.pm +++ b/lib/Qpsmtpd/Address.pm @@ -25,9 +25,9 @@ for easy testing of values. =cut use overload ( - '""' => \&format, - 'cmp' => \&_addr_cmp, -); + '""' => \&format, + 'cmp' => \&_addr_cmp, + ); =head2 new() @@ -59,13 +59,13 @@ test for equality (like in badmailfrom). sub new { my ($class, $user, $host) = @_; my $self = {}; - if ($user =~ /^<(.*)>$/ ) { - ($user, $host) = $class->canonify($user); - return undef unless defined $user; + if ($user =~ /^<(.*)>$/) { + ($user, $host) = $class->canonify($user); + return undef unless defined $user; } - elsif ( not defined $host ) { - my $address = $user; - ($user, $host) = $address =~ m/(.*)(?:\@(.*))/; + elsif (not defined $host) { + my $address = $user; + ($user, $host) = $address =~ m/(.*)(?:\@(.*))/; } $self->{_user} = $user; $self->{_host} = $host; @@ -84,35 +84,35 @@ sub new { # 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) @@ -127,12 +127,12 @@ sub new { # ; 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 @@ -145,21 +145,21 @@ sub new { # "|" / "}" / # "~" # 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 / @@ -196,8 +196,11 @@ sub canonify { return undef unless ($path =~ /^<(.*)>$/); $path = $1; - my $domain = $domain_expr ? $domain_expr - : "$subdomain_expr(?:\.$subdomain_expr)*"; + 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)" @@ -216,14 +219,15 @@ sub canonify { 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); } @@ -234,7 +238,7 @@ to new() called with a single parameter. =cut -sub parse { # retain for compatibility only +sub parse { # retain for compatibility only return shift->new(shift); } @@ -252,14 +256,14 @@ L. sub address { my ($self, $val) = @_; - if ( defined($val) ) { - $val = "<$val>" unless $val =~ /^<.+>$/; - my ($user, $host) = $self->canonify($val); - $self->{_user} = $user; - $self->{_host} = $host; + 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} : '' ); + return (defined $self->{_user} ? $self->{_user} : '') + . (defined $self->{_host} ? '@' . $self->{_host} : ''); } =head2 format() @@ -278,11 +282,12 @@ 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().">"; + if ((my $user = $self->{_user}) =~ s/($qchar)/\\$1/g) { + return + qq(<"$user") + . (defined $self->{_host} ? '@' . $self->{_host} : '') . ">"; + } + return "<" . $self->address() . ">"; } =head2 user([$user]) @@ -326,10 +331,11 @@ 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; + 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 { @@ -337,16 +343,16 @@ sub _addr_cmp { my ($left, $right, $swap) = @_; my $class = ref($left); - unless ( UNIVERSAL::isa($right, $class) ) { - $right = $class->new($right); + 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; + #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); + if ($swap) { + ($right, $left) = ($left, $right); } return ($left cmp $right); diff --git a/lib/Qpsmtpd/Auth.pm b/lib/Qpsmtpd/Auth.pm index 509069c..c0a03e1 100644 --- a/lib/Qpsmtpd/Auth.pm +++ b/lib/Qpsmtpd/Auth.pm @@ -1,5 +1,6 @@ package Qpsmtpd::Auth; -# See the documentation in 'perldoc docs/authentication.pod' + +# See the documentation in 'perldoc docs/authentication.pod' use strict; use warnings; @@ -10,167 +11,172 @@ use Digest::HMAC_MD5 qw(hmac_md5_hex); use MIME::Base64; sub e64 { - my ($arg) = @_; - my $res = encode_base64($arg); - chomp($res); - return($res); + 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 ); + 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; + 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 '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; + 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" ); + $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 ); + 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 || $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 ); + 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 + 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_user} = $user; $session->{_auth_mechanism} = $mechanism; - s/[\r\n].*//s for ($session->{_auth_user}, $session->{_auth_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 + $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 ) = @_; + my ($session, $prekey) = @_; - if ( ! $prekey) { - $session->respond( 334, ' ' ); - $prekey= ; + if (!$prekey) { + $session->respond(334, ' '); + $prekey = ; } - my ( $loginas, $user, $passClear ) = split /\x0/, decode_base64($prekey); + my ($loginas, $user, $passClear) = split /\x0/, decode_base64($prekey); - if ( ! $user ) { - if ( $loginas ) { + 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 ) { + 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 ($session, $prekey) = @_; my $user; - if ( $prekey ) { + if ($prekey) { $user = decode_base64($prekey); } else { - $user = get_base64_response($session,'Username:') or return; + $user = get_base64_response($session, 'Username:') or return; } - my $passClear = get_base64_response($session,'Password:') or return; + my $passClear = get_base64_response($session, 'Password:') or return; return ($user, $passClear); -}; +} sub get_auth_details_cram_md5 { - my ( $session, $ticket ) = @_; + 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') ); - }; + 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, '' ) ); + $session->respond(334, encode_base64($ticket, '')); my $line = ; - if ( $line eq '*' ) { - $session->respond( 501, "Authentication canceled" ); + if ($line eq '*') { + $session->respond(501, "Authentication canceled"); return; - }; + } - my ( $user, $passHash ) = split( / /, decode_base64($line) ); - unless ( $user && $passHash ) { + 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( ); + my $answer = decode_base64(); if ($answer eq '*') { $session->respond(501, "Authentication canceled"); return; } return $answer; -}; +} sub validate_password { - my ( $self, %a ) = @_; + my ($self, %a) = @_; my ($pkg, $file, $line) = caller(); - $file = (split /\//, $file)[-1]; # strip off the path + $file = (split /\//, $file)[-1]; # strip off the path my $src_clear = $a{src_clear}; my $src_crypt = $a{src_crypt}; @@ -180,43 +186,43 @@ sub validate_password { my $ticket = $a{ticket} || $self->{auth}{ticket}; my $deny = $a{deny} || DENY; - if ( ! $src_crypt && ! $src_clear ) { + 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 ); + return ($deny, "$file - no such user"); } - if ( defined $attempt_clear ) { - if ( $src_clear && $src_clear eq $attempt_clear ) { + 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 ); + return (OK, $file); } - }; - if ( defined $attempt_hash && $src_clear ) { - if ( ! $ticket ) { + 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 ); - }; + return (DECLINED, $file); + } - if ( $attempt_hash eq hmac_md5_hex( $ticket, $src_clear ) ) { + if ($attempt_hash eq hmac_md5_hex($ticket, $src_clear)) { $self->log(LOGINFO, "pass: hash match"); - return ( OK, $file ); - }; - }; + return (OK, $file); + } + } $self->log(LOGINFO, "fail: wrong password"); - return ( $deny, "$file - wrong password" ); -}; + return ($deny, "$file - wrong password"); +} # tag: qpsmtpd plugin that sets RELAYCLIENT when the user authenticates diff --git a/lib/Qpsmtpd/Command.pm b/lib/Qpsmtpd/Command.pm index e48c0f2..29a0f63 100644 --- a/lib/Qpsmtpd/Command.pm +++ b/lib/Qpsmtpd/Command.pm @@ -60,8 +60,8 @@ use vars qw(@ISA); @ISA = qw(Qpsmtpd::SMTP); sub parse { - my ($me,$cmd,$line,$sub) = @_; - return (OK) unless defined $line; # trivial case + my ($me, $cmd, $line, $sub) = @_; + return (OK) unless defined $line; # trivial case my $self = {}; bless $self, $me; $cmd = lc $cmd; @@ -77,28 +77,29 @@ sub parse { ## } ## $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 (DENY, "Failed to parse line"); } return @out; } - return(OK, split(/ +/, $line)); # default :) + return (OK, split(/ +/, $line)); # default :) } sub parse_rcpt { - my ($self,$cmd,$line) = @_; + 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) = @_; + my ($self, $cmd, $line) = @_; return (DENY, "Syntax error in command") unless $line =~ s/^from:\s*//i; return &_get_mail_params($cmd, $line); } @@ -121,7 +122,7 @@ sub parse_mail { ## inner-esmtp-cmd ::= ("MAIL FROM:" reverse-path) / ## ("RCPT TO:" forward-path) sub _get_mail_params { - my ($cmd,$line) = @_; + my ($cmd, $line) = @_; my @params = (); $line =~ s/\s*$//; @@ -130,36 +131,37 @@ sub _get_mail_params { } @params = reverse @params; - # the above will "fail" (i.e. all of the line in @params) on + # the above will "fail" (i.e. all of the line in @params) on # some addresses without <> like # MAIL FROM: user=name@example.net # or RCPT TO: postmaster # let's see if $line contains nothing and use the first value as address: if ($line) { - # parameter syntax error, i.e. not all of the arguments were + + # 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/); + if ($line =~ /\@.*\s/); return (OK, $line, @params); } - $line = shift @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 + 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") + 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); + 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 diff --git a/lib/Qpsmtpd/ConfigServer.pm b/lib/Qpsmtpd/ConfigServer.pm index a112545..16d2d12 100644 --- a/lib/Qpsmtpd/ConfigServer.pm +++ b/lib/Qpsmtpd/ConfigServer.pm @@ -6,38 +6,38 @@ use Qpsmtpd::Constants; use strict; use fields qw( - _auth - _commands - _config_cache - _connection - _transaction - _test_mode - _extras - other_fds -); + _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->SUPER::new(@_); $self->write($PROMPT); return $self; } -sub max_idle_time { 3600 } # one hour +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"; } + 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 $prev = alarm(2); # must process a command in < 2 seconds my $resp = eval { $self->_process_line($line) }; alarm($prev); if ($@) { @@ -56,11 +56,11 @@ sub respond { } sub fault { - my $self = shift; - my ($msg) = shift || "program fault - command not performed"; - print STDERR "$0 [$$]: $msg ($!)\n"; - $self->respond("Error - " . $msg); - return $PROMPT; + 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 { @@ -71,9 +71,7 @@ sub _process_line { my ($cmd, @params) = split(/ +/, $line); my $meth = "cmd_" . lc($cmd); if (my $lookup = $self->can($meth)) { - my $resp = eval { - $lookup->($self, @params); - }; + my $resp = eval { $lookup->($self, @params); }; if ($@) { my $error = $@; chomp($error); @@ -89,28 +87,33 @@ sub _process_line { } my %helptext = ( - help => "HELP [CMD] - Get help on all commands or a specific command", + 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", + 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", - ); + 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)); + 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."; + my $txt = $helptext{$subcmd} + || "Unrecognised help option. Try 'help' for a full list."; return "$txt\n"; } @@ -125,47 +128,48 @@ sub cmd_shutdown { sub cmd_pause { my $self = shift; - + my $other_fds = $self->OtherFds; - - $self->{other_fds} = { %$other_fds }; + + $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 ); + + $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 - + + # 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; + my $current_dns = 0; foreach my $fd (keys %$descriptors) { my $pob = $descriptors->{$fd}; if ($pob->isa("Qpsmtpd::PollServer")) { @@ -175,99 +179,109 @@ sub cmd_status { $current_dns = $pob->pending; } } - - $output .= "Curr Connections: $current_connections / $::MAXconn\n". - "Curr DNS Queries: $current_dns"; - + + $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 $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]; + 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]; + @all = @all[$#all - ($count - 1) .. $#all]; } else { - @all = @all[0..(abs($count) - 1)]; + @all = @all[0 .. (abs($count) - 1)]; } } foreach my $item (@all) { - $list .= sprintf("%x : %s [%s] Connected %0.2fs\n", map { defined()?$_:'' } @$item); + $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 + 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->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"); + 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; - + $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)) { + if ($pob + 0 == hex($ref)) { return Data::Dumper::Dumper($pob); } } } - + return "Unable to find the connection: $ref. Try the LIST command\n"; } diff --git a/lib/Qpsmtpd/Connection.pm b/lib/Qpsmtpd/Connection.pm index 99b7b38..0efa829 100644 --- a/lib/Qpsmtpd/Connection.pm +++ b/lib/Qpsmtpd/Connection.pm @@ -1,123 +1,124 @@ package Qpsmtpd::Connection; use strict; -# All of these parameters depend only on the physical connection, +# 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 -); - + 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); + 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 $self = shift; + $self = $self->new(@_) unless ref $self; - my %args = @_; + my %args = @_; - foreach my $f ( @parameters ) { - $self->$f($args{$f}) if $args{$f}; - } + foreach my $f (@parameters) { + $self->$f($args{$f}) if $args{$f}; + } - return $self; + 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; + 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}; + 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}; + 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}; + 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}; + 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}; + 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}; + 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}; + my $self = shift; + @_ and $self->{_relay_client} = shift; + $self->{_relay_client}; } sub hello { - my $self = shift; - @_ and $self->{_hello} = shift; - $self->{_hello}; + my $self = shift; + @_ and $self->{_hello} = shift; + $self->{_hello}; } sub hello_host { - my $self = shift; - @_ and $self->{_hello_host} = shift; - $self->{_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; + 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; + my $self = shift; + $self->{_notes} = undef; + $self = $self->new; } 1; diff --git a/lib/Qpsmtpd/Constants.pm b/lib/Qpsmtpd/Constants.pm index ccd8440..03f0e84 100644 --- a/lib/Qpsmtpd/Constants.pm +++ b/lib/Qpsmtpd/Constants.pm @@ -4,64 +4,64 @@ 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, -); + 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, -); + 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 %return_codes) { + eval "use constant $_ => " . $return_codes{$_}; } -foreach (keys %log_levels ) { - eval "use constant $_ => ".$log_levels{$_}; +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/; - } + 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}; + 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/; - } + 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}; + else { # just return the numeric value + return $log_levels{$test}; } } diff --git a/lib/Qpsmtpd/DSN.pm b/lib/Qpsmtpd/DSN.pm index d446edd..5439f0d 100644 --- a/lib/Qpsmtpd/DSN.pm +++ b/lib/Qpsmtpd/DSN.pm @@ -48,95 +48,95 @@ than the RFC message. =cut my @rfc1893 = ( - [ - "Other or Undefined Status", # x.0.x + [ + "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 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 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 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 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 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 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 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 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 + "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); + 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 + else { # err .... no :) + return 4; # just 2,4,5 are allowed.. temp error by default } } sub _dsn { - my ($self,$return,$reason,$default,$subject,$detail) = @_; + my ($self, $return, $reason, $default, $subject, $detail) = @_; if (!defined $return) { $return = $default; - } + } elsif ($return !~ /^\d+$/) { $reason = $return; $return = $default; @@ -157,7 +157,7 @@ sub _dsn { return ($return, "$msg (#$class.$subject.$detail)"); } -sub unspecified { shift->_dsn(shift,shift,DENYSOFT,0,0); } +sub unspecified { shift->_dsn(shift, shift, DENYSOFT, 0, 0); } =head1 ADDRESS STATUS @@ -170,7 +170,7 @@ default: DENYSOFT =cut -sub addr_unspecified { shift->_dsn(shift,shift,DENYSOFT,1,0); } +sub addr_unspecified { shift->_dsn(shift, shift, DENYSOFT, 1, 0); } =item no_such_user, addr_bad_dest_mbox @@ -179,8 +179,8 @@ 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); } +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 @@ -189,7 +189,7 @@ default: DENY =cut -sub addr_bad_dest_system { shift->_dsn(shift,shift,DENY,1,2); } +sub addr_bad_dest_system { shift->_dsn(shift, shift, DENY, 1, 2); } =item addr_bad_dest_syntax @@ -198,7 +198,7 @@ default: DENY =cut -sub addr_bad_dest_syntax { shift->_dsn(shift,shift,DENY,1,3); } +sub addr_bad_dest_syntax { shift->_dsn(shift, shift, DENY, 1, 3); } =item addr_dest_ambigous @@ -207,7 +207,7 @@ default: DENYSOFT =cut -sub addr_dest_ambigous { shift->_dsn(shift,shift,DENYSOFT,1,4); } +sub addr_dest_ambigous { shift->_dsn(shift, shift, DENYSOFT, 1, 4); } =item addr_rcpt_ok @@ -217,7 +217,7 @@ 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); } +sub addr_rcpt_ok { shift->_dsn(shift, shift, OK, 1, 5); } =item addr_mbox_moved @@ -226,7 +226,7 @@ default: DENY =cut -sub addr_mbox_moved { shift->_dsn(shift,shift,DENY,1,6); } +sub addr_mbox_moved { shift->_dsn(shift, shift, DENY, 1, 6); } =item addr_bad_from_syntax @@ -235,7 +235,7 @@ default: DENY =cut -sub addr_bad_from_syntax { shift->_dsn(shift,shift,DENY,1,7); } +sub addr_bad_from_syntax { shift->_dsn(shift, shift, DENY, 1, 7); } =item addr_bad_from_system @@ -246,7 +246,7 @@ default: DENY =cut -sub addr_bad_from_system { shift->_dsn(shift,shift,DENY,1,8); } +sub addr_bad_from_system { shift->_dsn(shift, shift, DENY, 1, 8); } =head1 MAILBOX STATUS @@ -259,7 +259,7 @@ default: DENYSOFT =cut -sub mbox_unspecified { shift->_dsn(shift,shift,DENYSOFT,2,0); } +sub mbox_unspecified { shift->_dsn(shift, shift, DENYSOFT, 2, 0); } =item mbox_disabled @@ -272,7 +272,7 @@ default: DENY ...but RFC says: =cut -sub mbox_disabled { shift->_dsn(shift,shift,DENY,2,1); } +sub mbox_disabled { shift->_dsn(shift, shift, DENY, 2, 1); } =item mbox_full @@ -281,7 +281,7 @@ default: DENYSOFT =cut -sub mbox_full { shift->_dsn(shift,shift,DENYSOFT,2,2); } +sub mbox_full { shift->_dsn(shift, shift, DENYSOFT, 2, 2); } =item mbox_msg_too_long @@ -290,7 +290,7 @@ default: DENY =cut -sub mbox_msg_too_long { shift->_dsn(shift,shift,DENY,2,3); } +sub mbox_msg_too_long { shift->_dsn(shift, shift, DENY, 2, 3); } =item mbox_list_expansion_problem @@ -301,7 +301,7 @@ default: DENYSOFT =cut -sub mbox_list_expansion_problem { shift->_dsn(shift,shift,DENYSOFT,2,4); } +sub mbox_list_expansion_problem { shift->_dsn(shift, shift, DENYSOFT, 2, 4); } =head1 MAIL SYSTEM STATUS @@ -314,7 +314,7 @@ default: DENYSOFT =cut -sub sys_unspecified { shift->_dsn(shift,shift,DENYSOFT,3,0); } +sub sys_unspecified { shift->_dsn(shift, shift, DENYSOFT, 3, 0); } =item sys_disk_full @@ -323,7 +323,7 @@ default: DENYSOFT =cut -sub sys_disk_full { shift->_dsn(shift,shift,DENYSOFT,3,1); } +sub sys_disk_full { shift->_dsn(shift, shift, DENYSOFT, 3, 1); } =item sys_not_accepting_mail @@ -332,7 +332,7 @@ default: DENYSOFT =cut -sub sys_not_accepting_mail { shift->_dsn(shift,shift,DENYSOFT,3,2); } +sub sys_not_accepting_mail { shift->_dsn(shift, shift, DENYSOFT, 3, 2); } =item sys_not_supported @@ -345,7 +345,7 @@ default: DENYSOFT =cut -sub sys_not_supported { shift->_dsn(shift,shift,DENYSOFT,3,3); } +sub sys_not_supported { shift->_dsn(shift, shift, DENYSOFT, 3, 3); } =item sys_msg_too_big @@ -356,7 +356,7 @@ default DENY =cut -sub sys_msg_too_big { shift->_dsn(shift,shift,DENY,3,4); } +sub sys_msg_too_big { shift->_dsn(shift, shift, DENY, 3, 4); } =head1 NETWORK AND ROUTING STATUS @@ -371,10 +371,10 @@ default: DENYSOFT =cut -sub net_unspecified { shift->_dsn(shift,shift,DENYSOFT,4,0); } +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); } +# 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 @@ -383,12 +383,11 @@ default: DENYSOFT =cut -sub temp_resolver_failed { - shift->_dsn(shift, - (shift || "Temporary address resolution failure"), - DENYSOFT,4,3); +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); } +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); } @@ -399,7 +398,7 @@ default: DENYSOFT =cut -sub net_system_congested { shift->_dsn(shift,shift,DENYSOFT,4,5); } +sub net_system_congested { shift->_dsn(shift, shift, DENYSOFT, 4, 5); } =item net_routing_loop, too_many_hops @@ -416,8 +415,11 @@ Why do we want to DENYSOFT something like this? =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,); } +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 @@ -431,7 +433,7 @@ default: DENYSOFT =cut -sub proto_unspecified { shift->_dsn(shift,shift,DENYSOFT,5,0); } +sub proto_unspecified { shift->_dsn(shift, shift, DENYSOFT, 5, 0); } =item proto_invalid_command @@ -440,7 +442,7 @@ default: DENY =cut -sub proto_invalid_command { shift->_dsn(shift,shift,DENY,5,1); } +sub proto_invalid_command { shift->_dsn(shift, shift, DENY, 5, 1); } =item proto_syntax_error @@ -449,7 +451,7 @@ default: DENY =cut -sub proto_syntax_error { shift->_dsn(shift,shift,DENY,5,2); } +sub proto_syntax_error { shift->_dsn(shift, shift, DENY, 5, 2); } =item proto_rcpt_list_too_long, too_many_rcpts @@ -458,8 +460,8 @@ 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); } +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 @@ -468,7 +470,7 @@ default: DENY =cut -sub proto_invalid_cmd_args { shift->_dsn(shift,shift,DENY,5,4); } +sub proto_invalid_cmd_args { shift->_dsn(shift, shift, DENY, 5, 4); } =item proto_wrong_version @@ -479,7 +481,7 @@ default: DENYSOFT =cut -sub proto_wrong_version { shift->_dsn(shift,shift,DENYSOFT,5,5); } +sub proto_wrong_version { shift->_dsn(shift, shift, DENYSOFT, 5, 5); } =head1 MESSAGE CONTENT OR MESSAGE MEDIA STATUS @@ -492,7 +494,7 @@ default: DENYSOFT =cut -sub media_unspecified { shift->_dsn(shift,shift,DENYSOFT,6,0); } +sub media_unspecified { shift->_dsn(shift, shift, DENYSOFT, 6, 0); } =item media_unsupported @@ -501,7 +503,7 @@ default: DENY =cut -sub media_unsupported { shift->_dsn(shift,shift,DENY,6,1); } +sub media_unsupported { shift->_dsn(shift, shift, DENY, 6, 1); } =item media_conv_prohibited @@ -510,7 +512,7 @@ default: DENY =cut -sub media_conv_prohibited { shift->_dsn(shift,shift,DENY,6,2); } +sub media_conv_prohibited { shift->_dsn(shift, shift, DENY, 6, 2); } =item media_conv_unsupported @@ -519,7 +521,7 @@ default: DENYSOFT =cut -sub media_conv_unsupported { shift->_dsn(shift,shift,DENYSOFT,6,3); } +sub media_conv_unsupported { shift->_dsn(shift, shift, DENYSOFT, 6, 3); } =item media_conv_lossy @@ -530,7 +532,7 @@ default: DENYSOFT =cut -sub media_conv_lossy { shift->_dsn(shift,shift,DENYSOFT,6,4); } +sub media_conv_lossy { shift->_dsn(shift, shift, DENYSOFT, 6, 4); } =head1 SECURITY OR POLICY STATUS @@ -543,7 +545,7 @@ default: DENYSOFT =cut -sub sec_unspecified { shift->_dsn(shift,shift,DENYSOFT,7,0); } +sub sec_unspecified { shift->_dsn(shift, shift, DENYSOFT, 7, 0); } =item sec_sender_unauthorized, bad_sender_ip, relaying_denied @@ -552,12 +554,14 @@ 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 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); + +sub relaying_denied { + shift->_dsn(shift, (shift || "Relaying denied"), DENY, 7, 1); } =item sec_list_dest_prohibited @@ -567,7 +571,7 @@ default: DENY =cut -sub sec_list_dest_prohibited { shift->_dsn(shift,shift,DENY,7,2); } +sub sec_list_dest_prohibited { shift->_dsn(shift, shift, DENY, 7, 2); } =item sec_conv_failed @@ -576,7 +580,7 @@ default: DENY =cut -sub sec_conv_failed { shift->_dsn(shift,shift,DENY,7,3); } +sub sec_conv_failed { shift->_dsn(shift, shift, DENY, 7, 3); } =item sec_feature_unsupported @@ -585,7 +589,7 @@ default: DENY =cut -sub sec_feature_unsupported { shift->_dsn(shift,shift,DENY,7,4); } +sub sec_feature_unsupported { shift->_dsn(shift, shift, DENY, 7, 4); } =item sec_crypto_failure @@ -594,7 +598,7 @@ default: DENY =cut -sub sec_crypto_failure { shift->_dsn(shift,shift,DENY,7,5); } +sub sec_crypto_failure { shift->_dsn(shift, shift, DENY, 7, 5); } =item sec_crypto_algorithm_unsupported @@ -603,7 +607,9 @@ default: DENYSOFT =cut -sub sec_crypto_algorithm_unsupported { shift->_dsn(shift,shift,DENYSOFT,7,6); } +sub sec_crypto_algorithm_unsupported { + shift->_dsn(shift, shift, DENYSOFT, 7, 6); +} =item sec_msg_integrity_failure @@ -614,7 +620,7 @@ default: DENY =cut -sub sec_msg_integrity_failure { shift->_dsn(shift,shift,DENY,7,7); } +sub sec_msg_integrity_failure { shift->_dsn(shift, shift, DENY, 7, 7); } 1; diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm index 4e3a08d..d4be038 100644 --- a/lib/Qpsmtpd/Plugin.pm +++ b/lib/Qpsmtpd/Plugin.pm @@ -9,102 +9,107 @@ 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 -); + 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); + my $proto = shift; + my $class = ref($proto) || $proto; + bless({}, $class); } sub hook_name { - return shift->{_hook}; + return shift->{_hook}; } sub register_hook { - my ($plugin, $hook, $method, $unshift) = @_; + my ($plugin, $hook, $method, $unshift) = @_; - die $plugin->plugin_name . " : Invalid hook: $hook" unless $hooks{$hook}; + 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() + $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, - ); + # 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'); + 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}; + 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, @_); + 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 ($self, $cur_level, $plugin_name) = @_; my $adj = $self->{_args}{loglevel} or return $cur_level; - return $adj if $adj =~ m/^[01234567]$/; # a raw syslog numeral + 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 + 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 $operator = substr($adj, 0, 1); + my $adjust = substr($adj, -1, 1); - my $new_level = $operator eq '+' ? $cur_level + $adjust : $cur_level - $adjust; + 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; + + # not sure if this will work in a non-forking or a threaded daemon + shift->qp->transaction; } sub connection { - shift->qp->connection; + shift->qp->connection; } sub spool_dir { - shift->qp->spool_dir; + shift->qp->spool_dir; } sub auth_user { @@ -116,17 +121,17 @@ sub auth_mechanism { } sub temp_file { - my $self = shift; - my $tempfile = $self->qp->temp_file; - push @{$self->qp->transaction->{_temp_files}}, $tempfile; - return $tempfile; + 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; + my $self = shift; + my $tempdir = $self->qp->temp_dir(); + push @{$self->qp->transaction->{_temp_dirs}}, $tempdir; + return $tempdir; } # plugin inheritance: @@ -137,32 +142,31 @@ sub temp_dir { # $self->SUPER::register(@_); # } sub isa_plugin { - my ($self, $parent) = @_; - my ($currentPackage) = caller; + my ($self, $parent) = @_; + my ($currentPackage) = caller; - my $cleanParent = $parent; - $cleanParent =~ s/\W/_/g; - my $newPackage = $currentPackage."::_isa_$cleanParent"; + 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"}; + # 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; + # 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; + 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; + $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. @@ -172,8 +176,8 @@ sub compile { my $sub; open F, $file or die "could not open $file: $!"; { - local $/ = undef; - $sub = ; + local $/ = undef; + $sub = ; } close F; @@ -189,19 +193,19 @@ sub compile { } 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? - ); + "\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"; @@ -213,120 +217,126 @@ sub compile { } sub get_reject { - my $self = shift; + my $self = shift; my $smtp_mess = shift || "why didn't you pass an error message?"; - my $log_mess = shift || ''; + my $log_mess = shift || ''; $log_mess = ", $log_mess" if $log_mess; my $reject = $self->{_args}{reject}; - if ( defined $reject && ! $reject ) { + if (defined $reject && !$reject) { $self->log(LOGINFO, "fail, reject disabled" . $log_mess); return DECLINED; - }; + } # the naughty plugin will reject later - if ( $reject eq 'naughty' ) { + if ($reject eq 'naughty') { $self->log(LOGINFO, "fail, NAUGHTY" . $log_mess); - return $self->store_deferred_reject( $smtp_mess ); - }; + return $self->store_deferred_reject($smtp_mess); + } # they asked for reject, we give them reject $self->log(LOGINFO, "fail" . $log_mess); - return ( $self->get_reject_type(), $smtp_mess); -}; + return ($self->get_reject_type(), $smtp_mess); +} sub get_reject_type { - my $self = shift; + my $self = shift; my $default = shift || DENY; - my $deny = shift || $self->{_args}{reject_type} or return $default; + my $deny = shift || $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; -}; + return + $deny =~ /^(temp|soft)$/i ? DENYSOFT + : $deny =~ /^(perm|hard)$/i ? DENY + : $deny eq 'disconnect' ? DENY_DISCONNECT + : $deny eq 'temp_disconnect' ? DENYSOFT_DISCONNECT + : $default; +} sub store_deferred_reject { my ($self, $smtp_mess) = @_; - # store the reject message that the naughty plugin will return later - if ( ! $self->connection->notes('naughty') ) { + # store the reject message that the naughty plugin will return later + if (!$self->connection->notes('naughty')) { $self->connection->notes('naughty', $smtp_mess); } else { # append this reject message to the message my $prev = $self->connection->notes('naughty'); $self->connection->notes('naughty', "$prev\015\012$smtp_mess"); - }; - if ( ! $self->connection->notes('naughty_reject_type') ) { - $self->connection->notes('naughty_reject_type', $self->{_args}{reject_type} ); + } + if (!$self->connection->notes('naughty_reject_type')) { + $self->connection->notes('naughty_reject_type', + $self->{_args}{reject_type}); } return (DECLINED); -}; +} sub init_resolver { my $self = shift; return $self->{_resolver} if $self->{_resolver}; - $self->log( LOGDEBUG, "initializing Net::DNS::Resolver"); + $self->log(LOGDEBUG, "initializing Net::DNS::Resolver"); $self->{_resolver} = Net::DNS::Resolver->new(dnsrch => 0); my $timeout = $self->{_args}{dns_timeout} || 5; $self->{_resolver}->tcp_timeout($timeout); $self->{_resolver}->udp_timeout($timeout); return $self->{_resolver}; -}; +} sub is_immune { my $self = shift; - if ( $self->qp->connection->relay_client() ) { + 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') ) { + } + 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') ) { + } + if ($self->qp->transaction->notes('whitelistsender')) { + # set by plugins/whitelist $self->log(LOGINFO, "skip, whitelisted sender"); return 1; - }; - if ( $self->connection->notes('naughty') ) { + } + if ($self->connection->notes('naughty')) { + # see plugins/naughty $self->log(LOGINFO, "skip, naughty"); return 1; - }; - if ( $self->connection->notes('rejected') ) { + } + if ($self->connection->notes('rejected')) { + # http://www.steve.org.uk/Software/ms-lite/ $self->log(LOGINFO, "skip, already rejected"); return 1; - }; + } return; -}; +} sub adjust_karma { - my ( $self, $value ) = @_; + my ($self, $value) = @_; my $karma = $self->connection->notes('karma') || 0; $karma += $value; $self->log(LOGDEBUG, "karma adjust: $value ($karma)"); $self->connection->notes('karma', $karma); return $value; -}; - -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)); - } } +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/PollServer.pm b/lib/Qpsmtpd/PollServer.pm index f987c3f..a9e6ba0 100644 --- a/lib/Qpsmtpd/PollServer.pm +++ b/lib/Qpsmtpd/PollServer.pm @@ -1,32 +1,33 @@ 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 -); + 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; @@ -36,7 +37,7 @@ use Socket qw(inet_aton AF_INET CRLF); use Time::HiRes qw(time); use strict; -sub max_idle_time { 60 } +sub max_idle_time { 60 } sub max_connect_time { 1200 } sub input_sock { @@ -47,12 +48,12 @@ sub input_sock { sub new { my Qpsmtpd::PollServer $self = shift; - + $self = fields::new($self) unless ref $self; - $self->SUPER::new( @_ ); + $self->SUPER::new(@_); $self->{cmd_timeout} = 5; - $self->{start_time} = time; - $self->{mode} = 'connect'; + $self->{start_time} = time; + $self->{mode} = 'connect'; $self->load_plugins; $self->load_logging; @@ -75,28 +76,28 @@ sub new { 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'; + 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} = {}; } @@ -121,17 +122,18 @@ 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 ($::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)) { + if (my $lookup = + $cmd_cache{$meth} + || $self->{_commands}->{$meth} && $self->can($meth)) + { $cmd_cache{$meth} = $lookup; - eval { - $lookup->($self, @params); - }; + eval { $lookup->($self, @params); }; if ($@) { my $error = $@; chomp($error); @@ -141,11 +143,13 @@ sub process_line { } else { # No such method - i.e. unrecognized command - my ($rc, $msg) = $self->run_hooks("unrecognized_command", $meth, @params); + 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; @@ -171,31 +175,33 @@ sub 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); + 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") }, + 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, - ); - + 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; } @@ -217,7 +223,7 @@ sub data_respond { $self->respond(451, @$msg); $self->reset_transaction(); return; - } + } elsif ($rc == DENY_DISCONNECT) { $msg->[0] ||= "Message denied"; $self->respond(554, @$msg); @@ -231,14 +237,16 @@ sub data_respond { return; } return $self->respond(503, "MAIL first") unless $self->transaction->sender; - return $self->respond(503, "RCPT first") unless $self->transaction->recipients; - + 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->{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"); @@ -255,42 +263,47 @@ sub got_data { my $remainder; if ($data =~ s/^\.\r\n(.*)\z//ms) { $remainder = $1; - $done = 1; + $done = 1; } - # add a transaction->blocked check back here when we have line by line plugin access... +# 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. + + # ... 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"); + + 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/"); - +#$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 + + # Save the start of just the body itself $self->transaction->set_body_start(); } } @@ -298,7 +311,6 @@ sub got_data { $self->transaction->body_write(\$data); $self->{data_size} += length $data; } - if ($done) { $self->end_of_data; @@ -309,38 +321,44 @@ sub got_data { 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}"); - + + $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 $esmtp = substr($smtp, 0, 1) eq "E"; my $authheader; my $sslheader; - + if (defined $self->connection->notes('tls_enabled') - and $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) "; + $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"; + $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}; - + + $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; } diff --git a/lib/Qpsmtpd/Postfix.pm b/lib/Qpsmtpd/Postfix.pm index 519e5f6..2946bba 100644 --- a/lib/Qpsmtpd/Postfix.pm +++ b/lib/Qpsmtpd/Postfix.pm @@ -21,125 +21,131 @@ use vars qw(@ISA); my %rec_types; sub init { - my ($self) = @_; + 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_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_MESG => 'M', # start message records - REC_TYPE_CONT => 'L', # long data record - REC_TYPE_NORM => 'N', # normal data record + REC_TYPE_CONT => 'L', # long data record + REC_TYPE_NORM => 'N', # normal data record - REC_TYPE_XTRA => 'X', # start extracted records + 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_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 + REC_TYPE_END => 'E', # terminator, required - ); + ); } sub print_rec { - my ($self, $type, @list) = @_; + my ($self, $type, @list) = @_; - die "unknown record type" unless ($rec_types{$type}); - $self->print($rec_types{$type}); + 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)); + # 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); + $self->print($s); } sub print_rec_size { - my ($self, $content_size, $data_offset, $rcpt_count) = @_; + 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); + 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) = @_; + my ($self, $time) = @_; - $time = time() unless (defined($time)); + $time = time() unless (defined($time)); - my $s = sprintf("%d", $time); - $self->print_rec('REC_TYPE_TIME', $s); + my $s = sprintf("%d", $time); + $self->print_rec('REC_TYPE_TIME', $s); } sub open_cleanup { - my ($class, $socket) = @_; + 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; + 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"); + 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; + 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. @@ -151,17 +157,17 @@ and splits the line across several records if it is longer than =cut sub print_msg_line { - my ($self, $line) = @_; + my ($self, $line) = @_; - $line =~ s/\r?\n$//s; + $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); + # 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) @@ -172,52 +178,55 @@ $transaction is supposed to be a Qpsmtpd::Transaction object. =cut sub inject_mail { - my ($class, $transaction) = @_; + 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 @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', ""); + 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', $_); + } - # a received header has already been added in SMTP.pm - # so we can just copy the message: + # add an empty message length record. + # cleanup is supposed to understand that. + # see src/pickup/pickup.c + $strm->print_rec('REC_TYPE_MESG', ""); - 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); - } + # a received header has already been added in SMTP.pm + # so we can just copy the message: - # 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; + 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 index c06ad3f..8535284 100644 --- a/lib/Qpsmtpd/Postfix/Constants.pm +++ b/lib/Qpsmtpd/Postfix/Constants.pm @@ -15,72 +15,79 @@ require Exporter; use vars qw(@ISA @EXPORT %cleanup_soft %cleanup_hard $postfix_version); use strict; -@ISA = qw(Exporter); +@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 -); + %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_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); +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_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)", -); + 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/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index fd6dcf4..a74dead 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -16,6 +16,7 @@ use Qpsmtpd::Address (); use Qpsmtpd::Command; use Mail::Header (); + #use Data::Dumper; use POSIX qw(strftime); use Net::DNS; @@ -26,42 +27,44 @@ use Net::DNS; #$SIG{ALRM} = sub { warn "Connection Timed Out\n"; exit; }; sub new { - my $proto = shift; - my $class = ref($proto) || $proto; + my $proto = shift; + my $class = ref($proto) || $proto; - my %args = @_; + my %args = @_; - my $self = bless ({ args => \%args }, $class); + 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; + 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; + my $self = shift; + $self->{_counter} || 0; } sub dispatch { my $self = shift; my ($cmd) = shift; - if ( ! $cmd ) { + if (!$cmd) { $self->run_hooks("unrecognized_command", '', @_); return 1; - }; + } $cmd = lc $cmd; - $self->{_counter}++; + $self->{_counter}++; - if ($cmd !~ /^(\w{1,12})$/ or !exists $self->{_commands}->{$1}) { - $self->run_hooks("unrecognized_command", $cmd, @_); - return 1; - } - $cmd = $1; + 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 $@; @@ -72,28 +75,28 @@ sub dispatch { sub unrecognized_command_respond { my ($self, $rc, $msg) = @_; if ($rc == DENY_DISCONNECT) { - $self->respond(521, @$msg); - $self->disconnect; + $self->respond(521, @$msg); + $self->disconnect; } elsif ($rc == DENY) { - $self->respond(500, @$msg); + $self->respond(500, @$msg); } elsif ($rc != DONE) { - $self->respond(500, "Unrecognized command"); + $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); + 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"); @@ -103,153 +106,188 @@ sub start_conversation { 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; + $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; + $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."; - } + 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); + $self->respond(220, $greets); } } sub transaction { - my $self = shift; - return $self->{_transaction} || $self->reset_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(); + 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()); + 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]); + 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; + 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); + $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."); - } + 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; + 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); + $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 ($self, $rc, $msg, $args) = @_; + my ($hello_host) = @$args; + if ($rc == DONE) { - my @capabilities = $self->transaction->notes('capabilities') - ? @{ $self->transaction->notes('capabilities') } - : (); + # 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; - # 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; + 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'} = ""; - } + # 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, - ); - } + $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 { @@ -261,57 +299,59 @@ 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") + 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, "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, "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') ); + 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 ); - }; + if (exists $auth_mechanisms{uc($mechanism)}) { + return $self->{_auth} = Qpsmtpd::Auth::SASL($self, $mechanism, @stuff); + } - $self->respond( 504, "Unimplemented authentification mechanism: $mechanism" ); + $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. + my ($self, $line) = @_; - # sendmail (8.11) rejects a second MAIL command. + # -> 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. - # qmail-smtpd (1.03) accepts it and just starts a new transaction. - # Since we are a qmail-smtpd thing we will do the same. + # sendmail (8.11) rejects a second MAIL command. - $self->reset_transaction; - - if ( ! $self->connection->hello) { - return $self->respond(503, "please say hello first ..."); - }; + # 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; + + if (!$self->connection->hello) { + return $self->respond(503, "please say hello first ..."); + } $self->log(LOGDEBUG, "full from_parameter: $line"); $self->run_hooks("mail_parse", $line); @@ -320,17 +360,19 @@ sub mail { 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 ($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; + 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>"); + # 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); @@ -340,20 +382,21 @@ sub mail_pre_respond { my ($self, $rc, $msg, $args) = @_; my ($from, $param) = @$args; if ($rc == OK) { - $from = shift @$msg; + $from = shift @$msg; } $self->log(LOGDEBUG, "from email address : [$from]"); - return $self->respond(501, "could not parse your mail from command") + 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]; + $from = Qpsmtpd::Address->new("<>"); } - return $self->respond(501, "could not parse your mail from command") unless $from; + 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); } @@ -362,300 +405,313 @@ sub mail_respond { my ($self, $rc, $msg, $args) = @_; my ($from, $param) = @$args; if ($rc == DONE) { - return 1; + return 1; } elsif ($rc == DENY) { - $msg->[0] ||= $from->format . ', denied'; - $self->log(LOGINFO, "deny mail from " . $from->format . " (@$msg)"); - $self->respond(550, @$msg); + $msg->[0] ||= $from->format . ', denied'; + $self->log(LOGINFO, "deny mail from " . $from->format . " (@$msg)"); + $self->respond(550, @$msg); } elsif ($rc == DENYSOFT) { - $msg->[0] ||= $from->format . ', temporarily denied'; - $self->log(LOGINFO, "denysoft mail from " . $from->format . " (@$msg)"); - $self->respond(450, @$msg); + $msg->[0] ||= $from->format . ', temporarily denied'; + $self->log(LOGINFO, "denysoft mail from " . $from->format . " (@$msg)"); + $self->respond(450, @$msg); } elsif ($rc == DENY_DISCONNECT) { - $msg->[0] ||= $from->format . ', denied'; - $self->log(LOGINFO, "deny mail from " . $from->format . " (@$msg)"); - $self->respond(550, @$msg); - $self->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; + $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); + 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); + 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 ($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); + 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 =~ /^<.*>$/; + 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]; + $rcpt = (Qpsmtpd::Address->parse($rcpt))[0]; - return $self->respond(501, "could not parse recipient") - if (!$rcpt or ($rcpt->format eq '<>')); + return $self->respond(501, "could not parse recipient") + if (!$rcpt or ($rcpt->format eq '<>')); - $self->run_hooks("rcpt", $rcpt, %$param); + $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(LOGDEBUG, "delivery denied (@$msg)"); - $self->respond(550, @$msg); - $self->disconnect; - } - elsif ($rc == DENYSOFT_DISCONNECT) { - $msg->[0] ||= 'relaying denied'; - $self->log(LOGDEBUG, "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; + 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(LOGDEBUG, "delivery denied (@$msg)"); + $self->respond(550, @$msg); + $self->disconnect; + } + elsif ($rc == DENYSOFT_DISCONNECT) { + $msg->[0] ||= 'relaying denied'; + $self->log(LOGDEBUG, "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); + my ($self, @args) = @_; + $self->run_hooks("help", @args); } sub help_respond { - my ($self, $rc, $msg, $args) = @_; + my ($self, $rc, $msg, $args) = @_; - return 1 - if $rc == DONE; + 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 .'); + if ($rc == DENY) { + $msg->[0] ||= "Syntax error, command not recognized"; + $self->respond(500, @$msg); } - $self->respond(214, @$msg); - } - return 1; + 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"); + my $self = shift; + $self->run_hooks("noop"); } sub noop_respond { - my ($self, $rc, $msg, $args) = @_; - return 1 if $rc == DONE; + 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; + 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; - } - - $self->respond(250, "OK"); - return 1; } sub vrfy { - my $self = shift; + 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. + # 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"); + $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; - } + 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"); + my $self = shift; + $self->reset_transaction; + $self->respond(250, "OK"); } sub quit { - my $self = shift; - $self->run_hooks("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(); + 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; + my $self = shift; + $self->run_hooks("disconnect"); + $self->connection->notes(disconnected => 1); + $self->reset_transaction; } sub data { - my $self = shift; - $self->run_hooks("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; + 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"); - $self->log(LOGDEBUG, "max_size: $max_size / size: $size"); + 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; - my $header = Mail::Header->new(Modify => 0, MailFrom => "COERCE"); + $self->log(LOGDEBUG, "max_size: $max_size / size: $size"); - my $timeout = $self->config('timeout'); - while (defined($_ = $self->getline($timeout))) { - if ( $_ eq ".\r\n" ) { - $complete++; - $_ = ''; - }; - $i++; + my $header = Mail::Header->new(Modify => 0, MailFrom => "COERCE"); + + my $timeout = $self->config('timeout'); + while (defined($_ = $self->getline($timeout))) { + if ($_ eq ".\r\n") { + $complete++; + $_ = ''; + } + $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. + # 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; + ($_ 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 && (m/^$/ || $complete > 0)) { - $in_header = 0; - my @headers = split /^/m, $buffer; +# 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 && (m/^$/ || $complete > 0)) { + $in_header = 0; + my @headers = split /^/m, $buffer; # ... need to check that we don't reformat any of the received lines. # @@ -664,199 +720,218 @@ sub data_respond { # 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/"); + $header->extract(\@headers); - $buffer = ""; +#$header->add("X-SMTPD", "qpsmtpd/".$self->version.", http://smtpd.develooper.com/"); - $self->transaction->header($header); + $buffer = ""; - # 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; + $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($_) if !$complete; + $size += length $_; } + last if $complete > 0; - # 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($_) if ! $complete; - $size += length $_; + #$self->log(LOGDEBUG, "size is at $size\n") unless ($i % 300); } - last if $complete > 0; - #$self->log(LOGDEBUG, "size is at $size\n") unless ($i % 300); - } - $self->log(LOGDEBUG, "max_size: $max_size / size: $size"); + $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 = ''; + 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->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"; - } + 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); + $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; - } + # 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->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"); + $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)) - } + 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); - } + 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; + my ($self, $timeout) = @_; + + alarm $timeout; + my $line = ; # default implementation + alarm 0; + return $line; } sub queue { - my ($self, $transaction) = @_; + my ($self, $transaction) = @_; - # First fire any queue_pre hooks - $self->run_hooks("queue_pre"); + # 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; - } + 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"); + # 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"); + 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); + 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 index af8fb8e..20b05b7 100644 --- a/lib/Qpsmtpd/SMTP/Prefork.pm +++ b/lib/Qpsmtpd/SMTP/Prefork.pm @@ -4,27 +4,28 @@ use Qpsmtpd::Constants; @ISA = qw(Qpsmtpd::SMTP); sub dispatch { - my $self = shift; - my ($cmd) = lc shift; + my $self = shift; + my ($cmd) = lc shift; - $self->{_counter}++; + $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 $@; + if ($cmd !~ /^(\w{1,12})$/ or !exists $self->{_commands}->{$1}) { + $self->run_hooks("unrecognized_command", $cmd, @_); + return 1; } - return $result if defined $result; - return $self->fault("command '$cmd' failed unexpectedly"); - } + $cmd = $1; - return; + 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 index e4af474..8641576 100644 --- a/lib/Qpsmtpd/TcpServer.pm +++ b/lib/Qpsmtpd/TcpServer.pm @@ -10,12 +10,15 @@ use POSIX (); my $has_ipv6 = 0; if ( - eval {require Socket6;} && + eval { require Socket6; } + && + # INET6 prior to 2.01 will not work; sorry. - eval {require IO::Socket::INET6; IO::Socket::INET6->VERSION("2.00");} - ) { + eval { require IO::Socket::INET6; IO::Socket::INET6->VERSION("2.00"); } + ) +{ Socket6->import(qw(inet_ntop)); - $has_ipv6=1; + $has_ipv6 = 1; } sub has_ipv6 { @@ -33,25 +36,31 @@ sub start_connection { ); 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; + + # 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; + } + 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]"); @@ -64,20 +73,22 @@ sub start_connection { 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, + $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 +# Set local client_socket to passed client object for testing socket state on writes $self->{__client_socket} = $client; $self->load_plugins unless $self->{hooks}; @@ -85,107 +96,121 @@ sub run { 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 +# 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 $self = shift; - my $timeout = - $self->config('timeoutsmtpd') # qmail smtpd control file - || $self->config('timeout') # qpsmtpd control file - || 1200; # default value + 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); + 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 = ''; + my ($self, $code, @messages) = @_; + my $buf = ''; - if ( !$self->check_socket() ) { - $self->log(LOGERROR, "Lost connection to client, cannot send response."); - return(0); - } + 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; + 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; + 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 ($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 ($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://; + 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); + return ($port, $iaddr, $lport, $laddr, $nto_iaddr, $nto_laddr); } sub tcpenv { - my ($nto_laddr, $nto_iaddr, $no_rdns) = @_; + my ($nto_laddr, $nto_iaddr, $no_rdns) = @_; - my $TCPLOCALIP = $nto_laddr; - my $TCPREMOTEIP = $nto_iaddr; + 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; + if ($no_rdns) { + return ($TCPLOCALIP, $TCPREMOTEIP, + $TCPREMOTEIP ? "[$ENV{TCPREMOTEIP}]" : "[noip!]"); } - } - return ($TCPLOCALIP, $TCPREMOTEIP, $TCPREMOTEHOST || "Unknown"); + 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; + my $self = shift; - return 1 if ( $self->{__client_socket}->connected ); + return 1 if ($self->{__client_socket}->connected); - return 0; + return 0; } 1; diff --git a/lib/Qpsmtpd/TcpServer/Prefork.pm b/lib/Qpsmtpd/TcpServer/Prefork.pm index 2728cea..d8c814e 100644 --- a/lib/Qpsmtpd/TcpServer/Prefork.pm +++ b/lib/Qpsmtpd/TcpServer/Prefork.pm @@ -5,75 +5,77 @@ use Qpsmtpd::Constants; @ISA = qw(Qpsmtpd::SMTP::Prefork Qpsmtpd::TcpServer); -my $first_0; +my $first_0; sub start_connection { my $self = shift; #reset info - $self->{_connection} = Qpsmtpd::Connection->new(); #reset connection + $self->{_connection} = Qpsmtpd::Connection->new(); #reset connection $self->reset_transaction; $self->SUPER::start_connection(@_); } sub read_input { - my $self = shift; + my $self = shift; - my $timeout = - $self->config('timeoutsmtpd') # qmail smtpd control file - || $self->config('timeout') # qpsmtpd control file - || 1200; # default value + 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; + 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"; } - unless ($self->connection->notes('disconnected')) { - $self->reset_transaction; - $self->run_hooks('disconnect'); - $self->connection->notes(disconnected => 1); + else { + $self->run_hooks("post-connection"); + $self->connection->reset; + die "died while reading from STDIN (probably broken sender) - $@"; } - }; - 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); + alarm(0); } sub respond { - my ($self, $code, @messages) = @_; + my ($self, $code, @messages) = @_; - if ( !$self->check_socket() ) { - $self->log(LOGERROR, "Lost connection to client, cannot send response."); - return(0); - } + 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; + 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"; + 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 index 4283d29..294fcd0 100644 --- a/lib/Qpsmtpd/Transaction.pm +++ b/lib/Qpsmtpd/Transaction.pm @@ -15,13 +15,13 @@ use Time::HiRes qw(gettimeofday); 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; + my $proto = shift; + my $class = ref($proto) || $proto; + my %args = @_; + + my $self = {_rcpt => [], started => time,}; + bless($self, $class); + return $self; } sub add_recipient { @@ -30,27 +30,28 @@ sub add_recipient { } sub remove_recipient { - my ($self,$rcpt) = @_; - $self->{_recipients} = [grep {$_->address ne $rcpt->address} - @{$self->{_recipients} || []}] if $rcpt; + 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}} : ()); + my $self = shift; + @_ and $self->{_recipients} = [@_]; + ($self->{_recipients} ? @{$self->{_recipients}} : ()); } sub sender { - my $self = shift; - @_ and $self->{_sender} = shift; - $self->{_sender}; + my $self = shift; + @_ and $self->{_sender} = shift; + $self->{_sender}; } sub header { - my $self = shift; - @_ and $self->{_header} = shift; - $self->{_header}; + my $self = shift; + @_ and $self->{_header} = shift; + $self->{_header}; } # blocked() will return when we actually can do something useful with it... @@ -63,32 +64,33 @@ sub header { #} 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; + 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}; + $self->{_header_size} = $self->{_body_start}; } else { $self->{_header_size} = 0; if ($self->{_body_array}) { - foreach my $line (@{ $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}; + my $self = shift; + @_ and die "body_start now read only"; + $self->{_body_start}; } sub body_current_pos { @@ -100,110 +102,116 @@ sub body_current_pos { } 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}; + 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: $!"; + 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_start} = $self->{_header_size}; - } - else { - $self->log(LOGERROR, "no message body"); - } - $self->{_body_array} = undef; + else { + $self->log(LOGERROR, "no message body"); + } + $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}; + 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); } - if ($$ref =~ m/\G(.+)\z/gc) { - push @{ $self->{_body_array} }, $1; - $self->{_body_size} += length($1); - ++$self->{_body_current_pos}; + 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()); } - $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 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; + 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}; + 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; + 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; - } + 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 { @@ -218,55 +226,59 @@ sub body_as_string { } sub body_fh { - return shift->{_body_file}; + return shift->{_body_file}; } sub dup_body_fh { - my ($self) = @_; - open(my $fh, '<&=', $self->body_fh); - return $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? + my $self = shift; - $self->log(LOGDEBUG, sprintf( "DESTROY called by %s, %s, %s", (caller) ) ); + # would we save some disk flushing if we unlinked the file before + # closing it? - if ( $self->{_body_file} ) { + $self->log(LOGDEBUG, sprintf("DESTROY called by %s, %s, %s", (caller))); + + if ($self->{_body_file}) { undef $self->{_body_file}; - }; + } if ($self->{_filename} and -e $self->{_filename}) { - if ( unlink $self->{_filename} ) { - $self->log(LOGDEBUG, "unlinked ", $self->{_filename} ); + if (unlink $self->{_filename}) { + $self->log(LOGDEBUG, "unlinked ", $self->{_filename}); } else { - $self->log(LOGERROR, "Could not unlink ", $self->{_filename}, ": $!"); + $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, ": $!"); + # 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, ": $!"); - } - } -} + # 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__ diff --git a/lib/Qpsmtpd/Utils.pm b/lib/Qpsmtpd/Utils.pm index 7ddc801..38c2c6f 100644 --- a/lib/Qpsmtpd/Utils.pm +++ b/lib/Qpsmtpd/Utils.pm @@ -11,5 +11,4 @@ sub tildeexp { return $path; } - 1; diff --git a/t/Test/Qpsmtpd.pm b/t/Test/Qpsmtpd.pm index 48041ee..0499ac5 100644 --- a/t/Test/Qpsmtpd.pm +++ b/t/Test/Qpsmtpd.pm @@ -9,11 +9,17 @@ 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); + 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 { @@ -23,12 +29,14 @@ sub start_connection { 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, - @_); + my $conn = + $self->SUPER::connection->start( + remote_info => $remote_info, + remote_ip => $remote_ip, + remote_host => $remote_host, + @_ + ); $self->load_plugins; @@ -39,33 +47,33 @@ sub start_connection { } sub respond { - my $self = shift; - $self->{_response} = [@_]; + my $self = shift; + $self->{_response} = [@_]; } sub response { - my $self = shift; - $self->{_response} ? (@{ delete $self->{_response} }) : (); + my $self = shift; + $self->{_response} ? (@{delete $self->{_response}}) : (); } sub command { - my ($self, $command) = @_; - $self->input($command); - $self->response; + my ($self, $command) = @_; + $self->input($command); + $self->response; } sub input { - my $self = shift; - my $command = shift; + my $self = shift; + my $command = shift; - my $timeout = $self->config('timeout'); - alarm $timeout; + 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) + $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; + alarm $timeout; } sub config_dir { @@ -95,20 +103,21 @@ 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 ); - + $Test->plan(tests => $num_tests); + # Now run them - + foreach my $plugin (@plugins) { $plugin->run_tests($self); } diff --git a/t/Test/Qpsmtpd/Plugin.pm b/t/Test/Qpsmtpd/Plugin.pm index 81969d1..2733f50 100644 --- a/t/Test/Qpsmtpd/Plugin.pm +++ b/t/Test/Qpsmtpd/Plugin.pm @@ -11,14 +11,16 @@ 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 }; + push @{$plugin->{_tests}}, {name => $test, num => $num_tests}; } sub total_tests { @@ -34,14 +36,15 @@ 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"; + print "# Running $method tests for plugin " + . $plugin->plugin_name . "\n"; local $plugin->{_qp} = $qp; $plugin->$method(); } } sub validate_password { - my ( $self, %a ) = @_; + my ($self, %a) = @_; my ($pkg, $file, $line) = caller(); @@ -53,42 +56,42 @@ sub validate_password { my $ticket = $a{ticket}; my $deny = $a{deny} || DENY; - if ( ! $src_crypt && ! $src_clear ) { + 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 ); + return ($deny, "$file - no such user"); } - if ( defined $attempt_clear ) { - if ( $src_clear && $src_clear eq $attempt_clear ) { + 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 ); + return (OK, $file); } - }; - if ( defined $attempt_hash && $src_clear ) { - if ( ! $ticket ) { + 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 ); - }; + return (DECLINED, $file); + } - if ( $attempt_hash eq hmac_md5_hex( $ticket, $src_clear ) ) { + if ($attempt_hash eq hmac_md5_hex($ticket, $src_clear)) { $self->log(LOGINFO, "pass: hash match"); - return ( OK, $file ); - }; - }; + return (OK, $file); + } + } $self->log(LOGINFO, "fail: wrong password"); - return ( $deny, "$file - wrong password" ); -}; + return ($deny, "$file - wrong password"); +} 1; From 5a0662b64a89b581bc0a5c580cbac106a5628f89 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sun, 21 Apr 2013 00:34:07 -0400 Subject: [PATCH 259/352] perltidy -b qpsmtpd* --- qpsmtpd | 4 +- qpsmtpd-async | 253 +++++++++++++----------- qpsmtpd-forkserver | 471 ++++++++++++++++++++++++--------------------- qpsmtpd-prefork | 168 +++++++++------- 4 files changed, 490 insertions(+), 406 deletions(-) diff --git a/qpsmtpd b/qpsmtpd index 19fa862..9e2374c 100755 --- a/qpsmtpd +++ b/qpsmtpd @@ -21,11 +21,11 @@ $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(\*STDIN); # pass the "socket" like -prefork/-forkserver $qpsmtpd->run_hooks("post-connection"); $qpsmtpd->connection->reset; -# needed for Qpsmtpd::TcpServer::check_socket(): +# 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) } diff --git a/qpsmtpd-async b/qpsmtpd-async index e2986e8..e4f9bf9 100755 --- a/qpsmtpd-async +++ b/qpsmtpd-async @@ -1,6 +1,7 @@ #!/usr/bin/perl use lib "./lib"; + BEGIN { delete $ENV{ENV}; delete $ENV{BASH_ENV}; @@ -14,6 +15,7 @@ BEGIN { use strict; use vars qw($DEBUG); use FindBin qw(); + # TODO: need to make this taint friendly use lib "$FindBin::Bin/lib"; use Danga::Socket; @@ -29,25 +31,26 @@ use List::Util qw(shuffle); $|++; -use Socket qw(SOMAXCONN IPPROTO_TCP SO_KEEPALIVE TCP_NODELAY SOL_SOCKET AF_UNIX SOCK_STREAM PF_UNSPEC); +use Socket + qw(SOMAXCONN IPPROTO_TCP SO_KEEPALIVE TCP_NODELAY SOL_SOCKET AF_UNIX SOCK_STREAM PF_UNSPEC); -$SIG{'PIPE'} = "IGNORE"; # handled manually +$SIG{'PIPE'} = "IGNORE"; # handled manually -$DEBUG = 0; +$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 $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 +my $DETACH; # daemonize on startup # make sure we don't spend forever doing accept() use constant ACCEPT_MAX => 1000; @@ -77,30 +80,39 @@ EOT } GetOptions( - 'p|port=i' => \$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(); + 'p|port=i' => \$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 } +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::HaveEpoll = 0; $Danga::Socket::HaveKQueue = 0; } -my $POLL = "with " . ($Danga::Socket::HaveEpoll ? "epoll()" : - $Danga::Socket::HaveKQueue ? "kqueue()" : "poll()"); +my $POLL = "with " + . ( + $Danga::Socket::HaveEpoll ? "epoll()" + : $Danga::Socket::HaveKQueue ? "kqueue()" + : "poll()" + ); my $SERVER; my $CONFIG_SERVER; @@ -113,12 +125,13 @@ 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; + 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"; - } + if (kill 0, $running_pid) { + die "Found an already running qpsmtpd with pid $running_pid.\n"; + } } close(PID); } @@ -133,32 +146,36 @@ sub _fork { # 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())); + $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"; + + 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; @@ -167,15 +184,14 @@ sub spawn_child { $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, - ); + fileno($reader) => sub { command_handler($reader) }, + fileno($SERVER) => \&accept_handler,); $ACCEPT_RSET = Danga::Socket->AddTimer(30, \&reset_num_accept); @@ -194,7 +210,7 @@ sub sig_hup { sub sig_chld { my $spawn_count = 0; - while ( (my $child = waitpid(-1,WNOHANG)) > 0) { + while ((my $child = waitpid(-1, WNOHANG)) > 0) { if (!defined $childstatus{$child}) { next; } @@ -205,7 +221,8 @@ sub sig_chld { $spawn_count++; } if ($spawn_count) { - for (1..$spawn_count) { + for (1 .. $spawn_count) { + # restart a new child if in poll server mode my $pid = spawn_child(); } @@ -223,34 +240,40 @@ sub HUNTSMAN { } sub run_as_server { + # establish SERVER socket, bind and listen. - $SERVER = IO::Socket::INET->new(LocalPort => $PORT, + $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"; + 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"; - + + $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 (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); @@ -260,40 +283,43 @@ sub run_as_server { } endgrent; $) = $groups; - POSIX::setgid($qgid) or - die "unable to change gid: $!\n"; - POSIX::setuid($quid) or - die "unable to change uid: $!\n"; + POSIX::setgid($qgid) + or die "unable to change gid: $!\n"; + POSIX::setuid($quid) + or die "unable to change uid: $!\n"; $> = $quid; - + # Load plugins here my $plugin_loader = Qpsmtpd::SMTP->new(); $plugin_loader->load_plugins; - + 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: $!"; + 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"; + open PID, ">$PID_FILE" || die "$PID_FILE: $!"; + print PID $$, "\n"; close PID; } - - $plugin_loader->log(LOGINFO, 'Running as user '. - (getpwuid($>) || $>) . - ', group '. - (getgrgid($)) || $))); + + $plugin_loader->log(LOGINFO, + 'Running as user ' + . (getpwuid($>) || $>) + . ', group ' + . (getgrgid($)) || $)) + ); $SIG{INT} = $SIG{TERM} = \&HUNTSMAN; ###################### -# more Profiling code + # more Profiling code + =pod $plugin_loader->run_hooks('post-fork'); @@ -315,38 +341,39 @@ sub run_as_server { Qpsmtpd::PollServer->EventLoop; exit; =cut + ##################### - for (1..$PROCS) { + for (1 .. $PROCS) { my $pid = spawn_child($plugin_loader); } - $plugin_loader->log(LOGDEBUG, "Listening on $PORT with $PROCS children $POLL"); + $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->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; @@ -354,21 +381,23 @@ sub config_handler { 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. } @@ -377,7 +406,7 @@ 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; @@ -391,26 +420,29 @@ 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; + 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(); @@ -420,12 +452,13 @@ sub _accept_handler { ######################################################################## sub log { - my ($level,$message) = @_; - # $level not used yet. this is reimplemented from elsewhere anyway - warn("$$ fd:? $message\n"); + my ($level, $message) = @_; + + # $level not used yet. this is reimplemented from elsewhere anyway + warn("$$ fd:? $message\n"); } sub pause { - my ($pause) = @_; - $PAUSED = $pause; + my ($pause) = @_; + $PAUSED = $pause; } diff --git a/qpsmtpd-forkserver b/qpsmtpd-forkserver index 2e33618..687b97c 100755 --- a/qpsmtpd-forkserver +++ b/qpsmtpd-forkserver @@ -21,19 +21,19 @@ $| = 1; my $has_ipv6 = Qpsmtpd::TcpServer::has_ipv6; # 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 $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 +my $USER = (getpwuid $>)[0]; # user to suid to $USER = "smtpd" if $USER eq "root"; sub usage { - print <<"EOT"; + print <<"EOT"; usage: qpsmtpd-forkserver [ options ] -l, --listen-address addr : listen on specific address(es); can be specified multiple times for multiple bindings. IPv6 @@ -49,51 +49,58 @@ usage: qpsmtpd-forkserver [ options ] -d, --detach : detach from controlling terminal (daemonize) -H, --no-rdns : don't perform reverse DNS lookups EOT - exit 0; + exit 0; } -GetOptions('h|help' => \&usage, - 'l|listen-address=s' => \@LOCALADDR, +GetOptions( + 'h|help' => \&usage, + 'l|listen-address=s' => \@LOCALADDR, 'c|limit-connections=i' => \$MAXCONN, - 'm|max-from-ip=i' => \$MAXCONNIP, - 'p|port=s' => \@PORT, - 'u|user=s' => \$USER, - 'pid-file=s' => \$PID_FILE, - 'd|detach' => \$DETACH, - 'H|no-rdns' => \$NORDNS, - ) || &usage; + '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; + @LOCALADDR = ('[::]') if !@LOCALADDR; } else { - @LOCALADDR = ( '0.0.0.0' ) if !@LOCALADDR; + @LOCALADDR = ('0.0.0.0') if !@LOCALADDR; } -@PORT = ( 2525 ) if !@PORT; +@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; +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; - } + else { + &usage; + } } -if ($USER =~ /^([\w\-]+)$/) { $USER = $1 } else { &usage } -if ($MAXCONN =~ /^(\d+)$/) { $MAXCONN = $1 } else { &usage } +if ($USER =~ /^([\w\-]+)$/) { $USER = $1 } +else { &usage } +if ($MAXCONN =~ /^(\d+)$/) { $MAXCONN = $1 } +else { &usage } delete $ENV{ENV}; $ENV{PATH} = '/bin:/usr/bin:/var/qmail/bin'; @@ -101,23 +108,23 @@ $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}; - } + 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{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{INT} = \&HUNTSMAN; $SIG{TERM} = \&HUNTSMAN; my $select = new IO::Select; @@ -125,89 +132,99 @@ 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); + 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"; - } + 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"; } - 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 (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()) { +while (my ($name, $passwd, $gid, $members) = getgrent()) { my @m = split(/ /, $members); - if (grep {$_ eq $USER} @m) { + 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"; +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'}"); +foreach my $listen_addr (@LISTENADDR) { + ::log(LOGINFO, + "Listening on $listen_addr->{'addr'}:$listen_addr->{'port'}"); } -::log(LOGINFO, 'Running as user '. - (getpwuid($>) || $>) . - ', group '. - (getgrgid($)) || $))); +::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: $!"; + 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; + print PID $$, "\n"; + close PID; } # Populate class cached variables @@ -222,137 +239,149 @@ $SIG{HUP} = sub { }; 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; + REAPER(); + my $running = scalar keys %childstatus; + if ($running >= $MAXCONN) { + ::log(LOGINFO, + "Too many connections: $running >= $MAXCONN. Waiting one second." + ); + sleep(1); + 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 @ready = $select->can_read(1); + next if !@ready; + while (my $server = shift @ready) { + my ($client, $hisaddr) = $server->accept; - 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; + 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 + + 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 } - - 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 - - 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); + 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; + 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'; + ### block signal for fork + my $sigset = POSIX::SigSet->new(SIGINT); + POSIX::sigprocmask(SIG_BLOCK, $sigset) + or die "Can't block SIGINT for fork: [$!]\n"; - ### put back to normal - POSIX::sigprocmask(SIG_UNBLOCK, $sigset) - or die "Can't unblock SIGINT for fork: [$!]\n"; + ### fork off a child + my $pid = fork; + unless (defined $pid) { + die "Couldn't fork: [$!]\n"; + } - return $pid; + ### 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__ diff --git a/qpsmtpd-prefork b/qpsmtpd-prefork index 3d018a9..7843609 100755 --- a/qpsmtpd-prefork +++ b/qpsmtpd-prefork @@ -36,8 +36,7 @@ my $has_ipv6 = Qpsmtpd::TcpServer::has_ipv6; #get available signals my %sig_num; my $i = 0; -foreach my $sig_name ( split( /\s/, $Config{sig_name} ) ) -{ +foreach my $sig_name (split(/\s/, $Config{sig_name})) { $sig_num{$sig_name} = $i++; } @@ -53,32 +52,32 @@ 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 $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) +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 $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 $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 @@ -108,35 +107,39 @@ EOT # 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; + '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 ($user && $user =~ /^([\w\-]+)$/) { $user = $1 } +else { &usage } if (@d_addr) { - for my $i (0..$#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 { + $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 } ); +} +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 @@ -151,11 +154,13 @@ $idle_children = $max_children $chld_pool = $idle_children; if ($pid_file) { - if ($pid_file =~ m#^(/[\w\d/\-.]+)$#) { $pid_file = $1 } else { &usage } + if ($pid_file =~ m#^(/[\w\d/\-.]+)$#) { $pid_file = $1 } + else { &usage } if (-e $pid_file) { - open PID, "+<$pid_file" + open PID, "+<$pid_file" or die "open pid_file: $!\n"; - my $running_pid = || ''; chomp $running_pid; + my $running_pid = || ''; + chomp $running_pid; if ($running_pid =~ /(\d+)/) { $running_pid = $1; die "Found an already running qpsmtpd with pid $running_pid.\n" @@ -176,15 +181,16 @@ 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()) { + while (my ($name, $passwd, $gid, $members) = getgrent()) { my @m = split(/ /, $members); - if (grep {$_ eq $user} @m) { + if (grep { $_ eq $user } @m) { $groups .= " $gid"; } } @@ -199,24 +205,25 @@ sub run { 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); + $s = IO::Socket::INET6->new(@Socket_opts); } else { - $s = IO::Socket::INET->new(@Socket_opts); + $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." + . "\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 [$<])"); + 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); @@ -231,6 +238,7 @@ sub run { } if ($user) { + # change UUID/UGID $) = $groups; POSIX::setgid($qgid) or die "unable to change gid: $!\n"; @@ -241,11 +249,12 @@ sub run { } # setup shared memory - $chld_shmem = shmem($d_port."qpsmtpd", 1); + $chld_shmem = shmem($d_port . "qpsmtpd", 1); untie $chld_shmem; # Interrupt handler $SIG{INT} = $SIG{TERM} = sub { + # terminate daemon (and children) my $sig = shift; @@ -271,8 +280,9 @@ sub run { # Hup handler $SIG{HUP} = sub { + # reload qpmstpd plugins - $qpsmtpd = qpsmtpd_instance('restart' => 1); # reload plugins... + $qpsmtpd = qpsmtpd_instance('restart' => 1); # reload plugins... $qpsmtpd->load_plugins; kill 'HUP' => keys %children; info("reload daemon requested"); @@ -282,16 +292,16 @@ sub run { $qpsmtpd = qpsmtpd_instance(); if ($detach) { - open STDIN, '/dev/null' or die "/dev/null: $!"; + 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: $!"; + 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"; + print PID $$, "\n"; close PID; } @@ -304,6 +314,7 @@ sub run { # 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) { @@ -336,6 +347,7 @@ sub reaper { 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; @@ -345,6 +357,7 @@ sub main_loop { # 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 = (); @@ -377,7 +390,7 @@ sub main_loop { # spawn children $created_children = $chld_pool - keys %children; $created_children = 0 if $created_children < 0; - new_child() for 1..$created_children; + new_child() for 1 .. $created_children; # unblock signals unblock_signal($sigset); @@ -413,10 +426,12 @@ sub unblock_signal { # 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"); @@ -444,10 +459,11 @@ sub new_child { # 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 + 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; @@ -456,19 +472,19 @@ sub new_child { 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 + # ... no longer use POSIX::dup2: it failes after a few # million connections close(STDIN); - open(STDIN, "+<&".fileno($client)) + open(STDIN, "+<&" . fileno($client)) or die "unable to duplicate filehandle to STDIN - $!"; close(STDOUT); - open(STDOUT, "+>&".fileno($client)) + open(STDOUT, "+>&" . fileno($client)) or die "unable to duplicate filehandle to STDOUT - $!"; select(STDOUT); $| = 1; @@ -509,7 +525,7 @@ sub respond_client { # arg0: void # ret0: ref to qpsmtpd_instance sub qpsmtpd_instance { - my %args = @_; + my %args = @_; my $qpsmtpd = Qpsmtpd::TcpServer::Prefork->new(%args); $qpsmtpd->load_plugins; $qpsmtpd->spool_dir; @@ -523,7 +539,7 @@ sub qpsmtpd_instance { # arg1: int 0|1 (0 = don't create shmem, 1 = create shmem) # ret0: ref to shared hash sub shmem { - my $glue = shift; #arg0 + my $glue = shift; #arg0 my $create = shift || 0; #arg1 my %options = ( @@ -569,7 +585,8 @@ sub shmem_opt { my ($chld_shmem, $chld_busy); eval { - $chld_shmem = &shmem($d_port."qpsmtpd", 0); #connect to shared memory hash + $chld_shmem = + &shmem($d_port . "qpsmtpd", 0); #connect to shared memory hash if (tied %{$chld_shmem}) { @@ -593,13 +610,16 @@ sub shmem_opt { 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) { @@ -659,7 +679,7 @@ sub qpsmtpd_session { # get local/remote hostname, port and ip address my ($port, $iaddr, $lport, $laddr, $nto_iaddr, $nto_laddr) = - Qpsmtpd::TcpServer::lrpip($socket, $client, $iinfo); + Qpsmtpd::TcpServer::lrpip($socket, $client, $iinfo); # get current connected ip addresses (from shared memory) my %children; @@ -713,7 +733,8 @@ sub qpsmtpd_session { }; # set enviroment variables - ($ENV{TCPLOCALIP}, $ENV{TCPREMOTEIP}, $ENV{TCPREMOTEHOST}) = Qpsmtpd::TcpServer::tcpenv($nto_laddr, $nto_iaddr); + ($ENV{TCPLOCALIP}, $ENV{TCPREMOTEIP}, $ENV{TCPREMOTEHOST}) = + Qpsmtpd::TcpServer::tcpenv($nto_laddr, $nto_iaddr); # run qpmsptd functions $SIG{__DIE__} = 'DEFAULT'; @@ -737,6 +758,7 @@ sub qpsmtpd_session { # 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; From f988f0337c48f108e1d2a12419b54f5bcd739b0c Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sun, 21 Apr 2013 00:50:39 -0400 Subject: [PATCH 260/352] find plugins -type f -exec perltidy -b {} \; --- plugins/async/dns_whitelist_soft | 2 +- plugins/async/earlytalker | 109 ++++---- plugins/async/queue/smtp-forward | 141 +++++----- plugins/async/resolvable_fromhost | 127 +++++---- plugins/async/rhsbl | 2 +- plugins/async/uribl | 41 +-- plugins/auth/auth_checkpassword | 47 ++-- plugins/auth/auth_cvm_unix_local | 43 +-- plugins/auth/auth_flat_file | 37 +-- plugins/auth/auth_ldap_bind | 27 +- plugins/auth/auth_vpopmail | 40 +-- plugins/auth/auth_vpopmail_sql | 74 ++--- plugins/auth/auth_vpopmaild | 39 +-- plugins/auth/authdeny | 6 +- plugins/badmailfrom | 58 ++-- plugins/badmailfromto | 54 ++-- plugins/badrcptto | 59 ++-- plugins/bogus_bounce | 34 +-- plugins/connection_time | 35 +-- plugins/content_log | 24 +- plugins/count_unrecognized_commands | 22 +- plugins/dkim | 334 +++++++++++------------ plugins/dmarc | 290 ++++++++++---------- plugins/dns_whitelist_soft | 94 +++---- plugins/dnsbl | 114 ++++---- plugins/domainkeys | 96 +++---- plugins/dont_require_anglebrackets | 10 +- plugins/dspam | 403 +++++++++++++++------------- plugins/earlytalker | 127 ++++----- plugins/fcrdns | 129 ++++----- plugins/greylisting | 333 ++++++++++++----------- plugins/headers | 76 +++--- plugins/helo | 256 +++++++++--------- plugins/help | 48 ++-- plugins/hosts_allow | 46 ++-- plugins/http_config | 30 ++- plugins/ident/geoip | 160 +++++------ plugins/ident/p0f | 183 +++++++------ plugins/karma | 215 ++++++++------- plugins/karma_tool | 216 ++++++++------- plugins/logging/adaptive | 77 +++--- plugins/logging/apache | 2 +- plugins/logging/connection_id | 63 +++-- plugins/logging/devnull | 2 +- plugins/logging/file | 87 +++--- plugins/logging/syslog | 33 +-- plugins/logging/transaction_id | 58 ++-- plugins/logging/warn | 42 +-- plugins/loop | 34 +-- plugins/milter | 168 +++++++----- plugins/naughty | 35 +-- plugins/noop_counter | 30 +-- plugins/parse_addr_withhelo | 14 +- plugins/qmail_deliverable | 93 ++++--- plugins/queue/exim-bsmtp | 27 +- plugins/queue/maildir | 204 +++++++------- plugins/queue/postfix-queue | 49 ++-- plugins/queue/qmail-queue | 64 +++-- plugins/queue/smtp-forward | 79 +++--- plugins/quit_fortune | 20 +- plugins/random_error | 39 +-- plugins/rcpt_map | 22 +- plugins/rcpt_ok | 58 ++-- plugins/rcpt_regexp | 1 + plugins/relay | 94 +++---- plugins/resolvable_fromhost | 120 +++++---- plugins/rhsbl | 67 ++--- plugins/sender_permitted_from | 164 +++++------ plugins/spamassassin | 249 +++++++++-------- plugins/tls | 133 +++++---- plugins/uribl | 275 +++++++++++-------- plugins/virus/aveclient | 188 +++++++------ plugins/virus/bitdefender | 34 +-- plugins/virus/clamav | 208 +++++++------- plugins/virus/clamdscan | 148 +++++----- plugins/virus/hbedv | 210 ++++++++------- plugins/virus/kavscanner | 238 ++++++++-------- plugins/virus/klez_filter | 46 ++-- plugins/virus/sophie | 56 ++-- plugins/virus/uvscan | 168 ++++++------ plugins/whitelist | 4 +- 81 files changed, 4188 insertions(+), 3696 deletions(-) mode change 100755 => 100644 plugins/qmail_deliverable diff --git a/plugins/async/dns_whitelist_soft b/plugins/async/dns_whitelist_soft index 1d42a03..95066a6 100644 --- a/plugins/async/dns_whitelist_soft +++ b/plugins/async/dns_whitelist_soft @@ -3,7 +3,7 @@ use Qpsmtpd::Plugin::Async::DNSBLBase; sub init { - my $self = shift; + my $self = shift; my $class = ref $self; no strict 'refs'; diff --git a/plugins/async/earlytalker b/plugins/async/earlytalker index 9e3fb22..989848a 100644 --- a/plugins/async/earlytalker +++ b/plugins/async/earlytalker @@ -62,73 +62,80 @@ Note that defer-reject has no meaning if check-at is I. my $MSG = 'Connecting host started transmitting before SMTP greeting'; sub register { - my ($self, $qp, @args) = @_; + 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; + 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 ($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; + 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) = @_; + 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) }); - } + if ($qp->has_data) { + $qp->log(LOGNOTICE, + 'remote host started talking after $phase before we responded'); + $qp->clear_data if $phase eq 'data'; + $conn->notes('earlytalker', 1); + $qp->run_continuation; + } + elsif (time >= $until) { + + # no early talking + $qp->run_continuation; + } + else { + $qp->AddTimer(1, sub { read_now($qp, $conn, $until, $phase) }); + } } sub check_talker_post { - my ($self, $transaction) = @_; + my ($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' + 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) = @_; + 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; + 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/queue/smtp-forward b/plugins/async/queue/smtp-forward index 10665bf..818190d 100644 --- a/plugins/async/queue/smtp-forward +++ b/plugins/async/queue/smtp-forward @@ -25,7 +25,7 @@ use Qpsmtpd::Constants; sub register { my ($self, $qp) = @_; - + $self->register_hook(queue => "start_queue"); $self->register_hook(queue => "finish_queue"); } @@ -44,8 +44,9 @@ sub init { if (@args > 1 and $args[1] =~ /^(\d+)$/) { $self->{_smtp_port} = $1; } - - $self->log(LOGWARN, "WARNING: Ignoring additional arguments.") if (@args > 2); + + $self->log(LOGWARN, "WARNING: Ignoring additional arguments.") + if (@args > 2); } else { die("No SMTP server specified in smtp-forward config"); @@ -55,27 +56,30 @@ sub init { sub start_queue { my ($self, $transaction) = @_; - - my $qp = $self->qp; + + 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) - ); - + + $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; } @@ -85,17 +89,17 @@ use IO::Socket; use base qw(Danga::Socket); use fields qw( - qp - pkg - tran - state - rcode - rmsg - buf - command - resp - to - ); + qp + pkg + tran + state + rcode + rmsg + buf + command + resp + to + ); use constant ST_CONNECTING => 0; use constant ST_CONNECTED => 1; @@ -107,28 +111,31 @@ 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"; + 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->{qp} = $qp; + $self->{pkg} = $pkg; + $self->{tran} = $transaction; + $self->{state} = ST_CONNECTING; + $self->{rcode} = DECLINED; $self->{command} = 'connect'; - $self->{buf} = ''; - $self->{resp} = []; + $self->{buf} = ''; + $self->{resp} = []; + # copy the recipients so we can pop them off one by one - $self->{to} = [ $transaction->recipients ]; - + $self->{to} = [$transaction->recipients]; + $self->SUPER::new($sock); + # Watch for write first, this is when the TCP session is established. $self->watch_write(1); @@ -137,7 +144,7 @@ sub new { sub results { my AsyncSMTPSender $self = shift; - return ( $self->{rcode}, $self->{rmsg} ); + return ($self->{rcode}, $self->{rmsg}); } sub log { @@ -154,27 +161,28 @@ 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->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; @@ -183,14 +191,15 @@ sub cmd_connect { else { my $host = $self->{qp}->config('me'); print "HELOing with $host\n"; - $self->command((join '', @$response) =~ m/ ESMTP/ ? "EHLO" : "HELO", $host); + $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; @@ -204,7 +213,7 @@ sub cmd_helo { sub cmd_ehlo { my AsyncSMTPSender $self = shift; my ($code, $response) = @_; - + if ($code != 250) { $self->{rmsg} = "Error on EHLO: @$response"; $self->close; @@ -218,7 +227,7 @@ sub cmd_ehlo { sub cmd_mail { my AsyncSMTPSender $self = shift; my ($code, $response) = @_; - + if ($code != 250) { $self->{rmsg} = "Error on MAIL FROM: @$response"; $self->close; @@ -232,7 +241,7 @@ sub cmd_mail { sub cmd_rcpt { my AsyncSMTPSender $self = shift; my ($code, $response) = @_; - + if ($code != 250) { $self->{rmsg} = "Error on RCPT TO: @$response"; $self->close; @@ -251,7 +260,7 @@ sub cmd_rcpt { sub cmd_data { my AsyncSMTPSender $self = shift; my ($code, $response) = @_; - + if ($code != 354) { $self->{rmsg} = "Error on DATA: @$response"; $self->close; @@ -265,7 +274,7 @@ sub cmd_data { while (my $line = $self->{tran}->body_getline) { $line =~ s/\r?\n/\r\n/; $write_buf .= $line; - if (length($write_buf) >= 131072) { # 128KB, arbitrary value + if (length($write_buf) >= 131072) { # 128KB, arbitrary value $self->log(LOGDEBUG, ">> $write_buf"); $self->datasend($write_buf); $write_buf = ''; @@ -283,7 +292,7 @@ sub cmd_data { sub cmd_dataend { my AsyncSMTPSender $self = shift; my ($code, $response) = @_; - + if ($code != 250) { $self->{rmsg} = "Error after DATA: @$response"; $self->close; @@ -297,9 +306,9 @@ sub cmd_dataend { sub cmd_quit { my AsyncSMTPSender $self = shift; my ($code, $response) = @_; - + $self->{rcode} = OK; - $self->{rmsg} = "Queued!"; + $self->{rmsg} = "Queued!"; $self->close; $self->cont; } @@ -313,7 +322,7 @@ sub datasend { sub event_read { my AsyncSMTPSender $self = shift; - + if ($self->{state} == ST_CONNECTED) { $self->{state} = ST_COMMANDS; } @@ -321,20 +330,21 @@ sub event_read { 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) { + + for (@lines) { if (my ($code, $cont, $rest) = /^([0-9]{3})([ -])(.*)/) { $self->log(LOGDEBUG, "<< $code$cont$rest"); push @{$self->{resp}}, $rest; - if($cont eq ' ') { + if ($cont eq ' ') { $self->handle_response($code, $self->{resp}); $self->{resp} = []; } @@ -363,6 +373,7 @@ sub event_write { $self->watch_read(1); } elsif (0 && $self->{state} == ST_DATA) { + # send more data if (my $line = $self->{tran}->body_getline) { $self->log(LOGDEBUG, ">> $line"); @@ -383,8 +394,9 @@ sub event_write { sub event_err { my ($self) = @_; - eval { $self->read(1); }; # gives us the correct error in errno + 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; @@ -392,8 +404,9 @@ sub event_err { sub event_hup { my ($self) = @_; - eval { $self->read(1); }; # gives us the correct error in errno + 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/resolvable_fromhost b/plugins/async/resolvable_fromhost index acf93d6..fa471de 100644 --- a/plugins/async/resolvable_fromhost +++ b/plugins/async/resolvable_fromhost @@ -14,45 +14,47 @@ my %invalid = (); my $has_ipv6 = Qpsmtpd::TcpServer::has_ipv6(); sub register { - my ( $self, $qp ) = @_; + my ($self, $qp) = @_; - foreach my $i ( $self->qp->config("invalid_resolvable_fromhost") ) { + 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?)# ) { + if ($i =~ m#^((\d{1,3}\.){3}\d{1,3})/(\d\d?)#) { $invalid{$1} = $3; } } eval 'use ParaDNS'; - if ( $@ ) { + if ($@) { warn "could not load ParaDNS, plugin disabled"; return DECLINED; - }; - $self->register_hook( mail => 'hook_mail_start' ); - $self->register_hook( mail => 'hook_mail_done' ); + } + $self->register_hook(mail => 'hook_mail_start'); + $self->register_hook(mail => 'hook_mail_done'); } sub hook_mail_start { - my ( $self, $transaction, $sender ) = @_; + my ($self, $transaction, $sender) = @_; return DECLINED if ($self->connection->notes('whitelisthost')); - if ( $sender ne '<>' ) { + if ($sender ne '<>') { + + unless ($sender->host) { - 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 + 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 )) { + unless ($self->check_dns($sender->host)) { return Qpsmtpd::DSN->temp_resolver_failed( - "Could not resolve " . $sender->host ); + "Could not resolve " . $sender->host); } return YIELD; @@ -62,76 +64,97 @@ sub hook_mail_start { } sub hook_mail_done { - my ( $self, $transaction, $sender ) = @_; + my ($self, $transaction, $sender) = @_; return DECLINED - if ( $self->connection->notes('whitelisthost') ); + if ($self->connection->notes('whitelisthost')); + + if ($sender ne "<>" && !$transaction->notes('resolvable_fromhost')) { - 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 ); + "Could not resolve " . $sender->host); } return DECLINED; } sub check_dns { - my ( $self, $host ) = @_; + my ($self, $host) = @_; my @host_answers; my $qp = $self->qp; $qp->input_sock->pause_read; - my $a_records = []; + my $a_records = []; my $num_queries = 1; # queries in progress - my $mx_found = 0; + my $mx_found = 0; ParaDNS->new( - callback => sub { + callback => sub { my $mx = shift; - return if $mx =~ /^[A-Z]+$/; # error + 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', - ); + 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', - ); + 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 { + 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', - ); + 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', - ); + 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', + ); } } @@ -139,9 +162,10 @@ sub check_dns { $num_queries--; $self->finish_up($qp, $a_records, $num_queries); }, - host => $host, - type => 'MX', - ) or $qp->input_sock->continue_read, return; + host => $host, + type => 'MX', + ) + or $qp->input_sock->continue_read, return; return 1; } @@ -161,6 +185,7 @@ sub finish_up { } unless ($num_queries) { + # all queries returned no valid response $qp->transaction->notes('resolvable_fromhost', 0); $qp->input_sock->continue_read; @@ -170,12 +195,12 @@ sub finish_up { sub is_valid { my $ip = shift; - my ( $net, $mask ); - foreach $net ( keys %invalid ) { + my ($net, $mask); + foreach $net (keys %invalid) { $mask = $invalid{$net}; - $mask = pack "B32", "1" x ($mask) . "0" x ( 32 - $mask ); + $mask = pack "B32", "1" x ($mask) . "0" x (32 - $mask); return 0 - if join( ".", unpack( "C4", inet_aton($ip) & $mask ) ) eq $net; + if join(".", unpack("C4", inet_aton($ip) & $mask)) eq $net; } return 1; } diff --git a/plugins/async/rhsbl b/plugins/async/rhsbl index c0a5e53..2672808 100644 --- a/plugins/async/rhsbl +++ b/plugins/async/rhsbl @@ -3,7 +3,7 @@ use Qpsmtpd::Plugin::Async::DNSBLBase; sub init { - my $self = shift; + my $self = shift; my $class = ref $self; no strict 'refs'; diff --git a/plugins/async/uribl b/plugins/async/uribl index 27b991b..026982a 100644 --- a/plugins/async/uribl +++ b/plugins/async/uribl @@ -31,10 +31,13 @@ sub start_data_post { my @names; - my $queries = $self->lookup_start($transaction, sub { - my ($self, $name) = @_; - push @names, $name; - }); + my $queries = $self->lookup_start( + $transaction, + sub { + my ($self, $name) = @_; + push @names, $name; + } + ); my @hosts; foreach my $z (keys %{$self->{uribl_zones}}) { @@ -42,10 +45,10 @@ sub start_data_post { } $transaction->notes(uribl_results => {}); - $transaction->notes(uribl_zones => $self->{uribl_zones}); + $transaction->notes(uribl_zones => $self->{uribl_zones}); return DECLINED - unless @hosts && $class->lookup($self->qp, [ @hosts ], [ @hosts ]); + unless @hosts && $class->lookup($self->qp, [@hosts], [@hosts]); return YIELD; } @@ -58,9 +61,11 @@ sub finish_data_post { $self->log(LOGWARN, $_->{desc}); if ($_->{action} eq 'add-header') { $transaction->header->add('X-URIBL-Match', $_->{desc}); - } elsif ($_->{action} eq 'deny') { + } + elsif ($_->{action} eq 'deny') { return (DENY, $_->{desc}); - } elsif ($_->{action} eq 'denysoft') { + } + elsif ($_->{action} eq 'denysoft') { return (DENYSOFT, $_->{desc}); } } @@ -73,8 +78,8 @@ 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'); + my $results = $transaction->notes('uribl_results'); + my $zones = $transaction->notes('uribl_zones'); foreach my $z (keys %$zones) { if ($query =~ /^(.*)\.$z$/) { @@ -88,8 +93,8 @@ 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'); + my $results = $transaction->notes('uribl_results'); + my $zones = $transaction->notes('uribl_zones'); foreach my $z (keys %$zones) { if ($query =~ /^(.*)\.$z$/) { @@ -110,11 +115,15 @@ sub collect_results { if (exists $results->{$z}->{$n}->{a}) { if ($self->evaluate($z, $results->{$z}->{$n}->{a})) { $self->log(LOGDEBUG, "match $n in $z"); - push @matches, { + push @matches, + { action => $self->{uribl_zones}->{$z}->{action}, - desc => "$n in $z: " . - ($results->{$z}->{$n}->{txt} || $results->{$z}->{$n}->{a}), - }; + desc => "$n in $z: " + . ( + $results->{$z}->{$n}->{txt} + || $results->{$z}->{$n}->{a} + ), + }; } } } diff --git a/plugins/auth/auth_checkpassword b/plugins/auth/auth_checkpassword index 28d7894..cb84758 100644 --- a/plugins/auth/auth_checkpassword +++ b/plugins/auth/auth_checkpassword @@ -106,12 +106,12 @@ Please see the LICENSE file included with qpsmtpd for details. =cut sub register { - my ($self, $qp, %args ) = @_; + my ($self, $qp, %args) = @_; - my ($checkpw, $true) = $self->get_checkpw( \%args ); - return DECLINED if ! $checkpw || ! $true; + my ($checkpw, $true) = $self->get_checkpw(\%args); + return DECLINED if !$checkpw || !$true; - $self->connection->notes('auth_checkpassword_bin', $checkpw); + $self->connection->notes('auth_checkpassword_bin', $checkpw); $self->connection->notes('auth_checkpassword_true', $true); $self->register_hook('auth-plain', 'auth_checkpassword'); @@ -123,8 +123,8 @@ sub auth_checkpassword { @_; my $binary = $self->connection->notes('auth_checkpassword_bin'); - my $true = $self->connection->notes('auth_checkpassword_true'); - chomp ($binary, $true); + my $true = $self->connection->notes('auth_checkpassword_true'); + chomp($binary, $true); my $sudo = get_sudo($binary); @@ -138,7 +138,7 @@ sub auth_checkpassword { if ($status != 0) { $self->log(LOGNOTICE, "authentication failed ($status)"); return (DECLINED); - }; + } $self->connection->notes('authuser', $user); return (OK, "auth_checkpassword"); @@ -147,42 +147,43 @@ sub auth_checkpassword { sub get_checkpw { my ($self, $args) = @_; - my ($checkpw) = $args->{checkpw} =~ /^(.*)$/ if $args->{checkpw}; # untaint - my ($true) = $args->{true} =~ /^(.*)$/ if $args->{true}; # untaint + 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 ); + 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."; + 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 ); + 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 ); + 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 + 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 + return '' if $mode eq '4711'; # $binary is setuid my $sudo = `which sudo` || '/usr/local/bin/sudo'; - return '' if ! -x $sudo; + return '' if !-x $sudo; $sudo .= ' -C4'; # prevent sudo from clobbering file descriptor 3 diff --git a/plugins/auth/auth_cvm_unix_local b/plugins/auth/auth_cvm_unix_local index c468381..80c893e 100644 --- a/plugins/auth/auth_cvm_unix_local +++ b/plugins/auth/auth_cvm_unix_local @@ -46,24 +46,24 @@ use warnings; use Qpsmtpd::Constants; use Socket; -use constant SMTP_PORT => getservbyname("smtp", "tcp") || 25; +use constant SMTP_PORT => getservbyname("smtp", "tcp") || 25; use constant SSMTP_PORT => getservbyname("ssmtp", "tcp") || 465; sub register { - my ( $self, $qp, %arg ) = @_; + 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->{_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 == SMTP_PORT && $arg{enable_smtp} ne 'yes'); return 0 if ($port == SSMTP_PORT && $arg{enable_ssmtp} ne 'yes'); if ($arg{cvm_socket} =~ /^([\w\/.-]+)$/) { @@ -77,11 +77,12 @@ sub register { $self->register_hook("auth-plain", "authcvm_plain"); $self->register_hook("auth-login", "authcvm_plain"); -# $self->register_hook("auth-cram-md5", "authcvm_hash"); + + # $self->register_hook("auth-cram-md5", "authcvm_hash"); } sub authcvm_plain { - my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) = + my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) = @_; socket(SOCK, PF_UNIX, SOCK_STREAM, 0) or do { @@ -89,41 +90,43 @@ sub authcvm_plain { 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 + # 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 $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 + shutdown SOCK, 1; # tell remote we're finished my $ret = ; - my ($s) = unpack ("C", $ret); + my ($s) = unpack("C", $ret); - if ( ! defined $s ) { + if (!defined $s) { $self->log(LOGERROR, "skip: no response from cvm for $user"); return (DECLINED); - }; + } - if ( $s == 0 ) { + if ($s == 0) { $self->log(LOGINFO, "pass: authentication for: $user"); return (OK, "auth success for $user"); - }; + } - if ( $s == 100 ) { + 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 index 2045009..3d862f8 100644 --- a/plugins/auth/auth_flat_file +++ b/plugins/auth/auth_flat_file @@ -37,7 +37,7 @@ use Qpsmtpd::Auth; use Qpsmtpd::Constants; sub register { - my ( $self, $qp ) = @_; + my ($self, $qp) = @_; $self->register_hook('auth-plain', 'auth_flat_file'); $self->register_hook('auth-login', 'auth_flat_file'); @@ -45,24 +45,25 @@ sub register { } sub auth_flat_file { - my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) = + my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) = @_; - if ( ! defined $passClear && ! defined $passHash ) { + if (!defined $passClear && !defined $passHash) { $self->log(LOGINFO, "fail: missing password"); - return ( DENY, "authflat - missing password" ); + return (DENY, "authflat - missing password"); } - my ( $pw_name, $pw_domain ) = split /@/, lc($user); + my ($pw_name, $pw_domain) = split /@/, lc($user); - unless ( defined $pw_domain ) { + 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'); + my ($auth_line) = + grep { /^$pw_name\@$pw_domain:/ } $self->qp->config('flat_auth_pw'); - if ( ! defined $auth_line) { + if (!defined $auth_line) { $self->log(LOGINFO, "fail: no such user: $user"); return DECLINED; } @@ -70,14 +71,16 @@ sub auth_flat_file { 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, - ); + 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 index 76acae3..a2721b3 100644 --- a/plugins/auth/auth_ldap_bind +++ b/plugins/auth/auth_ldap_bind @@ -136,7 +136,7 @@ sub authldap { 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'}; @@ -149,20 +149,23 @@ sub authldap { }; # find the user's DN - $mesg = $ldh->search( base => $ldbase, - scope => 'sub', - filter => "$ldmattr=$pw_name", - attrs => ['uid'], - timeout => $ldwait, - sizelimit => '1' - ) or do { + $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"); + $self->log(LOGALERT, + "skip: err " . $mesg->code . " in search for user"); return (DECLINED, "authldap - temporary auth error"); } @@ -170,10 +173,10 @@ sub authldap { $ldh->unbind if $ldh; # bind against directory as user with password supplied - if ( ! $mesg->count || $lduserdn = $mesg->entry->dn ) { + 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"); diff --git a/plugins/auth/auth_vpopmail b/plugins/auth/auth_vpopmail index e1dc423..e698cc7 100644 --- a/plugins/auth/auth_vpopmail +++ b/plugins/auth/auth_vpopmail @@ -50,10 +50,10 @@ use Qpsmtpd::Constants; sub register { my ($self, $qp) = @_; - return (DECLINED) if ! $self->test_vpopmail_module(); + 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-plain", "auth_vpopmail"); + $self->register_hook("auth-login", "auth_vpopmail"); $self->register_hook("auth-cram-md5", "auth_vpopmail"); } @@ -61,41 +61,45 @@ sub auth_vpopmail { my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) = @_; - my $pw = vauth_getpw( split /@/, lc($user) ); + 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, - ); + 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 ( $@ ) { + 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; - }; + $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 index 90f08e8..b561cd3 100644 --- a/plugins/auth/auth_vpopmail_sql +++ b/plugins/auth/auth_vpopmail_sql @@ -72,14 +72,14 @@ use Qpsmtpd::Constants; #use DBI; # done in ->register sub register { - my ( $self, $qp ) = @_; + my ($self, $qp) = @_; eval 'use DBI'; - if ( $@ ) { + 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'); @@ -89,27 +89,28 @@ sub register { 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 $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 ); + 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"); @@ -118,16 +119,17 @@ FROM vpopmail WHERE pw_name = ? AND pw_domain = ?"; - my $sth = $dbh->prepare( $query ); - $sth->execute( $pw_name, $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 ($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; @@ -136,21 +138,23 @@ sub auth_vmysql { # 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} ) { + if (!$u->{pw_passwd} && !$u->{pw_clear_passwd}) { $self->log(LOGINFO, "fail: no such user"); - return ( DENY, "auth_vmysql - 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, - ); + 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 index fe51c0c..08e3970 100644 --- a/plugins/auth/auth_vpopmaild +++ b/plugins/auth/auth_vpopmaild @@ -5,7 +5,7 @@ use warnings; use Qpsmtpd::Constants; use IO::Socket; -use version; +use version; my $VERSION = qv('1.0.3'); sub register { @@ -16,58 +16,63 @@ sub register { $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) = @_; + my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) = + @_; - if ( ! $passClear ) { + if (!$passClear) { $self->log(LOGINFO, "skip: vpopmaild does not support cram-md5"); return DECLINED; } # create socket - my $vpopmaild_socket = IO::Socket::INET->new( + my $vpopmaild_socket = + IO::Socket::INET->new( PeerAddr => $self->{_vpopmaild_host}, PeerPort => $self->{_vpopmaild_port}, Proto => 'tcp', Type => SOCK_STREAM - ) or do { + ) + 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 ) { + 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"); + 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 + 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 ) { + 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/ ) { + if ($login_response =~ /^\+OK/) { $self->log(LOGINFO, "pass: clear"); return (OK, 'auth_vpopmaild'); - }; + } chomp $login_response; $self->log(LOGNOTICE, "fail: $login_response"); diff --git a/plugins/auth/authdeny b/plugins/auth/authdeny index deb8537..a06759b 100644 --- a/plugins/auth/authdeny +++ b/plugins/auth/authdeny @@ -13,11 +13,11 @@ the Qpsmtpd::Auth module. Don't run this in production!!! =cut sub hook_auth { - my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) = + my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) = @_; - $self->log( LOGWARN, "fail: cannot authenticate" ); + $self->log(LOGWARN, "fail: cannot authenticate"); - return ( DECLINED, "$user is not free to abuse my relay" ); + return (DECLINED, "$user is not free to abuse my relay"); } diff --git a/plugins/badmailfrom b/plugins/badmailfrom index 4aea3fe..4a8a1b8 100644 --- a/plugins/badmailfrom +++ b/plugins/badmailfrom @@ -59,11 +59,11 @@ anywhere in the string. =cut sub register { - my ($self,$qp) = (shift, shift); - $self->{_args} = { @_ }; + my ($self, $qp) = (shift, shift); + $self->{_args} = {@_}; - $self->{_args}{reject} = 1 if ! defined $self->{_args}{reject}; -}; + $self->{_args}{reject} = 1 if !defined $self->{_args}{reject}; +} sub hook_mail { my ($self, $transaction, $sender, %param) = @_; @@ -71,22 +71,22 @@ sub hook_mail { return DECLINED if $self->is_immune(); my @badmailfrom = $self->qp->config('badmailfrom'); - if ( defined $self->{_badmailfrom_config} ) { # testing + if (defined $self->{_badmailfrom_config}) { # testing @badmailfrom = @{$self->{_badmailfrom_config}}; - }; - return DECLINED if $self->is_immune_sender( $sender, \@badmailfrom ); + } + 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 + $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 ); + next unless $self->is_match($from, $bad, $host); $reason ||= "Your envelope sender is in my badmailfrom list"; - $self->adjust_karma( -1 ); - return $self->get_reject( $reason ); + $self->adjust_karma(-1); + return $self->get_reject($reason); } $self->log(LOGINFO, "pass"); @@ -94,46 +94,46 @@ sub hook_mail { } sub is_match { - my ( $self, $from, $bad, $host ) = @_; + my ($self, $from, $bad, $host) = @_; - if ( $bad =~ /[\/\^\$\*\+\!\%\?\\]/ ) { # it's a regexp - if ( $from =~ /$bad/ ) { + if ($bad =~ /[\/\^\$\*\+\!\%\?\\]/) { # it's a regexp + if ($from =~ /$bad/) { $self->log(LOGDEBUG, "badmailfrom pattern ($bad) match for $from"); return 1; - }; + } return; - }; + } $bad = lc $bad; - if ( $bad !~ m/\@/ ) { + if ($bad !~ m/\@/) { $self->log(LOGWARN, "badmailfrom: bad config: no \@ sign in $bad"); return; - }; - if ( substr($bad,0,1) eq '@' ) { + } + if (substr($bad, 0, 1) eq '@') { return 1 if $bad eq "\@$host"; return; - }; + } return if $bad ne $from; return 1; -}; +} sub is_immune_sender { - my ($self, $sender, $badmf ) = @_; + my ($self, $sender, $badmf) = @_; - if ( ! scalar @$badmf ) { + if (!scalar @$badmf) { $self->log(LOGDEBUG, 'skip, empty list'); return 1; - }; + } - if ( ! $sender || $sender->format eq '<>' ) { + if (!$sender || $sender->format eq '<>') { $self->log(LOGDEBUG, 'skip, null sender'); return 1; - }; + } - if ( ! $sender->host || ! $sender->user ) { + if (!$sender->host || !$sender->user) { $self->log(LOGDEBUG, 'skip, missing user or host'); return 1; - }; + } return; -}; +} diff --git a/plugins/badmailfromto b/plugins/badmailfromto index 351345a..efe46c4 100644 --- a/plugins/badmailfromto +++ b/plugins/badmailfromto @@ -21,27 +21,27 @@ use strict; use Qpsmtpd::Constants; sub hook_mail { - my ($self, $transaction, $sender, %param) = @_; + my ($self, $transaction, $sender, %param) = @_; my @badmailfromto = $self->qp->config("badmailfromto"); - return DECLINED if $self->is_sender_immune( $sender, \@badmailfromto ); + return DECLINED if $self->is_sender_immune($sender, \@badmailfromto); - my $host = lc $sender->host; - my $from = lc($sender->user) . '@' . $host; + 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, '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); + for my $bad (@badmailfromto) { + $bad =~ s/^\s*(\S+).*/$1/; + next unless $bad; + $bad = lc $bad; + if ($bad !~ m/\@/) { + $self->log(LOGWARN, '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 { @@ -52,32 +52,32 @@ sub hook_rcpt { return (DECLINED); }; - foreach ( $self->qp->config("badmailfromto") ) { + 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; + 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 ) = @_; + my ($self, $sender, $badmf) = @_; - if ( ! scalar @$badmf ) { + if (!scalar @$badmf) { $self->log(LOGDEBUG, 'skip, empty list'); return 1; - }; + } - if ( ! $sender || $sender->format eq '<>' ) { + if (!$sender || $sender->format eq '<>') { $self->log(LOGDEBUG, 'skip, null sender'); return 1; - }; + } - if ( ! $sender->host || ! $sender->user ) { + if (!$sender->host || !$sender->user) { $self->log(LOGDEBUG, 'skip, missing user or host'); return 1; - }; + } return; -}; +} diff --git a/plugins/badrcptto b/plugins/badrcptto index 3d15776..3069289 100644 --- a/plugins/badrcptto +++ b/plugins/badrcptto @@ -51,8 +51,8 @@ sub hook_rcpt { return (DECLINED) if $self->is_immune(); - my ($host, $to) = $self->get_host_and_to( $recipient ) - or return (DECLINED); + 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"); @@ -60,71 +60,72 @@ sub hook_rcpt { }; for my $line (@badrcptto) { - $line =~ s/^\s+//g; # trim leading whitespace + $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 ) ) { - $self->adjust_karma( -2 ); - if ( $reason ) { + next if !$bad; + if ($self->is_match($to, lc($bad), $host)) { + $self->adjust_karma(-2); + if ($reason) { return (DENY, "mail to $bad not accepted here"); } else { - return Qpsmtpd::DSN->no_such_user("mail to $bad not accepted here"); + 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 ) = @_; + my ($self, $to, $bad, $host) = @_; - if ( $bad =~ /[\/\^\$\*\+\!\%\?\\]/ ) { # it's a regexp + if ($bad =~ /[\/\^\$\*\+\!\%\?\\]/) { # it's a regexp $self->log(LOGDEBUG, "badmailfrom pattern ($bad) match for $to"); - if ( $to =~ /$bad/i ) { + if ($to =~ /$bad/i) { $self->log(LOGINFO, 'fail: pattern match'); return 1; - }; + } return; - }; + } - if ( $bad !~ m/\@/ ) { + 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" ) { + if (substr($bad, 0, 1) eq '@') { + if ($bad eq "\@$host") { $self->log(LOGINFO, 'fail: host match'); return 1; - }; + } return; - }; + } - if ( $bad eq $to ) { + if ($bad eq $to) { $self->log(LOGINFO, 'fail: rcpt match'); return 1; } return; -}; +} sub get_host_and_to { - my ( $self, $recipient ) = @_; + my ($self, $recipient) = @_; - if ( ! $recipient ) { + if (!$recipient) { $self->log(LOGERROR, 'skip: no recipient!'); return; - }; + } - if ( ! $recipient->host || ! $recipient->user ) { + 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 ); -}; + return ($host, lc($recipient->user) . '@' . $host); +} diff --git a/plugins/bogus_bounce b/plugins/bogus_bounce index a05a5a2..8ab1362 100644 --- a/plugins/bogus_bounce +++ b/plugins/bogus_bounce @@ -40,23 +40,22 @@ Deny with a soft error code. =cut - sub register { my ($self, $qp) = (shift, shift); - if ( @_ % 2 ) { + if (@_ % 2) { $self->{_args}{action} = shift; } else { - $self->{_args} = { @_ }; - }; + $self->{_args} = {@_}; + } - if ( ! defined $self->{_args}{reject} ) { - $self->{_args}{reject} = 0; # legacy default - }; + if (!defined $self->{_args}{reject}) { + $self->{_args}{reject} = 0; # legacy default + } # we only need to check for deferral, default is DENY - if ( $self->{_args}{action} && $self->{_args}{action} =~ /soft/i ) { + if ($self->{_args}{action} && $self->{_args}{action} =~ /soft/i) { $self->{_args}{reject_type} = 'temp'; } } @@ -68,10 +67,10 @@ sub hook_data_post { # Find the sender, quit processing if this isn't a bounce. # my $sender = $transaction->sender->address || undef; - if ( $sender && $sender ne '<>') { + if ($sender && $sender ne '<>') { $self->log(LOGINFO, "pass, not a null sender"); return DECLINED; - }; + } # at this point we know it is a bounce, via the null-envelope. # @@ -80,16 +79,19 @@ sub hook_data_post { my @to = $transaction->recipients || (); if (scalar @to != 1) { $self->log(LOGINFO, "fail, bogus bounce to: " . join(',', @to)); - return $self->get_reject( "fail, this bounce message does not have 1 recipient" ); - }; + return $self->get_reject( + "fail, this bounce message does not have 1 recipient"); + } # validate that Return-Path is empty, RFC 3834 my $rp = $transaction->header->get('Return-Path'); - if ( $rp && $rp ne '<>' ) { - $self->log(LOGINFO, "fail, bounce messages must not have a Return-Path"); - return $self->get_reject( "a bounce return path must be empty (RFC 3834)" ); - }; + if ($rp && $rp ne '<>') { + $self->log(LOGINFO, + "fail, bounce messages must not have a Return-Path"); + return $self->get_reject( + "a bounce return path must be empty (RFC 3834)"); + } $self->log(LOGINFO, "pass, single recipient, empty Return-Path"); return DECLINED; diff --git a/plugins/connection_time b/plugins/connection_time index 2c9d8f7..74ed735 100644 --- a/plugins/connection_time +++ b/plugins/connection_time @@ -32,44 +32,47 @@ use Time::HiRes qw(gettimeofday tv_interval); sub register { my ($self, $qp) = (shift, shift); - if ( @_ == 1 ) { # backwards compatible + if (@_ == 1) { # backwards compatible $self->{_args}{loglevel} = shift; - if ( $self->{_args}{loglevel} =~ /\D/ ) { - $self->{_args}{loglevel} = Qpsmtpd::Constants::log_level($self->{_args}{loglevel}); - }; + 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"); + elsif (@_ % 2) { + $self->log(LOGERROR, "invalid arguments"); } else { - $self->{_args} = { @_ }; # named args, inherits loglevel - }; -# pre-connection is not available in the tcpserver deployment model. -# duplicate the handler, so it works both ways with no redudant methods + $self->{_args} = {@_}; # named args, inherits loglevel + } + + # pre-connection is not available in the tcpserver deployment model. + # duplicate the handler, so it works both ways with no redudant methods $self->register_hook('pre-connection', 'connect_handler'); $self->register_hook('connect', 'connect_handler'); } sub connect_handler { my $self = shift; - return DECLINED if ( $self->hook_name eq 'connect' && defined $self->{_connection_start} ); + return DECLINED + if ($self->hook_name eq 'connect' && defined $self->{_connection_start}); $self->{_connection_start} = [gettimeofday]; - $self->log(LOGDEBUG, "started at " . scalar gettimeofday ); + $self->log(LOGDEBUG, "started at " . scalar gettimeofday); return (DECLINED); } sub hook_post_connection { my $self = shift; - if ( ! $self->{_connection_start} ) { + if (!$self->{_connection_start}) { $self->log(LOGERROR, "Start time not set?!"); return (DECLINED); - }; + } - my $elapsed = tv_interval( $self->{_connection_start}, [gettimeofday] ); + my $elapsed = tv_interval($self->{_connection_start}, [gettimeofday]); - $self->log(LOGINFO, sprintf "%.3f s.", $elapsed ); + $self->log(LOGINFO, sprintf "%.3f s.", $elapsed); return (DECLINED); } diff --git a/plugins/content_log b/plugins/content_log index 696c9e0..3ac6f4d 100644 --- a/plugins/content_log +++ b/plugins/content_log @@ -6,20 +6,20 @@ use POSIX qw:strftime:; sub hook_data_post { - my ($self, $transaction) = @_; + 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"); + # 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; - } + $transaction->header->print($out); + $transaction->body_resetpos; + while (my $line = $transaction->body_getline) { + print $out $line; + } - close $out; + close $out; - return (DECLINED, "successfully saved message.. continuing"); + return (DECLINED, "successfully saved message.. continuing"); } diff --git a/plugins/count_unrecognized_commands b/plugins/count_unrecognized_commands index 5cb6d69..eb02cc0 100644 --- a/plugins/count_unrecognized_commands +++ b/plugins/count_unrecognized_commands @@ -22,28 +22,30 @@ use warnings; use Qpsmtpd::Constants; sub register { - my ($self, $qp ) = (shift, shift); + my ($self, $qp) = (shift, shift); $self->{_unrec_cmd_max} = shift || 4; - if ( scalar @_ ) { + 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); + my ($self, $cmd) = @_[0, 2]; - if ( $count < $self->{_unrec_cmd_max} ) { + 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?" ); + return (DENY_DISCONNECT, +"Closing connection, $count unrecognized commands. Perhaps you should read RFC 2821?" + ); } diff --git a/plugins/dkim b/plugins/dkim index 2b5b5d4..39c6759 100644 --- a/plugins/dkim +++ b/plugins/dkim @@ -172,8 +172,8 @@ use Socket qw(:DEFAULT :crlf); sub init { my ($self, $qp) = (shift, shift); - $self->{_args} = { @_ }; - $self->{_args}{reject} = 1 if ! defined $self->{_args}{reject}; + $self->{_args} = {@_}; + $self->{_args}{reject} = 1 if !defined $self->{_args}{reject}; $self->{_args}{reject_type} ||= 'perm'; } @@ -181,52 +181,55 @@ sub register { my $self = shift; # Mail::DKIM::TextWrap - nice idea, clients get mangled headers though - foreach my $mod ( qw/ Mail::DKIM::Verifier Mail::DKIM::Signer / ) { + foreach my $mod (qw/ Mail::DKIM::Verifier Mail::DKIM::Signer /) { eval "use $mod"; - if ( $@ ) { + if ($@) { warn "error, plugin disabled, could not load $mod\n"; - $self->log(LOGERROR, "skip, plugin disabled, is Mail::DKIM installed?"); + $self->log(LOGERROR, + "skip, plugin disabled, is Mail::DKIM installed?"); return; - }; - }; + } + } $self->register_hook('data_post', 'data_post_handler'); -}; +} sub data_post_handler { my ($self, $transaction) = @_; - if ( $self->qp->connection->relay_client() ) { + if ($self->qp->connection->relay_client()) { + # this is an authenticated user sending a message. - return $self->sign_it( $transaction ); - }; + return $self->sign_it($transaction); + } return DECLINED if $self->is_immune(); - return $self->validate_it( $transaction ); -}; + return $self->validate_it($transaction); +} sub validate_it { my ($self, $transaction) = @_; # Incoming message, perform DKIM validation my $dkim = Mail::DKIM::Verifier->new() or do { - $self->log(LOGERROR, "error, could not instantiate a new Mail::DKIM::Verifier"); + $self->log(LOGERROR, + "error, could not instantiate a new Mail::DKIM::Verifier"); return DECLINED; }; - $self->send_message_to_dkim( $dkim, $transaction ); + $self->send_message_to_dkim($dkim, $transaction); my $result = $dkim->result; - my $mess = $self->get_details( $dkim ); + my $mess = $self->get_details($dkim); - foreach my $t ( qw/ pass fail invalid temperror none / ) { + foreach my $t (qw/ pass fail invalid temperror none /) { next if $t ne $result; my $handler = 'handle_sig_' . $t; $self->log(LOGDEBUG, "dispatching $result to $handler"); - return $self->$handler( $dkim, $mess ); - }; + return $self->$handler($dkim, $mess); + } - $self->log( LOGERROR, "error, unknown result: $result, $mess" ); + $self->log(LOGERROR, "error, unknown result: $result, $mess"); return DECLINED; } @@ -237,277 +240,276 @@ sub sign_it { my $selector = $self->get_selector($keydir); my $dkim = Mail::DKIM::Signer->new( - Algorithm => "rsa-sha256", - Method => "relaxed", - Domain => $domain, - Selector => $selector, - KeyFile => "$keydir/private", - ); + Algorithm => "rsa-sha256", + Method => "relaxed", + Domain => $domain, + Selector => $selector, + KeyFile => "$keydir/private", + ); - $self->send_message_to_dkim( $dkim, $transaction ); + $self->send_message_to_dkim($dkim, $transaction); - my $signature = $dkim->signature; # what is the signature result? - $self->qp->transaction->header->add( - 'DKIM-Signature', $signature->as_string, 0 ); + my $signature = $dkim->signature; # what is the signature result? + $self->qp->transaction->header->add('DKIM-Signature', + $signature->as_string, 0); - $self->log(LOGINFO, "pass, we signed the message" ); + $self->log(LOGINFO, "pass, we signed the message"); return DECLINED; -}; +} sub get_details { - my ($self, $dkim ) = @_; + my ($self, $dkim) = @_; my @data; my $string; - push @data, "domain: " . $dkim->signature->domain if $dkim->signature; + push @data, "domain: " . $dkim->signature->domain if $dkim->signature; push @data, "selector: " . $dkim->signature->selector if $dkim->signature; - push @data, "result: " . $dkim->result_detail if $dkim->result_detail; + push @data, "result: " . $dkim->result_detail if $dkim->result_detail; - foreach my $policy ( $dkim->policies ) { - next if ! $policy; + foreach my $policy ($dkim->policies) { + next if !$policy; push @data, "policy: " . $policy->as_string; - push @data, "name: " . $policy->name; - push @data, "policy_location: " . $policy->location if $policy->location; + push @data, "name: " . $policy->name; + push @data, "policy_location: " . $policy->location + if $policy->location; my $policy_result; $policy_result = $policy->apply($dkim); $policy_result or next; push @data, "policy_result: " . $policy_result if $policy_result; - }; + } return join(', ', @data); -}; +} sub handle_sig_fail { - my ( $self, $dkim, $mess ) = @_; + my ($self, $dkim, $mess) = @_; - $self->adjust_karma( -1 ); - return $self->get_reject( "DKIM signature invalid: " . $dkim->result_detail, $mess ); -}; + $self->adjust_karma(-1); + return + $self->get_reject("DKIM signature invalid: " . $dkim->result_detail, + $mess); +} sub handle_sig_temperror { - my ( $self, $dkim, $mess ) = @_; + my ($self, $dkim, $mess) = @_; - $self->log(LOGINFO, "error, $mess" ); - return ( DENYSOFT, "Please try again later - $dkim->result_detail" ); -}; + $self->log(LOGINFO, "error, $mess"); + return (DENYSOFT, "Please try again later - $dkim->result_detail"); +} sub handle_sig_invalid { - my ( $self, $dkim, $mess ) = @_; + my ($self, $dkim, $mess) = @_; - my ( $prs, $policies) = $self->get_policy_results( $dkim ); + my ($prs, $policies) = $self->get_policy_results($dkim); - foreach my $policy ( @$policies ) { - if ( $policy->signall && ! $policy->is_implied_default_policy ) { - $self->log(LOGINFO, $mess ); - return $self->get_reject( - "invalid DKIM signature with sign-all policy", - "invalid signature, sign-all policy" - ); + foreach my $policy (@$policies) { + if ($policy->signall && !$policy->is_implied_default_policy) { + $self->log(LOGINFO, $mess); + return + $self->get_reject("invalid DKIM signature with sign-all policy", + "invalid signature, sign-all policy"); } - }; + } - $self->adjust_karma( -1 ); - $self->log(LOGINFO, $mess ); + $self->adjust_karma(-1); + $self->log(LOGINFO, $mess); - if ( $prs->{accept} ) { - $self->add_header( $mess ); - $self->log( LOGERROR, "error, invalid signature but accept policy!?" ); + if ($prs->{accept}) { + $self->add_header($mess); + $self->log(LOGERROR, "error, invalid signature but accept policy!?"); return DECLINED; } - elsif ( $prs->{neutral} ) { - $self->add_header( $mess ); - $self->log( LOGERROR, "error, invalid signature but neutral policy?!" ); + elsif ($prs->{neutral}) { + $self->add_header($mess); + $self->log(LOGERROR, "error, invalid signature but neutral policy?!"); return DECLINED; } - elsif ( $prs->{reject} ) { - return $self->get_reject( - "invalid DKIM signature: " . $dkim->result_detail, - "fail, invalid signature, reject policy" - ); + elsif ($prs->{reject}) { + return + $self->get_reject("invalid DKIM signature: " . $dkim->result_detail, + "fail, invalid signature, reject policy"); } # this should never happen - $self->log( LOGINFO, "error, invalid signature, unhandled" ); - $self->add_header( $mess ); + $self->log(LOGINFO, "error, invalid signature, unhandled"); + $self->add_header($mess); return DECLINED; -}; +} sub handle_sig_pass { - my ( $self, $dkim, $mess ) = @_; + my ($self, $dkim, $mess) = @_; - $self->save_signatures_to_note( $dkim ); + $self->save_signatures_to_note($dkim); - my ($prs) = $self->get_policy_results( $dkim ); + my ($prs) = $self->get_policy_results($dkim); - if ( $prs->{accept} ) { - $self->add_header( $mess ); + if ($prs->{accept}) { + $self->add_header($mess); $self->log(LOGINFO, "pass, valid signature, accept policy"); - $self->adjust_karma( 1 ); + $self->adjust_karma(1); return DECLINED; } - elsif ( $prs->{neutral} ) { - $self->add_header( $mess ); + elsif ($prs->{neutral}) { + $self->add_header($mess); $self->log(LOGINFO, "pass, valid signature, neutral policy"); - $self->log(LOGINFO, $mess ); + $self->log(LOGINFO, $mess); return DECLINED; } - elsif ( $prs->{reject} ) { - $self->log(LOGINFO, $mess ); - $self->adjust_karma( -1 ); - return $self->get_reject( - "DKIM signature valid but fails policy, $mess", - "fail, valid sig, reject policy" - ); - }; + elsif ($prs->{reject}) { + $self->log(LOGINFO, $mess); + $self->adjust_karma(-1); + return + $self->get_reject("DKIM signature valid but fails policy, $mess", + "fail, valid sig, reject policy"); + } # this should never happen - $self->add_header( $mess ); - $self->log(LOGERROR, "pass, valid sig, no policy results" ); - $self->log(LOGINFO, $mess ); + $self->add_header($mess); + $self->log(LOGERROR, "pass, valid sig, no policy results"); + $self->log(LOGINFO, $mess); return DECLINED; -}; +} sub handle_sig_none { - my ( $self, $dkim, $mess ) = @_; + my ($self, $dkim, $mess) = @_; - my ( $prs, $policies) = $self->get_policy_results( $dkim ); + my ($prs, $policies) = $self->get_policy_results($dkim); - foreach my $policy ( @$policies ) { - if ( $policy->signall && ! $policy->is_implied_default_policy ) { - $self->log(LOGINFO, $mess ); - return $self->get_reject( - "no DKIM signature with sign-all policy", - "no signature, sign-all policy" - ); + foreach my $policy (@$policies) { + if ($policy->signall && !$policy->is_implied_default_policy) { + $self->log(LOGINFO, $mess); + return + $self->get_reject("no DKIM signature with sign-all policy", + "no signature, sign-all policy"); } - }; + } - if ( $prs->{accept} ) { - $self->log( LOGINFO, "pass, no signature, accept policy" ); + if ($prs->{accept}) { + $self->log(LOGINFO, "pass, no signature, accept policy"); return DECLINED; } - elsif ( $prs->{neutral} ) { - $self->log( LOGINFO, "pass, no signature, neutral policy" ); + elsif ($prs->{neutral}) { + $self->log(LOGINFO, "pass, no signature, neutral policy"); return DECLINED; } - elsif ( $prs->{reject} ) { - $self->log(LOGINFO, $mess ); + elsif ($prs->{reject}) { + $self->log(LOGINFO, $mess); $self->get_reject( - "no DKIM signature, policy says reject: " . $dkim->result_detail, - "no signature, reject policy" - ); - }; + "no DKIM signature, policy says reject: " . $dkim->result_detail, + "no signature, reject policy"); + } # should never happen - $self->log( LOGINFO, "error, no signature, no policy" ); - $self->log(LOGINFO, $mess ); + $self->log(LOGINFO, "error, no signature, no policy"); + $self->log(LOGINFO, $mess); return DECLINED; -}; +} sub get_keydir { my ($self, $transaction) = @_; my $domain = $transaction->sender->host; - my $dir = "config/dkim/$domain"; + my $dir = "config/dkim/$domain"; - if ( ! -e $dir ) { # the dkim key dir doesn't exist - my @labels = split /\./, $domain; # split the domain into labels - while ( @labels > 1 ) { - shift @labels; # remove the first label (ie: www) - my $zone = join '.', @labels; # reassemble the labels - if ( -e "config/dkim/$zone" ) { # if the directory exists - $dir = "config/dkim/$zone"; # use the parent domain's key + if (!-e $dir) { # the dkim key dir doesn't exist + my @labels = split /\./, $domain; # split the domain into labels + while (@labels > 1) { + shift @labels; # remove the first label (ie: www) + my $zone = join '.', @labels; # reassemble the labels + if (-e "config/dkim/$zone") { # if the directory exists + $dir = "config/dkim/$zone"; # use the parent domain's key $self->log(LOGINFO, "info, using $zone key for $domain"); - }; - }; - }; + } + } + } - if ( -l $dir ) { + if (-l $dir) { $dir = readlink($dir); - $dir = "config/dkim/$dir" if $dir !~ /\//; # no /, relative path + $dir = "config/dkim/$dir" if $dir !~ /\//; # no /, relative path ($domain) = (split /\//, $dir)[-1]; - }; + } - if ( ! -d $dir ) { + if (!-d $dir) { $self->log(LOGINFO, "skip, DKIM not configured for $domain"); return; - }; - if ( ! -r $dir ) { + } + if (!-r $dir) { $self->log(LOGINFO, "error, unable to read key from $dir"); return; - }; - if ( ! -r "$dir/private" ) { + } + if (!-r "$dir/private") { $self->log(LOGINFO, "error, unable to read dkim key from $dir/private"); return; - }; + } return ($domain, $dir); -}; +} sub save_signatures_to_note { - my ( $self, $dkim ) = @_; + my ($self, $dkim) = @_; - foreach my $sig ( $dkim->signatures ) { + foreach my $sig ($dkim->signatures) { next if $sig->result ne 'pass'; my $doms = $self->connection->notes('dkim_pass_domains') || []; push @$doms, $sig->domain; $self->connection->notes('dkim_pass_domains', $doms); - $self->log(LOGINFO, "info, added " . $sig->domain ); - }; -}; + $self->log(LOGINFO, "info, added " . $sig->domain); + } +} sub send_message_to_dkim { my ($self, $dkim, $transaction) = @_; - foreach ( split ( /\n/s, $transaction->header->as_string ) ) { + foreach (split(/\n/s, $transaction->header->as_string)) { $_ =~ s/\r?$//s; - eval { $dkim->PRINT ( $_ . CRLF ); }; - $self->log(LOGERROR, $@ ) if $@; + eval { $dkim->PRINT($_ . CRLF); }; + $self->log(LOGERROR, $@) if $@; } $transaction->body_resetpos; while (my $line = $transaction->body_getline) { chomp $line; $line =~ s/\015$//; - eval { $dkim->PRINT($line . CRLF ); }; - $self->log(LOGERROR, $@ ) if $@; - }; + eval { $dkim->PRINT($line . CRLF); }; + $self->log(LOGERROR, $@) if $@; + } $dkim->CLOSE; -}; +} sub get_policies { my ($self, $dkim) = @_; my @policies; eval { @policies = $dkim->policies }; - $self->log(LOGERROR, $@ ) if $@; + $self->log(LOGERROR, $@) if $@; return @policies; -}; +} sub get_policy_results { - my ( $self, $dkim ) = @_; + my ($self, $dkim) = @_; my %prs; - my @policies = $self->get_policies( $dkim ); + my @policies = $self->get_policies($dkim); - foreach my $policy ( @policies ) { + foreach my $policy (@policies) { my $policy_result; eval { $policy_result = $policy->apply($dkim); }; # accept, reject, neutral - if ( $@ ) { - $self->log(LOGERROR, $@ ); - }; + if ($@) { + $self->log(LOGERROR, $@); + } $prs{$policy_result}++ if $policy_result; - }; + } return \%prs, \@policies; -}; +} sub get_selector { my ($self, $keydir) = @_; open my $SFH, '<', "$keydir/selector" or do { - $self->log(LOGINFO, "error, unable to read selector from $keydir/selector"); + $self->log(LOGINFO, + "error, unable to read selector from $keydir/selector"); return DECLINED; }; my $selector = <$SFH>; @@ -515,13 +517,13 @@ sub get_selector { close $SFH; $self->log(LOGINFO, "info, selector: $selector"); return $selector; -}; +} sub add_header { my $self = shift; my $header = shift or return; -# consider adding Authentication-Results header, (RFC 5451) - $self->qp->transaction->header->add( 'X-DKIM-Authentication', $header, 0 ); + # consider adding Authentication-Results header, (RFC 5451) + $self->qp->transaction->header->add('X-DKIM-Authentication', $header, 0); } diff --git a/plugins/dmarc b/plugins/dmarc index c74776b..b3896d3 100644 --- a/plugins/dmarc +++ b/plugins/dmarc @@ -104,261 +104,267 @@ use Qpsmtpd::Constants; sub init { my ($self, $qp) = (shift, shift); - $self->{_args} = { @_ }; - $self->{_args}{reject} = 1 if ! defined $self->{_args}{reject}; + $self->{_args} = {@_}; + $self->{_args}{reject} = 1 if !defined $self->{_args}{reject}; $self->{_args}{reject_type} ||= 'perm'; - $self->{_args}{p_vals} = { map { $_ => 1 } qw/ none reject quarantine / }; + $self->{_args}{p_vals} = {map { $_ => 1 } qw/ none reject quarantine /}; } sub register { my $self = shift; $self->register_hook('data_post', 'data_post_handler'); -}; +} sub data_post_handler { my ($self, $transaction) = @_; return DECLINED if $self->is_immune(); -# 11.1. Extract Author Domain + # 11.1. Extract Author Domain # TODO: check exists_in_dns result, and possibly reject here if domain non-exist - my $from_host = $self->get_from_host( $transaction ) or return DECLINED; - if ( ! $self->exists_in_dns( $from_host ) ) { - my $org_host = $self->get_organizational_domain( $from_host ); - if ( ! $self->exists_in_dns( $org_host ) ) { - $self->log( LOGINFO, "fail, domain/org not in DNS" ); + my $from_host = $self->get_from_host($transaction) or return DECLINED; + if (!$self->exists_in_dns($from_host)) { + my $org_host = $self->get_organizational_domain($from_host); + if (!$self->exists_in_dns($org_host)) { + $self->log(LOGINFO, "fail, domain/org not in DNS"); + #return $self->get_reject(); return DECLINED; - }; - }; + } + } -# 11.2. Determine Handling Policy - my $policy = $self->discover_policy( $from_host ) - or return DECLINED; + # 11.2. Determine Handling Policy + my $policy = $self->discover_policy($from_host) + or return DECLINED; -# 3. Perform DKIM signature verification checks. A single email may -# contain multiple DKIM signatures. The results of this step are -# passed to the remainder of the algorithm and MUST include the -# value of the "d=" tag from all DKIM signatures that successfully -# validated. + # 3. Perform DKIM signature verification checks. A single email may + # contain multiple DKIM signatures. The results of this step are + # passed to the remainder of the algorithm and MUST include the + # value of the "d=" tag from all DKIM signatures that successfully + # validated. my $dkim_sigs = $self->connection->notes('dkim_pass_domains') || []; -# 4. Perform SPF validation checks. The results of this step are -# passed to the remainder of the algorithm and MUST include the -# domain name from the RFC5321.MailFrom if SPF evaluation returned -# a "pass" result. + # 4. Perform SPF validation checks. The results of this step are + # passed to the remainder of the algorithm and MUST include the + # domain name from the RFC5321.MailFrom if SPF evaluation returned + # a "pass" result. my $spf_dom = $transaction->notes('spf_pass_host'); -# 5. Conduct identifier alignment checks. With authentication checks -# and policy discovery performed, the Mail Receiver checks if -# Authenticated Identifiers fall into alignment as decribed in -# Section 4. If one or more of the Authenticated Identifiers align -# with the RFC5322.From domain, the message is considered to pass -# the DMARC mechanism check. All other conditions (authentication -# failures, identifier mismatches) are considered to be DMARC -# mechanism check failures. - foreach ( @$dkim_sigs ) { - if ( $_ eq $from_host ) { # strict alignment + # 5. Conduct identifier alignment checks. With authentication checks + # and policy discovery performed, the Mail Receiver checks if + # Authenticated Identifiers fall into alignment as decribed in + # Section 4. If one or more of the Authenticated Identifiers align + # with the RFC5322.From domain, the message is considered to pass + # the DMARC mechanism check. All other conditions (authentication + # failures, identifier mismatches) are considered to be DMARC + # mechanism check failures. + foreach (@$dkim_sigs) { + if ($_ eq $from_host) { # strict alignment $self->log(LOGINFO, "pass, DKIM alignment"); - $self->adjust_karma( 2 ); # big karma boost + $self->adjust_karma(2); # big karma boost return DECLINED; - }; - }; + } + } - if ( $spf_dom && $spf_dom eq $from_host ) { - $self->adjust_karma( 2 ); # big karma boost + if ($spf_dom && $spf_dom eq $from_host) { + $self->adjust_karma(2); # big karma boost $self->log(LOGINFO, "pass, SPF alignment"); return DECLINED; - }; + } -# 6. Apply policy. Emails that fail the DMARC mechanism check are -# disposed of in accordance with the discovered DMARC policy of the -# Domain Owner. See Section 6.2 for details. + # 6. Apply policy. Emails that fail the DMARC mechanism check are + # disposed of in accordance with the discovered DMARC policy of the + # Domain Owner. See Section 6.2 for details. $self->log(LOGINFO, "skip, NEED RELAXED alignment"); return DECLINED; -}; +} sub discover_policy { my ($self, $from_host) = @_; -# 1. Mail Receivers MUST query the DNS for a DMARC TXT record at the -# DNS domain matching the one found in the RFC5322.From domain in -# the message. A possibly empty set of records is returned. - my @matches = $self->fetch_dmarc_record($from_host); # 2. within - if ( 0 == scalar @matches ) { -# 3. If the set is now empty, the Mail Receiver MUST query the DNS for -# a DMARC TXT record at the DNS domain matching the Organizational -# Domain in place of the RFC5322.From domain in the message (if -# different). This record can contain policy to be asserted for -# subdomains of the Organizational Domain. + # 1. Mail Receivers MUST query the DNS for a DMARC TXT record at the + # DNS domain matching the one found in the RFC5322.From domain in + # the message. A possibly empty set of records is returned. + my @matches = $self->fetch_dmarc_record($from_host); # 2. within + if (0 == scalar @matches) { - my $org_dom = $self->get_organizational_domain( $from_host ) or return; - if ( $org_dom eq $from_host ) { - $self->log( LOGINFO, "skip, no policy for $from_host (same org)" ); + # 3. If the set is now empty, the Mail Receiver MUST query the DNS for + # a DMARC TXT record at the DNS domain matching the Organizational + # Domain in place of the RFC5322.From domain in the message (if + # different). This record can contain policy to be asserted for + # subdomains of the Organizational Domain. + + my $org_dom = $self->get_organizational_domain($from_host) or return; + if ($org_dom eq $from_host) { + $self->log(LOGINFO, "skip, no policy for $from_host (same org)"); return; - }; + } @matches = $self->fetch_dmarc_record($org_dom); - if ( 0 == scalar @matches ) { - $self->log( LOGINFO, "skip, no policy for $from_host" ); + if (0 == scalar @matches) { + $self->log(LOGINFO, "skip, no policy for $from_host"); return; - }; - }; + } + } -# 4. Records that do not include a "v=" tag that identifies the -# current version of DMARC are discarded. + # 4. Records that do not include a "v=" tag that identifies the + # current version of DMARC are discarded. @matches = grep /v=DMARC1/i, @matches; - if ( 0 == scalar @matches ) { - $self->log( LOGINFO, "skip, no valid record for $from_host" ); + if (0 == scalar @matches) { + $self->log(LOGINFO, "skip, no valid record for $from_host"); return; - }; + } -# 5. If the remaining set contains multiple records, processing -# terminates and the Mail Receiver takes no action. - if ( @matches > 1 ) { - $self->log( LOGINFO, "skip, too many records" ); + # 5. If the remaining set contains multiple records, processing + # terminates and the Mail Receiver takes no action. + if (@matches > 1) { + $self->log(LOGINFO, "skip, too many records"); return; - }; + } -# 6. If a retrieved policy record does not contain a valid "p" tag, or -# contains an "sp" tag that is not valid, then: - my %policy = $self->parse_policy( $matches[0] ); - if ( ! $self->has_valid_p(\%policy) || $self->has_invalid_sp(\%policy) ) { + # 6. If a retrieved policy record does not contain a valid "p" tag, or + # contains an "sp" tag that is not valid, then: + my %policy = $self->parse_policy($matches[0]); + if (!$self->has_valid_p(\%policy) || $self->has_invalid_sp(\%policy)) { -# A. if an "rua" tag is present and contains at least one -# syntactically valid reporting URI, the Mail Receiver SHOULD -# act as if a record containing a valid "v" tag and "p=none" -# was retrieved, and continue processing; -# B. otherwise, the Mail Receiver SHOULD take no action. + # A. if an "rua" tag is present and contains at least one + # syntactically valid reporting URI, the Mail Receiver SHOULD + # act as if a record containing a valid "v" tag and "p=none" + # was retrieved, and continue processing; + # B. otherwise, the Mail Receiver SHOULD take no action. my $rua = $policy{rua}; - if ( ! $rua || ! $self->has_valid_reporting_uri($rua) ) { - $self->log( LOGINFO, "skip, no valid reporting rua" ); + if (!$rua || !$self->has_valid_reporting_uri($rua)) { + $self->log(LOGINFO, "skip, no valid reporting rua"); return; - }; + } $policy{v} = 'DMARC1'; $policy{p} = 'none'; - }; + } return \%policy; -}; +} sub has_valid_p { my ($self, $policy) = @_; return 1 if $self->{_args}{p_vals}{$policy}; return 0; -}; +} sub has_invalid_sp { my ($self, $policy) = @_; - return 0 if ! $self->{_args}{p_vals}{$policy}; + return 0 if !$self->{_args}{p_vals}{$policy}; return 1; -}; +} sub has_valid_reporting_uri { my ($self, $rua) = @_; return 1 if 'mailto:' eq lc substr($rua, 0, 7); return 0; -}; +} sub get_organizational_domain { my ($self, $from_host) = @_; -# 1. Acquire a "public suffix" list, i.e., a list of DNS domain -# names reserved for registrations. http://publicsuffix.org/list/ -# $self->qp->config('public_suffix_list') + # 1. Acquire a "public suffix" list, i.e., a list of DNS domain + # names reserved for registrations. http://publicsuffix.org/list/ + # $self->qp->config('public_suffix_list') -# 2. Break the subject DNS domain name into a set of "n" ordered -# labels. Number these labels from right-to-left; e.g. for -# "example.com", "com" would be label 1 and "example" would be -# label 2.; + # 2. Break the subject DNS domain name into a set of "n" ordered + # labels. Number these labels from right-to-left; e.g. for + # "example.com", "com" would be label 1 and "example" would be + # label 2.; my @labels = reverse split /\./, $from_host; -# 3. Search the public suffix list for the name that matches the -# largest number of labels found in the subject DNS domain. Let -# that number be "x". + # 3. Search the public suffix list for the name that matches the + # largest number of labels found in the subject DNS domain. Let + # that number be "x". my $greatest = 0; - for ( my $i = 0; $i <= scalar @labels; $i++ ) { - next if ! $labels[$i]; - my $tld = join '.', reverse( (@labels)[0..$i] ); -# $self->log( LOGINFO, "i: $i, $tld" ); -#warn "i: $i - tld: $tld\n"; - if ( grep /$tld/, $self->qp->config('public_suffix_list') ) { + for (my $i = 0 ; $i <= scalar @labels ; $i++) { + next if !$labels[$i]; + my $tld = join '.', reverse((@labels)[0 .. $i]); + + # $self->log( LOGINFO, "i: $i, $tld" ); + #warn "i: $i - tld: $tld\n"; + if (grep /$tld/, $self->qp->config('public_suffix_list')) { $greatest = $i + 1; - }; - }; + } + } - return $from_host if $greatest == scalar @labels; # same + return $from_host if $greatest == scalar @labels; # same -# 4. Construct a new DNS domain name using the name that matched -# from the public suffix list and prefixing to it the "x+1"th -# label from the subject domain. This new name is the -# Organizational Domain. - return join '.', reverse( (@labels)[0..$greatest]); -}; + # 4. Construct a new DNS domain name using the name that matched + # from the public suffix list and prefixing to it the "x+1"th + # label from the subject domain. This new name is the + # Organizational Domain. + return join '.', reverse((@labels)[0 .. $greatest]); +} sub exists_in_dns { my ($self, $domain) = @_; my $res = $self->init_resolver(); - my $query = $res->send( $domain, 'NS' ) or do { - if ( $res->errorstring eq 'NXDOMAIN' ) { - $self->log( LOGDEBUG, "fail, non-existent domain: $domain" ); + my $query = $res->send($domain, 'NS') or do { + if ($res->errorstring eq 'NXDOMAIN') { + $self->log(LOGDEBUG, "fail, non-existent domain: $domain"); return; - }; - $self->log( LOGINFO, "error, looking up NS for $domain: " . $res->errorstring ); + } + $self->log(LOGINFO, + "error, looking up NS for $domain: " . $res->errorstring); return; }; my @matches; for my $rr ($query->answer) { next if $rr->type ne 'NS'; push @matches, $rr->nsdname; - }; - if ( 0 == scalar @matches ) { - $self->log( LOGDEBUG, "fail, zero NS for $domain" ); - }; + } + if (0 == scalar @matches) { + $self->log(LOGDEBUG, "fail, zero NS for $domain"); + } return @matches; -}; +} sub fetch_dmarc_record { my ($self, $zone) = @_; my $res = $self->init_resolver(); - my $query = $res->send( '_dmarc.' . $zone, 'TXT' ); + my $query = $res->send('_dmarc.' . $zone, 'TXT'); my @matches; for my $rr ($query->answer) { next if $rr->type ne 'TXT'; -# 2. Records that do not start with a "v=" tag that identifies the -# current version of DMARC are discarded. - next if 'v=' ne substr( $rr->txtdata, 0, 2); - $self->log( LOGINFO, $rr->txtdata ); + + # 2. Records that do not start with a "v=" tag that identifies the + # current version of DMARC are discarded. + next if 'v=' ne substr($rr->txtdata, 0, 2); + $self->log(LOGINFO, $rr->txtdata); push @matches, join('', $rr->txtdata); - }; + } return @matches; -}; +} sub get_from_host { my ($self, $transaction) = @_; my $from = $transaction->header->get('From') or do { - $self->log( LOGINFO, "error, unable to retrieve From header!" ); + $self->log(LOGINFO, "error, unable to retrieve From header!"); return; }; - my ($from_host) = (split /@/, $from)[-1]; # grab everything after the @ - ($from_host) = split /\s+/, $from_host; # remove any trailing cruft + my ($from_host) = (split /@/, $from)[-1]; # grab everything after the @ + ($from_host) = split /\s+/, $from_host; # remove any trailing cruft chomp $from_host; - chop $from_host if '>' eq substr($from_host,-1,1); - $self->log( LOGDEBUG, "info, from_host is $from_host" ); + chop $from_host if '>' eq substr($from_host, -1, 1); + $self->log(LOGDEBUG, "info, from_host is $from_host"); return $from_host; -}; +} sub parse_policy { my ($self, $str) = @_; - $str =~ s/\s//g; # remove all whitespace + $str =~ s/\s//g; # remove all whitespace my %dmarc = map { split /=/, $_ } split /;/, $str; -#warn Data::Dumper::Dumper(\%dmarc); + + #warn Data::Dumper::Dumper(\%dmarc); return %dmarc; -}; +} sub verify_external_reporting { @@ -396,4 +402,4 @@ sub verify_external_reporting { =cut -}; +} diff --git a/plugins/dns_whitelist_soft b/plugins/dns_whitelist_soft index dc3785d..9ac5cf4 100644 --- a/plugins/dns_whitelist_soft +++ b/plugins/dns_whitelist_soft @@ -55,56 +55,58 @@ use warnings; use Qpsmtpd::Constants; sub register { - my ( $self, $qp ) = (shift, shift); + my ($self, $qp) = (shift, shift); $self->log(LOGERROR, "Bad arguments") if @_ % 2; - $self->{_args} = { @_ }; + $self->{_args} = {@_}; } sub hook_connect { - my ($self, $transaction) = @_; + my ($self, $transaction) = @_; - my $remote_ip = $self->qp->connection->remote_ip; + my $remote_ip = $self->qp->connection->remote_ip; - my %whitelist_zones = map { (split /\s+/, $_, 2)[0,1] } - $self->qp->config('whitelist_zones'); + my %whitelist_zones = + map { (split /\s+/, $_, 2)[0, 1] } $self->qp->config('whitelist_zones'); - return DECLINED unless %whitelist_zones; + return DECLINED unless %whitelist_zones; - my $reversed_ip = join('.', reverse(split(/\./, $remote_ip))); + 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 + # 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(); + 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')); - } + 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; + $self->connection->notes('whitelist_sockets', $sel); + return DECLINED; } sub process_sockets { - my ($self) = @_; + my ($self) = @_; - my $conn = $self->connection; + my $conn = $self->connection; - return $conn->notes('whitelisthost') if $conn->notes('whitelisthost'); + return $conn->notes('whitelisthost') if $conn->notes('whitelisthost'); - my $res = new Net::DNS::Resolver; - my $sel = $conn->notes('whitelist_sockets') or return ''; + my $res = new Net::DNS::Resolver; + my $sel = $conn->notes('whitelist_sockets') or return ''; - $self->log(LOGDEBUG, "waiting for whitelist dns"); + $self->log(LOGDEBUG, "waiting for whitelist dns"); - # don't wait more than 4 seconds here - my @ready = $sel->can_read(4); + # 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; + $self->log(LOGDEBUG, + "done waiting for whitelist dns, got ", + scalar @ready, + " answers ..."); + return '' unless @ready; my $result; @@ -131,36 +133,38 @@ sub process_sockets { } else { $self->log(LOGERROR, "$whitelist query failed: ", $res->errorstring) - if $res->errorstring ne "NXDOMAIN"; + if $res->errorstring ne "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(); - } + if ($sel->count) { - # er, the following code doesn't make much sense anymore... + # loop around if we have dns blacklists left to see results from + return $self->process_sockets(); + } - # if there was more to read; then forget it - $conn->notes('whitelist_sockets', undef); + # er, the following code doesn't make much sense anymore... - return $conn->notes('whitelisthost', $result); + # 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 or return (DECLINED); - my $note = $self->process_sockets; - if ( $note ) { - $self->log(LOGNOTICE,"Host $ip is whitelisted: $note"); - } - return DECLINED; + my ($self, $transaction, $rcpt, %param) = @_; + my $ip = $self->qp->connection->remote_ip or return (DECLINED); + my $note = $self->process_sockets; + if ($note) { + $self->log(LOGNOTICE, "Host $ip is whitelisted: $note"); + } + return DECLINED; } diff --git a/plugins/dnsbl b/plugins/dnsbl index 4a055fc..4f48270 100644 --- a/plugins/dnsbl +++ b/plugins/dnsbl @@ -135,20 +135,20 @@ See: https://github.com/smtpd/qpsmtpd/commits/master/plugins/dnsbl sub register { my ($self, $qp) = (shift, shift); - if ( @_ % 2 ) { - $self->{_args}{reject_type} = shift; # backwards compatibility + if (@_ % 2) { + $self->{_args}{reject_type} = shift; # backwards compatibility } else { - $self->{_args} = { @_ }; - }; + $self->{_args} = {@_}; + } # explicitly state legacy reject behavior - if ( ! defined $self->{_args}{reject_type} ) { + if (!defined $self->{_args}{reject_type}) { $self->{_args}{reject_type} = 'perm'; - }; - if ( ! defined $self->{_args}{reject} ) { + } + if (!defined $self->{_args}{reject}) { $self->{_args}{reject} = 1; - }; + } } sub hook_connect { @@ -156,76 +156,79 @@ sub hook_connect { # perform RBLSMTPD checks to mimic DJB's rblsmtpd # RBLSMTPD being non-empty means it contains the failure message to return - if ( defined $ENV{'RBLSMTPD'} && $ENV{'RBLSMTPD'} ne '' ) { + if (defined $ENV{'RBLSMTPD'} && $ENV{'RBLSMTPD'} ne '') { my $reject = $self->{_args}{reject}; return $self->return_env_message() if $reject && $reject eq 'connect'; - }; + } return DECLINED if $self->is_immune(); return DECLINED if $self->is_set_rblsmtpd(); return DECLINED if $self->ip_whitelisted(); my $dnsbl_zones = $self->get_dnsbl_zones() or return DECLINED; - my $resolv = $self->get_resolver() or return DECLINED; + my $resolv = $self->get_resolver() or return DECLINED; - for my $dnsbl ( keys %$dnsbl_zones ) { + for my $dnsbl (keys %$dnsbl_zones) { - my $query = $self->get_query( $dnsbl ) or do { - if ( $resolv->errorstring ne 'NXDOMAIN' ) { - $self->log(LOGERROR, "$dnsbl query failed: ", $resolv->errorstring); - }; + my $query = $self->get_query($dnsbl) or do { + if ($resolv->errorstring ne 'NXDOMAIN') { + $self->log(LOGERROR, "$dnsbl query failed: ", + $resolv->errorstring); + } next; }; my $a_record = 0; my $result; foreach my $rr ($query->answer) { - if ( $rr->type eq 'A' ) { + if ($rr->type eq 'A') { $result = $rr->name; - $self->log(LOGDEBUG, "found A for $result with IP " . $rr->address); + $self->log(LOGDEBUG, + "found A for $result with IP " . $rr->address); } elsif ($rr->type eq 'TXT') { $self->log(LOGDEBUG, "found TXT, " . $rr->txtdata); $result = $rr->txtdata; - }; + } - next if ! $result; + next if !$result; - $self->adjust_karma( -1 ); + $self->adjust_karma(-1); - if ( ! $dnsbl ) { ($dnsbl) = ($result =~ m/(?:\d+\.){4}(.*)/); }; - if ( ! $dnsbl ) { $dnsbl = $result; }; + if (!$dnsbl) { ($dnsbl) = ($result =~ m/(?:\d+\.){4}(.*)/); } + if (!$dnsbl) { $dnsbl = $result; } if ($a_record) { if (defined $dnsbl_zones->{$dnsbl}) { - my $smtp_msg = $dnsbl_zones->{$dnsbl}; - my $remote_ip= $self->qp->connection->remote_ip; + my $smtp_msg = $dnsbl_zones->{$dnsbl}; + my $remote_ip = $self->qp->connection->remote_ip; $smtp_msg =~ s/%IP%/$remote_ip/g; - return $self->get_reject( $smtp_msg, $dnsbl ); + return $self->get_reject($smtp_msg, $dnsbl); } - return $self->get_reject( "Blocked by $dnsbl" ); + return $self->get_reject("Blocked by $dnsbl"); } - return $self->get_reject( $result, $dnsbl ); + return $self->get_reject($result, $dnsbl); } } $self->log(LOGINFO, 'pass'); return DECLINED; -}; +} sub get_dnsbl_zones { my $self = shift; - my %dnsbl_zones = map { (split /:/, $_, 2)[0,1] } $self->qp->config('dnsbl_zones'); - if ( ! %dnsbl_zones ) { - $self->log( LOGDEBUG, "skip, no zones"); + my %dnsbl_zones = + map { (split /:/, $_, 2)[0, 1] } $self->qp->config('dnsbl_zones'); + if (!%dnsbl_zones) { + $self->log(LOGDEBUG, "skip, no zones"); return; - }; + } $self->{_dnsbl}{zones} = \%dnsbl_zones; return \%dnsbl_zones; -}; +} sub get_query { my ($self, $dnsbl) = @_; @@ -234,24 +237,24 @@ sub get_query { my $reversed_ip = join('.', reverse(split(/\./, $remote_ip))); # fix to find A records, if the dnsbl_zones line has a second field 20/1/04 ++msp - if ( defined $self->{_dnsbl}{zones}{$dnsbl} ) { + if (defined $self->{_dnsbl}{zones}{$dnsbl}) { $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for A record"); return $self->{_resolver}->query("$reversed_ip.$dnsbl"); - }; + } $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for TXT record"); return $self->{_resolver}->query("$reversed_ip.$dnsbl", 'TXT'); -}; +} sub is_set_rblsmtpd { my $self = shift; my $remote_ip = $self->qp->connection->remote_ip; - if ( ! defined $ENV{'RBLSMTPD'} ) { + 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"); @@ -259,38 +262,39 @@ sub is_set_rblsmtpd { } $self->log(LOGINFO, "RBLSMTPD set, but empty for $remote_ip"); - return 1; # don't return empty string, it evaluates to false -}; + return 1; # don't return empty string, it evaluates to false +} sub ip_whitelisted { my ($self) = @_; my $remote_ip = $self->qp->connection->remote_ip; - return grep { s/\.?$/./; - $_ eq substr($remote_ip . '.', 0, length $_) - } - $self->qp->config('dnsbl_allow'); -}; + return grep { + s/\.?$/./; + $_ eq substr($remote_ip . '.', 0, length $_) + } $self->qp->config('dnsbl_allow'); +} sub return_env_message { - my $self = shift; - my $result = $ENV{'RBLSMTPD'}; + my $self = shift; + 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'); + my $msg = $self->qp->config('dnsbl_rejectmsg'); $self->log(LOGINFO, "fail, $msg"); - return ( $self->get_reject_type(), join(' ', $msg, $result)); + return ($self->get_reject_type(), join(' ', $msg, $result)); } sub hook_rcpt { my ($self, $transaction, $rcpt, %param) = @_; - if ( $rcpt->user =~ /^(?:postmaster|abuse|mailer-daemon|root)$/i ) { - $self->log(LOGWARN, "skip, don't blacklist special account: ".$rcpt->user); + if ($rcpt->user =~ /^(?:postmaster|abuse|mailer-daemon|root)$/i) { + $self->log(LOGWARN, + "skip, don't blacklist special account: " . $rcpt->user); # clear the naughty connection note here, if desired. - $self->connection->notes('naughty', 0 ); + $self->connection->notes('naughty', 0); } return DECLINED; @@ -299,11 +303,11 @@ sub hook_rcpt { sub get_resolver { my $self = shift; return $self->{_resolver} if $self->{_resolver}; - $self->log( LOGDEBUG, "initializing Net::DNS::Resolver"); + $self->log(LOGDEBUG, "initializing Net::DNS::Resolver"); $self->{_resolver} = Net::DNS::Resolver->new(dnsrch => 0); my $timeout = $self->{_args}{timeout} || 30; $self->{_resolver}->tcp_timeout($timeout); $self->{_resolver}->udp_timeout($timeout); return $self->{_resolver}; -}; +} diff --git a/plugins/domainkeys b/plugins/domainkeys index b01a814..eac7abb 100644 --- a/plugins/domainkeys +++ b/plugins/domainkeys @@ -57,68 +57,69 @@ use Qpsmtpd::Constants; sub init { my ($self, $qp, %args) = @_; - foreach my $key ( %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}; + $self->{reject} = 1 if !defined $self->{reject}; # default reject + $self->{reject_type} = 'perm' if !defined $self->{reject_type}; - if ( $args{'warn_only'} ) { + 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 / ) { + for my $m (qw/ Mail::DomainKeys::Message Mail::DomainKeys::Policy /) { eval "use $m"; - if ( $@ ) { + 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') ) { + if (!$transaction->header->get('DomainKey-Signature')) { $self->log(LOGINFO, "skip, unsigned"); return DECLINED; - }; + } - my $body = $self->assemble_body( $transaction ); + 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; - }; + 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 ) { + if (!$message->senderdomain) { $self->log(LOGINFO, "skip, failed to parse sender domain"), - return DECLINED; - }; + return DECLINED; + } - my $status = $self->get_message_status( $message ); + my $status = $self->get_message_status($message); - if ( defined $status ) { + if (defined $status) { $transaction->header->add("DomainKey-Status", $status, 0); $self->log(LOGINFO, "pass, $status"); return DECLINED; - }; + } $self->log(LOGERROR, "fail, signature invalid"); - return DECLINED if ! $self->{reject}; + return DECLINED if !$self->{reject}; my $deny = $self->{reject_type} eq 'temp' ? DENYSOFT : DENY; return ($deny, "DomainKeys signature validation failed"); } @@ -126,45 +127,44 @@ sub data_post_handler { sub get_message_status { my ($self, $message) = @_; - if ( $message->testing ) { - return "testing"; # key testing, don't do anything else - }; + 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 - }; + 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 - ); + my $policy = + fetch Mail::DomainKeys::Policy(Protocol => 'dns', + Domain => $message->senderdomain); - if ( ! $policy ) { + if (!$policy) { return $message->signed ? "non-participant" : "no signature"; - }; + } - if ( $policy->testing ) { - return "testing"; # Don't do anything else - }; + if ($policy->testing) { + return "testing"; # Don't do anything else + } - if ( $policy->signall ) { - return undef; # policy requires all mail to be signed - }; + 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 -}; + 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 + $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 index 000030a..b81df88 100644 --- a/plugins/dont_require_anglebrackets +++ b/plugins/dont_require_anglebrackets @@ -1,5 +1,5 @@ #!perl -w - + =head1 NAME dont_require_anglebrackets @@ -22,19 +22,19 @@ MAIL FROM:user@example.com =cut sub hook_mail_pre { - my ($self,$transaction, $addr) = @_; + my ($self, $transaction, $addr) = @_; unless ($addr =~ /^<.*>$/) { $self->log(LOGINFO, "added MAIL angle brackets"); - $addr = '<'.$addr.'>'; + $addr = '<' . $addr . '>'; } return (OK, $addr); } sub hook_rcpt_pre { - my ($self,$transaction, $addr) = @_; + my ($self, $transaction, $addr) = @_; unless ($addr =~ /^<.*>$/) { $self->log(LOGINFO, "added RCPT angle brackets"); - $addr = '<'.$addr.'>'; + $addr = '<' . $addr . '>'; } return (OK, $addr); } diff --git a/plugins/dspam b/plugins/dspam index 593a129..39849a9 100644 --- a/plugins/dspam +++ b/plugins/dspam @@ -212,10 +212,10 @@ sub register { $self->log(LOGERROR, "Bad parameters for the dspam plugin") if @_ % 2; - $self->{_args} = { @_ }; - $self->{_args}{reject} = 1 if ! defined $self->{_args}{reject}; + $self->{_args} = {@_}; + $self->{_args}{reject} = 1 if !defined $self->{_args}{reject}; $self->{_args}{reject_type} ||= 'perm'; - $self->{_args}{dspam_bin} ||= '/usr/local/bin/dspam'; + $self->{_args}{dspam_bin} ||= '/usr/local/bin/dspam'; $self->get_dspam_bin() or return DECLINED; @@ -226,16 +226,18 @@ sub get_dspam_bin { my $self = shift; my $bin = $self->{_args}{dspam_bin}; - if ( ! -e $bin ) { - $self->log(LOGERROR, "error, dspam CLI binary not found: install dspam and/or set dspam_bin"); + if (!-e $bin) { + $self->log(LOGERROR, +"error, dspam CLI binary not found: install dspam and/or set dspam_bin" + ); return; - }; - if ( ! -x $bin ) { + } + if (!-x $bin) { $self->log(LOGERROR, "error, no permission to run $bin"); return; - }; + } return $bin; -}; +} sub data_post_handler { my $self = shift; @@ -243,29 +245,30 @@ sub data_post_handler { return (DECLINED) if $self->is_immune(); - if ( $transaction->data_size > 500_000 ) { - $self->log(LOGINFO, "skip, too big (" . $transaction->data_size . ")" ); + if ($transaction->data_size > 500_000) { + $self->log(LOGINFO, "skip, too big (" . $transaction->data_size . ")"); return (DECLINED); - }; + } - my $user = $self->select_username( $transaction ); + my $user = $self->select_username($transaction); my $bin = $self->{_args}{dspam_bin}; - my $filtercmd = "$bin --user $user --mode=tum --process --deliver=summary --stdout"; + my $filtercmd = + "$bin --user $user --mode=tum --process --deliver=summary --stdout"; $self->log(LOGDEBUG, $filtercmd); - my $response = $self->dspam_process( $filtercmd, $transaction ); - if ( ! $response->{result} ) { + my $response = $self->dspam_process($filtercmd, $transaction); + if (!$response->{result}) { $self->log(LOGWARN, "error, no dspam response. Check logs for errors."); return (DECLINED); - }; + } $transaction->notes('dspam', $response); - $self->attach_headers( $response, $transaction ); - $self->autolearn( $response, $transaction ); + $self->attach_headers($response, $transaction); + $self->autolearn($response, $transaction); - return $self->log_and_return( $transaction ); -}; + return $self->log_and_return($transaction); +} sub select_username { my ($self, $transaction) = @_; @@ -273,34 +276,36 @@ sub select_username { my $recipient_count = scalar $transaction->recipients; $self->log(LOGDEBUG, "Message has $recipient_count recipients"); - if ( $recipient_count > 1 ) { - $self->log(LOGINFO, "multiple recipients ($recipient_count), ignoring user prefs"); + if ($recipient_count > 1) { + $self->log(LOGINFO, + "multiple recipients ($recipient_count), ignoring user prefs"); return getpwuid($>); - }; + } -# use the recipients email address as username. This enables user prefs + # 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) = @_; - my $message = "X-Envelope-From: " - . $transaction->sender->format . "\n" - . $transaction->header->as_string . "\n\n"; + my $message = + "X-Envelope-From: " + . $transaction->sender->format . "\n" + . $transaction->header->as_string . "\n\n"; $transaction->body_resetpos; - while (my $line = $transaction->body_getline) { $message .= $line; }; + while (my $line = $transaction->body_getline) { $message .= $line; } $message = join(CRLF, split /\n/, $message); return $message . CRLF; -}; +} sub parse_response { my $self = shift; my $response = shift or do { - $self->log( LOGDEBUG, "missing dspam response!" ); + $self->log(LOGDEBUG, "missing dspam response!"); return; }; @@ -313,22 +318,22 @@ sub parse_response { my ($user, $result, $class, $prob, $conf, $sig) = split /; /, $response; (undef, $result) = split /=/, $result; - (undef, $class ) = split /=/, $class; - (undef, $prob ) = split /=/, $prob; - (undef, $conf ) = split /=/, $conf; - (undef, $sig ) = split /=/, $sig; + (undef, $class) = split /=/, $class; + (undef, $prob) = split /=/, $prob; + (undef, $conf) = split /=/, $conf; + (undef, $sig) = split /=/, $sig; - $result = substr($result, 1, -1); # strip off quotes + $result = substr($result, 1, -1); # strip off quotes $class = substr($class, 1, -1); return { - class => $class, - result => $result, - probability => $prob, - confidence => $conf, - signature => $sig, - }; -}; + class => $class, + result => $result, + probability => $prob, + confidence => $conf, + signature => $sig, + }; +} sub parse_response_regexp { my ($self, $response) = @_; @@ -342,107 +347,114 @@ sub parse_response_regexp { /x; return { - class => $class, - result => $result, - probability => $prob, - confidence => $conf, - signature => $sig, - }; -}; + class => $class, + result => $result, + probability => $prob, + confidence => $conf, + signature => $sig, + }; +} sub dspam_process { - my ( $self, $filtercmd, $transaction ) = @_; + my ($self, $filtercmd, $transaction) = @_; + + my $response = $self->dspam_process_backticks($filtercmd); - my $response = $self->dspam_process_backticks( $filtercmd ); #my $response = $self->dspam_process_open2( $filtercmd, $transaction ); #my $response = $self->dspam_process_fork( $filtercmd ); - return $self->parse_response( $response ); -}; + return $self->parse_response($response); +} sub dspam_process_fork { - my ( $self, $filtercmd, $transaction ) = @_; + my ($self, $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 $message = $self->assemble_message($transaction); my $in_fh; - if (! open($in_fh, '-|')) { # forks child for writing + 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 ($self, $filtercmd) = @_; my $transaction = $self->qp->transaction; my $message = $self->temp_file(); open my $fh, '>', $message; print $fh "X-Envelope-From: " - . $transaction->sender->format . CRLF - . $transaction->header->as_string . CRLF . CRLF; + . $transaction->sender->format + . CRLF + . $transaction->header->as_string + . CRLF + . CRLF; $transaction->body_resetpos; - while (my $line = $transaction->body_getline) { print $fh $line; }; + while (my $line = $transaction->body_getline) { print $fh $line; } close $fh; my ($line1) = split /[\r|\n]/, `$filtercmd < $message`; $self->log(LOGDEBUG, $line1); return $line1; -}; +} sub dspam_process_open2 { - my ( $self, $filtercmd, $transaction ) = @_; + my ($self, $filtercmd, $transaction) = @_; - my $message = $self->assemble_message( $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? + # 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::Open3; my ($read, $write, $err); - use Symbol 'gensym'; $err = gensym; + use Symbol 'gensym'; + $err = gensym; my $pid = open3($write, $read, $err, $filtercmd); print $write $message; close $write; + #my $response = join('', <$dspam_out>); # get full response - my $response = <$read>; # get first line only + my $response = <$read>; # get first line only waitpid $pid, 0; my $child_exit_status = $? >> 8; + #$self->log(LOGINFO, "exit status: $child_exit_status"); - if ( $response ) { + if ($response) { chomp $response; $self->log(LOGDEBUG, $response); - }; + } my $err_msg = <$err>; - if ( $err_msg ) { - $self->log(LOGDEBUG, $err_msg ); - }; + if ($err_msg) { + $self->log(LOGDEBUG, $err_msg); + } 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; + my $d = $self->get_dspam_results($transaction) or return DECLINED; - if ( ! $d->{class} ) { + 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 { @@ -450,26 +462,30 @@ sub log_and_return { return DECLINED; }; - if ( $reject eq 'agree' ) { - return $self->reject_agree( $transaction ); - }; + if ($reject eq 'agree') { + return $self->reject_agree($transaction); + } - if ( $d->{class} eq 'Innocent' ) { + 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)"); + } + 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)"); + } + 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})"); + } + 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)"); @@ -478,82 +494,84 @@ sub log_and_return { } sub reject_agree { - my ($self, $transaction ) = @_; + my ($self, $transaction) = @_; - my $sa = $transaction->notes('spamassassin' ); - my $d = $transaction->notes('dspam' ); + my $sa = $transaction->notes('spamassassin'); + my $d = $transaction->notes('dspam'); my $status = "$d->{class}, $d->{confidence} c"; - if ( ! $sa->{is_spam} ) { + 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' ) { - $self->adjust_karma( -2 ); + if ($d->{class} eq 'Spam') { + if ($sa->{is_spam} eq 'Yes') { + $self->adjust_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 ) { - $self->adjust_karma( 1 ); - }; + if ($d->{class} eq 'Innocent') { + if ($sa->{is_spam} eq 'No') { + if ($d->{confidence} > .9) { + $self->adjust_karma(1); + } $self->log(LOGINFO, "pass, agree, $status"); return DECLINED; - }; + } $self->log(LOGINFO, "pass, disagree, $status"); return DECLINED; - }; + } $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') ) { + 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 @bits = split /,\s+/, $string; + chomp @bits; my $class = shift @bits; my %d; foreach (@bits) { - my ($key,$val) = split /=/, $_; + my ($key, $val) = split /=/, $_; $d{$key} = $val; - }; + } $d{class} = $class; my $message = $d{class}; - if ( defined $d{probability} && defined $d{confidence} ) { + 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 attach_headers { my ($self, $r, $transaction) = @_; $transaction ||= $self->qp->transaction; - my $header_str = "$r->{result}, probability=$r->{probability}, confidence=$r->{confidence}"; + my $header_str = +"$r->{result}, probability=$r->{probability}, confidence=$r->{confidence}"; $self->log(LOGDEBUG, $header_str); my $name = 'X-DSPAM-Result'; $transaction->header->delete($name) if $transaction->header->get($name); @@ -562,135 +580,160 @@ sub attach_headers { # 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', $r->{signature}, 0); -}; +} sub train_error_as_ham { - my $self = shift; + my $self = shift; my $transaction = shift; - my $user = $self->select_username( $transaction ); + my $user = $self->select_username($transaction); my $dspam_bin = $self->{_args}{dspam_bin} || '/usr/local/bin/dspam'; - my $cmd = "$dspam_bin --user $user --mode=toe --source=error --class=innocent --deliver=summary --stdout"; - my $response = $self->dspam_process( $cmd, $transaction ); - if ( $response ) { + my $cmd = +"$dspam_bin --user $user --mode=toe --source=error --class=innocent --deliver=summary --stdout"; + my $response = $self->dspam_process($cmd, $transaction); + if ($response) { $transaction->notes('dspam', $response); } else { - $transaction->notes('dspam', { class => 'Innocent', result => 'Innocent', confidence=>1 } ); - }; -}; + $transaction->notes( + 'dspam', + { + class => 'Innocent', + result => 'Innocent', + confidence => 1 + } + ); + } +} sub train_error_as_spam { - my $self = shift; + my $self = shift; my $transaction = shift; - my $user = $self->select_username( $transaction ); + my $user = $self->select_username($transaction); my $dspam_bin = $self->{_args}{dspam_bin} || '/usr/local/bin/dspam'; - my $cmd = "$dspam_bin --user $user --mode=toe --source=error --class=spam --deliver=summary --stdout"; - my $response = $self->dspam_process( $cmd, $transaction ); - if ( $response ) { + my $cmd = +"$dspam_bin --user $user --mode=toe --source=error --class=spam --deliver=summary --stdout"; + my $response = $self->dspam_process($cmd, $transaction); + if ($response) { $transaction->notes('dspam', $response); } else { - $transaction->notes('dspam', { class => 'Spam', result => 'Spam', confidence=>1 } ); - }; -}; + $transaction->notes( + 'dspam', + { + class => 'Spam', + result => 'Spam', + confidence => 1 + } + ); + } +} sub autolearn { - my ( $self, $response, $transaction ) = @_; + my ($self, $response, $transaction) = @_; defined $self->{_args}{autolearn} or return; if ( $self->{_args}{autolearn} ne 'any' && $self->{_args}{autolearn} ne 'karma' && $self->{_args}{autolearn} ne 'naughty' - && $self->{_args}{autolearn} ne 'spamassassin' - ) { - $self->log(LOGERROR, "bad autolearn setting! Read 'perldoc plugins/dspam' again!"); + && $self->{_args}{autolearn} ne 'spamassassin') + { + $self->log(LOGERROR, + "bad autolearn setting! Read 'perldoc plugins/dspam' again!"); return; - }; + } # only train once. - $self->autolearn_naughty( $response, $transaction ) and return; - $self->autolearn_karma( $response, $transaction ) and return; - $self->autolearn_spamassassin( $response, $transaction ) and return; -}; + $self->autolearn_naughty($response, $transaction) and return; + $self->autolearn_karma($response, $transaction) and return; + $self->autolearn_spamassassin($response, $transaction) and return; +} sub autolearn_naughty { - my ( $self, $response, $transaction ) = @_; + my ($self, $response, $transaction) = @_; my $learn = $self->{_args}{autolearn} or return; - if ( $learn ne 'naughty' && $learn ne 'any' ) { + if ($learn ne 'naughty' && $learn ne 'any') { $self->log(LOGDEBUG, "skipping naughty autolearn"); return; - }; + } - if ( $self->connection->notes('naughty') && $response->{result} eq 'Innocent' ) { + if ( $self->connection->notes('naughty') + && $response->{result} eq 'Innocent') + { $self->log(LOGINFO, "training naughty FN message as spam"); - $self->train_error_as_spam( $transaction ); + $self->train_error_as_spam($transaction); return 1; - }; + } $self->log(LOGDEBUG, "falling through naughty autolearn"); return; -}; +} sub autolearn_karma { - my ( $self, $response, $transaction ) = @_; + my ($self, $response, $transaction) = @_; my $learn = $self->{_args}{autolearn} or return; - return if ( $learn ne 'karma' && $learn ne 'any' ); + return if ($learn ne 'karma' && $learn ne 'any'); my $karma = $self->connection->notes('karma'); - return if ! defined $karma; + return if !defined $karma; - if ( $karma < -2 && $response->{result} eq 'Innocent' ) { + if ($karma < -2 && $response->{result} eq 'Innocent') { $self->log(LOGINFO, "training bad karma ($karma) FN as spam"); - $self->train_error_as_spam( $transaction ); + $self->train_error_as_spam($transaction); return 1; - }; + } - if ( $karma > 2 && $response->{result} eq 'Spam' ) { + if ($karma > 2 && $response->{result} eq 'Spam') { $self->log(LOGINFO, "training good karma ($karma) FP as ham"); - $self->train_error_as_ham( $transaction ); + $self->train_error_as_ham($transaction); return 1; - }; + } return; -}; +} sub autolearn_spamassassin { - my ( $self, $response, $transaction ) = @_; + my ($self, $response, $transaction) = @_; my $learn = $self->{_args}{autolearn} or return; - return if ( $learn ne 'spamassassin' && $learn ne 'any' ); + return if ($learn ne 'spamassassin' && $learn ne 'any'); - my $sa = $transaction->notes('spamassassin' ); - if ( ! $sa || ! $sa->{is_spam} ) { - if ( ! $self->connection->notes('naughty') ) { - $self->log(LOGERROR, "SA results missing"); # SA skips naughty - }; + my $sa = $transaction->notes('spamassassin'); + if (!$sa || !$sa->{is_spam}) { + if (!$self->connection->notes('naughty')) { + $self->log(LOGERROR, "SA results missing"); # SA skips naughty + } return; - }; + } - if ( ! $sa->{autolearn} ) { + if (!$sa->{autolearn}) { $self->log(LOGERROR, "SA autolearn unset"); return; - }; + } - if ( $sa->{is_spam} eq 'Yes' && $sa->{autolearn} eq 'spam' && $response->{result} eq 'Innocent' ) { + if ( $sa->{is_spam} eq 'Yes' + && $sa->{autolearn} eq 'spam' + && $response->{result} eq 'Innocent') + { $self->log(LOGINFO, "training SA FN as spam"); - $self->train_error_as_spam( $transaction ); + $self->train_error_as_spam($transaction); return 1; } - elsif ( $sa->{is_spam} eq 'No' && $sa->{autolearn} eq 'ham' && $response->{result} eq 'Spam' ) { + elsif ( $sa->{is_spam} eq 'No' + && $sa->{autolearn} eq 'ham' + && $response->{result} eq 'Spam') + { $self->log(LOGINFO, "training SA FP as ham"); - $self->train_error_as_ham( $transaction ); + $self->train_error_as_ham($transaction); return 1; - }; + } return; -}; +} diff --git a/plugins/earlytalker b/plugins/earlytalker index 33cbf19..788d32d 100644 --- a/plugins/earlytalker +++ b/plugins/earlytalker @@ -70,52 +70,57 @@ use IO::Select; use Qpsmtpd::Constants; sub register { - my ($self, $qp, @args) = @_; + my ($self, $qp, @args) = @_; - if (@args % 2) { + 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}; + 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 { @@ -124,7 +129,7 @@ sub apr_connect_handler { return DECLINED unless $self->{_args}{'check-at'}{CONNECT}; return DECLINED if $self->is_immune(); - my $c = $self->qp->{conn} or return DECLINED; + my $c = $self->qp->{conn} or return DECLINED; my $socket = $c->client_socket or return DECLINED; my $timeout = $self->{_args}{'wait'} * 1_000_000; @@ -133,9 +138,9 @@ sub apr_connect_handler { if ($self->{_args}{'defer-reject'}) { $self->connection->notes('earlytalker', 1); return DECLINED; - }; + } return $self->log_and_deny(); - }; + } return $self->log_and_pass(); } @@ -145,14 +150,14 @@ sub apr_data_handler { return DECLINED unless $self->{_args}{'check-at'}{DATA}; return DECLINED if $self->is_immune(); - my $c = $self->qp->{conn} or return DECLINED; + 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(); } @@ -168,19 +173,19 @@ sub connect_handler { if (defined $karma && $karma > 5) { $self->log(LOGINFO, "skip, karma $karma"); return DECLINED; - }; + } $in->add(\*STDIN) or return DECLINED; - if (! $in->can_read($self->{_args}{'wait'})) { + if (!$in->can_read($self->{_args}{'wait'})) { return $self->log_and_pass(); - }; + } - if ( ! $self->{_args}{'defer-reject'}) { + if (!$self->{_args}{'defer-reject'}) { return $self->log_and_deny(); - }; + } $self->connection->notes('earlytalker', 1); - $self->adjust_karma( -1 ); + $self->adjust_karma(-1); return DECLINED; } @@ -192,12 +197,12 @@ sub data_handler { return DECLINED if $self->is_immune(); $in->add(\*STDIN) or return DECLINED; - if ( ! $in->can_read($self->{_args}{'wait'})) { + if (!$in->can_read($self->{_args}{'wait'})) { return $self->log_and_pass(); - }; + } return $self->log_and_deny(); -}; +} sub log_and_pass { my $self = shift; @@ -212,18 +217,18 @@ sub log_and_deny { my $ip = $self->qp->connection->remote_ip || 'remote host'; $self->connection->notes('earlytalker', 1); - $self->adjust_karma( -1 ); + $self->adjust_karma(-1); my $log_mess = "remote started talking before we said hello"; my $smtp_msg = 'Connecting host started transmitting before SMTP greeting'; - return $self->get_reject( $smtp_msg, $log_mess ); + return $self->get_reject($smtp_msg, $log_mess); } sub mail_handler { - my ($self, $transaction) = @_; + my ($self, $transaction) = @_; - return DECLINED unless $self->connection->notes('earlytalker'); - return $self->log_and_deny(); + return DECLINED unless $self->connection->notes('earlytalker'); + return $self->log_and_deny(); } diff --git a/plugins/fcrdns b/plugins/fcrdns index c1f2e56..b8190e4 100644 --- a/plugins/fcrdns +++ b/plugins/fcrdns @@ -102,20 +102,20 @@ use Qpsmtpd::Constants; sub register { my ($self, $qp) = (shift, shift); - $self->{_args} = { @_ }; + $self->{_args} = {@_}; $self->{_args}{reject_type} = 'temp'; $self->{_args}{timeout} ||= 5; $self->{_args}{ptr_hosts} = {}; - if ( ! defined $self->{_args}{reject} ) { + if (!defined $self->{_args}{reject}) { $self->{_args}{reject} = 0; - }; + } $self->init_resolver() or return; $self->register_hook('connect', 'connect_handler'); $self->register_hook('data_post', 'data_post_handler'); -}; +} sub connect_handler { my ($self) = @_; @@ -123,9 +123,9 @@ sub connect_handler { return DECLINED if $self->is_immune(); # run a couple cheap tests before the more expensive DNS tests - foreach my $test ( qw/ invalid_localhost is_not_fqdn / ) { + foreach my $test (qw/ invalid_localhost is_not_fqdn /) { $self->$test() or return DECLINED; - }; + } $self->has_reverse_dns() or return DECLINED; $self->has_forward_dns() or return DECLINED; @@ -138,91 +138,93 @@ sub data_post_handler { my ($self, $transaction) = @_; my $match = $self->connection->notes('fcrdns_match') || 0; - $transaction->header->add('X-Fcrdns', $match ? 'Yes' : 'No', 0 ); + $transaction->header->add('X-Fcrdns', $match ? 'Yes' : 'No', 0); return (DECLINED); -}; +} sub invalid_localhost { - my ( $self ) = @_; + my ($self) = @_; return 1 if lc $self->qp->connection->remote_host ne 'localhost'; if ( $self->qp->connection->remote_ip ne '127.0.0.1' - && $self->qp->connection->remote_ip ne '::1' ) { - $self->adjust_karma( -1 ); - $self->log( LOGINFO, "fail, not localhost" ); + && $self->qp->connection->remote_ip ne '::1') + { + $self->adjust_karma(-1); + $self->log(LOGINFO, "fail, not localhost"); return; - }; - $self->adjust_karma( 1 ); - $self->log( LOGDEBUG, "pass, is localhost" ); + } + $self->adjust_karma(1); + $self->log(LOGDEBUG, "pass, is localhost"); return 1; -}; +} sub is_not_fqdn { my ($self) = @_; my $host = $self->qp->connection->remote_host or return 1; - return 1 if $host eq 'Unknown'; # QP assigns this to a "no DNS result" + return 1 if $host eq 'Unknown'; # QP assigns this to a "no DNS result" # Since QP looked it up, perform some quick validation - if ( $host !~ /\./ ) { # has no dots - $self->adjust_karma( -1 ); + if ($host !~ /\./) { # has no dots + $self->adjust_karma(-1); $self->log(LOGINFO, "fail, not FQDN"); return; - }; - if ( $host =~ /[^a-zA-Z0-9\-\.]/ ) { - $self->adjust_karma( -1 ); + } + if ($host =~ /[^a-zA-Z0-9\-\.]/) { + $self->adjust_karma(-1); $self->log(LOGINFO, "fail, invalid FQDN chars"); return; - }; + } return 1; -}; +} sub has_reverse_dns { - my ( $self ) = @_; + my ($self) = @_; my $res = $self->init_resolver(); my $ip = $self->qp->connection->remote_ip; - my $query = $res->query( $ip ) or do { - if ( $res->errorstring eq 'NXDOMAIN' ) { - $self->adjust_karma( -1 ); - $self->log( LOGINFO, "fail, no rDNS: ".$res->errorstring ); + my $query = $res->query($ip) or do { + if ($res->errorstring eq 'NXDOMAIN') { + $self->adjust_karma(-1); + $self->log(LOGINFO, "fail, no rDNS: " . $res->errorstring); return; - }; - $self->log( LOGINFO, "fail, error getting rDNS: ".$res->errorstring ); + } + $self->log(LOGINFO, "fail, error getting rDNS: " . $res->errorstring); return; }; my $hits = 0; - $self->{_args}{ptr_hosts} = {}; # reset hash + $self->{_args}{ptr_hosts} = {}; # reset hash for my $rr ($query->answer) { next if $rr->type ne 'PTR'; $hits++; - $self->{_args}{ptr_hosts}{ $rr->ptrdname } = 1; - $self->log(LOGDEBUG, "PTR: " . $rr->ptrdname ); - }; - if ( ! $hits ) { - $self->adjust_karma( -1 ); - $self->log( LOGINFO, "fail, no PTR records"); + $self->{_args}{ptr_hosts}{$rr->ptrdname} = 1; + $self->log(LOGDEBUG, "PTR: " . $rr->ptrdname); + } + if (!$hits) { + $self->adjust_karma(-1); + $self->log(LOGINFO, "fail, no PTR records"); return; - }; + } $self->log(LOGDEBUG, "has rDNS"); return 1; -}; +} sub has_forward_dns { - my ( $self ) = @_; + my ($self) = @_; my $res = $self->init_resolver(); - foreach my $host ( keys %{ $self->{_args}{ptr_hosts} } ) { + foreach my $host (keys %{$self->{_args}{ptr_hosts}}) { - $host .= '.' if '.' ne substr( $host, -1, 1); # fully qualify name + $host .= '.' if '.' ne substr($host, -1, 1); # fully qualify name my $query = $res->search($host) or do { - if ( $res->errorstring eq 'NXDOMAIN' ) { - $self->log(LOGDEBUG, "host $host does not exist" ); + if ($res->errorstring eq 'NXDOMAIN') { + $self->log(LOGDEBUG, "host $host does not exist"); next; } - $self->log(LOGDEBUG, "query for $host failed (", $res->errorstring, ")" ); + $self->log(LOGDEBUG, "query for $host failed (", + $res->errorstring, ")"); next; }; @@ -230,38 +232,39 @@ sub has_forward_dns { foreach my $rr ($query->answer) { next unless $rr->type =~ /^(?:A|AAAA)$/; $hits++; - $self->check_ip_match( $rr->address ) and return 1; + $self->check_ip_match($rr->address) and return 1; } - if ( $hits ) { + if ($hits) { $self->log(LOGDEBUG, "PTR host has forward DNS") if $hits; return 1; - }; - }; - $self->adjust_karma( -1 ); + } + } + $self->adjust_karma(-1); $self->log(LOGINFO, "fail, no PTR hosts have forward DNS"); return; -}; +} 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" ); + if ($ip eq $self->qp->connection->remote_ip) { + $self->log(LOGDEBUG, "forward ip match"); $self->connection->notes('fcrdns_match', 1); - $self->adjust_karma( 1 ); + $self->adjust_karma(1); return 1; - }; + } -# TODO: make this IPv6 compatible - my $dns_net = join('.', (split(/\./, $ip))[0,1,2] ); - my $rem_net = join('.', (split(/\./, $self->qp->connection->remote_ip))[0,1,2] ); + # TODO: make this IPv6 compatible + 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" ); + if ($dns_net eq $rem_net) { + $self->log(LOGNOTICE, "forward network match"); $self->connection->notes('fcrdns_match', 1); return 1; - }; + } return; -}; +} diff --git a/plugins/greylisting b/plugins/greylisting index 158404e..166130e 100644 --- a/plugins/greylisting +++ b/plugins/greylisting @@ -176,47 +176,51 @@ 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 $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, -); + 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; + 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 { + } + else { $self->register_hook('rcpt', 'rcpt_handler'); } $self->prune_db(); - if ( $self->{_args}{upgrade} ) { + if ($self->{_args}{upgrade}) { $self->convert_db(); - }; + } } sub mail_handler { @@ -226,144 +230,159 @@ sub mail_handler { return DECLINED if $status != DENYSOFT; - if ( ! $self->{_args}{deny_late} ) { + 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; + 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'); + 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)); + $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->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 $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"; + my $fmt = "%s:%d:%d:%d"; -# new IP or entry timed out - record new - if ( ! $tied->{$key} ) { + # 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 ); - }; + 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 ($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 ); + 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 + # 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 ); + return $self->cleanup_and_return($tied, $lock, DECLINED); } $self->log(LOGWARN, "pass: timed out (grey)"); - return $self->cleanup_and_return( $tied, $lock, DECLINED ); + return $self->cleanup_and_return($tied, $lock, DECLINED); } sub cleanup_and_return { - my ($self, $tied, $lock, $return_val ) = @_; + 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 $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 $self = shift; my $sender = shift || $self->qp->transaction->sender; - my $rcpt = shift || ($self->qp->transaction->recipients)[0]; + 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 - }; + 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 ) { + 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 ) = @_; + my ($self, $db, $lock) = @_; - tie( my %db, 'AnyDBM_File', $db, O_CREAT|O_RDWR, 0600) or do { + 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}; + my $config = $self->{_args}; if ($config->{db_dir} && $config->{db_dir} =~ m{^([-a-zA-Z0-9./_]+)$}) { $config->{db_dir} = $1; @@ -371,25 +390,28 @@ sub get_db_location { # Setup database location my $dbdir; - if ( $config->{per_recipient_db} ) { + 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", '.' ); + 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 + for my $d (@candidate_dirs) { + next if !$d || !-d $d; # impossible $dbdir = $d; - last; # first match wins + last; # first match wins } my $db = "$dbdir/$DB"; - if ( ! -f $db && -f "$dbdir/denysoft_greylist.dbm" ) { - $db = "$dbdir/denysoft_greylist.dbm"; # old DB name + if (!-f $db && -f "$dbdir/denysoft_greylist.dbm") { + $db = "$dbdir/denysoft_greylist.dbm"; # old DB name } - $self->log(LOGDEBUG,"using $db as greylisting database"); + $self->log(LOGDEBUG, "using $db as greylisting database"); return $db; -}; +} sub get_db_lock { my ($self, $db) = @_; @@ -397,12 +419,12 @@ sub get_db_lock { return $self->get_db_lock_nfs($db) if $self->{_args}{nfslock}; # Check denysoft db - open( my $lock, ">$db.lock" ) or do { + open(my $lock, ">$db.lock") or do { $self->log(LOGCRIT, "opening lockfile failed: $!"); return; }; - flock( $lock, LOCK_EX ) or do { + flock($lock, LOCK_EX) or do { $self->log(LOGCRIT, "flock of lockfile failed: $!"); close $lock; return; @@ -418,110 +440,111 @@ sub get_db_lock_nfs { ### 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 { + 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 { + 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 $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 + 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 $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 ); -}; + $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 $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 ) { + 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 ); -}; + $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}; + return if !$self->{_args}{p0f}; my $p0f = $self->connection->notes('p0f'); - if ( !$p0f || !ref $p0f ) { # p0f fingerprint info not found + 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} ); + 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 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 + 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 ) { + if ($key eq 'distance' && $p0f->{$key} > $value) { $self->log(LOGDEBUG, "p0f distance match ($value)"); return 1; - }; - if ( $key eq 'genre' && $p0f->{$key} =~ /$value/i ) { + } + if ($key eq 'genre' && $p0f->{$key} =~ /$value/i) { $self->log(LOGDEBUG, "p0f genre match ($value)"); return 1; - }; - if ( $key eq 'uptime' && $p0f->{$key} < $value ) { + } + if ($key eq 'uptime' && $p0f->{$key} < $value) { $self->log(LOGDEBUG, "p0f uptime match ($value)"); return 1; - }; - if ( $key eq 'link' && $p0f->{$key} =~ /$value/i ) { + } + 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; @@ -530,21 +553,21 @@ sub p0f_match { sub geoip_match { my $self = shift; - return if ! $self->{_args}{geoip}; + return if !$self->{_args}{geoip}; my $country = $self->connection->notes('geoip_country'); - my $c_name = $self->connection->notes('geoip_country_name') || ''; + my $c_name = $self->connection->notes('geoip_country_name') || ''; - if ( !$country ) { + if (!$country) { $self->LOGINFO(LOGNOTICE, "skip: no geoip country"); return; - }; + } my @countries = split /,/, $self->{_args}{geoip}; - foreach ( @countries ) { + 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 index deb5b70..8dd0220 100644 --- a/plugins/headers +++ b/plugins/headers @@ -97,71 +97,73 @@ use Qpsmtpd::Constants; use Date::Parse qw(str2time); my @required_headers = qw/ From /; # <- to be RFC 5322 compliant, 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 /; + Message-Id In-Reply-To References + Subject /; sub register { - my ($self, $qp ) = (shift, shift); + my ($self, $qp) = (shift, shift); $self->log(LOGWARN, "invalid arguments") if @_ % 2; - $self->{_args} = { @_ }; + $self->{_args} = {@_}; - $self->{_args}{reject_type} ||= 'perm'; # set default - if ( ! defined $self->{_args}{reject} ) { - $self->{_args}{reject} = 1; # set default - }; + $self->{_args}{reject_type} ||= 'perm'; # set default + if (!defined $self->{_args}{reject}) { + $self->{_args}{reject} = 1; # set default + } - if ( $self->{_args}{require} ) { + 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" ); - }; + 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( "Headers are missing", "missing headers" ); + return $self->get_reject("Headers are missing", "missing headers"); }; return (DECLINED, "immune") if $self->is_immune(); - foreach my $h ( @required_headers ) { + foreach my $h (@required_headers) { next if $header->get($h); - $self->adjust_karma( -1 ); - return $self->get_reject( "We require a valid $h header", "no $h header"); - }; + $self->adjust_karma(-1); + 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 + 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 - $self->adjust_karma( -1 ); - return $self->get_reject( - "Only one $h header allowed. See RFC 5322, Section 3.6", - "too many $h headers", - ); - }; + next if @qty == 1; # only 1 header + $self->adjust_karma(-1); + return + $self->get_reject( + "Only one $h header allowed. See RFC 5322, Section 3.6", + "too many $h headers",); + } my $err_msg = $self->invalid_date_range(); - if ( $err_msg ) { - $self->adjust_karma( -1 ); + if ($err_msg) { + $self->adjust_karma(-1); return $self->get_reject($err_msg, $err_msg); - }; + } - $self->log( LOGINFO, 'pass' ); + $self->log(LOGINFO, 'pass'); return (DECLINED); -}; +} sub invalid_date_range { my $self = shift; - return if ! $self->transaction->header; + return if !$self->transaction->header; my $date = shift || $self->transaction->header->get('Date') or return; chomp $date; @@ -171,16 +173,16 @@ sub invalid_date_range { }; my $past = $self->{_args}{past}; - if ( $past && $ts < time - ($past*24*3600) ) { + 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) ) { + 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 index a4c5404..b5d7fb3 100644 --- a/plugins/helo +++ b/plugins/helo @@ -225,40 +225,40 @@ use Qpsmtpd::Constants; sub register { my ($self, $qp) = (shift, shift); - $self->{_args} = { @_ }; + $self->{_args} = {@_}; $self->{_args}{reject_type} = 'disconnect'; $self->{_args}{policy} ||= 'lenient'; $self->{_args}{dns_timeout} ||= $self->{_args}{timeout} || 5; - if ( ! defined $self->{_args}{reject} ) { + if (!defined $self->{_args}{reject}) { $self->{_args}{reject} = 1; - }; + } $self->populate_tests(); $self->init_resolver() or return; - $self->register_hook('helo', 'helo_handler'); - $self->register_hook('ehlo', 'helo_handler'); + $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 ) { + 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 ); - if ( scalar @err ) { - $self->adjust_karma( -1 ); - return $self->get_reject( @err ); - }; - }; + foreach my $test (@{$self->{_helo_tests}}) { + my @err = $self->$test($host); + if (scalar @err) { + $self->adjust_karma(-1); + return $self->get_reject(@err); + } + } $self->log(LOGINFO, "pass"); return DECLINED; @@ -268,239 +268,249 @@ sub data_post_handler { my ($self, $transaction) = @_; $transaction->header->delete('X-HELO'); - $transaction->header->add('X-HELO', $self->qp->connection->hello_host, 0 ); + $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 is_plain_ip /; + @{$self->{_helo_tests}} = + qw/ is_in_badhelo invalid_localhost is_forged_literal is_plain_ip /; - if ( $policy eq 'rfc' || $policy eq 'strict' ) { - push @{ $self->{_helo_tests} }, qw/ is_not_fqdn no_forward_dns no_reverse_dns /; - }; + if ($policy eq 'rfc' || $policy eq 'strict') { + push @{$self->{_helo_tests}}, + qw/ is_not_fqdn no_forward_dns no_reverse_dns /; + } - if ( $policy eq 'strict' ) { - push @{ $self->{_helo_tests} }, qw/ is_address_literal no_matching_dns /; - }; -}; + if ($policy eq 'strict') { + push @{$self->{_helo_tests}}, qw/ is_address_literal no_matching_dns /; + } +} sub is_in_badhelo { - my ( $self, $host ) = @_; + 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) { + 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 ($self, $host, $pattern) = @_; my $error = "Your HELO hostname is not allowed"; #$self->log( LOGDEBUG, "is regex ($pattern)"); - if ( substr( $pattern, 0, 1) eq '!' ) { + if (substr($pattern, 0, 1) eq '!') { $pattern = substr $pattern, 1; - if ( $host !~ /$pattern/ ) { + if ($host !~ /$pattern/) { + #$self->log( LOGDEBUG, "matched ($pattern)"); return ($error, "badhelo pattern match ($pattern)"); - }; + } return; } - if ( $host =~ /$pattern/ ) { + if ($host =~ /$pattern/) { + #$self->log( LOGDEBUG, "matched ($pattern)"); return ($error, "badhelo pattern match ($pattern)"); - }; + } return; } sub invalid_localhost { - my ( $self, $host ) = @_; + my ($self, $host) = @_; return if lc $host ne 'localhost'; - if ( $self->qp->connection->remote_ip ne '127.0.0.1' ) { + 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" ); + } + $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 + 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" ); + $self->log(LOGDEBUG, "fail, plain IP"); return ("Plain IP is invalid HELO hostname (RFC 2821)", "plain IP"); -}; +} sub is_address_literal { - my ( $self, $host ) = @_; + 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"); -}; + $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 ) = @_; + my ($self, $host) = @_; return if $host !~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/; -# should we add exceptions for reserved internal IP space? (192.168,10., etc?) + # should we add exceptions for reserved internal IP space? (192.168,10., etc?) $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 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"); - }; + } + 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 ($self, $host) = @_; - return if $self->is_address_literal( $host ); + return if $self->is_address_literal($host); my $res = $self->init_resolver(); - $host = "$host." if $host !~ /\.$/; # fully qualify name + $host = "$host." if $host !~ /\.$/; # fully qualify name my $query = $res->search($host); - if (! $query) { - if ( $res->errorstring eq 'NXDOMAIN' ) { + if (!$query) { + if ($res->errorstring eq 'NXDOMAIN') { return ("HELO hostname does not exist", "no such host"); } - $self->log(LOGERROR, "skip, query failed (", $res->errorstring, ")" ); + $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 ); + $self->check_ip_match($rr->address); $hits++; last if $self->connection->notes('helo_forward_match'); } - if ( $hits ) { + if ($hits) { $self->log(LOGDEBUG, "pass, forward DNS") if $hits; return; - }; + } return ("HELO hostname did not resolve", "no forward DNS"); -}; +} sub no_reverse_dns { - my ( $self, $host, $ip ) = @_; + 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' ) { + 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); + } + $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 ); + $self->log(LOGDEBUG, "PTR: " . $rr->ptrdname); + $self->check_name_match(lc $rr->ptrdname, lc $host); $hits++; - }; - if ( $hits ) { + } + if ($hits) { $self->log(LOGDEBUG, "has rDNS"); return; - }; + } return ("no reverse DNS for $ip", "no rDNS"); -}; +} sub no_matching_dns { - my ( $self, $host ) = @_; + my ($self, $host) = @_; -# this is called iprev, or "Forward-confirmed reverse DNS" and is discussed -# in RFC 5451. FCrDNS is done for the remote IP in the fcrdns plugin. Here -# we do it on the HELO hostname. -# consider adding status to Authentication-Results header + # this is called iprev, or "Forward-confirmed reverse DNS" and is discussed + # in RFC 5451. FCrDNS is done for the remote IP in the fcrdns plugin. Here + # we do it on the HELO hostname. + # consider adding status to Authentication-Results header - if ( $self->connection->notes('helo_forward_match') && - $self->connection->notes('helo_reverse_match') ) { - $self->log( LOGDEBUG, "foward and reverse match" ); - $self->adjust_karma( 1 ); # a perfect match - return; - }; - - if ( $self->connection->notes('helo_forward_match') ) { - $self->log( LOGDEBUG, "name matches IP" ); + if ( $self->connection->notes('helo_forward_match') + && $self->connection->notes('helo_reverse_match')) + { + $self->log(LOGDEBUG, "foward and reverse match"); + $self->adjust_karma(1); # a perfect match 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" ); + 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 FCrDNS", "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" ); + 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] ); + 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" ); + 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) = @_; - return if ! $dns_name; - return if split(/\./, $dns_name) < 2; # not a FQDN + return if !$dns_name; + return if split(/\./, $dns_name) < 2; # not a FQDN - if ( $dns_name eq $helo_name ) { - $self->log( LOGDEBUG, "reverse name match" ); + 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] ); + 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" ); + 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 index e9cd4d5..4c24c22 100644 --- a/plugins/help +++ b/plugins/help @@ -42,15 +42,15 @@ The hard coded F path should be changed. my %config = (); sub register { - my ($self,$qp,%args) = @_; + 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; + /^(\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'}; @@ -58,28 +58,28 @@ sub register { elsif ($cmd eq 'help_dir') { $file = $args{$cmd}; $file =~ m#^([\w\.\-/]+)$# - or $self->log(LOGERROR, + or $self->log(LOGERROR, "Invalid charachters in filename for command $cmd"), - next; + next; $config{'help_dir'} = $1; } else { $file = $args{$cmd}; $file =~ m#^([\w\.\-/]+)$# - or $self->log(LOGERROR, + or $self->log(LOGERROR, "Invalid charachters in filename for command $cmd"), - next; + next; $file = $1; if ($file =~ m#/#) { - -e $file + -e $file or $self->log(LOGWARN, "No help file for command '$cmd'"), - next; + next; } else { $file = "help/$file"; - if (-e "help/$file") { ## FIXME: path + if (-e "help/$file") { ## FIXME: path $file = "help/$file"; - } + } else { $self->log(LOGWARN, "No help file for command '$cmd'"); next; @@ -105,8 +105,8 @@ sub hook_help { $cmd = lc $args[0]; - unless ($cmd =~ /^(\w+)$/) { # else someone could request - # "HELP ../../../../../../../../etc/passwd" + unless ($cmd =~ /^(\w+)$/) { # else someone could request + # "HELP ../../../../../../../../etc/passwd" $self->qp->respond(502, "Invalid command name"); return DONE; } @@ -114,25 +114,25 @@ sub hook_help { 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"; + 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"; + 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 + $help = "No help available for SMTP command: $cmd" # empty file unless $help; return OK, split(/\n/, $help); } sub read_helpfile { - my ($file,$cmd) = @_; + my ($file, $cmd) = @_; my $help; open HELP, $file - or return undef; - { + or return undef; + { local $/ = undef; $help = ; }; diff --git a/plugins/hosts_allow b/plugins/hosts_allow index 1ea62df..e5c2cc8 100644 --- a/plugins/hosts_allow +++ b/plugins/hosts_allow @@ -57,7 +57,7 @@ use Qpsmtpd::Constants; use Socket; sub hook_pre_connection { - my ($self,$transaction,%args) = @_; + my ($self, $transaction, %args) = @_; # remote_ip => inet_ntoa($iaddr), # remote_port => $port, @@ -70,62 +70,62 @@ sub hook_pre_connection { my $max = $args{max_conn_ip}; my $karma = $self->connection->notes('karma_history'); - if ( $max ) { - my $num_conn = 1; # seed with current value + 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); } - $max = $self->karma_bump( $karma, $max ) if defined $karma; - if ($num_conn > $max ) { + $max = $self->karma_bump($karma, $max) if defined $karma; + if ($num_conn > $max) { my $err_mess = "too many connections from $remote"; $self->log(LOGINFO, "fail: $err_mess ($num_conn > $max)"); return (DENYSOFT, "$err_mess, try again later"); } } - my @r = $self->in_hosts_allow( $remote ); + my @r = $self->in_hosts_allow($remote); return @r if scalar @r; - $self->log(LOGDEBUG, "pass" ); + $self->log(LOGDEBUG, "pass"); return (DECLINED); } sub in_hosts_allow { - my $self = shift; + my $self = shift; my $remote = shift; - foreach ( $self->qp->config('hosts_allow') ) { + foreach ($self->qp->config('hosts_allow')) { s/^\s*//; # trim leading whitespace 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); + 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); + if ($const =~ /deny/i) { + $self->log(LOGINFO, "fail, $message"); + } + $self->log(LOGDEBUG, "pass, $const, $message"); + return ($const, $message); } } return; -}; +} sub karma_bump { my ($self, $karma, $max) = @_; - if ( $karma > 5 ) { + if ($karma > 5) { $self->log(LOGDEBUG, "connect limit +3 for positive karma"); return $max + 3; - }; - if ( $karma <= 0 ) { + } + if ($karma <= 0) { $self->log(LOGINFO, "connect limit 1, karma $karma"); return 1; - }; + } return $max; -}; +} diff --git a/plugins/http_config b/plugins/http_config index bb3f674..79bdece 100644 --- a/plugins/http_config +++ b/plugins/http_config @@ -1,4 +1,5 @@ #!perl -w + =head1 NAME http_config @@ -30,21 +31,22 @@ use LWP::Simple qw(get); my @urls; sub register { - my ($self, $qp, @args) = @_; - @urls = @args; + 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; + 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 index 9964457..b25408b 100644 --- a/plugins/ident/geoip +++ b/plugins/ident/geoip @@ -111,22 +111,23 @@ 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; + my ($self, $qp) = shift, shift; $self->log(LOGERROR, "Bad arguments") if @_ % 2; - $self->{_args} = { @_ }; - $self->{_args}{db_dir} ||= '/usr/local/share/GeoIP'; + $self->{_args} = {@_}; + $self->{_args}{db_dir} ||= '/usr/local/share/GeoIP'; eval 'use Geo::IP'; - if ( $@ ) { + if ($@) { warn "could not load Geo::IP"; - $self->log( LOGERROR, "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 @@ -136,8 +137,8 @@ sub register { $self->init_my_country_code(); - $self->register_hook( 'connect', 'connect_handler' ); -}; + $self->register_hook('connect', 'connect_handler'); +} sub connect_handler { my $self = shift; @@ -146,7 +147,7 @@ sub connect_handler { $self->open_geoip_db(); my $c_code = $self->set_country_code() or do { - $self->log( LOGINFO, "skip, no results" ); + $self->log(LOGINFO, "skip, no results"); return DECLINED; }; $self->qp->connection->notes('geoip_country', $c_code); @@ -154,24 +155,26 @@ sub connect_handler { my $c_name = $self->set_country_name(); my ($city, $continent_code, $distance) = ''; - if ( $self->{_my_country_code} ) { - $continent_code = $self->set_continent( $c_code ); - $city = $self->set_city_gc(); - $distance = $self->set_distance_gc(); - }; + if ($self->{_my_country_code}) { + $continent_code = $self->set_continent($c_code); + $city = $self->set_city_gc(); + $distance = $self->set_distance_gc(); + } my @msg_parts; - push @msg_parts, $continent_code if $continent_code && $continent_code ne '--'; - push @msg_parts, $c_code if $c_code; + push @msg_parts, $continent_code + if $continent_code && $continent_code ne '--'; + push @msg_parts, $c_code if $c_code; + #push @msg_parts, $c_name if $c_name; - push @msg_parts, $city if $city; - if ( $distance ) { + push @msg_parts, $city if $city; + if ($distance) { push @msg_parts, "\t$distance km"; - if ( $self->{_args}{too_far} && $distance > $self->{_args}{too_far} ) { - $self->adjust_karma( -1 ); - }; - }; - $self->log(LOGINFO, join( ", ", @msg_parts) ); + if ($self->{_args}{too_far} && $distance > $self->{_args}{too_far}) { + $self->adjust_karma(-1); + } + } + $self->log(LOGINFO, join(", ", @msg_parts)); return DECLINED; } @@ -181,156 +184,159 @@ sub open_geoip_db { # 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} ); + 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" ) { + 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" ); + $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} ) { + if (!$self->{_geoip_city}) { $self->log(LOGDEBUG, "using default db"); - $self->{_geoip} = Geo::IP->new(); # loads default Country 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 ); -}; + $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(); + 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 ); -}; + 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; + 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; + 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}; + 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; + 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}; + 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_city_gc { my $self = shift; - return if ! $self->{_geoip_record}; + return if !$self->{_geoip_record}; my $remote_ip = $self->qp->connection->remote_ip; my $city = $self->{_geoip_record}->city() or return; $self->qp->connection->notes('geoip_city', $city); return $city; -}; +} sub set_distance_gc { my $self = shift; - return if ! $self->{_geoip_record}; + return if !$self->{_geoip_record}; - my ($self_lat, $self_lon) = $self->get_my_lat_lon() or return; + 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"); + 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 ); + 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); + 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}; + return if !$self->{_geoip_city}; - if ( $self->{_latitude} && $self->{_longitude} ) { - return ( $self->{_latitude}, $self->{_longitude} ); # cached - }; + if ($self->{_latitude} && $self->{_longitude}) { + return ($self->{_latitude}, $self->{_longitude}); # cached + } - my $ip = $self->{_args}{distance} or return; + 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"); + $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} ); -}; + 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"); + 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 index d3a1c2b..ad0e591 100644 --- a/plugins/ident/p0f +++ b/plugins/ident/p0f @@ -140,7 +140,7 @@ use Net::IP; my $QUERY_MAGIC_V2 = 0x0defaced; my $QUERY_MAGIC_V3 = 0x50304601; -my $RESP_MAGIC_V3 = 0x50304602; +my $RESP_MAGIC_V3 = 0x50304602; my $P0F_STATUS_BADQUERY = 0x00; my $P0F_STATUS_OK = 0x10; @@ -149,7 +149,7 @@ my $P0F_STATUS_NOMATCH = 0x20; sub register { my ($self, $qp, $p0f_socket, %args) = @_; - $p0f_socket =~ /(.*)/; # untaint + $p0f_socket =~ /(.*)/; # untaint $self->{_args}->{p0f_socket} = $1; foreach (keys %args) { $self->{_args}->{$_} = $args{$_}; @@ -157,18 +157,18 @@ sub register { } sub hook_connect { - my($self, $qp) = @_; + my ($self, $qp) = @_; my $p0f_version = $self->{_args}{version} || 3; - if ( $p0f_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 ); + $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 ); + $self->test_v2_response($response) or return DECLINED; + $self->store_v2_results($response); } return DECLINED; @@ -179,38 +179,41 @@ sub get_v2_query { 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, "skip, ".Net::IP::Error()), return; + my $src = new Net::IP($self->qp->connection->remote_ip) + or $self->log(LOGERROR, "skip, " . Net::IP::Error()), return; my $dst = new Net::IP($local_ip) - or $self->log(LOGERROR, "skip, ".NET::IP::Error()), return; + or $self->log(LOGERROR, "skip, " . 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); -}; + 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, "skip, unable to determine remote IP"); + $self->log(LOGERROR, "skip, 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 ); - }; + 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 ); -}; + return pack("L C C16", $QUERY_MAGIC_V3, 0x04, @octets); +} sub query_p0f_v3 { my $self = shift; @@ -221,38 +224,39 @@ sub query_p0f_v3 { }; my $query = $self->get_v3_query() or return; -# Open the connection to p0f + # Open the connection to p0f my $sock; eval { - $sock = IO::Socket::UNIX->new(Peer => $p0f_socket, Type => SOCK_STREAM ); + $sock = IO::Socket::UNIX->new(Peer => $p0f_socket, Type => SOCK_STREAM); }; - if ( ! $sock ) { + if (!$sock) { $self->log(LOGERROR, "skip, could not open socket: $@"); return; + } + + $sock->autoflush(1); # paranoid redundancy + $sock->connected or do { + $self->log(LOGERROR, "skip, socket not connected: $!"); + return; }; - $sock->autoflush(1); # paranoid redundancy - $sock->connected or do { - $self->log(LOGERROR, "skip, socket not connected: $!"); - return; - }; - my $sent = $sock->send($query, 0) or do { - $self->log(LOGERROR, "skip, send failed: $!"); - return; - }; + $self->log(LOGERROR, "skip, send failed: $!"); + return; + }; - print $sock $query; # yes, this is redundant, but I get no response from p0f otherwise + print $sock $query + ; # yes, this is redundant, but I get no response from p0f otherwise $self->log(LOGDEBUG, "sent $sent byte request"); my $response; - $sock->recv( $response, 232 ); + $sock->recv($response, 232); my $length = length $response; $self->log(LOGDEBUG, "received $length byte response"); close $sock; return $response; -}; +} sub query_p0f_v2 { my $self = shift; @@ -262,24 +266,24 @@ sub query_p0f_v2 { # Open the connection to p0f socket(SOCK, PF_UNIX, SOCK_STREAM, 0) - or $self->log(LOGERROR, "socket: $!"), return; + or $self->log(LOGERROR, "socket: $!"), return; connect(SOCK, sockaddr_un($p0f_socket)) - or $self->log(LOGERROR, "connect: $! ($p0f_socket)"), return; + or $self->log(LOGERROR, "connect: $! ($p0f_socket)"), return; defined syswrite SOCK, $query - or $self->log(LOGERROR, "write: $!"), close SOCK, return; + or $self->log(LOGERROR, "write: $!"), close SOCK, return; my $response; defined sysread SOCK, $response, 1024 - or $self->log(LOGERROR, "read: $!"), close SOCK, return; + or $self->log(LOGERROR, "read: $!"), close SOCK, return; close SOCK; return $response; -}; +} sub test_v2_response { - my ($self, $response ) = @_; + my ($self, $response) = @_; # Extract part of the p0f response - my ($magic, $id, $type) = unpack ("L L C", $response); + my ($magic, $id, $type) = unpack("L L C", $response); # $self->log(LOGERROR, $response); if ($magic != $QUERY_MAGIC_V2) { @@ -296,84 +300,87 @@ sub test_v2_response { return; } return 1; -}; +} sub test_v3_response { - my ($self, $response ) = @_; + my ($self, $response) = @_; - my ($magic,$status) = unpack ("L L", $response); + my ($magic, $status) = unpack("L L", $response); # check the magic response value (a p0f constant) - if ($magic != $RESP_MAGIC_V3 ) { + if ($magic != $RESP_MAGIC_V3) { $self->log(LOGERROR, "skip, Bad response magic."); return; } # check the response status - if ($status == $P0F_STATUS_BADQUERY ) { + if ($status == $P0F_STATUS_BADQUERY) { $self->log(LOGERROR, "skip, bad query"); return; } - elsif ($status == $P0F_STATUS_NOMATCH ) { + elsif ($status == $P0F_STATUS_NOMATCH) { $self->log(LOGINFO, "skip, no match"); return; } - if ($status == $P0F_STATUS_OK ) { + if ($status == $P0F_STATUS_OK) { $self->log(LOGDEBUG, "pass, query ok"); return 1; } return; -}; +} sub store_v2_results { - my ($self, $response ) = @_; + 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 ( + $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, - }; + 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 $@; + $self->log(LOGINFO, $genre . " (" . $detail . ")"); + $self->log(LOGERROR, "error: $@") if $@; return $p0f; -}; +} sub store_v3_results { - my ($self, $response ) = @_; + 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); + 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 + 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}; - }; + } - if ( $r{genre} && $self->{_args}{smite_os} ) { + if ($r{genre} && $self->{_args}{smite_os}) { my $sos = $self->{_args}{smite_os}; - $self->adjust_karma( -1 ) if $r{genre} =~ /$sos/i; - }; + $self->adjust_karma(-1) if $r{genre} =~ /$sos/i; + } $self->connection->notes('p0f', \%r); - $self->log(LOGINFO, "$r{os_name} $r{os_flavor}"); - $self->log(LOGDEBUG, join(' ', @values )); - $self->log(LOGERROR,"error: $@") if $@; + $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 index f83a679..8cc91e6 100644 --- a/plugins/karma +++ b/plugins/karma @@ -231,113 +231,117 @@ use Fcntl qw(:DEFAULT :flock LOCK_EX LOCK_NB); use Net::IP; sub register { - my ($self, $qp ) = (shift, shift); + my ($self, $qp) = (shift, shift); $self->log(LOGERROR, "Bad arguments") if @_ % 2; - $self->{_args} = { @_ }; + $self->{_args} = {@_}; $self->{_args}{negative} ||= 1; $self->{_args}{penalty_days} ||= 1; $self->{_args}{reject_type} ||= 'disconnect'; - if ( ! defined $self->{_args}{reject} ) { + 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('data', 'data_handler' ); - $self->register_hook('disconnect', 'disconnect_handler'); - $self->register_hook('received_line', 'rcpt_handler'); + $self->register_hook('connect', 'connect_handler'); + $self->register_hook('data', 'data_handler'); + $self->register_hook('disconnect', 'disconnect_handler'); + $self->register_hook('received_line', 'rcpt_handler'); } sub hook_pre_connection { - my ($self,$transaction,%args) = @_; + my ($self, $transaction, %args) = @_; $self->connection->notes('karma_history', 0); my $remote_ip = $args{remote_ip}; + #my $max_conn = $args{max_conn_ip}; 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( $remote_ip ) or do { - $self->log( LOGINFO, "skip, unable to get DB key" ); + 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($remote_ip) or do { + $self->log(LOGINFO, "skip, unable to get DB key"); return DECLINED; }; - if ( ! $tied->{$key} ) { + if (!$tied->{$key}) { $self->log(LOGDEBUG, "pass, no record"); - return $self->cleanup_and_return($tied, $lock ); - }; + return $self->cleanup_and_return($tied, $lock); + } - my ($penalty_start_ts, $naughty, $nice, $connects) = $self->parse_value( $tied->{$key} ); + my ($penalty_start_ts, $naughty, $nice, $connects) = + $self->parse_value($tied->{$key}); $self->calc_karma($naughty, $nice); - return $self->cleanup_and_return($tied, $lock ); -}; + return $self->cleanup_and_return($tied, $lock); +} sub connect_handler { my $self = shift; - $self->connection->notes('karma', 0); # default + $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 $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() or do { - $self->log( LOGINFO, "skip, unable to get DB key" ); + $self->log(LOGINFO, "skip, unable to get DB key"); return DECLINED; }; - if ( ! $tied->{$key} ) { + if (!$tied->{$key}) { $self->log(LOGINFO, "pass, no record"); - return $self->cleanup_and_return($tied, $lock ); - }; + return $self->cleanup_and_return($tied, $lock); + } - my ($penalty_start_ts, $naughty, $nice, $connects) = $self->parse_value( $tied->{$key} ); + 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 ) { + if (!$penalty_start_ts) { $self->log(LOGINFO, "pass, no penalty ($summary)"); - return $self->cleanup_and_return($tied, $lock ); - }; + return $self->cleanup_and_return($tied, $lock); + } my $days_old = (time - $penalty_start_ts) / 86400; - if ( $days_old >= $self->{_args}{penalty_days} ) { + if ($days_old >= $self->{_args}{penalty_days}) { $self->log(LOGINFO, "pass, penalty expired ($summary)"); - return $self->cleanup_and_return($tied, $lock ); - }; + return $self->cleanup_and_return($tied, $lock); + } $tied->{$key} = join(':', $penalty_start_ts, $naughty, $nice, ++$connects); - $self->cleanup_and_return($tied, $lock ); + $self->cleanup_and_return($tied, $lock); my $left = sprintf "%.2f", $self->{_args}{penalty_days} - $days_old; my $mess = "You were naughty. You cannot connect for $left more days."; - return $self->get_reject( $mess, $karma ); + return $self->get_reject($mess, $karma); } sub rcpt_handler { my ($self, $transaction, $recipient, %args) = @_; my $recipients = scalar $self->transaction->recipients; - return DECLINED if $recipients < 2; # only one recipient + return DECLINED if $recipients < 2; # only one recipient my $karma = $self->connection->notes('karma_history'); - return DECLINED if $karma > 0; # good karma, no limit + return DECLINED if $karma > 0; # good karma, no limit -# limit # of recipients if host has negative or unknown karma - return $self->get_reject( "too many recipients"); -}; + # limit # of recipients if host has negative or unknown karma + return $self->get_reject("too many recipients"); +} sub data_handler { my ($self, $transaction) = @_; - return DECLINED if ! $self->qp->connection->relay_client; + return DECLINED if !$self->qp->connection->relay_client; - $self->adjust_karma( 5 ); # big karma boost for authenticated user/IP + $self->adjust_karma(5); # big karma boost for authenticated user/IP return DECLINED; -}; +} sub disconnect_handler { my $self = shift; @@ -348,30 +352,31 @@ sub disconnect_handler { }; 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 $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} ); - my $history = ($nice || 0) - $naughty; + my ($penalty_start_ts, $naughty, $nice, $connects) = + $self->parse_value($tied->{$key}); + my $history = ($nice || 0) - $naughty; my $log_mess = ''; - if ( $karma < -1 ) { # they achieved at least 2 strikes + if ($karma < -1) { # they achieved at least 2 strikes $history--; my $negative_limit = 0 - $self->{_args}{negative}; - if ( $history <= $negative_limit ) { - if ( $nice == 0 && $history < -5 ) { + if ($history <= $negative_limit) { + if ($nice == 0 && $history < -5) { $log_mess = ", penalty box bonus!"; $penalty_start_ts = sprintf "%s", time + abs($history) * 86400; } else { $penalty_start_ts = sprintf "%s", time; - }; + } $log_mess = "negative, sent to penalty box" . $log_mess; } else { $log_mess = "negative"; - }; + } } elsif ($karma > 1) { $nice++; @@ -380,84 +385,87 @@ sub disconnect_handler { else { $log_mess = "neutral"; } - $self->log(LOGINFO, $log_mess . ", (msg: $karma, his: $history)" ); + $self->log(LOGINFO, $log_mess . ", (msg: $karma, his: $history)"); $tied->{$key} = join(':', $penalty_start_ts, $naughty, $nice, ++$connects); - return $self->cleanup_and_return($tied, $lock ); + 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 ) { + 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 ); -}; + $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 ); + return 0 if (!$naughty && !$nice); - my $karma = ( $nice || 0 ) - ( $naughty || 0 ); - $self->connection->notes('karma_history', $karma ); - $self->adjust_karma( 1 ) if $karma > 10; + my $karma = ($nice || 0) - ($naughty || 0); + $self->connection->notes('karma_history', $karma); + $self->adjust_karma(1) if $karma > 10; return $karma; -}; +} sub cleanup_and_return { - my ($self, $tied, $lock, $return_val ) = @_; + my ($self, $tied, $lock, $return_val) = @_; untie $tied; close $lock; - return ($return_val) if defined $return_val; # explicit override + return ($return_val) if defined $return_val; # explicit override return (DECLINED); -}; +} sub get_db_key { my $self = shift; - my $ip = shift || $self->qp->connection->remote_ip; - my $nip = Net::IP->new( $ip ) or do { + my $ip = shift || $self->qp->connection->remote_ip; + my $nip = Net::IP->new($ip) or do { $self->log(LOGERROR, "skip, unable to determine remote IP"); return; }; - return $nip->intip; # convert IP to an int -}; + return $nip->intip; # convert IP to an int +} sub get_db_tie { - my ( $self, $db, $lock ) = @_; + my ($self, $db, $lock) = @_; - tie( my %db, 'AnyDBM_File', $db, O_CREAT|O_RDWR, 0600) or do { + tie(my %db, 'AnyDBM_File', $db, O_CREAT | O_RDWR, 0600) or do { $self->log(LOGCRIT, "error, 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 @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 + for my $d (@candidate_dirs) { + next if !$d || !-d $d; # impossible $dbdir = $d; - last; # first match wins + last; # first match wins } my $db = "$dbdir/karma.dbm"; - $self->log(LOGDEBUG,"using $db as karma database"); + $self->log(LOGDEBUG, "using $db as karma database"); return $db; -}; +} sub get_db_lock { my ($self, $db) = @_; @@ -465,12 +473,12 @@ sub get_db_lock { return $self->get_db_lock_nfs($db) if $self->{_args}{nfslock}; # Check denysoft db - open( my $lock, ">$db.lock" ) or do { + open(my $lock, ">$db.lock") or do { $self->log(LOGCRIT, "error, opening lockfile failed: $!"); return; }; - flock( $lock, LOCK_EX ) or do { + flock($lock, LOCK_EX) or do { $self->log(LOGCRIT, "error, flock of lockfile failed: $!"); close $lock; return; @@ -486,42 +494,43 @@ sub get_db_lock_nfs { ### 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 { + 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, "error, nfs lockfile failed: $!"); return; - }; + }; - open( my $lock, "+<$db.lock") or do { + open(my $lock, "+<$db.lock") or do { $self->log(LOGCRIT, "error, 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 $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; + 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 ); -}; + $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 index 627725c..b617e4b 100755 --- a/plugins/karma_tool +++ b/plugins/karma_tool @@ -11,27 +11,27 @@ 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 $self = bless({args => {db_dir => 'config'},}, 'Karma'); my $command = $ARGV[0]; -if ( ! $command ) { +if (!$command) { $self->usage(); } -elsif ( $command eq 'capture' ) { - $self->capture( $ARGV[1] ); +elsif ($command eq 'capture') { + $self->capture($ARGV[1]); } -elsif ( $command eq 'release' ) { - $self->release( $ARGV[1] ); +elsif ($command eq 'release') { + $self->release($ARGV[1]); } -elsif ( $command eq 'prune' ) { - $self->prune_db( $ARGV[1] || 7 ); +elsif ($command eq 'prune') { + $self->prune_db($ARGV[1] || 7); } -elsif ( $command eq 'search' && is_ip( $ARGV[1] ) ) { - $self->show_ip( $ARGV[1] ); +elsif ($command eq 'search' && is_ip($ARGV[1])) { + $self->show_ip($ARGV[1]); } -elsif ( $command eq 'list' | $command eq 'search' ) { +elsif ($command eq 'list' | $command eq 'search') { $self->main(); -}; +} exit(0); @@ -54,157 +54,170 @@ prune takes no arguments. prunes database of entries older than 7 days EO_HELP -; -}; + ; +} sub capture { my $self = shift; my $ip = shift or return; - is_ip( $ip ) or do { + 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 ); + 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); - my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/, $tied->{$key}; + my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/, + $tied->{$key}; - $tied->{$key} = join(':', time, $naughty+1, $nice, $connects); - return $self->cleanup_and_return( $tied, $lock ); -}; + $tied->{$key} = join(':', time, $naughty + 1, $nice, $connects); + 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; }; + 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 ); + 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); - my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/, $tied->{$key}; + my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/, + $tied->{$key}; $tied->{$key} = join(':', 0, 0, $nice, $connects); - return $self->cleanup_and_return( $tied, $lock ); -}; + return $self->cleanup_and_return($tied, $lock); +} sub show_ip { my $self = shift; - my $ip = shift or return; + my $ip = shift or 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 ); + 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); - my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/, $tied->{$key}; - $naughty ||= 0; - $nice ||= 0; + my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/, + $tied->{$key}; + $naughty ||= 0; + $nice ||= 0; $connects ||= 0; my $time_human = ''; - if ( $penalty_start_ts ) { + if ($penalty_start_ts) { $time_human = strftime "%a %b %e %H:%M", localtime $penalty_start_ts; - }; - my $hostname = `dig +short -x $ip` || ''; chomp $hostname; - print " IP Address Penalty Naughty Nice Connects Hostname\n"; - printf(" %-18s %24s %3s %3s %3s %-30s\n", $ip, $time_human, $naughty, $nice, $connects, $hostname); -}; + } + my $hostname = `dig +short -x $ip` || ''; + chomp $hostname; + print +" IP Address Penalty Naughty Nice Connects Hostname\n"; + printf(" %-18s %24s %3s %3s %3s %-30s\n", + $ip, $time_human, $naughty, $nice, $connects, $hostname); +} 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 $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 ||= ''; + 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' ) { + if ($command eq 'search') { my $search = $ARGV[1]; - if ( $search eq 'nice' ) { - next if ! $nice; + if ($search eq 'nice') { + next if !$nice; } - elsif ( $search eq 'naughty' ) { - next if ! $naughty; + elsif ($search eq 'naughty') { + next if !$naughty; } - elsif ( $search eq 'both' ) { - next if ! $naughty || ! $nice; + elsif ($search eq 'both') { + next if !$naughty || !$nice; } - elsif ( is_ip( $ARGV[1] ) && $search ne $ip ) { + elsif (is_ip($ARGV[1]) && $search ne $ip) { next; } - }; - if ( $penalty_start_ts ) { - $time_human = strftime "%a %b %e %H:%M", localtime $penalty_start_ts; - }; + } + if ($penalty_start_ts) { + $time_human = strftime "%a %b %e %H:%M", + localtime $penalty_start_ts; + } my $hostname = ''; - if ( $naughty && $nice ) { + 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); + } + 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]; - new Net::IP( $ip ) or return; + new Net::IP($ip) or return; return 1; -}; +} sub cleanup_and_return { - my ($self, $tied, $lock ) = @_; + my ($self, $tied, $lock) = @_; untie $tied; close $lock; -}; +} sub get_db_key { my $self = shift; - my $nip = Net::IP->new( shift ) or return; - return $nip->intip; # convert IP to an int -}; + my $nip = Net::IP->new(shift) or return; + return $nip->intip; # convert IP to an int +} sub get_db_tie { - my ( $self, $db, $lock ) = @_; + my ($self, $db, $lock) = @_; - tie( my %db, 'AnyDBM_File', $db, O_CREAT|O_RDWR, 0600) or do { + 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 @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 + for my $d (@candidate_dirs) { + next if !$d || !-d $d; # impossible $dbdir = $d; - last; # first match wins + 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) = @_; @@ -212,12 +225,12 @@ sub get_db_lock { return $self->get_db_lock_nfs($db) if $self->{_args}{nfslock}; # Check denysoft db - open( my $lock, ">$db.lock" ) or do { + open(my $lock, ">$db.lock") or do { warn "opening lockfile failed: $!"; return; }; - flock( $lock, LOCK_EX ) or do { + flock($lock, LOCK_EX) or do { warn "flock of lockfile failed: $!"; close $lock; return; @@ -233,43 +246,44 @@ sub get_db_lock_nfs { ### 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 { + 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 { + open(my $lock, "+<$db.lock") or do { warn "opening nfs lockfile failed: $!"; return; }; return $lock; -}; +} sub prune_db { - my $self = shift; + 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 $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 ) { + foreach my $key (keys %$tied) { my ($ts, $naughty, $nice, $connects) = split /:/, $tied->{$key}; - my $days_old = ( time - $ts ) / 86400; + 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 ); -}; + return $self->cleanup_and_return($tied, $lock); +} diff --git a/plugins/logging/adaptive b/plugins/logging/adaptive index 4e96ba6..572fbfd 100644 --- a/plugins/logging/adaptive +++ b/plugins/logging/adaptive @@ -3,92 +3,93 @@ # one level for DENY'd messages sub register { - my ( $self, $qp, %args ) = @_; + my ($self, $qp, %args) = @_; $self->{_minlevel} = LOGERROR; - if ( defined( $args{accept} ) ) { - if ( $args{accept} =~ /^\d+$/ ) { + if (defined($args{accept})) { + if ($args{accept} =~ /^\d+$/) { $self->{_minlevel} = $args{accept}; } else { - $self->{_minlevel} = log_level( $args{accept} ); + $self->{_minlevel} = log_level($args{accept}); } } $self->{_maxlevel} = LOGWARN; - if ( defined( $args{reject} ) ) { - if ( $args{reject} =~ /^\d+$/ ) { + if (defined($args{reject})) { + if ($args{reject} =~ /^\d+$/) { $self->{_maxlevel} = $args{reject}; } else { - $self->{_maxlevel} = log_level( $args{reject} ); + $self->{_maxlevel} = log_level($args{reject}); } } $self->{_prefix} = '`'; - if ( defined $args{prefix} and $args{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' ); + $self->log(LOGINFO, 'Initializing logging::adaptive plugin'); } -sub hook_logging { # wlog - my ( $self, $transaction, $trace, $hook, $plugin, @log ) = @_; +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} ) { + if (defined $self->{_maxlevel} && $trace <= $self->{_maxlevel}) { warn join( - " ", $$. - ( - defined $plugin ? " $plugin plugin:" - : defined $hook ? " running plugin ($hook):" - : "" - ), - @log - ), + " ", + $$ + . ( + 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} ); + 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 ) = @_; +sub hook_deny { # dlog + my ($self, $transaction, $prev_hook, $return, $return_text) = @_; $self->{_denied} = 1; } -sub hook_reset_transaction { # slog +sub hook_reset_transaction { # slog # fires when a message is accepted - my ( $self, $transaction, @args ) = @_; + my ($self, $transaction, @args) = @_; return DECLINED if $self->{_denied}; - foreach my $row ( @{ $transaction->{_log} } ) { + foreach my $row (@{$transaction->{_log}}) { next unless scalar @$row; # skip over empty log lines - my ( $trace, $hook, $plugin, @log ) = @$row; + my ($trace, $hook, $plugin, @log) = @$row; warn join( - " ", $$, - $self->{_prefix}. - ( - defined $plugin ? " $plugin plugin:" - : defined $hook ? " running plugin ($hook):" - : "" - ), - @log - ), + " ", $$, + $self->{_prefix} + . ( + defined $plugin ? " $plugin plugin:" + : defined $hook ? " running plugin ($hook):" + : "" + ), + @log + ), "\n" - if ( $trace <= $self->{_minlevel} ); + if ($trace <= $self->{_minlevel}); } return DECLINED; diff --git a/plugins/logging/apache b/plugins/logging/apache index 317b45c..b609922 100644 --- a/plugins/logging/apache +++ b/plugins/logging/apache @@ -64,7 +64,7 @@ sub hook_logging { . ( defined $plugin ? " $plugin plugin:" : defined $hook ? " running plugin ($hook):" - : "" + : "" ), @log ) diff --git a/plugins/logging/connection_id b/plugins/logging/connection_id index 7023601..fda0da9 100644 --- a/plugins/logging/connection_id +++ b/plugins/logging/connection_id @@ -5,41 +5,48 @@ # 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); - } - } + 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'); + # 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) = @_; + 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; + # 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}); + my $connection = $self->qp && $self->qp->connection; - return DECLINED; + # 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 diff --git a/plugins/logging/devnull b/plugins/logging/devnull index e8bbf8f..e55050f 100644 --- a/plugins/logging/devnull +++ b/plugins/logging/devnull @@ -2,6 +2,6 @@ # this is a simple 'drop packets on the floor' plugin sub hook_logging { - return DECLINED; + return DECLINED; } diff --git a/plugins/logging/file b/plugins/logging/file index cc51d92..7c82bf7 100644 --- a/plugins/logging/file +++ b/plugins/logging/file @@ -128,11 +128,11 @@ sub register { my %args; $self->{_loglevel} = LOGWARN; - $self->{_tsformat} = '%a %b %d %T %Y'; # same as scalar localtime + $self->{_tsformat} = '%a %b %d %T %Y'; # same as scalar localtime while (1) { - last if !@args; - if (lc $args[0] eq 'loglevel') { + last if !@args; + if (lc $args[0] eq 'loglevel') { shift @args; my $ll = shift @args; if (!defined $ll) { @@ -147,19 +147,19 @@ sub register { 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; - } + 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 } } @@ -171,13 +171,14 @@ sub register { my $output = join(' ', @args); if ($output =~ /^\s*\|(.*)/) { - $self->{_log_pipe} = 1; - $self->{_log_format} = $1; - } else { - $output =~ /^(.*)/; # detaint + $self->{_log_pipe} = 1; $self->{_log_format} = $1; } - $self->{_current_output} = ''; + else { + $output =~ /^(.*)/; # detaint + $self->{_log_format} = $1; + } + $self->{_current_output} = ''; $self->{_session_counter} = 0; 1; } @@ -191,14 +192,15 @@ sub log_output { } sub open_log { - my ($self,$output,$qp) = @_; + 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 { + } + else { unless ($self->{_f} = new IO::File ">>$output") { warn "Error opening log output to path $output: $!"; return undef; @@ -209,7 +211,6 @@ sub open_log { 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. @@ -219,10 +220,13 @@ 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'))) { + 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; } @@ -235,11 +239,14 @@ sub maybe_reopen { sub hook_connect { my ($self, $transaction) = @_; - $transaction->notes('file-logged-this-session', 0); + $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})); + $transaction->notes( + 'logging-session-id', + sprintf("%08d-%04d-%d", + scalar time, $$, + ++$self->{_session_counter}) + ); return DECLINED; } @@ -255,8 +262,9 @@ sub hook_disconnect { sub hook_logging { my ($self, $transaction, $trace, $hook, $plugin, @log) = @_; - return DECLINED if !defined $self->{_loglevel} or - $trace > $self->{_loglevel}; + 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: @@ -264,10 +272,11 @@ sub hook_logging { # - 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')) { + if ( !$self->{_f} + || !$self->{_nosplit} + || !$transaction + || !$transaction->notes('file-logged-this-session')) + { unless (defined $self->maybe_reopen($transaction)) { return DECLINED; } @@ -276,7 +285,7 @@ sub hook_logging { my $f = $self->{_f}; print $f strftime($self->{_tsformat}, localtime), ' ', - hostname(), '[', $$, ']: ', @log, "\n"; + hostname(), '[', $$, ']: ', @log, "\n"; return DECLINED; } diff --git a/plugins/logging/syslog b/plugins/logging/syslog index 8552650..b37def2 100644 --- a/plugins/logging/syslog +++ b/plugins/logging/syslog @@ -116,13 +116,14 @@ sub register { if (@args % 2 == 0) { %args = @args; - } else { + } + else { warn "Malformed arguments to syslog plugin"; return; } - my $ident = 'qpsmtpd'; - my $logopt = 'pid'; + my $ident = 'qpsmtpd'; + my $logopt = 'pid'; my $facility = 'LOG_MAIL'; $self->{_loglevel} = LOGWARN; @@ -150,8 +151,8 @@ sub register { } if ($args{logsock}) { - my @logopt = split(/,/, $args{logsock}); - setlogsock(@logopt); + my @logopt = split(/,/, $args{logsock}); + setlogsock(@logopt); } unless (openlog $ident, $logopt, $facility) { @@ -161,15 +162,15 @@ sub register { } 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', -); + 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) = @_; @@ -177,8 +178,8 @@ sub hook_logging { 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}; + 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 index bc5a293..aa6d503 100644 --- a/plugins/logging/transaction_id +++ b/plugins/logging/transaction_id @@ -5,40 +5,46 @@ # as how to ignore log entries from itself sub register { - my ($self, $qp, $loglevel) = @_; - die "The transaction ID feature is currently unsupported"; + 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); - } - } + $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'); + # 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) = @_; + 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; + # 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}); + warn join( + " ", + ($transaction ? $transaction->id : "???") + . ( + defined $plugin ? " $plugin plugin:" + : defined $hook ? " running plugin ($hook):" + : "" + ), + @log + ), + "\n" + if ($trace <= $self->{_level}); - return DECLINED; + return DECLINED; } =head1 NAME diff --git a/plugins/logging/warn b/plugins/logging/warn index c85b9d5..1b772cd 100644 --- a/plugins/logging/warn +++ b/plugins/logging/warn @@ -38,36 +38,38 @@ Please see the LICENSE file included with qpsmtpd for details. =cut sub register { - my ($self, $qp, $loglevel) = @_; + my ($self, $qp, $loglevel) = @_; - $self->{_level} = LOGWARN; - if ( defined($loglevel) ) { - if ($loglevel =~ /^\d+$/) { - $self->{_level} = $loglevel; - } - else { - $self->{_level} = log_level($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'); + # 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) = @_; + 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. + # 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:" : ''; + my $prefix = + defined $plugin && defined $hook ? " ($hook) $plugin:" + : defined $plugin ? " $plugin:" + : defined $hook ? " ($hook) running plugin:" + : ''; warn join(' ', $$ . $prefix, @log), "\n"; diff --git a/plugins/loop b/plugins/loop index 1a3d264..b0d8e51 100644 --- a/plugins/loop +++ b/plugins/loop @@ -29,28 +29,30 @@ Released to the public domain, 17 June 2005. use Qpsmtpd::DSN; sub init { - my ($self, $qp, @args) = @_; + my ($self, $qp, @args) = @_; - $self->{_max_hops} = $args[0] || 100; + $self->{_max_hops} = $args[0] || 100; - if ( $self->{_max_hops} !~ /^\d+$/ ) { - $self->log(LOGWARN, "Invalid max_hops value -- using default"); - $self->{_max_hops} = 100; - } - $self->log(LOGWARN, "Ignoring additional arguments") if @args > 1; + if ($self->{_max_hops} !~ /^\d+$/) { + $self->log(LOGWARN, "Invalid max_hops value -- using default"); + $self->{_max_hops} = 100; + } + $self->log(LOGWARN, "Ignoring additional arguments") if @args > 1; } sub hook_data_post { - my ($self, $transaction) = @_; + my ($self, $transaction) = @_; - my $hops = 0; - $hops++ for $transaction->header->get('Received'), - $transaction->header->get('Delivered-To'); + 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(); - } + if ($hops >= $self->{_max_hops}) { - return DECLINED; + # 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/milter b/plugins/milter index 64370e9..824e10e 100644 --- a/plugins/milter +++ b/plugins/milter @@ -1,4 +1,5 @@ #!perl -w + =head1 NAME milter @@ -31,19 +32,19 @@ use Qpsmtpd::Constants; no warnings; sub register { - my ($self, $qp, @args) = @_; + 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; - 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 { @@ -51,8 +52,8 @@ sub hook_disconnect { my $milter = $self->connection->notes('milter') || return DECLINED; $milter->send_quit(); - - $self->connection->notes('spam', undef); + + $self->connection->notes('spam', undef); $self->connection->notes('milter', undef); return DECLINED; @@ -62,9 +63,11 @@ 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}"); + $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})"); + die( +"Rejected at $where by $self->{name} milter ($result->{explanation})"); } elsif ($result->{action} eq 'add') { if ($result->{header} eq 'body') { @@ -72,27 +75,29 @@ sub check_results { } else { push @{$transaction->notes('milter_header_changes')->{add}}, - [$result->{header}, $result->{value}]; + [$result->{header}, $result->{value}]; } } elsif ($result->{action} eq 'delete') { push @{$transaction->notes('milter_header_changes')->{delete}}, - $result->{header}; + $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}]; + [$result->{header}, $result->{value}]; } } } sub hook_connect { my ($self, $transaction) = @_; - - $self->log(LOGDEBUG, "milter $self->{name} opening connection to milter backend"); + + $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(); @@ -100,15 +105,21 @@ sub hook_connect { $self->connection->notes(milter => $milter); $self->connection->notes( - milter_header_changes => { add => [], delete => [], replace => [], } - ); - my $remote_ip = $self->qp->connection->remote_ip; + 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\]"); - + $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->check_results( + $transaction, + "connection", + $milter->send_connect( + $remote_host, 'tcp4', 0, $remote_ip + ) + ); }; $self->connection->notes('spam', $@) if $@; @@ -121,44 +132,51 @@ sub hook_helo { 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 $@; - + + 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 $@; + $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); + $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 $@; + eval { + $self->check_results($transaction, "RCPT TO", + $milter->send_rcpt_to($address->format)); + }; + return (DENY, $@) if $@; return DECLINED; } @@ -170,25 +188,31 @@ sub hook_data_post { $self->log(LOGDEBUG, "milter $self->{name} checking headers"); - my $headers = $transaction->header(); # Mail::Header object + 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 $@; + + # $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 $@; - + + 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//; @@ -202,25 +226,31 @@ sub hook_data_post { 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 $@; + 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 $@; + 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'); + 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]); @@ -231,6 +261,6 @@ sub hook_data_post { foreach my $repl (@{$milter_header_changes->{replace}}) { $headers->replace($repl->[0], $repl->[1]); } - + return DECLINED; } diff --git a/plugins/naughty b/plugins/naughty index b1f4441..3b41826 100644 --- a/plugins/naughty +++ b/plugins/naughty @@ -109,28 +109,28 @@ 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} = {@_}; + $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 /; + 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'); + 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'); - }; + 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'); + $self->register_hook($reject, 'naughty'); } sub naughty { @@ -140,8 +140,11 @@ sub naughty { return DECLINED; }; $self->log(LOGINFO, "disconnecting"); - my $type = $self->get_reject_type( 'disconnect', - $self->connection->notes('naughty_reject_type') ); - return ( $type, $naughty ); -}; + my $type = $self->get_reject_type( + 'disconnect', + $self->connection->notes( + 'naughty_reject_type') + ); + return ($type, $naughty); +} diff --git a/plugins/noop_counter b/plugins/noop_counter index 6ce949b..8e9840e 100644 --- a/plugins/noop_counter +++ b/plugins/noop_counter @@ -33,30 +33,30 @@ sub register { 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 :-) + ### 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 (DENY_DISCONNECT, + "Stop wasting my time, too many consecutive NOOPs"); } return (DECLINED); } sub reset_noop_counter { - $_[0]->{_noop_count} = 0; - return (DECLINED); + $_[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; +*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 index 2d70e7b..2af5f4c 100644 --- a/plugins/parse_addr_withhelo +++ b/plugins/parse_addr_withhelo @@ -35,20 +35,20 @@ sub hook_rcpt_parse { } sub _parse { - my ($self,$cmd,$line) = @_; + my ($self, $cmd, $line) = @_; $self->log(LOGDEBUG, "_parse() cmd=[$cmd], line=[$line]"); if ($cmd eq 'mail') { - return(DENY, "Syntax error in command") + return (DENY, "Syntax error in command") unless ($line =~ s/^from:\s*//i); } - else { # cmd eq 'rcpt' - return(DENY, "Syntax error in command") + 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)) + return (DENY, "No parameters allowed in " . uc($cmd)) if ($line =~ /^\S/); return (OK, $addr, ()); } @@ -56,13 +56,13 @@ sub _parse { ## now, no <> are given $line =~ s/\s*$//; if ($line =~ /\@/) { - return (DENY, "No parameters allowed in ".uc($cmd)) + 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 (OK, "<>") unless $line; # 'MAIL FROM:' -> 'MAIL FROM:<>' return (DENY, "Could not parse your MAIL FROM command"); } else { diff --git a/plugins/qmail_deliverable b/plugins/qmail_deliverable old mode 100755 new mode 100644 index ec45024..62609f8 --- a/plugins/qmail_deliverable +++ b/plugins/qmail_deliverable @@ -90,21 +90,21 @@ BEGIN { if (not $INC{'Qpsmtpd.pm'}) { my $dir = '$PLUGINS_DIRECTORY'; -d and $dir = $_ for qw( - /home/qpsmtpd/plugins - /home/smtp/qpsmtpd/plugins - /usr/local/qpsmtpd/plugins - /usr/local/share/qpsmtpd/plugins - /usr/share/qpsmtpd/plugins - ); + /home/qpsmtpd/plugins + /home/smtp/qpsmtpd/plugins + /usr/local/qpsmtpd/plugins + /usr/local/share/qpsmtpd/plugins + /usr/share/qpsmtpd/plugins + ); my $file = "the 'plugins' configuration file"; -f and $file = $_ for qw( - /home/qpsmtpd/config/plugins - /home/smtp/qpsmtpd/config/plugins - /usr/local/qpsmtpd/config/plugins - /usr/local/etc/qpsmtpd/plugins - /etc/qpsmtpd/plugins - ); + /home/qpsmtpd/config/plugins + /home/smtp/qpsmtpd/config/plugins + /usr/local/qpsmtpd/config/plugins + /usr/local/etc/qpsmtpd/plugins + /etc/qpsmtpd/plugins + ); # "die" would print "BEGIN failed" garbage print STDERR <<"END"; @@ -135,20 +135,21 @@ use Qpsmtpd::Constants; use Qmail::Deliverable::Client qw(deliverable); my %smtproutes; -my $shared_domain; # global variable to be closed over by the SERVER callback +my $shared_domain; # global variable to be closed over by the SERVER callback sub register { my ($self, $qp, @args) = @_; if (@args % 2) { $self->log(LOGWARN, "Odd number of arguments, using default config"); - } else { + } + else { my %args = @args; if ($args{server} && $args{server} =~ /^smtproutes:/) { my ($fallback, $port) = $args{server} =~ /:(?:(.*?):?)(\d+)/; open my $fh, "/var/qmail/control/smtproutes" - or warn "Could not read smtproutes"; + or warn "Could not read smtproutes"; for (readline $fh) { my ($domain, $mx) = /^(.*?) : \[? ( [^\]:\s]* )/x; $smtproutes{$domain} = $mx; @@ -161,16 +162,17 @@ sub register { return; }; - } elsif ($args{server}) { + } + elsif ($args{server}) { $Qmail::Deliverable::Client::SERVER = $args{server}; } - if ( $args{vpopmail_ext} ) { + if ($args{vpopmail_ext}) { $Qmail::Deliverable::VPOPMAIL_EXT = $args{vpopmail_ext}; - }; - if ( $args{reject} ) { + } + if ($args{reject}) { $self->{_args}{reject} = $args{reject}; - }; + } } $self->register_hook("rcpt", "rcpt_handler"); } @@ -178,7 +180,7 @@ sub register { sub rcpt_handler { my ($self, $transaction, $rcpt) = @_; - return DECLINED if $self->is_immune(); # requires QP 0.90+ + return DECLINED if $self->is_immune(); # requires QP 0.90+ my $address = $rcpt->address; $self->log(LOGDEBUG, "Checking deliverability for recipient '$address'"); @@ -192,38 +194,41 @@ sub rcpt_handler { return DECLINED; } - my $k = 0; # known status code - $self->log(LOGINFO, "error, permission failure"), $k++ if $rv == 0x11; - $self->log(LOGINFO, "pass, qmail-command in dot-qmail"),$k++ if $rv == 0x12; + my $k = 0; # known status code + $self->log(LOGINFO, "error, permission failure"), $k++ if $rv == 0x11; + $self->log(LOGINFO, "pass, qmail-command in dot-qmail"), $k++ + if $rv == 0x12; $self->log(LOGINFO, "pass, bouncesaying with program"), $k++ if $rv == 0x13; - if ( $rv == 0x14 ) { + if ($rv == 0x14) { my $s = $transaction->sender->address; return (DENY, "mailing lists do not accept null senders") - if ( ! $s || $s eq '<>'); - $self->log(LOGINFO, "pass, ezmlm list"); $k++; - }; + if (!$s || $s eq '<>'); + $self->log(LOGINFO, "pass, ezmlm list"); + $k++; + } $self->log(LOGINFO, "Temporarily undeliverable: group/world writable"), $k++ - if $rv == 0x21; - $self->log(LOGINFO, "Temporarily undeliverable: sticky home directory"),$k++ - if $rv == 0x22; + if $rv == 0x21; + $self->log(LOGINFO, "Temporarily undeliverable: sticky home directory"), + $k++ + if $rv == 0x22; $self->log(LOGINFO, "error, $Qmail::Deliverable::Client::ERROR"), $k++ - if $rv == 0x2f; - $self->log(LOGINFO, "pass, normal delivery"), $k++ if $rv == 0xf1; - $self->log(LOGINFO, "pass, vpopmail dir"), $k++ if $rv == 0xf2; - $self->log(LOGINFO, "pass, vpopmail alias"), $k++ if $rv == 0xf3; - $self->log(LOGINFO, "pass, vpopmail catchall"), $k++ if $rv == 0xf4; - $self->log(LOGINFO, "pass, vpopmail vuser"), $k++ if $rv == 0xf5; - $self->log(LOGINFO, "pass, vpopmail qmail-ext"), $k++ if $rv == 0xf6; - $self->log(LOGINFO, "error, SHOULD NOT HAPPEN"), $k++ if $rv == 0xfe; - $self->log(LOGINFO, "fail, address not local"), $k++ if $rv == 0xff; + if $rv == 0x2f; + $self->log(LOGINFO, "pass, normal delivery"), $k++ if $rv == 0xf1; + $self->log(LOGINFO, "pass, vpopmail dir"), $k++ if $rv == 0xf2; + $self->log(LOGINFO, "pass, vpopmail alias"), $k++ if $rv == 0xf3; + $self->log(LOGINFO, "pass, vpopmail catchall"), $k++ if $rv == 0xf4; + $self->log(LOGINFO, "pass, vpopmail vuser"), $k++ if $rv == 0xf5; + $self->log(LOGINFO, "pass, vpopmail qmail-ext"), $k++ if $rv == 0xf6; + $self->log(LOGINFO, "error, SHOULD NOT HAPPEN"), $k++ if $rv == 0xfe; + $self->log(LOGINFO, "fail, address not local"), $k++ if $rv == 0xff; - if ( $rv ) { + if ($rv) { $self->log(LOGINFO, sprintf("error, unknown: 0x%02x", $rv)) if not $k; return DECLINED; - }; + } - $self->adjust_karma( -1 ); - return $self->get_reject( "Sorry, no mailbox by that name. qd (#5.1.1)" ); + $self->adjust_karma(-1); + return $self->get_reject("Sorry, no mailbox by that name. qd (#5.1.1)"); } sub _smtproute { diff --git a/plugins/queue/exim-bsmtp b/plugins/queue/exim-bsmtp index 0dd4246..784f5ab 100644 --- a/plugins/queue/exim-bsmtp +++ b/plugins/queue/exim-bsmtp @@ -1,4 +1,5 @@ #!perl -w + =head1 NAME exim-bsmtp @@ -69,8 +70,10 @@ sub register { $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"); + $self->log(LOGERROR, + "Could not find exim at $self->{_exim_path};" + . " please set exim_path in config/plugins" + ); return undef; } } @@ -91,14 +94,14 @@ sub hook_queue { } print $tmp "HELO ", hostname(), "\n", - "MAIL FROM:<", ($transaction->sender->address || ''), ">\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; + $line =~ s/^\./../; + print $tmp $line; } print $tmp ".\nQUIT\n"; close $tmp; @@ -111,6 +114,7 @@ sub hook_queue { 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; @@ -122,20 +126,23 @@ sub hook_queue { ($bsmtp_error, $bsmtp_msg) = ($1, $2); } } - $self->log(LOGDEBUG, "BSMTP finished (".(time - $start)." sec)"); + $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)"); + $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"); + $self->log(LOGERROR, + 'BSMTP enqueue failed; exitcode ' + . ($exit >> 8) + . " from $self->{_exim_path} -bS" + ); return (DECLINED, 'Internal error enqueuing mail'); } diff --git a/plugins/queue/maildir b/plugins/queue/maildir index 0c71b85..b90d4e3 100644 --- a/plugins/queue/maildir +++ b/plugins/queue/maildir @@ -41,9 +41,9 @@ Replaced by the full address. =cut # =item %% -# +# # Replaced by a single percent sign (%) -# +# # =cut =back @@ -82,133 +82,145 @@ use Sys::Hostname qw(hostname); use Time::HiRes qw(gettimeofday); sub register { - my ($self, $qp, @args) = @_; + my ($self, $qp, @args) = @_; - if (@args > 0) { - ($self->{_maildir}) = ($args[0] =~ m!([-/\w\.]+)!); - } + 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; + } - 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; + + # 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; } - } - 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 $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); + 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) { + 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 ($rc, @msg); - } + return (OK, @msg); # last @msg is the same like any other before... } - 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); + $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; + my ($self, $transaction, $maildir, $addr) = @_; + my ($time, $microseconds) = gettimeofday; - $time = ($time =~ m/(\d+)/)[0]; - $microseconds =~ s/\D//g; + $time = ($time =~ m/(\d+)/)[0]; + $microseconds =~ s/\D//g; - my $unique = "P$$" . "M$microseconds" . "Q" . $maildir_counter++; - my $file = join ".", $time, $unique, $self->{_hostname}; + my $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)"); + 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 "Return-Path: ", $transaction->sender->format, "\n"; - print MF "Delivered-To: ",$addr->address,"\n" - if $addr; # else it had been added before... + 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)"); + $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)"); + 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"; + unlink "$maildir/tmp/$file"; - my $msg_id = $transaction->header->get('Message-Id') || ''; - $msg_id =~ s/[\r\n].*//s; + my $msg_id = $transaction->header->get('Message-Id') || ''; + $msg_id =~ s/[\r\n].*//s; - return (OK, "Queued! $msg_id"); + 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 ($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 $subdir = $self->{_subdirs}; + $subdir =~ s/\%l/$user/g; + $subdir =~ s/\%d/$host/g; + $subdir =~ s/\%u/$rcpt/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; + # $subdir =~ s/\%%/%/g; - return $self->write_file($transaction, $maildir, $addr); + 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 index 2586d9a..9eea355 100644 --- a/plugins/queue/postfix-queue +++ b/plugins/queue/postfix-queue @@ -128,20 +128,22 @@ use Qpsmtpd::Postfix::Constants; sub register { my ($self, $qp, @args) = @_; - $self->log(LOGDEBUG, "using constants generated from Postfix" - ."v$postfix_version"); + $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_]+)$/) { + 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 { @@ -166,29 +168,32 @@ sub hook_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')); +# $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}); + + # 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}); + 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)"); + + # 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') || ''; diff --git a/plugins/queue/qmail-queue b/plugins/queue/qmail-queue index b50b73a..1d97fc3 100644 --- a/plugins/queue/qmail-queue +++ b/plugins/queue/qmail-queue @@ -20,7 +20,6 @@ If set the environment variable QMAILQUEUE overrides this setting. =cut - use strict; use warnings; @@ -32,7 +31,8 @@ sub register { if (@args > 0) { $self->{_queue_exec} = $args[0]; - $self->log(LOGWARN, "WARNING: Ignoring additional arguments.") if @args > 1; + $self->log(LOGWARN, "WARNING: Ignoring additional arguments.") + if @args > 1; } $self->{_queue_exec} ||= ($ENV{QMAIL} || '/var/qmail') . "/bin/qmail-queue"; @@ -42,19 +42,23 @@ sub register { sub hook_queue { my ($self, $transaction) = @_; -# these bits inspired by Peter Samuels "qmail-queue wrapper" + # 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"; + pipe(ENVELOPE_READER, ENVELOPE_WRITER) + or die "Could not create envelope pipe"; local $SIG{PIPE} = sub { die 'SIGPIPE' }; my $child = fork(); - ! defined $child and die "Could not fork"; + !defined $child and die "Could not fork"; if ($child) { -# Parent - my $oldfh = select MESSAGE_WRITER; $| = 1; - select ENVELOPE_WRITER; $| = 1; + + # Parent + my $oldfh = select MESSAGE_WRITER; + $| = 1; + select ENVELOPE_WRITER; + $| = 1; select $oldfh; close MESSAGE_READER or die "close msg reader fault"; @@ -68,51 +72,59 @@ sub hook_queue { 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"); + 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)"); + $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"); + $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; + + # Child + close MESSAGE_WRITER or exit 1; close ENVELOPE_WRITER or exit 2; -# Untaint $self->{_queue_exec} + # 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. + } + 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"); + # 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: $!"; + 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 to $queue_exec"); my $rc = exec $queue_exec; -# close the pipe + # close the pipe close(MESSAGE_READER); close(MESSAGE_WRITER); - exit 6; # we'll only get here if the exec fails + exit 6; # we'll only get here if the exec fails } } diff --git a/plugins/queue/smtp-forward b/plugins/queue/smtp-forward index a6c23c3..5491569 100644 --- a/plugins/queue/smtp-forward +++ b/plugins/queue/smtp-forward @@ -1,4 +1,5 @@ #!perl -w + =head1 NAME smtp-forward @@ -23,48 +24,56 @@ Optionally you can also add a port: use Net::SMTP; sub init { - my ($self, $qp, @args) = @_; + my ($self, $qp, @args) = @_; - if (@args > 0) { - if ($args[0] =~ /^([\.\w_-]+)$/) { - $self->{_smtp_server} = $1; + 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 "Bad data in smtp server: $args[0]"; + die("No SMTP server specified in smtp-forward config"); } - $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) = @_; + 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!"); + $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 index 2e1effe..15abfc9 100644 --- a/plugins/quit_fortune +++ b/plugins/quit_fortune @@ -1,17 +1,17 @@ #!perl -w sub hook_quit { - my $qp = shift->qp; + 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"; + # 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 = '/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; + 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 index 780ee06..bceb2c5 100644 --- a/plugins/random_error +++ b/plugins/random_error @@ -27,17 +27,17 @@ For use with other plugins, scribble the revised failure rate to =cut sub register { - my ($self, $qp, @args) = @_; + my ($self, $qp, @args) = @_; + + die "Invalid args: '@args'" unless @args < 2; + ($self->{__PACKAGE__ . '_how'}) = $args[0] || 1; - 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_%'); + my $fpct = $_[0]->connection->notes('random_fail_%'); =head1 calculating the probability of failure @@ -52,40 +52,41 @@ 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"); + + 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 + $_[0]->connection->notes('random_fail_%', $_[0]->{__PACKAGE__ . '_how'}); + goto &random_fail; } sub hook_helo { - goto &random_fail + goto &random_fail; } sub hook_ehlo { - goto &random_fail + goto &random_fail; } sub hook_mail { - goto &random_fail + goto &random_fail; } sub hook_rcpt { - goto &random_fail + goto &random_fail; } sub hook_data { - goto &random_fail + goto &random_fail; } sub hook_data_post { - goto &random_fail + goto &random_fail; } diff --git a/plugins/rcpt_map b/plugins/rcpt_map index e18d168..367fa07 100644 --- a/plugins/rcpt_map +++ b/plugins/rcpt_map @@ -113,17 +113,17 @@ sub register { $self->{_default} or $self->{_default} = [DENY, "No such user."]; - $self->{_file} + $self->{_file} or die "No map file given..."; - $self->{_domain} + $self->{_domain} or die "No domain name given..."; $self->{_domain} = lc $self->{_domain}; - $self->log(LOGDEBUG, - "Using map ".$self->{_file}." for domain ".$self->{_domain}); + $self->log(LOGDEBUG, + "Using map " . $self->{_file} . " for domain " . $self->{_domain}); %map = $self->read_map(1); - die "Empty map file ".$self->{_file} + die "Empty map file " . $self->{_file} unless keys %map; } @@ -132,7 +132,7 @@ sub hook_pre_connection { my ($time) = (stat($self->{_file}))[9] || 0; if ($time > $self->{_time}) { my %temp = $self->read_map(); - keys %temp + keys %temp or return DECLINED; %map = %temp; } @@ -157,14 +157,14 @@ sub read_map { next unless $addr; unless ($code) { - $self->log(LOGERROR, - "No constant in line $line in ".$self->{_file}); + $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}); + $self->log(LOGERROR, + "Not a valid constant in line $line in " . $self->{_file}); next; } $msg or $msg = "No such user."; @@ -184,6 +184,6 @@ sub hook_rcpt { 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 index ba4ba45..57f64b7 100644 --- a/plugins/rcpt_ok +++ b/plugins/rcpt_ok @@ -28,16 +28,16 @@ use Qpsmtpd::Constants; use Qpsmtpd::DSN; sub hook_rcpt { - my ($self, $transaction, $recipient, %param) = @_; + 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); + # 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 + 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... @@ -45,55 +45,55 @@ sub hook_rcpt { } sub is_in_rcpthosts { - my ( $self, $host ) = @_; + 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" ); + 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" ); + 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 ($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" ); + if (exists $more_rcpt_hosts->{$host}) { + $self->log(LOGINFO, "pass: $host found in morercpthosts"); return 1; - }; + } - $self->log( LOGINFO, "fail: $host not in morercpthosts" ); + $self->log(LOGINFO, "fail: $host not in morercpthosts"); return; -}; +} sub get_rcpt_host { - my ( $self, $recipient ) = @_; + my ($self, $recipient) = @_; - return if ! $recipient; # Qpsmtpd::Address couldn't parse the recipient + return if !$recipient; # Qpsmtpd::Address couldn't parse the recipient - if ( $recipient->host ) { + 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' ) { + 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 index 40705b7..41d93a4 100644 --- a/plugins/rcpt_regexp +++ b/plugins/rcpt_regexp @@ -1,4 +1,5 @@ #!perl -w + =head1 NAME rcpt_regexp - check recipients against a list of regular expressions diff --git a/plugins/relay b/plugins/relay index 7cba450..61a2ec5 100644 --- a/plugins/relay +++ b/plugins/relay @@ -105,14 +105,14 @@ use Qpsmtpd::Constants; use Net::IP qw(:PROC); sub register { - my ($self, $qp) = ( shift, shift ); + my ($self, $qp) = (shift, shift); $self->log(LOGERROR, "Bad arguments") if @_ % 2; - $self->{_args} = { @_ }; + $self->{_args} = {@_}; - if ( $self->{_args}{only} ) { + if ($self->{_args}{only}) { $self->register_hook('rcpt', 'relay_only'); - }; -}; + } +} sub is_in_norelayclients { my $self = shift; @@ -121,30 +121,30 @@ sub is_in_norelayclients { my $ip = $self->qp->connection->remote_ip; - while ( $ip ) { - if ( exists $no_relay_clients{$ip} ) { + while ($ip) { + if (exists $no_relay_clients{$ip}) { $self->log(LOGINFO, "$ip in norelayclients"); return 1; } - $ip =~ s/(\d|\w)+(:|\.)?$// or last; # strip off another octet - }; + $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') ) { + foreach ($self->qp->config('relayclients')) { my ($network, $netmask) = ip_splitprefix($_); - if ( $netmask ) { - push @{ $self->{_cidr_blocks} }, $_; + if ($netmask) { + push @{$self->{_cidr_blocks}}, $_; next; } - $self->{_octets}{$_} = 1; # no prefix, split + $self->{_octets}{$_} = 1; # no prefix, split } -}; +} sub is_in_cidr_block { my $self = shift; @@ -154,20 +154,20 @@ sub is_in_cidr_block { return; }; 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 + 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 + # expand the client address (zero pad it) before converting to binary my $bin_ip = ip_iptobin(ip_expand_address($ip, $cversion), $cversion) - or next; + or next; - next if ! $begin || ! $end; # probably not a netmask entry + next if !$begin || !$end; # probably not a netmask entry - if ( ip_bincomp($bin_ip, 'gt', ip_iptobin($begin, $rversion)) - && ip_bincomp($bin_ip, 'lt', ip_iptobin($end, $rversion)) - ) { + 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; } @@ -175,75 +175,75 @@ sub is_in_cidr_block { $self->log(LOGDEBUG, "no cidr match"); return; -}; +} sub is_octet_match { my $self = shift; my $ip = $self->qp->connection->remote_ip; - if ( $ip eq '::1' ) { + if ($ip eq '::1') { $self->log(LOGINFO, "pass, octet matched localhost ($ip)"); return 1; - }; + } my $more_relay_clients = $self->qp->config('morerelayclients', 'map'); my $ipv6 = $ip =~ /:/ ? 1 : 0; - if ( $ipv6 && $ip =~ /::/ ) { # IPv6 compressed notation - $ip = Net::IP::ip_expand_address($ip,6); - }; + if ($ipv6 && $ip =~ /::/) { # IPv6 compressed notation + $ip = Net::IP::ip_expand_address($ip, 6); + } while ($ip) { - if ( exists $self->{_octets}{$ip} ) { + if (exists $self->{_octets}{$ip}) { $self->log(LOGINFO, "pass, octet match in relayclients ($ip)"); return 1; - }; + } - if ( exists $more_relay_clients->{$ip} ) { + if (exists $more_relay_clients->{$ip}) { $self->log(LOGINFO, "pass, octet match in morerelayclients ($ip)"); return 1; - }; + } # added IPv6 support (Michael Holzt - 2012-11-14) - if ( $ipv6 ) { - $ip =~ s/[0-9a-f]:?$//; # strip off another nibble + if ($ipv6) { + $ip =~ s/[0-9a-f]:?$//; # strip off another nibble chop $ip if ':' eq substr($ip, -1, 1); } else { - $ip =~ s/\d+\.?$// or last; # strip off another 8 bits + $ip =~ s/\d+\.?$// or last; # strip off another 8 bits } } - $self->log(LOGDEBUG, "no octet match" ); + $self->log(LOGDEBUG, "no octet match"); return; } sub hook_connect { my ($self, $transaction) = @_; - if ( $self->is_in_norelayclients() ) { + if ($self->is_in_norelayclients()) { $self->qp->connection->relay_client(0); delete $ENV{RELAYCLIENT}; $self->log(LOGINFO, "fail, disabled by norelayclients"); return (DECLINED); } - if ( $ENV{RELAYCLIENT} ) { + if ($ENV{RELAYCLIENT}) { $self->qp->connection->relay_client(1); $self->log(LOGINFO, "pass, enabled by env"); return (DECLINED); - }; + } $self->populate_relayclients(); -# 95586 (connect) relay: pass, octet match in relayclients (127.0.0.) + # 95586 (connect) relay: pass, octet match in relayclients (127.0.0.) - if ( $self->is_in_cidr_block() || $self->is_octet_match() ) { + 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); @@ -251,9 +251,9 @@ sub hook_connect { sub relay_only { my $self = shift; - if ( $self->qp->connection->relay_client ) { + if ($self->qp->connection->relay_client) { return (OK); - }; + } return (DENY); } diff --git a/plugins/resolvable_fromhost b/plugins/resolvable_fromhost index 6d4ed0a..aa881a3 100644 --- a/plugins/resolvable_fromhost +++ b/plugins/resolvable_fromhost @@ -86,9 +86,9 @@ sub register { foreach (keys %args) { $self->{_args}->{$_} = $args{$_}; } - if ( ! defined $self->{_args}{reject} ) { + if (!defined $self->{_args}{reject}) { $self->{_args}{reject} = 1; - }; + } $self->{_args}{reject_type} ||= 'soft'; } @@ -97,82 +97,86 @@ sub hook_mail { return DECLINED if $self->is_immune(); - if ( $sender eq '<>' ) { + if ($sender eq '<>') { $transaction->notes('resolvable_fromhost', 'null'); $self->log(LOGINFO, "pass, null sender"); return DECLINED; - }; + } $self->populate_invalid_networks(); my $resolved = $self->check_dns($sender->host, $transaction); - return DECLINED if $resolved; # success, no need to continue - #return DECLINED if $sender->host; # reject later + return DECLINED if $resolved; # success, no need to continue + #return DECLINED if $sender->host; # reject later my $result = $transaction->notes('resolvable_fromhost') or do { - if ( $self->{_args}{reject} ) {; - $self->log(LOGINFO, 'fail, missing result' ); - return Qpsmtpd::DSN->temp_resolver_failed( $self->get_reject_type(), '' ); - }; - $self->log(LOGINFO, 'fail, missing result, reject disabled' ); + if ($self->{_args}{reject}) { + ; + $self->log(LOGINFO, 'fail, missing result'); + return Qpsmtpd::DSN->temp_resolver_failed($self->get_reject_type(), + ''); + } + $self->log(LOGINFO, 'fail, missing result, reject disabled'); return DECLINED; }; - return DECLINED if $result =~ /^(?:a|ip|mx)$/; # success - return DECLINED if $result =~ /^(?:whitelist|null|naughty)$/; # immunity + return DECLINED if $result =~ /^(?:a|ip|mx)$/; # success + return DECLINED if $result =~ /^(?:whitelist|null|naughty)$/; # immunity - $self->adjust_karma( -1 ); + $self->adjust_karma(-1); - if ( ! $self->{_args}{reject} ) {; - $self->log(LOGINFO, "fail, reject disabled, $result" ); + if (!$self->{_args}{reject}) { + ; + $self->log(LOGINFO, "fail, reject disabled, $result"); return DECLINED; - }; + } - $self->log(LOGINFO, "fail, $result" ); # log error - return Qpsmtpd::DSN->addr_bad_from_system( $self->get_reject_type(), - "FQDN required in the envelope sender"); + $self->log(LOGINFO, "fail, $result"); # log error + return + Qpsmtpd::DSN->addr_bad_from_system($self->get_reject_type(), + "FQDN required in the envelope sender"); } sub check_dns { my ($self, $host, $transaction) = @_; # we can't even parse a hostname out of the address - if ( ! $host ) { + if (!$host) { $transaction->notes('resolvable_fromhost', 'unparsable host'); - $self->adjust_karma( -1 ); + $self->adjust_karma(-1); return; - }; + } $transaction->notes('resolvable_fromhost_host', $host); - if ( $host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/ ) { + if ($host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/) { $self->log(LOGINFO, "skip, $host is an IP"); $transaction->notes('resolvable_fromhost', 'ip'); - $self->adjust_karma( -1 ); + $self->adjust_karma(-1); 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, has MX! - return if $has_mx == -1; # has invalid MX records - # at this point, no MX for fh is resolvable + my $has_mx = $self->get_and_validate_mx($res, $host, $transaction); + return 1 if $has_mx == 1; # success, has MX! + return if $has_mx == -1; # has invalid MX records + # at this point, no MX for fh is resolvable - my @host_answers = $self->get_host_records( $res, $host, $transaction ); + my @host_answers = $self->get_host_records($res, $host, $transaction); foreach my $rr (@host_answers) { - if ( $rr->type eq 'A' || $rr->type eq 'AAAA' ) { + if ($rr->type eq 'A' || $rr->type eq 'AAAA') { $self->log(LOGINFO, "pass, found A for $host"); $transaction->notes('resolvable_fromhost', 'a'); return $self->ip_is_valid($rr->address); - }; - if ( $rr->type eq 'MX' ) { + } + if ($rr->type eq 'MX') { $self->log(LOGINFO, "pass, found MX for $host"); $transaction->notes('resolvable_fromhost', 'mx'); return $self->mx_address_resolves($rr->exchange, $host); - }; + } } return; } @@ -193,33 +197,34 @@ sub ip_is_valid { } sub get_and_validate_mx { - my ($self, $res, $host, $transaction ) = @_; + my ($self, $res, $host, $transaction) = @_; my @mx = mx($res, $host); - if ( ! scalar @mx ) { # no mx records - $self->adjust_karma( -1 ); + if (!scalar @mx) { # no mx records + $self->adjust_karma(-1); $self->log(LOGINFO, "$host has no MX"); 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) ) { + if ($self->mx_address_resolves($mx->exchange, $host)) { $self->log(LOGINFO, "pass, $host has 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"); - $self->adjust_karma( -1 ); + $self->adjust_karma(-1); return -1; -}; +} sub get_host_records { - my ($self, $res, $host, $transaction ) = @_; + my ($self, $res, $host, $transaction) = @_; my @answers; my $query = $res->search($host); @@ -239,15 +244,15 @@ sub get_host_records { } } - if ( ! scalar @answers) { - if ( $res->errorstring ne 'NXDOMAIN' ) { + if (!scalar @answers) { + if ($res->errorstring ne 'NXDOMAIN') { $self->log(LOGWARN, "fail, query for $host, ", $res->errorstring); - }; + } return; - }; + } return @answers; -}; +} sub mx_address_resolves { my ($self, $name, $fromhost) = @_; @@ -271,15 +276,16 @@ sub mx_address_resolves { } } } - if (! @mx_answers) { - if ( $res->errorstring eq 'NXDOMAIN' ) { - $self->log(LOGWARN, "fail, query for $fromhost, ", $res->errorstring); - }; + if (!@mx_answers) { + if ($res->errorstring eq 'NXDOMAIN') { + $self->log(LOGWARN, "fail, query for $fromhost, ", + $res->errorstring); + } return; } foreach my $rr (@mx_answers) { - next if ( $rr->type ne 'A' && $rr->type ne 'AAAA' ); + next if ($rr->type ne 'A' && $rr->type ne 'AAAA'); return $self->ip_is_valid($rr->address); } @@ -290,11 +296,11 @@ 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 + $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; } } -}; +} diff --git a/plugins/rhsbl b/plugins/rhsbl index eea19f5..4682c83 100644 --- a/plugins/rhsbl +++ b/plugins/rhsbl @@ -31,29 +31,29 @@ use warnings; use Qpsmtpd::Constants; sub register { - my ($self, $qp ) = (shift, shift); + my ($self, $qp) = (shift, shift); - if ( @_ == 1 ) { - $self->legacy_positional_args( @_ ); + if (@_ == 1) { + $self->legacy_positional_args(@_); } else { - $self->{_args} = { @_ }; - }; + $self->{_args} = {@_}; + } - $self->{_args}{reject} = 1 if ! defined $self->{_args}{reject}; + $self->{_args}{reject} = 1 if !defined $self->{_args}{reject}; $self->{_args}{reject_type} ||= 'perm'; } sub legacy_positional_args { my ($self, $denial) = @_; - if ( defined $denial && $denial =~ /^disconnect$/i ) { + if (defined $denial && $denial =~ /^disconnect$/i) { $self->{_args}{reject_type} = 'disconnect'; } else { $self->{_args}{reject_type} = 'perm'; } -}; +} sub hook_mail { my ($self, $transaction, $sender, %param) = @_; @@ -63,7 +63,7 @@ sub hook_mail { if ($sender->format eq '<>') { $self->log(LOGINFO, 'pass, null sender'); return DECLINED; - }; + } my %rhsbl_zones = $self->populate_zones() or return DECLINED; @@ -73,47 +73,53 @@ sub hook_mail { for my $host (@hosts) { for my $rhsbl (keys %rhsbl_zones) { my $query; -# fix to find TXT records, if the rhsbl_zones line doesn't have second field + + # 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"); $query = $res->query("$host.$rhsbl"); - } else { + } + else { $self->log(LOGDEBUG, "Checking $host.$rhsbl for TXT record"); $query = $res->query("$host.$rhsbl", 'TXT'); } - if ( ! $query) { - if ( $res->errorstring ne 'NXDOMAIN' ) { + if (!$query) { + if ($res->errorstring ne 'NXDOMAIN') { $self->log(LOGCRIT, "query failed: ", $res->errorstring); - }; + } next; - }; + } my $result; foreach my $rr ($query->answer) { - $self->log(LOGDEBUG, 'got an ' . $rr->type . ' record ' . $rr->name); + $self->log(LOGDEBUG, + 'got an ' . $rr->type . ' record ' . $rr->name); if ($rr->type eq 'A') { - $self->log(LOGDEBUG, "A record found for $result with IP " . $rr->address); + $self->log(LOGDEBUG, + "A record found for $result with IP " . $rr->address); $result = $rr->name; } elsif ($rr->type eq 'TXT') { $result = $rr->txtdata; $self->log(LOGDEBUG, "TXT record found: " . $rr->txtdata); - }; + } - next if ! $result; + next if !$result; $self->log(LOGINFO, "fail, $result"); - if ( $transaction->sender ) { + if ($transaction->sender) { my $host = $transaction->sender->host; - if ($result =~ /^$host\./ ) { - return $self->get_reject( "Mail from $host rejected because it $result" ); - }; - }; + if ($result =~ /^$host\./) { + return $self->get_reject( + "Mail from $host rejected because it $result"); + } + } my $hello = $self->qp->connection->hello_host; - return $self->get_reject( "Mail from HELO $hello rejected because it $result" ); + return $self->get_reject( + "Mail from HELO $hello rejected because it $result"); } } } @@ -125,15 +131,14 @@ sub hook_mail { sub populate_zones { my $self = shift; - my %rhsbl_zones - = map { (split /\s+/, $_, 2)[0,1] } - $self->qp->config('rhsbl_zones'); + my %rhsbl_zones = + map { (split /\s+/, $_, 2)[0, 1] } $self->qp->config('rhsbl_zones'); - if ( ! keys %rhsbl_zones ) { + if (!keys %rhsbl_zones) { $self->log(LOGINFO, 'pass, no zones'); return; - }; + } return %rhsbl_zones; -}; +} diff --git a/plugins/sender_permitted_from b/plugins/sender_permitted_from index 1978f91..e9a1f9e 100644 --- a/plugins/sender_permitted_from +++ b/plugins/sender_permitted_from @@ -68,19 +68,19 @@ use Qpsmtpd::Constants; sub register { my ($self, $qp, %args) = @_; eval 'use Mail::SPF'; - if ( $@ ) { + if ($@) { warn "skip: plugin disabled, is Mail::SPF installed?\n"; $self->log(LOGERROR, "skip: plugin disabled, is Mail::SPF installed?"); return; - }; - $self->{_args} = { %args }; - if ( $self->{_args}{spf_deny} ) { + } + $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') ) { + } + if (!$self->{_args}{reject} && $self->qp->config('spfbehavior')) { $self->{_args}{reject} = $self->qp->config('spfbehavior'); - }; + } $self->register_hook('mail', 'mail_handler'); $self->register_hook('data_post', 'data_post_handler'); } @@ -91,28 +91,29 @@ sub mail_handler { return (DECLINED) if $self->is_immune(); my $format = $sender->format; - if ( $format eq '<>' || ! $sender->host || ! $sender->user ) { - $self->log( LOGINFO, "skip, null sender" ); + if ($format eq '<>' || !$sender->host || !$sender->user) { + $self->log(LOGINFO, "skip, null sender"); return (DECLINED, "SPF - null sender"); - }; + } - if ( $self->qp->connection->relay_client ) { - $self->log( LOGINFO, "skip, relay_client" ); + if ($self->qp->connection->relay_client) { + $self->log(LOGINFO, "skip, relay_client"); return (DECLINED, "SPF - relaying permitted"); - }; + } - if ( ! $self->{_args}{reject} ) { - $self->log( LOGINFO, "skip, reject disabled" ); + if (!$self->{_args}{reject}) { + $self->log(LOGINFO, "skip, reject disabled"); return (DECLINED); - }; + } - 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, + 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$/) { @@ -127,7 +128,7 @@ sub mail_handler { my $spf_server = Mail::SPF::Server->new(); my $request = Mail::SPF::Request->new(%req_params); my $result = $spf_server->process($request) or do { - $self->log( LOGINFO, "fail, no result" ); + $self->log(LOGINFO, "fail, no result"); return DECLINED; }; @@ -137,49 +138,49 @@ sub mail_handler { my $why = $result->local_explanation; my $reject = $self->{_args}{reject}; - if ( ! $code ) { - $self->log( LOGINFO, "fail, no response" ); + if (!$code) { + $self->log(LOGINFO, "fail, no response"); return (DENYSOFT, "SPF - no response") if $reject >= 2; return (DECLINED, "SPF - no response"); - }; + } - if ( ! $reject ) { - $self->log( LOGINFO, "fail, no reject policy ($code: $why)" ); - return (DECLINED, "SPF - $code: $why") - }; + if (!$reject) { + $self->log(LOGINFO, "fail, no reject policy ($code: $why)"); + return (DECLINED, "SPF - $code: $why"); + } -# SPF result codes: pass fail softfail neutral none error permerror temperror + # SPF result codes: pass fail softfail neutral none error permerror temperror return $self->handle_code_none($reject, $why) if $code eq 'none'; - if ( $code eq 'fail' ) { - $self->adjust_karma( -1 ); + if ($code eq 'fail') { + $self->adjust_karma(-1); return $self->handle_code_fail($reject, $why); } - elsif ( $code eq 'softfail' ) { - $self->adjust_karma( -1 ); + elsif ($code eq 'softfail') { + $self->adjust_karma(-1); return $self->handle_code_softfail($reject, $why); } - elsif ( $code eq 'pass' ) { - $self->adjust_karma( 1 ); + elsif ($code eq 'pass') { + $self->adjust_karma(1); $transaction->notes('spf_pass_host', lc $sender->host); - $self->log(LOGINFO, "pass, $code: $why" ); + $self->log(LOGINFO, "pass, $code: $why"); return (DECLINED); } - elsif ( $code eq 'neutral' ) { - $self->log(LOGINFO, "fail, $code, $why" ); + elsif ($code eq 'neutral') { + $self->log(LOGINFO, "fail, $code, $why"); return (DENY, "SPF - $code: $why") if $reject >= 5; } - elsif ( $code eq 'error' ) { - $self->log(LOGINFO, "fail, $code, $why" ); - return (DENY, "SPF - $code: $why") if $reject >= 6; + elsif ($code eq 'error') { + $self->log(LOGINFO, "fail, $code, $why"); + return (DENY, "SPF - $code: $why") if $reject >= 6; return (DENYSOFT, "SPF - $code: $why") if $reject > 3; } - elsif ( $code eq 'permerror' ) { - $self->log(LOGINFO, "fail, $code, $why" ); - return (DENY, "SPF - $code: $why") if $reject >= 6; + elsif ($code eq 'permerror') { + $self->log(LOGINFO, "fail, $code, $why"); + return (DENY, "SPF - $code: $why") if $reject >= 6; return (DENYSOFT, "SPF - $code: $why") if $reject > 3; } - elsif ( $code eq 'temperror' ) { - $self->log(LOGINFO, "fail, $code, $why" ); + elsif ($code eq 'temperror') { + $self->log(LOGINFO, "fail, $code, $why"); return (DENYSOFT, "SPF - $code: $why") if $reject >= 2; } @@ -188,60 +189,61 @@ sub mail_handler { } sub handle_code_none { - my ($self, $reject, $why ) = @_; + my ($self, $reject, $why) = @_; - if ( $reject >= 6 ) { - $self->log(LOGINFO, "fail, none, $why" ); + if ($reject >= 6) { + $self->log(LOGINFO, "fail, none, $why"); return (DENY, "SPF - none: $why"); - }; + } - $self->log(LOGINFO, "pass, none, $why" ); + $self->log(LOGINFO, "pass, none, $why"); return DECLINED; -}; +} sub handle_code_fail { - my ($self, $reject, $why ) = @_; + my ($self, $reject, $why) = @_; - if ( $reject >= 2 ) { - $self->log(LOGINFO, "fail, $why" ); + if ($reject >= 2) { + $self->log(LOGINFO, "fail, $why"); return (DENY, "SPF - forgery: $why") if $reject >= 3; - return (DENYSOFT, "SPF - fail: $why") - }; + return (DENYSOFT, "SPF - fail: $why"); + } - $self->log(LOGINFO, "pass, fail tolerated, $why" ); + $self->log(LOGINFO, "pass, fail tolerated, $why"); return DECLINED; -}; +} sub handle_code_softfail { - my ($self, $reject, $why ) = @_; + my ($self, $reject, $why) = @_; - if ( $reject >= 3 ) { - $self->log(LOGINFO, "fail, soft, $why" ); - return (DENY, "SPF - fail: $why") if $reject >= 4; + if ($reject >= 3) { + $self->log(LOGINFO, "fail, soft, $why"); + return (DENY, "SPF - fail: $why") if $reject >= 4; return (DENYSOFT, "SPF - fail: $why") if $reject >= 3; - }; + } - $self->log(LOGINFO, "pass, softfail tolerated, $why" ); + $self->log(LOGINFO, "pass, softfail tolerated, $why"); return DECLINED; -}; +} sub data_post_handler { my ($self, $transaction) = @_; my $result = $transaction->notes('spfquery') or return DECLINED; -# if we skipped processing in mail_handler, we should skip here too + # if we skipped processing in mail_handler, we should skip here too return (DECLINED) if $self->is_immune(); $self->log(LOGDEBUG, "result was $result->code"); - if ( ! $transaction->header ) { + if (!$transaction->header) { $self->log(LOGERROR, "missing headers!"); return DECLINED; - }; + } $transaction->header->add('Received-SPF', $result->received_spf_header, 0); -# consider also adding SPF status to Authentication-Results header + + # consider also adding SPF status to Authentication-Results header return DECLINED; } @@ -249,20 +251,20 @@ sub data_post_handler { sub is_special_recipient { my ($self, $rcpt) = @_; - if ( ! $rcpt ) { + if (!$rcpt) { $self->log(LOGINFO, "skip: missing recipient"); return 1; - }; - if ( ! $rcpt->user ) { + } + 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.")"); + 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 index 6d0a559..7d7f734 100644 --- a/plugins/spamassassin +++ b/plugins/spamassassin @@ -153,17 +153,20 @@ use IO::Handle; sub register { my ($self, $qp, %args) = @_; - $self->log(LOGERROR, "Bad parameters for the spamassassin plugin") if @_ % 2; + $self->log(LOGERROR, "Bad parameters for the spamassassin plugin") + if @_ % 2; - $self->{_args} = { %args }; + $self->{_args} = {%args}; # backwards compatibility with previous config syntax - if ( ! defined $self->{_args}{reject} && defined $self->{_args}{reject_threshold} ) { + if ( !defined $self->{_args}{reject} + && defined $self->{_args}{reject_threshold}) + { $self->{_args}{reject} = $self->{_args}{reject_threshold}; - }; - if ( ! defined $self->{_args}{reject_type} ) { + } + if (!defined $self->{_args}{reject_type}) { $self->{_args}{reject_type} = 'perm'; - }; + } $self->register_hook('data_post', 'data_post_handler'); } @@ -173,24 +176,25 @@ sub data_post_handler { return (DECLINED) if $self->is_immune(); - if ( $transaction->data_size > 500_000 ) { - $self->log(LOGINFO, "skip: too large (".$transaction->data_size.")"); + 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 $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->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 ); - $self->munge_subject( $transaction ); - return $self->reject( $transaction ); -}; + $self->insert_spam_headers($transaction, $headers, $username); + $self->munge_subject($transaction); + return $self->reject($transaction); +} sub select_spamd_username { my ($self, $transaction) = @_; @@ -198,40 +202,41 @@ sub select_spamd_username { my $username = $self->{_args}{spamd_user} || getpwuid($>); my $recipient_count = scalar $transaction->recipients; - if ( $recipient_count > 1 ) { + 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 + 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 ($self, $SPAMD) = @_; - my $line0 = <$SPAMD>; # get the first protocol line - if ( $line0 !~ /EX_OK/ ) { - $self->log(LOGERROR, "invalid response from spamd: $line0"); - return; - }; + 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-.*?): (.*)?/ ) { + if (m/^(X-Spam-.*?): (.*)?/) { $new_headers{$1} = $2 || ''; $last_header = $1; next; } - if ( $last_header && m/^(\s+.*)/ ) { # a folded line, append to last + if ($last_header && m/^(\s+.*)/) { # a folded line, append to last $new_headers{$last_header} .= CRLF . "\t" . $1; next; } @@ -241,37 +246,41 @@ sub parse_spamd_response { $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 ($self, $transaction, $new_headers, $username) = @_; - if ( $self->{_args}{headers} && $self->{_args}{headers} eq 'none' ) { - my $r = $self->parse_spam_header( $new_headers->{'X-Spam-Status'} ); + if ($self->{_args}{headers} && $self->{_args}{headers} eq 'none') { + my $r = $self->parse_spam_header($new_headers->{'X-Spam-Status'}); $transaction->notes('spamassassin', $r); return; - }; + } 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); - }; + $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 + 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 { @@ -279,39 +288,40 @@ sub assemble_message { $transaction->body_resetpos; - my $message = "X-Envelope-From: " - . $transaction->sender->format . "\n" - . $transaction->header->as_string . "\n\n"; + my $message = + "X-Envelope-From: " + . $transaction->sender->format . "\n" + . $transaction->header->as_string . "\n\n"; - while (my $line = $transaction->body_getline) { $message .= $line; }; + while (my $line = $transaction->body_getline) { $message .= $line; } - $message = join(CRLF, split/\n/, $message); + $message = join(CRLF, split /\n/, $message); return $message . CRLF; -}; +} sub connect_to_spamd { - my $self = shift; + my $self = shift; my $socket = $self->{_args}{spamd_socket}; my $SPAMD; - if ( $socket && $socket =~ /\// ) { # file path - $SPAMD = $self->connect_to_spamd_socket( $socket ); + if ($socket && $socket =~ /\//) { # file path + $SPAMD = $self->connect_to_spamd_socket($socket); } else { - $SPAMD = $self->connect_to_spamd_tcpip( $socket ); - }; + $SPAMD = $self->connect_to_spamd_tcpip($socket); + } - return if ! $SPAMD; + return if !$SPAMD; $SPAMD->autoflush(1); return $SPAMD; -}; +} sub connect_to_spamd_socket { - my ( $self, $socket ) = @_; + my ($self, $socket) = @_; - if ( ! $socket || $socket !~ /^([\w\/.-]+)$/ ) { # Unix Domain Socket + if (!$socket || $socket !~ /^([\w\/.-]+)$/) { # Unix Domain Socket $self->log(LOGERROR, "not a valid path"); return; - }; + } # Sanitize for use with taint mode $socket =~ /^([\w\/.-]+)$/; @@ -321,7 +331,7 @@ sub connect_to_spamd_socket { $self->log(LOGERROR, "Could not open socket: $!"); return; }; - my $paddr = sockaddr_un( $socket ); + my $paddr = sockaddr_un($socket); connect($SPAMD, $paddr) or do { $self->log(LOGERROR, "Could not connect to spamd socket: $!"); @@ -330,23 +340,23 @@ sub connect_to_spamd_socket { $self->log(LOGDEBUG, "connected to spamd"); return $SPAMD; -}; +} sub connect_to_spamd_tcpip { - my ( $self, $socket ) = @_; + my ($self, $socket) = @_; - my $remote = 'localhost'; - my $port = 783; + my $remote = 'localhost'; + my $port = 783; if (defined $socket && $socket =~ /^([\w.-]+):(\d+)$/) { - $remote = $1; - $port = $2; + $remote = $1; + $port = $2; } - if ($port =~ /\D/) { $port = getservbyname($port, 'tcp') }; - if ( ! $port ) { + 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; @@ -361,24 +371,25 @@ sub connect_to_spamd_tcpip { connect($SPAMD, $paddr) or do { $self->log(LOGERROR, "Could not connect to spamd: $!"); - return; + return; }; $self->log(LOGDEBUG, "connected to spamd"); return $SPAMD; -}; +} sub print_to_spamd { - my ( $self, $SPAMD, $message, $length, $username ) = @_; + 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: $!"); + print $SPAMD $message + or $self->log(LOGWARN, "Could not print to spamd: $!"); $self->log(LOGDEBUG, "check_spam: finished sending to spamd"); -}; +} sub reject { my ($self, $transaction) = @_; @@ -387,32 +398,32 @@ sub reject { $self->log(LOGNOTICE, "error, no results"); return DECLINED; }; - my $score = $sa_results->{score}; - if ( ! defined $score ) { + my $score = $sa_results->{score}; + if (!defined $score) { $self->log(LOGERROR, "error, error getting score"); return DECLINED; - }; + } my $ham_or_spam = $sa_results->{is_spam} eq 'Yes' ? 'Spam' : 'Ham'; - if ( $ham_or_spam eq 'Spam' ) { - $self->adjust_karma( -1 ); - }; + if ($ham_or_spam eq 'Spam') { + $self->adjust_karma(-1); + } my $status = "$ham_or_spam, $score"; - my $learn = ''; - my $al = $sa_results->{autolearn}; # subject to local SA learn scores - if ( $al ) { - $self->adjust_karma( 1 ) if $al eq 'ham'; - $self->adjust_karma( -1 ) if $al eq 'spam'; - $learn = "learn=". $al; - }; + my $learn = ''; + my $al = $sa_results->{autolearn}; # subject to local SA learn scores + if ($al) { + $self->adjust_karma(1) if $al eq 'ham'; + $self->adjust_karma(-1) if $al eq 'spam'; + $learn = "learn=" . $al; + } my $reject = $self->{_args}{reject} or do { $self->log(LOGERROR, "error, reject disabled ($status, $learn)"); return DECLINED; }; - if ( $score < $reject ) { - if ( $ham_or_spam eq 'Spam' ) { + if ($score < $reject) { + if ($ham_or_spam eq 'Spam') { $self->log(LOGINFO, "fail, $status < $reject, $learn"); return DECLINED; } @@ -440,20 +451,20 @@ sub munge_subject { }; return unless $sa->{score} > $required; - my $subject_prefix = $self->qp->config('subject_prefix') || '*** SPAM ***'; - my $subject = $transaction->header->get('Subject') || ''; + my $subject_prefix = $self->qp->config('subject_prefix') || '*** SPAM ***'; + my $subject = $transaction->header->get('Subject') || ''; $transaction->header->replace('Subject', "$subject_prefix $subject"); } sub get_spam_results { my ($self, $transaction) = @_; - if ( defined $transaction->notes('spamassassin') ) { + 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 ); + my $r = $self->parse_spam_header($header); $self->log(LOGDEBUG, "$r->{is_spam}, $r->{score}"); $transaction->notes('spamassassin', $r); @@ -464,44 +475,48 @@ sub get_spam_results { 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. + # 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 , + chop $is_spam; # remove trailing , my %r; - foreach ( @parts ) { - my ($key,$val) = split(/=/, $_); + foreach (@parts) { + my ($key, $val) = split(/=/, $_); $r{$key} = $val; } $r{is_spam} = $is_spam; # compatibility for SA versions < 3 - if ( defined $r{hits} && ! defined $r{score} ) { + 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} ) { + 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"; + $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, 0) if $action eq 'rename'; + for my $header ($transaction->header->get($header_name)) { + $transaction->header->add($old_header_name, $header, 0) + if $action eq 'rename'; $transaction->header->delete($header_name); } } diff --git a/plugins/tls b/plugins/tls index 75c6751..533c5df 100644 --- a/plugins/tls +++ b/plugins/tls @@ -67,8 +67,9 @@ sub init { $cert ||= "$dir/qpsmtpd-server.crt"; $key ||= "$dir/qpsmtpd-server.key"; $ca ||= "$dir/qpsmtpd-ca.crt"; - unless ( -f $cert && -f $key && -f $ca ) { - $self->log(LOGERROR, "Cannot locate cert/key! Run plugins/tls_cert to generate"); + 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); @@ -76,31 +77,34 @@ sub init { $self->tls_ca($ca); $self->tls_ciphers($self->qp->config('tls_ciphers') || 'HIGH'); - $self->log(LOGDEBUG, "ciphers: ".$self->tls_ciphers); + $self->log(LOGDEBUG, "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: $!"; - 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} ) { + HOOK: foreach my $hook (keys %{$qp->hooks}) { no strict 'refs'; - if ( $hook =~ m/^auth-?(.+)?$/ ) { - if ( defined $1 ) { + 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 + else { # at least one polymorphous auth provider *hook_auth = \&bad_ssl_hook; } } @@ -111,10 +115,11 @@ 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'); + return DENY, "Command refused due to lack of security" + if $transaction->notes('ssl_failed'); my $cap = $transaction->notes('capabilities') || []; push @$cap, 'STARTTLS'; - $transaction->notes('tls_enabled', 1); + $transaction->notes('tls_enabled', 1); $transaction->notes('capabilities', $cap); return DECLINED; } @@ -126,9 +131,10 @@ sub hook_unrecognized_command { return DENY, "Syntax error (no parameters allowed)" if @args; # OK, now we setup TLS - $self->qp->respond (220, "Go ahead with TLS"); + $self->qp->respond(220, "Go ahead with TLS"); + + unless (_convert_to_ssl($self)) { - 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); @@ -143,9 +149,9 @@ sub hook_connect { my ($self, $transaction) = @_; my $local_port = $self->qp->connection->local_port; - return DECLINED unless defined $local_port && $local_port == 465; # SMTPS + return DECLINED unless defined $local_port && $local_port == 465; # SMTPS - unless ( _convert_to_ssl($self) ) { + unless (_convert_to_ssl($self)) { return (DENY_DISCONNECT, "Cannot establish SSL session"); } $self->log(LOGWARN, "Connected via SMTPS"); @@ -156,9 +162,10 @@ 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')) { + if (defined $tls_socket && $self->connection->notes('tls_socket_is_duped')) + { $tls_socket->close; - $self->connection->notes('tls_socket', undef); + $self->connection->notes('tls_socket', undef); $self->connection->notes('tls_socked_is_duped', 0); } @@ -173,34 +180,36 @@ sub _convert_to_ssl { } 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: $!"; + 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); + $self->connection->notes('tls_enabled', 1); }; if ($@) { return 0; - }; + } return 1; } sub _convert_to_ssl_async { my ($self) = @_; - my $upgrader = $self->connection - ->notes( 'tls_upgrader', UpgradeClientSSL->new($self) ); + my $upgrader = + $self->connection->notes('tls_upgrader', UpgradeClientSSL->new($self)); $upgrader->upgrade_socket(); return 1; } @@ -243,7 +252,8 @@ sub ssl_context { # 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 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; @@ -254,7 +264,7 @@ package UpgradeClientSSL; use strict; use warnings; -no warnings qw(deprecated); +no warnings qw(deprecated); use IO::Socket::SSL 0.98; use Errno qw( EAGAIN ); @@ -265,27 +275,29 @@ sub new { my UpgradeClientSSL $self = shift; $self = fields::new($self) unless ref $self; $self->{_stashed_plugin} = shift; - $self->{_stashed_qp} = $self->{_stashed_plugin}->qp; + $self->{_stashed_qp} = $self->{_stashed_plugin}->qp; return $self; } sub upgrade_socket { my UpgradeClientSSL $self = shift; - unless ( $self->{_ssl_started} ) { + 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->{_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; } @@ -296,14 +308,14 @@ sub event_read { my UpgradeClientSSL $self = shift; my $qp = shift; - $qp->watch_read( 0 ); + $qp->watch_read(0); my $sock = $qp->{sock}->accept_SSL; if (defined $sock) { - $qp->connection( $qp->connection->clone ); + $qp->connection($qp->connection->clone); $qp->reset_transaction; - $self->connection->notes('tls_socket', $sock); + $self->connection->notes('tls_socket', $sock); $self->connection->notes('tls_enabled', 1); $qp->watch_read(1); return 1; @@ -314,12 +326,15 @@ sub event_read { $qp->set_reader_object($self); if ($SSL_ERROR == SSL_WANT_READ) { $qp->watch_read(1); - } elsif ($SSL_ERROR == SSL_WANT_WRITE) { + } + elsif ($SSL_ERROR == SSL_WANT_WRITE) { $qp->watch_write(1); - } else { + } + else { $qp->disconnect(); } - } else { + } + else { $qp->disconnect(); } } diff --git a/plugins/uribl b/plugins/uribl index 25ee88d..4834101 100644 --- a/plugins/uribl +++ b/plugins/uribl @@ -101,46 +101,47 @@ use IO::Select; # 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, -); + '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->{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'}; @@ -152,7 +153,7 @@ sub init { for (@zones) { chomp; next if !$_ or /^\s*#/; - my @z = split (/\s+/, $_); + my @z = split(/\s+/, $_); next unless $z[0]; my $mask = 0; @@ -171,16 +172,14 @@ sub init { } $self->{uribl_zones}->{$z[0]} = { - mask => $mask, - action => $action, - }; + 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->{whitelist_zones} = {(map { ($_ => 1) } @whitelist)}; $self->init_resolver; } @@ -194,17 +193,17 @@ sub register { # async version: not used sub send_query { - my $self = shift; - my $name = shift || return undef; + 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, - }; + zone => $z, + name => $name, + }; next unless $z; next if exists $self->{sockets}->{$z}->{$name}; @@ -214,10 +213,12 @@ sub send_query { $self->{socket_select}->add($s); $self->{socket_idx}->{"$s"} = $index; $count++; - } else { + } + else { $self->log(LOGERROR, - "Couldn't open socket for A record '$name.$z': ". - ($self->{resolver}->errorstring || 'unknown error')); + "Couldn't open socket for A record '$name.$z': " + . ($self->{resolver}->errorstring || 'unknown error') + ); } $s1 = $self->{resolver}->bgsend("$name.$z", 'TXT'); @@ -226,10 +227,12 @@ sub send_query { $self->{socket_select}->add($s1); $self->{socket_idx}->{"$s1"} = $index; $count++; - } else { + } + else { $self->log(LOGERROR, - "Couldn't open socket for TXT record '$name.$z': ". - ($self->{resolver}->errorstring || 'unknown error')); + "Couldn't open socket for TXT record '$name.$z': " + . ($self->{resolver}->errorstring || 'unknown error') + ); } $self->{sockets}->{$z}->{$name} = {}; @@ -241,7 +244,7 @@ sub send_query { sub lookup_finish { my $self = shift; $self->{socket_idx} = {}; - $self->{sockets} = {}; + $self->{sockets} = {}; undef $self->{socket_select}; } @@ -249,14 +252,13 @@ sub lookup_finish { sub evaluate { my $self = shift; my $zone = shift || return undef; - my $a = 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); + my $v = + (($1 & 0xff) << 24) | (($2 & 0xff) << 16) | (($3 & 0xff) << 8) | + ($4 & 0xff); return ($v & $mask); } @@ -270,8 +272,9 @@ sub lookup_start { 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 + + # 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; @@ -281,51 +284,62 @@ sub lookup_start { if ($l =~ /(.*)=$/) { push @qp_continuations, $1; - } elsif (@qp_continuations) { + } + 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{ + while ( + $l =~ m{ \w{3,16}:/+ # protocol (?:\S+@)? # user/pass (\d{7,}) # raw-numeric IP (?::\d*)?([/?\s]|$) # port, slash # or EOL - }gx) { + }gx + ) + { my @octets = ( - (($1 >> 24) & 0xff), - (($1 >> 16) & 0xff), - (($1 >> 8) & 0xff), - ($1 & 0xff) - ); + (($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)"); + $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{ + 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); + }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) { + for (0 .. $#octets) { $octets[$_] =~ s/^0([0-7]+)$/oct($1)/e; $octets[$_] =~ s/^0x([0-9a-fA-F]+)$/hex($1)/e; } @@ -337,7 +351,8 @@ sub lookup_start { $pending{$rev} = 1; } } - while ($l =~ m{ + while ( + $l =~ m{ ((?:www\.)? # www? [a-zA-Z0-9][a-zA-Z0-9\-.]+\. # hostname (?:aero|arpa|asia|biz|cat|com|coop| # tld @@ -345,22 +360,33 @@ sub lookup_start { museum|name|net|org|pro|tel|travel| [a-zA-Z]{2}) )(?!\w) - }gix) { + }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])}) { + 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 { + } + else { while (@host_domains >= $cutoff) { my $subhost = join('.', @host_domains); unless (exists $pending{$subhost}) { - $self->log(LOGINFO, "URIBL: checking sub-host $subhost"); + $self->log(LOGINFO, + "URIBL: checking sub-host $subhost"); $queries += $start_query->($self, $subhost); $pending{$subhost} = 1; } @@ -368,7 +394,8 @@ sub lookup_start { } } } - while ($l =~ m{ + while ( + $l =~ m{ \w{3,16}:/+ # protocol (?:\S+@)? # user/pass ( @@ -378,22 +405,30 @@ sub lookup_start { museum|name|net|org|pro|tel|travel| [a-zA-Z]{2}) ) - }gix) { + }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])}) { + 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 { + } + else { while (@host_domains >= $cutoff) { my $subhost = join('.', @host_domains); unless (exists $pending{$subhost}) { - $self->log(LOGINFO, "URIBL: checking sub-host $subhost"); + $self->log(LOGINFO, + "URIBL: checking sub-host $subhost"); $queries += $start_query->($self, $subhost); $pending{$subhost} = 1; } @@ -411,8 +446,8 @@ sub lookup_start { sub collect_results { my ($self, $transaction) = @_; - my $matches = 0; - my $complete = 0; + my $matches = 0; + my $complete = 0; my $start_time = time; while ($self->{socket_select}->handles) { my $timeout = ($start_time + $self->{timeout}) - time; @@ -420,16 +455,18 @@ sub collect_results { my @ready = $self->{socket_select}->can_read($timeout); - SOCK: for my $s (@ready) { + 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}; + $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; + or next SOCK; for my $a ($packet->answer) { if ($a->type eq 'TXT') { @@ -438,8 +475,7 @@ sub collect_results { elsif ($a->type eq 'A') { $h->{a} = $a->address; if ($self->evaluate($zone, $h->{a})) { - $self->log(LOGDEBUG, - "match in $zone"); + $self->log(LOGDEBUG, "match in $zone"); $h->{match} = 1; $matches++; } @@ -451,21 +487,23 @@ sub collect_results { } 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')); + 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}), - }; + push @matches, + { + action => $self->{uribl_zones}->{$z}->{action}, + desc => "$n in $z: " . ($h->{txt} || $h->{a}), + }; } } @@ -480,10 +518,13 @@ sub data_handler { return (DECLINED) if $self->is_immune(); - my $queries = $self->lookup_start($transaction, sub { - my ($self, $name) = @_; - return $self->send_query($name); - }); + my $queries = $self->lookup_start( + $transaction, + sub { + my ($self, $name) = @_; + return $self->send_query($name); + } + ); unless ($queries) { $self->log(LOGINFO, "pass, No URIs found in mail"); @@ -495,9 +536,11 @@ sub data_handler { $self->log(LOGWARN, $_->{desc}); if ($_->{action} eq 'add-header') { $transaction->header->add('X-URIBL-Match', $_->{desc}, 0); - } elsif ($_->{action} eq 'deny') { + } + elsif ($_->{action} eq 'deny') { return (DENY, $_->{desc}); - } elsif ($_->{action} eq 'denysoft') { + } + elsif ($_->{action} eq 'denysoft') { return (DENYSOFT, $_->{desc}); } } diff --git a/plugins/virus/aveclient b/plugins/virus/aveclient index f321f76..8f5c38c 100644 --- a/plugins/virus/aveclient +++ b/plugins/virus/aveclient @@ -1,4 +1,5 @@ #!perl -w + =head1 NAME aveclient @@ -92,89 +93,112 @@ SOFTWARE. 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}; - } + my ($self, $qp, @args) = @_; - # 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; - } + # 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); -} +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 index 17609a2..ea01e6c 100644 --- a/plugins/virus/bitdefender +++ b/plugins/virus/bitdefender @@ -67,10 +67,10 @@ use File::Path; use Qpsmtpd::Constants; sub register { - my ( $self, $qp, @args ) = @_; + my ($self, $qp, @args) = @_; while (@args) { - $self->{"_bitd"}->{ pop @args } = pop @args; + $self->{"_bitd"}->{pop @args} = pop @args; } $self->{"_bitd"}->{"bitdefender_location"} ||= "/opt/bdc/bdc"; $self->{"_bitd"}->{"deny_viruses"} ||= "yes"; @@ -79,31 +79,31 @@ sub register { } sub hook_data_post { - my ( $self, $transaction ) = @_; + 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"} - . ")" ); + 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 ) + unless ( $content_type + && $content_type =~ m!\bmultipart/.*\bboundary="?([^"]+)!i) { - $self->log( LOGERROR, "non-multipart mail - skipping" ); + $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; + $self->log(LOGERROR, "didn't get a filename"); + return DECLINED; } # Now do the actual scanning! @@ -121,9 +121,9 @@ sub hook_data_post { close $bdc; if ($output) { - $self->log( LOGINFO, "Virus(es) found: $output" ); - if ( $self->{"_bitd"}->{"deny_viruses"} eq "yes" ) { - return ( DENY, "Virus Found: $output" ); + $self->log(LOGINFO, "Virus(es) found: $output"); + if ($self->{"_bitd"}->{"deny_viruses"} eq "yes") { + return (DENY, "Virus Found: $output"); } } diff --git a/plugins/virus/clamav b/plugins/virus/clamav index 73d505c..e7452f1 100644 --- a/plugins/virus/clamav +++ b/plugins/virus/clamav @@ -105,127 +105,133 @@ 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; + 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]*)$/) { + if ($args[0] && $args[0] =~ /^(\/[\/\-\_\.a-z0-9A-Z]*)$/ && -x $1) { $self->{_clamscan_loc} = $1; + shift @args; } - 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 + 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; + } + } - unless ($self->{_spool_dir}) { + $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}) { + } + 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) = @_; + 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); - } + 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) { + 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); -} + 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 index 4148bd8..00feaae 100644 --- a/plugins/virus/clamdscan +++ b/plugins/virus/clamdscan @@ -109,17 +109,17 @@ use warnings; use Qpsmtpd::Constants; sub register { - my ( $self, $qp ) = shift, shift; + my ($self, $qp) = shift, shift; $self->log(LOGERROR, "Bad parameters for the clamdscan plugin") if @_ % 2; - $self->{'_args'} = { @_ }; + $self->{'_args'} = {@_}; eval 'use ClamAV::Client'; - if ( $@ ) { + 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'; @@ -127,73 +127,75 @@ sub register { $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' ) { + 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 ($self, $transaction) = @_; - my $filename = $self->get_filename( $transaction ) or return DECLINED; + my $filename = $self->get_filename($transaction) or return DECLINED; - if ( $self->connection->notes('naughty') ) { - $self->log( LOGINFO, "skip, naughty" ); + if ($self->connection->notes('naughty')) { + $self->log(LOGINFO, "skip, naughty"); return (DECLINED); - }; - return (DECLINED) if $self->is_too_big( $transaction ); - return (DECLINED) if $self->is_not_multipart( $transaction ); + } + return (DECLINED) if $self->is_too_big($transaction); + return (DECLINED) if $self->is_not_multipart($transaction); - $self->set_permission( $filename ) or return DECLINED; + $self->set_permission($filename) or return DECLINED; my $clamd = $self->get_clamd() - or return $self->err_and_return( "Cannot instantiate ClamAV::Client" ); + or return $self->err_and_return("Cannot instantiate ClamAV::Client"); - unless ( eval { $clamd->ping() } ) { - return $self->err_and_return( "Cannot ping clamd server: $@" ); + 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 ) }; + my ($path, $found) = eval { $clamd->scan_path($filename) }; if ($@) { - return $self->err_and_return( "Error scanning mail: $@" ); - }; + return $self->err_and_return("Error scanning mail: $@"); + } - if ( $found ) { - $self->log( LOGNOTICE, "fail, found virus $found" ); + if ($found) { + $self->log(LOGNOTICE, "fail, found virus $found"); - $self->connection->notes('naughty', 1); # see plugins/naughty - $self->adjust_karma( -1 ); + $self->connection->notes('naughty', 1); # see plugins/naughty + $self->adjust_karma(-1); - if ( $self->{_args}{deny_viruses} ) { - return ( DENY, "Virus found: $found" ); + 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 ); + $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); + $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 $self = shift; my $message = shift; - if ( $message ) { - $self->log( LOGERROR, $message ); - }; - return (DENYSOFT, "Unable to scan for viruses") if $self->{_args}{defer_on_error}; + 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; @@ -201,25 +203,25 @@ sub get_filename { my $filename = $transaction->body_filename; - if ( ! $filename ) { - $self->log( LOGWARN, "Cannot process due to lack of 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" ); + 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" ); + 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" ); + $self->log(LOGDEBUG, "Spooled $size bytes to $filename"); } return $filename; -}; +} sub set_permission { my ($self, $filename) = @_; @@ -227,26 +229,28 @@ sub set_permission { # 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" ); + my $dir_mode = (stat($self->spool_dir()))[2]; + $self->log(LOGDEBUG, "spool dir mode: $dir_mode"); + + if ($dir_mode & 0010 || $dir_mode & 0001) { - 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); + my $fmode = + ($dir_mode & 0044) | ($dir_mode & 0010 ? 0040 : 0) | + ($dir_mode & 0001 ? 0004 : 0); - unless ( chmod $fmode, $filename ) { - $self->log( LOGERROR, "chmod: $filename: $!" ); + unless (chmod $fmode, $filename) { + $self->log(LOGERROR, "chmod: $filename: $!"); return; } return 1; } - $self->log( LOGWARN, "spool directory permissions do not permit scanner access" ); + $self->log(LOGWARN, + "spool directory permissions do not permit scanner access"); return 1; -}; +} sub get_clamd { my $self = shift; @@ -254,34 +258,34 @@ sub get_clamd { 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 ); - }; + 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 ); + if ($socket) { + if ($socket =~ /([\w\/.]+)/) { + return new ClamAV::Client(socket_name => $1); } - $self->log( LOGERROR, "invalid characters in socket name" ); + $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)" ); + if ($size > $self->{_args}{max_size} * 1024) { + $self->log(LOGINFO, "skip, too big ($size)"); return 1; } - $self->log( LOGDEBUG, "data_size, $size" ); + $self->log(LOGDEBUG, "data_size, $size"); return; -}; +} sub is_not_multipart { my $self = shift; @@ -289,15 +293,15 @@ sub is_not_multipart { return if $self->{'_args'}{'scan_all'}; - return 1 if ! $transaction->header; + return 1 if !$transaction->header; # 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" ); + 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 index 60e01de..856d4c6 100644 --- a/plugins/virus/hbedv +++ b/plugins/virus/hbedv @@ -49,110 +49,120 @@ 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; + my ($self, $qp, @args) = @_; + + if (@args % 2) { + $self->log(LOGERROR, "FATAL ERROR: odd number of arguments"); + 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"); + 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; } - } } - } - return (DECLINED); -} +} + +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) + ## 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 index 92a1bd5..993f21d 100644 --- a/plugins/virus/kavscanner +++ b/plugins/virus/kavscanner @@ -54,123 +54,139 @@ B option. use File::Temp qw(tempfile); use Mail::Address; - + sub register { - my ($self, $qp, @args) = @_; + 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}; + if (@args % 2) { + $self->log(LOGWARN, "kavscanner: Wrong number of arguments"); + $self->{_kavscanner_bin} = "/opt/AVP/kavscanner"; } - # 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; + 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; + my ($self, $transaction) = @_; - 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"); + 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; } - } - - $self->log(LOGINFO, "kavscanner results: $description"); - - $transaction->header->add('X-Virus-Checked', 'Checked by '.$self->qp->config("me")); - return (DECLINED); -} + 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 index 8a977fc..e45a7aa 100644 --- a/plugins/virus/klez_filter +++ b/plugins/virus/klez_filter @@ -1,34 +1,36 @@ #!perl -w sub hook_data_post { - my ($self, $transaction) = @_; + 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; + # klez files are always sorta big .. how big? Dunno. + return (DECLINED) + if $transaction->data_size < 60_000; - # maybe it would be worthwhile to add a check for - # Content-Type: multipart/alternative; here? + # 220k was too little, so let's just disable the "big size check" + # or $transaction->data_size > 1_000_000; - # make sure we read from the beginning; - $transaction->body_resetpos; - - my $line_number = 0; - my $seen_klez_signature = 0; + # maybe it would be worthwhile to add a check for + # Content-Type: multipart/alternative; here? - while ($_ = $transaction->body_getline) { - last if $line_number++ > 40; + # make sure we read from the beginning; + $transaction->body_resetpos; - m/^Content-type:.*(?:audio|application)/i - and ++$seen_klez_signature and next; + my $line_number = 0; + my $seen_klez_signature = 0; - return (DENY, "Klez Virus Detected") - if $seen_klez_signature - and m!^TVqQAAMAAAAEAAAA//8AALgAAAAAAAAAQA!; + while ($_ = $transaction->body_getline) { + last if $line_number++ > 40; - } + m/^Content-type:.*(?:audio|application)/i + and ++$seen_klez_signature + and next; - return (DECLINED); + 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 index 6fc0f52..e84dd38 100644 --- a/plugins/virus/sophie +++ b/plugins/virus/sophie @@ -2,9 +2,9 @@ use IO::Socket; sub register { - my ( $self, $qp, @args ) = @_; + my ($self, $qp, @args) = @_; - %{ $self->{"_sophie"} } = @args; + %{$self->{"_sophie"}} = @args; # Set some sensible defaults $self->{"_sophie"}->{"sophie_socket"} ||= "/var/run/sophie"; @@ -13,68 +13,66 @@ sub register { } sub hook_data_post { - my ( $self, $transaction ) = @_; + my ($self, $transaction) = @_; $DB::single = 1; - if ( $transaction->data_size > $self->{"_sophie"}->{"max_size"} * 1024 ) { - $self->log( LOGNOTICE, "Declining due to data_size" ); + 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 ) + unless ( $content_type + && $content_type =~ m!\bmultipart/.*\bboundary="?([^"]+)!i) { - $self->log( LOGWARN, "non-multipart mail - skipping" ); + $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" ); + $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" ); + 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"; + || die "Couldn't create socket ($!)\n"; connect(\*SOPHIE, pack_sockaddr_un $self->{"_sophie"}->{"sophie_socket"}) - || die "Couldn't connect() to the socket ($!)\n"; + || die "Couldn't connect() to the socket ($!)\n"; - syswrite(\*SOPHIE, $filename."\n", length($filename)+1); - sysread(\*SOPHIE, $response, 256); - close (\*SOPHIE); + 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 (($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" ); + 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 ); + $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") ); + $transaction->header->add('X-Virus-Checked', + "Checked by SOPHIE on " . $self->qp->config("me")); return (DECLINED); } diff --git a/plugins/virus/uvscan b/plugins/virus/uvscan index 8faa531..eab7bfa 100644 --- a/plugins/virus/uvscan +++ b/plugins/virus/uvscan @@ -44,91 +44,99 @@ Please see the LICENSE file included with qpsmtpd for details. =cut sub register { - my ($self, $qp, @args) = @_; + my ($self, $qp, @args) = @_; - while (@args) { - $self->{"_uvscan"}->{pop @args}=pop @args; - } - $self->{"_uvscan"}->{"uvscan_location"}||="/usr/local/bin/uvscan"; + 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; + my ($self, $transaction) = @_; - # 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; - } + return (DECLINED) + if $transaction->data_size > 250_000; - 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"); + # 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; } - 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")); + my $filename = $transaction->body_filename; + return (DECLINED) unless $filename; - return (DECLINED); -} + # 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/plugins/whitelist b/plugins/whitelist index 76797ce..1ccdbae 100644 --- a/plugins/whitelist +++ b/plugins/whitelist @@ -139,7 +139,7 @@ sub check_host { if (exists $ENV{WHITELISTCLIENT}) { $self->qp->connection->notes('whitelistclient', 1); $self->log(2, "pass, is whitelisted client"); - $self->adjust_karma( 5 ); + $self->adjust_karma(5); return OK; } @@ -148,7 +148,7 @@ sub check_host { if ($h eq $ip or $ip =~ /^\Q$h\E/) { $self->qp->connection->notes('whitelisthost', 1); $self->log(2, "pass, is a whitelisted host"); - $self->adjust_karma( 5 ); + $self->adjust_karma(5); return OK; } } From 58aab2ad206c2b287a53973d430cc2375557c39f Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sun, 21 Apr 2013 00:52:07 -0400 Subject: [PATCH 261/352] find . -name '*.t' -exec perltidy -b {} \; --- t/addresses.t | 37 +++++++++----- t/auth.t | 122 ++++++++++++++++++++++---------------------- t/config.t | 19 +++---- t/helo.t | 2 +- t/misc.t | 6 +-- t/plugin_tests.t | 9 ++-- t/qpsmtpd-address.t | 98 +++++++++++++++++------------------ t/rset.t | 10 ++-- t/tempstuff.t | 14 ++--- xt/01-syntax.t | 33 ++++++------ xt/02-pod.t | 8 +-- 11 files changed, 185 insertions(+), 173 deletions(-) diff --git a/t/addresses.t b/t/addresses.t index 5fbc375..09272ba 100644 --- a/t/addresses.t +++ b/t/addresses.t @@ -7,35 +7,46 @@ 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:'))[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@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'); +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'); +is($smtpd->transaction->sender->format, + '', 'got the right sender'); $command = 'MAIL FROM:<>'; -is(($smtpd->command($command))[0], 250, $command); +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'); +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->command($command))[0], 250, $command); is($smtpd->transaction->sender->format, '<>', 'got the right sender'); - diff --git a/t/auth.t b/t/auth.t index d6e23b4..2d2876e 100644 --- a/t/auth.t +++ b/t/auth.t @@ -19,119 +19,121 @@ 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"); +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 ) ); +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 ($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 -"); +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"); +cmp_ok(OK, '==', $r, "plain auth"); -if ( $ENV{QPSMTPD_DEVELOPER} && is_interactive() ) { -# same thing, but must be entered interactively +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"); -}; - + cmp_ok(OK, '==', $r, "SASL, plain"); +} # LOGIN -if ( $ENV{QPSMTPD_DEVELOPER} && is_interactive() ) { +if ($ENV{QPSMTPD_DEVELOPER} && is_interactive()) { - my $enc_user = Qpsmtpd::Auth::e64( $user ); - my $enc_pass = Qpsmtpd::Auth::e64( $pass ); + my $enc_user = Qpsmtpd::Auth::e64($user); + my $enc_pass = Qpsmtpd::Auth::e64($pass); -# get_base64_response + # get_base64_response print "answer: $enc_user\n"; - $r = Qpsmtpd::Auth::get_base64_response( $smtpd, 'Username' ); - cmp_ok( $r, 'eq', $user, "get_base64_response +"); + $r = Qpsmtpd::Auth::get_base64_response($smtpd, 'Username'); + cmp_ok($r, 'eq', $user, "get_base64_response +"); -# get_auth_details_login + # 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 +"); + ($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"); -}; - + cmp_ok(OK, '==', $r, "SASL, login"); +} # CRAM-MD5 -if ( $ENV{QPSMTPD_DEVELOPER} && is_interactive() ) { +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 ) ); + # 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); + 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"); -# 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"); -}; + #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 + # borrowed from IO::Interactive + my ($out_handle) = (@_, select); # Default to default output handle -# Not interactive if output is not to terminal... + # 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 ) { + # If *ARGV is opened, we're interactive if... + if (openhandle * ARGV) { -# ...it's currently opened to the magic '-' file + # ...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 + # ...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 + # ...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 '-' ); + # 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 ) { diff --git a/t/config.t b/t/config.t index 5e674b8..06f5ce0 100644 --- a/t/config.t +++ b/t/config.t @@ -7,15 +7,15 @@ use_ok('Test::Qpsmtpd'); my @mes; -BEGIN { # need this to happen before anything else +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 ) { + 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"); @@ -25,12 +25,13 @@ 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.,2001:0DB8,2001:0DB8:0000:0000:0000:0000:0000:0001,2001:DB8::1,2001:DB8::1/32', - 'config("relayclients") are trimmed'); +is( + $relayclients, +'127.0.0.1,192.0.,2001:0DB8,2001:0DB8:0000:0000:0000:0000:0000:0001,2001:DB8::1,2001:DB8::1/32', + 'config("relayclients") are trimmed' + ); -foreach my $f ( @mes ) { +foreach my $f (@mes) { unlink $f if -f $f; -}; - +} diff --git a/t/helo.t b/t/helo.t index f45680e..558130f 100644 --- a/t/helo.t +++ b/t/helo.t @@ -1,4 +1,4 @@ -use Test::More tests => 12; +use Test::More tests => 12; use strict; use lib 't'; use_ok('Test::Qpsmtpd'); diff --git a/t/misc.t b/t/misc.t index 82526bf..496f4e6 100644 --- a/t/misc.t +++ b/t/misc.t @@ -8,10 +8,8 @@ ok(my ($smtpd, $conn) = Test::Qpsmtpd->new_conn(), "get new connection"); # fault method 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' - ); - + "Internal error - try again later - test message", + 'returns the input message'); # vrfy command is(($smtpd->command('VRFY '))[0], 252, 'VRFY command'); diff --git a/t/plugin_tests.t b/t/plugin_tests.t index 69344c1..c514d4c 100644 --- a/t/plugin_tests.t +++ b/t/plugin_tests.t @@ -7,11 +7,8 @@ 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; +foreach my $file ("./t/config/greylist.dbm", "./t/config/greylist.dbm.lock") { + next if !-f $file; unlink $file; -}; +} diff --git a/t/qpsmtpd-address.t b/t/qpsmtpd-address.t index 599a4af..0e5f88a 100644 --- a/t/qpsmtpd-address.t +++ b/t/qpsmtpd-address.t @@ -13,96 +13,96 @@ my $ao; $as = '<>'; $ao = Qpsmtpd::Address->parse($as); -ok ($ao, "parse $as"); -is ($ao->format, $as, "format $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"); +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"); +ok($ao, "parse $as"); +is($ao->format, $as, "format $as"); -is ($ao->user, 'foo', 'user'); -is ($ao->host, 'example.com', 'host'); +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 +# 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"); +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"); +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"); +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"); +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"); +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"); +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)'); +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"); +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"); +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 - ); +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 @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"); +is_deeply(\@test_list, \@sorted_list, "sort via overloaded 'cmp' operator"); # RT#38746 - non-RFC compliant address should return undef -$as=''; +$as = ''; $ao = Qpsmtpd::Address->new($as); -is ($ao, undef, "illegal $as"); +is($ao, undef, "illegal $as"); diff --git a/t/rset.t b/t/rset.t index ae1e462..d1c5ae9 100644 --- a/t/rset.t +++ b/t/rset.t @@ -7,7 +7,9 @@ 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'); +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 index 467e5d7..fdcef05 100644 --- a/t/tempstuff.t +++ b/t/tempstuff.t @@ -5,7 +5,7 @@ use strict; use lib 't'; use_ok('Test::Qpsmtpd'); -BEGIN { # need this to happen before anything else +BEGIN { # need this to happen before anything else my $cwd = `pwd`; chomp($cwd); open my $spooldir, '>', "./config.sample/spool_dir"; @@ -15,13 +15,13 @@ BEGIN { # need this to happen before anything else 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() ); +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" ); +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); diff --git a/xt/01-syntax.t b/xt/01-syntax.t index c0ea682..3072713 100644 --- a/xt/01-syntax.t +++ b/xt/01-syntax.t @@ -4,38 +4,39 @@ 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"; -}; +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' ); +my @files = + find({wanted => \&test_syntax, no_chdir => 1}, 'plugins', 'lib', 't'); -sub test_syntax { +sub test_syntax { my $f = $File::Find::name; chomp $f; - return if ! -f $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"); + my $exit_code = sprintf("%d", $CHILD_ERROR >> 8); + if ($exit_code == 0) { + ok($exit_code == 0, "syntax $f"); return; } - if ( $r =~ /^Base class package "Danga::Socket" is empty/ ) { - ok( 0 == 0, "skipping $f, Danga::Socket not available."); + 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/xt/02-pod.t b/xt/02-pod.t index e989b93..67953f0 100644 --- a/xt/02-pod.t +++ b/xt/02-pod.t @@ -2,17 +2,17 @@ use Test::More; -if ( ! $ENV{'QPSMTPD_DEVELOPER'} ) { +if (!$ENV{'QPSMTPD_DEVELOPER'}) { plan skip_all => "not a developer, skipping POD tests"; exit; } eval "use Test::Pod 1.14"; -if ( $@ ) { +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 ) ); +all_pod_files_ok(all_pod_files(@poddirs)); done_testing(); From cd23266105b1af2817cd7fd68357acf37b18d875 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sun, 21 Apr 2013 00:54:43 -0400 Subject: [PATCH 262/352] perltidy -b watch summarize show_message log2sql --- log/log2sql | 530 +++++++++++++++++++++++++---------------------- log/show_message | 72 +++---- log/summarize | 377 +++++++++++++++++---------------- log/watch | 40 ++-- 4 files changed, 540 insertions(+), 479 deletions(-) diff --git a/log/log2sql b/log/log2sql index cd1f4f3..fa8010e 100755 --- a/log/log2sql +++ b/log/log2sql @@ -22,11 +22,11 @@ my (%plugins, %os, %message_ids); my $has_cleanup; my $db = get_db(); -foreach my $file ( @logfiles ) { +foreach my $file (@logfiles) { my ($fid, $offset) = check_logfile($file); $fid or next; - parse_logfile( $file, $fid, $offset ); -}; + parse_logfile($file, $fid, $offset); +} exit; @@ -47,14 +47,14 @@ sub trim_message { return '' if $mess eq 'TLS setup returning'; return $mess; -}; +} sub get_os_id { my $p0f_string = shift or return; $p0f_string =~ s/\s+$//; $p0f_string =~ s/^\s+//; - return if ! $p0f_string; + return if !$p0f_string; return if $p0f_string =~ /no match/; return if $p0f_string =~ /^skip/; return if $p0f_string =~ /^\d/; @@ -62,266 +62,267 @@ sub get_os_id { return if $p0f_string !~ /\w/; return if $p0f_string =~ /no longer in the cache/; - if ( ! scalar keys %os ) { - my $ref = exec_query( 'SELECT * FROM os' ); - foreach my $o ( @$ref ) { - $os{ $o->{name} } = $o->{id}; - }; - }; + if (!scalar keys %os) { + my $ref = exec_query('SELECT * FROM os'); + foreach my $o (@$ref) { + $os{$o->{name}} = $o->{id}; + } + } - if ( ! defined $os{$p0f_string} ) { + if (!defined $os{$p0f_string}) { warn "missing OS for $p0f_string\n"; - }; + } return $os{$p0f_string}; -}; +} sub get_plugin_id { my $plugin = shift; - if ( ! scalar keys %plugins ) { - my $ref = exec_query( 'SELECT * FROM plugin' ); - foreach my $p ( @$ref ) { - $plugins{ $p->{name} } = $p->{id}; - $plugins{ $p->{id} } = $p->{name}; - }; - $ref = exec_query( 'SELECT * FROM plugin_aliases' ); - foreach my $pa ( @$ref ) { - $plugins{ $pa->{name} } = $pa->{plugin_id}; - }; - }; + if (!scalar keys %plugins) { + my $ref = exec_query('SELECT * FROM plugin'); + foreach my $p (@$ref) { + $plugins{$p->{name}} = $p->{id}; + $plugins{$p->{id}} = $p->{name}; + } + $ref = exec_query('SELECT * FROM plugin_aliases'); + foreach my $pa (@$ref) { + $plugins{$pa->{name}} = $pa->{plugin_id}; + } + } + + if (!defined $plugins{$plugin}) { - if ( ! defined $plugins{$plugin} ) { #warn Dumper(\%plugins); die "missing DB plugin $plugin\n"; - }; + } return $plugins{$plugin}; -}; +} sub get_msg_id { - my ( $fid, $pid ) = @_; + my ($fid, $pid) = @_; - return $message_ids{ "$fid-$pid" } if $message_ids{ "$fid-$pid" }; + return $message_ids{"$fid-$pid"} if $message_ids{"$fid-$pid"}; #print "searching for message $pid..."; - my $msgs = exec_query( - 'SELECT * FROM message WHERE file_id=? AND qp_pid=?', - [ $fid, $pid ] - ); + my $msgs = exec_query('SELECT * FROM message WHERE file_id=? AND qp_pid=?', + [$fid, $pid]); + #print scalar @$msgs ? "y\n" : "n\n"; - if ( $msgs->[0]{id} ) { - $message_ids{ "$fid-$pid" } = $msgs->[0]{id}; - }; + if ($msgs->[0]{id}) { + $message_ids{"$fid-$pid"} = $msgs->[0]{id}; + } return $msgs->[0]{id}; -}; +} sub create_message { - my ( $fid, $ts, $pid, $message ) = @_; + my ($fid, $ts, $pid, $message) = @_; my ($host, $ip) = split /\s/, $message; - $ip = substr $ip, 1, -1; # remove brackets + $ip = substr $ip, 1, -1; # remove brackets my $id = exec_query( - "INSERT INTO message SET file_id=?, connect_start=FROM_UNIXTIME(?), qp_pid=?, ip=INET_ATON(?)", - [ $fid, $ts, $pid, $ip ] +"INSERT INTO message SET file_id=?, connect_start=FROM_UNIXTIME(?), qp_pid=?, ip=INET_ATON(?)", + [$fid, $ts, $pid, $ip] ); - if ( $host && $host ne 'Unknown' ) { - exec_query( "UPDATE message SET hostname=? WHERE id=?", [ $host, $id ] ); - }; + if ($host && $host ne 'Unknown') { + exec_query("UPDATE message SET hostname=? WHERE id=?", [$host, $id]); + } + #warn "host updated: $host\n"; -}; +} sub insert_plugin { - my ( $msg_id, $plugin, $message ) = @_; + my ($msg_id, $plugin, $message) = @_; - my $plugin_id = get_plugin_id( $plugin ); + my $plugin_id = get_plugin_id($plugin); - if ( $plugin eq 'ident::geoip' ) { + if ($plugin eq 'ident::geoip') { my ($gip, $distance) = $message =~ /(.*?),\s+([\d]+)\skm/; - if ( $distance ) { - exec_query( 'UPDATE message SET distance=? WHERE id=?', [ $distance, $msg_id ] ); + if ($distance) { + exec_query('UPDATE message SET distance=? WHERE id=?', + [$distance, $msg_id]); $message = $gip; } } - elsif ( $plugin =~ /^ident::p0f/ ) { - my $os_id = get_os_id( $message ); - if ( $os_id ) { - exec_query( 'UPDATE message SET os_id=? WHERE id=?', [ $os_id, $msg_id ] ); + elsif ($plugin =~ /^ident::p0f/) { + my $os_id = get_os_id($message); + if ($os_id) { + exec_query('UPDATE message SET os_id=? WHERE id=?', + [$os_id, $msg_id]); $message = 'pass'; } } - elsif ( $plugin eq 'connection_time' ) { + elsif ($plugin eq 'connection_time') { my ($seconds) = $message =~ /\s*([\d\.]+)\s/; - if ( $seconds ) { - exec_query( 'UPDATE message SET time=? WHERE id=?', [ $seconds, $msg_id ] ); + if ($seconds) { + exec_query('UPDATE message SET time=? WHERE id=?', + [$seconds, $msg_id]); $message = 'pass'; } } - my $result = get_score( $message ); - if ( $result ) { + my $result = get_score($message); + if ($result) { $message = trim_message($message); - }; + } - exec_query( 'INSERT INTO message_plugin SET msg_id=?, plugin_id=?, result=?, string=?', - [ $msg_id, $plugin_id, $result, $message ] + exec_query( +'INSERT INTO message_plugin SET msg_id=?, plugin_id=?, result=?, string=?', + [$msg_id, $plugin_id, $result, $message] ); -}; +} sub parse_logfile { - my $file = shift; - my $fid = shift; + my $file = shift; + my $fid = shift; my $offset = shift || 0; - my $path = "$logdir/$file"; + my $path = "$logdir/$file"; print "parsing file $file (id: $fid) from offset $offset\n"; open my $F, '<', $path or die "could not open $path: $!"; - seek( $F, $offset, 0 ) if $offset; + seek($F, $offset, 0) if $offset; - while ( defined (my $line = <$F> ) ) { + while (defined(my $line = <$F>)) { chomp $line; - next if ! $line; - my ( $type, $pid, $hook, $plugin, $message ) = parse_line( $line ); + next if !$line; + my ($type, $pid, $hook, $plugin, $message) = parse_line($line); - next if ! $type; + next if !$type; next if $type eq 'info'; next if $type eq 'unknown'; next if $type eq 'response'; - next if $type eq 'init'; # doesn't occur in all deployment models + next if $type eq 'init'; # doesn't occur in all deployment models next if $type eq 'cleanup'; next if $type eq 'error'; - my $ts = tai2unix( (split /\s/, $line)[0] ); # print "ts: $ts\n"; + my $ts = tai2unix((split /\s/, $line)[0]); # print "ts: $ts\n"; - my $msg_id = get_msg_id( $fid, $pid ) or do { - create_message( $fid, $ts, $pid, $message ) if $type eq 'connect'; + my $msg_id = get_msg_id($fid, $pid) or do { + create_message($fid, $ts, $pid, $message) if $type eq 'connect'; next; }; #warn "type: $type\n"; - if ( $type eq 'plugin' ) { - next if $plugin eq 'naughty'; # housekeeping only - insert_plugin( $msg_id, $plugin, $message ); + if ($type eq 'plugin') { + next if $plugin eq 'naughty'; # housekeeping only + insert_plugin($msg_id, $plugin, $message); } - elsif ( $type eq 'queue' ) { - exec_query('UPDATE message SET result=? WHERE id=?', [ 3, $msg_id ] ); + elsif ($type eq 'queue') { + exec_query('UPDATE message SET result=? WHERE id=?', [3, $msg_id]); } - elsif ( $type eq 'reject' ) { - exec_query('UPDATE message SET result=? WHERE id=?', [ -3, $msg_id ] ); + elsif ($type eq 'reject') { + exec_query('UPDATE message SET result=? WHERE id=?', [-3, $msg_id]); } - elsif ( $type eq 'close' ) { - if ( $message eq 'Connection Timed Out' ) { - exec_query('UPDATE message SET result=? WHERE id=?', [ -1, $msg_id ] ); - }; - } - elsif ( $type eq 'connect' ) { } - elsif ( $type eq 'dispatch' ) { - if ( substr($message, 0, 21) eq 'dispatching MAIL FROM' ) { - my ($from) = $message =~ /<(.*?)>/; - exec_query('UPDATE message SET mail_from=? WHERE id=?', [ $from, $msg_id ] ); + elsif ($type eq 'close') { + if ($message eq 'Connection Timed Out') { + exec_query('UPDATE message SET result=? WHERE id=?', + [-1, $msg_id]); } - elsif ( substr($message, 0, 19) eq 'dispatching RCPT TO' ) { - my ($to) = $message =~ /<(.*?)>/; - exec_query('UPDATE message SET rcpt_to=? WHERE id=? AND rcpt_to IS NULL', [ $to, $msg_id ] ); + } + elsif ($type eq 'connect') { } + elsif ($type eq 'dispatch') { + if (substr($message, 0, 21) eq 'dispatching MAIL FROM') { + my ($from) = $message =~ /<(.*?)>/; + exec_query('UPDATE message SET mail_from=? WHERE id=?', + [$from, $msg_id]); } - elsif ( $message =~ m/dispatching (EHLO|HELO) (.*)/ ) { - exec_query('UPDATE message SET helo=? WHERE id=?', [ $2, $msg_id ] ); + elsif (substr($message, 0, 19) eq 'dispatching RCPT TO') { + my ($to) = $message =~ /<(.*?)>/; + exec_query( +'UPDATE message SET rcpt_to=? WHERE id=? AND rcpt_to IS NULL', + [$to, $msg_id] + ); } - elsif ( $message eq 'dispatching DATA' ) { } - elsif ( $message eq 'dispatching QUIT' ) { } - elsif ( $message eq 'dispatching STARTTLS' ) { } - elsif ( $message eq 'dispatching RSET' ) { } + elsif ($message =~ m/dispatching (EHLO|HELO) (.*)/) { + exec_query('UPDATE message SET helo=? WHERE id=?', + [$2, $msg_id]); + } + elsif ($message eq 'dispatching DATA') { } + elsif ($message eq 'dispatching QUIT') { } + elsif ($message eq 'dispatching STARTTLS') { } + elsif ($message eq 'dispatching RSET') { } else { # anything here is likely an unrecognized command #print "$message\n"; - }; + } } else { print "$type $pid $hook $plugin $message\n"; - }; - }; + } + } close $F; -}; +} sub check_logfile { my $file = shift; my $path = "$logdir/$file"; - die "missing file $logdir/$file" if ! -f "$logdir/$file"; + die "missing file $logdir/$file" if !-f "$logdir/$file"; - my $inode = stat($path)->ino or die "unable to get inode for $path\n"; + my $inode = stat($path)->ino or die "unable to get inode for $path\n"; my $size = stat($path)->size or die "unable to get size for $path\n"; my $exists; #warn "check if file $file is in the DB as 'current'\n"; - if ( $file =~ /^\@/ ) { - $exists = exec_query( - 'SELECT * FROM log WHERE inode=? AND name=?', - [ $inode, 'current' ] - ); - if ( @$exists ) { + if ($file =~ /^\@/) { + $exists = exec_query('SELECT * FROM log WHERE inode=? AND name=?', + [$inode, 'current']); + if (@$exists) { print "Updating current -> $file\n"; - exec_query( - 'UPDATE log SET name=? WHERE inode=? AND name=?', - [ $file, $inode, 'current' ] - ); - return ( $exists->[0]{id}, $exists->[0]{size} ); # continue parsing - }; - }; + exec_query('UPDATE log SET name=? WHERE inode=? AND name=?', + [$file, $inode, 'current']); + return ($exists->[0]{id}, $exists->[0]{size}); # continue parsing + } + } - if ( $file eq 'current' ) { - $exists = exec_query( - 'SELECT * FROM log WHERE inode=? AND name=?', - [ $inode, $file ] - ); - if ( @$exists ) { - exec_query( - 'UPDATE log SET size=? WHERE inode=? AND name=?', - [ $size, $inode, 'current' ] - ); - return ( $exists->[0]{id}, $exists->[0]{size} ); # continue parsing - }; - }; + if ($file eq 'current') { + $exists = exec_query('SELECT * FROM log WHERE inode=? AND name=?', + [$inode, $file]); + if (@$exists) { + exec_query('UPDATE log SET size=? WHERE inode=? AND name=?', + [$size, $inode, 'current']); + return ($exists->[0]{id}, $exists->[0]{size}); # continue parsing + } + } - $exists = exec_query( - 'SELECT * FROM log WHERE name=? AND size=?', - [ $file, $size ] - ); + $exists = + exec_query('SELECT * FROM log WHERE name=? AND size=?', [$file, $size]); return if @$exists; # log file hasn't changed, ignore it - #print Dumper($exists); + #print Dumper($exists); # file is a new one we haven't seen, add to DB and parse my $id = exec_query( 'INSERT INTO log SET inode=?, size=?, name=?, created=FROM_UNIXTIME(?)', - [ $inode, $size, $file, stat($path)->ctime ] + [$inode, $size, $file, stat($path)->ctime] ); print "new file id: $id\n"; - return ( $id ); -}; + return ($id); +} sub get_log_dir { - if ( -d "log/main" ) { + if (-d "log/main") { my $wd = Cwd::cwd(); return "$wd/log/main"; - }; + } - foreach my $user ( qw/ qpsmtpd smtpd / ) { + foreach my $user (qw/ qpsmtpd smtpd /) { - my ($homedir) = (getpwnam( $user ))[7] or next; + my ($homedir) = (getpwnam($user))[7] or next; - if ( -d "$homedir/log" ) { + if (-d "$homedir/log") { return "$homedir/log/main"; - }; - if ( -d "$homedir/smtpd/log" ) { + } + if (-d "$homedir/smtpd/log") { return "$homedir/smtpd/log/main"; - }; - }; + } + } -}; +} sub get_logfiles { my $dir = shift; @@ -329,134 +330,159 @@ sub get_logfiles { opendir my $D, $dir or die "unable to open log dir $dir\n"; my @files; - while ( defined( my $f = readdir($D) ) ) { - next if ! -f "$dir/$f"; # ignore anything that's not a file - if ( $f =~ /^\@.*s$/ ) { + while (defined(my $f = readdir($D))) { + next if !-f "$dir/$f"; # ignore anything that's not a file + if ($f =~ /^\@.*s$/) { push @files, $f; - }; + } } - push @files, "current"; # always have this one last + push @files, "current"; # always have this one last closedir $D; return @files; -}; +} sub parse_line { my $line = shift; my ($tai, $pid, $message) = split /\s+/, $line, 3; - return if ! $message; # garbage in the log file + return if !$message; # garbage in the log file # lines seen many times per connection - return parse_line_plugin( $line ) if substr($message, 0, 1) eq '('; - return ( 'dispatch', $pid, undef, undef, $message ) if substr($message, 0, 12) eq 'dispatching '; - return ( 'queue', $pid, undef, undef, $message ) if substr($message, 0, 11) eq '250 Queued!'; - return ( 'response', $pid, undef, undef, $message ) if $message =~ /^[2|3]\d\d/; + return parse_line_plugin($line) if substr($message, 0, 1) eq '('; + return ('dispatch', $pid, undef, undef, $message) + if substr($message, 0, 12) eq 'dispatching '; + return ('queue', $pid, undef, undef, $message) + if substr($message, 0, 11) eq '250 Queued!'; + return ('response', $pid, undef, undef, $message) + if $message =~ /^[2|3]\d\d/; # lines seen about once per connection - return ( 'init', $pid, undef, undef, $message ) if substr($message, 0, 19) eq 'Accepted connection'; - return ( 'connect', $pid, undef, undef, substr( $message, 16) ) if substr($message, 0, 15) eq 'Connection from'; - return ( 'connect', $pid, undef, undef, substr( $message, 16) ) if substr($message, 0, 8) eq 'connect '; - return ( 'close', $pid, undef, undef, $message ) if substr($message, 0, 6) eq 'close '; - return ( 'close', $pid, undef, undef, $message ) if $message eq 'Connection Timed Out'; - return ( 'close', $pid, undef, undef, $message ) if substr($message, 0, 20) eq 'click, disconnecting'; - return parse_line_cleanup( $line ) if substr($message, 0, 11) eq 'cleaning up'; + return ('init', $pid, undef, undef, $message) + if substr($message, 0, 19) eq 'Accepted connection'; + return ('connect', $pid, undef, undef, substr($message, 16)) + if substr($message, 0, 15) eq 'Connection from'; + return ('connect', $pid, undef, undef, substr($message, 16)) + if substr($message, 0, 8) eq 'connect '; + return ('close', $pid, undef, undef, $message) + if substr($message, 0, 6) eq 'close '; + return ('close', $pid, undef, undef, $message) + if $message eq 'Connection Timed Out'; + return ('close', $pid, undef, undef, $message) + if substr($message, 0, 20) eq 'click, disconnecting'; + return parse_line_cleanup($line) + if substr($message, 0, 11) eq 'cleaning up'; # lines seen less than once per connection - return ( 'info', $pid, undef, undef, $message ) if $message eq 'spooling message to disk'; - return ( 'reject', $pid, undef, undef, $message ) if $message =~ /^[4|5]\d\d/; - return ( 'reject', $pid, undef, undef, $message ) if substr($message, 0, 14) eq 'deny mail from'; - return ( 'reject', $pid, undef, undef, $message ) if substr($message, 0, 18) eq 'denysoft mail from'; - return ( 'info', $pid, undef, undef, $message ) if substr($message, 0, 15) eq 'Lost connection'; - return ( 'info', $pid, undef, undef, $message ) if $message eq 'auth success cleared naughty'; - return ( 'info', $pid, undef, undef, $message ) if substr($message, 0, 15) eq 'Running as user'; - return ( 'info', $pid, undef, undef, $message ) if substr($message, 0, 16) eq 'Loaded Qpsmtpd::'; - return ( 'info', $pid, undef, undef, $message ) if substr($message, 0, 24) eq 'Permissions on spool_dir'; - return ( 'info', $pid, undef, undef, $message ) if substr($message, 0, 13) eq 'Listening on '; - return ( 'info', $pid, undef, undef, $message ) if substr($message, 0, 18) eq 'size_threshold set'; - return ( 'info', $pid, undef, undef, $message ) if substr($message, 0, 12) eq 'tls: ciphers'; - return ( 'error', $pid, undef, undef, $message ) if substr($message, 0, 22) eq 'of uninitialized value'; - return ( 'error', $pid, undef, undef, $message ) if substr($message, 0, 8) eq 'symbol "'; - return ( 'error', $pid, undef, undef, $message ) if substr($message, 0, 9) eq 'error at '; - return ( 'error', $pid, undef, undef, $message ) if substr($message, 0, 15) eq 'Could not print'; + return ('info', $pid, undef, undef, $message) + if $message eq 'spooling message to disk'; + return ('reject', $pid, undef, undef, $message) if $message =~ /^[4|5]\d\d/; + return ('reject', $pid, undef, undef, $message) + if substr($message, 0, 14) eq 'deny mail from'; + return ('reject', $pid, undef, undef, $message) + if substr($message, 0, 18) eq 'denysoft mail from'; + return ('info', $pid, undef, undef, $message) + if substr($message, 0, 15) eq 'Lost connection'; + return ('info', $pid, undef, undef, $message) + if $message eq 'auth success cleared naughty'; + return ('info', $pid, undef, undef, $message) + if substr($message, 0, 15) eq 'Running as user'; + return ('info', $pid, undef, undef, $message) + if substr($message, 0, 16) eq 'Loaded Qpsmtpd::'; + return ('info', $pid, undef, undef, $message) + if substr($message, 0, 24) eq 'Permissions on spool_dir'; + return ('info', $pid, undef, undef, $message) + if substr($message, 0, 13) eq 'Listening on '; + return ('info', $pid, undef, undef, $message) + if substr($message, 0, 18) eq 'size_threshold set'; + return ('info', $pid, undef, undef, $message) + if substr($message, 0, 12) eq 'tls: ciphers'; + return ('error', $pid, undef, undef, $message) + if substr($message, 0, 22) eq 'of uninitialized value'; + return ('error', $pid, undef, undef, $message) + if substr($message, 0, 8) eq 'symbol "'; + return ('error', $pid, undef, undef, $message) + if substr($message, 0, 9) eq 'error at '; + return ('error', $pid, undef, undef, $message) + if substr($message, 0, 15) eq 'Could not print'; print "UNKNOWN LINE: $line\n"; - return ( 'unknown', $pid, undef, undef, $message ); -}; + return ('unknown', $pid, undef, undef, $message); +} sub parse_line_plugin { my ($line) = @_; - # @tai 13486 (connect) ident::p0f: Windows (XP/2000 (RFC1323+, w, tstamp-)) - # @tai 13681 (connect) dnsbl: fail, NAUGHTY - # @tai 15787 (connect) karma: pass, no penalty (0 naughty, 3 nice, 3 connects) - # @tai 27500 (queue) queue::qmail_2dqueue: (for 27481) Queuing to /var/qmail/bin/qmail-queue - my ($tai, $pid, $hook, $plugin, $message ) = split /\s/, $line, 5; +# @tai 13486 (connect) ident::p0f: Windows (XP/2000 (RFC1323+, w, tstamp-)) +# @tai 13681 (connect) dnsbl: fail, NAUGHTY +# @tai 15787 (connect) karma: pass, no penalty (0 naughty, 3 nice, 3 connects) +# @tai 27500 (queue) queue::qmail_2dqueue: (for 27481) Queuing to /var/qmail/bin/qmail-queue + my ($tai, $pid, $hook, $plugin, $message) = split /\s/, $line, 5; $plugin =~ s/:$//; - return parse_line_plugin_p0f( $line ) if $plugin =~ /^ident::p0f/; - return parse_line_plugin_dspam( $line ) if $plugin =~ /^dspam/; - return parse_line_plugin_spamassassin( $line ) if $plugin =~ /^spamassassin/; + return parse_line_plugin_p0f($line) if $plugin =~ /^ident::p0f/; + return parse_line_plugin_dspam($line) if $plugin =~ /^dspam/; + return parse_line_plugin_spamassassin($line) if $plugin =~ /^spamassassin/; - if ( $plugin eq 'sender_permitted_from' ) { + if ($plugin eq 'sender_permitted_from') { $message = 'pass' if $message =~ /^pass/; $message = 'fail' if $message =~ /^fail/; $message = 'skip' if $message =~ /^none/; } - elsif ( $plugin eq 'queue::qmail_2dqueue' ) { + elsif ($plugin eq 'queue::qmail_2dqueue') { ($pid) = $message =~ /\(for ([\d]+)\)/; $message = 'pass' if $message =~ /Queuing/; } - elsif ( $plugin =~ /(?:early|karma|helo|rcpt_ok)/ ) { + elsif ($plugin =~ /(?:early|karma|helo|rcpt_ok)/) { $message = 'pass' if $message =~ /^pass/; } - elsif ( $plugin =~ /resolvable_fromhost/ ) { + elsif ($plugin =~ /resolvable_fromhost/) { $message = 'pass' if $message =~ /^pass/; - }; + } - return ( 'plugin', $pid, $hook, $plugin, $message ); -}; + return ('plugin', $pid, $hook, $plugin, $message); +} sub parse_line_plugin_dspam { my $line = shift; - my ($tai, $pid, $hook, $plugin, $message ) = split /\s/, $line, 5; + my ($tai, $pid, $hook, $plugin, $message) = split /\s/, $line, 5; $plugin =~ s/:$//; - if ( $message =~ /Innocent, (\d\.\d\d c)/ ) { + if ($message =~ /Innocent, (\d\.\d\d c)/) { $message = "pass, $1"; - }; - if ( $message =~ /Spam, (\d\.\d\d c)/ ) { + } + if ($message =~ /Spam, (\d\.\d\d c)/) { $message = "fail, $1"; - }; + } - return ( 'plugin', $pid, $hook, $plugin, $message ); -}; + return ('plugin', $pid, $hook, $plugin, $message); +} sub parse_line_plugin_spamassassin { my $line = shift; - my ($tai, $pid, $hook, $plugin, $message ) = split /\s/, $line, 5; + my ($tai, $pid, $hook, $plugin, $message) = split /\s/, $line, 5; $plugin =~ s/:$//; - if ( $message =~ /pass, Ham, ([\d\-\.]+)\s/ ) { + if ($message =~ /pass, Ham, ([\d\-\.]+)\s/) { $message = "pass, $1"; - }; - if ( $message =~ /^fail, Spam,\s([\d\.]+)\s< 100/ ) { + } + if ($message =~ /^fail, Spam,\s([\d\.]+)\s< 100/) { $message = "fail, $1"; - }; + } - return ( 'plugin', $pid, $hook, $plugin, $message ); -}; + return ('plugin', $pid, $hook, $plugin, $message); +} sub parse_line_plugin_p0f { my $line = shift; - my ($tai, $pid, $hook, $plugin, $message ) = split /\s/, $line, 5; + my ($tai, $pid, $hook, $plugin, $message) = split /\s/, $line, 5; $plugin =~ s/:$//; - if ( substr( $message, -5, 5) eq 'hops)' ) { - ($message) = split( /\s\(/, $message ); - }; + if (substr($message, -5, 5) eq 'hops)') { + ($message) = split(/\s\(/, $message); + } $message = 'iOS' if $message =~ /^iOS/; $message = 'Solaris' if $message =~ /^Solaris/; @@ -478,68 +504,68 @@ sub parse_line_plugin_p0f { $message = 'Cisco' if $message =~ /^Cisco/i; $message = 'Netware' if $message =~ /Netware/i; - return ( 'plugin', $pid, $hook, $plugin, $message ); -}; + return ('plugin', $pid, $hook, $plugin, $message); +} sub parse_line_cleanup { my ($line) = @_; + # @tai 85931 cleaning up after 3210 my $pid = (split /\s+/, $line)[-1]; $has_cleanup++; - return ( 'cleanup', $pid, undef, undef, $line ); -}; + return ('cleanup', $pid, undef, undef, $line); +} sub get_score { my $mess = shift; - return 3 if $mess eq 'TLS setup returning'; - return 3 if $mess =~ /^pass/; - return -3 if $mess =~ /^fail/; - return -2 if $mess =~ /^negative/; - return 2 if $mess =~ /^positive/; - return 1 if $mess =~ /^skip/; + return 3 if $mess eq 'TLS setup returning'; + return 3 if $mess =~ /^pass/; + return -3 if $mess =~ /^fail/; + return -2 if $mess =~ /^negative/; + return 2 if $mess =~ /^positive/; + return 1 if $mess =~ /^skip/; return 0; -}; - +} sub get_db { - my $db = DBIx::Simple->connect( $dsn, $user, $pass ) - or die DBIx::Simple->error; + my $db = DBIx::Simple->connect($dsn, $user, $pass) + or die DBIx::Simple->error; return $db; -}; +} sub exec_query { - my $query = shift; + my $query = shift; my $params = shift; die "invalid arguments to exec_query!" if @_; my @params; - if ( defined $params ) { + if (defined $params) { @params = ref $params eq 'ARRAY' ? @$params : $params; - }; + } my $err = "query failed: $query\n"; - if ( scalar @params ) { + if (scalar @params) { $err .= join(',', @params); - }; + } #warn "err: $err\n"; - if ( $query =~ /INSERT INTO/ ) { - my ( $table ) = $query =~ /INSERT INTO (\w+)\s/; - $db->query( $query, @params ); + if ($query =~ /INSERT INTO/) { + my ($table) = $query =~ /INSERT INTO (\w+)\s/; + $db->query($query, @params); die "$db->error\n$err" if $db->error ne 'DBI error: '; - my $id = $db->last_insert_id(undef,undef,$table,undef) or die $err; + my $id = $db->last_insert_id(undef, undef, $table, undef) or die $err; return $id; } - elsif ( $query =~ /^UPDATE/i ) { - return $db->query( $query, @params ); + elsif ($query =~ /^UPDATE/i) { + return $db->query($query, @params); } - elsif ( $query =~ /DELETE/ ) { - $db->query( $query, @params ) or die $err; + elsif ($query =~ /DELETE/) { + $db->query($query, @params) or die $err; return $db->query("SELECT ROW_COUNT()")->list; - }; + } - my $r = $db->query( $query, @params )->hashes or die $err; + my $r = $db->query($query, @params)->hashes or die $err; return $r; -}; +} diff --git a/log/show_message b/log/show_message index 9ee2ef1..c677d01 100755 --- a/log/show_message +++ b/log/show_message @@ -5,68 +5,68 @@ use warnings; use Data::Dumper; -my $QPDIR = get_qp_dir(); +my $QPDIR = get_qp_dir(); my $logfile = "$QPDIR/log/main/current"; my $is_ip = 0; my $search = $ARGV[0]; -if ( ! $search ) { +if (!$search) { die "\nusage: $0 [ ip_address | PID ]\n\n"; -}; +} + +if ($search =~ /^(?:[0-9]{1,3}\.){3}[0-9]{1,3}$/) { -if ( $search =~ /^(?:[0-9]{1,3}\.){3}[0-9]{1,3}$/ ) { #print "it's an IP\n"; $is_ip++; -}; +} open my $LOG, '<', $logfile or die "unable to open $logfile\n"; -if ( $is_ip ) { # look for the connection start message for the IP +if ($is_ip) { # look for the connection start message for the IP my $ip_matches; - while ( defined (my $line = <$LOG>) ) { - next if ! $line; - my ( $tai, $pid, $mess ) = split /\s/, $line, 3; - if ( 'Connection from ' eq substr( $mess, 0, 16 ) ) { - my ( $ip ) = (split /\s+/, $mess)[-1]; # IP is last word + while (defined(my $line = <$LOG>)) { + next if !$line; + my ($tai, $pid, $mess) = split /\s/, $line, 3; + if ('Connection from ' eq substr($mess, 0, 16)) { + my ($ip) = (split /\s+/, $mess)[-1]; # IP is last word $ip = substr $ip, 1, -1; # trim off brackets - if ( $ip eq $search ) { + if ($ip eq $search) { $ip_matches++; $search = $pid; - $is_ip = 0; - }; - }; - }; + $is_ip = 0; + } + } + } seek $LOG, 0, 0; die "no pid found for ip $search\n" if $is_ip; print "showing the last of $ip_matches connnections from $ARGV[0]\n"; -}; +} print "showing QP message PID $search\n"; -while ( defined (my $line = <$LOG>) ) { - next if ! $line; - my ( $tai, $pid, $mess ) = split /\s/, $line, 3; - next if ! $pid; - print $mess if ( $pid eq $search ); -}; +while (defined(my $line = <$LOG>)) { + next if !$line; + my ($tai, $pid, $mess) = split /\s/, $line, 3; + next if !$pid; + print $mess if ($pid eq $search); +} close $LOG; - sub get_qp_dir { - foreach my $user ( qw/ qpsmtpd smtpd / ) { - my ($homedir) = (getpwnam( $user ))[7] or next; + foreach my $user (qw/ qpsmtpd smtpd /) { + my ($homedir) = (getpwnam($user))[7] or next; - if ( -d "$homedir/plugins" ) { + if (-d "$homedir/plugins") { return "$homedir"; - }; - foreach my $s ( qw/ smtpd qpsmtpd qpsmtpd-dev / ) { - if ( -d "$homedir/$s/plugins" ) { + } + foreach my $s (qw/ smtpd qpsmtpd qpsmtpd-dev /) { + if (-d "$homedir/$s/plugins") { return "$homedir/$s"; - }; - }; - }; - if ( -d "./plugins" ) { + } + } + } + if (-d "./plugins") { return Cwd::getcwd(); - }; -}; + } +} diff --git a/log/summarize b/log/summarize index cca2651..b72cef9 100755 --- a/log/summarize +++ b/log/summarize @@ -15,210 +15,238 @@ my %hide_plugins = map { $_ => 1 } qw/ hostname /; my $qpdir = get_qp_dir(); my $file = "$qpdir/log/main/current"; populate_plugins_from_registry(); -my @sorted_plugins = sort { $plugins{$a}{id} <=> $plugins{$b}{id} } keys %plugins; +my @sorted_plugins = + sort { $plugins{$a}{id} <=> $plugins{$b}{id} } keys %plugins; -my $fh = File::Tail->new(name=>$file, interval=>1, maxinterval=>1, debug =>1, tail =>1000 ); +my $fh = File::Tail->new( + name => $file, + interval => 1, + maxinterval => 1, + debug => 1, + tail => 1000 + ); my $printed = 0; my $has_cleanup; my %formats = ( - ip => "%-15.15s", - hostname => "%-20.20s", - distance => "%5.5s", - 'ident::geoip' => "%-20.20s", - 'ident::p0f' => "%-10.10s", - count_unrecognized_commands => "%-5.5s", - unrecognized_commands => "%-5.5s", - dnsbl => "%-3.3s", - rhsbl => "%-3.3s", - relay => "%-3.3s", - karma => "%-3.3s", - fcrdns => "%-3.3s", - earlytalker => "%-3.3s", - check_earlytalker => "%-3.3s", - helo => "%-3.3s", - tls => "%-3.3s", - 'auth::auth_vpopmail' => "%-3.3s", - 'auth::auth_vpopmaild' => "%-3.3s", - 'auth::auth_vpopmail_sql' => "%-3.3s", - 'auth::auth_checkpassword' => "%-3.3s", - badmailfrom => "%-3.3s", - check_badmailfrom => "%-3.3s", - sender_permitted_from => "%-3.3s", - resolvable_fromhost => "%-3.3s", - 'queue::qmail-queue' => "%-3.3s", - connection_time => "%-4.4s", -); + ip => "%-15.15s", + hostname => "%-20.20s", + distance => "%5.5s", + 'ident::geoip' => "%-20.20s", + 'ident::p0f' => "%-10.10s", + count_unrecognized_commands => "%-5.5s", + unrecognized_commands => "%-5.5s", + dnsbl => "%-3.3s", + rhsbl => "%-3.3s", + relay => "%-3.3s", + karma => "%-3.3s", + fcrdns => "%-3.3s", + earlytalker => "%-3.3s", + check_earlytalker => "%-3.3s", + helo => "%-3.3s", + tls => "%-3.3s", + 'auth::auth_vpopmail' => "%-3.3s", + 'auth::auth_vpopmaild' => "%-3.3s", + 'auth::auth_vpopmail_sql' => "%-3.3s", + 'auth::auth_checkpassword' => "%-3.3s", + badmailfrom => "%-3.3s", + check_badmailfrom => "%-3.3s", + sender_permitted_from => "%-3.3s", + resolvable_fromhost => "%-3.3s", + 'queue::qmail-queue' => "%-3.3s", + connection_time => "%-4.4s", + ); my %formats3 = ( - %formats, - badrcptto => "%-3.3s", - check_badrcptto => "%-3.3s", - qmail_deliverable => "%-3.3s", - rcpt_ok => "%-3.3s", - check_basicheaders => "%-3.3s", - headers => "%-3.3s", - uribl => "%-3.3s", - bogus_bounce => "%-3.3s", - check_bogus_bounce => "%-3.3s", - domainkeys => "%-3.3s", - dkim => "%-3.3s", - dmarc => "%-3.3s", - spamassassin => "%-3.3s", - dspam => "%-3.3s", - 'virus::clamdscan' => "%-3.3s", -); + %formats, + badrcptto => "%-3.3s", + check_badrcptto => "%-3.3s", + qmail_deliverable => "%-3.3s", + rcpt_ok => "%-3.3s", + check_basicheaders => "%-3.3s", + headers => "%-3.3s", + uribl => "%-3.3s", + bogus_bounce => "%-3.3s", + check_bogus_bounce => "%-3.3s", + domainkeys => "%-3.3s", + dkim => "%-3.3s", + dmarc => "%-3.3s", + spamassassin => "%-3.3s", + dspam => "%-3.3s", + 'virus::clamdscan' => "%-3.3s", + ); - -while ( defined (my $line = $fh->read) ) { +while (defined(my $line = $fh->read)) { chomp $line; - next if ! $line; - my ( $type, $pid, $hook, $plugin, $message ) = parse_line( $line ); - next if ! $type; + next if !$line; + my ($type, $pid, $hook, $plugin, $message) = parse_line($line); + next if !$type; next if $type =~ /^(info|unknown|response|tcpserver)$/; - next if $type eq 'init'; # doesn't occur in all deployment models + next if $type eq 'init'; # doesn't occur in all deployment models - if ( ! $pids{$pid} ) { # haven't seen this pid + if (!$pids{$pid}) { # haven't seen this pid next if $type ne 'connect'; # ignore unless connect my ($host, $ip) = split /\s/, $message; $ip = substr $ip, 1, -1; - foreach ( keys %seen_plugins, qw/ helo_host from to / ) { $pids{$pid}{$_} = ''; }; - $pids{$pid}{ip} = $ip; + foreach (keys %seen_plugins, qw/ helo_host from to /) { + $pids{$pid}{$_} = ''; + } + $pids{$pid}{ip} = $ip; $pids{$pid}{hostname} = $host if $host ne 'Unknown'; - }; + } - if ( $type eq 'close' ) { - next if $has_cleanup; # it'll get handled later + if ($type eq 'close') { + next if $has_cleanup; # it'll get handled later print_auto_format($pid, $line); delete $pids{$pid}; } - elsif ( $type eq 'cleanup' ) { + elsif ($type eq 'cleanup') { print_auto_format($pid, $line); delete $pids{$pid}; } - elsif ( $type eq 'plugin' ) { + elsif ($type eq 'plugin') { next if $plugin eq 'naughty'; # housekeeping only - if ( ! $pids{$pid}{$plugin} ) { # first entry for this plugin + if (!$pids{$pid}{$plugin}) { # first entry for this plugin $pids{$pid}{$plugin} = $message; } else { # subsequent log entry for this plugin - if ( $pids{$pid}{$plugin} !~ /^(?:pass|fail|skip)/i ) { - $pids{$pid}{$plugin} = $message; # overwrite 1st + if ($pids{$pid}{$plugin} !~ /^(?:pass|fail|skip)/i) { + $pids{$pid}{$plugin} = $message; # overwrite 1st } else { #print "ignoring subsequent hit on $plugin: $message\n"; - }; - }; + } + } - if ( $plugin eq 'ident::geoip' ) { - if ( length $message < 3 ) { - $formats{'ident::geoip'} = "%-3.3s"; + if ($plugin eq 'ident::geoip') { + if (length $message < 3) { + $formats{'ident::geoip'} = "%-3.3s"; $formats3{'ident::geoip'} = "%-3.3s"; } else { my ($gip, $distance) = $message =~ /(.*?),\s+([\d]+)\skm/; - if ( $distance ) { - $pids{$pid}{$plugin} = $gip; + if ($distance) { + $pids{$pid}{$plugin} = $gip; $pids{$pid}{distance} = $distance; - }; - }; - }; + } + } + } } - elsif ( $type eq 'reject' ) { } - elsif ( $type eq 'connect' ) { } - elsif ( $type eq 'dispatch' ) { - if ( $message =~ /^dispatching MAIL FROM/i ) { - my ($from) = $message =~ /<(.*?)>/; + elsif ($type eq 'reject') { } + elsif ($type eq 'connect') { } + elsif ($type eq 'dispatch') { + if ($message =~ /^dispatching MAIL FROM/i) { + my ($from) = $message =~ /<(.*?)>/; $pids{$pid}{from} = $from; } - elsif ( $message =~ /^dispatching RCPT TO/i ) { - my ($to) = $message =~ /<(.*?)>/; + elsif ($message =~ /^dispatching RCPT TO/i) { + my ($to) = $message =~ /<(.*?)>/; $pids{$pid}{to} = $to; } - elsif ( $message =~ m/dispatching (EHLO|HELO) (.*)/ ) { + elsif ($message =~ m/dispatching (EHLO|HELO) (.*)/) { $pids{$pid}{helo_host} = $2; } - elsif ( $message eq 'dispatching DATA' ) { } - elsif ( $message eq 'dispatching QUIT' ) { } - elsif ( $message eq 'dispatching STARTTLS' ) { } - elsif ( $message eq 'dispatching RSET' ) { + elsif ($message eq 'dispatching DATA') { } + elsif ($message eq 'dispatching QUIT') { } + elsif ($message eq 'dispatching STARTTLS') { } + elsif ($message eq 'dispatching RSET') { print_auto_format($pid, $line); } else { # anything here is likely an unrecognized command #print "$message\n"; - }; + } } else { print "$type $pid $hook $plugin $message\n"; - }; -}; + } +} sub parse_line { my $line = shift; my ($tai, $pid, $message) = split /\s+/, $line, 3; - return if ! $message; # garbage in the log file + return if !$message; # garbage in the log file # lines seen many times per connection - return parse_line_plugin( $line ) if substr($message, 0, 1) eq '('; - return ( 'dispatch', $pid, undef, undef, $message ) if substr($message, 0, 12) eq 'dispatching '; - return ( 'response', $pid, undef, undef, $message ) if $message =~ /^[2|3]\d\d/; - return ( 'tcpserver', $pid, undef, undef, undef ) if substr($pid, 0, 10) eq 'tcpserver:'; + return parse_line_plugin($line) if substr($message, 0, 1) eq '('; + return ('dispatch', $pid, undef, undef, $message) + if substr($message, 0, 12) eq 'dispatching '; + return ('response', $pid, undef, undef, $message) + if $message =~ /^[2|3]\d\d/; + return ('tcpserver', $pid, undef, undef, undef) + if substr($pid, 0, 10) eq 'tcpserver:'; # lines seen about once per connection - return ( 'init', $pid, undef, undef, $message ) if substr($message, 0, 19) eq 'Accepted connection'; - return ( 'connect', $pid, undef, undef, substr( $message, 16) ) if substr($message, 0, 15) eq 'Connection from'; - return ( 'close', $pid, undef, undef, $message ) if substr($message, 0, 6) eq 'close '; - return ( 'close', $pid, undef, undef, $message ) if substr($message, 0, 20) eq 'click, disconnecting'; - return parse_line_cleanup( $line ) if substr($message, 0, 11) eq 'cleaning up'; + return ('init', $pid, undef, undef, $message) + if substr($message, 0, 19) eq 'Accepted connection'; + return ('connect', $pid, undef, undef, substr($message, 16)) + if substr($message, 0, 15) eq 'Connection from'; + return ('close', $pid, undef, undef, $message) + if substr($message, 0, 6) eq 'close '; + return ('close', $pid, undef, undef, $message) + if substr($message, 0, 20) eq 'click, disconnecting'; + return parse_line_cleanup($line) + if substr($message, 0, 11) eq 'cleaning up'; # lines seen less than once per connection - return ( 'info', $pid, undef, undef, $message ) if $message eq 'spooling message to disk'; - return ( 'reject', $pid, undef, undef, $message ) if $message =~ /^[4|5]\d\d/; - return ( 'reject', $pid, undef, undef, $message ) if substr($message, 0, 14) eq 'deny mail from'; - return ( 'reject', $pid, undef, undef, $message ) if substr($message, 0, 18) eq 'denysoft mail from'; - return ( 'info', $pid, undef, undef, $message ) if substr($message, 0, 15) eq 'Lost connection'; - return ( 'info', $pid, undef, undef, $message ) if $message eq 'auth success cleared naughty'; - return ( 'info', $pid, undef, undef, $message ) if substr($message, 0, 15) eq 'Running as user'; - return ( 'info', $pid, undef, undef, $message ) if substr($message, 0, 16) eq 'Loaded Qpsmtpd::'; - return ( 'info', $pid, undef, undef, $message ) if substr($message, 0, 24) eq 'Permissions on spool_dir'; - return ( 'info', $pid, undef, undef, $message ) if substr($message, 0, 13) eq 'Listening on '; + return ('info', $pid, undef, undef, $message) + if $message eq 'spooling message to disk'; + return ('reject', $pid, undef, undef, $message) if $message =~ /^[4|5]\d\d/; + return ('reject', $pid, undef, undef, $message) + if substr($message, 0, 14) eq 'deny mail from'; + return ('reject', $pid, undef, undef, $message) + if substr($message, 0, 18) eq 'denysoft mail from'; + return ('info', $pid, undef, undef, $message) + if substr($message, 0, 15) eq 'Lost connection'; + return ('info', $pid, undef, undef, $message) + if $message eq 'auth success cleared naughty'; + return ('info', $pid, undef, undef, $message) + if substr($message, 0, 15) eq 'Running as user'; + return ('info', $pid, undef, undef, $message) + if substr($message, 0, 16) eq 'Loaded Qpsmtpd::'; + return ('info', $pid, undef, undef, $message) + if substr($message, 0, 24) eq 'Permissions on spool_dir'; + return ('info', $pid, undef, undef, $message) + if substr($message, 0, 13) eq 'Listening on '; - return ( 'err', $pid, undef, undef, $message ) if $line =~ /at [\S]+ line \d/; # generic perl error + return ('err', $pid, undef, undef, $message) + if $line =~ /at [\S]+ line \d/; # generic perl error print "UNKNOWN LINE: $line\n"; - return ( 'unknown', $pid, undef, undef, $message ); -}; + return ('unknown', $pid, undef, undef, $message); +} sub parse_line_plugin { my ($line) = @_; - # @tai 13486 (connect) ident::p0f: Windows (XP/2000 (RFC1323+, w, tstamp-)) - # @tai 13681 (connect) dnsbl: fail, NAUGHTY - # @tai 15787 (connect) karma: pass, no penalty (0 naughty, 3 nice, 3 connects) - # @tai 77603 (queue) queue::qmail_2dqueue: (for 77590) Queuing to /var/qmail/bin/qmail-queue - my ($tai, $pid, $hook, $plugin, $message ) = split /\s/, $line, 5; +# @tai 13486 (connect) ident::p0f: Windows (XP/2000 (RFC1323+, w, tstamp-)) +# @tai 13681 (connect) dnsbl: fail, NAUGHTY +# @tai 15787 (connect) karma: pass, no penalty (0 naughty, 3 nice, 3 connects) +# @tai 77603 (queue) queue::qmail_2dqueue: (for 77590) Queuing to /var/qmail/bin/qmail-queue + my ($tai, $pid, $hook, $plugin, $message) = split /\s/, $line, 5; $plugin =~ s/:$//; - if ( $plugin =~ /_3a/ ) { - ($plugin) = split /_3a/, $plugin; # trim :N off the plugin log entry - }; + if ($plugin =~ /_3a/) { + ($plugin) = split /_3a/, $plugin; # trim :N off the plugin log entry + } $plugin =~ s/_2d/-/g; - $plugin = $plugin_aliases{$plugin} if $plugin_aliases{$plugin}; # map alias to master - if ( $hook eq '(queue)' ) { + $plugin = $plugin_aliases{$plugin} + if $plugin_aliases{$plugin}; # map alias to master + if ($hook eq '(queue)') { ($pid) = $message =~ /\(for ([\d]+)\)\s/; $message = 'pass'; - }; + } - return ( 'plugin', $pid, $hook, $plugin, $message ); -}; + return ('plugin', $pid, $hook, $plugin, $message); +} sub parse_line_cleanup { my ($line) = @_; + # @tai 85931 cleaning up after 3210 - my $pid = (split /\s+/, $line)[-1]; + my $pid = (split /\s+/, $line)[-1]; $has_cleanup++; - return ( 'cleanup', $pid, undef, undef, $line ); -}; + return ('cleanup', $pid, undef, undef, $line); +} sub print_auto_format { my ($pid, $line) = @_; @@ -227,52 +255,53 @@ sub print_auto_format { my @headers; my @values; - foreach my $plugin ( qw/ ip hostname distance /, @sorted_plugins ) { - if ( defined $pids{$pid}{$plugin} ) { - if ( ! $seen_plugins{$plugin} ) { # first time seeing this plugin + foreach my $plugin (qw/ ip hostname distance /, @sorted_plugins) { + if (defined $pids{$pid}{$plugin}) { + if (!$seen_plugins{$plugin}) { # first time seeing this plugin $printed = 0; # force header print - }; + } $seen_plugins{$plugin}++; - }; + } - next if ! $seen_plugins{$plugin}; # hide unused plugins - if ( $hide_plugins{$plugin} ) { # user doesn't want to see + next if !$seen_plugins{$plugin}; # hide unused plugins + if ($hide_plugins{$plugin}) { # user doesn't want to see delete $pids{$pid}{$plugin}; next; - }; + } - if ( defined $pids{$pid}{helo_host} && $plugin =~ /helo/ ) { + if (defined $pids{$pid}{helo_host} && $plugin =~ /helo/) { $format .= " %-18.18s"; - push @values, substr( delete $pids{$pid}{helo_host}, -18, 18); + push @values, substr(delete $pids{$pid}{helo_host}, -18, 18); push @headers, 'HELO'; } - elsif ( defined $pids{$pid}{from} && $plugin =~ /from/ ) { + elsif (defined $pids{$pid}{from} && $plugin =~ /from/) { $format .= " %-20.20s"; - push @values, substr( delete $pids{$pid}{from}, -20, 20); + push @values, substr(delete $pids{$pid}{from}, -20, 20); push @headers, 'MAIL FROM'; } - elsif ( defined $pids{$pid}{to} && $plugin =~ /to|rcpt|recipient/ ) { + elsif (defined $pids{$pid}{to} && $plugin =~ /to|rcpt|recipient/) { $format .= " %-20.20s"; - push @values, delete $pids{$pid}{to}; + push @values, delete $pids{$pid}{to}; push @headers, 'RCPT TO'; - }; + } $format .= $formats3{$plugin} ? " $formats3{$plugin}" : " %-10.10s"; - if ( defined $pids{$pid}{$plugin} ) { - push @values, show_symbol( delete $pids{$pid}{$plugin} ); + if (defined $pids{$pid}{$plugin}) { + push @values, show_symbol(delete $pids{$pid}{$plugin}); } else { push @values, ''; - }; - push @headers, ($plugins{$plugin}{abb3} ? $plugins{$plugin}{abb3} : $plugin); + } + push @headers, + ($plugins{$plugin}{abb3} ? $plugins{$plugin}{abb3} : $plugin); } $format .= "\n"; - printf( "\n$format", @headers ) if ( ! $printed || $printed % 20 == 0 ); - printf( $format, @values ); - print Data::Dumper::Dumper( $pids{$pid} ) if keys %{$pids{$pid}}; + printf("\n$format", @headers) if (!$printed || $printed % 20 == 0); + printf($format, @values); + print Data::Dumper::Dumper($pids{$pid}) if keys %{$pids{$pid}}; $printed++; -}; +} sub show_symbol { my $mess = shift; @@ -288,46 +317,46 @@ sub show_symbol { return ' !' if $mess =~ /^error[,:\s]/i; $mess =~ s/\s\s/ /g; return $mess; -}; +} sub get_qp_dir { - foreach my $user ( qw/ qpsmtpd smtpd / ) { - my ($homedir) = (getpwnam( $user ))[7] or next; + foreach my $user (qw/ qpsmtpd smtpd /) { + my ($homedir) = (getpwnam($user))[7] or next; - if ( -d "$homedir/plugins" ) { + if (-d "$homedir/plugins") { return "$homedir"; - }; - foreach my $s ( qw/ smtpd qpsmtpd qpsmtpd-dev / ) { - if ( -d "$homedir/$s/plugins" ) { + } + foreach my $s (qw/ smtpd qpsmtpd qpsmtpd-dev /) { + if (-d "$homedir/$s/plugins") { return "$homedir/$s"; - }; - }; - }; - if ( -d "./plugins" ) { + } + } + } + if (-d "./plugins") { return Cwd::getcwd(); - }; -}; + } +} sub populate_plugins_from_registry { my $file = "$qpdir/plugins/registry.txt"; - if ( ! -f $file ) { + if (!-f $file) { die "unable to find plugin registry\n"; - }; + } open my $F, '<', $file; - while ( defined ( my $line = <$F> ) ) { - next if $line =~ /^#/; # discard comments + while (defined(my $line = <$F>)) { + next if $line =~ /^#/; # discard comments my ($id, $name, $abb3, $abb5, $aliases) = split /\s+/, $line; - next if ! defined $name; - $plugins{$name} = { id=>$id, abb3=>$abb3, abb5=>$abb5 }; + next if !defined $name; + $plugins{$name} = {id => $id, abb3 => $abb3, abb5 => $abb5}; - next if ! $aliases; + next if !$aliases; $aliases =~ s/\s+//g; $plugins{$name}{aliases} = $aliases; - foreach my $a ( split /,/, $aliases ) { + foreach my $a (split /,/, $aliases) { $plugin_aliases{$a} = $name; - }; - }; -}; + } + } +} diff --git a/log/watch b/log/watch index 6ba3cdd..3e8c398 100755 --- a/log/watch +++ b/log/watch @@ -3,7 +3,7 @@ use strict; use warnings; -$|++; # OUTPUT_AUTOFLUSH +$|++; # OUTPUT_AUTOFLUSH use Cwd; use Data::Dumper; @@ -11,28 +11,34 @@ use File::Tail; my $dir = get_qp_dir() or die "unable to find QP home dir"; my $file = "$dir/log/main/current"; -my $fh = File::Tail->new(name=>$file, interval=>1, maxinterval=>1, debug =>1, tail =>300 ); +my $fh = File::Tail->new( + name => $file, + interval => 1, + maxinterval => 1, + debug => 1, + tail => 300 + ); -while ( defined (my $line = $fh->read) ) { - my (undef, $line) = split /\s/, $line, 2; # strip off tai timestamps +while (defined(my $line = $fh->read)) { + my (undef, $line) = split /\s/, $line, 2; # strip off tai timestamps print $line; -}; +} sub get_qp_dir { - foreach my $user ( qw/ qpsmtpd smtpd / ) { - my ($homedir) = (getpwnam( $user ))[7] or next; + foreach my $user (qw/ qpsmtpd smtpd /) { + my ($homedir) = (getpwnam($user))[7] or next; - if ( -d "$homedir/plugins" ) { + if (-d "$homedir/plugins") { return "$homedir"; - }; - foreach my $s ( qw/ smtpd qpsmtpd qpsmtpd-dev / ) { - if ( -d "$homedir/$s/plugins" ) { + } + foreach my $s (qw/ smtpd qpsmtpd qpsmtpd-dev /) { + if (-d "$homedir/$s/plugins") { return "$homedir/$s"; - }; - }; - }; - if ( -d "./plugins" ) { + } + } + } + if (-d "./plugins") { return Cwd::getcwd(); - }; -}; + } +} From b59000cece9563f37a331d03f6d71d124838a3ce Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sun, 21 Apr 2013 02:49:39 -0400 Subject: [PATCH 263/352] dmarc: added relaxed alignment tests --- plugins/dmarc | 170 ++++++++++++++++++++++++++++++-------------------- 1 file changed, 103 insertions(+), 67 deletions(-) diff --git a/plugins/dmarc b/plugins/dmarc index b3896d3..d3f6704 100644 --- a/plugins/dmarc +++ b/plugins/dmarc @@ -38,9 +38,7 @@ See Section 10 of the draft: Domain Owner Actions rf=afrf; (report format: afrf, iodef) ri=8400; (report interval) pct=50; (percent of messages to filter) - -=head2 =head1 DRAFT @@ -48,8 +46,6 @@ http://www.dmarc.org/draft-dmarc-base-00-02.txt =head1 TODO - 1. run dmarc before SPF, if DMARC policy is discovered, ignore SPF - 2. provide dmarc feedback to domains that request it 3. If a message has multiple 'From' recipients, reject it @@ -58,7 +54,7 @@ http://www.dmarc.org/draft-dmarc-base-00-02.txt =head1 IMPLEMENTATION -1. Primary identifier is RFC5322.From field +1. Primary identifier is RFC5322.From field (From: header) 2. Senders can specify strict or relaxed mode @@ -72,29 +68,6 @@ http://www.dmarc.org/draft-dmarc-base-00-02.txt RFC5322.From purports to be from a domain that appears to be either non-existent or incapable of receiving mail. -=head2 Reports should include - -The report SHOULD include the following data: - - o Enough information for the report consumer to re-calculate DMARC - disposition based on the published policy, message dispositon, and - SPF, DKIM, and identifier alignment results. {R12} - - o Data for each sender subdomain separately from mail from the - sender's organizational domain, even if no subdomain policy is - applied. {R13} - - o Sending and receiving domains {R17} - - o The policy requested by the Domain Owner and the policy actually - applied (if different) {R18} - - o The number of successful authentications {R19} - - o The counts of messages based on all messages received even if - their delivery is ultimately blocked by other filtering agents - {R20} - =cut use strict; @@ -123,15 +96,13 @@ sub data_post_handler { # 11.1. Extract Author Domain -# TODO: check exists_in_dns result, and possibly reject here if domain non-exist my $from_host = $self->get_from_host($transaction) or return DECLINED; - if (!$self->exists_in_dns($from_host)) { - my $org_host = $self->get_organizational_domain($from_host); - if (!$self->exists_in_dns($org_host)) { - $self->log(LOGINFO, "fail, domain/org not in DNS"); + my $org_host = $self->get_organizational_domain($from_host); - #return $self->get_reject(); - return DECLINED; + if (!$self->exists_in_dns($from_host)) { + if (!$self->exists_in_dns($org_host)) { + $self->log(LOGINFO, "fail, $from_host not in DNS"); + return $self->get_reject("RFC5322.From host does not exist"); } } @@ -140,18 +111,30 @@ sub data_post_handler { or return DECLINED; # 3. Perform DKIM signature verification checks. A single email may - # contain multiple DKIM signatures. The results of this step are - # passed to the remainder of the algorithm and MUST include the - # value of the "d=" tag from all DKIM signatures that successfully - # validated. - my $dkim_sigs = $self->connection->notes('dkim_pass_domains') || []; + # contain multiple DKIM signatures. The results MUST include the + # value of the "d=" tag from all DKIM signatures that validated. + #my $dkim_sigs = $self->connection->notes('dkim_pass_domains') || []; - # 4. Perform SPF validation checks. The results of this step are - # passed to the remainder of the algorithm and MUST include the - # domain name from the RFC5321.MailFrom if SPF evaluation returned - # a "pass" result. + # 4. Perform SPF validation checks. The results of this step + # MUST include the domain name from the RFC5321.MailFrom if SPF + # evaluation returned a "pass" result. my $spf_dom = $transaction->notes('spf_pass_host'); + # 5. Conduct identifier alignment checks. + return DECLINED + if $self->is_aligned($from_host, $org_host, $policy, $spf_dom ); + + # 6. Apply policy. Emails that fail the DMARC mechanism check are + # disposed of in accordance with the discovered DMARC policy of the + # Domain Owner. See Section 6.2 for details. + return DECLINED if lc $policy->{p} eq 'none'; + + return $self->get_reject("failed DMARC policy"); +} + +sub is_aligned { + my ($self, $from_host, $org_host, $policy, $spf_dom) = @_; + # 5. Conduct identifier alignment checks. With authentication checks # and policy discovery performed, the Mail Receiver checks if # Authenticated Identifiers fall into alignment as decribed in @@ -160,34 +143,43 @@ sub data_post_handler { # the DMARC mechanism check. All other conditions (authentication # failures, identifier mismatches) are considered to be DMARC # mechanism check failures. + + my $dkim_sigs = $self->connection->notes('dkim_pass_domains') || []; foreach (@$dkim_sigs) { - if ($_ eq $from_host) { # strict alignment - $self->log(LOGINFO, "pass, DKIM alignment"); - $self->adjust_karma(2); # big karma boost - return DECLINED; + if ($_ eq $from_host) { # strict alignment + $self->log(LOGINFO, "pass, DKIM aligned"); + $self->adjust_karma(1); + return 1; } + next if $policy->{adkim} && lc $policy->{adkim} eq 's'; # strict pol. + # default policy is relaxed + if ( $_ eq $org_host ) { + $self->log(LOGINFO, "pass, DKIM aligned, relaxed"); + $self->adjust_karma(1); + return 1; + }; } - if ($spf_dom && $spf_dom eq $from_host) { - $self->adjust_karma(2); # big karma boost - $self->log(LOGINFO, "pass, SPF alignment"); - return DECLINED; + return 0 if ! $spf_dom; + if ($spf_dom eq $from_host) { + $self->adjust_karma(1); + $self->log(LOGINFO, "pass, SPF aligned"); + return 1; + } + return 0 if ($policy->{aspf} && lc $policy->{aspf} eq 's' ); # strict pol + if ($spf_dom eq $org_host) { + $self->adjust_karma(1); + $self->log(LOGINFO, "pass, SPF aligned, relaxed"); + return 1; } - # 6. Apply policy. Emails that fail the DMARC mechanism check are - # disposed of in accordance with the discovered DMARC policy of the - # Domain Owner. See Section 6.2 for details. - - $self->log(LOGINFO, "skip, NEED RELAXED alignment"); - return DECLINED; -} + return 0; +}; sub discover_policy { my ($self, $from_host) = @_; - # 1. Mail Receivers MUST query the DNS for a DMARC TXT record at the - # DNS domain matching the one found in the RFC5322.From domain in - # the message. A possibly empty set of records is returned. + # 1. Mail Receivers MUST query the DNS for a DMARC TXT record... my @matches = $self->fetch_dmarc_record($from_host); # 2. within if (0 == scalar @matches) { @@ -304,29 +296,45 @@ sub get_organizational_domain { sub exists_in_dns { my ($self, $domain) = @_; +# the DMARC draft suggests rejecting messages whose From: domain does not +# exist in DNS. That's as far as it goes. So I went back to the ADSP (from +# where DMARC this originated, which in turn led me to the ietf-dkim email +# list where a handful of 'experts' failed to agree on The Right Way to +# perform this test. And thus no direction was given. +# As they point out: +# MX records aren't mandatory. +# A or AAAA records as fallback aren't reliable either. + +# I chose to query the name and match NS,MX,A,or AAAA records. Since it gets +# repeated for the for the Organizational Name, if it fails, there's no +# delegation from the TLD. my $res = $self->init_resolver(); - my $query = $res->send($domain, 'NS') or do { + my $query = $res->send($domain) or do { if ($res->errorstring eq 'NXDOMAIN') { $self->log(LOGDEBUG, "fail, non-existent domain: $domain"); return; } - $self->log(LOGINFO, - "error, looking up NS for $domain: " . $res->errorstring); + $self->log(LOGINFO, "error, looking up $domain: " . $res->errorstring); return; }; my @matches; for my $rr ($query->answer) { - next if $rr->type ne 'NS'; + next if $rr->type !~ /(?:NS|MX|A|AAAA)/; push @matches, $rr->nsdname; } if (0 == scalar @matches) { - $self->log(LOGDEBUG, "fail, zero NS for $domain"); + $self->log(LOGDEBUG, "fail, no records for $domain"); } return @matches; } sub fetch_dmarc_record { my ($self, $zone) = @_; + + # 1. Mail Receivers MUST query the DNS for a DMARC TXT record at the + # DNS domain matching the one found in the RFC5322.From domain in + # the message. A possibly empty set of records is returned. + my $res = $self->init_resolver(); my $query = $res->send('_dmarc.' . $zone, 'TXT'); my @matches; @@ -366,6 +374,34 @@ sub parse_policy { return %dmarc; } +sub external_report { + +=pod + +The report SHOULD include the following data: + + o Enough information for the report consumer to re-calculate DMARC + disposition based on the published policy, message dispositon, and + SPF, DKIM, and identifier alignment results. {R12} + + o Data for each sender subdomain separately from mail from the + sender's organizational domain, even if no subdomain policy is + applied. {R13} + + o Sending and receiving domains {R17} + + o The policy requested by the Domain Owner and the policy actually + applied (if different) {R18} + + o The number of successful authentications {R19} + + o The counts of messages based on all messages received even if + their delivery is ultimately blocked by other filtering agents {R20} + +=cut + +}; + sub verify_external_reporting { =head2 Verify External Destinations From 8122fcfb27626a56b8e084572342a30f3a23eea9 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sun, 21 Apr 2013 12:14:27 -0400 Subject: [PATCH 264/352] Plugin: override dns_timeout by passing in a value --- lib/Qpsmtpd/Plugin.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm index d4be038..2d3537e 100644 --- a/lib/Qpsmtpd/Plugin.pm +++ b/lib/Qpsmtpd/Plugin.pm @@ -273,10 +273,10 @@ sub store_deferred_reject { sub init_resolver { my $self = shift; + my $timeout = $self->{_args}{dns_timeout} || shift || 5; 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}{dns_timeout} || 5; $self->{_resolver}->tcp_timeout($timeout); $self->{_resolver}->udp_timeout($timeout); return $self->{_resolver}; From 278399f1ad17c52bee28c6b69325281b45bbfef7 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sun, 21 Apr 2013 12:15:14 -0400 Subject: [PATCH 265/352] dkim: when signing, use signing domain when we finding the signing key in a different directory than the sending (eg: example.com instead of www.example.com.) --- plugins/dkim | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/plugins/dkim b/plugins/dkim index 39c6759..dbef7a7 100644 --- a/plugins/dkim +++ b/plugins/dkim @@ -418,7 +418,8 @@ sub get_keydir { shift @labels; # remove the first label (ie: www) my $zone = join '.', @labels; # reassemble the labels if (-e "config/dkim/$zone") { # if the directory exists - $dir = "config/dkim/$zone"; # use the parent domain's key + $domain = $zone; # the DKIM signing domain + $dir = "config/dkim/$zone"; # use the parent domain's key $self->log(LOGINFO, "info, using $zone key for $domain"); } } @@ -451,6 +452,7 @@ sub save_signatures_to_note { foreach my $sig ($dkim->signatures) { next if $sig->result ne 'pass'; my $doms = $self->connection->notes('dkim_pass_domains') || []; + next if grep /$sig->domain/, @$doms; # already in the list push @$doms, $sig->domain; $self->connection->notes('dkim_pass_domains', $doms); $self->log(LOGINFO, "info, added " . $sig->domain); @@ -515,7 +517,7 @@ sub get_selector { my $selector = <$SFH>; chomp $selector; close $SFH; - $self->log(LOGINFO, "info, selector: $selector"); + $self->log(LOGDEBUG, "info, selector: $selector"); return $selector; } From 8f834d5df2a5b3f95959cf429b8cd628b5302e92 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sun, 21 Apr 2013 12:17:49 -0400 Subject: [PATCH 266/352] dmarc: weed out SPF records from initial search use a variable instead of array to count list (not using RR address after all) --- plugins/dmarc | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/plugins/dmarc b/plugins/dmarc index d3f6704..95b0320 100644 --- a/plugins/dmarc +++ b/plugins/dmarc @@ -195,7 +195,6 @@ sub discover_policy { return; } @matches = $self->fetch_dmarc_record($org_dom); - if (0 == scalar @matches) { $self->log(LOGINFO, "skip, no policy for $from_host"); return; @@ -308,8 +307,8 @@ sub exists_in_dns { # I chose to query the name and match NS,MX,A,or AAAA records. Since it gets # repeated for the for the Organizational Name, if it fails, there's no # delegation from the TLD. - my $res = $self->init_resolver(); - my $query = $res->send($domain) or do { + my $res = $self->init_resolver(8); + my $query = $res->query($domain, 'NS') or do { if ($res->errorstring eq 'NXDOMAIN') { $self->log(LOGDEBUG, "fail, non-existent domain: $domain"); return; @@ -317,15 +316,15 @@ sub exists_in_dns { $self->log(LOGINFO, "error, looking up $domain: " . $res->errorstring); return; }; - my @matches; + my $matches = 0; for my $rr ($query->answer) { next if $rr->type !~ /(?:NS|MX|A|AAAA)/; - push @matches, $rr->nsdname; + $matches++; } - if (0 == scalar @matches) { + if (0 == $matches) { $self->log(LOGDEBUG, "fail, no records for $domain"); } - return @matches; + return $matches; } sub fetch_dmarc_record { @@ -344,6 +343,7 @@ sub fetch_dmarc_record { # 2. Records that do not start with a "v=" tag that identifies the # current version of DMARC are discarded. next if 'v=' ne substr($rr->txtdata, 0, 2); + next if 'v=spf' eq substr($rr->txtdata, 0, 5); # commonly found $self->log(LOGINFO, $rr->txtdata); push @matches, join('', $rr->txtdata); } From b7ce45a5020bcc0e2ffe6c73e63036a04c73f5d9 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sun, 21 Apr 2013 16:06:37 -0400 Subject: [PATCH 267/352] moved tls plugin to the top of the config it must be listed before other connection plugins for port 465 place it up there just in case --- config.sample/plugins | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/config.sample/plugins b/config.sample/plugins index e59bcae..bb15895 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -6,6 +6,10 @@ # plugins/http_config for details. # http_config http://localhost/~smtpd/config/ http://www.example.com/smtp.pl?config= +# tls should load before count_unrecognized_commands +# to support legacy port 465, tls must load before connection plugins +#tls + # hosts_allow does not work with the tcpserver deployment model! # perldoc plugins/hosts_allow for an alternative. # @@ -23,8 +27,6 @@ ident/geoip fcrdns quit_fortune -# tls should load before count_unrecognized_commands -#tls earlytalker count_unrecognized_commands 4 From 7d88c51e0a980a3daf0d3e85cf9a47cdc49ee711 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sun, 21 Apr 2013 17:02:34 -0400 Subject: [PATCH 268/352] auth_chkpw: added pass|fail prefix to log msgs --- plugins/auth/auth_checkpassword | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/plugins/auth/auth_checkpassword b/plugins/auth/auth_checkpassword index cb84758..a20fb71 100644 --- a/plugins/auth/auth_checkpassword +++ b/plugins/auth/auth_checkpassword @@ -136,11 +136,12 @@ sub auth_checkpassword { my $status = $?; if ($status != 0) { - $self->log(LOGNOTICE, "authentication failed ($status)"); + $self->log(LOGNOTICE, "fail, auth failed: $status"); return (DECLINED); } $self->connection->notes('authuser', $user); + $self->log(LOGINFO, "pass, auth success with $method"); return (OK, "auth_checkpassword"); } From 71997439c147c2d7dcc363c9a278a1897d4d9765 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sun, 21 Apr 2013 17:03:24 -0400 Subject: [PATCH 269/352] tls: added pass|fail prefix to a couple log msgs --- plugins/tls | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/plugins/tls b/plugins/tls index 533c5df..4aceaad 100644 --- a/plugins/tls +++ b/plugins/tls @@ -149,12 +149,16 @@ sub hook_connect { my ($self, $transaction) = @_; my $local_port = $self->qp->connection->local_port; - return DECLINED unless defined $local_port && $local_port == 465; # SMTPS + if ( ! defined $local_port || $local_port != 465 ) { # SMTPS + $self->log(LOGDEBUG, "skip, not SMTPS"); + return DECLINED; + }; unless (_convert_to_ssl($self)) { + $self->log(LOGINFO, "fail, unable to establish SSL"); return (DENY_DISCONNECT, "Cannot establish SSL session"); } - $self->log(LOGWARN, "Connected via SMTPS"); + $self->log(LOGINFO, "pass, connect via SMTPS"); return DECLINED; } From f1aa848166d94313ea84c761f9cae14d72834241 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sun, 21 Apr 2013 19:54:06 -0400 Subject: [PATCH 270/352] dkim: reduce INFO logging to once per connect --- plugins/dkim | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/plugins/dkim b/plugins/dkim index dbef7a7..13815a1 100644 --- a/plugins/dkim +++ b/plugins/dkim @@ -353,7 +353,7 @@ sub handle_sig_pass { elsif ($prs->{neutral}) { $self->add_header($mess); $self->log(LOGINFO, "pass, valid signature, neutral policy"); - $self->log(LOGINFO, $mess); + $self->log(LOGDEBUG, $mess); return DECLINED; } elsif ($prs->{reject}) { @@ -364,7 +364,7 @@ sub handle_sig_pass { "fail, valid sig, reject policy"); } - # this should never happen + # this should never happen, $self->add_header($mess); $self->log(LOGERROR, "pass, valid sig, no policy results"); $self->log(LOGINFO, $mess); @@ -449,14 +449,17 @@ sub get_keydir { sub save_signatures_to_note { my ($self, $dkim) = @_; + my %domains; foreach my $sig ($dkim->signatures) { next if $sig->result ne 'pass'; - my $doms = $self->connection->notes('dkim_pass_domains') || []; - next if grep /$sig->domain/, @$doms; # already in the list - push @$doms, $sig->domain; - $self->connection->notes('dkim_pass_domains', $doms); - $self->log(LOGINFO, "info, added " . $sig->domain); + $domains{$sig->domain} = 1; } + return if 0 == scalar keys %domains; + + my $doms = $self->connection->notes('dkim_pass_domains') || []; + push @$doms, keys %domains; + $self->log(LOGDEBUG, "info, signed by: ". join(',', keys %domains) ); + $self->connection->notes('dkim_pass_domains', $doms); } sub send_message_to_dkim { From 8b95e9053d1e69b6c29e62696c483302e04e5c56 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sun, 21 Apr 2013 20:33:46 -0400 Subject: [PATCH 271/352] Makefile.PL: gzip -9, and clean up test db and a perltidy --- Makefile.PL | 40 ++++++++++++++++++++++------------------ 1 file changed, 22 insertions(+), 18 deletions(-) diff --git a/Makefile.PL b/Makefile.PL index 3a40c1b..39d9104 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -4,21 +4,25 @@ 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)], + 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)], + dist => {COMPRESS => 'gzip -9f',}, + clean => { + FILES => ['t/config/greylist.dbm*',], + }, ); sub MY::libscan { @@ -28,11 +32,11 @@ sub MY::libscan { } sub MY::postamble { - qq[ + qq[ testcover : \t cover -delete && \\ - HARNESS_PERL_SWITCHES=-MDevel::Cover \$(MAKE) test && \\ - cover + HARNESS_PERL_SWITCHES=-MDevel::Cover \$(MAKE) test && \\ + cover ] } From 78ac01df760f23e88f70fb44b67c8642b7d2d7e6 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 22 Apr 2013 02:12:53 -0400 Subject: [PATCH 272/352] log2sql: populate plugins table from registry.txt much easier for local customizations. moved SQL connection settings to config/log2sql --- config.sample/log2sql | 4 ++ log/log2sql | 74 ++++++++++++++++++--- log/log2sql.sql | 146 ++++++++---------------------------------- plugins/registry.txt | 29 +++++---- 4 files changed, 113 insertions(+), 140 deletions(-) create mode 100644 config.sample/log2sql diff --git a/config.sample/log2sql b/config.sample/log2sql new file mode 100644 index 0000000..5b02654 --- /dev/null +++ b/config.sample/log2sql @@ -0,0 +1,4 @@ +# comments are allowed +dsn = DBI:mysql:database=qpsmtpd;host=db;port=3306 +user = qplog +pass = can mysql have 6 spaces in a passphrase? diff --git a/log/log2sql b/log/log2sql index fa8010e..89bb1f1 100755 --- a/log/log2sql +++ b/log/log2sql @@ -6,21 +6,19 @@ use warnings; use Cwd; use Data::Dumper; use DBIx::Simple; +use IO::File; use File::stat; use Time::TAI64 qw/ tai2unix /; $Data::Dumper::Sortkeys = 1; -my $dsn = 'DBI:mysql:database=qpsmtpd;host=db;port=3306'; -my $user = 'qplog'; -my $pass = 't0ps3cret'; - my $logdir = get_log_dir(); my @logfiles = get_logfiles($logdir); my (%plugins, %os, %message_ids); my $has_cleanup; my $db = get_db(); +check_plugins_table(); foreach my $file (@logfiles) { my ($fid, $offset) = check_logfile($file); @@ -208,6 +206,7 @@ sub parse_logfile { #warn "type: $type\n"; if ($type eq 'plugin') { next if $plugin eq 'naughty'; # housekeeping only + next if $plugin eq 'karma' && 'karma adjust' eq substr($message,0,12); insert_plugin($msg_id, $plugin, $message); } elsif ($type eq 'queue') { @@ -529,12 +528,70 @@ sub get_score { sub get_db { - my $db = DBIx::Simple->connect($dsn, $user, $pass) + my %dbv = get_config('log2sql'); + + $dbv{dsn} ||= 'DBI:mysql:database=qpsmtpd;host=db;port=3306'; + $dbv{user} ||= 'qplog'; + $dbv{pass} ||= 't0ps3cret'; + + print Dumper(\%dbv); + my $db = DBIx::Simple->connect($dbv{dsn}, $dbv{user}, $dbv{pass}) or die DBIx::Simple->error; return $db; } +sub get_config { + my $file = shift or die "missing file name\n"; + my %values; + foreach my $line ( get_config_contents( $file ) ) { + next if $line =~ /^#/; + chomp $line; + my ($key,$val) = split /\s*=\s*/, $line, 2; + $values{$key} = $val; + }; + return %values; +}; + +sub get_config_contents { + my $name = shift; + + my @config_dirs = qw[ config ../config log plugins ]; + foreach my $dir ( @config_dirs ) { + next if ! -f "$dir/$name"; + + my $fh = IO::File->new(); + if ( ! $fh->open( "$dir/$name", '<' ) ) { + warn "unable to open config file $dir/$name\n"; + next; + }; + my @contents = <$fh>; + return @contents; + }; +}; + +sub check_plugins_table { + my $rows = exec_query( 'SELECT COUNT(*) FROM plugin'); + return if scalar @$rows != 0; + my @lines = get_config_contents('registry.txt'); + foreach my $line ( @lines ) { + next if $line =~ /^\s*#/; # ignore comments + chomp $line; + next if ! $line; + my ($id, $name, $abb3, $abb5, $aliases) = split /\s+/, $line, 5; + my $q = "REPLACE INTO plugin (id,name,abb3,abb5) VALUES (??)"; + print "query: $q, $id, $name, $abb3, $abb5\n"; + exec_query($q, [$id, $name, $abb3, $abb5 ]); + next if ! $aliases; + foreach my $alias ( split /\s*,\s*/, $aliases ) { + next if ! $alias; + my $aq = "REPLACE INTO plugin_aliases (plugin_id,name) VALUES (??)"; + print "aqury: $aq, $id, $alias\n"; + exec_query($aq, [$id, $alias]); + }; + }; +}; + sub exec_query { my $query = shift; my $params = shift; @@ -550,10 +607,11 @@ sub exec_query { } #warn "err: $err\n"; - if ($query =~ /INSERT INTO/) { - my ($table) = $query =~ /INSERT INTO (\w+)\s/; + if ($query =~ /(?:REPLACE|INSERT) INTO/) { + my ($table) = $query =~ /(?:REPLACE|INSERT) INTO (\w+)\s/; $db->query($query, @params); - die "$db->error\n$err" if $db->error ne 'DBI error: '; + warn "$db->error\n$err" if $db->error ne 'DBI error: '; + return if $query =~ /^REPLACE/; my $id = $db->last_insert_id(undef, undef, $table, undef) or die $err; return $id; } diff --git a/log/log2sql.sql b/log/log2sql.sql index 4f975eb..0c06f35 100644 --- a/log/log2sql.sql +++ b/log/log2sql.sql @@ -13,35 +13,34 @@ DROP TABLE IF EXISTS `log`; CREATE TABLE `log` ( - `id` int(11) unsigned NOT NULL auto_increment, + `id` int(11) unsigned NOT NULL AUTO_INCREMENT, `inode` int(11) unsigned NOT NULL, `size` int(11) unsigned NOT NULL, - `name` varchar(30) NOT NULL default '', - `created` datetime default NULL, - PRIMARY KEY (`id`) + `name` varchar(30) NOT NULL DEFAULT '', + `created` datetime DEFAULT NULL, + PRIMARY KEY (`id`) ) ENGINE=InnoDB DEFAULT CHARSET=utf8; - # Dump of table message # ------------------------------------------------------------ DROP TABLE IF EXISTS `message`; CREATE TABLE `message` ( - `id` int(11) unsigned NOT NULL auto_increment, + `id` int(11) unsigned NOT NULL AUTO_INCREMENT, `file_id` int(10) unsigned NOT NULL, `connect_start` datetime NOT NULL, `ip` int(10) unsigned NOT NULL, `qp_pid` int(10) unsigned NOT NULL, - `result` tinyint(3) NOT NULL default '0', - `distance` mediumint(8) unsigned default NULL, - `time` decimal(3,2) unsigned default NULL, - `os_id` tinyint(3) unsigned default NULL, - `hostname` varchar(128) default NULL, - `helo` varchar(128) default NULL, - `mail_from` varchar(128) default NULL, - `rcpt_to` varchar(128) default NULL, - PRIMARY KEY (`id`), + `result` tinyint(3) NOT NULL DEFAULT '0', + `distance` mediumint(8) unsigned DEFAULT NULL, + `time` decimal(3,2) unsigned DEFAULT NULL, + `os_id` tinyint(3) unsigned DEFAULT NULL, + `hostname` varchar(128) DEFAULT NULL, + `helo` varchar(128) DEFAULT NULL, + `mail_from` varchar(128) DEFAULT NULL, + `rcpt_to` varchar(128) DEFAULT NULL, + PRIMARY KEY (`id`), KEY `file_id` (`file_id`), CONSTRAINT `message_ibfk_1` FOREIGN KEY (`file_id`) REFERENCES `log` (`id`) ON DELETE CASCADE ON UPDATE CASCADE ) ENGINE=InnoDB DEFAULT CHARSET=utf8; @@ -54,12 +53,12 @@ CREATE TABLE `message` ( DROP TABLE IF EXISTS `message_plugin`; CREATE TABLE `message_plugin` ( - `id` int(11) unsigned NOT NULL auto_increment, + `id` int(11) unsigned NOT NULL AUTO_INCREMENT, `msg_id` int(11) unsigned NOT NULL, `plugin_id` int(4) unsigned NOT NULL, `result` tinyint(4) NOT NULL, - `string` varchar(128) default NULL, - PRIMARY KEY (`id`), + `string` varchar(128) DEFAULT NULL, + PRIMARY KEY (`id`), KEY `msg_id` (`msg_id`), KEY `plugin_id` (`plugin_id`), CONSTRAINT `message_plugin_ibfk_1` FOREIGN KEY (`plugin_id`) REFERENCES `plugin` (`id`) ON DELETE CASCADE ON UPDATE CASCADE, @@ -67,16 +66,15 @@ CREATE TABLE `message_plugin` ( ) ENGINE=InnoDB DEFAULT CHARSET=utf8; - # Dump of table os # ------------------------------------------------------------ DROP TABLE IF EXISTS `os`; CREATE TABLE `os` ( - `id` tinyint(3) unsigned NOT NULL auto_increment, - `name` varchar(36) default NULL, - PRIMARY KEY (`id`) + `id` tinyint(3) unsigned NOT NULL AUTO_INCREMENT, + `name` varchar(36) DEFAULT NULL, + PRIMARY KEY (`id`) ) ENGINE=InnoDB DEFAULT CHARSET=utf8; LOCK TABLES `os` WRITE; @@ -114,81 +112,14 @@ UNLOCK TABLES; DROP TABLE IF EXISTS `plugin`; CREATE TABLE `plugin` ( - `id` int(4) unsigned NOT NULL auto_increment, - `name` varchar(35) character set utf8 NOT NULL default '', - `abb3` char(3) character set utf8 default NULL, - `abb5` char(5) character set utf8 default NULL, - PRIMARY KEY (`id`), - UNIQUE KEY `abb3` (`abb3`), + `id` int(4) unsigned NOT NULL AUTO_INCREMENT, + `name` varchar(35) CHARACTER SET utf8 NOT NULL DEFAULT '', + `abb3` char(3) CHARACTER SET utf8 DEFAULT NULL, + `abb5` char(5) CHARACTER SET utf8 DEFAULT NULL, + PRIMARY KEY (`id`), UNIQUE KEY `abb5` (`abb5`) ) ENGINE=InnoDB DEFAULT CHARSET=utf8 COLLATE=utf8_bin; -LOCK TABLES `plugin` WRITE; -/*!40000 ALTER TABLE `plugin` DISABLE KEYS */; - -INSERT INTO `plugin` (`id`, `name`, `abb3`, `abb5`) -VALUES - (1,'hosts_allow','alw','allow'), - (2,'ident::geoip','geo','geoip'), - (3,'ident::p0f','p0f',' p0f'), - (5,'karma','krm','karma'), - (6,'dnsbl','dbl','dnsbl'), - (7,'relay','rly','relay'), - (9,'earlytalker','ear','early'), - (15,'helo','hlo','helo'), - (16,'tls','tls',' tls'), - (20,'dont_require_anglebrackets','rab','drabs'), - (21,'unrecognized_commands','cmd','uncmd'), - (22,'noop','nop','noop'), - (23,'random_error','rnd','rande'), - (24,'milter','mtr','mlter'), - (25,'content_log','log','colog'), - (30,'auth::vpopmail_sql','aut','vpsql'), - (31,'auth::vpopmaild','vpd','vpopd'), - (32,'auth::vpopmail','vpo','vpop'), - (33,'auth::checkpasswd','ckp','chkpw'), - (34,'auth::cvs_unix_local','cvs','cvsul'), - (35,'auth::flat_file','flt','aflat'), - (36,'auth::ldap_bind','ldp','aldap'), - (40,'badmailfrom','bmf','badmf'), - (41,'badmailfromto','bmt','bfrto'), - (42,'rhsbl','rbl','rhsbl'), - (44,'resolvable_fromhost','rfh','rsvfh'), - (45,'sender_permitted_from','spf',' spf'), - (50,'badrcptto','bto','badto'), - (51,'rcpt_map','rmp','rcmap'), - (52,'rcpt_regex','rcx','rcrex'), - (53,'qmail_deliverable','qmd',' qmd'), - (55,'rcpt_ok','rok','rcpok'), - (58,'bogus_bounce','bog','bogus'), - (59,'greylisting','gry','greyl'), - (60,'headers','hdr','headr'), - (61,'loop','lop','loop'), - (62,'uribl','uri','uribl'), - (63,'domainkeys','dk','dkey'), - (64,'dkim','dkm','dkim'), - (65,'spamassassin','spm','spama'), - (66,'dspam','dsp','dspam'), - (70,'virus::aveclient','vav','avirs'), - (71,'virus::bitdefender','vbd','bitdf'), - (72,'virus::clamav','cav','clamv'), - (73,'virus::clamdscan','cad','clamd'), - (74,'virus::hbedv','hbv','hbedv'), - (75,'virus::kavscanner','kav','kavsc'), - (76,'virus::klez_filter','klz','vklez'), - (77,'virus::sophie','sop','sophe'), - (78,'virus::uvscan','uvs','uvscn'), - (80,'queue::qmail-queue','qqm','queue'), - (81,'queue::maildir','qdr','qudir'), - (82,'queue::postfix-queue','qpf','qupfx'), - (83,'queue::smtp-forward','qfw','qufwd'), - (84,'queue::exim-bsmtp','qxm','qexim'), - (98,'quit_fortune','for','fortu'), - (99,'connection_time','tim','time'); - -/*!40000 ALTER TABLE `plugin` ENABLE KEYS */; -UNLOCK TABLES; - # Dump of table plugin_aliases # ------------------------------------------------------------ @@ -197,33 +128,10 @@ DROP TABLE IF EXISTS `plugin_aliases`; CREATE TABLE `plugin_aliases` ( `plugin_id` int(11) unsigned NOT NULL, - `name` varchar(35) character set utf8 NOT NULL default '', - KEY `plugin_id` (`plugin_id`), - CONSTRAINT `plugin_id` FOREIGN KEY (`plugin_id`) REFERENCES `plugin` (`id`) ON UPDATE CASCADE + `name` varchar(35) CHARACTER SET utf8 NOT NULL DEFAULT '', + UNIQUE KEY `plugin_id` (`plugin_id`,`name`) ) ENGINE=InnoDB DEFAULT CHARSET=utf8 COLLATE=utf8_bin; -LOCK TABLES `plugin_aliases` WRITE; -/*!40000 ALTER TABLE `plugin_aliases` DISABLE KEYS */; - -INSERT INTO `plugin_aliases` (`plugin_id`, `name`) -VALUES - (60,'check_basicheaders'), - (44,'require_resolvable_fromhost'), - (21,'count_unrecognized_commands'), - (9,'check_earlytalker'), - (40,'check_badmailfrom'), - (50,'check_badrcptto'), - (58,'check_bogus_bounce'), - (15,'check_spamhelo'), - (3,'ident::p0f_3a0'), - (80,'queue::qmail_2dqueue'), - (22,'noop_counter'); - -/*!40000 ALTER TABLE `plugin_aliases` ENABLE KEYS */; -UNLOCK TABLES; - - - /*!40111 SET SQL_NOTES=@OLD_SQL_NOTES */; /*!40101 SET SQL_MODE=@OLD_SQL_MODE */; /*!40014 SET FOREIGN_KEY_CHECKS=@OLD_FOREIGN_KEY_CHECKS */; diff --git a/plugins/registry.txt b/plugins/registry.txt index f02709c..872a239 100644 --- a/plugins/registry.txt +++ b/plugins/registry.txt @@ -1,13 +1,16 @@ # This file contains a list of every plugin used on this server. If you have # additional plugins running, add them here. # Fields are whitespace delimited. Columns are ordered by numeric plugin ID. +# +# the order of plugins in this file determines the order they appear in +# summary output # #id name abb3 abb5 aliases # 201 hosts_allow alw allow 202 ident::geoip geo geoip -203 ident::p0f p0f p0f -204 ident::p0f_3a0 p0f p0f +203 ident::p0f p0f p0f ident::p0f_3a0,ident::p0f_3a1 + 205 karma krm karma 206 dnsbl dbl dnsbl 207 relay rly relay check_relay,check_norelay,relay_only @@ -26,13 +29,13 @@ # # Authentication # -400 auth::auth_vpopmail_sql aut vpsql -401 auth::auth_vpopmaild vpd vpopd -402 auth::auth_vpopmail vpo vpop -403 auth::auth_checkpasswd ckp chkpw -404 auth::auth_cvs_unix_local cvs cvsul -405 auth::auth_flat_file flt aflat -406 auth::auth_ldap_bind ldp aldap +400 auth::auth_vpopmail_sql avq avsql +401 auth::auth_vpopmaild avd vpopd +402 auth::auth_vpopmail avp vpop +403 auth::auth_checkpassword ack chkpw +404 auth::auth_cvs_unix_local acv cvsul +405 auth::auth_flat_file aff aflat +406 auth::auth_ldap_bind ald aldap 407 auth::authdeny dny adeny # # Sender / Envelope From @@ -80,11 +83,11 @@ # # Queue Plugins # -800 queue::qmail-queue qqm queue +800 queue::qmail-queue qqm queue queue::qmail_2dqueue 801 queue::maildir qdr qudir -802 queue::postfix-queue qpf qupfx -803 queue::smtp-forward qfw qufwd -804 queue::exim-bsmtp qxm qexim +802 queue::postfix-queue qpf qupfx queue::postfix_2dqueue +803 queue::smtp-forward qfw qufwd queue::smtp_2dqueue +804 queue::exim-bsmtp qxm qexim queue::exim_2dbsmtp 900 quit_fortune for fortu From f63c029bbb90f850330837e9b60b176694115b52 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 22 Apr 2013 02:29:29 -0400 Subject: [PATCH 273/352] qmail_deliverable: smite null sender to email list --- plugins/karma | 18 ++++++++++++++---- plugins/qmail_deliverable | 6 ++++-- 2 files changed, 18 insertions(+), 6 deletions(-) diff --git a/plugins/karma b/plugins/karma index 8cc91e6..a32ed6a 100644 --- a/plugins/karma +++ b/plugins/karma @@ -328,8 +328,11 @@ sub rcpt_handler { my $recipients = scalar $self->transaction->recipients; return DECLINED if $recipients < 2; # only one recipient - my $karma = $self->connection->notes('karma_history'); - return DECLINED if $karma > 0; # good karma, no limit + my $history = $self->connection->notes('karma_history'); + return DECLINED if $history > 0; # good history, no limit + + my $karma = $self->connection->notes('karma'); + return DECLINED if $karma > 0; # good connection, no limit # limit # of recipients if host has negative or unknown karma return $self->get_reject("too many recipients"); @@ -337,9 +340,16 @@ sub rcpt_handler { sub data_handler { my ($self, $transaction) = @_; - return DECLINED if !$self->qp->connection->relay_client; - $self->adjust_karma(5); # big karma boost for authenticated user/IP + if ( $self->qp->connection->relay_client ) { + $self->adjust_karma(5); # big karma boost for authenticated user/IP + }; + + my $karma = $self->connection->notes('karma'); + if ( $karma < -3 ) { # bad karma + return $self->get_reject("very bad karma: $karma"); + }; + return DECLINED; } diff --git a/plugins/qmail_deliverable b/plugins/qmail_deliverable index 62609f8..2b31756 100644 --- a/plugins/qmail_deliverable +++ b/plugins/qmail_deliverable @@ -201,8 +201,10 @@ sub rcpt_handler { $self->log(LOGINFO, "pass, bouncesaying with program"), $k++ if $rv == 0x13; if ($rv == 0x14) { my $s = $transaction->sender->address; - return (DENY, "mailing lists do not accept null senders") - if (!$s || $s eq '<>'); + if (!$s || $s eq '<>') { + $self->adjust_karma(-1); + return (DENY, "mailing lists do not accept null senders"); + }; $self->log(LOGINFO, "pass, ezmlm list"); $k++; } From 050aa4b0bf8e3a3b26491676ca30aed0fd000cdf Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 22 Apr 2013 16:30:26 -0700 Subject: [PATCH 274/352] docs/logging: corrected example register() syntax --- docs/logging.pod | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docs/logging.pod b/docs/logging.pod index 0066132..63febed 100644 --- a/docs/logging.pod +++ b/docs/logging.pod @@ -86,7 +86,7 @@ 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; + my ( $self, $qp ) = (shift, shift); $self->log(LOGERROR, "Bad arguments") if @_ % 2; $self->{_args} = { @_ }; } From eab1d5e4cfe01ef3d4e5fe8d0563506b31242686 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Tue, 23 Apr 2013 21:11:33 -0700 Subject: [PATCH 275/352] added modules required by several of the plugins and imported bin/install_deps.pl, preparing for a future where QP is almost easy to install --- Makefile.PL | 16 +- bin/install_deps.pl | 400 ++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 412 insertions(+), 4 deletions(-) create mode 100755 bin/install_deps.pl diff --git a/Makefile.PL b/Makefile.PL index 3a40c1b..12e2753 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -7,14 +7,22 @@ WriteMakefile( NAME => 'qpsmtpd', VERSION_FROM => 'lib/Qpsmtpd.pm', PREREQ_PM => { + 'Data::Dumper' => 0, + 'Date::Parse' => 0, + 'File::Temp' => 0, '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, + 'Time::HiRes' => 0, + 'IO::Socket::SSL'=>0, +# modules for specific features + 'Geo::IP' => 0, + 'Mail::DKIM' => 0, + 'Mail::SpamAssassin' => 0, + 'Mail::SPF' => 0, + 'File::Tail' => 0, + 'Time::TAI64' => 0, }, ABSTRACT => 'Flexible smtpd daemon written in Perl', AUTHOR => 'Ask Bjoern Hansen ', diff --git a/bin/install_deps.pl b/bin/install_deps.pl new file mode 100755 index 0000000..ac4609e --- /dev/null +++ b/bin/install_deps.pl @@ -0,0 +1,400 @@ +#!/usr/bin/perl + +# v1.7 - 2013-04-20 - Matt +# - get list of modules from Makefile.PL or dist.ini +# - abstracted yum and apt into subs +# +# v1.6 - 2013-04-01 - Matt +# - improved error reporting for FreeBSD port installs +# +# v1.5 - 2013-03-27 - Matt +# - added option to specify port category +# +# v1.4 - 2012-10-23 - Matt +# - improved yum & apt-get module installer +# +# v1.3 - 2012-10-23 - Matt +# - added apt-get support +# - added app install support +# +# circa 2008, by Matt Simerson & Phil Nadeau +# - based on installer in Mail::Toaster dating back to the 20th century + +use strict; +use warnings; + +use CPAN; +use English qw( -no_match_vars ); + +my $apps = [ + { app => 'expat' , info => { port => 'expat2', dport=>'expat2' } }, + { app => 'gettext' , info => { port => 'gettext', dport=>'gettext'} }, + { app => 'gmake' , info => { port => 'gmake', dport=>'gmake' } }, + { app => 'mysql-server-5', info => { port => 'mysql50-server', dport=>'mysql5', yum =>'mysql-server'} }, + { app => 'apache22' , info => { port => 'apache22', dport=>'', yum => 'httpd' } }, + { app => 'mod_perl2' , info => { port => 'mod_perl2', dport=>'', yum => 'mod_perl' } }, + { app => 'rsync' , info => { }, }, +]; + +$EUID == 0 or die "You will have better luck if you run me as root.\n"; + +my @failed; +foreach ( @$apps ) { + my $name = $_->{app} or die 'missing app name'; + install_app( $name, $_->{info} ); +}; + +foreach ( get_perl_modules() ) { +#print Dumper($_); + my $module = $_->{module} or die 'missing module name'; + my $info = $_->{info}; + my $version = $info->{version} || ''; + print "checking for $module $version\n"; + +## no critic + eval "use $module $version"; + next if ! $EVAL_ERROR; + next if $info->{ships_with} && $info->{ships_with} eq 'perl'; + + install_module( $module, $info, $version ); + eval "use $module $version"; +## use critic + if ($EVAL_ERROR) { + push @failed, $module; + } +} + +if ( scalar @failed > 0 ) { + print "The following modules failed installation:\n"; + print join( "\n", @failed ); + print "\n"; +} + +exit; + +sub get_perl_modules { + if ( -f 'dist.ini' ) { + return get_perl_modules_from_ini(); + }; + if ( -f 'Makefile.PL' ) { + return get_perl_modules_from_Makefile_PL(); + }; + die "unable to find module list. Run this script in the dist dir\n"; +}; + +sub get_perl_modules_from_Makefile_PL { + my $fh = new IO::File 'Makefile.PL', 'r' + or die "unable to read Makefile.PL\n"; + + my $in = 0; + my @modules; + foreach my $line ( <$fh> ) { + if ( $line =~ /PREREQ_PM/ ) { + $in++; + next; + }; + next if ! $in; + last if $line =~ /}/; + my ($mod,$ver) = split /\s*=\s*/, $line; + $mod =~ s/[\s'"]*//g; # remove whitespace and quotes + next if ! $mod; + push @modules, name_overrides($mod); +#print "module: .$mod.\n"; + } + $fh->close; + return @modules; +}; + +sub get_perl_modules_from_ini { + my $fh = new IO::File 'dist.ini', 'r' + or die "unable to read dist.ini\n"; + + my $in = 0; + my @modules; + foreach my $line ( <$fh> ) { + if ( '[Prereqs]' eq substr($line,0,9) ) { + $in++; + next; + }; + next if ! $in; + print "line: $line\n"; + last if '[' eq substr($line,0,1); # [...] starts a new section + my ($mod,$ver) = split /\s*=\s*/, $line; + $mod =~ s/\s*//g; # remove whitespace + next if ! $mod; + push @modules, name_overrides($mod); + print "module: $mod\n"; + } + $fh->close; +#print Dumper(\@modules); + return @modules; +}; + +sub install_app { + my ( $app, $info) = @_; + + if ( lc($OSNAME) eq 'darwin' ) { + install_app_darwin($app, $info ); + } + elsif ( lc($OSNAME) eq 'freebsd' ) { + install_app_freebsd($app, $info ); + } + elsif ( lc($OSNAME) eq 'linux' ) { + install_app_linux( $app, $info ); + }; + +}; + +sub install_app_darwin { + my ($app, $info ) = @_; + + my $port = $info->{dport} || $info->{port} || $app; + + if ( ! -x '/opt/local/bin/port' ) { + print "MacPorts is not installed! Consider installing it.\n"; + return; + } + + system "/opt/local/bin/port install $port" + and warn "install failed for Darwin port $port"; +} + +sub install_app_freebsd { + my ($app, $info ) = @_; + + print " from ports..."; + my $name = $info->{port} || $app; + + if ( `/usr/sbin/pkg_info | /usr/bin/grep $name` ) { + return print "$app is installed.\n"; + } + elsif( `/usr/sbin/pkg info | /usr/bin/grep $name` ) { + return print "$app is installed.\n"; + } + + print "installing $app"; + + my $category = $info->{category} || '*'; + my ($portdir) = glob "/usr/ports/$category/$name"; + + if ( $portdir && -d $portdir && chdir $portdir ) { + print " from ports ($portdir)\n"; + system "make install clean" + and warn "'make install clean' failed for port $app\n"; + }; +}; + +sub install_app_linux { + my ($app, $info ) = @_; + + if ( -x '/usr/bin/yum' ) { + my $rpm = $info->{yum} || $app; + system "/usr/bin/yum -y install $rpm"; + } + elsif ( -x '/usr/bin/apt-get' ) { + my $package = $info->{apt} || $app; + system "/usr/bin/apt-get -y install $package"; + } + else { + warn "no Linux package manager detected\n"; + }; +}; + + +sub install_module { + + my ($module, $info, $version) = @_; + + if ( lc($OSNAME) eq 'darwin' ) { + install_module_darwin($module, $info, $version); + } + elsif ( lc($OSNAME) eq 'freebsd' ) { + install_module_freebsd($module, $info, $version); + } + elsif ( lc($OSNAME) eq 'linux' ) { + install_module_linux( $module, $info, $version); + }; + +## no critic + eval "require $module"; +## use critic + return 1 if ! $EVAL_ERROR; + + install_module_cpan($module, $version); +}; + +sub install_module_cpan { + + my ($module, $version) = @_; + + print " from CPAN..."; + sleep 1; + + # this causes problems when CPAN is not configured. + #$ENV{PERL_MM_USE_DEFAULT} = 1; # supress CPAN prompts + + $ENV{FTP_PASSIVE} = 1; # for FTP behind NAT/firewalls + + # some Linux distros break CPAN by auto/preconfiguring it with no URL mirrors. + # this works around that annoying little habit + no warnings; + $CPAN::Config = get_cpan_config(); + use warnings; + + # a hack to grab the latest version on CPAN before its hits the mirrors + if ( $module eq 'Provision::Unix' && $version ) { + $module =~ s/\:\:/\-/g; + $module = "M/MS/MSIMERSON/$module-$version.tar.gz"; + } + CPAN::Shell->install($module); +} + +sub install_module_darwin { + my ($module, $info, $version) = @_; + + my $dport = '/opt/local/bin/port'; + if ( ! -x $dport ) { + print "MacPorts is not installed! Consider installing it.\n"; + return; + } + + my $port = "p5-$module"; + $port =~ s/::/-/g; + system "$dport install $port" + and warn "install failed for Darwin port $module"; +} + +sub install_module_freebsd { + my ($module, $info, $version) = @_; + + my $name = $info->{port} || $module; + my $portname = "p5-$name"; + $portname =~ s/::/-/g; + + print " from ports...$portname..."; + + if ( `/usr/sbin/pkg_info | /usr/bin/grep $portname` ) { + return print "$module is installed.\n"; + } + elsif( `/usr/sbin/pkg info | /usr/bin/grep $portname` ) { + return print "$module is installed.\n"; + } + + print "installing $module ..."; + + my $category = $info->{category} || '*'; + my ($portdir) = glob "/usr/ports/$category/$portname"; + + if ( ! $portdir || ! -d $portdir ) { + print "oops, no match at /usr/ports/$category/$portname\n"; + return; + }; + + if ( ! chdir $portdir ) { + print "unable to cd to /usr/ports/$category/$portname\n"; + }; + + print " from ports ($portdir)\n"; + system "make install clean" + and warn "'make install clean' failed for port $module\n"; +} + +sub install_module_linux { + my ($module, $info, $version) = @_; + + my $package; + if ( -x '/usr/bin/yum' ) { + return install_module_linux_yum($module, $info); + } + elsif ( -x '/usr/bin/apt-get' ) { + return install_module_linux_apt($module, $info); + } + warn "no Linux package manager detected\n"; +}; + +sub install_module_linux_yum { + my ($module, $info) = @_; + my $package; + if ( $info->{yum} ) { + $package = $info->{yum}; + } + else { + $package = "perl-$module"; + $package =~ s/::/-/g; + }; + system "/usr/bin/yum -y install $package"; +}; + +sub install_module_linux_apt { + my ($module, $info) = @_; + my $package; + if ( $info->{apt} ) { + $package = $info->{apt}; + } + else { + $package = 'lib' . $module . '-perl'; + $package =~ s/::/-/g; + }; + system "/usr/bin/apt-get -y install $package"; +}; + +sub get_cpan_config { + + my $ftp = `which ftp`; chomp $ftp; + my $gzip = `which gzip`; chomp $gzip; + my $unzip = `which unzip`; chomp $unzip; + my $tar = `which tar`; chomp $tar; + my $make = `which make`; chomp $make; + my $wget = `which wget`; chomp $wget; + + return +{ + 'build_cache' => q[10], + 'build_dir' => qq[$ENV{HOME}/.cpan/build], + 'cache_metadata' => q[1], + 'cpan_home' => qq[$ENV{HOME}/.cpan], + 'ftp' => $ftp, + 'ftp_proxy' => q[], + 'getcwd' => q[cwd], + 'gpg' => q[], + 'gzip' => $gzip, + 'histfile' => qq[$ENV{HOME}/.cpan/histfile], + 'histsize' => q[100], + 'http_proxy' => q[], + 'inactivity_timeout' => q[5], + 'index_expire' => q[1], + 'inhibit_startup_message' => q[1], + 'keep_source_where' => qq[$ENV{HOME}/.cpan/sources], + 'lynx' => q[], + 'make' => $make, + 'make_arg' => q[], + 'make_install_arg' => q[], + 'makepl_arg' => q[], + 'ncftp' => q[], + 'ncftpget' => q[], + 'no_proxy' => q[], + 'pager' => q[less], + 'prerequisites_policy' => q[follow], + 'scan_cache' => q[atstart], + 'shell' => q[/bin/csh], + 'tar' => $tar, + 'term_is_latin' => q[1], + 'unzip' => $unzip, + 'urllist' => [ 'http://www.perl.com/CPAN/', 'http://mirrors.kernel.org/pub/CPAN/', 'ftp://cpan.cs.utah.edu/pub/CPAN/', 'ftp://mirrors.kernel.org/pub/CPAN', 'ftp://osl.uoregon.edu/CPAN/', 'http://cpan.yahoo.com/', 'ftp://ftp.funet.fi/pub/languages/perl/CPAN/' ], + 'wget' => $wget, }; +} + +sub name_overrides { + my $mod = shift; +# Package and port managers have naming conventions for perl modules. The +# methods will typically work out the name based on the module name and a +# couple rules. When that doesn't work, add entries here for FreeBSD (port), +# MacPorts ($dport), yum, and apt. + my @modules = ( + { module=>'LWP::UserAgent', info => { cat=>'www', port=>'p5-libwww', dport=>'p5-libwww-perl' }, }, + { module=>'Mail::Send' , info => { port => 'Mail::Tools', } }, + ); + my ($match) = grep { $_->{module} eq $mod } @modules; + return $match if $match; + return { module=>$mod, info => { } }; +}; From 78e7a0c644a349031ac023ec853f16a0b6cff2ce Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 24 Apr 2013 00:21:36 -0400 Subject: [PATCH 276/352] bump RAM from 150 to 200MB DKIM message signing needs more RAM --- run | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/run b/run index 1bbd0a6..908d775 100755 --- a/run +++ b/run @@ -2,8 +2,8 @@ # # 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 +# limit qpsmtpd to 200MB memory, should be several times what is needed. +MAXRAM=200000000 BIN=/usr/local/bin PERL=/usr/bin/perl From 3d7d43e0af4ec46047cb5a93a407628b25661e27 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 24 Apr 2013 00:23:24 -0400 Subject: [PATCH 277/352] split is_immune into itself + is_naughty is_immune tests designates to plugins they should always skip processing. That's typical for naughty connections, but this change provides the ability to handly naughty connections differently than (whitelisted/relayclients/known good) senders. --- lib/Qpsmtpd/Plugin.pm | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm index 2d3537e..4e0226f 100644 --- a/lib/Qpsmtpd/Plugin.pm +++ b/lib/Qpsmtpd/Plugin.pm @@ -303,6 +303,12 @@ sub is_immune { $self->log(LOGINFO, "skip, whitelisted sender"); return 1; } + return; +} + +sub is_naughty { + my $self = shift; + if ($self->connection->notes('naughty')) { # see plugins/naughty @@ -323,7 +329,7 @@ sub adjust_karma { my $karma = $self->connection->notes('karma') || 0; $karma += $value; - $self->log(LOGDEBUG, "karma adjust: $value ($karma)"); + $self->log(LOGDEBUG, "karma $value ($karma)"); $self->connection->notes('karma', $karma); return $value; } From f41df6e96de38c08674b51e6494555d6e5b1dbb5 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 24 Apr 2013 00:27:07 -0400 Subject: [PATCH 278/352] summarize shows a narrower screen by default. passing in -l for when your term windows is more than 200 chars wide will show more detail --- log/summarize | 22 +++++++++++++++------- 1 file changed, 15 insertions(+), 7 deletions(-) diff --git a/log/summarize b/log/summarize index b72cef9..539e5d3 100755 --- a/log/summarize +++ b/log/summarize @@ -6,9 +6,13 @@ use warnings; use Cwd; use Data::Dumper; use File::Tail; +use Getopt::Std; $Data::Dumper::Sortkeys = 1; +our $opt_l = 0; +getopts('l'); + my (%plugins, %plugin_aliases, %seen_plugins, %pids); my %hide_plugins = map { $_ => 1 } qw/ hostname /; @@ -32,7 +36,7 @@ my %formats = ( ip => "%-15.15s", hostname => "%-20.20s", distance => "%5.5s", - 'ident::geoip' => "%-20.20s", + 'ident::geoip' => $opt_l ? "%-20.20s" : "%-6.6s", 'ident::p0f' => "%-10.10s", count_unrecognized_commands => "%-5.5s", unrecognized_commands => "%-5.5s", @@ -269,18 +273,20 @@ sub print_auto_format { next; } + my $wide = $opt_l ? 20 : 8; + if (defined $pids{$pid}{helo_host} && $plugin =~ /helo/) { - $format .= " %-18.18s"; - push @values, substr(delete $pids{$pid}{helo_host}, -18, 18); + $format .= " %-$wide.${wide}s"; + push @values, substr(delete $pids{$pid}{helo_host}, -$wide, $wide); push @headers, 'HELO'; } elsif (defined $pids{$pid}{from} && $plugin =~ /from/) { - $format .= " %-20.20s"; - push @values, substr(delete $pids{$pid}{from}, -20, 20); + $format .= " %-$wide.${wide}s"; + push @values, substr(delete $pids{$pid}{from}, -$wide, $wide); push @headers, 'MAIL FROM'; } elsif (defined $pids{$pid}{to} && $plugin =~ /to|rcpt|recipient/) { - $format .= " %-20.20s"; + $format .= " %-$wide.${wide}s"; push @values, delete $pids{$pid}{to}; push @headers, 'RCPT TO'; } @@ -299,7 +305,7 @@ sub print_auto_format { $format .= "\n"; printf("\n$format", @headers) if (!$printed || $printed % 20 == 0); printf($format, @values); - print Data::Dumper::Dumper($pids{$pid}) if keys %{$pids{$pid}}; + #print Data::Dumper::Dumper($pids{$pid}) if keys %{$pids{$pid}}; $printed++; } @@ -347,6 +353,8 @@ sub populate_plugins_from_registry { open my $F, '<', $file; while (defined(my $line = <$F>)) { next if $line =~ /^#/; # discard comments + chomp $line; + next if ! $line; my ($id, $name, $abb3, $abb5, $aliases) = split /\s+/, $line; next if !defined $name; $plugins{$name} = {id => $id, abb3 => $abb3, abb5 => $abb5}; From 88e6ce6adb1d90814e1bd6893b34c31b8e2c7a19 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 24 Apr 2013 00:29:33 -0400 Subject: [PATCH 279/352] dmarc: improving and updating POD --- plugins/dmarc | 69 ++++++++++++++++++++++++++++++++------------------- 1 file changed, 44 insertions(+), 25 deletions(-) diff --git a/plugins/dmarc b/plugins/dmarc index 95b0320..60db367 100644 --- a/plugins/dmarc +++ b/plugins/dmarc @@ -6,6 +6,10 @@ Domain-based Message Authentication, Reporting and Conformance =head1 SYNOPSIS +DMARC is an extremely reliable means to authenticate email. + +=head1 DESCRIPTION + From the DMARC Draft: "DMARC operates as a policy layer atop DKIM and SPF. These technologies are the building blocks of DMARC as each is widely deployed, supported by mature tools, and is readily available to both senders and receivers. They are complementary, as each is resilient to many of the failure modes of the other." DMARC provides a way to exchange authentication information and policies among mail servers. @@ -14,10 +18,10 @@ DMARC benefits domain owners by preventing others from impersonating them. A dom DMARC benefits mail server operators by providing them with an extremely reliable (as opposed to DKIM or SPF, which both have reliability issues when used independently) means to block forged emails. Is that message really from PayPal, Chase, Gmail, or Facebook? Since those organizations, and many more, publish DMARC policies, operators have a definitive means to know. -=head1 HOW IT WORKS - =head1 HOWTO +=head2 Protect a domain with DMARC + See Section 10 of the draft: Domain Owner Actions 1. Deploy DKIM & SPF @@ -25,33 +29,47 @@ See Section 10 of the draft: Domain Owner Actions 3. Publish a "monitor" record, ask for data reports 4. Roll policies from monitor to reject -=head2 Publish a DMARC policy +=head3 Publish a DMARC policy + +_dmarc IN TXT "v=DMARC1; p=reject; pct=100; rua=mailto:dmarc-feedback@example.com;" v=DMARC1; (version) p=none; (disposition policy : reject, quarantine, none (monitor)) sp=reject; (subdomain policy: default, same as p) - rua adkim=s; (dkim alignment: s=strict, r=relaxed) aspf=r; (spf alignment: s=strict, r=relaxed) - rua=mailto: dmarc-feedback\@$zone; (aggregate reports) - ruf=mailto: dmarc-feedback\@$zone.com; (forensic reports) + rua=mailto: dmarc-feedback@example.com; (aggregate reports) + ruf=mailto: dmarc-feedback@example.com; (forensic reports) rf=afrf; (report format: afrf, iodef) ri=8400; (report interval) pct=50; (percent of messages to filter) +=head2 Validate messages with DMARC -=head1 DRAFT +1. install this plugin + +2. install a public suffix list in config/public_suffix_list. See http://publicsuffix.org/list/ + +3. activate this plugin (add to config/plugins) + +Be sure to run the DMARC after the SPF & DKIM plugins, and you should also have I set for both SPF and DKIM. + +=head2 Parse dmarc feedback reports into a database + +See http://www.taugh.com/rddmarc/ + +=head1 MORE INFORMATION http://www.dmarc.org/draft-dmarc-base-00-02.txt +https://github.com/qpsmtpd-dev/qpsmtpd-dev/wiki/DMARC-FAQ + =head1 TODO 2. provide dmarc feedback to domains that request it 3. If a message has multiple 'From' recipients, reject it - 4. Rejections with a 550 (perm) or 450 (temp) - =head1 IMPLEMENTATION 1. Primary identifier is RFC5322.From field (From: header) @@ -99,11 +117,10 @@ sub data_post_handler { my $from_host = $self->get_from_host($transaction) or return DECLINED; my $org_host = $self->get_organizational_domain($from_host); - if (!$self->exists_in_dns($from_host)) { - if (!$self->exists_in_dns($org_host)) { - $self->log(LOGINFO, "fail, $from_host not in DNS"); - return $self->get_reject("RFC5322.From host does not exist"); - } + # 6. Receivers should reject email if the domain appears to not exist + if (!$self->exists_in_dns($from_host) && !$self->exists_in_dns($org_host)) { + $self->log(LOGINFO, "fail, $from_host not in DNS"); + return $self->get_reject("RFC5322.From host appears non-existent"); } # 11.2. Determine Handling Policy @@ -295,18 +312,20 @@ sub get_organizational_domain { sub exists_in_dns { my ($self, $domain) = @_; -# the DMARC draft suggests rejecting messages whose From: domain does not -# exist in DNS. That's as far as it goes. So I went back to the ADSP (from -# where DMARC this originated, which in turn led me to the ietf-dkim email -# list where a handful of 'experts' failed to agree on The Right Way to -# perform this test. And thus no direction was given. -# As they point out: -# MX records aren't mandatory. -# A or AAAA records as fallback aren't reliable either. +# 6. Receivers should endeavour to reject or quarantine email if the +# RFC5322.From purports to be from a domain that appears to be +# either non-existent or incapable of receiving mail. -# I chose to query the name and match NS,MX,A,or AAAA records. Since it gets -# repeated for the for the Organizational Name, if it fails, there's no -# delegation from the TLD. +# I went back to the ADSP (from where DMARC this originated, which in turn +# led me to the ietf-dkim email list where a handful of 'experts' failed to +# agree on The Right Way to test domain validity. No direction was given. +# They point out: +# MX records aren't mandatory. +# A or AAAA records as fallback aren't reliable. + +# I chose to query the From: domain name and match NS,MX,A,or AAAA records. +# Since this search gets repeated for the Organizational Name, if it +# fails for the O.N., there's no delegation from the TLD. my $res = $self->init_resolver(8); my $query = $res->query($domain, 'NS') or do { if ($res->errorstring eq 'NXDOMAIN') { From 5aafca314fc1eac76f56aedaa308bd0d1d7c6ee5 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 24 Apr 2013 03:09:02 -0400 Subject: [PATCH 280/352] SPF: arrage flow so if a pass result is possible, we will get it and set the note for DMARC plugin --- plugins/dmarc | 26 +++++++++++++---- plugins/sender_permitted_from | 55 ++++++++++++++--------------------- 2 files changed, 43 insertions(+), 38 deletions(-) diff --git a/plugins/dmarc b/plugins/dmarc index 60db367..6f41234 100644 --- a/plugins/dmarc +++ b/plugins/dmarc @@ -296,9 +296,16 @@ sub get_organizational_domain { # $self->log( LOGINFO, "i: $i, $tld" ); #warn "i: $i - tld: $tld\n"; - if (grep /$tld/, $self->qp->config('public_suffix_list')) { + if (grep /^$tld/, $self->qp->config('public_suffix_list')) { $greatest = $i + 1; + next; } + + # check for wildcards (ex: *.uk should match co.uk) + $tld = join '.', '\*', reverse((@labels)[0 .. $i-1]); + if (grep /^$tld/, $self->qp->config('public_suffix_list')) { + $greatest = $i + 1; + }; } return $from_host if $greatest == scalar @labels; # same @@ -327,7 +334,16 @@ sub exists_in_dns { # Since this search gets repeated for the Organizational Name, if it # fails for the O.N., there's no delegation from the TLD. my $res = $self->init_resolver(8); - my $query = $res->query($domain, 'NS') or do { + return 1 if $self->host_has_rr('NS', $res, $domain); + return 1 if $self->host_has_rr('MX', $res, $domain); + return 1 if $self->host_has_rr('A', $res, $domain); + return 1 if $self->host_has_rr('AAAA', $res, $domain); +} + +sub host_has_rr { + my ($self, $type, $res, $domain) = @_; + + my $query = $res->query($domain, $type) or do { if ($res->errorstring eq 'NXDOMAIN') { $self->log(LOGDEBUG, "fail, non-existent domain: $domain"); return; @@ -337,14 +353,14 @@ sub exists_in_dns { }; my $matches = 0; for my $rr ($query->answer) { - next if $rr->type !~ /(?:NS|MX|A|AAAA)/; + next if $rr->type ne $type; $matches++; } if (0 == $matches) { - $self->log(LOGDEBUG, "fail, no records for $domain"); + $self->log(LOGDEBUG, "no $type records for $domain"); } return $matches; -} +}; sub fetch_dmarc_record { my ($self, $zone) = @_; diff --git a/plugins/sender_permitted_from b/plugins/sender_permitted_from index e9a1f9e..87d418d 100644 --- a/plugins/sender_permitted_from +++ b/plugins/sender_permitted_from @@ -96,28 +96,17 @@ sub mail_handler { return (DECLINED, "SPF - null sender"); } - if ($self->qp->connection->relay_client) { - $self->log(LOGINFO, "skip, relay_client"); - return (DECLINED, "SPF - relaying permitted"); - } - - if (!$self->{_args}{reject}) { - $self->log(LOGINFO, "skip, reject disabled"); - return (DECLINED); - } - - 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, + ip_address => $self->qp->connection->remote_ip, ); if ($scope =~ /^mfrom|pra$/) { - $req_params{identity} = $from; + $req_params{identity} = $from; $req_params{helo_identity} = $helo if $helo; } elsif ($scope eq 'helo') { @@ -144,28 +133,24 @@ sub mail_handler { return (DECLINED, "SPF - no response"); } - if (!$reject) { - $self->log(LOGINFO, "fail, no reject policy ($code: $why)"); - return (DECLINED, "SPF - $code: $why"); - } - - # SPF result codes: pass fail softfail neutral none error permerror temperror - return $self->handle_code_none($reject, $why) if $code eq 'none'; - if ($code eq 'fail') { - $self->adjust_karma(-1); - return $self->handle_code_fail($reject, $why); - } - elsif ($code eq 'softfail') { - $self->adjust_karma(-1); - return $self->handle_code_softfail($reject, $why); - } - elsif ($code eq 'pass') { + if ($code eq 'pass') { $self->adjust_karma(1); $transaction->notes('spf_pass_host', lc $sender->host); $self->log(LOGINFO, "pass, $code: $why"); return (DECLINED); } - elsif ($code eq 'neutral') { + + if (!$reject) { + $self->log(LOGINFO, "skip, tolerated ($code: $why)"); + return (DECLINED, "SPF - $code: $why"); + } + + # SPF result codes: pass fail softfail neutral none error permerror temperror + return $self->handle_code_none($reject, $why) if $code eq 'none'; + return $self->handle_code_fail($reject, $why) if $code eq 'fail'; + return $self->handle_code_softfail($reject, $why) if $code eq 'softfail'; + + if ($code eq 'neutral') { $self->log(LOGINFO, "fail, $code, $why"); return (DENY, "SPF - $code: $why") if $reject >= 5; } @@ -196,33 +181,37 @@ sub handle_code_none { return (DENY, "SPF - none: $why"); } - $self->log(LOGINFO, "pass, none, $why"); + $self->log(LOGINFO, "skip, tolerated, none, $why"); return DECLINED; } sub handle_code_fail { my ($self, $reject, $why) = @_; + $self->adjust_karma(-1); + if ($reject >= 2) { $self->log(LOGINFO, "fail, $why"); return (DENY, "SPF - forgery: $why") if $reject >= 3; return (DENYSOFT, "SPF - fail: $why"); } - $self->log(LOGINFO, "pass, fail tolerated, $why"); + $self->log(LOGINFO, "fail, tolerated, $why"); return DECLINED; } sub handle_code_softfail { my ($self, $reject, $why) = @_; + $self->adjust_karma(-1); + if ($reject >= 3) { $self->log(LOGINFO, "fail, soft, $why"); return (DENY, "SPF - fail: $why") if $reject >= 4; return (DENYSOFT, "SPF - fail: $why") if $reject >= 3; } - $self->log(LOGINFO, "pass, softfail tolerated, $why"); + $self->log(LOGINFO, "fail, soft, tolerated, $why"); return DECLINED; } From b4ee9620e591033ad2170719ea6ce00540cd5a61 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 24 Apr 2013 16:16:00 -0400 Subject: [PATCH 281/352] dmarc: added support for DMARC policy pct=NNN --- plugins/dmarc | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/plugins/dmarc b/plugins/dmarc index 6f41234..1c1eaa0 100644 --- a/plugins/dmarc +++ b/plugins/dmarc @@ -52,7 +52,7 @@ _dmarc IN TXT "v=DMARC1; p=reject; pct=100; rua=mailto:dmarc-feedback@example.c 3. activate this plugin (add to config/plugins) -Be sure to run the DMARC after the SPF & DKIM plugins, and you should also have I set for both SPF and DKIM. +Be sure to run the DMARC plugin after the SPF & DKIM plugins. Configure the SPF and DKIM messages to not reject mail. =head2 Parse dmarc feedback reports into a database @@ -146,6 +146,12 @@ sub data_post_handler { # Domain Owner. See Section 6.2 for details. return DECLINED if lc $policy->{p} eq 'none'; + my $pct = $policy->{pct} || 100; + if ( $pct != 100 && int(rand(100)) >= $pct ) { + $self->log("fail, tolerated, policy, sampled out"); + return DECLINED; + }; + return $self->get_reject("failed DMARC policy"); } @@ -348,6 +354,7 @@ sub host_has_rr { $self->log(LOGDEBUG, "fail, non-existent domain: $domain"); return; } + return if $res->errorstring eq 'NOERROR'; $self->log(LOGINFO, "error, looking up $domain: " . $res->errorstring); return; }; From 981bdf5f852c2958467d40b5fa17db571d8e291c Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 24 Apr 2013 16:18:22 -0400 Subject: [PATCH 282/352] SPF: added more precise disposition logs, so that postprocess can determine if a SPF failure caused a rejection --- plugins/sender_permitted_from | 25 ++++++++++++++----------- 1 file changed, 14 insertions(+), 11 deletions(-) diff --git a/plugins/sender_permitted_from b/plugins/sender_permitted_from index 87d418d..e80b4e4 100644 --- a/plugins/sender_permitted_from +++ b/plugins/sender_permitted_from @@ -151,22 +151,25 @@ sub mail_handler { return $self->handle_code_softfail($reject, $why) if $code eq 'softfail'; if ($code eq 'neutral') { - $self->log(LOGINFO, "fail, $code, $why"); - return (DENY, "SPF - $code: $why") if $reject >= 5; + if ($reject >= 5 ) { + $self->log(LOGINFO, "fail, $code, $why"); + return (DENY, "SPF - $code: $why"); + }; + $self->log(LOGINFO, "fail, tolerated, $code, $why"); + return (DECLINED); } - elsif ($code eq 'error') { - $self->log(LOGINFO, "fail, $code, $why"); + if ($code =~ /(?:permerror|error)/ ) { + $self->log(LOGINFO, "fail, $code, $why") if $reject > 3; return (DENY, "SPF - $code: $why") if $reject >= 6; return (DENYSOFT, "SPF - $code: $why") if $reject > 3; + $self->log(LOGINFO, "fail, tolerated, $code, $why"); + return (DECLINED); } - elsif ($code eq 'permerror') { - $self->log(LOGINFO, "fail, $code, $why"); - return (DENY, "SPF - $code: $why") if $reject >= 6; - return (DENYSOFT, "SPF - $code: $why") if $reject > 3; - } - elsif ($code eq 'temperror') { + if ($code eq 'temperror') { $self->log(LOGINFO, "fail, $code, $why"); return (DENYSOFT, "SPF - $code: $why") if $reject >= 2; + $self->log(LOGINFO, "fail, tolerated, $code, $why"); + return (DECLINED); } $self->log(LOGINFO, "SPF from $from was $code: $why"); @@ -211,7 +214,7 @@ sub handle_code_softfail { return (DENYSOFT, "SPF - fail: $why") if $reject >= 3; } - $self->log(LOGINFO, "fail, soft, tolerated, $why"); + $self->log(LOGINFO, "fail, tolerated, soft, $why"); return DECLINED; } From 6947c4fa773983be2ece5da553a39da9cfe652dc Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 24 Apr 2013 16:20:07 -0400 Subject: [PATCH 283/352] docs/logging: added description of log prefixes --- STATUS | 1 + 1 file changed, 1 insertion(+) diff --git a/STATUS b/STATUS index 98050a6..6992271 100644 --- a/STATUS +++ b/STATUS @@ -15,6 +15,7 @@ in Perl Best Practices is also fair game. So far, the main changes between the release and dev branches have focused on these goals: + - plugins use is_immune and is_naughty instead of a local methods - plugins log a single entry summarizing their disposition - plugin logs prefixed with keywords: pass, fail, skip, error - plugins use 'reject' and 'reject_type' settings From f7a59707ded511e2c8320ed5e491aa321d63e8bb Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 24 Apr 2013 16:21:18 -0400 Subject: [PATCH 284/352] docs/logging: added description of log prefixes --- Changes | 1 + docs/logging.pod | 34 ++++++++++++++++++++++++++++++++++ 2 files changed, 35 insertions(+) diff --git a/Changes b/Changes index 74b91e2..d5b50ca 100644 --- a/Changes +++ b/Changes @@ -17,6 +17,7 @@ karma: sprinkled karma awards throughout other plugins - limit poor karma hosts to 1 concurrent connection - allow +3 conncurrent connections to hosts with good karma + - limit recipients to 1 for senders with negative karma Sanitize spamd_sock path for perl taint mode - Markus Ullmann diff --git a/docs/logging.pod b/docs/logging.pod index 0066132..40a8747 100644 --- a/docs/logging.pod +++ b/docs/logging.pod @@ -127,6 +127,40 @@ plugins in plugins/logging, specifically the L and L files for examples of how to write your own logging plugins. +=head1 plugin authors + +While plugins can log anything they like, a few logging conventions in use: + +=over 4 + +=item * at LOGINFO, log a single entry summarizing their disposition + +=item * log messages are prefixed with keywords: pass, fail, skip, error + +=over 4 + +=item pass: tests were run and the message passed + +=item fail: tests were run and the message failed + +=item fail, tolerated: tests run, msg failed, reject disabled + +=item skip: tests were not run + +=item error: tried to run tests but failure(s) encountered + +=item info: additional info, not to be used for plugin summary + +=back + +=item * when tests fail and reject is disabled, use the 'fail, tolerated' prefix + +=back + +When these conventions are adhered to, the logs/summarize tool outputs each +message as a single row, with a small x showing failed tests and a large X +for failed tests that caused message rejection. + =head1 Internal support for pluggable logging Any code in the core can call C<$self->log()> and those log lines will be From 736e3b6eb3f1c76cbe812c39e5dae31c656caf49 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 24 Apr 2013 16:25:31 -0400 Subject: [PATCH 285/352] distinguish rejecting versus tolerated failures --- lib/Qpsmtpd/Plugin.pm | 2 +- log/summarize | 1 + plugins/helo | 2 +- plugins/resolvable_fromhost | 4 ++-- plugins/spamassassin | 4 ++-- 5 files changed, 7 insertions(+), 6 deletions(-) diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm index 4e0226f..a72cc86 100644 --- a/lib/Qpsmtpd/Plugin.pm +++ b/lib/Qpsmtpd/Plugin.pm @@ -224,7 +224,7 @@ sub get_reject { my $reject = $self->{_args}{reject}; if (defined $reject && !$reject) { - $self->log(LOGINFO, "fail, reject disabled" . $log_mess); + $self->log(LOGINFO, "fail, tolerated" . $log_mess); return DECLINED; } diff --git a/log/summarize b/log/summarize index 539e5d3..51270c3 100755 --- a/log/summarize +++ b/log/summarize @@ -314,6 +314,7 @@ sub show_symbol { return ' o' if $mess eq 'TLS setup returning'; return ' o' if $mess eq 'pass'; return ' -' if $mess eq 'skip'; + return ' x' if 'fail, tolerated' eq substr($mess, 0, 15); return ' X' if $mess eq 'fail'; return ' -' if $mess =~ /^skip[,:\s]/i; return ' o' if $mess =~ /^pass[,:\s]/i; diff --git a/plugins/helo b/plugins/helo index b5d7fb3..0123471 100644 --- a/plugins/helo +++ b/plugins/helo @@ -246,7 +246,7 @@ sub helo_handler { my ($self, $transaction, $host) = @_; if (!$host) { - $self->log(LOGINFO, "fail, no helo host"); + $self->log(LOGINFO, "fail, tolerated, no helo host"); return DECLINED; } diff --git a/plugins/resolvable_fromhost b/plugins/resolvable_fromhost index aa881a3..9804705 100644 --- a/plugins/resolvable_fromhost +++ b/plugins/resolvable_fromhost @@ -116,7 +116,7 @@ sub hook_mail { return Qpsmtpd::DSN->temp_resolver_failed($self->get_reject_type(), ''); } - $self->log(LOGINFO, 'fail, missing result, reject disabled'); + $self->log(LOGINFO, 'fail, tolerated, missing result'); return DECLINED; }; @@ -127,7 +127,7 @@ sub hook_mail { if (!$self->{_args}{reject}) { ; - $self->log(LOGINFO, "fail, reject disabled, $result"); + $self->log(LOGINFO, "fail, tolerated, $result"); return DECLINED; } diff --git a/plugins/spamassassin b/plugins/spamassassin index 7d7f734..342c788 100644 --- a/plugins/spamassassin +++ b/plugins/spamassassin @@ -178,7 +178,7 @@ sub data_post_handler { if ($transaction->data_size > 500_000) { $self->log(LOGINFO, - "skip: too large (" . $transaction->data_size . ")"); + "skip, too large (" . $transaction->data_size . ")"); return (DECLINED); } @@ -424,7 +424,7 @@ sub reject { if ($score < $reject) { if ($ham_or_spam eq 'Spam') { - $self->log(LOGINFO, "fail, $status < $reject, $learn"); + $self->log(LOGINFO, "fail, tolerated, $status < $reject, $learn"); return DECLINED; } else { From b3ca4e3ccc9cff484516c3f18d68d6ad579573d4 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 24 Apr 2013 16:30:28 -0400 Subject: [PATCH 286/352] karma: limit rcpts to 1 for senders with neg karma --- plugins/karma | 45 +++++++++++++++++++++++++++------------------ 1 file changed, 27 insertions(+), 18 deletions(-) diff --git a/plugins/karma b/plugins/karma index a32ed6a..a8f2dd6 100644 --- a/plugins/karma +++ b/plugins/karma @@ -20,22 +20,22 @@ 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: +custom connection policies such as these two examples: -=over 4 +=over 4 Hi there, well known and well behaved sender. Please help yourself to greater concurrency (hosts_allow), multiple recipients (karma), and no delays (early_sender). Hi there, naughty sender. You get a max concurrency of 1, max recipients of 2, and SMTP delays. -=back +=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. +naughty message. Karma is the number of nice - naughty connections. Default: 1 @@ -67,7 +67,7 @@ I<0> will not reject any connections. I<1> will reject naughty senders. -I is the most efficient setting. +I is the most efficient setting. To reject at any other connection hook, use the I setting and the B plugin. @@ -104,7 +104,7 @@ 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, +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. @@ -244,9 +244,10 @@ sub register { #$self->prune_db(); # keep the DB compact $self->register_hook('connect', 'connect_handler'); + $self->register_hook('rcpt_pre', 'rcpt_handler'); $self->register_hook('data', 'data_handler'); + $self->register_hook('data_post', 'data_handler'); $self->register_hook('disconnect', 'disconnect_handler'); - $self->register_hook('received_line', 'rcpt_handler'); } sub hook_pre_connection { @@ -256,8 +257,6 @@ sub hook_pre_connection { my $remote_ip = $args{remote_ip}; - #my $max_conn = $args{max_conn_ip}; - 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; @@ -323,28 +322,38 @@ sub connect_handler { } sub rcpt_handler { - my ($self, $transaction, $recipient, %args) = @_; + my ($self, $transaction, $addr) = @_; - my $recipients = scalar $self->transaction->recipients; - return DECLINED if $recipients < 2; # only one recipient + return DECLINED if $self->is_immune(); + + my $recipients = scalar $self->transaction->recipients or do { + $self->log(LOGDEBUG, "info, no recipient count"); + return DECLINED; + }; my $history = $self->connection->notes('karma_history'); - return DECLINED if $history > 0; # good history, no limit + if ( $history > 0 ) { + $self->log(LOGDEBUG, "info, good history"); + return DECLINED; + }; my $karma = $self->connection->notes('karma'); - return DECLINED if $karma > 0; # good connection, no limit + if ( $karma > 0 ) { + $self->log(LOGDEBUG, "info, good connection"); + return DECLINED; + }; # limit # of recipients if host has negative or unknown karma - return $self->get_reject("too many recipients"); + return (DENY, "too many recipients for karma $karma (h: $history)"); } sub data_handler { my ($self, $transaction) = @_; - if ( $self->qp->connection->relay_client ) { - $self->adjust_karma(5); # big karma boost for authenticated user/IP - }; + return DECLINED if $self->is_immune(); + return DECLINED if $self->is_naughty(); # let naughty do it +# cutting off a naughty sender at DATA prevents having to receive the message my $karma = $self->connection->notes('karma'); if ( $karma < -3 ) { # bad karma return $self->get_reject("very bad karma: $karma"); From e3d8a7030e4c9e767b5d4a662aa1c1341bdd5ec9 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 24 Apr 2013 16:31:00 -0400 Subject: [PATCH 287/352] rcpt_ok: do immunity checks earlier, so that disposition logs don't indicate failure for authenticated senders --- plugins/rcpt_ok | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/plugins/rcpt_ok b/plugins/rcpt_ok index 57f64b7..7d4d201 100644 --- a/plugins/rcpt_ok +++ b/plugins/rcpt_ok @@ -6,18 +6,18 @@ rcpt_ok =head1 SYNOPSIS -this plugin checks the standard rcpthosts config +Validate that we accept mail for a recipient using a qmail rcpthosts file =head1 DESCRIPTION -Check the recipient hostname and determine if we accept mail to that host. +Check the envelope 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_! +It should be configured as the _LAST_ recipient plugin! =cut @@ -30,6 +30,8 @@ use Qpsmtpd::DSN; sub hook_rcpt { my ($self, $transaction, $recipient, %param) = @_; + return (OK) if $self->is_immune(); # relay_client or whitelist + # 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. @@ -37,7 +39,6 @@ sub hook_rcpt { 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... From 3d6f23fcfd1bcfa21d2ebe74b3edaa45fa4635af Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 24 Apr 2013 16:32:08 -0400 Subject: [PATCH 288/352] run: increase RAM from 200 to 300MB (dkim) still seeing (infrequent) "too large" errors validating DKIM signatures --- run | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/run b/run index 908d775..79f57ff 100755 --- a/run +++ b/run @@ -2,8 +2,8 @@ # # You might want/need to to edit these settings QPUSER=smtpd -# limit qpsmtpd to 200MB memory, should be several times what is needed. -MAXRAM=200000000 +# limit qpsmtpd to 300MB memory +MAXRAM=300000000 BIN=/usr/local/bin PERL=/usr/bin/perl From 8823de50751da52942593df0c1e347be3d902fb9 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 24 Apr 2013 16:33:57 -0400 Subject: [PATCH 289/352] dmarc test: comments in the public list was allowing certain org domain searches to fail (plus.google.com, b/c a google.com email address was in the public list). Now I anchor the searches to the start of the line. This test also catches edge cases like co.uk, which isn't listed, but a wildcard *.uk is. --- t/plugin_tests/dmarc | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/t/plugin_tests/dmarc b/t/plugin_tests/dmarc index 4c8ef1c..461db72 100644 --- a/t/plugin_tests/dmarc +++ b/t/plugin_tests/dmarc @@ -12,7 +12,7 @@ my $test_email = 'matt@tnpi.net'; sub register_tests { my $self = shift; - $self->register_test('test_get_organizational_domain', 2); + $self->register_test('test_get_organizational_domain', 3); $self->register_test("test_fetch_dmarc_record", 3); $self->register_test("test_discover_policy", 1); } @@ -55,7 +55,8 @@ sub test_get_organizational_domain { my $transaction = $self->qp->transaction; cmp_ok( $self->get_organizational_domain('test.www.tnpi.net'), 'eq', 'tnpi.net' ); - cmp_ok( $self->get_organizational_domain('www.example.co.uk'), 'eq', 'example.co.uk' ) + cmp_ok( $self->get_organizational_domain('www.example.co.uk'), 'eq', 'example.co.uk' ); + cmp_ok( $self->get_organizational_domain('plus.google.com'), 'eq', 'google.com' ); }; sub test_discover_policy { From 96c27d410bb7eb43bd826d80d69e42c4435c8b14 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 24 Apr 2013 20:50:36 -0400 Subject: [PATCH 290/352] see if removing Mail::SPF makes Travis happy --- Makefile.PL | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile.PL b/Makefile.PL index d9e118e..be52460 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -20,7 +20,7 @@ WriteMakefile( 'Geo::IP' => 0, 'Mail::DKIM' => 0, 'Mail::SpamAssassin' => 0, - 'Mail::SPF' => 0, +# 'Mail::SPF' => 0, 'File::Tail' => 0, 'Time::TAI64' => 0, }, From b7a00a3741b59ce03a6b8234fcdd5d1b38464853 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 24 Apr 2013 20:51:11 -0400 Subject: [PATCH 291/352] .travis.yml: added perl 5.16 --- .travis.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.travis.yml b/.travis.yml index d32947f..ccf6732 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,5 +1,6 @@ language: perl perl: + - "5.16" - "5.14" - "5.12" - "5.10" From d02fbd2f22bdd50a14270fa7a0e9a05b7636b3a5 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 24 Apr 2013 22:12:31 -0400 Subject: [PATCH 292/352] try disabling Time::TAI64, update MANIFEST --- MANIFEST | 2 ++ Makefile.PL | 4 ++-- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/MANIFEST b/MANIFEST index 55b4ef9..4e7276f 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1,5 +1,6 @@ .gitignore .travis.yml +bin/install_deps.pl Changes config.sample/badhelo config.sample/badmailfrom @@ -10,6 +11,7 @@ config.sample/dnsbl_zones config.sample/flat_auth_pw config.sample/invalid_resolvable_fromhost config.sample/IP +config.sample/log2sql config.sample/logging config.sample/loglevel config.sample/norelayclients diff --git a/Makefile.PL b/Makefile.PL index be52460..5cad0c9 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -20,9 +20,9 @@ WriteMakefile( 'Geo::IP' => 0, 'Mail::DKIM' => 0, 'Mail::SpamAssassin' => 0, -# 'Mail::SPF' => 0, + 'Mail::SPF' => 0, 'File::Tail' => 0, - 'Time::TAI64' => 0, +# 'Time::TAI64' => 0, }, ABSTRACT => 'Flexible smtpd daemon written in Perl', AUTHOR => 'Ask Bjoern Hansen ', From ad08e7b2e5d631afd67b909a1bc25438f7dfada2 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 24 Apr 2013 22:15:45 -0400 Subject: [PATCH 293/352] Makefile.PL: disable Geo::IP module --- Makefile.PL | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Makefile.PL b/Makefile.PL index 5cad0c9..b54a83c 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -17,11 +17,11 @@ WriteMakefile( 'Time::HiRes' => 0, 'IO::Socket::SSL'=>0, # modules for specific features - 'Geo::IP' => 0, 'Mail::DKIM' => 0, 'Mail::SpamAssassin' => 0, - 'Mail::SPF' => 0, 'File::Tail' => 0, +# 'Geo::IP' => 0, +# 'Mail::SPF' => 0, # 'Time::TAI64' => 0, }, ABSTRACT => 'Flexible smtpd daemon written in Perl', From af3d7952255fb0a465672b502ed7a3c76640f491 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 24 Apr 2013 22:22:29 -0400 Subject: [PATCH 294/352] Makefile.PL: comment out Mail::Spamassassin --- Makefile.PL | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/Makefile.PL b/Makefile.PL index b54a83c..f7deec6 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -18,11 +18,11 @@ WriteMakefile( 'IO::Socket::SSL'=>0, # modules for specific features 'Mail::DKIM' => 0, - 'Mail::SpamAssassin' => 0, 'File::Tail' => 0, -# 'Geo::IP' => 0, -# 'Mail::SPF' => 0, -# 'Time::TAI64' => 0, +# 'Mail::SpamAssassin' => 0, +# 'Geo::IP' => 0, +# 'Mail::SPF' => 0, +# 'Time::TAI64' => 0, }, ABSTRACT => 'Flexible smtpd daemon written in Perl', AUTHOR => 'Ask Bjoern Hansen ', From 2a192c4108cfb3e40a33f2bf55f009463f48e030 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 24 Apr 2013 22:25:51 -0400 Subject: [PATCH 295/352] Makefile.PL: reenable Time::TAI64 --- Makefile.PL | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/Makefile.PL b/Makefile.PL index f7deec6..ebcf8ab 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -15,14 +15,15 @@ WriteMakefile( 'Net::DNS' => 0.39, 'Net::IP' => 0, 'Time::HiRes' => 0, - 'IO::Socket::SSL'=>0, + 'IO::Socket::SSL' => 0, # modules for specific features 'Mail::DKIM' => 0, 'File::Tail' => 0, + 'Time::TAI64' => 0, +# modules that cause Travis build tests to fail # 'Mail::SpamAssassin' => 0, # 'Geo::IP' => 0, # 'Mail::SPF' => 0, -# 'Time::TAI64' => 0, }, ABSTRACT => 'Flexible smtpd daemon written in Perl', AUTHOR => 'Ask Bjoern Hansen ', From 9e204aaf7e9fa96f3a1d1ae50fc262429cbb0865 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Thu, 25 Apr 2013 02:19:48 -0400 Subject: [PATCH 296/352] Makefile.PL: added clean { *.bak } --- Makefile.PL | 1 + 1 file changed, 1 insertion(+) diff --git a/Makefile.PL b/Makefile.PL index ebcf8ab..1eeaa55 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -28,6 +28,7 @@ WriteMakefile( ABSTRACT => 'Flexible smtpd daemon written in Perl', AUTHOR => 'Ask Bjoern Hansen ', EXE_FILES => [qw(qpsmtpd qpsmtpd-forkserver qpsmtpd-prefork qpsmtpd-async)], + clean => { FILES => [ '*.bak' ], }, ); sub MY::libscan { From f854736142ea6bf7a1a82283d2b6647eff42a592 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Thu, 25 Apr 2013 02:25:21 -0400 Subject: [PATCH 297/352] dmarc: added subdomain policy handling --- plugins/dmarc | 164 +++++++++++++++++++++++--------------------------- 1 file changed, 75 insertions(+), 89 deletions(-) diff --git a/plugins/dmarc b/plugins/dmarc index 1c1eaa0..a44c6d6 100644 --- a/plugins/dmarc +++ b/plugins/dmarc @@ -24,14 +24,14 @@ DMARC benefits mail server operators by providing them with an extremely reliabl See Section 10 of the draft: Domain Owner Actions -1. Deploy DKIM & SPF -2. Ensure identifier alignment. -3. Publish a "monitor" record, ask for data reports -4. Roll policies from monitor to reject + 1. Deploy DKIM & SPF + 2. Ensure identifier alignment. + 3. Publish a "monitor" record, ask for data reports + 4. Roll policies from monitor to reject =head3 Publish a DMARC policy -_dmarc IN TXT "v=DMARC1; p=reject; pct=100; rua=mailto:dmarc-feedback@example.com;" +_dmarc IN TXT "v=DMARC1; p=reject; rua=mailto:dmarc-feedback@example.com;" v=DMARC1; (version) p=none; (disposition policy : reject, quarantine, none (monitor)) @@ -50,9 +50,7 @@ _dmarc IN TXT "v=DMARC1; p=reject; pct=100; rua=mailto:dmarc-feedback@example.c 2. install a public suffix list in config/public_suffix_list. See http://publicsuffix.org/list/ -3. activate this plugin (add to config/plugins) - -Be sure to run the DMARC plugin after the SPF & DKIM plugins. Configure the SPF and DKIM messages to not reject mail. +3. activate this plugin. (add to config/plugins, listing it after SPF & DKIM. Check that SPF and DKIM are configured to not reject mail. =head2 Parse dmarc feedback reports into a database @@ -68,23 +66,9 @@ https://github.com/qpsmtpd-dev/qpsmtpd-dev/wiki/DMARC-FAQ 2. provide dmarc feedback to domains that request it - 3. If a message has multiple 'From' recipients, reject it +=head1 AUTHORS -=head1 IMPLEMENTATION - -1. Primary identifier is RFC5322.From field (From: header) - -2. Senders can specify strict or relaxed mode - -3. policies available: reject, quarantine, no action - -4. DMARC overrides other public auth mechanisms - -5. senders can specify a percentage of messages to which policy applies - -6. Receivers should endeavour to reject or quarantine email if the - RFC5322.From purports to be from a domain that appears to be - either non-existent or incapable of receiving mail. + 2013 - Matt Simerson =cut @@ -113,18 +97,17 @@ sub data_post_handler { return DECLINED if $self->is_immune(); # 11.1. Extract Author Domain - - my $from_host = $self->get_from_host($transaction) or return DECLINED; - my $org_host = $self->get_organizational_domain($from_host); + my $from_dom = $self->get_from_dom($transaction) or return DECLINED; + my $org_dom = $self->get_organizational_domain($from_dom); # 6. Receivers should reject email if the domain appears to not exist - if (!$self->exists_in_dns($from_host) && !$self->exists_in_dns($org_host)) { - $self->log(LOGINFO, "fail, $from_host not in DNS"); + my $exists = $self->exists_in_dns($from_dom, $org_dom) or do { + $self->log(LOGINFO, "fail, $from_dom not in DNS"); return $self->get_reject("RFC5322.From host appears non-existent"); - } + }; # 11.2. Determine Handling Policy - my $policy = $self->discover_policy($from_host) + my $policy = $self->discover_policy($from_dom, $org_dom) or return DECLINED; # 3. Perform DKIM signature verification checks. A single email may @@ -139,11 +122,14 @@ sub data_post_handler { # 5. Conduct identifier alignment checks. return DECLINED - if $self->is_aligned($from_host, $org_host, $policy, $spf_dom ); + if $self->is_aligned($from_dom, $org_dom, $policy, $spf_dom ); # 6. Apply policy. Emails that fail the DMARC mechanism check are # disposed of in accordance with the discovered DMARC policy of the # Domain Owner. See Section 6.2 for details. + if ( $self->{_args}{is_subdomain} && defined $policy->{sp} ) { + return DECLINED if lc $policy->{sp} eq 'none'; + }; return DECLINED if lc $policy->{p} eq 'none'; my $pct = $policy->{pct} || 100; @@ -156,7 +142,7 @@ sub data_post_handler { } sub is_aligned { - my ($self, $from_host, $org_host, $policy, $spf_dom) = @_; + my ($self, $from_dom, $org_dom, $policy, $spf_dom) = @_; # 5. Conduct identifier alignment checks. With authentication checks # and policy discovery performed, the Mail Receiver checks if @@ -169,14 +155,14 @@ sub is_aligned { my $dkim_sigs = $self->connection->notes('dkim_pass_domains') || []; foreach (@$dkim_sigs) { - if ($_ eq $from_host) { # strict alignment + if ($_ eq $from_dom) { # strict alignment, requires exact match $self->log(LOGINFO, "pass, DKIM aligned"); $self->adjust_karma(1); return 1; } next if $policy->{adkim} && lc $policy->{adkim} eq 's'; # strict pol. - # default policy is relaxed - if ( $_ eq $org_host ) { + # relaxed policy (default): Org. Dom must match a DKIM sig + if ( $_ eq $org_dom ) { $self->log(LOGINFO, "pass, DKIM aligned, relaxed"); $self->adjust_karma(1); return 1; @@ -184,13 +170,13 @@ sub is_aligned { } return 0 if ! $spf_dom; - if ($spf_dom eq $from_host) { + if ($spf_dom eq $from_dom) { $self->adjust_karma(1); $self->log(LOGINFO, "pass, SPF aligned"); return 1; } return 0 if ($policy->{aspf} && lc $policy->{aspf} eq 's' ); # strict pol - if ($spf_dom eq $org_host) { + if ($spf_dom eq $org_dom) { $self->adjust_karma(1); $self->log(LOGINFO, "pass, SPF aligned, relaxed"); return 1; @@ -200,35 +186,16 @@ sub is_aligned { }; sub discover_policy { - my ($self, $from_host) = @_; + my ($self, $from_dom, $org_dom) = @_; # 1. Mail Receivers MUST query the DNS for a DMARC TXT record... - my @matches = $self->fetch_dmarc_record($from_host); # 2. within - if (0 == scalar @matches) { - - # 3. If the set is now empty, the Mail Receiver MUST query the DNS for - # a DMARC TXT record at the DNS domain matching the Organizational - # Domain in place of the RFC5322.From domain in the message (if - # different). This record can contain policy to be asserted for - # subdomains of the Organizational Domain. - - my $org_dom = $self->get_organizational_domain($from_host) or return; - if ($org_dom eq $from_host) { - $self->log(LOGINFO, "skip, no policy for $from_host (same org)"); - return; - } - @matches = $self->fetch_dmarc_record($org_dom); - if (0 == scalar @matches) { - $self->log(LOGINFO, "skip, no policy for $from_host"); - return; - } - } + my @matches = $self->fetch_dmarc_record($from_dom, $org_dom) or return; # 4. Records that do not include a "v=" tag that identifies the # current version of DMARC are discarded. @matches = grep /v=DMARC1/i, @matches; if (0 == scalar @matches) { - $self->log(LOGINFO, "skip, no valid record for $from_host"); + $self->log(LOGINFO, "skip, no valid record for $from_dom"); return; } @@ -280,7 +247,7 @@ sub has_valid_reporting_uri { } sub get_organizational_domain { - my ($self, $from_host) = @_; + my ($self, $from_dom) = @_; # 1. Acquire a "public suffix" list, i.e., a list of DNS domain # names reserved for registrations. http://publicsuffix.org/list/ @@ -290,7 +257,7 @@ sub get_organizational_domain { # labels. Number these labels from right-to-left; e.g. for # "example.com", "com" would be label 1 and "example" would be # label 2.; - my @labels = reverse split /\./, $from_host; + my @labels = reverse split /\./, $from_dom; # 3. Search the public suffix list for the name that matches the # largest number of labels found in the subject DNS domain. Let @@ -314,7 +281,7 @@ sub get_organizational_domain { }; } - return $from_host if $greatest == scalar @labels; # same + return $from_dom if $greatest == scalar @labels; # same # 4. Construct a new DNS domain name using the name that matched # from the public suffix list and prefixing to it the "x+1"th @@ -324,26 +291,29 @@ sub get_organizational_domain { } sub exists_in_dns { - my ($self, $domain) = @_; + my ($self, $domain, $org_dom) = @_; # 6. Receivers should endeavour to reject or quarantine email if the # RFC5322.From purports to be from a domain that appears to be # either non-existent or incapable of receiving mail. -# I went back to the ADSP (from where DMARC this originated, which in turn -# led me to the ietf-dkim email list where a handful of 'experts' failed to -# agree on The Right Way to test domain validity. No direction was given. -# They point out: -# MX records aren't mandatory. -# A or AAAA records as fallback aren't reliable. - -# I chose to query the From: domain name and match NS,MX,A,or AAAA records. -# Since this search gets repeated for the Organizational Name, if it -# fails for the O.N., there's no delegation from the TLD. +# That's all the draft says. I went back to the DKIM ADSP (which led me to +# the ietf-dkim email list where some 'experts' failed to agree on The Right +# Way to test domain validity. Let alone deliverability. They point out: +# MX records aren't mandatory, and A|AAAA as fallback aren't reliable. +# +# Some experimentation proved both cases in real world usage. Instead, I test +# existence by searching for a MX, NS, A, or AAAA record. Since this search +# is repeated for the Organizational Name, if the NS query fails, there's no +# delegation from the TLD. That's proven very reliable. my $res = $self->init_resolver(8); - return 1 if $self->host_has_rr('NS', $res, $domain); - return 1 if $self->host_has_rr('MX', $res, $domain); - return 1 if $self->host_has_rr('A', $res, $domain); - return 1 if $self->host_has_rr('AAAA', $res, $domain); + my @todo = $domain; + push @todo, $org_dom if $domain ne $org_dom; + foreach ( @todo ) { + return 1 if $self->host_has_rr('MX', $res, $_); + return 1 if $self->host_has_rr('NS', $res, $_); + return 1 if $self->host_has_rr('A', $res, $_); + return 1 if $self->host_has_rr('AAAA', $res, $_); + }; } sub host_has_rr { @@ -370,12 +340,12 @@ sub host_has_rr { }; sub fetch_dmarc_record { - my ($self, $zone) = @_; + my ($self, $zone, $org_dom) = @_; # 1. Mail Receivers MUST query the DNS for a DMARC TXT record at the # DNS domain matching the one found in the RFC5322.From domain in # the message. A possibly empty set of records is returned. - + $self->{_args}{is_subdomain} = defined $org_dom ? 0 : 1; my $res = $self->init_resolver(); my $query = $res->send('_dmarc.' . $zone, 'TXT'); my @matches; @@ -384,27 +354,43 @@ sub fetch_dmarc_record { # 2. Records that do not start with a "v=" tag that identifies the # current version of DMARC are discarded. - next if 'v=' ne substr($rr->txtdata, 0, 2); - next if 'v=spf' eq substr($rr->txtdata, 0, 5); # commonly found + next if 'v=' ne lc substr($rr->txtdata, 0, 2); + next if 'v=spf' eq lc substr($rr->txtdata, 0, 5); # SPF commonly found $self->log(LOGINFO, $rr->txtdata); push @matches, join('', $rr->txtdata); } + return @matches if scalar @matches; # found one! (at least) + + # 3. If the set is now empty, the Mail Receiver MUST query the DNS for + # a DMARC TXT record at the DNS domain matching the Organizational + # Domain in place of the RFC5322.From domain in the message (if + # different). This record can contain policy to be asserted for + # subdomains of the Organizational Domain. + if ( defined $org_dom ) { # <- recursion break + if ( $org_dom eq $zone ) { + $self->log(LOGINFO, "skip, no policy for $zone (same org)"); + return @matches; + }; + return $self->fetch_dmarc_record($org_dom); # <- recursion + }; + + $self->log(LOGINFO, "skip, no policy for $zone"); return @matches; } -sub get_from_host { +sub get_from_dom { my ($self, $transaction) = @_; my $from = $transaction->header->get('From') or do { $self->log(LOGINFO, "error, unable to retrieve From header!"); return; }; - my ($from_host) = (split /@/, $from)[-1]; # grab everything after the @ - ($from_host) = split /\s+/, $from_host; # remove any trailing cruft - chomp $from_host; - chop $from_host if '>' eq substr($from_host, -1, 1); - $self->log(LOGDEBUG, "info, from_host is $from_host"); - return $from_host; + my ($from_dom) = (split /@/, $from)[-1]; # grab everything after the @ + ($from_dom) = split /\s+/, $from_dom; # remove any trailing cruft + chomp $from_dom; # remove \n + chop $from_dom if '>' eq substr($from_dom, -1, 1); # remove closing > + $self->log(LOGDEBUG, "info, from_dom is $from_dom"); + return $from_dom; } sub parse_policy { From 5ca971d0fb57ffc092beb01a9a5b00ef09aabbc1 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Thu, 25 Apr 2013 11:24:08 -0700 Subject: [PATCH 298/352] install_deps: handle comments in Makefile.PL --- bin/install_deps.pl | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/bin/install_deps.pl b/bin/install_deps.pl index ac4609e..b825e73 100755 --- a/bin/install_deps.pl +++ b/bin/install_deps.pl @@ -27,13 +27,8 @@ use CPAN; use English qw( -no_match_vars ); my $apps = [ - { app => 'expat' , info => { port => 'expat2', dport=>'expat2' } }, - { app => 'gettext' , info => { port => 'gettext', dport=>'gettext'} }, - { app => 'gmake' , info => { port => 'gmake', dport=>'gmake' } }, - { app => 'mysql-server-5', info => { port => 'mysql50-server', dport=>'mysql5', yum =>'mysql-server'} }, - { app => 'apache22' , info => { port => 'apache22', dport=>'', yum => 'httpd' } }, - { app => 'mod_perl2' , info => { port => 'mod_perl2', dport=>'', yum => 'mod_perl' } }, - { app => 'rsync' , info => { }, }, +# { app => 'mysql-server-5', info => { port => 'mysql50-server', dport=>'mysql5', yum =>'mysql-server'} }, +# { app => 'apache22' , info => { port => 'apache22', dport=>'', yum => 'httpd' } }, ]; $EUID == 0 or die "You will have better luck if you run me as root.\n"; @@ -95,8 +90,9 @@ sub get_perl_modules_from_Makefile_PL { }; next if ! $in; last if $line =~ /}/; + next if $line !~ /=/; # no = char means not a module my ($mod,$ver) = split /\s*=\s*/, $line; - $mod =~ s/[\s'"]*//g; # remove whitespace and quotes + $mod =~ s/[\s'"\#]*//g; # remove whitespace and quotes next if ! $mod; push @modules, name_overrides($mod); #print "module: .$mod.\n"; From c3c56432961d3353464117e441b45e49d7c01779 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Thu, 25 Apr 2013 17:53:55 -0400 Subject: [PATCH 299/352] Qpsmtpd.pm: split config args on /\s+/, was / / --- lib/Qpsmtpd.pm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index ec7c0ef..87b30f9 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -7,7 +7,7 @@ use Qpsmtpd::Constants; #use DashProfiler; -$VERSION = "0.91"; +$VERSION = "0.92"; my $git; @@ -377,7 +377,7 @@ sub _load_plugin { my $self = shift; my ($plugin_line, @plugin_dirs) = @_; - my ($plugin, @args) = split / /, $plugin_line; + my ($plugin, @args) = split /\s+/, $plugin_line; my $package; From 8e9e2926c4dcc9d427e1d44b8365a766932d4e25 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Thu, 25 Apr 2013 18:44:21 -0400 Subject: [PATCH 300/352] Qpsmtpd: untaint config data passed to plugins if QP passes in tainted data, such as a hostname that subsequently gets used to open a connection using IO::Socket, the plugin die because the information is tainted. Fix it once here, instead of in each plugin. --- lib/Qpsmtpd.pm | 94 +++++++++++++++++++++++++++----------------------- 1 file changed, 51 insertions(+), 43 deletions(-) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index 87b30f9..da36d68 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -377,58 +377,46 @@ sub _load_plugin { my $self = shift; my ($plugin_line, @plugin_dirs) = @_; - my ($plugin, @args) = split /\s+/, $plugin_line; - - my $package; + # untaint the config data before passing it to plugins + my ($safe_line) = $plugin_line =~ /^([ -~]+)$/ # all ascii printable + or die "unsafe characters in config line: $plugin_line\n"; + my ($plugin, @args) = split /\s+/, $safe_line; if ($plugin =~ m/::/) { + return $self->_load_package_plugin($plugin, $safe_line, \@args); + }; - # "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 + # 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; + # 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; + # 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"; + my $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; - } + # 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 $safe_line from $dir/$plugin") + unless $safe_line =~ /logging/; + last PLUGIN_DIR; } - die "Plugin $plugin_name not found in our plugin dirs (", - join(", ", @plugin_dirs), ")" - unless defined &{"${package}::plugin_name"}; } + die "Plugin $plugin_name not found in our plugin dirs (", + join(", ", @plugin_dirs), ")" + unless defined &{"${package}::plugin_name"}; } my $plug = $package->new(); @@ -437,6 +425,26 @@ sub _load_plugin { return $plug; } +sub _load_package_plugin { + my ($self, $plugin, $plugin_line, $args) = @_; + # "full" package plugin (My::Plugin) + my $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/; + + my $plug = $package->new(); + $plug->_register($self, @$args); + + return $plug; +}; + sub transaction { return {}; } # base class implements empty transaction sub run_hooks { From 887e3caadbf32fa106c408daebfee2fd0471341a Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Thu, 25 Apr 2013 18:51:34 -0400 Subject: [PATCH 301/352] auth_vpopmaild: added taint checking to responses --- plugins/auth/auth_vpopmaild | 108 ++++++++++++++++++++++-------------- 1 file changed, 66 insertions(+), 42 deletions(-) diff --git a/plugins/auth/auth_vpopmaild b/plugins/auth/auth_vpopmaild index 08e3970..b7e8395 100644 --- a/plugins/auth/auth_vpopmaild +++ b/plugins/auth/auth_vpopmaild @@ -6,7 +6,7 @@ use warnings; use Qpsmtpd::Constants; use IO::Socket; use version; -my $VERSION = qv('1.0.3'); +my $VERSION = qv('1.0.4'); sub register { my ($self, $qp, %args) = @_; @@ -29,8 +29,65 @@ sub auth_vpopmaild { return DECLINED; } + my $socket = $self->get_socket() or return DECLINED; + + $self->log(LOGDEBUG, "attempting $method"); + + # Get server greeting (+OK) + my $response = $self->get_response( $socket, '' ) + or return DECLINED; + + if ($response !~ /^\+OK/) { + $self->log(LOGERROR, "skip, bad connection response: $response"); + close $socket; + return DECLINED; + } + + print $socket "login $user $passClear\n\r"; # send login details + $response = $self->get_response( $socket, "login $user $passClear\n\r" ) + or return DECLINED; + + close $socket; + + # check for successful login (single line (+OK) or multiline (+OK+)) + if ($response =~ /^\+OK/) { + $self->log(LOGINFO, "pass, clear"); + return (OK, 'auth_vpopmaild'); + } + + chomp $response; + $self->log(LOGNOTICE, "fail, $response"); + return DECLINED; +} + +sub get_response { + my ($self, $socket, $send) = @_; + + print $socket $send if $send; # send request + my $response = <$socket>; # get response + chomp $response; + + if ( ! defined $response ) { + $self->log(LOGERROR, "error, no connection response"); + close $socket; + return; + } + + if ($response =~ /^([ -~\n\r]+)$/) { # match ascii printable + $response = $1; # $response now untainted + } + else { + $self->log(LOGERROR, "error, response unsafe."); + }; + + return $response; +}; + +sub get_socket { + my ($self) = @_; + # create socket - my $vpopmaild_socket = + my $socket = IO::Socket::INET->new( PeerAddr => $self->{_vpopmaild_host}, PeerPort => $self->{_vpopmaild_port}, @@ -38,46 +95,11 @@ sub auth_vpopmaild { Type => SOCK_STREAM ) or do { - $self->log(LOGERROR, "skip: socket connection to vpopmaild failed"); - return DECLINED; + $self->log(LOGERROR, "skip, socket connection to vpopmaild failed"); + return; }; - - $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; -} + return $socket; +}; __END__ @@ -113,7 +135,9 @@ please read the VPOPMAIL section in doc/authentication.pod Robin Bowes -Matt Simerson (updated response parsing, added logging) +2012 Matt Simerson (updated response parsing, added logging) + +2013 Matt Simerson - split get_response and get_socket into new methods, added taint checking to responses =head1 COPYRIGHT AND LICENSE From 0b8e4f5ca33c433369f1cec484db433f40f70954 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Thu, 25 Apr 2013 19:55:35 -0400 Subject: [PATCH 302/352] replace run with separate run for the 2 common deployment methods. Rather than having to edit the run file, it's much easier to rename the run file. Moved qpsmtpd* into bin/ --- qpsmtpd => bin/qpsmtpd | 0 qpsmtpd-async => bin/qpsmtpd-async | 0 qpsmtpd-forkserver => bin/qpsmtpd-forkserver | 0 qpsmtpd-prefork => bin/qpsmtpd-prefork | 0 run | 40 -------------------- run.forkserver | 23 +++++++++++ run.tcpserver | 24 ++++++++++++ 7 files changed, 47 insertions(+), 40 deletions(-) rename qpsmtpd => bin/qpsmtpd (100%) rename qpsmtpd-async => bin/qpsmtpd-async (100%) rename qpsmtpd-forkserver => bin/qpsmtpd-forkserver (100%) rename qpsmtpd-prefork => bin/qpsmtpd-prefork (100%) delete mode 100755 run create mode 100755 run.forkserver create mode 100755 run.tcpserver diff --git a/qpsmtpd b/bin/qpsmtpd similarity index 100% rename from qpsmtpd rename to bin/qpsmtpd diff --git a/qpsmtpd-async b/bin/qpsmtpd-async similarity index 100% rename from qpsmtpd-async rename to bin/qpsmtpd-async diff --git a/qpsmtpd-forkserver b/bin/qpsmtpd-forkserver similarity index 100% rename from qpsmtpd-forkserver rename to bin/qpsmtpd-forkserver diff --git a/qpsmtpd-prefork b/bin/qpsmtpd-prefork similarity index 100% rename from qpsmtpd-prefork rename to bin/qpsmtpd-prefork diff --git a/run b/run deleted file mode 100755 index 79f57ff..0000000 --- a/run +++ /dev/null @@ -1,40 +0,0 @@ -#!/bin/sh -# -# You might want/need to to edit these settings -QPUSER=smtpd -# limit qpsmtpd to 300MB memory -MAXRAM=300000000 -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` -PORT=25 -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 $PORT \ - ./qpsmtpd 2>&1 -# - - -# -#exec 2>&1 \ -#sh -c " -# exec $BIN/softlimit -m $MAXRAM \ -# $PERL -T ./qpsmtpd-forkserver \ -# --listen-address $IP \ -# --port $PORT \ -# --port 587 \ -# --limit-connections 15 \ -# --max-from-ip 5 \ -# --user $QPUSER -#" -# diff --git a/run.forkserver b/run.forkserver new file mode 100755 index 0000000..64b9df3 --- /dev/null +++ b/run.forkserver @@ -0,0 +1,23 @@ +#!/bin/sh +# +QPUSER=smtpd +# limit qpsmtpd to 300MB memory +MAXRAM=300000000 +BIN=/usr/local/bin +PERL=/usr/bin/perl +IP=0.0.0.0 +LANG=C + +# See also: http://wiki.qpsmtpd.org/deploy:start + +exec 2>&1 \ +sh -c " + exec $BIN/softlimit -m $MAXRAM \ + $PERL -T ./bin/qpsmtpd-forkserver \ + --listen-address $IP \ + --port 25 \ + --port 587 \ + --limit-connections 15 \ + --max-from-ip 5 \ + --user $QPUSER +" diff --git a/run.tcpserver b/run.tcpserver new file mode 100755 index 0000000..ca543a2 --- /dev/null +++ b/run.tcpserver @@ -0,0 +1,24 @@ +#!/bin/sh +# +QPUSER=smtpd +# limit qpsmtpd to 300MB memory +MAXRAM=300000000 +BIN=/usr/local/bin +PERL=/usr/bin/perl + +IP=`head -1 config/IP` +PORT=25 + +LANG=C +QMAILDUID=`id -u $QPUSER` +NOFILESGID=`id -g $QPUSER` + +# 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 $PORT \ + ./bin/qpsmtpd 2>&1 +# + From dfe8c1cd83d494859fddacf1f56a6b64982386de Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Thu, 25 Apr 2013 21:31:07 -0400 Subject: [PATCH 303/352] revert movement of qp bins to bin/ plugin dir, config dir, spool dir, all have different logic about where/how to find their config. The logic needs some untangling and unification before attempting this again. --- bin/qpsmtpd => qpsmtpd | 0 bin/qpsmtpd-async => qpsmtpd-async | 0 bin/qpsmtpd-forkserver => qpsmtpd-forkserver | 0 bin/qpsmtpd-prefork => qpsmtpd-prefork | 0 run.forkserver | 2 +- run.tcpserver | 2 +- 6 files changed, 2 insertions(+), 2 deletions(-) rename bin/qpsmtpd => qpsmtpd (100%) rename bin/qpsmtpd-async => qpsmtpd-async (100%) rename bin/qpsmtpd-forkserver => qpsmtpd-forkserver (100%) rename bin/qpsmtpd-prefork => qpsmtpd-prefork (100%) diff --git a/bin/qpsmtpd b/qpsmtpd similarity index 100% rename from bin/qpsmtpd rename to qpsmtpd diff --git a/bin/qpsmtpd-async b/qpsmtpd-async similarity index 100% rename from bin/qpsmtpd-async rename to qpsmtpd-async diff --git a/bin/qpsmtpd-forkserver b/qpsmtpd-forkserver similarity index 100% rename from bin/qpsmtpd-forkserver rename to qpsmtpd-forkserver diff --git a/bin/qpsmtpd-prefork b/qpsmtpd-prefork similarity index 100% rename from bin/qpsmtpd-prefork rename to qpsmtpd-prefork diff --git a/run.forkserver b/run.forkserver index 64b9df3..2bdadbf 100755 --- a/run.forkserver +++ b/run.forkserver @@ -13,7 +13,7 @@ LANG=C exec 2>&1 \ sh -c " exec $BIN/softlimit -m $MAXRAM \ - $PERL -T ./bin/qpsmtpd-forkserver \ + $PERL -T ./qpsmtpd-forkserver \ --listen-address $IP \ --port 25 \ --port 587 \ diff --git a/run.tcpserver b/run.tcpserver index ca543a2..d5b4c99 100755 --- a/run.tcpserver +++ b/run.tcpserver @@ -19,6 +19,6 @@ NOFILESGID=`id -g $QPUSER` exec $BIN/softlimit -m $MAXRAM \ $BIN/tcpserver -c 10 -v -R -p \ -u $QMAILDUID -g $NOFILESGID $IP $PORT \ - ./bin/qpsmtpd 2>&1 + ./qpsmtpd 2>&1 # From 80bb4c93dd5b0309aeebcaccf87800b3be424ee7 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Thu, 25 Apr 2013 21:39:31 -0400 Subject: [PATCH 304/352] Makefile.PL: added more disabled dependencies DBI: commented out, but included for documentation's sake --- Makefile.PL | 3 +++ 1 file changed, 3 insertions(+) diff --git a/Makefile.PL b/Makefile.PL index 1eeaa55..fc88314 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -20,6 +20,9 @@ WriteMakefile( 'Mail::DKIM' => 0, 'File::Tail' => 0, 'Time::TAI64' => 0, +# 'DBI' => 0, # auth_vpopmail_sql and +# 'DBD::mysql' => 0, # log2sql +# 'DBIx::Simple' => 0, # modules that cause Travis build tests to fail # 'Mail::SpamAssassin' => 0, # 'Geo::IP' => 0, From cebf995f9dfb3de1b072649c7fb305b9213e822d Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Thu, 25 Apr 2013 21:40:09 -0400 Subject: [PATCH 305/352] summarize: strip out unprintable chars --- log/summarize | 2 ++ 1 file changed, 2 insertions(+) diff --git a/log/summarize b/log/summarize index 51270c3..ba82291 100755 --- a/log/summarize +++ b/log/summarize @@ -57,6 +57,7 @@ my %formats = ( check_badmailfrom => "%-3.3s", sender_permitted_from => "%-3.3s", resolvable_fromhost => "%-3.3s", + dont_require_anglebrackets => "%-3.3s", 'queue::qmail-queue' => "%-3.3s", connection_time => "%-4.4s", ); @@ -82,6 +83,7 @@ my %formats3 = ( while (defined(my $line = $fh->read)) { chomp $line; + $line =~ s/[^[ -~]]//g; # strip out binary/unprintable next if !$line; my ($type, $pid, $hook, $plugin, $message) = parse_line($line); next if !$type; From e8effdd6cd3d68462a115e12ec9683c5a0da01b4 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 26 Apr 2013 01:01:17 -0400 Subject: [PATCH 306/352] Makefile.PL, added comments, stating where the disabled plugins are used --- Makefile.PL | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Makefile.PL b/Makefile.PL index fc88314..3821b0d 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -18,11 +18,11 @@ WriteMakefile( 'IO::Socket::SSL' => 0, # modules for specific features 'Mail::DKIM' => 0, - 'File::Tail' => 0, - 'Time::TAI64' => 0, + 'File::Tail' => 0, # log/summarize, log/watch + 'Time::TAI64' => 0, # log2sql # 'DBI' => 0, # auth_vpopmail_sql and # 'DBD::mysql' => 0, # log2sql -# 'DBIx::Simple' => 0, +# 'DBIx::Simple' => 0, # log2sql # modules that cause Travis build tests to fail # 'Mail::SpamAssassin' => 0, # 'Geo::IP' => 0, From 341865d9410a26349750bd373d435e29c33b3b02 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 26 Apr 2013 01:03:00 -0400 Subject: [PATCH 307/352] summarize: move parts of main while loop to subs and added POD --- log/summarize | 257 +++++++++++++++++++++++++++++++------------------- 1 file changed, 160 insertions(+), 97 deletions(-) diff --git a/log/summarize b/log/summarize index ba82291..a0066f1 100755 --- a/log/summarize +++ b/log/summarize @@ -8,6 +8,7 @@ use Data::Dumper; use File::Tail; use Getopt::Std; +$|++; $Data::Dumper::Sortkeys = 1; our $opt_l = 0; @@ -32,54 +33,11 @@ my $fh = File::Tail->new( my $printed = 0; my $has_cleanup; -my %formats = ( - ip => "%-15.15s", - hostname => "%-20.20s", - distance => "%5.5s", - 'ident::geoip' => $opt_l ? "%-20.20s" : "%-6.6s", - 'ident::p0f' => "%-10.10s", - count_unrecognized_commands => "%-5.5s", - unrecognized_commands => "%-5.5s", - dnsbl => "%-3.3s", - rhsbl => "%-3.3s", - relay => "%-3.3s", - karma => "%-3.3s", - fcrdns => "%-3.3s", - earlytalker => "%-3.3s", - check_earlytalker => "%-3.3s", - helo => "%-3.3s", - tls => "%-3.3s", - 'auth::auth_vpopmail' => "%-3.3s", - 'auth::auth_vpopmaild' => "%-3.3s", - 'auth::auth_vpopmail_sql' => "%-3.3s", - 'auth::auth_checkpassword' => "%-3.3s", - badmailfrom => "%-3.3s", - check_badmailfrom => "%-3.3s", - sender_permitted_from => "%-3.3s", - resolvable_fromhost => "%-3.3s", - dont_require_anglebrackets => "%-3.3s", - 'queue::qmail-queue' => "%-3.3s", - connection_time => "%-4.4s", - ); - -my %formats3 = ( - %formats, - badrcptto => "%-3.3s", - check_badrcptto => "%-3.3s", - qmail_deliverable => "%-3.3s", - rcpt_ok => "%-3.3s", - check_basicheaders => "%-3.3s", - headers => "%-3.3s", - uribl => "%-3.3s", - bogus_bounce => "%-3.3s", - check_bogus_bounce => "%-3.3s", - domainkeys => "%-3.3s", - dkim => "%-3.3s", - dmarc => "%-3.3s", - spamassassin => "%-3.3s", - dspam => "%-3.3s", - 'virus::clamdscan' => "%-3.3s", - ); +my %formats = get_default_field_widths(); +my %formats3 = ( %formats, map { $_ => "%-3.3s" } qw/ badrcptto check_badrcptto + qmail_deliverable rcpt_ok check_basicheaders headers uribl bogus_bounce + check_bogus_bounce domainkeys dkim dmarc spamassassin dspam + virus::clamdscan / ); while (defined(my $line = $fh->read)) { chomp $line; @@ -87,7 +45,7 @@ while (defined(my $line = $fh->read)) { next if !$line; my ($type, $pid, $hook, $plugin, $message) = parse_line($line); next if !$type; - next if $type =~ /^(info|unknown|response|tcpserver)$/; + next if $type =~ /^(?:info|unknown|response|tcpserver)$/; next if $type eq 'init'; # doesn't occur in all deployment models if (!$pids{$pid}) { # haven't seen this pid @@ -95,7 +53,7 @@ while (defined(my $line = $fh->read)) { my ($host, $ip) = split /\s/, $message; $ip = substr $ip, 1, -1; foreach (keys %seen_plugins, qw/ helo_host from to /) { - $pids{$pid}{$_} = ''; + $pids{$pid}{$_} = ''; # define them } $pids{$pid}{ip} = $ip; $pids{$pid}{hostname} = $host if $host ne 'Unknown'; @@ -111,63 +69,94 @@ while (defined(my $line = $fh->read)) { delete $pids{$pid}; } elsif ($type eq 'plugin') { - next if $plugin eq 'naughty'; # housekeeping only - if (!$pids{$pid}{$plugin}) { # first entry for this plugin - $pids{$pid}{$plugin} = $message; - } - else { # subsequent log entry for this plugin - if ($pids{$pid}{$plugin} !~ /^(?:pass|fail|skip)/i) { - $pids{$pid}{$plugin} = $message; # overwrite 1st - } - else { - #print "ignoring subsequent hit on $plugin: $message\n"; - } - } - - if ($plugin eq 'ident::geoip') { - if (length $message < 3) { - $formats{'ident::geoip'} = "%-3.3s"; - $formats3{'ident::geoip'} = "%-3.3s"; - } - else { - my ($gip, $distance) = $message =~ /(.*?),\s+([\d]+)\skm/; - if ($distance) { - $pids{$pid}{$plugin} = $gip; - $pids{$pid}{distance} = $distance; - } - } - } + handle_plugin($message,$plugin,$pid,$line); } elsif ($type eq 'reject') { } elsif ($type eq 'connect') { } elsif ($type eq 'dispatch') { - if ($message =~ /^dispatching MAIL FROM/i) { - my ($from) = $message =~ /<(.*?)>/; - $pids{$pid}{from} = $from; - } - elsif ($message =~ /^dispatching RCPT TO/i) { - my ($to) = $message =~ /<(.*?)>/; - $pids{$pid}{to} = $to; - } - elsif ($message =~ m/dispatching (EHLO|HELO) (.*)/) { - $pids{$pid}{helo_host} = $2; - } - elsif ($message eq 'dispatching DATA') { } - elsif ($message eq 'dispatching QUIT') { } - elsif ($message eq 'dispatching STARTTLS') { } - elsif ($message eq 'dispatching RSET') { - print_auto_format($pid, $line); - } - else { - # anything here is likely an unrecognized command - #print "$message\n"; - } + handle_dispatch($message,$pid,$line); } else { print "$type $pid $hook $plugin $message\n"; } } +sub get_default_field_widths { + my %widths = ( + ip => "%-15.15s", + hostname => "%-20.20s", + 'ident::geoip' => $opt_l ? "%-20.20s" : "%-6.6s", + 'ident::p0f' => "%-10.10s", + distance => "%5.5s", + count_unrecognized_commands => "%-5.5s", + unrecognized_commands => "%-5.5s", + connection_time => "%-4.4s", + ), + map { $_ => "%-3.3s" } + qw/ dnsbl rhsbl relay karma fcrdns earlytalker check_earlytalker helo + tls auth::auth_vpopmail auth::auth_vpopmaild auth::auth_vpopmail_sql + auth::auth_checkpassword badmailfrom check_badmailfrom + sender_permitted_from resolvable_fromhost dont_require_anglebrackets + queue::qmail-queue queue::smtp-forward /; + + return %widths; +}; + +sub handle_plugin { + my ($message, $plugin, $pid, $line) = @_; + return if $plugin eq 'naughty'; # housekeeping only + if (!$pids{$pid}{$plugin}) { # first entry for this plugin + $pids{$pid}{$plugin} = $message; + } + else { # subsequent log entry for this plugin + if ($pids{$pid}{$plugin} !~ /^(?:pass|fail|skip)/i) { + $pids{$pid}{$plugin} = $message; # overwrite 1st + } + else { + #print "ignoring subsequent hit on $plugin: $message\n"; + } + } + + if ($plugin eq 'ident::geoip') { + if (length $message < 3) { + $formats{'ident::geoip'} = "%-3.3s"; + $formats3{'ident::geoip'} = "%-3.3s"; + } + else { + my ($gip, $distance) = $message =~ /(.*?),\s+([\d]+)\skm/; + if ($distance) { + $pids{$pid}{$plugin} = $gip; + $pids{$pid}{distance} = $distance; + } + } + } +} + +sub handle_dispatch { + my ($message, $pid, $line) = @_; + if ($message =~ /^dispatching MAIL FROM/i) { + my ($from) = $message =~ /<(.*?)>/; + $pids{$pid}{from} = $from; + } + elsif ($message =~ /^dispatching RCPT TO/i) { + my ($to) = $message =~ /<(.*?)>/; + $pids{$pid}{to} = $to; + } + elsif ($message =~ m/dispatching (EHLO|HELO) (.*)/) { + $pids{$pid}{helo_host} = $2; + } + elsif ($message eq 'dispatching DATA') { } + elsif ($message eq 'dispatching QUIT') { } + elsif ($message eq 'dispatching STARTTLS') { } + elsif ($message eq 'dispatching RSET') { + print_auto_format($pid, $line); + } + else { + # anything here is likely an unrecognized command + #print "$message\n"; + } +} + sub parse_line { my $line = shift; my ($tai, $pid, $message) = split /\s+/, $line, 3; @@ -371,3 +360,77 @@ sub populate_plugins_from_registry { } } +__END__ + +=head1 NAME + +Summarize + +=head2 SYNOPSIS + +Parse the qpsmtpd logs and display a one line summary of each connection + +=head2 EXAMPLES + + ip dista geo p0f krm dbl rly dns ear HELO hlo tls MAIL FRO bmf rbl rfh spf RCPT TO bto qmd rok tim + 192.48.85.146 2705 NA, US FreeBSD 9. o o - o - tnpi.net o o 0.55 + 190.194.22.35 7925 SA, AR Windows 7 X X - X o a.net.ar x ogle.com o o o x *o*g@sim o o o 2.72 + 192.48.85.146 2705 NA, US - o o - o - tnpi.net o 0.41 + 181.164.160.98 8493 SA, AR Windows 7 X X - X o l.com.ar x ogle.com o o o x trapped@ o o o 2.61 + 188.79.146.22 8381 EU, ES Windows 7 o X - o o zztel.es o ogle.com o o o x *o**an@s o o o 3.02 + 188.79.146.22 8381 EU, ES Windows 7 o X - o o zztel.es o ogle.com o o o x *o**an@s o o o 2.58 + 188.79.146.22 8381 EU, ES Windows 7 o X - o o zztel.es o ogle.com o o o x *o**an@s o o o 2.70 + 190.194.22.35 7925 SA, AR Windows 7 X X - X o a.net.ar x ogle.com o o o x do*g@s*m o o o 2.60 + + ip dista geo p0f krm dbl rly dns ear HELO hlo tls MAIL FRO bmf rbl rfh spf RCPT TO bto qmd rok bog hdr dky dkm dmc spm dsp clm qqm tim + 192.48.85.146 2705 NA, US FreeBSD 9. o o - o - tnpi.net o o 1.36 + 192.48.85.146 2705 NA, US - o o - o - tnpi.net o 0.36 + 66.175.56.179 2313 NA, US Linux 2.6. o o - o - zone.com o o chem.com o o o - d**n@the o o o o o - o - - - - o 2.86 + 190.237.55.32 5411 SA, PE Windows 7 o X - X o gtsgnvnu x ryrk.net o o x - *an@s*rl o o o 3.54 + 192.48.85.146 2705 NA, US - o o - o - tnpi.net o 0.20 + 207.171.174.77 2700 NA, US o o - o - azon.com o azon.com o o o o *a*e@s*r o o o o o - o o o o o o 7.27 + 201.141.78.4 1487 NA, MX Windows XP o X - X o fmhufhjo x fdvx.net o o x - d**@si*e o o o 2.95 + 201.141.78.4 1487 NA, MX Windows XP X X - X o fmhufhjo x fdvx.net o o x - d**@s*rl o o o 2.42 + +The display autosizes to display disposition results for as many plugins as are emitting logs. The 3 char abbreviations are listed with their full plugin names in plugins/registry.txt. The GeoIP, p0f, HELO, FROM, and RCPT fields are compressed to fit on a typical display. If you have a wider display, use the -l option to display longer lines and more detail. + +Starting from left to right, in the first block, the results are interpreted as follows: + + geo - We see 2 connections from N. America, 3 from S. America, and 3 from Europe. + p0f - One system is running FreeBSD and the rest are running Windows 7. + krm - 3 of the connections will be rejected because of bad karma (sender history) + dbl - 7 are from IPs on DNS blacklists, an offense worth rejecting for. + rly - None of the IPs have relay permission. + dns - Only three senders have Forward Confirmed Reverse DNS + ear - two connections skipped testing (good karma), and the rest passed + hlo - three of the senders failed to present valid HELO hostnames + tls - one sender negotiated TLS + bmf - none of the senders presented a from address in our badmailfrom list + rbl - none of the sender domains are in a RHS blocking list + rfh - resolvable_from_host: all the sender domains resolve + spf - all but two connections fail SPF, meaning they are forging the envelope sender identity + bto - badmailto: none of the recipients are in our badmailto list + qmd - qmail_deliverable: the recipients are valid addresses on our system + rok - the recipient domain is on our system + tim - the number of seconds the connection was active + +In the second block, we have two messages that were ultimately delivered. + + bog - no messages were bogus bounces + hdr - the messages had valid headers + dky - the messages were not DomainKeys signed + dkm - two messages were DKIM signed and passed validation + dmc - the message from amazon.com passed DMARC validation + spm - spamassassin, one skipped processing, one passed + dsp - dspam, one skipped, one passed + clm - clamav, one skipped, one passed + qqm - qmail queue, two messages were delivered + +In the first block of entries, not a single connection made it past the DATA phase of the SMTP conversation, where the content tests kick in. Other interesting observations are that many connections purport to be from Google. Ah, you say, but does Google have Windows mail servers in Estonia? If we look over to the SPF column, the lower case x is telling us that it failed SPF tests, meaning Google has explicitely told us that IP is not theirs. Instead of rejecting immediately, the SPF plugin deferred the rejection to B to disconnect later. + +=head1 AUTHOR + +Matt Simerson + +=cut + From 51645b856452e1f92ddcaf928d04d1709c20bf70 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 26 Apr 2013 01:53:37 -0400 Subject: [PATCH 308/352] updated Changes --- Changes | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/Changes b/Changes index d5b50ca..01053b6 100644 --- a/Changes +++ b/Changes @@ -4,7 +4,12 @@ new plugins: dmarc, fcrdns new feature: DKIM message signing. See 'perldoc plugins/dkim' for details. - includes script for generating DKIM selectors, keys, and DNS records + includes script for generating DKIM selectors, keys, and DNS records. + RAM bumped up to 300MB, to avoid memory exhaustion errors. + + Qpsmtpd.pm: untaint config options before passing them to plugins. + + auth_vpopmaild: untaint responses obtained from network. Combined with the taint fix for config options, enables auth_vpopmaild to work when setting the host config and port tls: added ability to store SSL keys in config/ssl @@ -27,6 +32,9 @@ Fix for Net::DNS break - Markus Ullmann + SPF: arrange logic to so improve reliability of spf pass reporting (helpful to DMARC plugin) + + is_naughty removed from is_immune feature. Allows more granular handling by plugins. 0.91 Nov 20, 2012 From 5eab7393590fad8c5c6b9e8134c837593e4e7362 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 26 Apr 2013 03:35:02 -0400 Subject: [PATCH 309/352] SMTP.pm: reduce auth details from Received header. based on patch from Devin Carraway http://www.nntp.perl.org/group/perl.qpsmtpd/2012/08/msg9954.html --- META.yml | 33 +++++++++++++++++++++++++++++++++ lib/Qpsmtpd/SMTP.pm | 2 +- 2 files changed, 34 insertions(+), 1 deletion(-) create mode 100644 META.yml diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..69d9edd --- /dev/null +++ b/META.yml @@ -0,0 +1,33 @@ +--- +abstract: 'Flexible smtpd daemon written in Perl' +author: + - 'Ask Bjoern Hansen ' +build_requires: + ExtUtils::MakeMaker: 0 +configure_requires: + ExtUtils::MakeMaker: 0 +dynamic_config: 0 +generated_by: 'ExtUtils::MakeMaker version 6.64, CPAN::Meta::Converter version 2.120921' +license: unknown +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: 1.4 +name: qpsmtpd +no_index: + directory: + - t + - inc +requires: + Data::Dumper: 0 + Date::Parse: 0 + File::Tail: 0 + File::Temp: 0 + IO::Socket::SSL: 0 + MIME::Base64: 0 + Mail::DKIM: 0 + Mail::Header: 0 + Net::DNS: 0.39 + Net::IP: 0 + Time::HiRes: 0 + Time::TAI64: 0 +version: 0.91 diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index a74dead..40d8b38 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -824,7 +824,7 @@ sub received_line { . " (HELO " . $self->connection->hello_host . ") (" . $self->connection->remote_ip - . ")\n $authheader by " + . ")\n by " . $self->config('me') . " (qpsmtpd/" . $self->version From 9d74793b241aaf8e13afe774523a52c88661c963 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 26 Apr 2013 03:36:34 -0400 Subject: [PATCH 310/352] MANIFEST: updated with run.* files --- MANIFEST | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/MANIFEST b/MANIFEST index 4e7276f..41ae730 100644 --- a/MANIFEST +++ b/MANIFEST @@ -157,7 +157,8 @@ qpsmtpd-forkserver qpsmtpd-prefork README README.plugins -run +run.forkserver +run.tcpserver STATUS t/addresses.t t/auth.t From ebe72f6c5bd5ebc88decd8421f28e7473ff66815 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 29 Apr 2013 18:58:57 -0700 Subject: [PATCH 311/352] added daemontools, ucspi-tcp to install list --- bin/install_deps.pl | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/bin/install_deps.pl b/bin/install_deps.pl index b825e73..c69797d 100755 --- a/bin/install_deps.pl +++ b/bin/install_deps.pl @@ -27,7 +27,10 @@ use CPAN; use English qw( -no_match_vars ); my $apps = [ -# { app => 'mysql-server-5', info => { port => 'mysql50-server', dport=>'mysql5', yum =>'mysql-server'} }, + { app => 'daemontools', info => { } }, + { app => 'ucspi-tcp', info => { } }, +# { app => 'dspam', info => { } }, +# { app => 'mysql-server-55', info => { port => 'mysql55-server', dport=>'mysql5', yum =>'mysql-server'} }, # { app => 'apache22' , info => { port => 'apache22', dport=>'', yum => 'httpd' } }, ]; @@ -388,7 +391,8 @@ sub name_overrides { # MacPorts ($dport), yum, and apt. my @modules = ( { module=>'LWP::UserAgent', info => { cat=>'www', port=>'p5-libwww', dport=>'p5-libwww-perl' }, }, - { module=>'Mail::Send' , info => { port => 'Mail::Tools', } }, + { module=>'Mail::Send' , info => { port => 'Mail::Tools', } }, + { module=>'Mail::SpamAssassin' , info => { cat => 'mail', } }, ); my ($match) = grep { $_->{module} eq $mod } @modules; return $match if $match; From e7b72775f99e463dbd82a76e9b13e03bd39690e8 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 29 Apr 2013 19:01:00 -0700 Subject: [PATCH 312/352] spf enabled in config/plugins by default the plugin will detect if Mail::SPF is missing and not register it's hooks --- config.sample/plugins | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/config.sample/plugins b/config.sample/plugins index bb15895..582a4fe 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -59,7 +59,7 @@ dont_require_anglebrackets badmailfrom reject naughty #badmailfromto resolvable_fromhost reject 0 -# sender_permitted_from reject 2 +sender_permitted_from reject 1 # RCPT TO plugins badrcptto @@ -105,6 +105,9 @@ naughty reject data # queue the mail with qmail-queue # queue/qmail-queue +# forward to another mail server +# queue/smtp-forward 10.2.2.2 9025 + # If you need to run the same plugin multiple times, you can do # something like the following From cc6ab494741a5448c0e5c89279395e6ab9232d6d Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 29 Apr 2013 22:06:47 -0400 Subject: [PATCH 313/352] raised default max msg size in clamdscan from 128k added max_size on config, so it's likely to get noticed, since even 1M is probably too low for most sites. This should likely default to the same as databytes? --- config.sample/plugins | 4 +- plugins/dmarc | 4 +- plugins/dont_require_anglebrackets | 2 + plugins/headers | 69 ++++++++++++++++++++++-------- plugins/helo | 6 +++ plugins/karma | 45 ++++++++++++++++--- plugins/virus/clamdscan | 4 +- 7 files changed, 104 insertions(+), 30 deletions(-) diff --git a/config.sample/plugins b/config.sample/plugins index 582a4fe..46e75d6 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -91,9 +91,9 @@ spamassassin reject 12 # dspam must run after spamassassin for the learn_from_sa feature to work dspam autolearn spamassassin reject 0.95 -# run the clamav virus checking plugin +# run the clamav virus checking plugin (max size in Kb) # virus/clamav -# virus/clamdscan deny_viruses yes scan_all 1 +# virus/clamdscan deny_viruses yes max_size 1024 naughty reject data diff --git a/plugins/dmarc b/plugins/dmarc index a44c6d6..3f5eab8 100644 --- a/plugins/dmarc +++ b/plugins/dmarc @@ -64,7 +64,9 @@ https://github.com/qpsmtpd-dev/qpsmtpd-dev/wiki/DMARC-FAQ =head1 TODO - 2. provide dmarc feedback to domains that request it + provide dmarc feedback to domains that request it + + reject messages with multiple From: headers =head1 AUTHORS diff --git a/plugins/dont_require_anglebrackets b/plugins/dont_require_anglebrackets index b81df88..c8f25fd 100644 --- a/plugins/dont_require_anglebrackets +++ b/plugins/dont_require_anglebrackets @@ -26,6 +26,7 @@ sub hook_mail_pre { unless ($addr =~ /^<.*>$/) { $self->log(LOGINFO, "added MAIL angle brackets"); $addr = '<' . $addr . '>'; + $self->adjust_karma(-1); } return (OK, $addr); } @@ -35,6 +36,7 @@ sub hook_rcpt_pre { unless ($addr =~ /^<.*>$/) { $self->log(LOGINFO, "added RCPT angle brackets"); $addr = '<' . $addr . '>'; + $self->adjust_karma(-1); } return (OK, $addr); } diff --git a/plugins/headers b/plugins/headers index 8dd0220..9c7be78 100644 --- a/plugins/headers +++ b/plugins/headers @@ -77,6 +77,12 @@ Default: perm Adjust the quantity of logging for this plugin. See docs/logging.pod +=head1 TODO + +=head1 SEE ALSO + +https://tools.ietf.org/html/rfc5322 + =head1 AUTHOR 2012 - Matt Simerson @@ -130,36 +136,59 @@ sub hook_data_post { return $self->get_reject("Headers are missing", "missing headers"); }; - return (DECLINED, "immune") if $self->is_immune(); + return DECLINED if $self->is_immune(); - foreach my $h (@required_headers) { - next if $header->get($h); - $self->adjust_karma(-1); - 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 - $self->adjust_karma(-1); - return - $self->get_reject( - "Only one $h header allowed. See RFC 5322, Section 3.6", - "too many $h headers",); - } + my $errors = $self->has_required_headers( $header ); + $errors += $self->has_singular_headers( $header ); my $err_msg = $self->invalid_date_range(); if ($err_msg) { - $self->adjust_karma(-1); return $self->get_reject($err_msg, $err_msg); } + if ( $errors ) { + return $self->get_reject($self->get_reject_type(), + "RFC 5322 validation errors" ); + }; + $self->log(LOGINFO, 'pass'); return (DECLINED); } +sub has_required_headers { + my ($self, $header) = @_; + + my $errors; + foreach my $h (@required_headers) { + next if $header->get($h); + $errors++; + $self->adjust_karma(-1); + $self->is_naughty(1) if $self->{args}{reject}; + $self->store_deferred_reject("We require a valid $h header"); + $self->log(LOGINFO, "fail, no $h header" ); + } + return $errors; +}; + +sub has_singular_headers { + my ($self, $header) = @_; + + my $errors; + 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 + $errors++; + $self->adjust_karma(-1); + $self->is_naughty(1) if $self->{args}{reject}; + $self->store_deferred_reject( + "Only one $h header allowed. See RFC 5322, Section 3.6", + ); + $self->log(LOGINFO, "fail, too many $h headers" ); + } + return $errors; +}; + sub invalid_date_range { my $self = shift; @@ -175,12 +204,14 @@ sub invalid_date_range { my $past = $self->{_args}{past}; if ($past && $ts < time - ($past * 24 * 3600)) { $self->log(LOGINFO, "fail, date too old ($date)"); + $self->adjust_karma(-1); 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)"); + $self->adjust_karma(-1); return "The Date header is too far in the future"; } diff --git a/plugins/helo b/plugins/helo index 0123471..d6ab0b5 100644 --- a/plugins/helo +++ b/plugins/helo @@ -203,6 +203,12 @@ this prohibition applies to the matching of the parameter to its IP address only; see Section 7.9 for a more extensive discussion of rejecting incoming connections or mail messages. +=head1 TODO + +is_forged_literal, if the forged IP is an internal IP, it's likely one +of our clients that should have authenticated. Perhaps when we check back +later in data_post, if they have added relay_client, then give back the +karma. =head1 AUTHOR diff --git a/plugins/karma b/plugins/karma index a8f2dd6..4dd0437 100644 --- a/plugins/karma +++ b/plugins/karma @@ -244,6 +244,7 @@ sub register { #$self->prune_db(); # keep the DB compact $self->register_hook('connect', 'connect_handler'); + $self->register_hook('mail_pre', 'from_handler'); $self->register_hook('rcpt_pre', 'rcpt_handler'); $self->register_hook('data', 'data_handler'); $self->register_hook('data_post', 'data_handler'); @@ -271,7 +272,7 @@ sub hook_pre_connection { } my ($penalty_start_ts, $naughty, $nice, $connects) = - $self->parse_value($tied->{$key}); + $self->parse_db_record($tied->{$key}); $self->calc_karma($naughty, $nice); return $self->cleanup_and_return($tied, $lock); } @@ -297,7 +298,7 @@ sub connect_handler { } my ($penalty_start_ts, $naughty, $nice, $connects) = - $self->parse_value($tied->{$key}); + $self->parse_db_record($tied->{$key}); my $summary = "$naughty naughty, $nice nice, $connects connects"; my $karma = $self->calc_karma($naughty, $nice); @@ -321,25 +322,47 @@ sub connect_handler { return $self->get_reject($mess, $karma); } +sub from_handler { + my ($self, $transaction, $addr) = @_; + +# test if sender has placed an illegal (RFC (2)821) space in envelope from + my $full_from = $self->connection->notes('envelope_from'); + $self->illegal_envelope_format( $full_from ); + + return DECLINED; +}; + sub rcpt_handler { my ($self, $transaction, $addr) = @_; + $self->illegal_envelope_format( + $self->connection->notes('envelope_rcpt'), + ); + + my $count = $self->connection->notes('recipient_count') || 0; + $count++; + if ( $count > 1 ) { + $self->log(LOGINFO, "recipients c: $count ($addr)"); + $self->connection->notes('recipient_count', $count); + }; + return DECLINED if $self->is_immune(); my $recipients = scalar $self->transaction->recipients or do { $self->log(LOGDEBUG, "info, no recipient count"); return DECLINED; }; + $self->log(LOGINFO, "recipients t: $recipients ($addr)"); my $history = $self->connection->notes('karma_history'); if ( $history > 0 ) { - $self->log(LOGDEBUG, "info, good history"); + $self->log(LOGINFO, "info, good history"); return DECLINED; }; my $karma = $self->connection->notes('karma'); if ( $karma > 0 ) { - $self->log(LOGDEBUG, "info, good connection"); + $self->log(LOGINFO, "info, good connection"); return DECLINED; }; @@ -376,7 +399,7 @@ sub disconnect_handler { my $key = $self->get_db_key(); my ($penalty_start_ts, $naughty, $nice, $connects) = - $self->parse_value($tied->{$key}); + $self->parse_db_record($tied->{$key}); my $history = ($nice || 0) - $naughty; my $log_mess = ''; @@ -410,7 +433,17 @@ sub disconnect_handler { return $self->cleanup_and_return($tied, $lock); } -sub parse_value { +sub illegal_envelope_format { + my ($self, $addr) = @_; + +# test if envelope address has an illegal (RFC (2)821) space + if ( uc substr($addr,0,6) ne 'FROM:<' && uc substr($addr,0,4) ne 'TO:<' ) { + $self->log(LOGINFO, "illegal envelope address format: $addr" ); + $self->adjust_karma(-1); + }; +}; + +sub parse_db_record { my ($self, $value) = @_; my $penalty_start_ts = my $naughty = my $nice = my $connects = 0; diff --git a/plugins/virus/clamdscan b/plugins/virus/clamdscan index 00feaae..246cb1e 100644 --- a/plugins/virus/clamdscan +++ b/plugins/virus/clamdscan @@ -123,8 +123,8 @@ sub register { # Set some sensible defaults $self->{'_args'}{'deny_viruses'} ||= 'yes'; - $self->{'_args'}{'max_size'} ||= 128; - $self->{'_args'}{'scan_all'} ||= 0; + $self->{'_args'}{'max_size'} ||= 1024; + $self->{'_args'}{'scan_all'} ||= 1; for my $setting ('deny_viruses', 'defer_on_error') { next unless $self->{'_args'}{$setting}; if (lc $self->{'_args'}{$setting} eq 'no') { From cf5f1bb9afe7231e6ef1ee511c404817e79bc392 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 29 Apr 2013 22:40:07 -0400 Subject: [PATCH 314/352] summarize: fix syntax error --- log/summarize | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/log/summarize b/log/summarize index a0066f1..1c85070 100755 --- a/log/summarize +++ b/log/summarize @@ -91,13 +91,13 @@ sub get_default_field_widths { count_unrecognized_commands => "%-5.5s", unrecognized_commands => "%-5.5s", connection_time => "%-4.4s", - ), map { $_ => "%-3.3s" } qw/ dnsbl rhsbl relay karma fcrdns earlytalker check_earlytalker helo tls auth::auth_vpopmail auth::auth_vpopmaild auth::auth_vpopmail_sql auth::auth_checkpassword badmailfrom check_badmailfrom sender_permitted_from resolvable_fromhost dont_require_anglebrackets - queue::qmail-queue queue::smtp-forward /; + queue::qmail-queue queue::smtp-forward / + ); return %widths; }; From 9c095ab2780746d9740c42a3fcd4a319bb346e3c Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 29 Apr 2013 23:49:22 -0400 Subject: [PATCH 315/352] is_naughty is a setter now too --- lib/Qpsmtpd/Plugin.pm | 7 ++++++- plugins/dnsbl | 2 +- plugins/dspam | 6 ++---- plugins/virus/clamdscan | 6 +++--- 4 files changed, 12 insertions(+), 9 deletions(-) diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm index a72cc86..026ffc3 100644 --- a/lib/Qpsmtpd/Plugin.pm +++ b/lib/Qpsmtpd/Plugin.pm @@ -307,7 +307,12 @@ sub is_immune { } sub is_naughty { - my $self = shift; + my ($self, $setit) = @_; + + if ( defined $setit ) { + $self->connection->notes('naughty', $setit); + $self->connection->notes('rejected', $setit); + }; if ($self->connection->notes('naughty')) { diff --git a/plugins/dnsbl b/plugins/dnsbl index 4f48270..a7b11b6 100644 --- a/plugins/dnsbl +++ b/plugins/dnsbl @@ -294,7 +294,7 @@ sub hook_rcpt { "skip, don't blacklist special account: " . $rcpt->user); # clear the naughty connection note here, if desired. - $self->connection->notes('naughty', 0); + $self->is_naughty(0); } return DECLINED; diff --git a/plugins/dspam b/plugins/dspam index 39849a9..e9f8be6 100644 --- a/plugins/dspam +++ b/plugins/dspam @@ -661,9 +661,7 @@ sub autolearn_naughty { return; } - if ( $self->connection->notes('naughty') - && $response->{result} eq 'Innocent') - { + if ( $self->is_naughty() && $response->{result} eq 'Innocent') { $self->log(LOGINFO, "training naughty FN message as spam"); $self->train_error_as_spam($transaction); return 1; @@ -707,7 +705,7 @@ sub autolearn_spamassassin { my $sa = $transaction->notes('spamassassin'); if (!$sa || !$sa->{is_spam}) { - if (!$self->connection->notes('naughty')) { + if (!$self->is_naughty()) { $self->log(LOGERROR, "SA results missing"); # SA skips naughty } return; diff --git a/plugins/virus/clamdscan b/plugins/virus/clamdscan index 246cb1e..2928665 100644 --- a/plugins/virus/clamdscan +++ b/plugins/virus/clamdscan @@ -92,8 +92,8 @@ adjusted for ClamAV::Client by Devin Carraway . =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005 John Peacock, -Copyright (c) 2007 Devin Carraway + Copyright (c) 2005 John Peacock, + Copyright (c) 2007 Devin Carraway Based heavily on the clamav plugin @@ -167,7 +167,7 @@ sub data_post_handler { if ($found) { $self->log(LOGNOTICE, "fail, found virus $found"); - $self->connection->notes('naughty', 1); # see plugins/naughty + $self->is_naughty(1); # see plugins/naughty $self->adjust_karma(-1); if ($self->{_args}{deny_viruses}) { From 55388248e44b8096aa55c811737ef48816ce78a3 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 29 Apr 2013 23:50:18 -0400 Subject: [PATCH 316/352] store envelope from and to in connection notes --- lib/Qpsmtpd/SMTP.pm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index 40d8b38..b5bb500 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -354,6 +354,7 @@ sub mail { } $self->log(LOGDEBUG, "full from_parameter: $line"); + $self->connection->notes('envelope_from', $line); $self->run_hooks("mail_parse", $line); } @@ -442,6 +443,7 @@ sub mail_respond { sub rcpt { my ($self, $line) = @_; + $self->connection->notes('envelope_rcpt', $line); $self->run_hooks("rcpt_parse", $line); } @@ -466,7 +468,7 @@ sub rcpt_parse_respond { # (... 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... + # by removing the trailing dot or space from this example. $self->run_hooks("rcpt_pre", $rcpt, \%param); } From 2a617462118db5f7a2d0f5b2fa340786a4789898 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 29 Apr 2013 23:51:35 -0400 Subject: [PATCH 317/352] headers: assign zeroes to avoid undef errors --- plugins/headers | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/plugins/headers b/plugins/headers index 9c7be78..1465e67 100644 --- a/plugins/headers +++ b/plugins/headers @@ -138,7 +138,7 @@ sub hook_data_post { return DECLINED if $self->is_immune(); - my $errors = $self->has_required_headers( $header ); + my $errors = $self->has_required_headers( $header ) || 0; $errors += $self->has_singular_headers( $header ); my $err_msg = $self->invalid_date_range(); @@ -158,7 +158,7 @@ sub hook_data_post { sub has_required_headers { my ($self, $header) = @_; - my $errors; + my $errors = 0; foreach my $h (@required_headers) { next if $header->get($h); $errors++; @@ -173,7 +173,7 @@ sub has_required_headers { sub has_singular_headers { my ($self, $header) = @_; - my $errors; + my $errors = 0; foreach my $h (@singular_headers) { next if !$header->get($h); # doesn't exist my @qty = $header->get($h); From c80bcf8e47e75255997821d4bd6c0888321d32d1 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Tue, 30 Apr 2013 00:28:08 -0400 Subject: [PATCH 318/352] Makefile.PL: added commented Math::Complex --- Makefile.PL | 1 + 1 file changed, 1 insertion(+) diff --git a/Makefile.PL b/Makefile.PL index 3821b0d..2037fd5 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -26,6 +26,7 @@ WriteMakefile( # modules that cause Travis build tests to fail # 'Mail::SpamAssassin' => 0, # 'Geo::IP' => 0, +# 'Math::Complex' => 0, # geodesic distance in Geo::IP # 'Mail::SPF' => 0, }, ABSTRACT => 'Flexible smtpd daemon written in Perl', From 3973f9ae800ea617c6b85d9db8c0907ba54f965b Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 1 May 2013 00:35:49 -0700 Subject: [PATCH 319/352] added Authentication-Results header, with provider dkim, dmarc, fcrdns (iprev), spf, and smtp-auth --- lib/Qpsmtpd/Plugin.pm | 28 +++++++++++++++ lib/Qpsmtpd/SMTP.pm | 24 ++++++++++--- plugins/dkim | 11 +++--- plugins/dmarc | 17 ++++++--- plugins/fcrdns | 66 ++++++++++++++++++++++++++++++----- plugins/sender_permitted_from | 6 ++-- 6 files changed, 123 insertions(+), 29 deletions(-) diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm index 026ffc3..177d237 100644 --- a/lib/Qpsmtpd/Plugin.pm +++ b/lib/Qpsmtpd/Plugin.pm @@ -271,6 +271,34 @@ sub store_deferred_reject { return (DECLINED); } +sub store_auth_results { + my ($self, $value) = @_; + + my @headers = $self->transaction->header->get('Authentication-Results'); + chomp @headers; + my @deleteme; + for ( my $i = 0; $i < scalar @headers; $i++ ) { + my @values = split /;/, $headers[$i]; + if ( $self->config->('me') ne $values[0] ) { # some other MTA +# we generally want to remove Authentication-Results headers added by other +# MTAs (so our downstream can trust the A-R header we insert), but we also +# don't want to invalidate DKIM signatures. +# TODO: parse the DKIM signature(s) to see if A-R header is signed + if ( ! $self->transaction->header->get('DKIM-Signature') ) { + $self->log(LOGINFO, "deleted auth-results from $_"); + push @deleteme, $i; + }; + next; + }; + push @values, $value; + $self->log(LOGINFO, "appended to auth-results: $value"); + $self->transaction->header->replace('Authentication->Results', join('; ', @values ), $i); + } + foreach ( @deleteme ) { + $self->transaction->header->delete('Authentication-Results', $_); + }; +}; + sub init_resolver { my $self = shift; my $timeout = $self->{_args}{dns_timeout} || shift || 5; diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index b5bb500..fd7c44d 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -770,6 +770,7 @@ sub data_respond { my $esmtp = substr($smtp, 0, 1) eq "E"; my $authheader = ''; my $sslheader = ''; + my $auth_result = 'none'; if (defined $self->connection->notes('tls_enabled') and $self->connection->notes('tls_enabled')) @@ -780,15 +781,28 @@ sub data_respond { . " 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"; + if (defined $self->{_auth} ) { + my $mech = $self->{_auth_mechanism}; + my $user = $self->{_auth_user}; + $auth_result = "auth="; + if ( $self->{_auth} == OK) { + $smtp .= "A" if $esmtp; # RFC3848 + $authheader = "(smtp-auth username $user, mechanism $mech)\n"; + $auth_result .= 'pass'; + } + else { + $auth_result .= 'fail'; + }; + $auth_result .= " ($mech) smtp.auth=$user"; } - $header->add("Received", + $header->add('Received', $self->received_line($smtp, $authheader, $sslheader), 0); + # RFC 5451: used in AUTH, DKIM, DOMAINKEYS, SENDERID, SPF + $header->add('Authentication-Results', + join('; ', $self->config('me'), $auth_result ) ); + # if we get here without seeing a terminator, the connection is # probably dead. unless ($complete) { diff --git a/plugins/dkim b/plugins/dkim index 13815a1..1866b25 100644 --- a/plugins/dkim +++ b/plugins/dkim @@ -222,6 +222,9 @@ sub validate_it { my $result = $dkim->result; my $mess = $self->get_details($dkim); + $self->store_auth_results("dkim=" .$dkim->result_detail . " header.i=@".$dkim->signature->domain); + #$self->add_header($mess); + foreach my $t (qw/ pass fail invalid temperror none /) { next if $t ne $result; my $handler = 'handle_sig_' . $t; @@ -286,8 +289,7 @@ sub handle_sig_fail { my ($self, $dkim, $mess) = @_; $self->adjust_karma(-1); - return - $self->get_reject("DKIM signature invalid: " . $dkim->result_detail, + return $self->get_reject("signature invalid: " . $dkim->result_detail, $mess); } @@ -316,12 +318,10 @@ sub handle_sig_invalid { $self->log(LOGINFO, $mess); if ($prs->{accept}) { - $self->add_header($mess); $self->log(LOGERROR, "error, invalid signature but accept policy!?"); return DECLINED; } elsif ($prs->{neutral}) { - $self->add_header($mess); $self->log(LOGERROR, "error, invalid signature but neutral policy?!"); return DECLINED; } @@ -333,7 +333,6 @@ sub handle_sig_invalid { # this should never happen $self->log(LOGINFO, "error, invalid signature, unhandled"); - $self->add_header($mess); return DECLINED; } @@ -527,8 +526,6 @@ sub get_selector { sub add_header { my $self = shift; my $header = shift or return; - - # consider adding Authentication-Results header, (RFC 5451) $self->qp->transaction->header->add('X-DKIM-Authentication', $header, 0); } diff --git a/plugins/dmarc b/plugins/dmarc index 3f5eab8..cd40ec0 100644 --- a/plugins/dmarc +++ b/plugins/dmarc @@ -122,24 +122,31 @@ sub data_post_handler { # evaluation returned a "pass" result. my $spf_dom = $transaction->notes('spf_pass_host'); + my $effective_policy = ( $self->{_args}{is_subdomain} && defined $policy->{sp} ) + ? $policy->{sp} : $policy->{p}; + # 5. Conduct identifier alignment checks. - return DECLINED - if $self->is_aligned($from_dom, $org_dom, $policy, $spf_dom ); + if ( $self->is_aligned($from_dom, $org_dom, $policy, $spf_dom ) ) { + $self->store_auth_results("dmarc=pass (p=$effective_policy) d=$from_dom"); + return DECLINED; + }; # 6. Apply policy. Emails that fail the DMARC mechanism check are # disposed of in accordance with the discovered DMARC policy of the # Domain Owner. See Section 6.2 for details. - if ( $self->{_args}{is_subdomain} && defined $policy->{sp} ) { - return DECLINED if lc $policy->{sp} eq 'none'; + if ( lc $effective_policy eq 'none' ) { + $self->store_auth_results("dmarc=fail (p=none) d=$from_dom"); + return DECLINED; }; - return DECLINED if lc $policy->{p} eq 'none'; my $pct = $policy->{pct} || 100; if ( $pct != 100 && int(rand(100)) >= $pct ) { $self->log("fail, tolerated, policy, sampled out"); + $self->store_auth_results("dmarc=sampled_out (p=$effective_policy) d=$from_dom"); return DECLINED; }; + $self->store_auth_results("dmarc=fail (p=$effective_policy) d=$from_dom"); return $self->get_reject("failed DMARC policy"); } diff --git a/plugins/fcrdns b/plugins/fcrdns index b8190e4..2cc2009 100644 --- a/plugins/fcrdns +++ b/plugins/fcrdns @@ -6,7 +6,7 @@ Forward Confirmed RDNS - http://en.wikipedia.org/wiki/FCrDNS =head1 DESCRIPTION -Determine if the SMTP sender has matching forward and reverse DNS. +Determine if the SMTP sender has matching forward and reverse DNS. Sets the connection note fcrdns. @@ -88,6 +88,38 @@ From Wikipedia summary: 3. Any A or AAAA record returned by the second query is then compared against the original IP address (check_ip_match), and if there is a match, then the FCrDNS check passes. +=head1 iprev + +# https://www.ietf.org/rfc/rfc5451.txt + +2.4.3. "iprev" Results + +The result values are used by the "iprev" method, defined in +Section 3, are as follows: + +pass: The DNS evaluation succeeded, i.e., the "reverse" and +"forward" lookup results were returned and were in agreement. + +fail: The DNS evaluation failed. In particular, the "reverse" and +"forward" lookups each produced results but they were not in +agreement, or the "forward" query completed but produced no +result, e.g., a DNS RCODE of 3, commonly known as NXDOMAIN, or an +RCODE of 0 (NOERROR) in a reply containing no answers, was +returned. + +temperror: The DNS evaluation could not be completed due to some +error that is likely transient in nature, such as a temporary DNS +error, e.g., a DNS RCODE of 2, commonly known as SERVFAIL, or +other error condition resulted. A later attempt may produce a +final result. + +permerror: The DNS evaluation could not be completed because no PTR +data are published for the connecting IP address, e.g., a DNS +RCODE of 3, commonly known as NXDOMAIN, or an RCODE of 0 (NOERROR) +in a reply containing no answers, was returned. This prevented +completion of the evaluation. + +=cut =head1 AUTHOR @@ -136,9 +168,8 @@ sub connect_handler { sub data_post_handler { my ($self, $transaction) = @_; - - my $match = $self->connection->notes('fcrdns_match') || 0; - $transaction->header->add('X-Fcrdns', $match ? 'Yes' : 'No', 0); + my $match = $self->connection->notes('fcrdns_match') || 'error'; + $self->store_auth_results("iprev=$match"); return (DECLINED); } @@ -182,13 +213,25 @@ sub has_reverse_dns { my $res = $self->init_resolver(); my $ip = $self->qp->connection->remote_ip; - my $query = $res->query($ip) or do { + my $query = $res->query($ip, 'PTR') or do { if ($res->errorstring eq 'NXDOMAIN') { $self->adjust_karma(-1); + $self->connection->notes('fcrdns_match', 'permerror'); $self->log(LOGINFO, "fail, no rDNS: " . $res->errorstring); return; } - $self->log(LOGINFO, "fail, error getting rDNS: " . $res->errorstring); + if ( $res->errorstring eq 'SERVFAIL' ) { + $self->log(LOGINFO, "fail, error getting rDNS: " . $res->errorstring); + $self->connection->notes('fcrdns_match', 'temperror'); + } + elsif ( $res->errorstring eq 'NOERROR' ) { + $self->log(LOGINFO, "fail, no PTR (NOERROR)" ); + $self->connection->notes('fcrdns_match', 'permerror'); + } + else { + $self->connection->notes('fcrdns_match', 'fail'); + $self->log(LOGINFO, "fail, error getting rDNS: " . $res->errorstring); + }; return; }; @@ -203,6 +246,7 @@ sub has_reverse_dns { if (!$hits) { $self->adjust_karma(-1); $self->log(LOGINFO, "fail, no PTR records"); + $self->connection->notes('fcrdns_match', 'permerror'); return; } @@ -218,11 +262,13 @@ sub has_forward_dns { foreach my $host (keys %{$self->{_args}{ptr_hosts}}) { $host .= '.' if '.' ne substr($host, -1, 1); # fully qualify name - my $query = $res->search($host) or do { + my $query = $res->query($host) or do { if ($res->errorstring eq 'NXDOMAIN') { + $self->connection->notes('fcrdns_match', 'permerror'); $self->log(LOGDEBUG, "host $host does not exist"); next; } + $self->connection->notes('fcrdns_match', 'fail'); $self->log(LOGDEBUG, "query for $host failed (", $res->errorstring, ")"); next; @@ -235,11 +281,13 @@ sub has_forward_dns { $self->check_ip_match($rr->address) and return 1; } if ($hits) { + $self->connection->notes('fcrdns_match', 'fail'); $self->log(LOGDEBUG, "PTR host has forward DNS") if $hits; return 1; } } $self->adjust_karma(-1); + $self->connection->notes('fcrdns_match', 'fail'); $self->log(LOGINFO, "fail, no PTR hosts have forward DNS"); return; } @@ -250,7 +298,7 @@ sub check_ip_match { if ($ip eq $self->qp->connection->remote_ip) { $self->log(LOGDEBUG, "forward ip match"); - $self->connection->notes('fcrdns_match', 1); + $self->connection->notes('fcrdns_match', 'pass'); $self->adjust_karma(1); return 1; } @@ -262,7 +310,7 @@ sub check_ip_match { if ($dns_net eq $rem_net) { $self->log(LOGNOTICE, "forward network match"); - $self->connection->notes('fcrdns_match', 1); + $self->connection->notes('fcrdns_match', 'pass'); return 1; } return; diff --git a/plugins/sender_permitted_from b/plugins/sender_permitted_from index e80b4e4..1f16a8d 100644 --- a/plugins/sender_permitted_from +++ b/plugins/sender_permitted_from @@ -133,10 +133,12 @@ sub mail_handler { return (DECLINED, "SPF - no response"); } + $self->store_auth_results("spf=$code smtp.mailfrom=".$sender->host); + if ($code eq 'pass') { $self->adjust_karma(1); $transaction->notes('spf_pass_host', lc $sender->host); - $self->log(LOGINFO, "pass, $code: $why"); + $self->log(LOGINFO, "pass, $why"); return (DECLINED); } @@ -235,8 +237,6 @@ sub data_post_handler { $transaction->header->add('Received-SPF', $result->received_spf_header, 0); - # consider also adding SPF status to Authentication-Results header - return DECLINED; } From a6b563a40c0319eb2d929c4e780600d91faeeaa1 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Thu, 2 May 2013 03:30:48 -0400 Subject: [PATCH 320/352] tested and working Authentication-Results changed the method of saving results. Instead of appending to/from a header, plugins save results to a connection note. Qpsmtpd::SMTP.pm has a new method that inserts the Authentication-Results header The smtp-auth information has been removed from the Received header Authentication-Results providing plugins have been updated to store results in connection note --- lib/Qpsmtpd.pm | 2 +- lib/Qpsmtpd/Plugin.pm | 31 +++--------- lib/Qpsmtpd/SMTP.pm | 111 +++++++++++++++++++++++++++--------------- plugins/dkim | 6 ++- plugins/domainkeys | 7 ++- plugins/fcrdns | 32 +++++------- 6 files changed, 101 insertions(+), 88 deletions(-) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index da36d68..fc41789 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -7,7 +7,7 @@ use Qpsmtpd::Constants; #use DashProfiler; -$VERSION = "0.92"; +$VERSION = "0.93"; my $git; diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm index 177d237..9693524 100644 --- a/lib/Qpsmtpd/Plugin.pm +++ b/lib/Qpsmtpd/Plugin.pm @@ -272,31 +272,14 @@ sub store_deferred_reject { } sub store_auth_results { - my ($self, $value) = @_; - - my @headers = $self->transaction->header->get('Authentication-Results'); - chomp @headers; - my @deleteme; - for ( my $i = 0; $i < scalar @headers; $i++ ) { - my @values = split /;/, $headers[$i]; - if ( $self->config->('me') ne $values[0] ) { # some other MTA -# we generally want to remove Authentication-Results headers added by other -# MTAs (so our downstream can trust the A-R header we insert), but we also -# don't want to invalidate DKIM signatures. -# TODO: parse the DKIM signature(s) to see if A-R header is signed - if ( ! $self->transaction->header->get('DKIM-Signature') ) { - $self->log(LOGINFO, "deleted auth-results from $_"); - push @deleteme, $i; - }; - next; + my ($self, $result) = @_; + my $auths = $self->qp->connection->notes('authentication_results') or do { + $self->qp->connection->notes('authentication_results', $result); + return; }; - push @values, $value; - $self->log(LOGINFO, "appended to auth-results: $value"); - $self->transaction->header->replace('Authentication->Results', join('; ', @values ), $i); - } - foreach ( @deleteme ) { - $self->transaction->header->delete('Authentication-Results', $_); - }; + my $ar = join('; ', $auths, $result); + $self->log(LOGDEBUG, "auth-results: $ar"); + $self->qp->connection->notes('authentication_results', $ar ); }; sub init_resolver { diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index fd7c44d..e9f857c 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -766,43 +766,6 @@ sub data_respond { $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 = ''; - my $auth_result = 'none'; - - 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} ) { - my $mech = $self->{_auth_mechanism}; - my $user = $self->{_auth_user}; - $auth_result = "auth="; - if ( $self->{_auth} == OK) { - $smtp .= "A" if $esmtp; # RFC3848 - $authheader = "(smtp-auth username $user, mechanism $mech)\n"; - $auth_result .= 'pass'; - } - else { - $auth_result .= 'fail'; - }; - $auth_result .= " ($mech) smtp.auth=$user"; - } - - $header->add('Received', - $self->received_line($smtp, $authheader, $sslheader), 0); - - # RFC 5451: used in AUTH, DKIM, DOMAINKEYS, SENDERID, SPF - $header->add('Authentication-Results', - join('; ', $self->config('me'), $auth_result ) ); - # if we get here without seeing a terminator, the connection is # probably dead. unless ($complete) { @@ -823,8 +786,75 @@ sub data_respond { $self->run_hooks("data_post"); } +sub authentication_results { + my ($self) = @_; + + my @auth_list = $self->config('me'); +# $self->clean_authentication_results(); + + if ( ! defined $self->{_auth} ) { + push @auth_list, 'auth=none'; + } + else { + my $mechanism = "(" . $self->{_auth_mechanism} . ")"; + my $user = "smtp.auth=" . $self->{_auth_user}; + if ( $self->{_auth} == OK) { + push @auth_list, "auth=pass $mechanism $user"; + } + else { + push @auth_list, "auth=fail $mechanism $user"; + }; + }; + + # RFC 5451: used in AUTH, DKIM, DOMAINKEYS, SENDERID, SPF + if ( $self->connection->notes('authentication_results') ) { + push @auth_list, $self->connection->notes('authentication_results'); + }; + + $self->log(LOGDEBUG, "adding auth results header" ); + $self->transaction->header->add('Authentication-Results', join('; ', @auth_list) ); +}; + +sub clean_authentication_results { + my $self = shift; + +# On messages received from the internet, we may want to remove +# the Authentication-Results headers added by other MTAs, so our downstream +# can trust the new A-R header we insert. +# We do not want to invalidate DKIM signatures. +# TODO: parse the DKIM signature(s) to see if A-R header is signed + return if $self->transaction->header->get('DKIM-Signature'); + + my @headers = $self->transaction->header->get('Authentication-Results'); + for ( my $i = 0; $i < scalar @headers; $i++ ) { + $self->transaction->header->delete('Authentication-Results', $i); + } +}; + sub received_line { - my ($self, $smtp, $authheader, $sslheader) = @_; + my ($self) = @_; + + 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} && $self->{_auth} == OK) { + my $mech = $self->{_auth_mechanism}; + my $user = $self->{_auth_user}; + $smtp .= "A" if $esmtp; # RFC3848 + $authheader = "(smtp-auth username $user, mechanism $mech)\n"; + } + + my $header_str; my ($rc, @received) = $self->run_hooks("received_line", $smtp, $authheader, $sslheader); if ($rc == YIELD) { @@ -834,7 +864,7 @@ sub received_line { return join("\n", @received); } else { # assume $rc == DECLINED - return + $header_str = "from " . $self->connection->remote_info . " (HELO " @@ -847,6 +877,7 @@ sub received_line { . ") with $sslheader$smtp; " . (strftime('%a, %d %b %Y %H:%M:%S %z', localtime)); } + $self->transaction->header->add('Received', $header_str, 0 ); } sub data_post_respond { @@ -881,6 +912,8 @@ sub data_post_respond { return 1; } else { + $self->authentication_results(); + $self->received_line(); $self->queue($self->transaction); } } diff --git a/plugins/dkim b/plugins/dkim index 1866b25..39049dc 100644 --- a/plugins/dkim +++ b/plugins/dkim @@ -222,7 +222,11 @@ sub validate_it { my $result = $dkim->result; my $mess = $self->get_details($dkim); - $self->store_auth_results("dkim=" .$dkim->result_detail . " header.i=@".$dkim->signature->domain); + my $auth_str = "dkim=" .$dkim->result_detail; + if ( $dkim->signature && $dkim->signature->domain ) { + $auth_str .= " header.i=@" . $dkim->signature->domain; + }; + $self->store_auth_results( $auth_str ); #$self->add_header($mess); foreach my $t (qw/ pass fail invalid temperror none /) { diff --git a/plugins/domainkeys b/plugins/domainkeys index eac7abb..5b9a33b 100644 --- a/plugins/domainkeys +++ b/plugins/domainkeys @@ -43,7 +43,9 @@ the same terms as Perl itself. =head1 AUTHORS - Matt Simerson - 2012 + Matt Simerson - 2013 - safe results to Authentication-Results header + instead of DomainKey-Status + Matt Simerson - 2012 - refactored, added tests, safe loading John Peacock - 2005-2006 Anthony D. Urso. - 2004 @@ -113,7 +115,8 @@ sub data_post_handler { my $status = $self->get_message_status($message); if (defined $status) { - $transaction->header->add("DomainKey-Status", $status, 0); +#$transaction->header->add("DomainKey-Status", $status, 0); + $self->store_auth_results('domainkey=' . $status); $self->log(LOGINFO, "pass, $status"); return DECLINED; } diff --git a/plugins/fcrdns b/plugins/fcrdns index 2cc2009..53b62c2 100644 --- a/plugins/fcrdns +++ b/plugins/fcrdns @@ -119,8 +119,6 @@ RCODE of 3, commonly known as NXDOMAIN, or an RCODE of 0 (NOERROR) in a reply containing no answers, was returned. This prevented completion of the evaluation. -=cut - =head1 AUTHOR 2013 - Matt Simerson @@ -146,7 +144,6 @@ sub register { $self->init_resolver() or return; $self->register_hook('connect', 'connect_handler'); - $self->register_hook('data_post', 'data_post_handler'); } sub connect_handler { @@ -166,13 +163,6 @@ sub connect_handler { return DECLINED; } -sub data_post_handler { - my ($self, $transaction) = @_; - my $match = $self->connection->notes('fcrdns_match') || 'error'; - $self->store_auth_results("iprev=$match"); - return (DECLINED); -} - sub invalid_localhost { my ($self) = @_; return 1 if lc $self->qp->connection->remote_host ne 'localhost'; @@ -216,20 +206,20 @@ sub has_reverse_dns { my $query = $res->query($ip, 'PTR') or do { if ($res->errorstring eq 'NXDOMAIN') { $self->adjust_karma(-1); - $self->connection->notes('fcrdns_match', 'permerror'); + $self->store_auth_results("iprev=permerror"); $self->log(LOGINFO, "fail, no rDNS: " . $res->errorstring); return; } if ( $res->errorstring eq 'SERVFAIL' ) { $self->log(LOGINFO, "fail, error getting rDNS: " . $res->errorstring); - $self->connection->notes('fcrdns_match', 'temperror'); + $self->store_auth_results("iprev=temperror"); } elsif ( $res->errorstring eq 'NOERROR' ) { $self->log(LOGINFO, "fail, no PTR (NOERROR)" ); - $self->connection->notes('fcrdns_match', 'permerror'); + $self->store_auth_results("iprev=permerror"); } else { - $self->connection->notes('fcrdns_match', 'fail'); + $self->store_auth_results("iprev=fail"); $self->log(LOGINFO, "fail, error getting rDNS: " . $res->errorstring); }; return; @@ -246,7 +236,7 @@ sub has_reverse_dns { if (!$hits) { $self->adjust_karma(-1); $self->log(LOGINFO, "fail, no PTR records"); - $self->connection->notes('fcrdns_match', 'permerror'); + $self->store_auth_results("iprev=permerror"); return; } @@ -264,11 +254,11 @@ sub has_forward_dns { $host .= '.' if '.' ne substr($host, -1, 1); # fully qualify name my $query = $res->query($host) or do { if ($res->errorstring eq 'NXDOMAIN') { - $self->connection->notes('fcrdns_match', 'permerror'); + $self->store_auth_results("iprev=permerror"); $self->log(LOGDEBUG, "host $host does not exist"); next; } - $self->connection->notes('fcrdns_match', 'fail'); + $self->store_auth_results("iprev=fail"); $self->log(LOGDEBUG, "query for $host failed (", $res->errorstring, ")"); next; @@ -281,13 +271,13 @@ sub has_forward_dns { $self->check_ip_match($rr->address) and return 1; } if ($hits) { - $self->connection->notes('fcrdns_match', 'fail'); + $self->store_auth_results("iprev=fail"); $self->log(LOGDEBUG, "PTR host has forward DNS") if $hits; return 1; } } $self->adjust_karma(-1); - $self->connection->notes('fcrdns_match', 'fail'); + $self->store_auth_results("iprev=fail"); $self->log(LOGINFO, "fail, no PTR hosts have forward DNS"); return; } @@ -298,7 +288,7 @@ sub check_ip_match { if ($ip eq $self->qp->connection->remote_ip) { $self->log(LOGDEBUG, "forward ip match"); - $self->connection->notes('fcrdns_match', 'pass'); + $self->store_auth_results("iprev=pass"); $self->adjust_karma(1); return 1; } @@ -310,7 +300,7 @@ sub check_ip_match { if ($dns_net eq $rem_net) { $self->log(LOGNOTICE, "forward network match"); - $self->connection->notes('fcrdns_match', 'pass'); + $self->store_auth_results("iprev=pass"); return 1; } return; From e32154e8efdd3a9d4e8453cf508cded69be8b01b Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Thu, 2 May 2013 03:53:21 -0400 Subject: [PATCH 321/352] define positioning of Authentication-Results header --- lib/Qpsmtpd/SMTP.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index e9f857c..1589472 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -812,7 +812,7 @@ sub authentication_results { }; $self->log(LOGDEBUG, "adding auth results header" ); - $self->transaction->header->add('Authentication-Results', join('; ', @auth_list) ); + $self->transaction->header->add('Authentication-Results', join('; ', @auth_list), 0); }; sub clean_authentication_results { From c3305179d246a4325c54f2fbfed5e9113a5a1517 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 5 Aug 2013 15:32:31 -0700 Subject: [PATCH 322/352] remove plaintext UPGRADING (.pod added by Ask) --- UPGRADING | 26 -------------------------- 1 file changed, 26 deletions(-) delete mode 100644 UPGRADING diff --git a/UPGRADING b/UPGRADING deleted file mode 100644 index 7a3b478..0000000 --- a/UPGRADING +++ /dev/null @@ -1,26 +0,0 @@ - -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. - - From 5b3f616571ad92a8e9c00512e9daf06b4f234aee Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sun, 1 Dec 2013 03:42:55 -0500 Subject: [PATCH 323/352] removed a diff block from docs/config.pod --- docs/config.pod | 4 ---- 1 file changed, 4 deletions(-) diff --git a/docs/config.pod b/docs/config.pod index e2fbb28..86e0f0b 100644 --- a/docs/config.pod +++ b/docs/config.pod @@ -89,11 +89,7 @@ connection before any auth succeeds, defaults to C<0>. =back -<<<<<<< HEAD -=head2 Plugin settings -======= =head2 Plugin settings files ->>>>>>> initial import - based on my qpsmtpd fork =over 4 From b085388cda28012a1a63da9c3c94225b399ac6a8 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sun, 1 Dec 2013 03:45:12 -0500 Subject: [PATCH 324/352] TcpServer: optimize DNS lookups for PTR a. don't use search path (/etc/resolv.conf) b. explicitely specify PTR in query request --- lib/Qpsmtpd/TcpServer.pm | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lib/Qpsmtpd/TcpServer.pm b/lib/Qpsmtpd/TcpServer.pm index 8641576..5651aa4 100644 --- a/lib/Qpsmtpd/TcpServer.pm +++ b/lib/Qpsmtpd/TcpServer.pm @@ -191,18 +191,18 @@ sub tcpenv { return ($TCPLOCALIP, $TCPREMOTEIP, $TCPREMOTEIP ? "[$ENV{TCPREMOTEIP}]" : "[noip!]"); } - my $res = new Net::DNS::Resolver; + my $res = Net::DNS::Resolver->new( dnsrch => 0 ); $res->tcp_timeout(3); $res->udp_timeout(3); - my $query = $res->query($nto_iaddr); + my $query = $res->query($nto_iaddr, 'PTR'); my $TCPREMOTEHOST; if ($query) { foreach my $rr ($query->answer) { - next unless $rr->type eq "PTR"; + next if $rr->type ne 'PTR'; $TCPREMOTEHOST = $rr->ptrdname; } } - return ($TCPLOCALIP, $TCPREMOTEIP, $TCPREMOTEHOST || "Unknown"); + return ($TCPLOCALIP, $TCPREMOTEIP, $TCPREMOTEHOST || 'Unknown'); } sub check_socket() { From a26d46ed87ccfee32b23f0ad0087a368fddaccdd Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Tue, 17 Dec 2013 14:13:51 -0800 Subject: [PATCH 325/352] move Auth-Results header to Original-Auth-Results this was in a sub, commented out as a TODO to delete them. Instead of deleting, move the Authentication-Results header on incoming messages to the Original-A-R. --- lib/Qpsmtpd/SMTP.pm | 25 ++++++++++++++++--------- 1 file changed, 16 insertions(+), 9 deletions(-) diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index 1589472..fe8e63e 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -23,7 +23,7 @@ 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 { respond(421, "timeout; I can't wait that long..."); exit }; #$SIG{ALRM} = sub { warn "Connection Timed Out\n"; exit; }; sub new { @@ -818,17 +818,24 @@ sub authentication_results { sub clean_authentication_results { my $self = shift; -# On messages received from the internet, we may want to remove -# the Authentication-Results headers added by other MTAs, so our downstream -# can trust the new A-R header we insert. -# We do not want to invalidate DKIM signatures. -# TODO: parse the DKIM signature(s) to see if A-R header is signed - return if $self->transaction->header->get('DKIM-Signature'); +# http://tools.ietf.org/html/draft-kucherawy-original-authres-00.html - my @headers = $self->transaction->header->get('Authentication-Results'); - for ( my $i = 0; $i < scalar @headers; $i++ ) { +# On messages received from the internet, move Authentication-Results headers +# to Original-AR, so our downstream can trust the A-R header we insert. + +# TODO: Do not invalidate DKIM signatures. +# if $self->transaction->header->get('DKIM-Signature') +# Parse the DKIM signature(s) +# return if A-R header is signed; +# } + + my @ar_headers = $self->transaction->header->get('Authentication-Results'); + for ( my $i = 0; $i < scalar @ar_headers; $i++ ) { $self->transaction->header->delete('Authentication-Results', $i); + $self->transaction->header->add('Original-Authentication-Results', $ar_headers[$i]); } + + $self->log(LOGDEBUG, "Authentication-Results moved to Original-Authentication-Results" ); }; sub received_line { From 7a9ae2c7058c6f77dd12dd15797b2cd1981810d3 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Tue, 17 Dec 2013 15:06:58 -0800 Subject: [PATCH 326/352] STATUS: removed -dev comments --- STATUS | 18 +++++------------- 1 file changed, 5 insertions(+), 13 deletions(-) diff --git a/STATUS b/STATUS index 6992271..c9e7e8f 100644 --- a/STATUS +++ b/STATUS @@ -1,19 +1,11 @@ -Qpsmtpd-dev is a fork of Qpsmtpd. Qpsmtpd is a very good SMTP daemon for -developers and hackers (admittedly, its focus). The plugin system is great -but the plugin organization, documentation, and consistency left much -to be desired. +Qpsmtpd is a very good SMTP daemon for developers and hackers. -The primary focus of the -dev branch is improving the consistency and -behavior of the plugins. After using one plugin, the knowledge gained -should carry over to other plugins. - -Secondary goals are making it easier to install, reducing code duplication, +Current goals are making it easier to install, reducing code duplication, reducing complexity, and cooperation between plugins. Anything covered -in Perl Best Practices is also fair game. +in Perl Best Practices is fair game. -So far, the main changes between the release and dev branches have focused -on these goals: +Recent changes have been made towards these goals: - plugins use is_immune and is_naughty instead of a local methods - plugins log a single entry summarizing their disposition @@ -36,7 +28,7 @@ For most sites, even DNSBL, SPF, DKIM, and SpamAssassin tests alone are insuffic Roadmap ======= - - https://github.com/qpsmtpd-dev/qpsmtpd-dev/issues + - https://github.com/smtpd/qpsmtpd/issues - Bugfixes - qpsmtpd is extremely stable (in production since 2001), but there are always more things to fix. From 2a12acce6e3090906ad0730d27efbead41a82604 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Tue, 17 Dec 2013 15:08:29 -0800 Subject: [PATCH 327/352] Changes: updated with 0.93 changes --- Changes | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) diff --git a/Changes b/Changes index 01053b6..3e377a8 100644 --- a/Changes +++ b/Changes @@ -1,4 +1,30 @@ +0.93 Dec 17, 2013 + + Added Authentication-Results header + moves Authentication-Results to Original-Authentication-Results on inbound. + no longer puts auth info in Received header + + TcpServer: ignore DNS search path and explicitely request PTR lookups (speedup) + + store envelope TO/FROM in connection notes + + raised max msg size in clamdscan + + SPF enabled by default (if Mail::SPF available) + + auth_vpopmaild: added taint checking to responses + + added run files for most common deployment methods (easier install) + + untaint config data passed to plugins + + Qpsmtpd.pm: split config args on /\s+/, was / / + (compatibility with newer versions of perl) + + dmarc: added subdomain policy handling + + 0.92 Apr 20, 2013 new plugins: dmarc, fcrdns From 14d5bad9ff60dcc780ba822b20ba85cd4c808926 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 5 Aug 2013 15:32:31 -0700 Subject: [PATCH 328/352] remove plaintext UPGRADING (.pod added by Ask) --- UPGRADING | 26 -------------------------- 1 file changed, 26 deletions(-) delete mode 100644 UPGRADING diff --git a/UPGRADING b/UPGRADING deleted file mode 100644 index 7a3b478..0000000 --- a/UPGRADING +++ /dev/null @@ -1,26 +0,0 @@ - -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. - - From 6b4b714c2af17baaf08df8d5d432acdb1a7dfc71 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sun, 1 Dec 2013 03:42:55 -0500 Subject: [PATCH 329/352] removed a diff block from docs/config.pod --- docs/config.pod | 4 ---- 1 file changed, 4 deletions(-) diff --git a/docs/config.pod b/docs/config.pod index e2fbb28..86e0f0b 100644 --- a/docs/config.pod +++ b/docs/config.pod @@ -89,11 +89,7 @@ connection before any auth succeeds, defaults to C<0>. =back -<<<<<<< HEAD -=head2 Plugin settings -======= =head2 Plugin settings files ->>>>>>> initial import - based on my qpsmtpd fork =over 4 From ddb613f173c6226a9e537c35ddb23f11489ac50e Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Sun, 1 Dec 2013 03:45:12 -0500 Subject: [PATCH 330/352] TcpServer: optimize DNS lookups for PTR a. don't use search path (/etc/resolv.conf) b. explicitely specify PTR in query request --- lib/Qpsmtpd/TcpServer.pm | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lib/Qpsmtpd/TcpServer.pm b/lib/Qpsmtpd/TcpServer.pm index 8641576..5651aa4 100644 --- a/lib/Qpsmtpd/TcpServer.pm +++ b/lib/Qpsmtpd/TcpServer.pm @@ -191,18 +191,18 @@ sub tcpenv { return ($TCPLOCALIP, $TCPREMOTEIP, $TCPREMOTEIP ? "[$ENV{TCPREMOTEIP}]" : "[noip!]"); } - my $res = new Net::DNS::Resolver; + my $res = Net::DNS::Resolver->new( dnsrch => 0 ); $res->tcp_timeout(3); $res->udp_timeout(3); - my $query = $res->query($nto_iaddr); + my $query = $res->query($nto_iaddr, 'PTR'); my $TCPREMOTEHOST; if ($query) { foreach my $rr ($query->answer) { - next unless $rr->type eq "PTR"; + next if $rr->type ne 'PTR'; $TCPREMOTEHOST = $rr->ptrdname; } } - return ($TCPLOCALIP, $TCPREMOTEIP, $TCPREMOTEHOST || "Unknown"); + return ($TCPLOCALIP, $TCPREMOTEIP, $TCPREMOTEHOST || 'Unknown'); } sub check_socket() { From 19115cd2e435f2cdcdd44524c404263e64723eb7 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Tue, 17 Dec 2013 14:13:51 -0800 Subject: [PATCH 331/352] move Auth-Results header to Original-Auth-Results this was in a sub, commented out as a TODO to delete them. Instead of deleting, move the Authentication-Results header on incoming messages to the Original-A-R. --- lib/Qpsmtpd/SMTP.pm | 25 ++++++++++++++++--------- 1 file changed, 16 insertions(+), 9 deletions(-) diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index 1589472..fe8e63e 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -23,7 +23,7 @@ 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 { respond(421, "timeout; I can't wait that long..."); exit }; #$SIG{ALRM} = sub { warn "Connection Timed Out\n"; exit; }; sub new { @@ -818,17 +818,24 @@ sub authentication_results { sub clean_authentication_results { my $self = shift; -# On messages received from the internet, we may want to remove -# the Authentication-Results headers added by other MTAs, so our downstream -# can trust the new A-R header we insert. -# We do not want to invalidate DKIM signatures. -# TODO: parse the DKIM signature(s) to see if A-R header is signed - return if $self->transaction->header->get('DKIM-Signature'); +# http://tools.ietf.org/html/draft-kucherawy-original-authres-00.html - my @headers = $self->transaction->header->get('Authentication-Results'); - for ( my $i = 0; $i < scalar @headers; $i++ ) { +# On messages received from the internet, move Authentication-Results headers +# to Original-AR, so our downstream can trust the A-R header we insert. + +# TODO: Do not invalidate DKIM signatures. +# if $self->transaction->header->get('DKIM-Signature') +# Parse the DKIM signature(s) +# return if A-R header is signed; +# } + + my @ar_headers = $self->transaction->header->get('Authentication-Results'); + for ( my $i = 0; $i < scalar @ar_headers; $i++ ) { $self->transaction->header->delete('Authentication-Results', $i); + $self->transaction->header->add('Original-Authentication-Results', $ar_headers[$i]); } + + $self->log(LOGDEBUG, "Authentication-Results moved to Original-Authentication-Results" ); }; sub received_line { From 04634feffea89d763ca02b8ab76f40f1bde713e5 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Tue, 17 Dec 2013 15:06:58 -0800 Subject: [PATCH 332/352] STATUS: removed -dev comments --- STATUS | 18 +++++------------- 1 file changed, 5 insertions(+), 13 deletions(-) diff --git a/STATUS b/STATUS index 6992271..c9e7e8f 100644 --- a/STATUS +++ b/STATUS @@ -1,19 +1,11 @@ -Qpsmtpd-dev is a fork of Qpsmtpd. Qpsmtpd is a very good SMTP daemon for -developers and hackers (admittedly, its focus). The plugin system is great -but the plugin organization, documentation, and consistency left much -to be desired. +Qpsmtpd is a very good SMTP daemon for developers and hackers. -The primary focus of the -dev branch is improving the consistency and -behavior of the plugins. After using one plugin, the knowledge gained -should carry over to other plugins. - -Secondary goals are making it easier to install, reducing code duplication, +Current goals are making it easier to install, reducing code duplication, reducing complexity, and cooperation between plugins. Anything covered -in Perl Best Practices is also fair game. +in Perl Best Practices is fair game. -So far, the main changes between the release and dev branches have focused -on these goals: +Recent changes have been made towards these goals: - plugins use is_immune and is_naughty instead of a local methods - plugins log a single entry summarizing their disposition @@ -36,7 +28,7 @@ For most sites, even DNSBL, SPF, DKIM, and SpamAssassin tests alone are insuffic Roadmap ======= - - https://github.com/qpsmtpd-dev/qpsmtpd-dev/issues + - https://github.com/smtpd/qpsmtpd/issues - Bugfixes - qpsmtpd is extremely stable (in production since 2001), but there are always more things to fix. From f78da4b13dd70d25fcd096cdff7476f4fa5ab206 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Tue, 17 Dec 2013 15:08:29 -0800 Subject: [PATCH 333/352] Changes: updated with 0.93 changes --- Changes | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) diff --git a/Changes b/Changes index 01053b6..3e377a8 100644 --- a/Changes +++ b/Changes @@ -1,4 +1,30 @@ +0.93 Dec 17, 2013 + + Added Authentication-Results header + moves Authentication-Results to Original-Authentication-Results on inbound. + no longer puts auth info in Received header + + TcpServer: ignore DNS search path and explicitely request PTR lookups (speedup) + + store envelope TO/FROM in connection notes + + raised max msg size in clamdscan + + SPF enabled by default (if Mail::SPF available) + + auth_vpopmaild: added taint checking to responses + + added run files for most common deployment methods (easier install) + + untaint config data passed to plugins + + Qpsmtpd.pm: split config args on /\s+/, was / / + (compatibility with newer versions of perl) + + dmarc: added subdomain policy handling + + 0.92 Apr 20, 2013 new plugins: dmarc, fcrdns From 2416d1e940369e6db1a923ee4865b2dee1dd7336 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Tue, 17 Dec 2013 23:43:26 -0500 Subject: [PATCH 334/352] Plugin.pm: made is_naughty is now a getter too --- lib/Qpsmtpd/Plugin.pm | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm index 9693524..5dde02c 100644 --- a/lib/Qpsmtpd/Plugin.pm +++ b/lib/Qpsmtpd/Plugin.pm @@ -218,7 +218,7 @@ sub compile { sub get_reject { my $self = shift; - my $smtp_mess = shift || "why didn't you pass an error message?"; + my $smtp_mess = shift || "unspecified error"; my $log_mess = shift || ''; $log_mess = ", $log_mess" if $log_mess; @@ -320,17 +320,17 @@ sub is_immune { sub is_naughty { my ($self, $setit) = @_; - if ( defined $setit ) { - $self->connection->notes('naughty', $setit); - $self->connection->notes('rejected', $setit); - }; + # see plugins/naughty + return $self->connection->notes('naughty') if ! defined $setit; + + $self->connection->notes('naughty', $setit); + $self->connection->notes('rejected', $setit); 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/ @@ -345,7 +345,7 @@ sub adjust_karma { my $karma = $self->connection->notes('karma') || 0; $karma += $value; - $self->log(LOGDEBUG, "karma $value ($karma)"); + $self->log(LOGINFO, "karma $value ($karma)"); $self->connection->notes('karma', $karma); return $value; } From 012a7a4918251b4cfa8f1c2ff992bf644354acef Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Tue, 17 Dec 2013 23:44:35 -0500 Subject: [PATCH 335/352] log/summarize: set undefined strings as empty str avoids undef warnings --- log/summarize | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/log/summarize b/log/summarize index 1c85070..6c0ad69 100755 --- a/log/summarize +++ b/log/summarize @@ -136,14 +136,14 @@ sub handle_dispatch { my ($message, $pid, $line) = @_; if ($message =~ /^dispatching MAIL FROM/i) { my ($from) = $message =~ /<(.*?)>/; - $pids{$pid}{from} = $from; + $pids{$pid}{from} = $from || ''; } elsif ($message =~ /^dispatching RCPT TO/i) { my ($to) = $message =~ /<(.*?)>/; - $pids{$pid}{to} = $to; + $pids{$pid}{to} = $to || ''; } elsif ($message =~ m/dispatching (EHLO|HELO) (.*)/) { - $pids{$pid}{helo_host} = $2; + $pids{$pid}{helo_host} = $2 || ''; } elsif ($message eq 'dispatching DATA') { } elsif ($message eq 'dispatching QUIT') { } From c202d3ef69543a5a6613a23ad1c76bd907316716 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Tue, 17 Dec 2013 23:53:00 -0500 Subject: [PATCH 336/352] dmarc integrated with Mail::DMARC reimplemented dmarc module to use Mail::DMARC updated SPF plugin to save SPF results in dmarc_spf note update dkim to store DKIM results in dkim_result & dkim_verifier notes --- plugins/dkim | 6 +- plugins/dmarc | 470 +++++++--------------------------- plugins/sender_permitted_from | 26 +- 3 files changed, 116 insertions(+), 386 deletions(-) diff --git a/plugins/dkim b/plugins/dkim index 39049dc..7351138 100644 --- a/plugins/dkim +++ b/plugins/dkim @@ -221,13 +221,14 @@ sub validate_it { $self->send_message_to_dkim($dkim, $transaction); my $result = $dkim->result; my $mess = $self->get_details($dkim); + $self->connection->notes('dkim_result', $result); + $self->connection->notes('dkim_verifier', $dkim); my $auth_str = "dkim=" .$dkim->result_detail; if ( $dkim->signature && $dkim->signature->domain ) { $auth_str .= " header.i=@" . $dkim->signature->domain; }; $self->store_auth_results( $auth_str ); - #$self->add_header($mess); foreach my $t (qw/ pass fail invalid temperror none /) { next if $t ne $result; @@ -482,7 +483,8 @@ sub send_message_to_dkim { $self->log(LOGERROR, $@) if $@; } - $dkim->CLOSE; + eval { $dkim->CLOSE; }; + $self->log(LOGERROR, $@) if $@; } sub get_policies { diff --git a/plugins/dmarc b/plugins/dmarc index cd40ec0..7e98e89 100644 --- a/plugins/dmarc +++ b/plugins/dmarc @@ -6,7 +6,7 @@ Domain-based Message Authentication, Reporting and Conformance =head1 SYNOPSIS -DMARC is an extremely reliable means to authenticate email. +DMARC is a reliable means to authenticate email. =head1 DESCRIPTION @@ -14,9 +14,9 @@ From the DMARC Draft: "DMARC operates as a policy layer atop DKIM and SPF. These DMARC provides a way to exchange authentication information and policies among mail servers. -DMARC benefits domain owners by preventing others from impersonating them. A domain owner can reliably tell other mail servers that "it it doesn't originate from this list of servers (SPF) and it is not signed (DKIM), then reject it!" DMARC also provides domain owners with a means to receive feedback and determine that their policies are working as desired. +DMARC benefits domain owners by preventing others from impersonating them. A domain owner can reliably tell other mail servers that "it it doesn't originate from this list of servers (SPF) and it is not signed (DKIM), then [ignore|quarantine|reject] it." DMARC also provides domain owners with a means to receive feedback and determine that their policies are working as desired. -DMARC benefits mail server operators by providing them with an extremely reliable (as opposed to DKIM or SPF, which both have reliability issues when used independently) means to block forged emails. Is that message really from PayPal, Chase, Gmail, or Facebook? Since those organizations, and many more, publish DMARC policies, operators have a definitive means to know. +DMARC benefits mail server operators by providing them with a more reliable (than SPF or DKIM alone) means to block forged emails. Is that message really from PayPal, Chase, Gmail, or Facebook? Since those organizations publish DMARC policies, operators have a definitive means to know. =head1 HOWTO @@ -46,26 +46,21 @@ _dmarc IN TXT "v=DMARC1; p=reject; rua=mailto:dmarc-feedback@example.com;" =head2 Validate messages with DMARC -1. install this plugin +1. install Mail::DMARC -2. install a public suffix list in config/public_suffix_list. See http://publicsuffix.org/list/ +2. install this plugin 3. activate this plugin. (add to config/plugins, listing it after SPF & DKIM. Check that SPF and DKIM are configured to not reject mail. -=head2 Parse dmarc feedback reports into a database - -See http://www.taugh.com/rddmarc/ =head1 MORE INFORMATION http://www.dmarc.org/draft-dmarc-base-00-02.txt -https://github.com/qpsmtpd-dev/qpsmtpd-dev/wiki/DMARC-FAQ +https://github.com/smtpd/qpsmtpd/wiki/DMARC-FAQ =head1 TODO - provide dmarc feedback to domains that request it - reject messages with multiple From: headers =head1 AUTHORS @@ -77,402 +72,111 @@ https://github.com/qpsmtpd-dev/qpsmtpd-dev/wiki/DMARC-FAQ use strict; use warnings; +use Data::Dumper; use Qpsmtpd::Constants; -sub init { - my ($self, $qp) = (shift, shift); - $self->{_args} = {@_}; +sub register { + my ($self, $qp, @args) = @_; + + $self->log(LOGERROR, "Bad arguments") if @args % 2; + $self->{_args} = {@args}; + $self->{_args}{reject} = 1 if !defined $self->{_args}{reject}; $self->{_args}{reject_type} ||= 'perm'; $self->{_args}{p_vals} = {map { $_ => 1 } qw/ none reject quarantine /}; -} -sub register { - my $self = shift; - - $self->register_hook('data_post', 'data_post_handler'); + eval "require Mail::DMARC::PurePerl"; + if ( $@ ) { + $self->log(LOGERROR, "failed to load Mail::DMARC::PurePerl" ); + } + else { + $self->{_dmarc} = Mail::DMARC::PurePerl->new(); + $self->register_hook('data_post', 'data_post_handler'); + }; } sub data_post_handler { my ($self, $transaction) = @_; - return DECLINED if $self->is_immune(); - - # 11.1. Extract Author Domain - my $from_dom = $self->get_from_dom($transaction) or return DECLINED; - my $org_dom = $self->get_organizational_domain($from_dom); - - # 6. Receivers should reject email if the domain appears to not exist - my $exists = $self->exists_in_dns($from_dom, $org_dom) or do { - $self->log(LOGINFO, "fail, $from_dom not in DNS"); - return $self->get_reject("RFC5322.From host appears non-existent"); + if ( $self->qp->connection->relay_client() ) { + $self->log(LOGINFO, "skip, relay client" ); + return DECLINED; # disable reporting to ourself }; - # 11.2. Determine Handling Policy - my $policy = $self->discover_policy($from_dom, $org_dom) - or return DECLINED; + my $dmarc = $self->{_dmarc}; + $dmarc->init(); + my $from = $transaction->header->get('From'); + eval { $dmarc->header_from_raw( $from ); }; + if ( $@ ) { + $self->log(LOGERROR, "unparseable from header: $from" ); + return $self->get_reject("unparseable from header"); + }; + my @recipients = $transaction->recipients; + eval { $dmarc->envelope_to( lc $recipients[0]->host ); }; # optional + eval { $dmarc->envelope_from( $transaction->sender->host ); }; # may be <> + $dmarc->spf( $transaction->notes('dmarc_spf') ); + my $dkim = $self->connection->notes('dkim_verifier'); + if ( $dkim ) { $dmarc->dkim( $dkim ); }; + $dmarc->source_ip( $self->qp->connection->remote_ip ); + eval { $dmarc->validate(); }; + if ( $@ ) { + $self->log(LOGERROR, $@ ); + return DECLINED if $self->is_immune; + $self->log(LOGINFO, "TODO: handle this validation failure"); + return DECLINED; + return $self->get_reject( $@, $@ ); + }; - # 3. Perform DKIM signature verification checks. A single email may - # contain multiple DKIM signatures. The results MUST include the - # value of the "d=" tag from all DKIM signatures that validated. - #my $dkim_sigs = $self->connection->notes('dkim_pass_domains') || []; +#$self->log(LOGINFO, "result: " . Dumper( $dmarc ) ); - # 4. Perform SPF validation checks. The results of this step - # MUST include the domain name from the RFC5321.MailFrom if SPF - # evaluation returned a "pass" result. - my $spf_dom = $transaction->notes('spf_pass_host'); + my $pol; + eval { $pol = $dmarc->result->published; }; + if ( $pol ) { + if ( $dmarc->has_valid_reporting_uri($pol->rua) ) { + eval { $dmarc->save_aggregate(); }; + $self->log(LOGERROR, $@ ) if $@; + } + else { + $self->log(LOGERROR, "has policy, no report URI" ); + }; + }; - my $effective_policy = ( $self->{_args}{is_subdomain} && defined $policy->{sp} ) - ? $policy->{sp} : $policy->{p}; + my $disposition = $dmarc->result->disposition; + my $auth_str = "dmarc=$disposition"; + $auth_str = " (p=" . $pol->p . ")" if $pol; - # 5. Conduct identifier alignment checks. - if ( $self->is_aligned($from_dom, $org_dom, $policy, $spf_dom ) ) { - $self->store_auth_results("dmarc=pass (p=$effective_policy) d=$from_dom"); + if ( $dmarc->result->result eq 'pass' ) { + $self->log(LOGINFO, "pass"); + $self->store_auth_results( $auth_str . " d=" . $dmarc->header_from); return DECLINED; }; - # 6. Apply policy. Emails that fail the DMARC mechanism check are - # disposed of in accordance with the discovered DMARC policy of the - # Domain Owner. See Section 6.2 for details. - if ( lc $effective_policy eq 'none' ) { - $self->store_auth_results("dmarc=fail (p=none) d=$from_dom"); + my $reason_type = my $comment = ''; + if ( $dmarc->result->reason && $dmarc->result->reason->[0] ) { + $reason_type = $dmarc->result->reason->[0]->type; + if ( $dmarc->result->reason->[0]->comment ) { + $comment = $dmarc->result->reason->[0]->comment; + }; + }; + if ( $disposition eq 'none' && $comment && $comment eq 'no policy') { + $self->log(LOGINFO, "skip, no policy"); return DECLINED; }; - my $pct = $policy->{pct} || 100; - if ( $pct != 100 && int(rand(100)) >= $pct ) { - $self->log("fail, tolerated, policy, sampled out"); - $self->store_auth_results("dmarc=sampled_out (p=$effective_policy) d=$from_dom"); - return DECLINED; - }; + my $log_mess = $dmarc->result->result; + $log_mess .= ", tolerated" if $disposition eq 'none'; + $log_mess .= ", $reason_type" if $reason_type; + $log_mess .= ", $comment" if $comment; + $self->log(LOGINFO, $log_mess); - $self->store_auth_results("dmarc=fail (p=$effective_policy) d=$from_dom"); + $self->store_auth_results( $auth_str . " d=" . $dmarc->header_from); + + return DECLINED if $disposition eq 'none'; + return DECLINED if ! $disposition; # for safety + return DECLINED if $self->is_immune; + + $self->adjust_karma(-3); +# at what point do we reject? return $self->get_reject("failed DMARC policy"); } -sub is_aligned { - my ($self, $from_dom, $org_dom, $policy, $spf_dom) = @_; - - # 5. Conduct identifier alignment checks. With authentication checks - # and policy discovery performed, the Mail Receiver checks if - # Authenticated Identifiers fall into alignment as decribed in - # Section 4. If one or more of the Authenticated Identifiers align - # with the RFC5322.From domain, the message is considered to pass - # the DMARC mechanism check. All other conditions (authentication - # failures, identifier mismatches) are considered to be DMARC - # mechanism check failures. - - my $dkim_sigs = $self->connection->notes('dkim_pass_domains') || []; - foreach (@$dkim_sigs) { - if ($_ eq $from_dom) { # strict alignment, requires exact match - $self->log(LOGINFO, "pass, DKIM aligned"); - $self->adjust_karma(1); - return 1; - } - next if $policy->{adkim} && lc $policy->{adkim} eq 's'; # strict pol. - # relaxed policy (default): Org. Dom must match a DKIM sig - if ( $_ eq $org_dom ) { - $self->log(LOGINFO, "pass, DKIM aligned, relaxed"); - $self->adjust_karma(1); - return 1; - }; - } - - return 0 if ! $spf_dom; - if ($spf_dom eq $from_dom) { - $self->adjust_karma(1); - $self->log(LOGINFO, "pass, SPF aligned"); - return 1; - } - return 0 if ($policy->{aspf} && lc $policy->{aspf} eq 's' ); # strict pol - if ($spf_dom eq $org_dom) { - $self->adjust_karma(1); - $self->log(LOGINFO, "pass, SPF aligned, relaxed"); - return 1; - } - - return 0; -}; - -sub discover_policy { - my ($self, $from_dom, $org_dom) = @_; - - # 1. Mail Receivers MUST query the DNS for a DMARC TXT record... - my @matches = $self->fetch_dmarc_record($from_dom, $org_dom) or return; - - # 4. Records that do not include a "v=" tag that identifies the - # current version of DMARC are discarded. - @matches = grep /v=DMARC1/i, @matches; - if (0 == scalar @matches) { - $self->log(LOGINFO, "skip, no valid record for $from_dom"); - return; - } - - # 5. If the remaining set contains multiple records, processing - # terminates and the Mail Receiver takes no action. - if (@matches > 1) { - $self->log(LOGINFO, "skip, too many records"); - return; - } - - # 6. If a retrieved policy record does not contain a valid "p" tag, or - # contains an "sp" tag that is not valid, then: - my %policy = $self->parse_policy($matches[0]); - if (!$self->has_valid_p(\%policy) || $self->has_invalid_sp(\%policy)) { - - # A. if an "rua" tag is present and contains at least one - # syntactically valid reporting URI, the Mail Receiver SHOULD - # act as if a record containing a valid "v" tag and "p=none" - # was retrieved, and continue processing; - # B. otherwise, the Mail Receiver SHOULD take no action. - my $rua = $policy{rua}; - if (!$rua || !$self->has_valid_reporting_uri($rua)) { - $self->log(LOGINFO, "skip, no valid reporting rua"); - return; - } - $policy{v} = 'DMARC1'; - $policy{p} = 'none'; - } - - return \%policy; -} - -sub has_valid_p { - my ($self, $policy) = @_; - return 1 if $self->{_args}{p_vals}{$policy}; - return 0; -} - -sub has_invalid_sp { - my ($self, $policy) = @_; - return 0 if !$self->{_args}{p_vals}{$policy}; - return 1; -} - -sub has_valid_reporting_uri { - my ($self, $rua) = @_; - return 1 if 'mailto:' eq lc substr($rua, 0, 7); - return 0; -} - -sub get_organizational_domain { - my ($self, $from_dom) = @_; - - # 1. Acquire a "public suffix" list, i.e., a list of DNS domain - # names reserved for registrations. http://publicsuffix.org/list/ - # $self->qp->config('public_suffix_list') - - # 2. Break the subject DNS domain name into a set of "n" ordered - # labels. Number these labels from right-to-left; e.g. for - # "example.com", "com" would be label 1 and "example" would be - # label 2.; - my @labels = reverse split /\./, $from_dom; - - # 3. Search the public suffix list for the name that matches the - # largest number of labels found in the subject DNS domain. Let - # that number be "x". - my $greatest = 0; - for (my $i = 0 ; $i <= scalar @labels ; $i++) { - next if !$labels[$i]; - my $tld = join '.', reverse((@labels)[0 .. $i]); - - # $self->log( LOGINFO, "i: $i, $tld" ); - #warn "i: $i - tld: $tld\n"; - if (grep /^$tld/, $self->qp->config('public_suffix_list')) { - $greatest = $i + 1; - next; - } - - # check for wildcards (ex: *.uk should match co.uk) - $tld = join '.', '\*', reverse((@labels)[0 .. $i-1]); - if (grep /^$tld/, $self->qp->config('public_suffix_list')) { - $greatest = $i + 1; - }; - } - - return $from_dom if $greatest == scalar @labels; # same - - # 4. Construct a new DNS domain name using the name that matched - # from the public suffix list and prefixing to it the "x+1"th - # label from the subject domain. This new name is the - # Organizational Domain. - return join '.', reverse((@labels)[0 .. $greatest]); -} - -sub exists_in_dns { - my ($self, $domain, $org_dom) = @_; -# 6. Receivers should endeavour to reject or quarantine email if the -# RFC5322.From purports to be from a domain that appears to be -# either non-existent or incapable of receiving mail. - -# That's all the draft says. I went back to the DKIM ADSP (which led me to -# the ietf-dkim email list where some 'experts' failed to agree on The Right -# Way to test domain validity. Let alone deliverability. They point out: -# MX records aren't mandatory, and A|AAAA as fallback aren't reliable. -# -# Some experimentation proved both cases in real world usage. Instead, I test -# existence by searching for a MX, NS, A, or AAAA record. Since this search -# is repeated for the Organizational Name, if the NS query fails, there's no -# delegation from the TLD. That's proven very reliable. - my $res = $self->init_resolver(8); - my @todo = $domain; - push @todo, $org_dom if $domain ne $org_dom; - foreach ( @todo ) { - return 1 if $self->host_has_rr('MX', $res, $_); - return 1 if $self->host_has_rr('NS', $res, $_); - return 1 if $self->host_has_rr('A', $res, $_); - return 1 if $self->host_has_rr('AAAA', $res, $_); - }; -} - -sub host_has_rr { - my ($self, $type, $res, $domain) = @_; - - my $query = $res->query($domain, $type) or do { - if ($res->errorstring eq 'NXDOMAIN') { - $self->log(LOGDEBUG, "fail, non-existent domain: $domain"); - return; - } - return if $res->errorstring eq 'NOERROR'; - $self->log(LOGINFO, "error, looking up $domain: " . $res->errorstring); - return; - }; - my $matches = 0; - for my $rr ($query->answer) { - next if $rr->type ne $type; - $matches++; - } - if (0 == $matches) { - $self->log(LOGDEBUG, "no $type records for $domain"); - } - return $matches; -}; - -sub fetch_dmarc_record { - my ($self, $zone, $org_dom) = @_; - - # 1. Mail Receivers MUST query the DNS for a DMARC TXT record at the - # DNS domain matching the one found in the RFC5322.From domain in - # the message. A possibly empty set of records is returned. - $self->{_args}{is_subdomain} = defined $org_dom ? 0 : 1; - my $res = $self->init_resolver(); - my $query = $res->send('_dmarc.' . $zone, 'TXT'); - my @matches; - for my $rr ($query->answer) { - next if $rr->type ne 'TXT'; - - # 2. Records that do not start with a "v=" tag that identifies the - # current version of DMARC are discarded. - next if 'v=' ne lc substr($rr->txtdata, 0, 2); - next if 'v=spf' eq lc substr($rr->txtdata, 0, 5); # SPF commonly found - $self->log(LOGINFO, $rr->txtdata); - push @matches, join('', $rr->txtdata); - } - return @matches if scalar @matches; # found one! (at least) - - # 3. If the set is now empty, the Mail Receiver MUST query the DNS for - # a DMARC TXT record at the DNS domain matching the Organizational - # Domain in place of the RFC5322.From domain in the message (if - # different). This record can contain policy to be asserted for - # subdomains of the Organizational Domain. - if ( defined $org_dom ) { # <- recursion break - if ( $org_dom eq $zone ) { - $self->log(LOGINFO, "skip, no policy for $zone (same org)"); - return @matches; - }; - return $self->fetch_dmarc_record($org_dom); # <- recursion - }; - - $self->log(LOGINFO, "skip, no policy for $zone"); - return @matches; -} - -sub get_from_dom { - my ($self, $transaction) = @_; - - my $from = $transaction->header->get('From') or do { - $self->log(LOGINFO, "error, unable to retrieve From header!"); - return; - }; - my ($from_dom) = (split /@/, $from)[-1]; # grab everything after the @ - ($from_dom) = split /\s+/, $from_dom; # remove any trailing cruft - chomp $from_dom; # remove \n - chop $from_dom if '>' eq substr($from_dom, -1, 1); # remove closing > - $self->log(LOGDEBUG, "info, from_dom is $from_dom"); - return $from_dom; -} - -sub parse_policy { - my ($self, $str) = @_; - $str =~ s/\s//g; # remove all whitespace - my %dmarc = map { split /=/, $_ } split /;/, $str; - - #warn Data::Dumper::Dumper(\%dmarc); - return %dmarc; -} - -sub external_report { - -=pod - -The report SHOULD include the following data: - - o Enough information for the report consumer to re-calculate DMARC - disposition based on the published policy, message dispositon, and - SPF, DKIM, and identifier alignment results. {R12} - - o Data for each sender subdomain separately from mail from the - sender's organizational domain, even if no subdomain policy is - applied. {R13} - - o Sending and receiving domains {R17} - - o The policy requested by the Domain Owner and the policy actually - applied (if different) {R18} - - o The number of successful authentications {R19} - - o The counts of messages based on all messages received even if - their delivery is ultimately blocked by other filtering agents {R20} - -=cut - -}; - -sub verify_external_reporting { - -=head2 Verify External Destinations - - 1. Extract the host portion of the authority component of the URI. - Call this the "destination host". - - 2. Prepend the string "_report._dmarc". - - 3. Prepend the domain name from which the policy was retrieved. - - 4. Query the DNS for a TXT record at the constructed name. If the - result of this request is a temporary DNS error of some kind - (e.g., a timeout), the Mail Receiver MAY elect to temporarily - fail the delivery so the verification test can be repeated later. - - 5. If the result includes no TXT resource records or multiple TXT - resource records, a positive determination of the external - reporting relationship cannot be made; stop. - - 6. Parse the result, if any, as a series of "tag=value" pairs, i.e., - the same overall format as the policy record. In particular, the - "v=DMARC1" tag is mandatory and MUST appear first in the list. - If at least that tag is present and the record overall is - syntactically valid per Section 6.3, then the external reporting - arrangement was authorized by the destination ADMD. - - 7. If a "rua" or "ruf" tag is thus discovered, replace the - corresponding value extracted from the domain's DMARC policy - record with the one found in this record. This permits the - report receiver to override the report destination. However, to - prevent loops or indirect abuse, the overriding URI MUST use the - same destination host from the first step. - -=cut - -} diff --git a/plugins/sender_permitted_from b/plugins/sender_permitted_from index 1f16a8d..7b049a9 100644 --- a/plugins/sender_permitted_from +++ b/plugins/sender_permitted_from @@ -53,6 +53,7 @@ The reject options are modeled after, and aim to match the functionality of thos =head1 AUTHOR + Matt Simerson - 2013 - populate dmarc_spf note with SPF results Matt Simerson - 2012 - increased policy options from 3 to 6 Matt Simerson - 2011 - rewrote using Mail::SPF Matt Sergeant - 2003 - initial plugin @@ -88,11 +89,22 @@ sub register { sub mail_handler { my ($self, $transaction, $sender, %param) = @_; - return (DECLINED) if $self->is_immune(); + if ( $self->is_immune() ) { + $transaction->notes('dmarc_spf', { + domain => $sender->host, + scope => 'mfrom', + result => 'pass', + } ); + return (DECLINED); + }; my $format = $sender->format; if ($format eq '<>' || !$sender->host || !$sender->user) { $self->log(LOGINFO, "skip, null sender"); + $transaction->notes('dmarc_spf', { + scope => 'helo', + result => 'none', + } ); return (DECLINED, "SPF - null sender"); } @@ -114,6 +126,12 @@ sub mail_handler { $req_params{helo_identity} = $helo; } + $transaction->notes('dmarc_spf', { + domain => $scope eq 'helo' ? $helo : $sender->host, + scope => $scope, + result => 'none', + } ); + my $spf_server = Mail::SPF::Server->new(); my $request = Mail::SPF::Request->new(%req_params); my $result = $spf_server->process($request) or do { @@ -133,6 +151,12 @@ sub mail_handler { return (DECLINED, "SPF - no response"); } + $transaction->notes('dmarc_spf', { + domain => $scope eq 'helo' ? $helo : $sender->host, + scope => $scope, + result => $code, + } ); + $self->store_auth_results("spf=$code smtp.mailfrom=".$sender->host); if ($code eq 'pass') { From 7a855d4d6bbcd75d834a1a1d9990ebbd77df564c Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Tue, 17 Dec 2013 23:56:02 -0500 Subject: [PATCH 337/352] added dmarc (run SPF & DKIM) first comment --- config.sample/plugins | 1 + 1 file changed, 1 insertion(+) diff --git a/config.sample/plugins b/config.sample/plugins index 46e75d6..28684a6 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -73,6 +73,7 @@ headers reject 0 reject_type temp require From,Date future 2 past 15 bogus_bounce log #loop dkim reject 0 +# dmarc requires dkim and SPF to run before it dmarc # content filters From 725a8d1960c5b2310aa8a054a2ab2b99d44939a6 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Tue, 17 Dec 2013 23:59:57 -0500 Subject: [PATCH 338/352] dspam: remove hard coded default in train_ methods --- plugins/dspam | 41 ++++++++++------------------------------- 1 file changed, 10 insertions(+), 31 deletions(-) diff --git a/plugins/dspam b/plugins/dspam index e9f8be6..2b6a8b5 100644 --- a/plugins/dspam +++ b/plugins/dspam @@ -208,7 +208,8 @@ use IO::Handle; use Socket qw(:DEFAULT :crlf); sub register { - my ($self, $qp) = (shift, shift); + my $self = shift; + my $qp = shift; $self->log(LOGERROR, "Bad parameters for the dspam plugin") if @_ % 2; @@ -590,20 +591,8 @@ sub train_error_as_ham { my $dspam_bin = $self->{_args}{dspam_bin} || '/usr/local/bin/dspam'; my $cmd = "$dspam_bin --user $user --mode=toe --source=error --class=innocent --deliver=summary --stdout"; - my $response = $self->dspam_process($cmd, $transaction); - if ($response) { - $transaction->notes('dspam', $response); - } - else { - $transaction->notes( - 'dspam', - { - class => 'Innocent', - result => 'Innocent', - confidence => 1 - } - ); - } + $self->dspam_process($cmd, $transaction); + return; } sub train_error_as_spam { @@ -614,20 +603,8 @@ sub train_error_as_spam { my $dspam_bin = $self->{_args}{dspam_bin} || '/usr/local/bin/dspam'; my $cmd = "$dspam_bin --user $user --mode=toe --source=error --class=spam --deliver=summary --stdout"; - my $response = $self->dspam_process($cmd, $transaction); - if ($response) { - $transaction->notes('dspam', $response); - } - else { - $transaction->notes( - 'dspam', - { - class => 'Spam', - result => 'Spam', - confidence => 1 - } - ); - } + $self->dspam_process($cmd, $transaction); + return; } sub autolearn { @@ -649,6 +626,7 @@ sub autolearn { $self->autolearn_naughty($response, $transaction) and return; $self->autolearn_karma($response, $transaction) and return; $self->autolearn_spamassassin($response, $transaction) and return; + return; } sub autolearn_naughty { @@ -723,8 +701,9 @@ sub autolearn_spamassassin { $self->log(LOGINFO, "training SA FN as spam"); $self->train_error_as_spam($transaction); return 1; - } - elsif ( $sa->{is_spam} eq 'No' + }; + + if ( $sa->{is_spam} eq 'No' && $sa->{autolearn} eq 'ham' && $response->{result} eq 'Spam') { From 96dfb08d8738968f6c2dafe791394533efe979a4 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 18 Dec 2013 00:00:52 -0500 Subject: [PATCH 339/352] headers: added POD descripting each header --- plugins/headers | 76 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 76 insertions(+) diff --git a/plugins/headers b/plugins/headers index 1465e67..4bdd275 100644 --- a/plugins/headers +++ b/plugins/headers @@ -218,3 +218,79 @@ sub invalid_date_range { return; } +__END__ + +=head1 SMTP HEADERS + +http://forum.unifiedemail.net/default.aspx?g=posts&t=68 + +=head2 From: + +The eMail address, and optionally the name of the author(s). In many eMail clients not changeable except through changing account settings. + +=head2 To: + +The eMail address(es), and optionally name(s) of the message's recipient(s). Indicates primary recipients (multiple allowed), for secondary recipients see Cc: and Bcc: below. + +=head2 Subject: + +A brief summary of the topic of the message. Certain abbreviations are commonly used in the subject, including "RE:" and "FW:". + +=head2 Date: + +The local time and date when the message was written. Like the From: field, many email clients fill this in automatically when sending. The recipient's client may then display the time in the format and time zone local to him/her. + +=head2 Message-ID: + +Also an automatically generated field; used to prevent multiple delivery and for reference in In-Reply-To: (see below). + +=head2 Bcc: + +Blind Carbon Copy; addresses added to the SMTP delivery list but not (usually) listed in the message data, remaining invisible to other recipients. + +=head2 Cc: + +Carbon copy; Many eMail clients will mark eMail in your inbox differently depending on whether you are in the To: or Cc: list. + +=head2 Content-Type: + +Information about how the message is to be displayed, usually a MIME type. + +=head2 In-Reply-To: + +Message-ID of the message that this is a reply to. Used to link related messages together. + +=head2 Precedence: + +Commonly with values "bulk", "junk", or "list"; used to indicate that automated "vacation" or "out of office" responses should not be returned for this mail, e.g. to prevent vacation notices from being sent to all other subscribers of a mailinglist. + +=head2 Received: + +Tracking information generated by mail servers that have previously handled a message, in reverse order (last handler first). + +=head2 References: + +Message-ID of the message that this is a reply to, and the message-id of the message the previous was reply a reply to, etc. + +=head2 Reply-To: + +Address that should be used to reply to the message. + +=head2 Sender: + +Address of the actual sender acting on behalf of the author listed in the From: field (secretary, list manager, etc.). + +=head2 Return-Path: + +When the delivery SMTP server makes the "final delivery" of a message, it inserts a return-path line at the beginning of the mail data. Thisuse of return-path is required; mail systems MUST support it. The return-path line preserves the information in the from the MAIL command. + +=head2 Error-To: + +Indicates where error messages should be sent. In the absence of this line, they go to the Sender:, and absent that, the From: address. + +=head2 X-* + +No standard header field will ever begin with the characters "X-", so application developers are free to use them for their own purposes. + +=cut + From a4695cec8bd22e436a0c65d9c3f60bf4f1434f0f Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 18 Dec 2013 00:02:07 -0500 Subject: [PATCH 340/352] geoip: added named array for invalid args so it passes Perl::Critic tests --- plugins/ident/geoip | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/plugins/ident/geoip b/plugins/ident/geoip index b25408b..b24c460 100644 --- a/plugins/ident/geoip +++ b/plugins/ident/geoip @@ -116,10 +116,10 @@ use Qpsmtpd::Constants; #use Math::Trig; # eval'ed in set_distance_gc sub register { - my ($self, $qp) = shift, shift; + my ($self, $qp, @args) = @_; - $self->log(LOGERROR, "Bad arguments") if @_ % 2; - $self->{_args} = {@_}; + $self->log(LOGERROR, "Bad arguments") if @args % 2; + $self->{_args} = {@args}; $self->{_args}{db_dir} ||= '/usr/local/share/GeoIP'; eval 'use Geo::IP'; From a19b7de7871e83e0af25b7be3a0362db9c56e47e Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 18 Dec 2013 00:09:10 -0500 Subject: [PATCH 341/352] updated DMARC plugin tests disabled for now, b/c they tested methods which no longer exist in new plugin --- t/plugin_tests/dmarc | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/t/plugin_tests/dmarc b/t/plugin_tests/dmarc index 461db72..093c3a7 100644 --- a/t/plugin_tests/dmarc +++ b/t/plugin_tests/dmarc @@ -12,9 +12,7 @@ my $test_email = 'matt@tnpi.net'; sub register_tests { my $self = shift; - $self->register_test('test_get_organizational_domain', 3); - $self->register_test("test_fetch_dmarc_record", 3); - $self->register_test("test_discover_policy", 1); +# TODO: test against newer DMARC plugin that uses Mail::DMARC } sub setup_test_headers { From fd4cc6f8abfadc78f08f219d2c89cc5f30b9e9b6 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 18 Dec 2013 00:11:16 -0500 Subject: [PATCH 342/352] Qpsmtpd: version bump to 0.94 --- lib/Qpsmtpd.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index fc41789..9e3d3e2 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -7,7 +7,7 @@ use Qpsmtpd::Constants; #use DashProfiler; -$VERSION = "0.93"; +$VERSION = "0.94"; my $git; From 9f88e374c2b4908732e6cffdae84fb7f3b3e386b Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 18 Dec 2013 00:11:53 -0500 Subject: [PATCH 343/352] tls: reduced importants of an info message from WARN to INFO --- plugins/tls | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/tls b/plugins/tls index 4aceaad..5d94565 100644 --- a/plugins/tls +++ b/plugins/tls @@ -141,7 +141,7 @@ sub hook_unrecognized_command { return DENY, "TLS Negotiation Failed"; } - $self->log(LOGWARN, "TLS setup returning"); + $self->log(LOGINFO, "TLS setup returning"); return DONE; } From 02da55e06d94a3b8abb3aed13d4f59fca81fbbf2 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 18 Dec 2013 00:15:20 -0500 Subject: [PATCH 344/352] karma: added penalty for spammy TLDs --- plugins/karma | 41 +++++++++++++++++++++++++++++++---------- 1 file changed, 31 insertions(+), 10 deletions(-) diff --git a/plugins/karma b/plugins/karma index 4dd0437..da1d515 100644 --- a/plugins/karma +++ b/plugins/karma @@ -210,8 +210,14 @@ There is little to be gained by listing servers that are already on DNS blacklists, send to invalid users, earlytalkers, etc. Those already have very lightweight tests. +=head1 TODO + + * Avoid storing results for DNSBL listed IPs + * some type of ASN integration, for tracking karma of 'neighborhoods' + =head1 AUTHOR + 2013 - MS - Addeded penalty for spammy TLDs 2012 - Matt Simerson - msimerson@cpan.org =head1 ACKNOWLEDGEMENTS @@ -244,8 +250,8 @@ sub register { #$self->prune_db(); # keep the DB compact $self->register_hook('connect', 'connect_handler'); - $self->register_hook('mail_pre', 'from_handler'); - $self->register_hook('rcpt_pre', 'rcpt_handler'); + $self->register_hook('mail', 'from_handler'); + $self->register_hook('rcpt', 'rcpt_handler'); $self->register_hook('data', 'data_handler'); $self->register_hook('data_post', 'data_handler'); $self->register_hook('disconnect', 'disconnect_handler'); @@ -323,17 +329,32 @@ sub connect_handler { } sub from_handler { - my ($self, $transaction, $addr) = @_; + my ($self,$transaction, $sender, %args) = @_; # test if sender has placed an illegal (RFC (2)821) space in envelope from my $full_from = $self->connection->notes('envelope_from'); $self->illegal_envelope_format( $full_from ); + my %spammy_tlds = ( + map { $_ => 4 } qw/ info pw /, + map { $_ => 3 } qw/ tw biz /, + map { $_ => 2 } qw/ cl br fr be jp no se sg /, + ); + foreach my $tld ( keys %spammy_tlds ) { + my $len = length $tld; + my $score = $spammy_tlds{$tld} or next; + $len ++; + if ( $sender->host && ".$tld" eq substr($sender->host,-$len,$len) ) { + $self->log(LOGINFO, "penalizing .$tld envelope sender"); + $self->adjust_karma(-$score); + }; + }; + return DECLINED; }; sub rcpt_handler { - my ($self, $transaction, $addr) = @_; + my ($self,$transaction, $recipient, %args) = @_; $self->illegal_envelope_format( $self->connection->notes('envelope_rcpt'), @@ -342,7 +363,7 @@ sub rcpt_handler { my $count = $self->connection->notes('recipient_count') || 0; $count++; if ( $count > 1 ) { - $self->log(LOGINFO, "recipients c: $count ($addr)"); + $self->log(LOGINFO, "recipients c: $count ($recipient)"); $self->connection->notes('recipient_count', $count); }; @@ -352,7 +373,7 @@ sub rcpt_handler { $self->log(LOGDEBUG, "info, no recipient count"); return DECLINED; }; - $self->log(LOGINFO, "recipients t: $recipients ($addr)"); + $self->log(LOGINFO, "recipients t: $recipients ($recipient)"); my $history = $self->connection->notes('karma_history'); if ( $history > 0 ) { @@ -378,7 +399,7 @@ sub data_handler { # cutting off a naughty sender at DATA prevents having to receive the message my $karma = $self->connection->notes('karma'); - if ( $karma < -3 ) { # bad karma + if ( $karma < -4 ) { # bad karma return $self->get_reject("very bad karma: $karma"); }; @@ -403,7 +424,7 @@ sub disconnect_handler { my $history = ($nice || 0) - $naughty; my $log_mess = ''; - if ($karma < -1) { # they achieved at least 2 strikes + if ($karma < -2) { # they achieved at least 2 strikes $history--; my $negative_limit = 0 - $self->{_args}{negative}; if ($history <= $negative_limit) { @@ -420,7 +441,7 @@ sub disconnect_handler { $log_mess = "negative"; } } - elsif ($karma > 1) { + elsif ($karma > 2) { $nice++; $log_mess = "positive"; } @@ -439,7 +460,7 @@ sub illegal_envelope_format { # test if envelope address has an illegal (RFC (2)821) space if ( uc substr($addr,0,6) ne 'FROM:<' && uc substr($addr,0,4) ne 'TO:<' ) { $self->log(LOGINFO, "illegal envelope address format: $addr" ); - $self->adjust_karma(-1); + $self->adjust_karma(-2); }; }; From bcc6adae1931c38d6b652a077d216efb2250b328 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 18 Dec 2013 00:16:02 -0500 Subject: [PATCH 345/352] helo: add karma penalty for no HELO hostname --- plugins/helo | 1 + 1 file changed, 1 insertion(+) diff --git a/plugins/helo b/plugins/helo index d6ab0b5..500fe79 100644 --- a/plugins/helo +++ b/plugins/helo @@ -253,6 +253,7 @@ sub helo_handler { if (!$host) { $self->log(LOGINFO, "fail, tolerated, no helo host"); + $self->adjust_karma(-2); return DECLINED; } From 45316487e3c2e383b11e42af12e84199561a6790 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 18 Dec 2013 00:16:41 -0500 Subject: [PATCH 346/352] anglebrackets: increase penalty, prefix log msgs --- plugins/dont_require_anglebrackets | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/plugins/dont_require_anglebrackets b/plugins/dont_require_anglebrackets index c8f25fd..16841e9 100644 --- a/plugins/dont_require_anglebrackets +++ b/plugins/dont_require_anglebrackets @@ -24,9 +24,9 @@ MAIL FROM:user@example.com sub hook_mail_pre { my ($self, $transaction, $addr) = @_; unless ($addr =~ /^<.*>$/) { - $self->log(LOGINFO, "added MAIL angle brackets"); $addr = '<' . $addr . '>'; - $self->adjust_karma(-1); + $self->adjust_karma(-2); + $self->log(LOGINFO, "fail, added MAIL angle brackets"); } return (OK, $addr); } @@ -34,9 +34,9 @@ sub hook_mail_pre { sub hook_rcpt_pre { my ($self, $transaction, $addr) = @_; unless ($addr =~ /^<.*>$/) { - $self->log(LOGINFO, "added RCPT angle brackets"); $addr = '<' . $addr . '>'; - $self->adjust_karma(-1); + $self->adjust_karma(-2); + $self->log(LOGINFO, "fail, added RCPT angle brackets"); } return (OK, $addr); } From 2d4f4a299a6470b0bc59cb1915f5f73e40bfcf5c Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 18 Dec 2013 00:17:37 -0500 Subject: [PATCH 347/352] naughty: legibility improvement --- plugins/naughty | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/plugins/naughty b/plugins/naughty index 3b41826..caea455 100644 --- a/plugins/naughty +++ b/plugins/naughty @@ -140,11 +140,8 @@ sub naughty { return DECLINED; }; $self->log(LOGINFO, "disconnecting"); - my $type = $self->get_reject_type( - 'disconnect', - $self->connection->notes( - 'naughty_reject_type') - ); + my $rtype = $self->connection->notes( 'naughty_reject_type' ); + my $type = $self->get_reject_type( 'disconnect', $rtype ); return ($type, $naughty); } From 0e0cda6d95d2208e5050ebe1a9d663a374c31ddd Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 18 Dec 2013 00:21:46 -0500 Subject: [PATCH 348/352] updated Changes with some 0.94 commits --- Changes | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/Changes b/Changes index 3e377a8..ae058b3 100644 --- a/Changes +++ b/Changes @@ -1,4 +1,15 @@ +0.94 ___ NN, 2014 + + Updated DMARC plugin to use Mail::DMARC + + Updated SPF & DKIM plugins to store data for DMARC processing + + karma plugin: added spammy TLD penalty + + a few more log prefixes (corralling stragglers) + + 0.93 Dec 17, 2013 Added Authentication-Results header From 3353578d8bb9be99fe33b3e0d4c95f0bb714b5a3 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Fri, 20 Dec 2013 00:22:09 -0500 Subject: [PATCH 349/352] clamdscan: add support for remote TCP/IP clamd previous version only worked when clamd was running on the same machine and had access to the spool file. This version also works with a remote clamd. --- plugins/virus/clamdscan | 56 ++++++++++++++++++++++++++++++++--------- 1 file changed, 44 insertions(+), 12 deletions(-) diff --git a/plugins/virus/clamdscan b/plugins/virus/clamdscan index 2928665..a12d6b7 100644 --- a/plugins/virus/clamdscan +++ b/plugins/virus/clamdscan @@ -10,6 +10,8 @@ A qpsmtpd plugin for virus scanning using the ClamAV scan daemon, clamd. =head1 RESTRICTIONS +If connecting to clamd via TCP/IP host:port, then ignore this restriction. + 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: @@ -47,19 +49,26 @@ You must have the ClamAV::Client module installed to use the plugin. =item B -Full path to the clamd socket (the recommended mode), if different from the -ClamAV::Client defaults. +Full path to the clamd socket, if different from the ClamAV::Client defaults. + +=item B + +IP address where clamd is listening. + +Default: localhost =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. +The TCP port where the clamd service is running, typically 3310. + +Default: disabled. When present, overrides 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. +Takes either 'yes' or 'no'. If set to 'no', adds a header with the virus name. + +Default: yes =item B @@ -71,7 +80,9 @@ backlog or be lost if the condition persists. =item B -The maximum size, in kilobytes, of messages to scan; defaults to 128k. +The maximum size, in kilobytes, of messages to scan. + +Default: 1024 (1 MB) =item B @@ -94,6 +105,7 @@ adjusted for ClamAV::Client by Devin Carraway . Copyright (c) 2005 John Peacock, Copyright (c) 2007 Devin Carraway + Copyright (c) 2013 Matt Simerson Based heavily on the clamav plugin @@ -106,10 +118,13 @@ use strict; use warnings; #use ClamAV::Client; # eval'ed in $self->register +use Socket qw(:DEFAULT :crlf); + use Qpsmtpd::Constants; sub register { - my ($self, $qp) = shift, shift; + my $self = shift; + my $qp = shift; $self->log(LOGERROR, "Bad parameters for the clamdscan plugin") if @_ % 2; $self->{'_args'} = {@_}; @@ -138,7 +153,6 @@ sub register { sub data_post_handler { my ($self, $transaction) = @_; - my $filename = $self->get_filename($transaction) or return DECLINED; if ($self->connection->notes('naughty')) { $self->log(LOGINFO, "skip, naughty"); @@ -147,8 +161,6 @@ sub data_post_handler { 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"); @@ -159,7 +171,18 @@ sub data_post_handler { my ($version) = split(/\//, $clamd->version); $version ||= 'ClamAV'; - my ($path, $found) = eval { $clamd->scan_path($filename) }; + my ($path, $found); + if ( $self->{_args}{clamd_port} ) { + my $message = $self->assemble_message($transaction); + $found = eval { $clamd->scan_scalar(\$message) }; # pass scalar ref +# $found = eval { $clamd->scan_stream() }; # pass IO handle + } + else { + my $filename = $self->get_filename($transaction) or return DECLINED; + $self->set_permission($filename) or return DECLINED; + ($path, $found) = eval { $clamd->scan_path($filename) }; + }; + if ($@) { return $self->err_and_return("Error scanning mail: $@"); } @@ -186,6 +209,15 @@ sub data_post_handler { return (DECLINED); } +sub assemble_message { + my ($self, $transaction) = @_; + $transaction->body_resetpos; + my $message = $transaction->header->as_string . "\n\n"; + while (my $line = $transaction->body_getline) { $message .= $line; } + $message = join(CRLF, split /\n/, $message); + return $message . CRLF; +} + sub err_and_return { my $self = shift; my $message = shift; From 4d1b9ffe3250a2d4f7c3ba9890443e321c0d8e8b Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 8 Jan 2014 16:10:38 -0800 Subject: [PATCH 350/352] headers: use a more descriptive variable name --- plugins/headers | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/plugins/headers b/plugins/headers index 4bdd275..d2c6f1d 100644 --- a/plugins/headers +++ b/plugins/headers @@ -196,20 +196,20 @@ sub invalid_date_range { my $date = shift || $self->transaction->header->get('Date') or return; chomp $date; - my $ts = str2time($date) or do { + my $msg_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)) { + if ($past && $msg_ts < time - ($past * 24 * 3600)) { $self->log(LOGINFO, "fail, date too old ($date)"); $self->adjust_karma(-1); return "The Date header is too far in the past"; } my $future = $self->{_args}{future}; - if ($future && $ts > time + ($future * 24 * 3600)) { + if ($future && $msg_ts > time + ($future * 24 * 3600)) { $self->log(LOGINFO, "fail, date in future ($date)"); $self->adjust_karma(-1); return "The Date header is too far in the future"; From 3a47dd2ac28b87d89469d1dfa3321fe6cf5dc060 Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Wed, 8 Jan 2014 19:22:16 -0500 Subject: [PATCH 351/352] dmarc: skip processing for null sender --- plugins/dmarc | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/plugins/dmarc b/plugins/dmarc index 7e98e89..a7b82d2 100644 --- a/plugins/dmarc +++ b/plugins/dmarc @@ -106,6 +106,10 @@ sub data_post_handler { my $dmarc = $self->{_dmarc}; $dmarc->init(); my $from = $transaction->header->get('From'); + if ( ! $from ) { + $self->log(LOGINFO, "skip, null sender" ); + return $self->get_reject("empty from address, null sender?"); + }; eval { $dmarc->header_from_raw( $from ); }; if ( $@ ) { $self->log(LOGERROR, "unparseable from header: $from" ); From 0fee54579424943cd1080f9f9ff2501b6700becf Mon Sep 17 00:00:00 2001 From: Matt Simerson Date: Mon, 16 Dec 2013 00:38:35 -0800 Subject: [PATCH 352/352] domainkeys: fixed doc typo --- plugins/domainkeys | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/domainkeys b/plugins/domainkeys index 5b9a33b..9fa1958 100644 --- a/plugins/domainkeys +++ b/plugins/domainkeys @@ -43,7 +43,7 @@ the same terms as Perl itself. =head1 AUTHORS - Matt Simerson - 2013 - safe results to Authentication-Results header + Matt Simerson - 2013 - save results to Authentication-Results header instead of DomainKey-Status Matt Simerson - 2012 - refactored, added tests, safe loading John Peacock - 2005-2006