Merge pull request #35 from msimerson/master

Merging in changes from qpsmtpd-dev fork

.gitignore

@@ -19,5 +19,9 @@ greylist.dbm
 greylist.dbm.lock
 
 /cover_db/
+.last_cover_stats
 
 *.tar.gz
+
+MANIFEST.bak
+nytprof.out

.travis.yml

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

Changes

@@ -1,5 +1,114 @@
 
-Next Version
+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.
+        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
+
+  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
+     - limit recipients to 1 for senders with negative 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
+
+  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
+
+  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
+
+  check_badmailfrom_patterns, merged functionality into check_badmailfrom
+
+  check_badrcptto_patterns, merged functionality into check_badrcptto
 
   check_basicheaders. New arguments available: past, future, reject, reject_type
 
@@ -9,7 +118,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)
 
@@ -19,7 +128,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)
@@ -36,12 +145,12 @@ 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)
 
-  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)
@@ -155,7 +264,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
 
@@ -183,7 +292,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
@@ -445,7 +554,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
@@ -562,7 +671,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
+  earlytalker and resolvable_fromhost - short circuit test if
   whitelistclient is set. (Michael Toren)
 
   check_badmailfrom - Do not say why a given message is denied.
@@ -634,7 +743,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)
@@ -720,7 +829,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
 
@@ -784,7 +893,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

MANIFEST

@@ -1,20 +1,27 @@
 .gitignore
+.travis.yml
+bin/install_deps.pl
 Changes
 config.sample/badhelo
 config.sample/badmailfrom
-config.sample/badrcptto_patterns
+config.sample/badrcptto
+config.sample/dkim/dkim_key_gen.sh
+config.sample/dnsbl_allow
 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
 config.sample/plugins
+config.sample/public_suffix_list
 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
@@ -50,16 +57,21 @@ 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/check_earlytalker
 plugins/async/dns_whitelist_soft
 plugins/async/dnsbl
+plugins/async/earlytalker
 plugins/async/queue/smtp-forward
-plugins/async/require_resolvable_fromhost
+plugins/async/resolvable_fromhost
 plugins/async/rhsbl
 plugins/async/uribl
 plugins/auth/auth_checkpassword
@@ -70,29 +82,32 @@ plugins/auth/auth_vpopmail
 plugins/auth/auth_vpopmail_sql
 plugins/auth/auth_vpopmaild
 plugins/auth/authdeny
-plugins/check_badmailfrom
+plugins/badmailfrom
-plugins/check_badmailfromto
+plugins/badmailfromto
-plugins/check_badrcptto
+plugins/badrcptto
-plugins/check_badrcptto_patterns
+plugins/bogus_bounce
-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/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
 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
@@ -101,9 +116,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
@@ -111,9 +129,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/require_resolvable_fromhost
+plugins/registry.txt
+plugins/relay
+plugins/resolvable_fromhost
 plugins/rhsbl
 plugins/sender_permitted_from
 plugins/spamassassin
@@ -129,32 +150,64 @@ plugins/virus/kavscanner
 plugins/virus/klez_filter
 plugins/virus/sophie
 plugins/virus/uvscan
+plugins/whitelist
 qpsmtpd
 qpsmtpd-async
 qpsmtpd-forkserver
 qpsmtpd-prefork
 README
 README.plugins
-run
+run.forkserver
+run.tcpserver
 STATUS
 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/public_suffix_list
+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/badmailfrom
-t/plugin_tests/greylisting
+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
+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/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
+xt/01-syntax.t
+xt/02-pod.t

MANIFEST.SKIP

@@ -21,6 +21,7 @@ output/.*
 ^pm_to_blib$
 ~$
 ^MANIFEST\.bak
+^MYMETA\.
 ^tv\.log$
 ^MakeMaker-\d
 \#$
@@ -30,3 +31,8 @@ output/.*
 ^cover_db/
 \.(orig|rej)$
 packaging
+^log/main/
+^config/
+^supervise/
+^ssl/
+^t/config/greylist

META.yml

@@ -0,0 +1,33 @@
+---
+abstract: 'Flexible smtpd daemon written in Perl'
+author:
+  - 'Ask Bjoern Hansen <ask@develooper.com>'
+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

Makefile.PL

@@ -7,18 +7,32 @@ 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
+        'Mail::DKIM'         => 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,   # log2sql
+# 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',
     AUTHOR         => 'Ask Bjoern Hansen <ask@develooper.com>',
     EXE_FILES      => [qw(qpsmtpd qpsmtpd-forkserver qpsmtpd-prefork qpsmtpd-async)],
+    clean          => { FILES => [ '*.bak' ], },
 );
 
 sub MY::libscan {
@@ -28,11 +42,11 @@ sub MY::libscan {
 }
 
 sub MY::postamble {
-  qq[
+    qq[
 testcover :
 \t cover -delete && \\
-   HARNESS_PERL_SWITCHES=-MDevel::Cover \$(MAKE) test && \\
+	HARNESS_PERL_SWITCHES=-MDevel::Cover \$(MAKE) test && \\
-   cover
+	cover
 ]
 
 }

README

@@ -12,6 +12,8 @@ web:
 mailinglist:
   qpsmtpd-subscribe@perl.org
 
+FAQ:
+  https://github.com/qpsmtpd-dev/qpsmtpd-dev/wiki/faq
 
 =head1 DESCRIPTION
 
@@ -123,7 +125,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 +159,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

STATUS

@@ -1,16 +1,42 @@
 
-New Name Suggestions
+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
-ignite
+but the plugin organization, documentation, and consistency left much
-flare(mta)
+to be desired.
-quench
+
-pez (or pezmail)
+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,
+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 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
+  - 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
 =======
 
- - 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 +50,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

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.
+
+

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 => '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' } },
+];
+
+$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 =~ /}/;
+        next if $line !~ /=/;  # no = char means not a module
+        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', }  },
+        { module=>'Mail::SpamAssassin' , info => { cat => 'mail', }  },
+    );
+    my ($match) = grep { $_->{module} eq $mod } @modules;
+    return $match if $match;
+    return { module=>$mod, info => { } };
+};

config.sample/badrcptto_patterns

@@ -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 

config.sample/dkim/dkim_key_gen.sh

@@ -0,0 +1,62 @@
+#!/bin/sh
+
+usage() {
+    echo "   usage: $0 <example.com> [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 <<EO_DKIM_DNS
+
+`cat selector | tr -d "\n"`._domainkey TXT "v=DKIM1;p=`grep -v -e '^-' public | tr -d "\n"`"
+
+Tell the world that the ONLY mail servers that send mail from this domain are DKIM signed and/or bear our MX and A records.
+
+With SPF:
+
+        SPF "v=spf1 mx a -all"
+        TXT "v=spf1 mx a -all"
+
+With DMARC:
+
+_dmarc  TXT "v=DMARC1; p=reject; adkim=s; aspf=r; rua=mailto:dmarc-feedback@$DOMAIN; ruf=mailto:dmarc-feedback@'$DOMAIN; pct=100"
+
+With DomainKeys (deprecated)
+
+_domainkey TXT "o=-; t=y; r=postmaster@$DOMAIN"
+
+For more information about DKIM and SPF policy, the documentation within each plugin contains a longer discussion and links to more detailed information:
+
+   perldoc plugins/dkim
+   perldoc plugins/sender_permitted_from
+
+
+EO_DKIM_DNS
+
+cd ..
+chown -R $SMTPD:$SMTPD $DOMAIN

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?

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

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.
 #
@@ -15,36 +19,32 @@
 # from one IP!
 hosts_allow
 
-# information plugins
+# connection / informational plugins
+#connection_time
+#karma penalty_box 1 reject naughty
 ident/geoip
 #ident/p0f /tmp/.p0f_socket version 3
-#connection_time
+fcrdns
 
-# enable to accept MAIL FROM:/RCPT TO: addresses without surrounding <>
+quit_fortune
-dont_require_anglebrackets
+earlytalker
+count_unrecognized_commands 4
 
+relay
+#whitelist
+dnsbl reject naughty reject_type disconnect
+rhsbl
+# greylisting reject 0 p0f genre,windows
+
+
+# HELO plugins
+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
 
-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 plugins
 #auth/auth_checkpassword checkpw /usr/local/vpopmail/bin/vchkpw true /usr/bin/true
 #auth/auth_vpopmail
 #auth/auth_vpopmaild
@@ -52,31 +52,50 @@ check_spamhelo
 auth/auth_flat_file
 auth/authdeny
 
+# enable to accept MAIL FROM:/RCPT TO: addresses without surrounding <>
+dont_require_anglebrackets
+
+# MAIL FROM plugins
+badmailfrom reject naughty
+#badmailfromto
+resolvable_fromhost reject 0
+sender_permitted_from reject 1
+
+# RCPT TO plugins
+badrcptto
+#qmail_deliverable
 # this plugin needs to run after all other "rcpt" plugins
 rcpt_ok
 
-check_basicheaders days 5 reject_type temp
+# DATA plugins
-domainkeys
+#uribl
+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
 
-
 # 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
+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 max_size 1024
+
+naughty reject data
 
 # You must enable a queue plugin - see the options in plugins/queue/ - for example:
 
@@ -86,6 +105,9 @@ dspam learn_from_sa 7 reject 1
 # 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

config.sample/relayclients

@@ -1,6 +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 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

config.sample/require_resolvable_fromhost

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

docs/FAQ.pod

@@ -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

docs/config.pod

@@ -89,7 +89,11 @@ 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
 
@@ -140,9 +144,9 @@ evaluate the efficacy and listing policies of a DNSBL before using it.
 See also C<dnsbl_allow> and C<dnsbl_rejectmsg> in the documentation of the
 C<dnsbl> plugin
 
-=item require_resolvable_fromhost
+=item resolvable_fromhost
 
-Plugin: F<require_resolvable_fromhost>
+Plugin: F<resolvable_fromhost>
 
 Reject sender addresses where the MX is unresolvable, i.e. a boolean value
 is the only value in this file. If the MX resolves to something, reject the
@@ -153,5 +157,48 @@ only currenlty.
 
 =back
 
+=head2 Plugin settings arguments
+
+These are arguments that can be set on the config/plugins line, after the name
+of the plugin. These config options are available to all plugins.
+
+=over 4
+
+=item loglevel
+
+Adjust the quantity of logging for the plugin. See docs/logging.pod
+
+=item reject
+
+ plugin reject [ 0 | 1 | naughty ]
+
+Should the plugin reject mail?
+
+The special 'naughty' case will mark the connection as a naughty. Most plugins
+skip processing naughty connections. Filtering plugins can learn from them.
+Naughty connections are terminated up by the B<naughty> plugin.
+
+Plugins that use $self->get_reject() or $self->get_reject_type() will
+automatically honor this setting.
+
+=item reject_type
+
+ plugin reject_type [ perm | temp | disconnect | temp_disconnect ]
+
+Default: perm
+
+Values with temp in the name return a 4xx code and the others return a 5xx
+code.
+
+The I<reject_type> argument and the corresponding get_reject_type() method
+provides a standard way for plugins to automatically return the selected
+rejection type, as chosen by the config setting, the plugin author, or the
+get_reject_type() method.
+
+Plugins that are updated to use the $self->get_reject() or
+$self->get_reject_type() methods will automatically honor this setting.
+
+=back
+
 =cut
 

docs/hooks.pod

@@ -235,8 +235,8 @@ Arguments for this hook are
   # $sender: an Qpsmtpd::Address object for 
   # sender of the message
 
-Example plugins for the C<hook_mail> are F<require_resolvable_fromhost>
+Example plugins for the C<hook_mail> are F<resolvable_fromhost>
-and F<check_badmailfrom>.
+and F<badmailfrom>.
 
 =head2 hook_rcpt_pre
 
@@ -293,7 +293,7 @@ was sent, this hook is called.
 
 B<NOTE:> This hook, like B<EHLO>, B<VRFY>, B<QUIT>, B<NOOP>, is an 
 endpoint of a pipelined command group (see RFC 1854) and may be used to 
-detect ``early talkers''. Since svn revision 758 the F<check_earlytalker>
+detect ``early talkers''. Since svn revision 758 the F<earlytalker>
 plugin may be configured to check at this hook for ``early talkers''.
 
 Allowed return codes are

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} = { @_ };
  }
@@ -127,6 +127,40 @@ plugins in plugins/logging, specifically the L<plugins/logging/warn> and
 L<plugins/logging/adaptive> files for examples of how to write your own
 logging plugins.
 
+=head1 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

docs/plugins.pod

@@ -25,7 +25,7 @@ various I<hooks> provided by the qpsmtpd core engine.
 At least one plugin B<must> allow or deny the B<RCPT> command to enable 
 receiving mail. The F<check_relay> plugin is the standard plugin for this.
 Other plugins provide extra functionality related to this; for example the
-F<require_resolvable_fromhost> plugin.
+F<resolvable_fromhost> plugin.
 
 =head2 Loading Plugins
 

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::Const -compile     => qw(SO_NONBLOCK EOF SUCCESS);
-use APR::Error ();
+use APR::Error      ();
-use APR::Brigade ();
+use APR::Brigade    ();
-use APR::Bucket ();
+use APR::Bucket     ();
-use APR::Socket ();
+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,
+                               ip   => $c->remote_ip,
-        host => $c->remote_host,
+                               host => $c->remote_host,
-        info => undef,
+                               info => undef,
-        conn => $c,
+                               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) = @_;
+    my ($self, $config) = @_;
-  if (exists $cdir_memo{$config}) {
+    if (exists $cdir_memo{$config}) {
-      return $cdir_memo{$config};
+        return $cdir_memo{$config};
-  }
+    }
 
-  if (uc($ENV{QPSMTPD_CONFIG}) eq 'USE-VIRTUAL-DOMAINS') {
+    if (uc($ENV{QPSMTPD_CONFIG}) eq 'USE-VIRTUAL-DOMAINS') {
-      my $cdir = $self->{conn}->base_server->dir_config("qpsmtpd.config_dir");
+        my $cdir = $self->{conn}->base_server->dir_config("qpsmtpd.config_dir");
-      $cdir =~ /^(.*)$/; # detaint
+        $cdir =~ /^(.*)$/;    # detaint
-      my $configdir = $1 if -e "$1/$config";
+        my $configdir = $1 if -e "$1/$config";
-      $cdir_memo{$config} = $configdir;
+        $cdir_memo{$config} = $configdir;
-  } else {
+    }
-      $cdir_memo{$config} = $self->SUPER::config_dir(@_);
+    else {
-  }
+        $cdir_memo{$config} = $self->SUPER::config_dir(@_);
-  return $cdir_memo{$config};
+    }
+    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->{conn}
-    $self->{bb_in} = APR::Brigade->new($self->{conn}->pool, $self->{conn}->bucket_alloc);
+      ->client_socket->timeout_set($self->config('timeout') * 1_000_000);
-    $self->{bb_out} = APR::Brigade->new($self->{conn}->pool, $self->{conn}->bucket_alloc);
+    $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_info => $remote_info,
-        remote_ip   => $remote_ip,
+                                    remote_ip   => $remote_ip,
-        remote_host => $remote_host,
+                                    remote_host => $remote_host,
-        local_ip    => $opts{conn}->local_ip,
+                                    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;
     }

lib/Danga/Client.pm

@@ -3,26 +3,26 @@
 package Danga::Client;
 use base 'Danga::TimeoutSocket';
 use fields qw(
-    line
+  line
-    pause_count
+  pause_count
-    read_bytes
+  read_bytes
-    data_bytes
+  data_bytes
-    callback
+  callback
-    get_chunks
+  get_chunks
-    reader_object
+  reader_object
-    );
+  );
 use Time::HiRes ();
 
 use bytes;
 
 # 30 seconds max timeout!
-sub max_idle_time       { 30 }
+sub max_idle_time    { 30 }
-sub max_connect_time    { 1200 }
+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->{line}          = '';
-    $self->{pause_count} = 0;
+    $self->{pause_count}   = 0;
-    $self->{read_bytes} = 0;
+    $self->{read_bytes}    = 0;
-    $self->{callback} = undef;
+    $self->{callback}      = undef;
     $self->{reader_object} = undef;
-    $self->{data_bytes} = '';
+    $self->{data_bytes}    = '';
-    $self->{get_chunks} = 0;
+    $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->{line} = substr(
-                                   $self->{read_bytes}, # negative offset
+                                   $self->{data_bytes},
-                                   0 - $self->{read_bytes}, # to end of str
+                                   $self->{read_bytes},        # negative offset
-                                   ""); # truncate that substr
+                                   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 {
+        $self->AddTimer(
-            if (length($self->{line}) && !$self->paused) {
+            0,
-                $self->process_read_buf(\""); # " for bad syntax highlighters
+            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 {
+        $self->AddTimer(
-            if (length($self->{line}) && !$self->paused) {
+            0,
-                $self->process_read_buf(\""); # " for bad syntax highlighters
+            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;

lib/Danga/TimeoutSocket.pm

@@ -22,8 +22,8 @@ sub new {
 }
 
 # overload these in a subclass
-sub max_idle_time       { 0 }
+sub max_idle_time    { 0 }
-sub max_connect_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_age;        # classname -> max age (0 means forever)
-    my %max_connect; # classname -> max connect time
+    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_age{$ref}     = $ref->max_idle_time    || 0;
-            $max_connect{$ref}  = $ref->max_connect_time || 0;
+            $max_connect{$ref} = $ref->max_connect_time || 0;
         }
         if (my $t = $max_connect{$ref}) {
             if ($v->{create_time} < $now - $t) {

lib/Qpsmtpd/Address.pm

@@ -25,9 +25,9 @@ for easy testing of values.
 =cut
 
 use overload (
-    '""'   => \&format,
+              '""'  => \&format,
-    'cmp'  => \&_addr_cmp,
+              '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 =~ /^<(.*)>$/ ) {
+    if ($user =~ /^<(.*)>$/) {
-	($user, $host) = $class->canonify($user);
+        ($user, $host) = $class->canonify($user);
-	return undef unless defined $user;
+        return undef unless defined $user;
     }
-    elsif ( not defined $host ) {
+    elsif (not defined $host) {
-	my $address = $user;
+        my $address = $user;
-	($user, $host) = $address =~ m/(.*)(?:\@(.*))/;
+        ($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
+    my $domain =
-                              : "$subdomain_expr(?:\.$subdomain_expr)*";
+        $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<format>.
 
 sub address {
     my ($self, $val) = @_;
-    if ( defined($val) ) {
+    if (defined($val)) {
-	$val = "<$val>" unless $val =~ /^<.+>$/;
+        $val = "<$val>" unless $val =~ /^<.+>$/;
-	my ($user, $host) = $self->canonify($val);
+        my ($user, $host) = $self->canonify($val);
-	$self->{_user} = $user;
+        $self->{_user} = $user;
-	$self->{_host} = $host;
+        $self->{_host} = $host;
     }
-    return ( defined $self->{_user} ?     $self->{_user} : '' )
+    return (defined $self->{_user} ? $self->{_user}       : '')
-         . ( defined $self->{_host} ? '@'.$self->{_host} : '' );
+      . (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) {
+    if ((my $user = $self->{_user}) =~ s/($qchar)/\\$1/g) {
-        return qq(<"$user")
+        return
-	. ( defined $self->{_host} ? '@'.$self->{_host} : '' ). ">";
+          qq(<"$user")
-      }
+          . (defined $self->{_host} ? '@' . $self->{_host} : '') . ">";
-    return "<".$self->address().">";
+    }
+    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);
+    my ($self, $key) = (shift, shift);
-  # Check for any additional arguments passed by the caller -- including undef
+
-  return $self->{_notes}->{$key} unless @_;
+    # Check for any additional arguments passed by the caller -- including undef
-  return $self->{_notes}->{$key} = shift;
+    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) ) {
+    unless (UNIVERSAL::isa($right, $class)) {
-	$right = $class->new($right);
+        $right = $class->new($right);
     }
 
-    #invert the address so we can sort by domain then user    
+    #invert the address so we can sort by domain then user
-    ($left  = join( '=', reverse( split('@', $left->format))) ) =~ tr/[<>]//d;
+    ($left  = join('=', reverse(split(/@/, $left->format)))) =~ tr/[<>]//d;
-    ($right = join( '=', reverse( split('@',$right->format))) ) =~ tr/[<>]//d;
+    ($right = join('=', reverse(split(/@/, $right->format)))) =~ tr/[<>]//d;
 
-    if ( $swap ) {
+    if ($swap) {
-	($right, $left) = ($left, $right);
+        ($right, $left) = ($left, $right);
     }
 
     return ($left cmp $right);

lib/Qpsmtpd/Auth.pm

@@ -1,5 +1,6 @@
 package Qpsmtpd::Auth;
-# See the documentation in 'perldoc README.authentication' 
+
+# See the documentation in 'perldoc docs/authentication.pod'
 
 use strict;
 use warnings;
@@ -10,163 +11,172 @@ use Digest::HMAC_MD5 qw(hmac_md5_hex);
 use MIME::Base64;
 
 sub e64 {
-  my ($arg) = @_;
+    my ($arg) = @_;
-  my $res = encode_base64($arg);
+    my $res = encode_base64($arg);
-  chomp($res);
+    chomp($res);
-  return($res);
+    return ($res);
 }
 
 sub SASL {
 
     # $DB::single = 1;
-    my ( $session, $mechanism, $prekey ) = @_;
+    my ($session, $mechanism, $prekey) = @_;
-    my ( $user, $passClear, $passHash, $ticket, $loginas );
+    my ($user, $passClear, $passHash, $ticket, $loginas);
 
-    if ( $mechanism eq 'plain' ) {
+    if ($mechanism eq 'plain') {
-        ($loginas, $user, $passClear) = get_auth_details_plain($session,$prekey);
+        ($loginas, $user, $passClear) =
-        return DECLINED if ! $user || ! $passClear;
+          get_auth_details_plain($session, $prekey);
+        return DECLINED if !$user || !$passClear;
     }
-    elsif ( $mechanism eq 'login' ) {
+    elsif ($mechanism eq 'login') {
-        ($user, $passClear) = get_auth_details_login($session,$prekey);
+        ($user, $passClear) = get_auth_details_login($session, $prekey);
-        return DECLINED if ! $user || ! $passClear;
+        return DECLINED if !$user || !$passClear;
     }
-    elsif ( $mechanism eq 'cram-md5' ) {
+    elsif ($mechanism eq 'cram-md5') {
-        ( $ticket, $user, $passHash ) = get_auth_details_cram_md5($session);
+        ($ticket, $user, $passHash) = get_auth_details_cram_md5($session);
-        return DECLINED if ! $user || ! $passHash;
+        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 ) =
+    my ($rc, $msg) =
-      $session->run_hooks( "auth-$mechanism", $mechanism, $user, $passClear,
+      $session->run_hooks("auth-$mechanism", $mechanism, $user, $passClear,
-        $passHash, $ticket );
+                          $passHash, $ticket);
 
     # try running the polymorphous hooks next
-    if ( !$rc || $rc == DECLINED ) {    
+    if (!$rc || $rc == DECLINED) {
-        ( $rc, $msg ) =
+        ($rc, $msg) =
-          $session->run_hooks( "auth", $mechanism, $user, $passClear,
+          $session->run_hooks("auth",     $mechanism, $user,
-            $passHash, $ticket );
+                              $passClear, $passHash,  $ticket);
     }
 
-    if ( $rc == OK ) {
+    if ($rc == OK) {
-        $msg = uc($mechanism) . " authentication successful for $user" .
+        $msg =
-            ( $msg ? " - $msg" : '');
+            uc($mechanism)
-        $session->respond( 235, $msg );
+          . " authentication successful for $user"
+          . ($msg ? " - $msg" : '');
+        $session->respond(235, $msg);
         $session->connection->relay_client(1);
-        $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 ? " - $msg" : '');
+            uc($mechanism)
-        $session->respond( 535, $msg );
+          . " authentication failed for $user"
-        $session->log( LOGDEBUG, $msg );  # already logged by $session->respond
+          . ($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) {
+    if (!$prekey) {
-        $session->respond( 334, ' ' );
+        $session->respond(334, ' ');
-        $prekey= <STDIN>;
+        $prekey = <STDIN>;
     }
 
-    my ( $loginas, $user, $passClear ) = split /\x0/, decode_base64($prekey);
+    my ($loginas, $user, $passClear) = split /\x0/, decode_base64($prekey);
 
-    if ( ! $user ) {
+    if (!$user) {
-        if ( $loginas ) {
+        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
+    if (!$ticket) {    # ticket is only passed in during testing
-    # rand() is not cryptographic, but we only need to generate a globally
+          # 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
+         # 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.
+         # once in the same second, or if the clock is skewed.
-        $ticket = sprintf( '<%x.%x@%s>',
+        $ticket =
-            rand(1000000), time(), $session->config('me') );
+          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 = <STDIN>;
 
-    if ( $line eq '*' ) {
+    if ($line eq '*') {
-        $session->respond( 501, "Authentication canceled" );
+        $session->respond(501, "Authentication canceled");
         return;
-    };
+    }
 
-    my ( $user, $passHash ) = split( ' ', decode_base64($line) );
+    my ($user, $passHash) = split(/ /, decode_base64($line));
-    unless ( $user && $passHash ) {
+    unless ($user && $passHash) {
         $session->respond(504, "Invalid authentication string");
         return;
     }
 
     $session->{auth}{ticket} = $ticket;
     return ($ticket, $user, $passHash);
-};
+}
 
 sub get_base64_response {
     my ($session, $question) = @_;
 
     $session->respond(334, e64($question));
-    my $answer = decode_base64( <STDIN> );
+    my $answer = decode_base64(<STDIN>);
     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};
@@ -176,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" );
+        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 && $method =~ /CRAM-MD5/i) {
-        if ( $src_clear && $src_clear eq $attempt_clear ) {
+        $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 );
+            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 ($src_crypt && $src_crypt eq crypt($attempt_clear, $src_crypt)) {
-        if ( ! $ticket ) {
+            $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
 

lib/Qpsmtpd/Command.pm

@@ -60,8 +60,8 @@ use vars qw(@ISA);
 @ISA = qw(Qpsmtpd::SMTP);
 
 sub parse {
-    my ($me,$cmd,$line,$sub) = @_;
+    my ($me, $cmd, $line, $sub) = @_;
-    return (OK) unless defined $line; # trivial case
+    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 (OK, "<>") unless $line;    # 'MAIL FROM:' --> 'MAIL FROM:<>'
-        return (DENY, "Syntax error in parameters") 
+        return (DENY, "Syntax error in parameters")
-          if ($line =~ /\@.*\s/); # parameter syntax error
+          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") 
+            return (DENY, "Syntax error in address")
-              unless ($line =~ /^(postmaster|abuse)$/i); 
+              unless ($line =~ /^(postmaster|abuse)$/i);
         }
     }
     ## XXX:  No: let this do a plugin, so it's not up to us to decide

lib/Qpsmtpd/ConfigServer.pm

@@ -6,38 +6,38 @@ use Qpsmtpd::Constants;
 use strict;
 
 use fields qw(
-    _auth
+  _auth
-    _commands
+  _commands
-    _config_cache
+  _config_cache
-    _connection
+  _connection
-    _transaction
+  _transaction
-    _test_mode
+  _test_mode
-    _extras
+  _extras
-    other_fds
+  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 $self = shift;
-  my ($msg) = shift || "program fault - command not performed";
+    my ($msg) = shift || "program fault - command not performed";
-  print STDERR "$0 [$$]: $msg ($!)\n";
+    print STDERR "$0 [$$]: $msg ($!)\n";
-  $self->respond("Error - " . $msg);
+    $self->respond("Error - " . $msg);
-  return $PROMPT;
+    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 {
+        my $resp = eval { $lookup->($self, @params); };
-            $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",
+    list =>
-    kill => "KILL (\$IP | \$REF) - Disconnect all connections from \$IP or connection reference \$REF",
+"LIST [LIMIT] - List the connections, specify limit or negative limit to shrink list",
-    pause => "PAUSE - Stop accepting new connections",
+    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",
+    reload   => "RELOAD - Reload all plugins and config",
-    quit => "QUIT - Exit the config server",
+    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:
+    # Status should show:
-#  - Total time running
+    #  - Total time running
-#  - Total number of mails received
+    #  - Total number of mails received
-#  - Total number of mails rejected (5xx)
+    #  - Total number of mails rejected (5xx)
-#  - Total number of mails tempfailed (5xx)
+    #  - Total number of mails tempfailed (5xx)
-#  - Avg number of mails/minute
+    #  - Avg number of mails/minute
-#  - Number of current connections
+    #  - Number of current connections
-#  - Number of outstanding DNS queries
+    #  - 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".
+    $output .= "Curr Connections: $current_connections / $::MAXconn\n"
-               "Curr DNS Queries: $current_dns";
+      . "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
+            next unless $pob->connection->remote_ip;  # haven't even started yet
-            push @all, [$pob+0, $pob->connection->remote_ip,
+            push @all,
-                        $pob->connection->remote_host, $pob->uptime];
+              [
+                $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)) {
+                if ($pob + 0 == hex($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++;
                 }
             }
         }
     }
-    
+
     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";
 }
 

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_host
-        remote_ip 
+  remote_ip
-        remote_info 
+  remote_info
-        remote_port
+  remote_port
-        local_ip
+  local_ip
-        local_port
+  local_port
-        relay_client
+  relay_client
-);
+  );
-
 
 sub new {
-  my $proto = shift;
+    my $proto = shift;
-  my $class = ref($proto) || $proto;
+    my $class = ref($proto) || $proto;
-  my $self = {};
+    my $self  = {};
-  bless ($self, $class);
+    bless($self, $class);
 }
 
 sub start {
-  my $self = shift;
+    my $self = shift;
-  $self = $self->new(@_) unless ref $self;
+    $self = $self->new(@_) unless ref $self;
 
-  my %args = @_;
+    my %args = @_;
 
-  foreach my $f ( @parameters ) {
+    foreach my $f (@parameters) {
-    $self->$f($args{$f}) if $args{$f};
+        $self->$f($args{$f}) if $args{$f};
-  }
+    }
 
-  return $self;
+    return $self;
 }
 
 sub clone {
-  my $self = shift;
+    my $self = shift;
-  my %args = @_;
+    my %args = @_;
-  my $new = $self->new();
+    my $new  = $self->new();
-  foreach my $f ( @parameters ) {
+    foreach my $f (@parameters) {
-    $new->$f($self->$f()) if $self->$f();
+        $new->$f($self->$f()) if $self->$f();
-  }
+    }
-  $new->{_notes} = $self->{_notes} if defined $self->{_notes};
+    $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 
+    # reset the old connection object like it's done at the end of a connection
-  # still around)
+    # to prevent leaks (like prefork/tls problem with the old SSL file handle
-  $self->reset unless $args{no_reset}; 
+    # still around)
-  # should we generate a new id here?
+    $self->reset unless $args{no_reset};
-  return $new;
+
+    # should we generate a new id here?
+    return $new;
 }
 
 sub remote_host {
-  my $self = shift;
+    my $self = shift;
-  @_ and $self->{_remote_host} = shift;
+    @_ and $self->{_remote_host} = shift;
-  $self->{_remote_host};
+    $self->{_remote_host};
 }
 
 sub remote_ip {
-  my $self = shift;
+    my $self = shift;
-  @_ and $self->{_remote_ip} = shift;
+    @_ and $self->{_remote_ip} = shift;
-  $self->{_remote_ip};
+    $self->{_remote_ip};
 }
 
 sub remote_port {
-  my $self = shift;
+    my $self = shift;
-  @_ and $self->{_remote_port} = shift;
+    @_ and $self->{_remote_port} = shift;
-  $self->{_remote_port};
+    $self->{_remote_port};
 }
 
 sub local_ip {
-  my $self = shift;
+    my $self = shift;
-  @_ and $self->{_local_ip} = shift;
+    @_ and $self->{_local_ip} = shift;
-  $self->{_local_ip};
+    $self->{_local_ip};
 }
 
 sub local_port {
-  my $self = shift;
+    my $self = shift;
-  @_ and $self->{_local_port} = shift;
+    @_ and $self->{_local_port} = shift;
-  $self->{_local_port};
+    $self->{_local_port};
 }
 
-
 sub remote_info {
-  my $self = shift;
+    my $self = shift;
-  @_ and $self->{_remote_info} = shift;
+    @_ and $self->{_remote_info} = shift;
-  $self->{_remote_info};
+    $self->{_remote_info};
 }
 
 sub relay_client {
-  my $self = shift;
+    my $self = shift;
-  @_ and $self->{_relay_client} = shift;
+    @_ and $self->{_relay_client} = shift;
-  $self->{_relay_client};
+    $self->{_relay_client};
 }
 
 sub hello {
-  my $self = shift;
+    my $self = shift;
-  @_ and $self->{_hello} = shift;
+    @_ and $self->{_hello} = shift;
-  $self->{_hello};
+    $self->{_hello};
 }
 
 sub hello_host {
-  my $self = shift;
+    my $self = shift;
-  @_ and $self->{_hello_host} = shift;
+    @_ and $self->{_hello_host} = shift;
-  $self->{_hello_host};
+    $self->{_hello_host};
 }
 
 sub notes {
-  my ($self,$key) = (shift,shift);
+    my ($self, $key) = (shift, shift);
-  # Check for any additional arguments passed by the caller -- including undef
+
-  return $self->{_notes}->{$key} unless @_;
+    # Check for any additional arguments passed by the caller -- including undef
-  return $self->{_notes}->{$key} = shift;
+    return $self->{_notes}->{$key} unless @_;
+    return $self->{_notes}->{$key} = shift;
 }
 
 sub reset {
-   my $self = shift;
+    my $self = shift;
-   $self->{_notes} = undef;
+    $self->{_notes} = undef;
-   $self = $self->new;
+    $self = $self->new;
 }
 
 1;

lib/Qpsmtpd/Constants.pm

@@ -4,64 +4,64 @@ require Exporter;
 
 # log levels
 my %log_levels = (
-	LOGDEBUG   => 7,
+                  LOGDEBUG  => 7,
-	LOGINFO    => 6,
+                  LOGINFO   => 6,
-	LOGNOTICE  => 5,
+                  LOGNOTICE => 5,
-	LOGWARN    => 4,
+                  LOGWARN   => 4,
-	LOGERROR   => 3,
+                  LOGERROR  => 3,
-	LOGCRIT    => 2,
+                  LOGCRIT   => 2,
-	LOGALERT   => 1,
+                  LOGALERT  => 1,
-	LOGEMERG   => 0,
+                  LOGEMERG  => 0,
-	LOGRADAR   => 0,
+                  LOGRADAR  => 0,
-);
+                 );
 
 # return codes
 my %return_codes = (
-	OK                     => 900,
+         OK                  => 900,
-	DENY                   => 901,   # 550
+         DENY                => 901,    # 550
-	DENYSOFT               => 902,   # 450
+         DENYSOFT            => 902,    # 450
-	DENYHARD               => 903,   # 550 + disconnect  (deprecated in 0.29)
+         DENYHARD            => 903,    # 550 + disconnect  (deprecated in 0.29)
-	DENY_DISCONNECT        => 903,   # 550 + disconnect
+         DENY_DISCONNECT     => 903,    # 550 + disconnect
-	DENYSOFT_DISCONNECT    => 904,   # 450 + disconnect
+         DENYSOFT_DISCONNECT => 904,    # 450 + disconnect
-	DECLINED               => 909,
+         DECLINED            => 909,
-	DONE                   => 910,
+         DONE                => 910,
-	CONTINUATION           => 911,   # deprecated - use YIELD
+         CONTINUATION        => 911,    # deprecated - use YIELD
-	YIELD                  => 911,
+         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 ) {
+foreach (keys %return_codes) {
-    eval "use constant $_ => ".$return_codes{$_};
+    eval "use constant $_ => " . $return_codes{$_};
 }
 
-foreach (keys %log_levels ) {
+foreach (keys %log_levels) {
-    eval "use constant $_ => ".$log_levels{$_};
+    eval "use constant $_ => " . $log_levels{$_};
 }
 
 sub return_code {
     my $test = shift;
-    if ( $test =~ /^\d+$/ ) { # need to return the textural form
+    if ($test =~ /^\d+$/) {    # need to return the textural form
-	foreach ( keys %return_codes ) {
+        foreach (keys %return_codes) {
-	    return $_ if $return_codes{$_} =~ /$test/;
+            return $_ if $return_codes{$_} =~ /$test/;
-	}
+        }
     }
-    else { # just return the numeric value
+    else {                     # just return the numeric value
-	return $return_codes{$test};
+        return $return_codes{$test};
     }
 }
 
 sub log_level {
     my $test = shift;
-    if ( $test =~ /^\d+$/ ) { # need to return the textural form
+    if ($test =~ /^\d+$/) {    # need to return the textural form
-	foreach ( keys %log_levels ) {
+        foreach (keys %log_levels) {
-	    return $_ if $log_levels{$_} =~ /$test/;
+            return $_ if $log_levels{$_} =~ /$test/;
-	}
+        }
     }
-    else { # just return the numeric value
+    else {                     # just return the numeric value
-	return $log_levels{$test};
+        return $log_levels{$test};
     }
 }
 

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
+     "Other address status.",                                    # x.1.0
-        "Bad destination mailbox address.",                       # x.1.1
+     "Bad destination mailbox address.",                         # x.1.1
-        "Bad destination system address.",                        # x.1.2
+     "Bad destination system address.",                          # x.1.2
-        "Bad destination mailbox address syntax.",                # x.1.3
+     "Bad destination mailbox address syntax.",                  # x.1.3
-        "Destination mailbox address ambiguous.",                 # x.1.4
+     "Destination mailbox address ambiguous.",                   # x.1.4
-        "Destination address valid.",                             # x.1.5
+     "Destination address valid.",                               # x.1.5
-        "Destination mailbox has moved, No forwarding address.",  # x.1.6
+     "Destination mailbox has moved, No forwarding address.",    # x.1.6
-        "Bad sender's mailbox address syntax.",                   # x.1.7
+     "Bad sender's mailbox address syntax.",                     # x.1.7
-        "Bad sender's system address.",                           # x.1.8
+     "Bad sender's system address.",                             # x.1.8
     ],
     [
-        "Other or undefined mailbox status.",                     # x.2.0
+     "Other or undefined mailbox status.",                       # x.2.0
-        "Mailbox disabled, not accepting messages.",              # x.2.1
+     "Mailbox disabled, not accepting messages.",                # x.2.1
-        "Mailbox full.",                                          # x.2.2
+     "Mailbox full.",                                            # x.2.2
-        "Message length exceeds administrative limit.",           # x.2.3
+     "Message length exceeds administrative limit.",             # x.2.3
-        "Mailing list expansion problem.",                        # x.2.4
+     "Mailing list expansion problem.",                          # x.2.4
     ],
     [
-        "Other or undefined mail system status.",                 # x.3.0
+     "Other or undefined mail system status.",                   # x.3.0
-        "Mail system full.",                                      # x.3.1
+     "Mail system full.",                                        # x.3.1
-        "System not accepting network messages.",                 # x.3.2
+     "System not accepting network messages.",                   # x.3.2
-        "System not capable of selected features.",               # x.3.3
+     "System not capable of selected features.",                 # x.3.3
-        "Message too big for system.",                            # x.3.4
+     "Message too big for system.",                              # x.3.4
-        "System incorrectly configured.",                         # x.3.5
+     "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 
+     "Other or undefined network or routing status.",            # x.4.0
-        "Invalid command.",                                       # x.5.1 
+     "No answer from host.",                                     # x.4.1
-        "Syntax error.",                                          # x.5.2 
+     "Bad connection.",                                          # x.4.2
-        "Too many recipients.",                                   # x.5.3 
+     "Directory server failure.",                                # x.4.3
-        "Invalid command arguments.",                             # x.5.4 
+     "Unable to route.",                                         # x.4.4
-        "Wrong protocol version.",                                # x.5.5 
+     "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
+     "Other or undefined protocol status.",                      # x.5.0
-        "Media not supported.",                                   # x.6.1
+     "Invalid command.",                                         # x.5.1
-        "Conversion required and prohibited.",                    # x.6.2
+     "Syntax error.",                                            # x.5.2
-        "Conversion required but not supported.",                 # x.6.3
+     "Too many recipients.",                                     # x.5.3
-        "Conversion with loss performed.",                        # x.6.4
+     "Invalid command arguments.",                               # x.5.4
-        "Conversion Failed.",                                     # x.6.5
+     "Wrong protocol version.",                                  # x.5.5
     ],
     [
-        "Other or undefined security status.",                    # x.7.0
+     "Other or undefined media error.",                          # x.6.0
-        "Delivery not authorized, message refused.",              # x.7.1
+     "Media not supported.",                                     # x.6.1
-        "Mailing list expansion prohibited.",                     # x.7.2
+     "Conversion required and prohibited.",                      # x.6.2
-        "Security conversion required but not possible.",         # x.7.3
+     "Conversion required but not supported.",                   # x.6.3
-        "Security features not supported.",                       # x.7.4
+     "Conversion with loss performed.",                          # x.6.4
-        "Cryptographic failure.",                                 # x.7.5
+     "Conversion Failed.",                                       # x.6.5
-        "Cryptographic algorithm not supported.",                 # x.7.6
+    ],
-        "Message integrity failure.",                             # x.7.7
+    [
+     "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 :)
+    else {    # err .... no :)
-        return 4; # just 2,4,5 are allowed.. temp error by default
+        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 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 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_no_answer   { shift->_dsn(shift,shift,4,1); }
-# not useful # sub net_bad_connection { shift->_dsn(shift,shift,4,2); } 
+# 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 { 
+sub temp_resolver_failed {
-      shift->_dsn(shift,
+    shift->_dsn(shift, (shift || "Temporary address resolution failure"),
-                 (shift || "Temporary address resolution failure"),
+                DENYSOFT, 4, 3);
-                 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 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 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 proto_rcpt_list_too_long { shift->_dsn(shift, shift, DENYSOFT, 5, 3); }
-sub too_many_rcpts           { 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 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 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;
 

lib/Qpsmtpd/Plugin.pm

@@ -3,106 +3,113 @@ package Qpsmtpd::Plugin;
 use strict;
 use warnings;
 
+use Net::DNS;
+
 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
+  logging config post-fork pre-connection connect ehlo_parse ehlo
-    helo_parse helo auth_parse auth auth-plain auth-login auth-cram-md5
+  helo_parse helo auth_parse auth auth-plain auth-login auth-cram-md5
-    rcpt_parse rcpt_pre rcpt mail_parse mail mail_pre
+  rcpt_parse rcpt_pre rcpt mail_parse mail mail_pre
-    data data_headers_end data_post queue_pre queue queue_post vrfy noop
+  data data_headers_end data_post queue_pre queue queue_post vrfy noop
-    quit reset_transaction disconnect post-connection
+  quit reset_transaction disconnect post-connection
-    unrecognized_command deny ok received_line help
+  unrecognized_command deny ok received_line help
-);
+  );
 our %hooks = map { $_ => 1 } @hooks;
 
 sub new {
-  my $proto = shift;
+    my $proto = shift;
-  my $class = ref($proto) || $proto;
+    my $class = ref($proto) || $proto;
-  bless ({}, $class);
+    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)
+    $plugin->{_qp}->log(LOGDEBUG, $plugin->plugin_name, "hooking", $hook)
-      unless $hook =~ /logging/; # can't log during load_logging()
+      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
+    # 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.
+    # we should pass the plugin object and method name ... hmn.
-  $plugin->qp->_register_hook
+    $plugin->qp->_register_hook(
-    ($hook,
+        $hook,
-     { code => sub { local $plugin->{_qp} = shift;
+        {
-                     local $plugin->{_hook} = $hook;
+         code => sub {
-                     $plugin->$method(@_)
+             local $plugin->{_qp}   = shift;
-                   },
+             local $plugin->{_hook} = $hook;
-       name => $plugin->plugin_name,
+             $plugin->$method(@_);
-     },
+         },
-     $unshift,
+         name => $plugin->plugin_name,
-    );
+        },
+        $unshift,
+                               );
 }
 
 sub _register {
-  my $self = shift;
+    my $self = shift;
-  my $qp = shift;
+    my $qp   = shift;
-  local $self->{_qp} = $qp;
+    local $self->{_qp} = $qp;
-  $self->init($qp, @_)     if $self->can('init');
+    $self->init($qp, @_) if $self->can('init');
-  $self->_register_standard_hooks($qp, @_);
+    $self->_register_standard_hooks($qp, @_);
-  $self->register($qp, @_) if $self->can('register');
+    $self->register($qp, @_) if $self->can('register');
 }
 
 sub qp {
-  shift->{_qp};
+    shift->{_qp};
 }
 
 sub log {
-  my $self = shift;
+    my $self = shift;
-  return if defined $self->{_hook} && $self->{_hook} eq 'logging';
+    return if defined $self->{_hook} && $self->{_hook} eq 'logging';
-  my $level = $self->adjust_log_level( shift, $self->plugin_name );
+    my $level = $self->adjust_log_level(shift, $self->plugin_name);
-  $self->{_qp}->varlog($level, $self->{_hook}, $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]$/ ) {
+    if ($adj !~ /^[\+\-][\d]$/) {
-        $self->log( LOGERROR, $self-"invalid $plugin_name loglevel setting ($adj)" );
+        $self->log(LOGERROR,
-        undef $self->{_args}{loglevel};  # only complain once per plugin
+                   $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 $operator = substr($adj, 0,  1);
-    my $adjust  = substr($adj, -1, 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 {
@@ -114,17 +121,17 @@ sub auth_mechanism {
 }
 
 sub temp_file {
-  my $self = shift;
+    my $self     = shift;
-  my $tempfile = $self->qp->temp_file;
+    my $tempfile = $self->qp->temp_file;
-  push @{$self->qp->transaction->{_temp_files}}, $tempfile;
+    push @{$self->qp->transaction->{_temp_files}}, $tempfile;
-  return $tempfile;
+    return $tempfile;
 }
 
 sub temp_dir {
-  my $self = shift;
+    my $self    = shift;
-  my $tempdir = $self->qp->temp_dir();
+    my $tempdir = $self->qp->temp_dir();
-  push @{$self->qp->transaction->{_temp_dirs}}, $tempdir;
+    push @{$self->qp->transaction->{_temp_dirs}}, $tempdir;
-  return $tempdir;
+    return $tempdir;
 }
 
 # plugin inheritance:
@@ -135,32 +142,31 @@ sub temp_dir {
 #    $self->SUPER::register(@_);
 #  }
 sub isa_plugin {
-  my ($self, $parent) = @_;
+    my ($self, $parent) = @_;
-  my ($currentPackage) = caller;
+    my ($currentPackage) = caller;
 
-  my $cleanParent = $parent;
+    my $cleanParent = $parent;
-  $cleanParent =~ s/\W/_/g;
+    $cleanParent =~ s/\W/_/g;
-  my $newPackage = $currentPackage."::_isa_$cleanParent";
+    my $newPackage = $currentPackage . "::_isa_$cleanParent";
 
-  # don't reload plugins if they are already loaded
+    # don't reload plugins if they are already loaded
-  return if defined &{"${newPackage}::plugin_name"};
+    return if defined &{"${newPackage}::plugin_name"};
 
-  # find $parent in plugin_dirs
+    # find $parent in plugin_dirs
-  my $parent_dir;
+    my $parent_dir;
-  for ($self->qp->plugin_dirs) {
+    for ($self->qp->plugin_dirs) {
-    if (-e "$_/$parent") {
+        if (-e "$_/$parent") {
-      $parent_dir = $_;
+            $parent_dir = $_;
-      last;
+            last;
+        }
     }
-  }
+    die "cannot find plugin '$parent'" unless $parent_dir;
-  die "cannot find plugin '$parent'" unless $parent_dir;
 
-  $self->compile($self->plugin_name . "_isa_$cleanParent",
+    $self->compile($self->plugin_name . "_isa_$cleanParent",
-                    $newPackage,
+                   $newPackage, "$parent_dir/$parent");
-                    "$parent_dir/$parent");
+    warn "---- $newPackage\n";
-  warn "---- $newPackage\n";
+    no strict 'refs';
-  no strict 'refs';
+    push @{"${currentPackage}::ISA"}, $newPackage;
-  push @{"${currentPackage}::ISA"}, $newPackage;
 }
 
 # why isn't compile private?  it's only called from Plugin and Qpsmtpd.
@@ -170,8 +176,8 @@ sub compile {
     my $sub;
     open F, $file or die "could not open $file: $!";
     {
-      local $/ = undef;
+        local $/ = undef;
-      $sub = <F>;
+        $sub = <F>;
     }
     close F;
 
@@ -187,19 +193,19 @@ sub compile {
     }
 
     my $eval = join(
-		    "\n",
+        "\n",
-		    "package $package;",
+        "package $package;",
-		    'use Qpsmtpd::Constants;',
+        'use Qpsmtpd::Constants;',
-		    "require Qpsmtpd::Plugin;",
+        "require Qpsmtpd::Plugin;",
-		    'use vars qw(@ISA);',
+        'use vars qw(@ISA);',
-                    'use strict;',
+        'use strict;',
-		    '@ISA = qw(Qpsmtpd::Plugin);',
+        '@ISA = qw(Qpsmtpd::Plugin);',
-		    ($test_mode ? 'use Test::More;' : ''),
+        ($test_mode ? 'use Test::More;' : ''),
-		    "sub plugin_name { qq[$plugin] }",
+        "sub plugin_name { qq[$plugin] }",
-		    $line,
+        $line,
-		    $sub,
+        $sub,
-		    "\n", # last line comment without newline?
+        "\n",                               # last line comment without newline?
-		   );
+                   );
 
     #warn "eval: $eval";
 
@@ -210,47 +216,149 @@ sub compile {
     die "eval $@" if $@;
 }
 
+sub get_reject {
+    my $self      = shift;
+    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, tolerated" . $log_mess);
+        return DECLINED;
+    }
+
+    # the naughty plugin will reject later
+    if ($reject eq 'naughty') {
+        $self->log(LOGINFO, "fail, NAUGHTY" . $log_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);
+}
+
+sub get_reject_type {
+    my $self    = shift;
+    my $default = shift || DENY;
+    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;
+}
+
+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 store_auth_results {
+    my ($self, $result) = @_;
+    my $auths = $self->qp->connection->notes('authentication_results') or do {
+        $self->qp->connection->notes('authentication_results', $result);
+        return;
+        };
+    my $ar = join('; ', $auths, $result);
+    $self->log(LOGDEBUG, "auth-results: $ar");
+    $self->qp->connection->notes('authentication_results', $ar );
+};
+
+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);
+    $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;
+    }
+    return;
+}
+
+sub is_naughty {
+    my ($self, $setit) = @_;
+
+    if ( defined $setit ) {
+        $self->connection->notes('naughty', $setit);
+        $self->connection->notes('rejected', $setit);
     };
-    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 _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 adjust_karma {
+    my ($self, $value) = @_;
+
+    my $karma = $self->connection->notes('karma') || 0;
+    $karma += $value;
+    $self->log(LOGDEBUG, "karma $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));
+    }
+}
 
 1;

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
+  input_sock
-    mode
+  mode
-    header_lines
+  header_lines
-    in_header
+  in_header
-    data_size
+  data_size
-    max_size
+  max_size
-    hooks
+  hooks
-    start_time
+  start_time
-    cmd_timeout
+  cmd_timeout
-    conn
+  conn
-    _auth
+  _auth
-    _auth_mechanism
+  _auth_mechanism
-    _auth_state
+  _auth_state
-    _auth_ticket
+  _auth_ticket
-    _auth_user
+  _auth_user
-    _commands
+  _commands
-    _config_cache
+  _config_cache
-    _connection
+  _connection
-    _continuation
+  _continuation
-    _extras
+  _extras
-    _test_mode
+  _test_mode
-    _transaction
+  _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->{start_time}  = time;
-    $self->{mode} = 'connect';
+    $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,
+                          ehlo => 1,
-        helo => 1,
+                          helo => 1,
-        rset => 1,
+                          rset => 1,
-        mail => 1,
+                          mail => 1,
-        rcpt => 1,
+                          rcpt => 1,
-        data => 1,
+                          data => 1,
-        help => 1,
+                          help => 1,
-        vrfy => 1,
+                          vrfy => 1,
-        noop => 1,
+                          noop => 1,
-        quit => 1,
+                          quit => 1,
-        auth => 0, # disabled by default
+                          auth => 0,    # disabled by default
-    };
+                         };
-    $self->{mode} = 'cmd';
+    $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 {
+            eval { $lookup->($self, @params); };
-                $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);
+    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])) },
+        callback => sub { $conn->remote_info($conn->remote_host($_[0])) },
-        host       => $ip,
+        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->{data_size}    = 0;
-    $self->{in_header} = 1;
+    $self->{in_header}    = 1;
-    $self->{max_size} = ($self->config('databytes'))[0] || 0;
+    $self->{max_size}     = ($self->config('databytes'))[0] || 0;
-    
+
-    $self->log(LOGDEBUG, "max_size: $self->{max_size} / size: $self->{data_size}");
+    $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.
+        # ... need to check that we don't reformat any of the received lines.
-                #
+        #
-                # 3.8.2 Received Lines in Gatewaying
+        # 3.8.2 Received Lines in Gatewaying
-                #   When forwarding a message into or out of the Internet environment, a
+        #   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
+        #   gateway MUST prepend a Received: line, but it MUST NOT alter in any
-                #   way a Received: line that is already in the header.
+        #   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,
+                my $header =
-                                                Modify => 0, MailFrom => "COERCE");
+                  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
+        $smtp .= "S" if $esmtp;    # RFC3848
-        $sslheader = "(".$self->connection->notes('tls_socket')->get_cipher()." encrypted) ";
+        $sslheader = "("
+          . $self->connection->notes('tls_socket')->get_cipher()
+          . " encrypted) ";
     }
-    
+
     if (defined $self->{_auth} and $self->{_auth} == OK) {
-        $smtp .= "A" if $esmtp; # RFC3848
+        $smtp .= "A" if $esmtp;    # RFC3848
-        $authheader = "(smtp-auth username $self->{_auth_user}, mechanism $self->{_auth_mechanism})\n";
+        $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);
-    return $self->respond(552, "Message too big!") if $self->{max_size} and $self->{data_size} > $self->{max_size};
+
-    
+    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;
 }

lib/Qpsmtpd/Postfix.pm

@@ -21,125 +21,131 @@ use vars qw(@ISA);
 my %rec_types;
 
 sub init {
-  my ($self) = @_;
+    my ($self) = @_;
 
-  %rec_types = (
+    %rec_types = (
-    REC_TYPE_SIZE    => 'C',	# first record, created by cleanup
+        REC_TYPE_SIZE => 'C',    # first record, created by cleanup
-    REC_TYPE_TIME    => 'T',	# time stamp, required
+        REC_TYPE_TIME => 'T',    # time stamp, required
-    REC_TYPE_FULL    => 'F',	# full name, optional
+        REC_TYPE_FULL => 'F',    # full name, optional
-    REC_TYPE_INSP    => 'I',	# inspector transport
+        REC_TYPE_INSP => 'I',    # inspector transport
-    REC_TYPE_FILT    => 'L',	# loop filter transport
+        REC_TYPE_FILT => 'L',    # loop filter transport
-    REC_TYPE_FROM    => 'S',	# sender, required
+        REC_TYPE_FROM => 'S',    # sender, required
-    REC_TYPE_DONE    => 'D',	# delivered recipient, optional
+        REC_TYPE_DONE => 'D',    # delivered recipient, optional
-    REC_TYPE_RCPT    => 'R',	# todo recipient, optional
+        REC_TYPE_RCPT => 'R',    # todo recipient, optional
-    REC_TYPE_ORCP    => 'O',	# original recipient, optional
+        REC_TYPE_ORCP => 'O',    # original recipient, optional
-    REC_TYPE_WARN    => 'W',	# warning message time
+        REC_TYPE_WARN => 'W',    # warning message time
-    REC_TYPE_ATTR    => 'A',	# named attribute for extensions
+        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_CONT => 'L',    # long data record
-    REC_TYPE_NORM    => 'N',	# normal 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_RRTO => 'r',    # return-receipt, from headers
-    REC_TYPE_ERTO    => 'e',	# errors-to, from headers
+        REC_TYPE_ERTO => 'e',    # errors-to, from headers
-    REC_TYPE_PRIO    => 'P',	# priority
+        REC_TYPE_PRIO => 'P',    # priority
-    REC_TYPE_VERP    => 'V',	# VERP delimiters
+        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});
+    die "unknown record type" unless ($rec_types{$type});
-  $self->print($rec_types{$type});
+    $self->print($rec_types{$type});
 
-  # the length is a little endian base-128 number where each 
+    # the length is a little endian base-128 number where each
-  # byte except the last has the high bit set:
+    # byte except the last has the high bit set:
-  my $s = "@list";
+    my $s  = "@list";
-  my $ln = length($s);
+    my $ln = length($s);
-  while ($ln >= 0x80) {
+    while ($ln >= 0x80) {
-    my $lnl = $ln & 0x7F;
+        my $lnl = $ln & 0x7F;
-    $ln >>= 7;
+        $ln >>= 7;
-    $self->print(chr($lnl | 0x80));
+        $self->print(chr($lnl | 0x80));
-  }
+    }
-  $self->print(chr($ln));
+    $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);
+    my $s =
-  $self->print_rec('REC_TYPE_SIZE', $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);
+    my $s = sprintf("%d", $time);
-  $self->print_rec('REC_TYPE_TIME', $s);
+    $self->print_rec('REC_TYPE_TIME', $s);
 }
 
 sub open_cleanup {
-  my ($class, $socket) = @_;
+    my ($class, $socket) = @_;
 
-  my $self;
+    my $self;
-  if ($socket =~ m#^(/.+)#) {
+    if ($socket =~ m#^(/.+)#) {
-    $socket = $1; # un-taint socket path
+        $socket = $1;    # un-taint socket path
-    $self = IO::Socket::UNIX->new(Type => SOCK_STREAM,
+        $self = IO::Socket::UNIX->new(Type => SOCK_STREAM,
-                                  Peer => $socket) if $socket;
+                                      Peer => $socket)
-    
+          if $socket;
-  } elsif ($socket =~ /(.*):(\d+)/) {
+
-    my ($host,$port) = ($1,$2); # un-taint address and port
+    }
-    $self = IO::Socket::INET->new(Proto => 'tcp',
+    elsif ($socket =~ /(.*):(\d+)/) {
-                                  PeerAddr => $host,PeerPort => $port)
+        my ($host, $port) = ($1, $2);    # un-taint address and port
-      if $host and $port;
+        $self = IO::Socket::INET->new(
-  }
+                                      Proto    => 'tcp',
-  unless (ref $self) {
+                                      PeerAddr => $host,
-    warn "Couldn't open \"$socket\": $!";
+                                      PeerPort => $port
-    return;
+                                     )
-  }
+          if $host and $port;
-  # allow buffered writes
+    }
-  $self->autoflush(0);
+    unless (ref $self) {
-  bless ($self, $class);
+        warn "Couldn't open \"$socket\": $!";
-  $self->init();
+        return;
-  return $self;
+    }
+
+    # allow buffered writes
+    $self->autoflush(0);
+    bless($self, $class);
+    $self->init();
+    return $self;
 }
 
 sub print_attr {
-  my ($self, @kv) = @_;
+    my ($self, @kv) = @_;
-  for (@kv) {
+    for (@kv) {
-    $self->print("$_\0");
+        $self->print("$_\0");
-  }
+    }
-  $self->print("\0");
+    $self->print("\0");
 }
 
 sub get_attr {
-  my ($self) = @_;
+    my ($self) = @_;
-  local $/ = "\0";
+    local $/ = "\0";
-  my %kv;
+    my %kv;
-  for(;;) {
+    for (; ;) {
-    my $k = $self->getline;
+        my $k = $self->getline;
-    chomp($k);
+        chomp($k);
-    last unless ($k);
+        last unless ($k);
-    my $v = $self->getline;
+        my $v = $self->getline;
-    chomp($v);
+        chomp($v);
-    $kv{$k} = $v;
+        $kv{$k} = $v;
-  }
+    }
-  return %kv;
+    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. 
+    # split into 1k chunks.
-  while (length($line) > 1024) {
+    while (length($line) > 1024) {
-    my $s = substr($line, 0, 1024);
+        my $s = substr($line, 0, 1024);
-    $line = substr($line, 1024);
+        $line = substr($line, 1024);
-    $self->print_rec('REC_TYPE_CONT', $s);
+        $self->print_rec('REC_TYPE_CONT', $s);
-  }
+    }
-  $self->print_rec('REC_TYPE_NORM', $line);
+    $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')
+    my @sockets = @{$transaction->notes('postfix-queue-sockets')
-                  // ['/var/spool/postfix/public/cleanup']};
+          // ['/var/spool/postfix/public/cleanup']};
-  my $strm;
+    my $strm;
-  $strm = $class->open_cleanup($_) and last for @sockets;
+    $strm = $class->open_cleanup($_) and last for @sockets;
-  die "Unable to open any cleanup sockets!" unless $strm;
+    die "Unable to open any cleanup sockets!" unless $strm;
 
-  my %at = $strm->get_attr;
+    my %at  = $strm->get_attr;
-  my $qid = $at{queue_id};
+    my $qid = $at{queue_id};
-  print STDERR "qid=$qid\n";
+    print STDERR "qid=$qid\n";
-  $strm->print_attr('flags' => $transaction->notes('postfix-queue-flags'));
+    $strm->print_attr('flags' => $transaction->notes('postfix-queue-flags'));
-  $strm->print_rec_time();
+    $strm->print_rec_time();
-  $strm->print_rec('REC_TYPE_FROM', $transaction->sender->address|| "");
+    $strm->print_rec('REC_TYPE_FROM', $transaction->sender->address || "");
-  for (map { $_->address } $transaction->recipients) {
+    for (map { $_->address } $transaction->recipients) {
-    $strm->print_rec('REC_TYPE_RCPT', $_);
+        $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
+    # add an empty message length record.
-  # so we can just copy the message:
+    # cleanup is supposed to understand that.
+    # see src/pickup/pickup.c
+    $strm->print_rec('REC_TYPE_MESG', "");
 
-  my $hdr = $transaction->header->as_string;
+    # a received header has already been added in SMTP.pm
-  for (split(/\r?\n/, $hdr)) {
+    # so we can just copy the message:
-    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.
+    my $hdr = $transaction->header->as_string;
-  $strm->print_rec('REC_TYPE_XTRA', "");
+    for (split(/\r?\n/, $hdr)) {
-  $strm->print_rec('REC_TYPE_END', "");
+        print STDERR "hdr: $_\n";
-  $strm->flush();
+        $strm->print_msg_line($_);
-  %at = $strm->get_attr;
+    }
-  my $status = $at{status};
+    $transaction->body_resetpos;
-  my $reason = $at{reason};
+    while (my $line = $transaction->body_getline) {
-  $strm->close();
+
-  return wantarray ? ($status, $qid, $reason || "") : $status;
+        # 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

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_soft
-	%cleanup_hard
+  %cleanup_hard
-	$postfix_version
+  $postfix_version
-	CLEANUP_FLAG_NONE
+  CLEANUP_FLAG_NONE
-	CLEANUP_FLAG_BOUNCE
+  CLEANUP_FLAG_BOUNCE
-	CLEANUP_FLAG_FILTER
+  CLEANUP_FLAG_FILTER
-	CLEANUP_FLAG_HOLD
+  CLEANUP_FLAG_HOLD
-	CLEANUP_FLAG_DISCARD
+  CLEANUP_FLAG_DISCARD
-	CLEANUP_FLAG_BCC_OK
+  CLEANUP_FLAG_BCC_OK
-	CLEANUP_FLAG_MAP_OK
+  CLEANUP_FLAG_MAP_OK
-	CLEANUP_FLAG_MILTER
+  CLEANUP_FLAG_MILTER
-	CLEANUP_FLAG_FILTER_ALL
+  CLEANUP_FLAG_FILTER_ALL
-	CLEANUP_FLAG_MASK_EXTERNAL
+  CLEANUP_FLAG_MASK_EXTERNAL
-	CLEANUP_FLAG_MASK_INTERNAL
+  CLEANUP_FLAG_MASK_INTERNAL
-	CLEANUP_FLAG_MASK_EXTRA
+  CLEANUP_FLAG_MASK_EXTRA
-	CLEANUP_STAT_OK
+  CLEANUP_STAT_OK
-	CLEANUP_STAT_BAD
+  CLEANUP_STAT_BAD
-	CLEANUP_STAT_WRITE
+  CLEANUP_STAT_WRITE
-	CLEANUP_STAT_SIZE
+  CLEANUP_STAT_SIZE
-	CLEANUP_STAT_CONT
+  CLEANUP_STAT_CONT
-	CLEANUP_STAT_HOPS
+  CLEANUP_STAT_HOPS
-	CLEANUP_STAT_RCPT
+  CLEANUP_STAT_RCPT
-	CLEANUP_STAT_PROXY
+  CLEANUP_STAT_PROXY
-	CLEANUP_STAT_DEFER
+  CLEANUP_STAT_DEFER
-	CLEANUP_STAT_MASK_CANT_BOUNCE
+  CLEANUP_STAT_MASK_CANT_BOUNCE
-	CLEANUP_STAT_MASK_INCOMPLETE
+  CLEANUP_STAT_MASK_INCOMPLETE
-);
+  );
 
 $postfix_version = "2.4";
-use constant CLEANUP_FLAG_NONE => 0; # /* No special features */ 
+use constant CLEANUP_FLAG_NONE    => 0;        # /* No special features */
-use constant CLEANUP_FLAG_BOUNCE => (1<<0); # /* Bounce bad messages */ 
+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_FILTER  => (1 << 1); # /* Enable header/body checks */
-use constant CLEANUP_FLAG_HOLD => (1<<2); # /* Place message on hold */ 
+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_DISCARD => (1 << 3); # /* Discard message silently */
-use constant CLEANUP_FLAG_BCC_OK => (1<<4); # /* Ok to add auto-BCC addresses */ 
+use constant CLEANUP_FLAG_BCC_OK  => (1 << 4)
-use constant CLEANUP_FLAG_MAP_OK => (1<<5); # /* Ok to map addresses */ 
+  ;    # /* Ok to add auto-BCC addresses */
-use constant CLEANUP_FLAG_MILTER => (1<<6); # /* Enable Milter applications */ 
+use constant CLEANUP_FLAG_MAP_OK => (1 << 5); # /* Ok to map addresses */
-use constant CLEANUP_FLAG_FILTER_ALL => (CLEANUP_FLAG_FILTER | CLEANUP_FLAG_MILTER); 
+use constant CLEANUP_FLAG_MILTER => (1 << 6); # /* Enable Milter applications */
-use constant CLEANUP_FLAG_MASK_EXTERNAL => (CLEANUP_FLAG_FILTER_ALL | CLEANUP_FLAG_BCC_OK | CLEANUP_FLAG_MAP_OK); 
+use constant CLEANUP_FLAG_FILTER_ALL =>
-use constant CLEANUP_FLAG_MASK_INTERNAL => CLEANUP_FLAG_MAP_OK; 
+  (CLEANUP_FLAG_FILTER | CLEANUP_FLAG_MILTER);
-use constant CLEANUP_FLAG_MASK_EXTRA => (CLEANUP_FLAG_HOLD | CLEANUP_FLAG_DISCARD); 
+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_OK    => 0;         # /* Success. */
-use constant CLEANUP_STAT_BAD => (1<<0); # /* Internal protocol error */ 
+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_WRITE => (1 << 1);  # /* Error writing message file */
-use constant CLEANUP_STAT_SIZE => (1<<2); # /* Message file too big */ 
+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_CONT  => (1 << 3);  # /* Message content rejected */
-use constant CLEANUP_STAT_HOPS => (1<<4); # /* Too many hops */ 
+use constant CLEANUP_STAT_HOPS  => (1 << 4);  # /* Too many hops */
-use constant CLEANUP_STAT_RCPT => (1<<6); # /* No recipients found */ 
+use constant CLEANUP_STAT_RCPT  => (1 << 6);  # /* No recipients found */
-use constant CLEANUP_STAT_PROXY => (1<<7); # /* Proxy reject */ 
+use constant CLEANUP_STAT_PROXY => (1 << 7);  # /* Proxy reject */
-use constant CLEANUP_STAT_DEFER => (1<<8); # /* Temporary 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_CANT_BOUNCE =>
-use constant CLEANUP_STAT_MASK_INCOMPLETE => (CLEANUP_STAT_BAD | CLEANUP_STAT_WRITE | CLEANUP_STAT_SIZE | CLEANUP_STAT_DEFER); 
+  (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_DEFER => "service unavailable (#4.7.1)",
-    CLEANUP_STAT_PROXY =>  "queue file write error (#4.3.0)",
+                 CLEANUP_STAT_PROXY => "queue file write error (#4.3.0)",
-    CLEANUP_STAT_BAD =>  "internal protocol 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_WRITE => "queue file write error (#4.3.0)",
-);
+                );
 %cleanup_hard = (
-    CLEANUP_STAT_RCPT =>  "no recipients specified (#5.1.0)",
+                 CLEANUP_STAT_RCPT => "no recipients specified (#5.1.0)",
-    CLEANUP_STAT_HOPS =>  "too many hops (#5.4.0)",
+                 CLEANUP_STAT_HOPS => "too many hops (#5.4.0)",
-    CLEANUP_STAT_SIZE =>  "message file too big (#5.3.4)",
+                 CLEANUP_STAT_SIZE => "message file too big (#5.3.4)",
-    CLEANUP_STAT_CONT =>  "message content rejected (#5.7.1)",
+                 CLEANUP_STAT_CONT => "message content rejected (#5.7.1)",
-);
+                );
 1;

lib/Qpsmtpd/Postfix/pf2qp.pl

@@ -67,7 +67,7 @@ while (<HEAD>) {
         next if /^_/;
         s#(/\*.*\*/)##;
         my $comment = $1 || "";
-        my @words = split ' ', $_;
+        my @words = split / /, $_;
         my $const = shift @words;
         if ($const eq "CLEANUP_STAT_OK") {
             push @out, "";

lib/Qpsmtpd/SMTP/Prefork.pm

@@ -4,27 +4,28 @@ use Qpsmtpd::Constants;
 @ISA = qw(Qpsmtpd::SMTP);
 
 sub dispatch {
-  my $self = shift;
+    my $self = shift;
-  my ($cmd) = lc shift;
+    my ($cmd) = lc shift;
 
-  $self->{_counter}++; 
+    $self->{_counter}++;
 
-  if ($cmd !~ /^(\w{1,12})$/ or !exists $self->{_commands}->{$1}) {
+    if ($cmd !~ /^(\w{1,12})$/ or !exists $self->{_commands}->{$1}) {
-    $self->run_hooks("unrecognized_command", $cmd, @_);
+        $self->run_hooks("unrecognized_command", $cmd, @_);
-    return 1;
+        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;
+    $cmd = $1;
-    return $self->fault("command '$cmd' failed unexpectedly");
-  }
 
-  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;
 }

lib/Qpsmtpd/TcpServer.pm

@@ -8,17 +8,17 @@ use strict;
 
 use POSIX ();
 
-my $has_ipv6;
+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"); }
-    ) {
+   )
-    import Socket6;
+{
-    $has_ipv6=1;
+    Socket6->import(qw(inet_ntop));
-}
+    $has_ipv6 = 1;
-else {
-    $has_ipv6=0;
 }
 
 sub has_ipv6 {
@@ -36,25 +36,31 @@ sub start_connection {
        );
 
     if ($ENV{TCPREMOTEIP}) {
-	# started from tcpserver (or some other superserver which
+
-	# exports the TCPREMOTE* variables.
+        # started from tcpserver (or some other superserver which
-	$remote_ip   = $ENV{TCPREMOTEIP};
+        # exports the TCPREMOTE* variables.
-	$remote_host = $ENV{TCPREMOTEHOST} || "[$remote_ip]";
+        $remote_ip = $ENV{TCPREMOTEIP};
-	$remote_info = $ENV{TCPREMOTEINFO} ? "$ENV{TCPREMOTEINFO}\@$remote_host" : $remote_host;
+        $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.
+    else {
-	# get info on the remote host from the socket.
+        # Started from inetd or similar.
-	# ignore ident/tap/...
+        # get info on the remote host from the socket.
-	my $hersockaddr    = getpeername(STDIN)
+        # ignore ident/tap/...
-	    or die "getpeername failed: $0 must be called from tcpserver, (x)inetd or a similar program which passes a socket to stdin";
+        my $hersockaddr = getpeername(STDIN)
-	my ($port, $iaddr) = sockaddr_in($hersockaddr);
+          or die
-	$remote_ip     = inet_ntoa($iaddr);
+"getpeername failed: $0 must be called from tcpserver, (x)inetd or a similar program which passes a socket to stdin";
-	$remote_host    = gethostbyaddr($iaddr, AF_INET) || "[$remote_ip]";
+        my ($port, $iaddr) = sockaddr_in($hersockaddr);
-	$remote_info	= $remote_host;
+        $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]");
 
@@ -67,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};
@@ -88,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 =
+    my $timeout = $self->config('timeoutsmtpd')    # qmail smtpd control file
-    $self->config('timeoutsmtpd')   # qmail smtpd control file
+      || $self->config('timeout')                  # qpsmtpd control file
-      || $self->config('timeout')   # qpsmtpd control file
+      || 1200;                                     # default value
-        || 1200;                    # default value
 
-  alarm $timeout;
-  while (<STDIN>) {
-    alarm 0;
-    $_ =~ s/\r?\n$//s; # advanced chomp
-    $self->log(LOGINFO, "dispatching $_");
-    $self->connection->notes('original_string', $_);
-    defined $self->dispatch(split / +/, $_, 2)
-      or $self->respond(502, "command unrecognized: '$_'");
     alarm $timeout;
-  }
+    while (<STDIN>) {
-  alarm(0);
+        alarm 0;
-  return if $self->connection->notes('disconnected');
+        $_ =~ s/\r?\n$//s;                         # advanced chomp
-  $self->reset_transaction;
+        $self->log(LOGINFO, "dispatching $_");
-  $self->run_hooks('disconnect');
+        $self->connection->notes('original_string', $_);
-  $self->connection->notes(disconnected => 1);
+        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 ($self, $code, @messages) = @_;
-  my $buf = '';
+    my $buf = '';
 
-  if ( !$self->check_socket() ) {
+    if (!$self->check_socket()) {
-    $self->log(LOGERROR, "Lost connection to client, cannot send response.");
+        $self->log(LOGERROR,
-    return(0);
+                   "Lost connection to client, cannot send response.");
-  }
+        return (0);
+    }
 
-  while (my $msg = shift @messages) {
+    while (my $msg = shift @messages) {
-    my $line = $code . (@messages?"-":" ").$msg;
+        my $line = $code . (@messages ? "-" : " ") . $msg;
-    $self->log(LOGINFO, $line);
+        $self->log(LOGINFO, $line);
-    $buf .= "$line\r\n";
+        $buf .= "$line\r\n";
-  }
+    }
-  print $buf or ($self->log(LOGERROR, "Could not print [$buf]: $!"), return 0);
+    print $buf
-  return 1;
+      or ($self->log(LOGERROR, "Could not print [$buf]: $!"), return 0);
+    return 1;
 }
 
 sub disconnect {
-  my $self = shift;
+    my $self = shift;
-  $self->log(LOGINFO,"click, disconnecting");
+    $self->log(LOGINFO, "click, disconnecting");
-  $self->SUPER::disconnect(@_);
+    $self->SUPER::disconnect(@_);
-  $self->run_hooks("post-connection");
+    $self->run_hooks("post-connection");
-  $self->connection->reset;
+    $self->connection->reset;
-  exit;
+    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 ($port, $iaddr) =
-  my $localsockaddr = getsockname($client);
+        ($server->sockdomain == AF_INET)
-  my ($lport, $laddr) = ($server->sockdomain == AF_INET) ? (sockaddr_in($localsockaddr)) : (sockaddr_in6($localsockaddr));
+      ? (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_iaddr =
-  my $nto_laddr = ($server->sockdomain == AF_INET) ? (inet_ntoa($laddr)) : (inet_ntop(AF_INET6(), $laddr));
+        ($server->sockdomain == AF_INET)
-  $nto_iaddr =~ s/::ffff://;
+      ? (inet_ntoa($iaddr))
-  $nto_laddr =~ s/::ffff://;
+      : (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 $TCPLOCALIP  = $nto_laddr;
-  my $TCPREMOTEIP = $nto_iaddr;
+    my $TCPREMOTEIP = $nto_iaddr;
 
-  if ($no_rdns) {
+    if ($no_rdns) {
-    return ($TCPLOCALIP, $TCPREMOTEIP, $TCPREMOTEIP ? "[$ENV{TCPREMOTEIP}]" : "[noip!]");
+        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;
     }
-  }
+    my $res = new Net::DNS::Resolver;
-  return ($TCPLOCALIP, $TCPREMOTEIP, $TCPREMOTEHOST || "Unknown");
+    $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;

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

lib/Qpsmtpd/Transaction.pm

@@ -2,24 +2,26 @@ 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 {
-  my $proto = shift;
+    my $proto = shift;
-  my $class = ref($proto) || $proto;
+    my $class = ref($proto) || $proto;
-  my %args = @_;
+    my %args  = @_;
-  
+
-  my $self = { _rcpt => [], started => time, };
+    my $self = {_rcpt => [], started => time,};
-  bless ($self, $class);
+    bless($self, $class);
-  return $self;
+    return $self;
 }
 
 sub add_recipient {
@@ -28,27 +30,28 @@ sub add_recipient {
 }
 
 sub remove_recipient {
-  my ($self,$rcpt) = @_;
+    my ($self, $rcpt) = @_;
-  $self->{_recipients} = [grep {$_->address ne $rcpt->address}
+    $self->{_recipients} =
-                               @{$self->{_recipients} || []}] if $rcpt;
+      [grep { $_->address ne $rcpt->address } @{$self->{_recipients} || []}]
+      if $rcpt;
 }
 
 sub recipients {
-  my $self = shift;
+    my $self = shift;
-  @_ and $self->{_recipients} = [@_];
+    @_ and $self->{_recipients} = [@_];
-  ($self->{_recipients} ? @{$self->{_recipients}} : ());
+    ($self->{_recipients} ? @{$self->{_recipients}} : ());
 }
 
 sub sender {
-  my $self = shift;
+    my $self = shift;
-  @_ and $self->{_sender} = shift;
+    @_ and $self->{_sender} = shift;
-  $self->{_sender};
+    $self->{_sender};
 }
 
 sub header {
-  my $self = shift;
+    my $self = shift;
-  @_ and $self->{_header} = shift;
+    @_ and $self->{_header} = shift;
-  $self->{_header};
+    $self->{_header};
 }
 
 # blocked() will return when we actually can do something useful with it...
@@ -61,32 +64,33 @@ sub header {
 #}
 
 sub notes {
-  my ($self,$key) = (shift,shift);
+    my ($self, $key) = (shift, shift);
-  # Check for any additional arguments passed by the caller -- including undef
+
-  return $self->{_notes}->{$key} unless @_;
+    # Check for any additional arguments passed by the caller -- including undef
-  return $self->{_notes}->{$key} = shift;
+    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;
+    my $self = shift;
-  @_ and die "body_start now read only";
+    @_ and die "body_start now read only";
-  $self->{_body_start};
+    $self->{_body_start};
 }
 
 sub body_current_pos {
@@ -98,107 +102,116 @@ sub body_current_pos {
 }
 
 sub body_filename {
-  my $self = shift;
+    my $self = shift;
-  $self->body_spool() unless $self->{_filename};
+    $self->body_spool() unless $self->{_filename};
-  $self->{_body_file}->flush(); # so contents won't be cached
+    $self->{_body_file}->flush();    # so contents won't be cached
-  return $self->{_filename};
+    return $self->{_filename};
 }
 
 sub body_spool {
-  my $self = shift;
+    my $self = shift;
-  $self->log(LOGINFO, "spooling message to disk");
+    $self->log(LOGINFO, "spooling message to disk");
-  $self->{_filename} = $self->temp_file();
+    $self->{_filename} = $self->temp_file();
-  $self->{_body_file} = IO::File->new($self->{_filename}, O_RDWR|O_CREAT, 0600)
+    $self->{_body_file} =
-    or die "Could not open file $self->{_filename} - $! "; # . $self->{_body_file}->error;
+      IO::File->new($self->{_filename}, O_RDWR | O_CREAT, 0600)
-  if ($self->{_body_array}) {
+      or die "Could not open file $self->{_filename} - $! "
-    foreach my $line (@{ $self->{_body_array} }) {
+      ;                              # . $self->{_body_file}->error;
-      $self->{_body_file}->print($line) or die "Cannot print to temp file: $!";
+    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;
+    }
+    $self->{_body_array} = undef;
 }
 
 sub body_write {
-  my $self = shift;
+    my $self = shift;
-  my $data = shift;
+    my $data = shift;
-  if ($self->{_body_file}) {
+    if ($self->{_body_file}) {
-    #warn("body_write to file\n");
+
-    # go to the end of the file
+        #warn("body_write to file\n");
-    seek($self->{_body_file},0,2)
+        # go to the end of the file
-      unless $self->{_body_file_writing};
+        seek($self->{_body_file}, 0, 2)
-    $self->{_body_file_writing} = 1;
+          unless $self->{_body_file_writing};
-    $self->{_body_file}->print(ref $data eq "SCALAR" ? $$data : $data)
+        $self->{_body_file_writing} = 1;
-      and $self->{_body_size} += length (ref $data eq "SCALAR" ? $$data : $data);
+        $self->{_body_file}->print(ref $data eq "SCALAR" ? $$data : $data)
-  }
+          and $self->{_body_size} +=
-  else {
+          length(ref $data eq "SCALAR" ? $$data : $data);
-    #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) {
+    else {
-      push @{ $self->{_body_array} }, $1;
+        #warn("body_write to array\n");
-      $self->{_body_size} += length($1);
+        $self->{_body_array} ||= [];
-      ++$self->{_body_current_pos};
+        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
+sub body_size {    # depreceated, use data_size() instead
-  my $self = shift;
+    my $self = shift;
-  $self->log(LOGWARN, "WARNING: body_size() is depreceated, use data_size() instead");
+    $self->log(LOGWARN,
-  $self->{_body_size} || 0;
+               "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;
+    my $self = shift;
-  $self->{_body_size}   or return 0;
+    $self->{_body_size}   or return 0;
-  $self->{_header_size} or return 0;
+    $self->{_header_size} or return 0;
-  return $self->{_body_size} - $self->{_header_size};
+    return $self->{_body_size} - $self->{_header_size};
 }
 
 sub body_resetpos {
-  my $self = shift;
+    my $self = shift;
-  
+
-  if ($self->{_body_file}) {
+    if ($self->{_body_file}) {
-    my $start = $self->{_body_start} || 0;
+        my $start = $self->{_body_start} || 0;
-    seek($self->{_body_file}, $start, 0);
+        seek($self->{_body_file}, $start, 0);
-    $self->{_body_file_writing} = 0;
+        $self->{_body_file_writing} = 0;
-  }
+    }
-  else {
+    else {
-    $self->{_body_current_pos} = $self->{_body_start};
+        $self->{_body_current_pos} = $self->{_body_start};
-  }
+    }
-  
+
-  1;
+    1;
 }
 
 sub body_getline {
-  my $self = shift;
+    my $self = shift;
-  if ($self->{_body_file}) {
+    if ($self->{_body_file}) {
-    my $start = $self->{_body_start} || 0;
+        my $start = $self->{_body_start} || 0;
-    seek($self->{_body_file}, $start,0)
+        seek($self->{_body_file}, $start, 0)
-      if $self->{_body_file_writing};
+          if $self->{_body_file_writing};
-    $self->{_body_file_writing} = 0;
+        $self->{_body_file_writing} = 0;
-    my $line = $self->{_body_file}->getline;
+        my $line = $self->{_body_file}->getline;
-    return $line;
+        return $line;
-  }
+    }
-  else {
+    else {
-    return unless $self->{_body_array};
+        return unless $self->{_body_array};
-    $self->{_body_current_pos} ||= 0;
+        $self->{_body_current_pos} ||= 0;
-    my $line = $self->{_body_array}->[$self->{_body_current_pos}];
+        my $line = $self->{_body_array}->[$self->{_body_current_pos}];
-    $self->{_body_current_pos}++;
+        $self->{_body_current_pos}++;
-    return $line;
+        return $line;
-  }
+    }
 }
 
 sub body_as_string {
@@ -213,46 +226,60 @@ sub body_as_string {
 }
 
 sub body_fh {
-  return shift->{_body_file};
+    return shift->{_body_file};
 }
 
 sub dup_body_fh {
-  my ($self) = @_;
+    my ($self) = @_;
-  open(my $fh, '<&=', $self->body_fh);
+    open(my $fh, '<&=', $self->body_fh);
-  return $fh;
+    return $fh;
 }
 
 sub DESTROY {
-  my $self = shift;
+    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};
+    # would we save some disk flushing if we unlinked the file before
-  if ($self->{_filename} and -e $self->{_filename}) {
+    # closing it?
-    unlink $self->{_filename} or $self->log(LOGERROR, "Could not unlink ", $self->{_filename}, ": $!");
-  }
 
-  # These may not exist
+    $self->log(LOGDEBUG, sprintf("DESTROY called by %s, %s, %s", (caller)));
-  if ( $self->{_temp_files} ) {
+
-    $self->log(LOGDEBUG, "Cleaning up temporary transaction files");
+    if ($self->{_body_file}) {
-    foreach my $file ( @{$self->{_temp_files}} ) {
+        undef $self->{_body_file};
-      next unless -e $file;
-      unlink $file or $self->log(LOGERROR,
-       "Could not unlink temporary file", $file, ": $!");
     }
-  }
+
-  # Ditto
+    if ($self->{_filename} and -e $self->{_filename}) {
-  if ( $self->{_temp_dirs} ) {
+        if (unlink $self->{_filename}) {
-    eval {use File::Path};
+            $self->log(LOGDEBUG, "unlinked ", $self->{_filename});
-    $self->log(LOGDEBUG, "Cleaning up temporary directories");
+        }
-    foreach my $dir ( @{$self->{_temp_dirs}} ) {
+        else {
-      rmtree($dir) or $self->log(LOGERROR, 
+            $self->log(LOGERROR, "Could not unlink ",
-        "Could not unlink temporary dir", $dir, ": $!");
+                       $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__
 
@@ -358,7 +385,7 @@ the C<DATA> command. If you need the size that will be queued, use
    + $transaction->body_length;
 
 The line above is of course only valid in I<hook_queue( )>, as other plugins
-may add headers and qpsmtpd will add its I<Received:> header.
+may add headers and qpsmtpd will add it's I<Received:> header.
 
 =head2 body_length( )
 

lib/Qpsmtpd/Utils.pm

@@ -11,5 +11,4 @@ sub tildeexp {
     return $path;
 }
 
-
 1;

log/log2sql

@@ -0,0 +1,629 @@
+#!/usr/bin/perl
+
+use strict;
+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 $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);
+    $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;    # 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]
+    );
+
+    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 $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;
+        };
+
+        #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') {
+            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;
+
+    #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) {
+            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) {
+            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 %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;
+    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);
+    }
+
+    #warn "err: $err\n";
+    if ($query =~ /(?:REPLACE|INSERT) INTO/) {
+        my ($table) = $query =~ /(?:REPLACE|INSERT) INTO (\w+)\s/;
+        $db->query($query, @params);
+        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;
+    }
+    elsif ($query =~ /^UPDATE/i) {
+        return $db->query($query, @params);
+    }
+    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;
+    return $r;
+}
+

log/log2sql.sql

@@ -0,0 +1,140 @@
+/*!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 `abb5` (`abb5`)
+) ENGINE=InnoDB DEFAULT CHARSET=utf8 COLLATE=utf8_bin;
+
+
+# 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 '',
+  UNIQUE KEY `plugin_id` (`plugin_id`,`name`)
+) ENGINE=InnoDB DEFAULT CHARSET=utf8 COLLATE=utf8_bin;
+
+/*!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 */;

log/run

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

log/show_message

@@ -0,0 +1,72 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Data::Dumper;
+
+my $QPDIR   = get_qp_dir();
+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 or die "unable to open $logfile\n";
+
+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();
+    }
+}

log/summarize

@@ -0,0 +1,436 @@
+#!/usr/bin/perl
+
+use strict;
+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 /;
+
+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  = 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;
+    $line =~ s/[^[ -~]]//g;   # strip out binary/unprintable
+    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
+
+    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}{$_} = '';    # define them
+        }
+        $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') {
+        handle_plugin($message,$plugin,$pid,$line);
+    }
+    elsif ($type eq 'reject')  { }
+    elsif ($type eq 'connect') { }
+    elsif ($type eq 'dispatch') {
+        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;
+    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:';
+
+    # 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 ';
+
+    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);
+}
+
+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 unused plugins
+        if ($hide_plugins{$plugin}) {         # user doesn't want to see
+            delete $pids{$pid}{$plugin};
+            next;
+        }
+
+        my $wide = $opt_l ? 20 : 8;
+
+        if (defined $pids{$pid}{helo_host} && $plugin =~ /helo/) {
+            $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 .= " %-$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 .= " %-$wide.${wide}s";
+            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 ' 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;
+    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";
+        }
+        foreach my $s (qw/ smtpd qpsmtpd qpsmtpd-dev /) {
+            if (-d "$homedir/$s/plugins") {
+                return "$homedir/$s";
+            }
+        }
+    }
+    if (-d "./plugins") {
+        return Cwd::getcwd();
+    }
+}
+
+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
+        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};
+
+        next if !$aliases;
+        $aliases =~ s/\s+//g;
+        $plugins{$name}{aliases} = $aliases;
+        foreach my $a (split /,/, $aliases) {
+            $plugin_aliases{$a} = $name;
+        }
+    }
+}
+
+__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<naughty> to disconnect later.
+
+=head1 AUTHOR
+
+Matt Simerson <msimerson@cpan.org>
+
+=cut
+

log/watch

@@ -0,0 +1,44 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+$|++;    # OUTPUT_AUTOFLUSH
+
+use Cwd;
+use Data::Dumper;
+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
+                        );
+
+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;
+
+        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();
+    }
+}
+

plugins/async/check_earlytalker

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

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';

plugins/async/earlytalker

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

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', 
+    $transaction->notes(
-        AsyncSMTPSender->new($SERVER, $PORT, $qp, $self, $transaction)
+                        '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
+  qp
-    pkg
+  pkg
-    tran
+  tran
-    state
+  state
-    rcode
+  rcode
-    rmsg
+  rmsg
-    buf
+  buf
-    command
+  command
-    resp
+  resp
-    to
+  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,
+                                     PeerAddr => $server,
-        PeerPort => $port,
+                                     PeerPort => $port,
-        Blocking  => 0,
+                                     Blocking => 0,
-    ) or die "Error connecting to server $server:$port : $!\n";
+                                    )
+      or die "Error connecting to server $server:$port : $!\n";
 
     IO::Handle::blocking($sock, 0);
     binmode($sock, ':raw');
-    
+
-    $self->{qp} = $qp;
+    $self->{qp}      = $qp;
-    $self->{pkg} = $pkg;
+    $self->{pkg}     = $pkg;
-    $self->{tran} = $transaction;
+    $self->{tran}    = $transaction;
-    $self->{state} = ST_CONNECTING;
+    $self->{state}   = ST_CONNECTING;
-    $self->{rcode} = DECLINED;
+    $self->{rcode}   = DECLINED;
     $self->{command} = 'connect';
-    $self->{buf} = '';
+    $self->{buf}     = '';
-    $self->{resp} = [];
+    $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)
+    $self->write(  ($command =~ m/ / ? "$command:" : $command)
-      . ($params ? " $params" : "") . "\r\n");
+                 . ($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;

plugins/async/require_resolvable_fromhost

@@ -1,181 +0,0 @@
-#!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;
-}

plugins/async/resolvable_fromhost

@@ -0,0 +1,206 @@
+#!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;
+}

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';

plugins/async/uribl

@@ -31,10 +31,13 @@ sub start_data_post {
 
     my @names;
 
-    my $queries = $self->lookup_start($transaction, sub {
+    my $queries = $self->lookup_start(
-        my ($self, $name) = @_;
+        $transaction,
-        push @names, $name;
+        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 $results     = $transaction->notes('uribl_results');
-    my $zones = $transaction->notes('uribl_zones');
+    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 $results     = $transaction->notes('uribl_results');
-    my $zones = $transaction->notes('uribl_zones');
+    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: " .
+                        desc   => "$n in $z: "
-                            ($results->{$z}->{$n}->{txt} || $results->{$z}->{$n}->{a}),
+                          . (
-                    };
+                                  $results->{$z}->{$n}->{txt}
+                               || $results->{$z}->{$n}->{a}
+                            ),
+                      };
                 }
             }
         }

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 );
+    my ($checkpw, $true) = $self->get_checkpw(\%args);
-    return DECLINED if ! $checkpw || ! $true;
+    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');
+    my $true   = $self->connection->notes('auth_checkpassword_true');
-    chomp ($binary, $true);
+    chomp($binary, $true);
 
     my $sudo = get_sudo($binary);
 
@@ -136,53 +136,55 @@ 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");
 }
 
 sub get_checkpw {
     my ($self, $args) = @_;
 
-    my ($checkpw) = $args->{checkpw} =~ /^(.*)$/ if $args->{checkpw}; # untaint
+    my ($checkpw) = $args->{checkpw} =~ /^(.*)$/ if $args->{checkpw};  # untaint
-    my ($true)    = $args->{true} =~ /^(.*)$/ if $args->{true};       # untaint
+    my ($true)    = $args->{true} =~ /^(.*)$/    if $args->{true};     # untaint
 
-    return ( $checkpw, $true )
+    return ($checkpw, $true)
-        if ( $checkpw && $true && -x $checkpw && -x $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') ) {
+    if (!$self->qp->config('smtpauth-checkpassword')) {
-        $self->log(LOGERROR, $missing_config );
+        $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 ) {
+    if (!$checkpw || !$true || !-x $checkpw || !-x $true) {
-        $self->log(LOGERROR, $missing_config );
+        $self->log(LOGERROR, $missing_config);
         return;
-    };
+    }
     return ($checkpw, $true);
-};
+}
 
 sub get_sudo {
     my $binary = shift;
 
-    return '' if $> == 0;                            # running as root
+    return '' if $> == 0;                             # running as root
-    return '' if $> == 89 && $binary =~ /vchkpw$/;   # running as vpopmail
+    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
 

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->{_args}         = {%arg};
-    $self->{_enable_smtp} = $arg{enable_smtp} || 'no';
+    $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
+    # 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
+    # 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
+    # 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 = <SOCK>;
-    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)");

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,
+    return
-            src_clear     => $auth_pass,
+      Qpsmtpd::Auth::validate_password(
-            src_crypt     => undef,
+                                       $self,
-            attempt_clear => $passClear,
+                                       src_clear     => $auth_pass,
-            attempt_hash  => $passHash,
+                                       src_crypt     => undef,
-            method        => $method,
+                                       attempt_clear => $passClear,
-            ticket        => $ticket,
+                                       attempt_hash  => $passHash,
-            deny          => DENY,
+                                       method        => $method,
-        );
+                                       ticket        => $ticket,
+                                       deny          => DENY,
+                                      );
 }
 

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,
+    $mesg = $ldh->search(
-                            scope     => 'sub',
+                         base      => $ldbase,
-                            filter    => "$ldmattr=$pw_name",
+                         scope     => 'sub',
-                            attrs     => ['uid'],
+                         filter    => "$ldmattr=$pw_name",
-                            timeout   => $ldwait,
+                         attrs     => ['uid'],
-                            sizelimit => '1'
+                         timeout   => $ldwait,
-                        ) or do {
+                         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");

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-plain",    "auth_vpopmail");
-    $self->register_hook("auth-login", "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,
+    return
-        src_clear     => $pw->{pw_clear_passwd},
+      Qpsmtpd::Auth::validate_password(
-        src_crypt     => $pw->{pw_passwd},
+                                       $self,
-        attempt_clear => $passClear,
+                                       src_clear     => $pw->{pw_clear_passwd},
-        attempt_hash  => $passHash,
+                                       src_crypt     => $pw->{pw_passwd},
-        method        => $method,
+                                       attempt_clear => $passClear,
-        ticket        => $ticket,
+                                       attempt_hash  => $passHash,
-        deny          => DENY,
+                                       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");
+        $self->log(LOGERROR, "skip: could not query vpopmail");
-            return;
+        return;
-        };
+    };
     return 1;
 }

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 {
+    my $dbh = DBI->connect($dsn, $dbuser, $dbpass) or do {
-            $self->log(LOGERROR, "skip: db connection failed");
+        $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;
     };
+    $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 );
+    my $sth = $dbh->prepare($query);
-    $sth->execute( $pw_name, $pw_domain );
+    $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,
+    return
-            src_clear     => $u->{pw_clear_passwd},
+      Qpsmtpd::Auth::validate_password(
-            src_crypt     => $u->{pw_passwd},
+                                       $self,
-            attempt_clear => $passClear,
+                                       src_clear     => $u->{pw_clear_passwd},
-            attempt_hash  => $passHash,
+                                       src_crypt     => $u->{pw_passwd},
-            method        => $method,
+                                       attempt_clear => $passClear,
-            ticket        => $ticket,
+                                       attempt_hash  => $passHash,
-            deny          => DENY,
+                                       method        => $method,
-        );
+                                       ticket        => $ticket,
+                                       deny          => DENY,
+                                      );
 }
 

plugins/auth/auth_vpopmaild

@@ -5,8 +5,8 @@ use warnings;
 
 use Qpsmtpd::Constants;
 use IO::Socket;
-use version; 
+use version;
-my $VERSION = qv('1.0.3');
+my $VERSION = qv('1.0.4');
 
 sub register {
     my ($self, $qp, %args) = @_;
@@ -16,64 +16,91 @@ 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 $socket = $self->get_socket() or return DECLINED;
-    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>;
+    my $response = $self->get_response( $socket, '' )
-    if ( ! $connect_response ) {
+        or return DECLINED;
-        $self->log(LOGERROR, "skip: no connection response");
-        close($vpopmaild_socket);
-        return DECLINED;
-    };
 
-    if ( $connect_response !~ /^\+OK/ ) {
+    if ($response !~ /^\+OK/) {
-        $self->log(LOGERROR, "skip: bad connection response: $connect_response");
+        $self->log(LOGERROR, "skip, bad connection response: $response");
-        close($vpopmaild_socket);
+        close $socket;
         return DECLINED;
-    };
+    }
 
-    print $vpopmaild_socket "login $user $passClear\n\r"; # send login details
+    print $socket "login $user $passClear\n\r";  # send login details
-    my $login_response = <$vpopmaild_socket>;       # get response from server
+    $response = $self->get_response( $socket, "login $user $passClear\n\r" )
-    close($vpopmaild_socket);
+        or return DECLINED;
 
-    if ( ! $login_response ) {
+    close $socket;
-        $self->log(LOGERROR, "skip: no login response");
-        return DECLINED;
-    };
 
     # check for successful login (single line (+OK) or multiline (+OK+))
-    if ( $login_response =~ /^\+OK/ ) {
+    if ($response =~ /^\+OK/) {
-        $self->log(LOGINFO, "pass: clear");
+        $self->log(LOGINFO, "pass, clear");
         return (OK, 'auth_vpopmaild');
-    };
+    }
 
-    chomp $login_response;
+    chomp $response;
-    $self->log(LOGNOTICE, "fail: $login_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 $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;
+      };
+    return $socket;
+};
+
 __END__
 
 =head1 NAME
@@ -108,7 +135,9 @@ please read the VPOPMAIL section in doc/authentication.pod
 
 Robin Bowes <robin.bowes@yo61.com>
 
-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
 

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");
 }
 

plugins/badmailfrom

@@ -17,6 +17,20 @@ listed in badmailfrom. A line in badmailfrom may be of the form
 You may include an optional message after the sender address (leave a space),
 to be used when rejecting the sender.
 
+=head1 CONFIGURATION
+
+=head2 reject
+
+  badmailfrom reject [ 0 | 1 | naughty ]
+
+I<0> will not reject any connections.
+
+I<1> will reject naughty senders.
+
+I<connect> is the most efficient setting. It's also the default.
+
+To reject at any other connection hook, use the I<naughty> setting and the
+B<naughty> plugin.
 
 =head1 PATTERNS
 
@@ -30,98 +44,96 @@ 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$
 
 
-=head1 NOTES
-
-According to the SMTP protocol, we can't reject until after the RCPT
-stage, so store it until later.
-
-
 =head1 AUTHORS
 
-initial author of badmailfrom - Jim Winstead
+2002 - Jim Winstead - initial author of badmailfrom
 
-pattern matching plugin - Johan Almqvist <johan-qpsmtpd@almqvist.net>
+2010 - Johan Almqvist <johan-qpsmtpd@almqvist.net> - pattern matching plugin
 
-merging of the two and plugin tests - Matt Simerson <matt@tnpi.net>
+2012 - Matt Simerson - merging of the two and plugin tests
 
 =cut
 
+sub register {
+    my ($self, $qp) = (shift, shift);
+    $self->{_args} = {@_};
+
+    $self->{_args}{reject} = 1 if !defined $self->{_args}{reject};
+}
+
 sub hook_mail {
     my ($self, $transaction, $sender, %param) = @_;
 
-    my @badmailfrom = $self->qp->config('badmailfrom');
-    if ( defined $self->{_badmailfrom_config} ) {       # testing
-        @badmailfrom = @{$self->{_badmailfrom_config}};
-    };
-
     return DECLINED if $self->is_immune();
-    return DECLINED if $self->is_immune_sender( $sender, \@badmailfrom );
+
+    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
+        $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";
-        $transaction->notes('badmailfrom', $reason);
+        $self->adjust_karma(-1);
+        return $self->get_reject($reason);
     }
+
+    $self->log(LOGINFO, "pass");
     return DECLINED;
 }
 
 sub is_match {
-    my ( $self, $from, $bad, $host ) = @_;
+    my ($self, $from, $bad, $host) = @_;
 
-    if ( $bad =~ /[\/\^\$\*\+]/ ) {  # it's a regexp
+    if ($bad =~ /[\/\^\$\*\+\!\%\?\\]/) {    # it's a regexp
-        $self->log(LOGDEBUG, "badmailfrom pattern ($bad) match for $from");
+        if ($from =~ /$bad/) {
-        return 1 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 hook_rcpt {
-    my ($self, $transaction, $rcpt, %param) = @_;
-    my $note = $transaction->notes('badmailfrom') or return (DECLINED);
-
-    $self->log(LOGINFO, $note);
-    return (DENY, $note);
 }
 
 sub is_immune_sender {
-    my ($self, $sender, $badmf ) = @_;
+    my ($self, $sender, $badmf) = @_;
 
-    if ( ! scalar @$badmf ) {
+    if (!scalar @$badmf) {
-        $self->log(LOGDEBUG, 'skip: empty list');
+        $self->log(LOGDEBUG, 'skip, empty list');
         return 1;
-    };
+    }
 
-    if ( ! $sender || $sender->format eq '<>' ) {
+    if (!$sender || $sender->format eq '<>') {
-        $self->log(LOGDEBUG, 'skip: null sender');
+        $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');
+        $self->log(LOGDEBUG, 'skip, missing user or host');
         return 1;
-    };
+    }
 
     return;
-};
+}

plugins/badmailfromto

@@ -0,0 +1,83 @@
+#!perl -w
+
+=head1 NAME
+
+badmailfromto - checks the badmailfromto config
+
+=head1 DESCRIPTION
+
+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 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, '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;
+}

plugins/badrcptto

@@ -47,83 +47,85 @@ 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();
 
-    my ($host, $to) = $self->get_host_and_to( $recipient )
+    my ($host, $to) = $self->get_host_and_to($recipient)
-        or return (DECLINED);
+      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);
     };
 
     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;
+        next if !$bad;
-        if ( $self->is_match( $to, lc($bad), $host ) ) {
+        if ($self->is_match($to, lc($bad), $host)) {
-            if ( $reason ) {
+            $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 (substr($bad, 0, 1) eq '@') {
-        if ( $bad eq "\@$host" ) {
+        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);
-};
+}

plugins/bogus_bounce

@@ -0,0 +1,98 @@
+#!perl -w
+
+=head1 NAME
+
+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
+
+=head1 AUTHOR
+
+2010 - Steve Kemp - http://steve.org.uk/Software/qpsmtpd/
+
+2013 - Matt  Simerson - added Return Path check
+
+=cut
+
+sub register {
+    my ($self, $qp) = (shift, shift);
+
+    if (@_ % 2) {
+        $self->{_args}{action} = shift;
+    }
+    else {
+        $self->{_args} = {@_};
+    }
+
+    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) {
+        $self->{_args}{reject_type} = 'temp';
+    }
+}
+
+sub hook_data_post {
+    my ($self, $transaction) = (@_);
+
+    #
+    # Find the sender, quit processing if this isn't a bounce.
+    #
+    my $sender = $transaction->sender->address || undef;
+    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.
+    #
+    #  Count the recipients. Valid bounces have a single recipient
+    #
+    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");
+    }
+
+    # 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)");
+    }
+
+    $self->log(LOGINFO, "pass, single recipient, empty Return-Path");
+    return DECLINED;
+}

plugins/check_badmailfromto

@@ -1,83 +0,0 @@
-#!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;
-};

plugins/check_badrcptto_patterns

@@ -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 <gordonr@gormand.com.au>
-
-This software is free software and may be distributed under the same
-terms as qpsmtpd itself.
-
-=cut
-
-sub hook_rcpt
-{
-  my ($self, $transaction, $recipient) = @_;
-
-  return (DECLINED) if $self->qp->connection->relay_client();
-
-  my @badrcptto = $self->qp->config("badrcptto_patterns") or return (DECLINED);
-  my $host = lc $recipient->host;
-  my $to = lc($recipient->user) . '@' . $host;
-
-  for (@badrcptto)
-  {
-      my ($pattern, $response) = split /\s+/, $_, 2;
-
-      return (DENY, $response) if ($to =~ /$pattern/);
-  }
-
-  return (DECLINED);
-}

plugins/check_basicheaders

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

plugins/check_bogus_bounce

@@ -1,126 +0,0 @@
-#!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;
-}

plugins/check_loop

@@ -1,55 +0,0 @@
-#!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;
-}

plugins/check_spamhelo

@@ -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<badhelo> configuration file; one
-per line.
-
-=cut
-
-sub hook_helo {
-  my ($self, $transaction, $host) = @_;
-  ($host = lc $host) or return DECLINED;
-  
-  for my $bad ($self->qp->config('badhelo')) {
-    if ($host eq lc $bad) {
-      $self->log(LOGDEBUG, "Denying HELO from host claiming to be $bad");
-      return (DENY_DISCONNECT, "Sorry, I don't believe that you are $host.");
-    }
-  }
-  return DECLINED;
-}
-
-# also support EHLO
-*hook_ehlo = \&hook_helo;

plugins/connection_time

@@ -31,49 +31,48 @@ 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
+    if (@_ == 1) {    # backwards compatible
         $self->{_args}{loglevel} = shift;
-        if ( $self->{_args}{loglevel} =~ /\D/ ) {
+        if ($self->{_args}{loglevel} =~ /\D/) {
-            $self->{_args}{loglevel} = Qpsmtpd::Constants::log_level($self->{_args}{loglevel});
+            $self->{_args}{loglevel} =
-        };
+              Qpsmtpd::Constants::log_level($self->{_args}{loglevel});
+        }
         $self->{_args}{loglevel} ||= 6;
     }
-    elsif ( @_ % 2 ) {
+    elsif (@_ % 2) {
-       $self->log(LOGERROR, "invalid arguments");
+        $self->log(LOGERROR, "invalid arguments");
     }
     else {
-        $self->{_args} = { @_ };     # named args, inherits loglevel
+        $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} );
+    $self->log(LOGDEBUG, "started at " . scalar gettimeofday);
-    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} ) {
+    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);
 }
 

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
+    # as a decent default, log on a per-day-basis
-  my $date = strftime("%Y%m%d",localtime(time));
+    my $date = strftime("%Y%m%d", localtime(time));
-  open(my $out,">>mail/$date")
+    open(my $out, ">>mail/$date")
-    or return(DECLINED,"Could not open log file.. continuing anyway");
+      or return (DECLINED, "Could not open log file.. continuing anyway");
 
-  $transaction->header->print($out);
+    $transaction->header->print($out);
-  $transaction->body_resetpos;
+    $transaction->body_resetpos;
-  while (my $line = $transaction->body_getline) {
+    while (my $line = $transaction->body_getline) {
-    print $out $line;
+        print $out $line;
-  }
+    }
 
-  close $out;
+    close $out;
 
-  return (DECLINED, "successfully saved message.. continuing");
+    return (DECLINED, "successfully saved message.. continuing");
 }

plugins/count_unrecognized_commands

@@ -2,7 +2,7 @@
 
 =head1 NAME
 
-count_unrecognized_commands - Count unrecognized commands and disconnect when we have too many
+count_unrecognized_commands - and disconnect after too many
 
 =head1 DESCRIPTION
 
@@ -22,38 +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_connect {
-  my $self = shift;
-
-  $self->connection->notes('unrec_cmd_count', 0);
-  return DECLINED;
-}
-
 sub hook_unrecognized_command {
-  my ($self, $cmd) = @_[0,2];
+    my ($self, $cmd) = @_[0, 2];
-  
-  $self->log(LOGINFO, "Unrecognized command '$cmd'");
 
-  my $badcmdcount = 
+    my $count = $self->connection->notes('unrec_cmd_count') || 0;
-    $self->connection->notes( 'unrec_cmd_count',
+    $count = $count + 1;
-        ($self->connection->notes('unrec_cmd_count') || 0) + 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?"
     );
-
-  if ($badcmdcount >= $self->{_unrec_cmd_max}) {
-    my $msg = "Closing connection, $badcmdcount unrecognized commands.";
-    $self->log(LOGINFO, "fail: $msg");
-    return (DENY_DISCONNECT, "$msg Perhaps you should read RFC 2821?");
-  }
-
-  return DECLINED;
 }
 

plugins/dkim

@@ -0,0 +1,535 @@
+#!perl -w
+
+=head1 NAME
+
+dkim: validate DomainKeys and (DKIM) Domain Keys Indentified Messages
+
+=head1 SYNOPSIS
+
+Validate the DKIM and Domainkeys signatures of a message, enforce DKIM
+sending policies, and DKIM sign outgoing messages.
+
+=head1 CONFIGURATION
+
+=head2 reject [ 0 | 1 | naughty ]
+
+  dkim [ reject 0 ]
+
+    0        - do not reject
+    1        - reject messages that fail DKIM policy
+    naughty  - defer rejection to the B<naughty> plugin
+
+Default: 1
+
+=head2 reject_type
+
+  dkim reject_type [ temp | perm ]
+
+Default: perm
+
+=head1 HOW TO SIGN
+
+=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 'may2013' > selector
+  openssl genrsa -out private 2048
+  chmod 400 private
+  openssl rsa -in private -out public -pubout
+  chown -R smtpd:smtpd ../example.org
+
+After generating the keys, there will be three files in the example.org directory: selector, private, and 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, 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<dns>. 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 combination of the three example DKIM, SPF, and DMARC policy records in the I<dns> 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:
+
+  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 ]
+  granularity: g=[ ]
+  notes: n=[ ]
+  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. You can testing DKIM by sending an email to:
+
+  * 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.
+
+=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]
+
+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 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
+  ln -s example.org client.com
+
+QP will follow the symlink target and sign client.com emails with the example.org DKIM key.
+
+This is B<not> 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
+
+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
+
+http://dkimcore.org/tools/
+
+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
+
+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. Why?
+
+=over 4
+
+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.
+
+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
+
+use strict;
+use warnings;
+
+use Qpsmtpd::Constants;
+
+# use Mail::DKIM::Verifier;  # eval'ed in register()
+# use Mail::DKIM::Signer;
+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;
+
+    #  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";
+            $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()) {
+
+        # this is an authenticated user 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;
+    };
+
+    $self->send_message_to_dkim($dkim, $transaction);
+    my $result = $dkim->result;
+    my $mess   = $self->get_details($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;
+        my $handler = 'handle_sig_' . $t;
+        $self->log(LOGDEBUG, "dispatching $result to $handler");
+        return $self->$handler($dkim, $mess);
+    }
+
+    $self->log(LOGERROR, "error, unknown result: $result, $mess");
+    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, we signed the message");
+    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) = @_;
+
+    $self->adjust_karma(-1);
+    return $self->get_reject("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);
+
+    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);
+
+    if ($prs->{accept}) {
+        $self->log(LOGERROR, "error, invalid signature but accept policy!?");
+        return DECLINED;
+    }
+    elsif ($prs->{neutral}) {
+        $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");
+    return DECLINED;
+}
+
+sub handle_sig_pass {
+    my ($self, $dkim, $mess) = @_;
+
+    $self->save_signatures_to_note($dkim);
+
+    my ($prs) = $self->get_policy_results($dkim);
+
+    if ($prs->{accept}) {
+        $self->add_header($mess);
+        $self->log(LOGINFO, "pass, valid signature, accept policy");
+        $self->adjust_karma(1);
+        return DECLINED;
+    }
+    elsif ($prs->{neutral}) {
+        $self->add_header($mess);
+        $self->log(LOGINFO, "pass, valid signature, neutral policy");
+        $self->log(LOGDEBUG, $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");
+    }
+
+    # 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);
+
+    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_keydir {
+    my ($self, $transaction) = @_;
+
+    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
+                $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");
+            }
+        }
+    }
+
+    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 save_signatures_to_note {
+    my ($self, $dkim) = @_;
+
+    my %domains;
+    foreach my $sig ($dkim->signatures) {
+        next if $sig->result ne 'pass';
+        $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 {
+    my ($self, $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;
+        $line =~ s/\015$//;
+        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 $@;
+    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 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(LOGDEBUG, "info, selector: $selector");
+    return $selector;
+}
+
+sub add_header {
+    my $self = shift;
+    my $header = shift or return;
+    $self->qp->transaction->header->add('X-DKIM-Authentication', $header, 0);
+}
+

plugins/dmarc

@@ -0,0 +1,478 @@
+#!perl -w
+
+=head1 NAME
+
+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.
+
+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 HOWTO
+
+=head2 Protect a domain with DMARC
+
+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
+
+=head3 Publish a DMARC policy
+
+_dmarc  IN TXT "v=DMARC1; p=reject; 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)
+ adkim=s;     (dkim alignment: s=strict, r=relaxed)
+ aspf=r;      (spf  alignment: s=strict, r=relaxed)
+ 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
+
+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, 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
+
+=head1 TODO
+
+ provide dmarc feedback to domains that request it
+
+ reject messages with multiple From: headers
+
+=head1 AUTHORS
+
+ 2013 - Matt Simerson <msimerson@cpan.org>
+
+=cut
+
+use strict;
+use warnings;
+
+use Qpsmtpd::Constants;
+
+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
+    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");
+    };
+
+    # 11.2.  Determine Handling Policy
+    my $policy = $self->discover_policy($from_dom, $org_dom)
+      or return DECLINED;
+
+    #   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') || [];
+
+    #   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 $effective_policy = ( $self->{_args}{is_subdomain} && defined $policy->{sp} )
+        ? $policy->{sp} : $policy->{p};
+
+    #   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");
+        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");
+        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;
+    };
+
+    $self->store_auth_results("dmarc=fail (p=$effective_policy) d=$from_dom");
+    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
+
+}

plugins/dns_whitelist_soft

@@ -1,4 +1,5 @@
 #!perl -w
+
 =head1 NAME
 
 dns_whitelist_soft - dns-based whitelist override for other qpsmtpd plugins
@@ -48,111 +49,122 @@ based on the 'whitelist' plugin by Devin Carraway <qpsmtpd@devin.com>.
 
 =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) = @_;
+    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] }
+    my %whitelist_zones =
-				$self->qp->config('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
+    # we queue these lookups in the background and just fetch the
-  # results in the first rcpt handler
+    # results in the first rcpt handler
 
-  my $res = new Net::DNS::Resolver;
+    my $res = new Net::DNS::Resolver;
-  my $sel = IO::Select->new();
+    my $sel = IO::Select->new();
 
-  for my $dnsbl (keys %whitelist_zones) {
+    for my $dnsbl (keys %whitelist_zones) {
-    $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl in the background");
+        $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);
+    $self->connection->notes('whitelist_sockets', $sel);
-
+    return DECLINED;
-  return DECLINED;
 }
 
 sub process_sockets {
-  my ($self) = @_;
+    my ($self) = @_;
 
-  my $conn = $self->connection;
+    my $conn = $self->connection;
 
-  return $conn->notes('whitelisthost') 
+    return $conn->notes('whitelisthost') if $conn->notes('whitelisthost');
-    if $conn->notes('whitelisthost');
 
-  my $res = new Net::DNS::Resolver;
+    my $res = new Net::DNS::Resolver;
-  my $sel = $conn->notes('whitelist_sockets') or return "";
+    my $sel = $conn->notes('whitelist_sockets') or return '';
 
-  my $result; 
+    $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
+    $self->log(LOGDEBUG,
-  my @ready = $sel->can_read(4);
+               "done waiting for whitelist dns, got ",
+               scalar @ready,
+               " answers ...");
+    return '' unless @ready;
 
-  $self->log(LOGDEBUG, "DONE waiting for whitelist dns, got ",
+    my $result;
-  	scalar @ready, " answers ...") ;
-  return '' unless @ready;
 
-  for my $socket (@ready) {
+    for my $socket (@ready) {
-    my $query = $res->bgread($socket);
+        my $query = $res->bgread($socket);
-    $sel->remove($socket);
+        $sel->remove($socket);
-    undef $socket;
+        undef $socket;
 
-    my $whitelist;
+        my $whitelist;
 
-    if ($query) {
+        if ($query) {
-      my $a_record = 0;
+            my $a_record = 0;
-      foreach my $rr ($query->answer) {
+            foreach my $rr ($query->answer) {
-	$a_record = 1 if $rr->type eq "A";
+                $a_record = 1 if $rr->type eq 'A';
-	my $name = $rr->name;
+                my $name = $rr->name;
-	($whitelist) = ($name =~ m/(?:\d+\.){4}(.*)/) unless $whitelist;
+                ($whitelist) = ($name =~ m/(?:\d+\.){4}(.*)/) unless $whitelist;
-	$whitelist = $name unless $whitelist;
+                $whitelist = $name unless $whitelist;
-	$self->log(LOGDEBUG, "name ", $rr->name);
+                $self->log(LOGDEBUG, 'name ', $rr->name);
-	next unless $rr->type eq "TXT";
+                next unless $rr->type eq 'TXT';
-	$self->log(LOGDEBUG, "got txt record");
+                $self->log(LOGDEBUG, "got txt record");
-	$result = $rr->txtdata and last;
+                $result = $rr->txtdata and last;
-      }
+            }
-      $a_record and $result = "Blocked by $whitelist";
+            $a_record and $result = "Blocked by $whitelist";
-    }
+        }
-    else {
+        else {
-      $self->log(LOGERROR, "$whitelist query failed: ", $res->errorstring)
+            $self->log(LOGERROR, "$whitelist query failed: ", $res->errorstring)
-	unless $res->errorstring eq "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 ($result) {
+    if ($sel->count) {
-      #kill any other pending I/O
+
-      $conn->notes('whitelist_sockets', undef);
+        # loop around if we have dns blacklists left to see results from
-      return $conn->notes('whitelisthost', $result);
+        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();
-  }
 
-  # er, the following code doesn't make much sense anymore...
+    # if there was more to read; then forget it
-
+    $conn->notes('whitelist_sockets', undef);
-  # if there was more to read; then forget it
-  $conn->notes('whitelist_sockets', undef);
-
-  return $conn->notes('whitelisthost', $result);
 
+    return $conn->notes('whitelisthost', $result);
 }
 
 sub hook_rcpt {
-  my ($self, $transaction, $rcpt, %param) = @_;
+    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;
+    my $note = $self->process_sockets;
-  if ( $note ) {
+    if ($note) {
-    $self->log(LOGNOTICE,"Host $ip is whitelisted: $note");
+        $self->log(LOGNOTICE, "Host $ip is whitelisted: $note");
-  }
+    }
-  return DECLINED;
+    return DECLINED;
 }
 
-1;

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<reject naughty> 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<reject_type disconnect>. 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,60 +133,117 @@ 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 ) {
+    if (@_ % 2) {
-        $self->{_args}{reject_type} = shift;   # backwards compatibility
+        $self->{_args}{reject_type} = shift;    # backwards compatibility
     }
     else {
-        $self->{_args} = { @_ };
+        $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) = @_;
+
+    # 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';
+    }
 
-    # 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->is_set_rblsmtpd();
     return DECLINED if $self->ip_whitelisted();
 
-  my %dnsbl_zones = map { (split /:/, $_, 2)[0,1] } $self->qp->config('dnsbl_zones');
+    my $dnsbl_zones = $self->get_dnsbl_zones() or return DECLINED;
-    if ( ! %dnsbl_zones ) {
+    my $resolv      = $self->get_resolver()    or return DECLINED;
-        $self->log( LOGDEBUG, "skip: no list configured");
-        return DECLINED;
-    };
 
-  my $remote_ip = $self->qp->connection->remote_ip;
+    for my $dnsbl (keys %$dnsbl_zones) {
-  my $reversed_ip = join('.', reverse(split(/\./, $remote_ip)));
 
-  # we queue these lookups in the background and fetch the
+        my $query = $self->get_query($dnsbl) or do {
-  # results in the first rcpt handler
+            if ($resolv->errorstring ne 'NXDOMAIN') {
+                $self->log(LOGERROR, "$dnsbl query failed: ",
+                           $resolv->errorstring);
+            }
+            next;
+        };
 
-  my $res = new Net::DNS::Resolver;
+        my $a_record = 0;
-  $res->tcp_timeout(30);
+        my $result;
-  $res->udp_timeout(30);
+        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;
+            }
 
-  my $sel = IO::Select->new();
+            next if !$result;
 
-  my $dom;
+            $self->adjust_karma(-1);
-  for my $dnsbl (keys %dnsbl_zones) {
+
-    # fix to find A records, if the dnsbl_zones line has a second field 20/1/04 ++msp
+            if (!$dnsbl) { ($dnsbl) = ($result =~ m/(?:\d+\.){4}(.*)/); }
-    $dom->{"$reversed_ip.$dnsbl"} = 1;
+            if (!$dnsbl) { $dnsbl = $result; }
-    if (defined($dnsbl_zones{$dnsbl})) {
+
-      $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for A record in the background");
+            if ($a_record) {
-      $sel->add($res->bgsend("$reversed_ip.$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);
+                }
+                return $self->get_reject("Blocked by $dnsbl");
+            }
+
+            return $self->get_reject($result, $dnsbl);
+        }
     }
-    else {
+
-      $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for TXT record in the background");
+    $self->log(LOGINFO, 'pass');
-      $sel->add($res->bgsend("$reversed_ip.$dnsbl", "TXT"));
+    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->connection->notes('dnsbl_sockets', $sel);
+    $self->{_dnsbl}{zones} = \%dnsbl_zones;
-  $self->connection->notes('dnsbl_domains', $dom);
+    return \%dnsbl_zones;
+}
 
-  return DECLINED;
+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 {
@@ -182,10 +251,10 @@ sub is_set_rblsmtpd {
 
     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");
@@ -193,151 +262,52 @@ 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 = shift;
+    my ($self) = @_;
 
-    my $remote_ip = shift || $self->qp->connection->remote_ip;
+    my $remote_ip = $self->qp->connection->remote_ip;
 
-    return
+    return grep {
-        grep { s/\.?$/./; $_ eq substr($remote_ip . '.', 0, length $_) }
+        s/\.?$/./;
-            $self->qp->config('dnsbl_allow');
+        $_ eq substr($remote_ip . '.', 0, length $_)
-};
+    } $self->qp->config('dnsbl_allow');
+}
 
-sub process_sockets {
+sub return_env_message {
-  my ($self) = @_;
+    my $self      = shift;
-
+    my $result    = $ENV{'RBLSMTPD'};
-  my $conn = $self->connection;
+    my $remote_ip = $self->qp->connection->remote_ip;
-
+    $result =~ s/%IP%/$remote_ip/g;
-  return $conn->notes('dnsbl') if $conn->notes('dnsbl');
+    my $msg = $self->qp->config('dnsbl_rejectmsg');
-
+    $self->log(LOGINFO, "fail, $msg");
-  my %dnsbl_zones = map { (split /:/, $_, 2)[0,1] } $self->qp->config('dnsbl_zones');
+    return ($self->get_reject_type(), join(' ', $msg, $result));
-
-  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) = @_;
+    my ($self, $transaction, $rcpt, %param) = @_;
 
-    return DECLINED if $self->is_immune();
+    if ($rcpt->user =~ /^(?:postmaster|abuse|mailer-daemon|root)$/i) {
+        $self->log(LOGWARN,
+                   "skip, don't blacklist special account: " . $rcpt->user);
 
-  # RBLSMTPD being non-empty means it contains the failure message to return
+        # clear the naughty connection note here, if desired.
-  if (defined $ENV{'RBLSMTPD'} && $ENV{'RBLSMTPD'} ne '') {
+        $self->is_naughty(0);
-    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 DECLINED;
-    return ( $self->get_reject_type(), $note);
 }
 
-sub hook_disconnect {
+sub get_resolver {
-  my ($self, $transaction) = @_;
-
-  $self->connection->notes('dnsbl_sockets', undef);
-
-  return DECLINED;
-}
-
-sub get_reject_type {
     my $self = shift;
-    my $default = shift || DENY;
+    return $self->{_resolver} if $self->{_resolver};
-    my $deny = $self->{_args}{reject_type} or return $default;
+    $self->log(LOGDEBUG, "initializing Net::DNS::Resolver");
-
+    $self->{_resolver} = Net::DNS::Resolver->new(dnsrch => 0);
-    return   $self->{_args}{reject_type} eq 'temp'       ? DENYSOFT
+    my $timeout = $self->{_args}{timeout} || 30;
-           : $self->{_args}{reject_type} eq 'disconnect' ? DENY_DISCONNECT
+    $self->{_resolver}->tcp_timeout($timeout);
-           : $default;
+    $self->{_resolver}->udp_timeout($timeout);
-};
+    return $self->{_resolver};
+}
 

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'm still seeing ham arrive with DomainKeys signatures.
+
 =head1 CONFIGURATION
 
 =head2 reject
@@ -39,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
 
@@ -53,114 +59,115 @@ 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} = 1 if !defined $self->{reject};    # default reject
-    $self->{reject_type} = 'perm' if ! defined $self->{reject_type};
+    $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) = @_;
 
-    if ( ! $transaction->header->get('DomainKey-Signature') ) {
-        $self->log(LOGINFO, "skip: unsigned");
-        return DECLINED;
-    };
-	
     return DECLINED if $self->is_immune();
 
-    my $body = $self->assemble_body( $transaction );
+    if (!$transaction->header->get('DomainKey-Signature')) {
+        $self->log(LOGINFO, "skip, unsigned");
+        return DECLINED;
+    }
 
-    my $message = load Mail::DomainKeys::Message(
+    my $body = $self->assemble_body($transaction);
-        HeadString => $transaction->header->as_string,
+
-        BodyReference => $body) or do {
+    my $message =
-            $self->log(LOGWARN, "skip: unable to load message"),
+      load Mail::DomainKeys::Message(
-            return DECLINED;
+                                  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"),
+        $self->log(LOGINFO, "skip, failed to parse sender domain"),
+          return DECLINED;
+    }
+
+    my $status = $self->get_message_status($message);
+
+    if (defined $status) {
+#$transaction->header->add("DomainKey-Status", $status, 0);
+        $self->store_auth_results('domainkey=' . $status);
+        $self->log(LOGINFO, "pass, $status");
         return DECLINED;
-    };
+    }
 
-    my $status = $self->get_message_status( $message );
+    $self->log(LOGERROR, "fail, signature invalid");
-
+    return DECLINED if !$self->{reject};
-    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");
+    return ($deny, "DomainKeys signature validation failed");
 }
 
 sub get_message_status {
     my ($self, $message) = @_;
 
-    if ( $message->testing ) {
+    if ($message->testing) {
-        return "testing";   # key testing, don't do anything else
+        return "testing";    # key testing, don't do anything else
-    };
+    }
 
-    if ( $message->signed && $message->verify ) {
+    if ($message->signed && $message->verify) {
-        return $message->signature->status; # verified: add good header
+        return $message->signature->status;    # verified: add good header
-    };
+    }
 
     # not signed or not verified
-    my $policy = fetch Mail::DomainKeys::Policy(
+    my $policy =
-        Protocol => 'dns',
+      fetch Mail::DomainKeys::Policy(Protocol => 'dns',
-        Domain => $message->senderdomain
+                                     Domain   => $message->senderdomain);
-    );
 
-    if ( ! $policy ) {
+    if (!$policy) {
         return $message->signed ? "non-participant" : "no signature";
-    };
+    }
 
-    if ( $policy->testing ) {
+    if ($policy->testing) {
-        return "testing";  # Don't do anything else
+        return "testing";    # Don't do anything else
-    };
+    }
 
-    if ( $policy->signall ) {
+    if ($policy->signall) {
-        return undef;      # policy requires all mail to be signed
+        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;
-};
+}

plugins/dont_require_anglebrackets

@@ -1,5 +1,5 @@
 #!perl -w
- 
+
 =head1 NAME
 
 dont_require_anglebrackets 
@@ -22,19 +22,21 @@ 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 . '>';
+        $self->adjust_karma(-1);
     }
     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 . '>';
+        $self->adjust_karma(-1);
     }
     return (OK, $addr);
 }

plugins/dspam

@@ -6,31 +6,31 @@ dspam - dspam integration for qpsmtpd
 
 =head1 DESCRIPTION
 
-qpsmtpd plugin that uses dspam to classify messages. Can use SpamAssassin to
+Uses dspam to classify messages. Use B<spamassassin>, B<karma>, and B<naughty>
-train dspam.
+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 notes is a hashref
+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 ratings as well.
+contain a probability and confidence rating.
 
 =head1 TRAINING DSPAM
 
-Do not just enable dspam! Its false positive rate when untrained is high. The
+If you enable dspam rejection without training first, you will lose valid
-good news is; dspam learns very, very fast.
+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
+The best method way to train dspam is to feed it two large equal sized
-train dspam is to feed it two large equal sized corpuses of spam and ham from
+corpuses of spam and ham from your mail server. The dspam authors suggest
-your mail server. The dspam authors suggest avoiding public corpuses. I train
+avoiding public corpuses. I train dspam as follows:
-dspam as follows:
 
 =over 4
 
 =item learn from SpamAssassin
 
-See the docs on the learn_from_sa feature in the CONFIG section.
+See the SPAMASSASSIN section.
 
 =item periodic training
 
@@ -54,41 +54,58 @@ messages are moved to/from the Spam folder.
 =head2 dspam_bin
 
 The path to the dspam binary. If yours is installed somewhere other
-than /usr/local/bin/dspam, you'll need to set this.
+than /usr/local/bin/dspam, set this.
 
-=head2 learn_from_sa
+=head2 autolearn [ naughty | karma | spamassassin | any ]
-
-Dspam can be trained by SpamAssassin. This relationship between them requires
-attention to several important details:
 
 =over 4
 
-=item 1
+=item naughty
 
-dspam must be listed B<after> spamassassin in the config/plugins file.
+learn naughty messages as spam (see plugins/naughty)
-Because SA runs first, I crank 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
+=item karma
-reduce the SA load.
 
-=item 2
+learn messages with negative karma as spam (see plugins/karma)
 
-Autolearn must be enabled and configured in SpamAssassin. SA autolearn
+=item spamassassin
-preferences will determine whether a message is learned as spam or innocent
-by dspam. The settings to pay careful attention to in your SA local.cf file
-are bayes_auto_learn_threshold_spam and bayes_auto_learn_threshold_nonspam.
-Make sure they are both set to conservative values that are certain to
-yield no false positives.
 
-If you are using learn_from_sa and reject, then messages that exceed the SA
+learn from spamassassins messages with autolearn=(ham|spam). See SPAMASSASSIN.
-threshholds will cause dspam to reject them. Again I say, make sure them SA
-autolearn threshholds are set high enough to avoid false positives.
 
-=item 3
+=item any
 
-dspam must be configured and working properly. I have modified the following
+all of the above, and any future tests too!
-dspam values on my system:
+
+=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<reject agree>.
+
+=head2 reject_type
+
+ reject_type [ perm | temp | disconnect ]
+
+By default, rejects are permanent (5xx). Set I<reject_type temp> to
+defer mail instead of rejecting it.
+
+Set I<reject_type disconnect> 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
 
@@ -117,27 +134,47 @@ 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
+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
+
+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<after> 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
+
+For I<autolearn spamassassin> 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<bayes_auto_learn_threshold_spam>
+and I<bayes_auto_learn_threshold_nonspam>. Make sure they are set to
+conservative values that will yield no false positives.
+
+If you are using I<autolearn spamassassin> and I<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
 
-=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.
-
-=head2 reject_type
-
- reject_type [ temp | perm ]
-
-By default, rejects are permanent (5xx). Set this to temp if you want to
-defer mail instead of rejecting it with dspam.
-
 =head1 MULTIPLE RECIPIENT BEHAVIOR
 
 For messages with multiple recipients, the user that dspam is running as will
@@ -151,65 +188,87 @@ ie, (Trust smtpd).
 
 =head1 CHANGES
 
+2012-06 - Matt Simerson - added karma & naughty learning support
+                        - worked around the DESTROY bug in dspam_process
+
 =head1 AUTHOR
 
- Matt Simerson - 2012
+2012 - Matt Simerson
 
 =cut
 
 use strict;
 use warnings;
 
+use lib 'lib';
+
 use Qpsmtpd::Constants;
 use Qpsmtpd::DSN;
 use IO::Handle;
 use Socket qw(:DEFAULT :crlf);
 
 sub register {
-    my ($self, $qp, %args) = @_;
+    my ($self, $qp) = (shift, shift);
 
     $self->log(LOGERROR, "Bad parameters for the dspam plugin") if @_ % 2;
 
-    $self->{_args} = { %args };
+    $self->{_args} = {@_};
-    $self->{_args}{reject} = defined $args{reject} ? $args{reject} : 1;
+    $self->{_args}{reject} = 1 if !defined $self->{_args}{reject};
-    $self->{_args}{reject_type} = $args{reject_type} || 'perm';
+    $self->{_args}{reject_type} ||= 'perm';
+    $self->{_args}{dspam_bin}   ||= '/usr/local/bin/dspam';
 
-    $self->register_hook('data_post', 'dspam_reject');
+    $self->get_dspam_bin() or return DECLINED;
+
+    $self->register_hook('data_post', 'data_post_handler');
 }
 
-sub hook_data_post {
+sub get_dspam_bin {
-    my ($self, $transaction) = @_;
+    my $self = shift;
 
-    $self->log(LOGDEBUG, "check_dspam");
+    my $bin = $self->{_args}{dspam_bin};
-    if ( $transaction->data_size > 500_000 ) {
+    if (!-e $bin) {
-        $self->log(LOGINFO, "skip: message too large (" . $transaction->data_size . ")" );
+        $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;
+
+    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 $user = $self->select_username($transaction);
-    my $message  = $self->assemble_message($transaction);
+    my $bin  = $self->{_args}{dspam_bin};
-    my $filtercmd = $self->get_filter_cmd( $transaction, $username );
+    my $filtercmd =
+      "$bin --user $user --mode=tum --process --deliver=summary --stdout";
     $self->log(LOGDEBUG, $filtercmd);
 
-    my $response = $self->dspam_process( $filtercmd, $message );
+    my $response = $self->dspam_process($filtercmd, $transaction);
-    if ( ! $response ) {
+    if (!$response->{result}) {
-        $self->log(LOGWARN, "skip: no response from dspam. Check logs for errors.");
+        $self->log(LOGWARN, "error, no dspam response. Check logs for errors.");
         return (DECLINED);
-    };
+    }
 
-    # X-DSPAM-Result: user@example.com; result="Spam"; class="Spam"; probability=1.0000; confidence=1.00; signature=N/A
+    $transaction->notes('dspam', $response);
-    # 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);
-    $transaction->header->replace('X-DSPAM-Result', $header_str, 0);
 
-    # the signature header is required if you intend to train dspam later.
+    $self->attach_headers($response, $transaction);
-    # In dspam.conf, set: Preference "signatureLocation=headers"
+    $self->autolearn($response, $transaction);
-    $transaction->header->add('X-DSPAM-Signature', $sig, 0);
 
-    return (DECLINED);
+    return $self->log_and_return($transaction);
-};
+}
 
 sub select_username {
     my ($self, $transaction) = @_;
@@ -217,190 +276,462 @@ sub select_username {
     my $recipient_count = scalar $transaction->recipients;
     $self->log(LOGDEBUG, "Message has $recipient_count recipients");
 
-    if ( $recipient_count > 1 ) {
+    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($>);
-    };
+    }
 
-# 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";
+
     $transaction->body_resetpos;
+    while (my $line = $transaction->body_getline) { $message .= $line; }
 
-    my $message = "X-Envelope-From: "
+    $message = join(CRLF, split /\n/, $message);
-        . $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 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, $message ) = @_;
+    my ($self, $filtercmd, $transaction) = @_;
 
-    #return $self->dspam_process_open2( $filtercmd, $message );
+    my $response = $self->dspam_process_backticks($filtercmd);
 
-    my ($in_fh, $out_fh);
+    #my $response = $self->dspam_process_open2( $filtercmd, $transaction );
-    if (! open($in_fh, '-|')) {
+    #my $response = $self->dspam_process_fork( $filtercmd );
-        open($out_fh, "|$filtercmd") or die "Can't run $filtercmd: $!\n";
+
+    return $self->parse_response($response);
+}
+
+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
+    # 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 = join('', <$in_fh>);
     my $response = <$in_fh>;
     close $in_fh;
     chomp $response;
     $self->log(LOGDEBUG, $response);
     return $response;
-};
+}
+
+sub dspam_process_backticks {
+    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->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 {
-    my ( $self, $filtercmd, $message ) = @_;
+    my ($self, $filtercmd, $transaction) = @_;
 
-# not sure why, but this is not as reliable as I'd like. What's a dspam
+    my $message = $self->assemble_message($transaction);
-# 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::Open2;
+    use IPC::Open3;
-    my ($dspam_in, $dspam_out);
+    my ($read, $write, $err);
-    my $pid = open2($dspam_out, $dspam_in, $filtercmd);
+    use Symbol 'gensym';
-    print $dspam_in $message;
+    $err = gensym;
-    close $dspam_in;
+    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;
+    my $child_exit_status = $? >> 8;
-    $self->log(LOGDEBUG, $response);
+
+    #$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;
-};
+}
 
-sub dspam_reject {
+sub log_and_return {
-    my ($self, $transaction) = @_;
+    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");
+        $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)");
+        $self->log(LOGINFO, "skip, reject disabled ($status)");
         return DECLINED;
     };
 
-    if ( $reject eq 'agree' ) {
+    if ($reject eq 'agree') {
-        return $self->dspam_reject_agree( $transaction, $d );
+        return $self->reject_agree($transaction);
-    };
+    }
-    if ( $d->{class} eq 'Innocent' ) {
+
-        $self->log(LOGINFO, "pass: $status");
+    if ($d->{class} eq 'Innocent') {
+        $self->log(LOGINFO, "pass, $status");
         return DECLINED;
-    };
+    }
-    if ( $self->qp->connection->relay_client ) {
+    if ($self->qp->connection->relay_client) {
-        $self->log(LOGINFO, "skip: allowing spam, user authenticated ($status)");
+        $self->log(LOGINFO,
+                   "skip, allowing spam, user authenticated ($status)");
         return DECLINED;
-    };
+    }
-    if ( $d->{probability} <= $reject ) {
+    if ($d->{probability} <= $reject) {
-        $self->log(LOGINFO, "pass, $d->{class} probability is too low ($d->{probability} < $reject)");
+        $self->log(LOGINFO,
+"pass, $d->{class} probability is too low ($d->{probability} < $reject)"
+        );
         return DECLINED;
-    };
+    }
-    if ( $d->{confidence} != 1 ) {
+    if ($d->{confidence} != 1) {
-        $self->log(LOGINFO, "pass: $d->{class} confidence is too low ($d->{confidence})");
+        $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)");
+    $self->log(LOGINFO, "fail, $d->{class}, ($d->{confidence} confident)");
-    my $deny = $self->{_args}{reject_type} eq 'temp' ? DENYSOFT : DENY;
+    my $deny = $self->get_reject_type();
-    return Qpsmtpd::DSN->media_unsupported($deny,'dspam says, no spam please');
+    return Qpsmtpd::DSN->media_unsupported($deny, 'dspam says, no spam please');
 }
 
-sub dspam_reject_agree {
+sub reject_agree {
-    my ($self, $transaction, $d ) = @_;
+    my ($self, $transaction) = @_;
 
-    my $sa = $transaction->notes('spamassassin' );
+    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)");
+        $self->log(LOGINFO, "pass, cannot agree, SA results missing ($status)");
         return DECLINED;
-    };
+    }
 
-    if ( $d->{class} eq 'Spam' && $sa->{is_spam} eq 'Yes' ) {
+    if ($d->{class} eq 'Spam') {
-        $self->log(LOGINFO, "fail: agree, $status");
+        if ($sa->{is_spam} eq 'Yes') {
-        return Qpsmtpd::DSN->media_unsupported(DENY,'we agree, no spam please');
+            $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, "pass: agree, $status");
+        $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);
+            }
+            $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, $transaction ) = @_;
+    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 get_filter_cmd {
+sub attach_headers {
-    my ($self, $transaction, $user) = @_;
+    my ($self, $r, $transaction) = @_;
+    $transaction ||= $self->qp->transaction;
 
+    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);
+    $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', $r->{signature}, 0);
+}
+
+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 $default = "$dspam_bin --user $user --mode=tum --process --deliver=summary --stdout";
+    my $cmd =
-    my $min_score = $self->{_args}{learn_from_sa} or return $default;
+"$dspam_bin --user $user --mode=toe --source=error --class=innocent --deliver=summary --stdout";
-
+    my $response = $self->dspam_process($cmd, $transaction);
-    #$self->log(LOGDEBUG, "attempting to learn from SA");
+    if ($response) {
-
+        $transaction->notes('dspam', $response);
-    my $sa = $transaction->notes('spamassassin' );
-    return $default if ! $sa || ! $sa->{is_spam};
-
-    if ( $sa->{is_spam} eq 'Yes' && $sa->{score} < $min_score ) {
-        $self->log(LOGNOTICE, "SA score $sa->{score} < $min_score, skip autolearn");
-        return $default;
-    };
-
-    return $default if ! $sa->{autolearn};
-
-    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' ) {
+    else {
-        return "$dspam_bin --user $user --mode=tum --source=corpus --class=innocent --deliver=summary --stdout";
+        $transaction->notes(
-    };
+                            'dspam',
+                            {
+                             class      => 'Innocent',
+                             result     => 'Innocent',
+                             confidence => 1
+                            }
+                           );
+    }
+}
 
-    return $default;
+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=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
+                            }
+                           );
+    }
+}
 
+sub autolearn {
+    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!");
+        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;
+}
+
+sub autolearn_naughty {
+    my ($self, $response, $transaction) = @_;
+
+    my $learn = $self->{_args}{autolearn} or return;
+
+    if ($learn ne 'naughty' && $learn ne 'any') {
+        $self->log(LOGDEBUG, "skipping naughty autolearn");
+        return;
+    }
+
+    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;
+    }
+
+    $self->log(LOGDEBUG, "falling through naughty autolearn");
+    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 < -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 > 2 && $response->{result} eq 'Spam') {
+        $self->log(LOGINFO, "training good karma ($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}) {
+        if (!$self->is_naughty()) {
+            $self->log(LOGERROR, "SA results missing");    # SA skips naughty
+        }
+        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 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 SA FP as ham");
+        $self->train_error_as_ham($transaction);
+        return 1;
+    }
+
+    return;
+}

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<reject 1>
 
@@ -48,7 +48,7 @@ issued a deny or denysoft (depending on the value of I<reject_type>). 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 ]
 
@@ -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)}++;
     }
-  }
+    my %check_at;
-  if (!%check_at) {
+    for (0 .. $#args) {
-    $check_at{CONNECT} = 1;
+        next if $_ % 2;
-  }
+        if (lc($args[$_]) eq 'check-at') {
-  $self->{_args} = {
+            my $val = $args[$_ + 1];
-        'wait' => 1,
+            $check_at{uc($val)}++;
-        @args,
+        }
-        'check-at' => \%check_at,
+    }
-  };
+    if (!%check_at) {
-# backwards compat with old 'action' argument
+        $check_at{CONNECT} = 1;
-  if ( defined $self->{_args}{action} && ! defined $self->{_args}{reject} ) {
+    }
-       $self->{_args}{reject} = $self->{_args}{action} =~ /^deny/i ? 1 : 0;
+    $self->{_args} = {
-  };
+                      'wait' => 1,
-  if ( defined $self->{_args}{'defer-reject'} && ! defined $self->{_args}{reject_type} ) {
+                      @args,
-       $self->{_args}{reject_type} = $self->{_args}{action} == 'denysoft' ? 'temp' : 'perm';
+                      'check-at' => \%check_at,
-  };
+                     };
-  if ( ! defined $self->{_args}{reject_type} ) {
+
-       $self->{_args}{reject_type} = 'perm';
+    # backwards compat with old 'action' argument
-  };
+    if (defined $self->{_args}{action} && !defined $self->{_args}{reject}) {
-# /end compat
+        $self->{_args}{reject} = $self->{_args}{action} =~ /^deny/i ? 1 : 0;
-  if ( $qp->{conn} && $qp->{conn}->isa('Apache2::Connection')) {
+    }
-      require APR::Const;
+    if (defined $self->{_args}{'defer-reject'}
-      APR::Const->import(qw(POLLIN SUCCESS));
+        && !defined $self->{_args}{reject_type})
-      $self->register_hook('connect', 'apr_connect_handler');
+    {
-      $self->register_hook('data', 'apr_data_handler');
+        $self->{_args}{reject_type} =
-  }
+          $self->{_args}{action} == 'denysoft' ? 'temp' : 'perm';
-  else {
+    }
-      $self->register_hook('connect', 'connect_handler');
+    if (!defined $self->{_args}{reject_type}) {
-      $self->register_hook('data', 'data_handler');
+        $self->{_args}{reject_type} = 'perm';
-  }
+    }
-  $self->register_hook('mail', 'mail_handler')
+
-    if $self->{_args}{'defer-reject'};
+    # /end compat
-  $self->{_args}{reject} = 1 if ! defined $self->{_args}{reject};
+    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,18 +129,18 @@ 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;
 
     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();
-    };
+    }
     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();
 }
 
@@ -163,16 +168,24 @@ 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');
+    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->qp->connection->notes('earlytalker', 1);
+    $self->connection->notes('earlytalker', 1);
+    $self->adjust_karma(-1);
     return DECLINED;
 }
 
@@ -184,17 +197,17 @@ 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;
     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;
 }
 
@@ -202,27 +215,20 @@ 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->connection->notes('earlytalker', 1);
-    $self->log(LOGNOTICE, "fail: $ip started talking before we said hello");
+    $self->adjust_karma(-1);
 
-    return ( $self->get_reject_type(), $msg ) if $self->{_args}{reject};
+    my $log_mess = "remote started talking before we said hello";
-    return DECLINED;
+    my $smtp_msg = 'Connecting host started transmitting before SMTP greeting';
+
+    return $self->get_reject($smtp_msg, $log_mess);
 }
 
 sub mail_handler {
-  my ($self, $transaction) = @_;
+    my ($self, $transaction) = @_;
 
-  return DECLINED unless $self->qp->connection->notes('earlytalker');
+    return DECLINED unless $self->connection->notes('earlytalker');
-  return $self->log_and_deny();
+    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;
-};

plugins/fcrdns

@@ -0,0 +1,308 @@
+#!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 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.
+
+=head1 AUTHOR
+
+2013 - Matt Simerson
+
+=cut
+
+use strict;
+use warnings;
+
+use Qpsmtpd::Constants;
+
+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() or return;
+
+    $self->register_hook('connect',   'connect_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 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, 'PTR') or do {
+        if ($res->errorstring eq 'NXDOMAIN') {
+            $self->adjust_karma(-1);
+            $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->store_auth_results("iprev=temperror");
+        }
+        elsif ( $res->errorstring eq 'NOERROR' ) {
+            $self->log(LOGINFO, "fail, no PTR (NOERROR)" );
+            $self->store_auth_results("iprev=permerror");
+        }
+        else {
+            $self->store_auth_results("iprev=fail");
+            $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");
+        $self->store_auth_results("iprev=permerror");
+        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->query($host) or do {
+            if ($res->errorstring eq 'NXDOMAIN') {
+                $self->store_auth_results("iprev=permerror");
+                $self->log(LOGDEBUG, "host $host does not exist");
+                next;
+            }
+            $self->store_auth_results("iprev=fail");
+            $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->store_auth_results("iprev=fail");
+            $self->log(LOGDEBUG, "PTR host has forward DNS") if $hits;
+            return 1;
+        }
+    }
+    $self->adjust_karma(-1);
+    $self->store_auth_results("iprev=fail");
+    $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->store_auth_results("iprev=pass");
+        $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->store_auth_results("iprev=pass");
+        return 1;
+    }
+    return;
+}
+

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
 
@@ -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 $DENYMSG        = "This mail is temporarily denied";
-my ($QPHOME) = ($0 =~ m!(.*?)/([^/]+)$!);
+my ($QPHOME)       = ($0 =~ m!(.*?)/([^/]+)$!);
-my $DB       = "greylist.dbm";
+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,
+                remote_ip     => 1,
-    sender    => 0,
+                sender        => 0,
-    recipient => 0,
+                recipient     => 0,
-    reject    => 1,
+                reject        => 1,
-    black_timeout => 50 * 60,             # 50m
+                black_timeout => 50 * 60,               # 50m
-    grey_timeout  =>  3 * 3600 + 20 * 60, # 3h:20m
+                grey_timeout  => 3 * 3600 + 20 * 60,    # 3h:20m
-    white_timeout => 36 * 3600 * 24,      # 36 days
+                white_timeout => 36 * 3600 * 24,        # 36 days
-    nfslock => 0,
+                nfslock       => 0,
-    p0f  => undef,
+                p0f           => undef,
-);
+               );
 
 sub register {
     my ($self, $qp, %arg) = @_;
-    my $config = { %DEFAULTS,
+    my $config = {
-        map { split /\s+/, $_, 2 } $self->qp->config('denysoft_greylist'),
+              %DEFAULTS,
-        %arg };
+              map { split /\s+/, $_, 2 } $self->qp->config('denysoft_greylist'),
-    if (my @bad = grep { ! exists $PERMITTED_ARGS{$_} } sort keys %$config) {
+              %arg
-        $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;
     };
+    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,177 +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) = @_;
+    my ($self, $transaction, $rcpt) = @_;
-  # Load per_recipient configs
+
-  my $config = { %{$self->{_args}},
+    # Load per_recipient configs
-    map { split /\s+/, $_, 2 } $self->qp->config('denysoft_greylist', { rcpt => $rcpt }) };
+    my $config = {
-  # Check greylisting
+                  %{$self->{_args}},
-  my $sender = $transaction->sender;
+                  map { split /\s+/, $_, 2 }
-  my ($status, $msg) = $self->greylist($transaction, $sender, $rcpt, $config);
+                    $self->qp->config('denysoft_greylist', {rcpt => $rcpt})
-  if ($status == DENYSOFT) {
+                 };
-    # Deny here (per-rcpt) unless this is a <> sender, for smtp probes
+
-    return DENYSOFT, $msg if $sender->address;
+    # Check greylisting
-    $transaction->notes('greylist', $msg);
+    my $sender = $transaction->sender;
-  }
+    my ($status, $msg) = $self->greylist($transaction, $sender, $rcpt, $config);
-  return DECLINED;
+    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) = @_;
+    my ($self, $transaction) = @_;
-  return DECLINED unless $transaction->notes('greylist');
+    return DECLINED unless $transaction->notes('greylist');
-  # Decline if ALL recipients are whitelisted
+
-  if (($transaction->notes('whitelistrcpt')||0) == scalar($transaction->recipients)) {
+    # Decline if ALL recipients are whitelisted
-    $self->log(LOGWARN,"skip: all recipients whitelisted");
+    if (($transaction->notes('whitelistrcpt') || 0) ==
-    return DECLINED;
+        scalar($transaction->recipients))
-  }
+    {
-  return DENYSOFT, $transaction->notes('greylist');
+        $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: " .
+    $self->log(LOGDEBUG,
-        join(',',map { $_ . '=' . $config->{$_} } sort keys %$config));
+               "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 $lock = $self->get_db_lock($db) or return DECLINED;
-    my $tied = $self->get_db_tie( $db, $lock ) 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 $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
+    # new IP or entry timed out - record new
-    if ( ! $tied->{$key} ) {
+    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 ) {
+    if ($white) {
-# white IP - accept unless timed out
+
+        # 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 is_immune {
-    my $self = shift;
-
-    # Always allow relayclients and whitelisted hosts/senders
-    if ( $self->qp->connection->relay_client() ) {
-        $self->log(LOGINFO, "skip: relay client");
-        return 1;
-    };
-    if ( $self->connection->notes('whitelisthost') ) {
-        $self->log(LOGINFO, "skip: whitelisted host");
-        return 1;
-    };
-    if ( $self->qp->transaction->notes('whitelistsender') ) {
-        $self->log(LOGINFO, "skip: whitelisted sender");
-        return 1;
-    };
-    if ( $self->qp->transaction->notes('tls_enabled') ) {
-        $self->log(LOGINFO, "skip: tls");
-        return 1;
-    };
-
-    if ( $self->{_args}{p0f} && ! $self->p0f_match() ) {
-        return 1;
-    };
-
-    if ( $self->{_args}{geoip} && $self->geoip_match() ) {
-        $self->log(LOGDEBUG, "skip: geoip");
-        return 1;
-    };
-
-    return;
-};
-
 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 if defined $self->{_args}{reject} && ! $self->{_args}{reject};
+    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} ) {
+    if ($self->{_args}{remote_ip}) {
-        my $nip = Net::IP->new( $self->qp->connection->remote_ip );
+        my $nip = Net::IP->new($self->qp->connection->remote_ip);
-        push @key, $nip->intip;             # convert IP to integer
+        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};
+    push @key, $rcpt->address if $rcpt && $self->{_args}{recipient};
-    if ( ! scalar @key ) {
+    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;
@@ -404,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},
+    my @candidate_dirs = (
-        "/var/lib/qpsmtpd/greylisting", "$QPHOME/var/db", "$QPHOME/config", '.' );
+                          $dbdir, $config->{db_dir},
+                          "/var/lib/qpsmtpd/greylisting",
+                          "$QPHOME/var/db", "$QPHOME/config", '.'
+                         );
 
-    for my $d ( @candidate_dirs ) {
+    for my $d (@candidate_dirs) {
-        next if ! $d || ! -d $d;   # impossible
+        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" ) {
+    if (!-f $db && -f "$dbdir/denysoft_greylist.dbm") {
-        $db = "$dbdir/denysoft_greylist.dbm";  # old DB name
+        $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) = @_;
@@ -430,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;
@@ -451,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",
+                             file               => "$db.lock",
-        lock_type => LOCK_EX|LOCK_NB,
+                             lock_type          => LOCK_EX | LOCK_NB,
-        blocking_timeout   => 10,      # 10 sec
+                             blocking_timeout   => 10,                  # 10 sec
-        stale_lock_timeout => 30 * 60, # 30 min
+                             stale_lock_timeout => 30 * 60,             # 30 min
-    } or do {
+                                    }
+      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 $db    = $self->get_db_location();
-    my $lock = $self->get_db_lock( $db ) 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 $tied  = $self->get_db_tie($db, $lock) or return DECLINED;
     my $count = keys %$tied;
 
     my $converted = 0;
-    foreach my $key ( keys %$tied ) {
+    foreach my $key (keys %$tied) {
-        my ( @parts ) = split /:/, $key;
+        my (@parts) = split /:/, $key;
-        next if $parts[0] =~ /^[\d]+$/;      # already converted
+        next if $parts[0] =~ /^[\d]+$/;    # already converted
         $converted++;
-        my $nip = Net::IP->new( $parts[0] );
+        my $nip = Net::IP->new($parts[0]);
-        $parts[0] = $nip->intip;             # convert IP to integer
+        $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" );
+    $self->log(LOGINFO, "converted $converted of $count DB entries");
-    return $self->cleanup_and_return( $tied, $lock, DECLINED );
+    return $self->cleanup_and_return($tied, $lock, DECLINED);
-};
+}
 
 sub prune_db {
     my $self = shift;
 
-    my $db   = $self->get_db_location();
+    my $db    = $self->get_db_location();
-    my $lock = $self->get_db_lock( $db ) 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 $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" );
+    $self->log(LOGINFO, "pruned $pruned of $count DB entries");
-    return $self->cleanup_and_return( $tied, $lock, DECLINED );
+    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;
+        next if !$key;
-        if ( ! defined $valid_matches{$key} ) {
+        if (!defined $valid_matches{$key}) {
-            $self->log(LOGERROR, "discarding invalid match key ($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 $value;          # bad config setting?
-        next if ! defined $p0f->{$key}; # p0f didn't detect the value
+        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;
@@ -563,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;

plugins/headers

@@ -0,0 +1,220 @@
+#!perl -w
+
+=head1 NAME
+
+headers - validate message 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<future> or I<past> are not defined, they are not tested.
+
+If the remote IP is whitelisted, header validation is skipped.
+
+=head1 CONFIGURATION
+
+The following optional settings exist:
+
+=head2 require
+
+ headers require [ From | Date | From,Date | From,Date,Subject,Message-ID,Received ]
+
+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<future> and/or I<past> 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<past> setting should take those factors into consideration.
+
+I would be surprised if a valid message ever had a date header older than a week.
+
+  headers [ past 5 ]
+
+=head2 reject
+
+Determine if the connection is denied. Use the I<reject 0> option when first enabling the plugin, and then watch your logs to see what would have been rejected. When you are no longer concerned that valid messages will be rejected, enable with I<reject 1>.
+
+  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<reject 0> can be set to permit the deferred message to be delivered.
+
+Default: perm
+
+=head2 loglevel
+
+Adjust the quantity of logging for this plugin. See docs/logging.pod
+
+=head1 TODO
+
+=head1 SEE ALSO
+
+https://tools.ietf.org/html/rfc5322
+
+=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 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);
+
+    $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("Headers are missing", "missing headers");
+    };
+
+    return DECLINED if $self->is_immune();
+
+    my $errors  = $self->has_required_headers( $header ) || 0;
+       $errors += $self->has_singular_headers( $header );
+
+    my $err_msg = $self->invalid_date_range();
+    if ($err_msg) {
+        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 = 0;
+    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 = 0;
+    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;
+
+    return if !$self->transaction->header;
+    my $date = shift || $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)");
+        $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";
+    }
+
+    return;
+}
+

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<soley>
+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
@@ -106,25 +109,25 @@ Default: lenient
 
 =head3 lenient
 
-Reject failures of the following tests: is_in_badhelo, invalid_localhost, and
+Runs the following tests: is_in_badhelo, invalid_localhost,
-is_forged_literal.
+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<policy rfc> is selected, all the lenient checks and
-the following are enforced: is_plain_ip, is_not_fqdn, no_forward_dns, and
+the following are tested: is_not_fqdn, no_forward_dns, and no_reverse_dns.
-no_reverse_dns.
 
 If you have Windows users that send mail via your server, do not choose
-I<policy rfc> without I<reject naughty> and the B<naughty> plugin. Windows
+I<policy rfc> without setting I<reject> to 0 or naughty.
-users often send unqualified HELO names and will have trouble sending mail.
+Windows PCs often send unqualified HELO names and will have trouble
-<Naughty> can defer the rejection, and if the user subsequently authenticates,
+sending mail. The B<naughty> plugin defers the rejection, giving the user
-the rejection will be cancelled.
+the opportunity to authenticate and bypass the rejection.
 
 =head3 strict
 
@@ -135,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<policy strict> be used with <reject 0> and that you
-monitor your logs for false positives before enabling rejection.
+examine your logs for false positives.
 
 =head2 badhelo
 
@@ -187,6 +190,26 @@ 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 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
 
 2012 - Matt Simerson
@@ -206,41 +229,42 @@ use warnings;
 
 use Qpsmtpd::Constants;
 
-use Net::DNS;
-
 sub register {
-    my ($self, $qp) = shift, shift;
+    my ($self, $qp) = (shift, shift);
-    $self->{_args} = { @_ };
+    $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} ) {
+    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('helo',      'helo_handler');
-    $self->register_hook('ehlo', '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");
+        $self->log(LOGINFO, "fail, tolerated, no helo host");
         return DECLINED;
-    };
+    }
 
     return DECLINED if $self->is_immune();
 
-    foreach my $test ( @{ $self->{_helo_tests} } ) {
+    foreach my $test (@{$self->{_helo_tests}}) {
-        my @err = $self->$test( $host );
+        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");
     return DECLINED;
@@ -250,239 +274,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 /;
+    @{$self->{_helo_tests}} =
+      qw/ is_in_badhelo invalid_localhost is_forged_literal is_plain_ip /;
 
-    if ( $policy eq 'rfc' || $policy eq 'strict' ) {
+    if ($policy eq 'rfc' || $policy eq 'strict') {
-        push @{ $self->{_helo_tests} }, qw/ is_plain_ip is_not_fqdn no_forward_dns
+        push @{$self->{_helo_tests}},
-                                       no_reverse_dns /;
+          qw/ is_not_fqdn no_forward_dns no_reverse_dns /;
-    };
+    }
 
-    if ( $policy eq 'strict' ) {
+    if ($policy eq 'strict') {
-        push @{ $self->{_helo_tests} }, qw/ is_address_literal no_matching_dns /;
+        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 ($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
+        if ($bad =~ /[\{\}\[\]\(\)\^\$\|\*\+\?\\\!]/) {    # it's a regexp
-            return $self->is_regex_match( $host, $bad );
+            return $self->is_regex_match($host, $bad);
-        };
+        }
-        if ( $host eq lc $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 ) = @_;
+    my ($self, $host) = @_;
-    return if $host =~ /[^\d\.]+/;  # has chars other than digits and a dot
+    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" );
+    $self->log(LOGDEBUG, "fail, bracketed IP");
-    return ("RFC 2821 allows an address literal, but we do not", "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?)
     $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
+    return if $host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/;   # address literal, skip
-    if ( $host !~ /\./ ) { # has no dots
+    if ($host !~ /\./) {                                 # has no dots
         return ("HELO name is not fully qualified. Read RFC 2821", "not FQDN");
-    };
+    }
-    if ( $host =~ /[^a-zA-Z0-9\-\.]/ ) {
+    if ($host =~ /[^a-zA-Z0-9\-\.]/) {
-        return ("HELO name contains invalid FQDN characters. Read RFC 1035", "invalid FQDN chars");
+        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);
 
     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 (!$query) {
-        if ( $res->errorstring eq 'NXDOMAIN' ) {
+        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, ")" );
+        $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", "fail, HELO forward DNS");
+    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 {
+    my $query = $res->query($ip) or do {
-        if ( $res->errorstring eq 'NXDOMAIN' ) {
+        if ($res->errorstring eq 'NXDOMAIN') {
             return ("no rDNS for $ip", "no rDNS");
-        };
+        }
-        $self->log( LOGINFO, $res->errorstring );
+        $self->log(LOGINFO, $res->errorstring);
-        return ("error getting reverse DNS for $ip", "rDNS " . $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->log(LOGDEBUG, "PTR: " . $rr->ptrdname);
-        $self->check_name_match( lc $rr->ptrdname, lc $host );
+        $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) = @_;
 
-    if ( $self->connection->notes('helo_forward_match') &&
+    # this is called iprev, or "Forward-confirmed reverse DNS" and is discussed
-         $self->connection->notes('helo_reverse_match') ) {
+    # in RFC 5451. FCrDNS is done for the remote IP in the fcrdns plugin. Here
-        $self->log( LOGDEBUG, "foward and reverse match" );
+    # we do it on the HELO hostname.
-# TODO: consider adding some karma here
+    # consider adding status to Authentication-Results header
-        return;
-    };
 
-    if ( $self->connection->notes('helo_forward_match') ) {
+    if (   $self->connection->notes('helo_forward_match')
-        $self->log( LOGDEBUG, "name matches IP" );
+        && $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')) {
-    return ("That HELO hostname fails forward and reverse DNS checks", "no matching DNS");
+        $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 ) {
+    if ($ip eq $self->qp->connection->remote_ip) {
-        $self->log( LOGDEBUG, "forward ip match" );
+        $self->log(LOGDEBUG, "forward ip match");
         $self->connection->notes('helo_forward_match', 1);
         return;
-    };
+    }
 
-    my $dns_net = join('.', (split('\.', $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] );
+    my $rem_net =
+      join('.', (split(/\./, $self->qp->connection->remote_ip))[0, 1, 2]);
 
-    if ( $dns_net eq $rem_net ) {
+    if ($dns_net eq $rem_net) {
-        $self->log( LOGNOTICE, "forward network match" );
+        $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 ) {
+    return if !$dns_name;
-        $self->log( LOGDEBUG, "reverse name match" );
+    return if split(/\./, $dns_name) < 2;    # not a FQDN
+
+    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 $dns_dom  = join('.', (split(/\./, $dns_name))[-2,  -1]);
-    my $helo_dom = join('.', (split('\.', $helo_name))[-2,-1] );
+    my $helo_dom = join('.', (split(/\./, $helo_name))[-2, -1]);
 
-    if ( $dns_dom eq $helo_dom ) {
+    if ($dns_dom eq $helo_dom) {
-        $self->log( LOGNOTICE, "reverse domain match" );
+        $self->log(LOGNOTICE, "reverse domain match");
         $self->connection->notes('helo_reverse_match', 1);
-    };
+    }
-};
+}
 

plugins/help

@@ -42,15 +42,15 @@ The hard coded F<help/> 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
+        /^(\w+)$/
-            $self->log(LOGWARN, "Invalid argument for the 'help' plugin $_"), 
+          or $self->log(LOGWARN, "Invalid argument for the 'help' plugin $_"),
-            next;
+          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 
+    unless ($cmd =~ /^(\w+)$/) {    # else someone could request
-                                 # "HELP ../../../../../../../../etc/passwd"
+                                    # "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: $!"),
+          or $self->log(LOGERROR, "failed to open help file for $cmd: $!"),
-               return OK, "No help available for SMTP command: $cmd";
+          return OK, "No help available for SMTP command: $cmd";
     }
-    elsif (exists $config{'help_dir'} && -e $config{'help_dir'}."/$cmd") {
+    elsif (exists $config{'help_dir'} && -e $config{'help_dir'} . "/$cmd") {
-        $help = read_helpfile($config{help_dir}."/$cmd", $cmd)
+        $help = read_helpfile($config{help_dir} . "/$cmd", $cmd)
-            or $self->log(LOGERROR, "failed to open help file for $cmd: $!"),
+          or $self->log(LOGERROR, "failed to open help file for $cmd: $!"),
-               return OK, "No help available for SMTP command: $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 = <HELP>;
     };

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,
@@ -68,38 +68,64 @@ sub hook_pre_connection {
 
     my $remote = $args{remote_ip};
     my $max    = $args{max_conn_ip};
+    my $karma  = $self->connection->notes('karma_history');
 
-    if ( $max ) {
+    if ($max) {
-        my $num_conn = 1; # seed with current value
+        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 ) {
+        $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, "Sorry, $err_mess, try again later");
+            return (DENYSOFT, "$err_mess, try again later");
         }
     }
 
-    foreach ($self->qp->config("hosts_allow")) {
+    my @r = $self->in_hosts_allow($remote);
-        s/^\s*//;
+    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;
+        my ($net, $mask) = split /\//, $ipmask, 2;
         $mask = 32 if !defined $mask;
-        $mask = pack "B32", "1"x($mask)."0"x(32-$mask);
+        $mask = pack "B32", "1" x ($mask) . "0" x (32 - $mask);
-        if (join(".", unpack("C4", inet_aton($remote) & $mask)) eq $net) {
+        if (join('.', unpack('C4', inet_aton($remote) & $mask)) eq $net) {
             $const = Qpsmtpd::Constants::return_code($const) || DECLINED;
-            if ( $const =~ /deny/i ) {
+            if ($const =~ /deny/i) {
-                $self->log( LOGINFO, "fail: $message" );
+                $self->log(LOGINFO, "fail, $message");
-            };
+            }
-            $self->log( LOGDEBUG, "pass: $const, $message" );
+            $self->log(LOGDEBUG, "pass, $const, $message");
-            return($const, $message);
+            return ($const, $message);
         }
     }
 
-    $self->log( LOGDEBUG, "pass" );
+    return;
-    return (DECLINED);
+}
+
+sub karma_bump {
+    my ($self, $karma, $max) = @_;
+
+    if ($karma > 5) {
+        $self->log(LOGDEBUG, "connect limit +3 for positive karma");
+        return $max + 3;
+    }
+    if ($karma <= 0) {
+        $self->log(LOGINFO, "connect limit 1, karma $karma");
+        return 1;
+    }
+    return $max;
 }

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) = @_;
+    my ($self, $qp, @args) = @_;
-  @urls = @args;
+    @urls = @args;
 }
 
 sub hook_config {
-  my ($self, $transaction, $config) = @_; 
+    my ($self, $transaction, $config) = @_;
-  $self->log(LOGNOTICE, "http_config called with $config");
+    $self->log(LOGNOTICE, "http_config called with $config");
-  for my $url (@urls) {
+    for my $url (@urls) {
-    $self->log(LOGDEBUG, "http_config loading from $url");
+        $self->log(LOGDEBUG, "http_config loading from $url");
-    my @config = split /[\r\n]+/, (get "$url$config" || "");
+        my @config = split /[\r\n]+/, (get "$url$config" || "");
-    chomp @config;
+        chomp @config;
-    @config = grep { $_ and $_ !~ m/^\s*#/ and $_ =~ m/\S/ } @config;
+        @config = grep { $_ and $_ !~ m/^\s*#/ and $_ =~ m/\S/ } @config;
-    close CF;
+        close CF;
-    # $self->log(LOGNOTICE, "returning http_config for $config ",Data::Dumper->Dump([\@config], [qw(config)]));
+
-    return (OK, @config) if @config;
+# $self->log(LOGNOTICE, "returning http_config for $config ",Data::Dumper->Dump([\@config], [qw(config)]));
-  }
+        return (OK, @config) if @config;
-  return DECLINED;
+    }
+    return DECLINED;
 }

plugins/ident/geoip

@@ -1,17 +1,109 @@
 #!perl -w
 
+=head1 NAME
+
+geoip - provide geographic information about mail senders.
+
 =head1 SYNOPSIS
 
-This plugin uses MaxMind's GeoIP service and the Geo::IP perl module to
+Use MaxMind's GeoIP databases and the Geo::IP perl module to report geographic
-do a lookup on incoming connections and record the country of origin.
+information about incoming connections.
 
-Thats all it does.
+=head1 DESCRIPTION
 
-It logs the 2 char country code to connection note I<geoip_country>.
+This plugin saves geographic information in the following connection notes:
-It logs the country name to the connection note I<geoip_country_name>.
 
-Other plugins can use that info to do things to the connection, like
+  geoip_country      - 2 char country code
-reject or greylist.
+  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: NA, US, United States,     1319 km
+  (connect) ident::geoip: AS, IN, India,            13862 km
+  (connect) ident::geoip: fail: no results
+  (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:
+
+  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 <IP Address>
+
+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 too_far <distance in km>
+
+Assign negative karma to connections further than this many km.
+
+Default: none
+
+=head2 db_dir </path/to/GeoIP>
+
+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
 
@@ -19,41 +111,232 @@ use strict;
 use warnings;
 
 use Qpsmtpd::Constants;
-#use Geo::IP;  # eval'ed in register()
+
+#use Geo::IP;     # eval'ed in register()
+#use Math::Trig;  # eval'ed in set_distance_gc
 
 sub register {
-    my $self = shift;
+    my ($self, $qp) = shift, shift;
-    eval 'use Geo::IP';
-    if ( $@ ) {
-        warn "could not load Geo::IP";
-        $self->log( LOGERROR, "could not load Geo::IP" );
-        return;
-    };
 
-    $self->register_hook( 'connect', 'connect_handler' );
+    $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;
 
-    my $geoip = Geo::IP->new();
+    # reopen the DB if Geo::IP failed due to DB update
-    my $remote_ip = $self->qp->connection->remote_ip;
+    $self->open_geoip_db();
 
-    my $c_code = $geoip->country_code_by_addr( $remote_ip ) or do {
+    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);
 
-    my $c_name = $geoip->country_name_by_addr( $remote_ip );
+    my $c_name = $self->set_country_name();
-    if ( $c_name ) {
+    my ($city, $continent_code, $distance) = '';
-        $self->connection->notes('geoip_country_name', $c_name);
-    };
 
-    $self->connection->notes('geoip_country', $c_code);
+    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;
+    my @msg_parts;
-       $message .= ", $c_name" if $c_name;
+    push @msg_parts, $continent_code
-    $self->log(LOGINFO, $message);
+      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, "\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;
 }
+
+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_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};
+
+    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);
+}
+

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
 
@@ -132,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;
@@ -141,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{$_};
@@ -149,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->test_v3_response($response) or return DECLINED;
-        $self->store_v3_results( $response );
+        $self->store_v3_results($response);
     }
     else {
         my $response = $self->query_p0f_v2() or return DECLINED;
-        $self->test_v2_response( $response ) or return DECLINED;
+        $self->test_v2_response($response) or return DECLINED;
-        $self->store_v2_results( $response );
+        $self->store_v2_results($response);
     }
 
     return DECLINED;
@@ -171,80 +179,84 @@ 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)
+    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",
+    return
-                   $QUERY_MAGIC_V2,
+      pack("L L L N N S S",
-                   1,
+           $QUERY_MAGIC_V2,
-                   rand ^ 42 ^ time,
+           1,
-                   $src->intip(),
+           rand ^ 42 ^ time,
-                   $dst->intip(),
+           $src->intip(),
-                   $self->qp->connection->remote_port,
+           $dst->intip(),
-                   $self->qp->connection->local_port);
+           $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");
+        $self->log(LOGERROR, "skip, unable to determine remote IP");
         return;
     };
 
-    if ( $src_ip =~ /:/ ) {   # IPv6
+    if ($src_ip =~ /:/) {    # IPv6
-        my @bits = split(/\:/, $src_ip );
+        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 );
+        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;
 
     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;
 
-# 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, "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, "skip, socket not connected: $!");
         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: $!");
+        $self->log(LOGERROR, "skip, send failed: $!");
-            return;
+        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, "p0f: send $sent byte request");
+    $self->log(LOGDEBUG, "sent $sent byte request");
 
     my $response;
-    $sock->recv( $response, 232 );
+    $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;
-};
+}
 
 sub query_p0f_v2 {
     my $self = shift;
@@ -254,114 +266,121 @@ 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: $! ($p0f_socket)"), 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;
-};
+}
 
 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) {
-        $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, connection not in the cache");
         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, "p0f: Bad response magic.");
+        $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, "p0f: bad query");
+        $self->log(LOGERROR, "skip, bad query");
         return;
     }
-    elsif ($status == $P0F_STATUS_NOMATCH ) {
+    elsif ($status == $P0F_STATUS_NOMATCH) {
-        $self->log(LOGINFO, "p0f: no match");
+        $self->log(LOGINFO, "skip, no match");
         return;
     }
-    if ($status == $P0F_STATUS_OK ) {
+    if ($status == $P0F_STATUS_OK) {
-        $self->log(LOGDEBUG, "p0f: query 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,
+    my (
-        $nat, $real, $score, $mflags, $uptime) =
+        $magic, $id, $type, $genre, $detail, $dist,   $link,
-            unpack ("L L C Z20 Z40 c Z30 Z30 C C C s S N", $response);
+        $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,
+               genre    => $genre,
-        detail   => $detail,
+               detail   => $detail,
-        distance => $dist,
+               distance => $dist,
-        link     => $link,
+               link     => $link,
-        uptime   => $uptime,
+               uptime   => $uptime,
-    };
+              };
 
     $self->connection->notes('p0f', $p0f);
-    $self->log(LOGINFO, $genre." (".$detail.")");
+    $self->log(LOGINFO, $genre . " (" . $detail . ")");
-    $self->log(LOGERROR,"error: $@") if $@;
+    $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
+      up_mod_days last_nat last_chg distance bad_sw os_match_q os_name os_flavor
-        http_name http_flavor link_type language /;
+      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 @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 ) ) {
+    foreach my $i (0 .. (scalar @labels - 1)) {
-        next if ! defined $values[$i];
+        next if !defined $values[$i];
-        next if ! defined $values[$i];
+        next if !defined $values[$i];
-        $r{ $labels[$i] } = $values[$i];
+        $r{$labels[$i]} = $values[$i];
-    };
+    }
-    if ( $r{os_name} ) {                             # compat with p0f v2
+    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}) {
+        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(LOGINFO,  "$r{os_name} $r{os_flavor}");
-    $self->log(LOGDEBUG, join(' ', @values ));
+    $self->log(LOGDEBUG, join(' ', @values));
-    $self->log(LOGERROR,"error: $@") if $@;
+    $self->log(LOGERROR, "error: $@") if $@;
     return \%r;
-};
+}
 

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,38 +14,37 @@ 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<penalty_days>. Connections
-from senders in the penalty box are tersely disconnected.
+from senders in the penalty box are rejected per the settings in I<reject>.
 
 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 behaved sender. Please help yourself to TLS, AUTH, greater
+Hi there, well known and well behaved sender. Please help yourself to greater concurrency (hosts_allow), multiple recipients (karma), and no delays (early_sender).
-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, max recipients of 2, and SMTP delays.
 
-=back 
+=back
 
 =head1 CONFIG
 
 =head2 negative <integer>
 
 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
 
 Examples:
 
- negative 1:  0 nice - 1 naughty = karma -1, penalize
+   negative 1:  0 nice - 1 naughty = karma -1, penalize
- negative 1:  1 nice - 1 naughty = karma  0, okay
+   negative 1:  1 nice - 1 naughty = karma  0, okay
- negative 2:  1 nice - 2 naughty = karma -1, okay
+   negative 2:  1 nice - 2 naughty = karma -1, okay
- negative 2:  1 nice - 3 naughty = karma -2, penalize
+   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
@@ -62,16 +61,16 @@ Default: 1
 
 =head2 reject
 
-  karma reject [ 0 | 1 | connect | zombie ]
+  karma reject [ 0 | 1 | connect | naughty ]
 
 I<0> will not reject any connections.
 
 I<1> will reject naughty senders.
 
-I<connect> is the most efficient setting. 
+I<connect> is the most efficient setting.
 
-To reject at any other connection hook, use the I<zombie> setting and the
+To reject at any other connection hook, use the I<naughty> setting and the
-B<reaper> plugin.
+B<naughty> plugin.
 
 =head2 db_dir <path>
 
@@ -95,33 +94,25 @@ Adjust the quantity of logging for this plugin. See docs/logging.pod
 
 =head1 BENEFITS
 
-Karma reduces the resources wasted by naughty mailers. 
+Karma reduces the resources wasted by naughty mailers.  When used with
-When used with the 
+I<reject connect>, naughty senders are disconnected in about 0.1 seconds.
-I<reject connect> setting, 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<karma> transaction note (see KARMA) when they encounter
+virus filters) set the B<karma> 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.
 
 This plugin does not penalize connections with transaction notes I<relayclient>
-or I<whitelisthost> set. These notes would have been set by the B<relay>, 
+or I<whitelisthost> set. These notes would have been set by the B<relay>,
 B<whitelist>, and B<dns_whitelist_soft> plugins. Obviously, those plugins must
 run before B<karma> for that to work.
 
 =head1 KARMA
 
-No attempt is made by this plugin to determine what karma is. It is up to
+No attempt is made by this plugin to determine karma. It is up to other
-other plugins to make that determination and communicate it to this plugin by
+plugins to reward well behaved senders with positive karma and smite poorly
-incrementing or decrementing the transaction note B<karma>. Raise it for good
+behaved senders with negative karma. See B<USING KARMA IN OTHER PLUGINS>
-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<karma> will record the result. Mail servers whose
 naughty connections exceed nice ones are sent to the penalty box. Servers in
@@ -134,16 +125,27 @@ 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.
 
-If we only sets negative karma, we will almost certainly penalize servers we
+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<penalty_days>. 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
+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 offense 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
@@ -161,20 +163,20 @@ ident plugins.
  88798 cleaning up after 89011
 
 Unlike RBLs, B<karma> 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
 
 This plugin sets the connection note I<karma_history>. Your plugin can
 use the senders karma to be more gracious or rude to senders. The value of
-I<karma_history> is the number the nice connections minus naughty
+I<karma_history> is the number of nice connections minus naughty
 ones. The higher the number, the better you should treat the sender.
 
-When I<reject zombie> is set and a naughty sender is encountered, most
+To alter a connections karma based on its behavior, do this:
-plugins should skip processing. However, if you wish to toy with spammers by
+
-teergrubing, extending banner delays, limiting connections, limiting
+  $self->adjust_karma( -1 );  # lower karma (naughty)
-recipients, random disconnects, handoffs to rblsmtpd, and other fun tricks, 
+  $self->adjust_karma(  1 );  # raise karma (good)
-then connections with the I<zombie> note set are for you!
+
 
 =head1 EFFECTIVENESS
 
@@ -184,7 +186,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<karma> rejected 31 percent. Since
@@ -193,20 +195,19 @@ seems to be a very big win.
 
 =head1 DATABASE
 
-Connection summaries are stored in a database. The database key is the int
+Connection summaries are stored in a database. The database key is the integer
-form of the remote IP. The value is a : delimited list containing a penalty
+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_dump.pl script.
+karma_tool script.
 
 =head1 BUGS & LIMITATIONS
 
-This plugin is reactionary. Like the FBI, it doesn't punish until
+This plugin is reactionary. Like the FBI, it doesn't do anything until
-after a crime has been committed. It an "abuse me once, shame on you,
+after a crime has been committed.
-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
+blacklists, send to invalid users, earlytalkers, etc. Those already have
 very lightweight tests.
 
 =head1 AUTHOR
@@ -230,66 +231,158 @@ 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} = 'zombie';
+        $self->{_args}{reject} = 'naughty';
-    };
+    }
+
     #$self->prune_db();    # keep the DB compact
-    $self->register_hook('connect',           'connect_handler');
+    $self->register_hook('connect',       'connect_handler');
-    $self->register_hook('disconnect',        'disconnect_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');
+    $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 $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(LOGDEBUG, "pass, no record");
+        return $self->cleanup_and_return($tied, $lock);
+    }
+
+    my ($penalty_start_ts, $naughty, $nice, $connects) =
+      $self->parse_db_record($tied->{$key});
+    $self->calc_karma($naughty, $nice);
+    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 $lock = $self->get_db_lock($db) or return DECLINED;
-    my $tied = $self->get_db_tie( $db, $lock ) 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} ) {
+    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_db_record($tied->{$key});
     my $summary = "$naughty naughty, $nice nice, $connects connects";
-    my $karma = 0;
+    my $karma = $self->calc_karma($naughty, $nice);
-    if ( $naughty || $nice ) {
-        $karma = $nice || 0 - $naughty || 0;
-        $self->connection->notes('karma_history', $karma );
-    };
 
-    my $happy_return = $karma > 3 ? DONE : DECLINED;  # skip other connection tests?
+    if (!$penalty_start_ts) {
-    if ( ! $penalty_start_ts ) {
         $self->log(LOGINFO, "pass, no penalty ($summary)");
-        return $self->cleanup_and_return($tied, $lock, $happy_return );
+        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 are penalized for $left more days.";
+    my $mess = "You were naughty. You cannot connect for $left more days.";
 
-    return $self->get_reject( $mess );
+    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(LOGINFO, "info, good history");
+        return DECLINED;
+    };
+
+    my $karma = $self->connection->notes('karma');
+    if ( $karma > 0 ) {
+        $self->log(LOGINFO, "info, good connection");
+        return DECLINED;
+    };
+
+    #  limit # of recipients if host has negative or unknown karma
+    return (DENY, "too many recipients for karma $karma (h: $history)");
+}
+
+sub data_handler {
+    my ($self, $transaction) = @_;
+
+    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");
+    };
+
+    return DECLINED;
 }
 
 sub disconnect_handler {
@@ -301,91 +394,130 @@ sub disconnect_handler {
     };
 
     my $db   = $self->get_db_location();
-    my $lock = $self->get_db_lock( $db ) 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 $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 ($penalty_start_ts, $naughty, $nice, $connects) =
+      $self->parse_db_record($tied->{$key});
+    my $history = ($nice || 0) - $naughty;
+    my $log_mess = '';
 
-    if ( $karma < 0 ) {
+    if ($karma < -1) {    # they achieved at least 2 strikes
-        $naughty++;
+        $history--;
         my $negative_limit = 0 - $self->{_args}{negative};
-        my $karma_history  = ($nice || 0) - $naughty;
+        if ($history <= $negative_limit) {
-        if ( $karma_history <= $negative_limit ) {
+            if ($nice == 0 && $history < -5) {
-            $self->log(LOGINFO, "negative, sent to penalty box");
+                $log_mess = ", penalty box bonus!";
-            $penalty_start_ts = sprintf "%s", time;
+                $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 {
-            $self->log(LOGINFO, "negative");
+            $log_mess = "negative";
-        };
+        }
     }
     elsif ($karma > 1) {
         $nice++;
-        $self->log(LOGINFO, "positive");
+        $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 );
+    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;
-    if ( $value  ) {
+    if ($value) {
         ($penalty_start_ts, $naughty, $nice, $connects) = split /:/, $value;
         $penalty_start_ts ||= 0;
-        $nice    ||= 0;
+        $nice             ||= 0;
-        $naughty ||= 0;
+        $naughty          ||= 0;
-        $connects ||= 0;
+        $connects         ||= 0;
-    };
+    }
-    return ($penalty_start_ts, $naughty, $nice, $connects );
+    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);
+    $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 $nip = Net::IP->new( $self->qp->connection->remote_ip );
+    my $ip   = shift || $self->qp->connection->remote_ip;
-    return $nip->intip;   # convert IP to an int
+    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
+}
 
 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: $!");
+        $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},
+    my @candidate_dirs = (
-        "/var/lib/qpsmtpd/karma", "$QPHOME/var/db", "$QPHOME/config", '.' );
+                          $self->{args}{db_dir},
+                          "/var/lib/qpsmtpd/karma", "$QPHOME/var/db",
+                          "$QPHOME/config", '.'
+                         );
 
     my $dbdir;
-    for my $d ( @candidate_dirs ) {
+    for my $d (@candidate_dirs) {
-        next if ! $d || ! -d $d;   # impossible
+        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) = @_;
@@ -393,13 +525,13 @@ 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: $!");
+        $self->log(LOGCRIT, "error, opening lockfile failed: $!");
         return;
     };
 
-    flock( $lock, LOCK_EX ) or do {
+    flock($lock, LOCK_EX) or do {
-        $self->log(LOGCRIT, "flock of lockfile failed: $!");
+        $self->log(LOGCRIT, "error, flock of lockfile failed: $!");
         close $lock;
         return;
     };
@@ -414,42 +546,43 @@ sub get_db_lock_nfs {
 
     ### set up a lock - lasts until object looses scope
     my $nfslock = new File::NFSLock {
-        file      => "$db.lock",
+                             file               => "$db.lock",
-        lock_type => LOCK_EX|LOCK_NB,
+                             lock_type          => LOCK_EX | LOCK_NB,
-        blocking_timeout   => 10,      # 10 sec
+                             blocking_timeout   => 10,                  # 10 sec
-        stale_lock_timeout => 30 * 60, # 30 min
+                             stale_lock_timeout => 30 * 60,             # 30 min
-    } or do {
+                                    }
-        $self->log(LOGCRIT, "nfs lockfile failed: $!");
+      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, "opening nfs lockfile failed: $!");
+        $self->log(LOGCRIT, "error, opening nfs lockfile failed: $!");
         return;
     };
 
     return $lock;
-};
+}
 
 sub prune_db {
     my $self = shift;
 
-    my $db   = $self->get_db_location();
+    my $db    = $self->get_db_location();
-    my $lock = $self->get_db_lock( $db ) 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 $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 = $tied->{$key};
+        my $ts       = $tied->{$key};
-        my $days_old = ( time - $ts ) / 86400;
+        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" );
+    $self->log(LOGINFO, "pruned $pruned of $count DB entries");
-    return $self->cleanup_and_return( $tied, $lock, DECLINED );
+    return $self->cleanup_and_return($tied, $lock, DECLINED);
-};
+}
 

plugins/karma_tool

@@ -11,24 +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' ) {
+elsif ($command eq 'capture') {
-    $self->capture( $ARGV[1] );
+    $self->capture($ARGV[1]);
 }
-elsif ( $command eq 'release' ) {
+elsif ($command eq 'release') {
-    $self->capture( $ARGV[1] );
+    $self->release($ARGV[1]);
 }
-elsif ( $command eq 'prune' ) {
+elsif ($command eq 'prune') {
-    $self->prune_db( $ARGV[1] || 7 );
+    $self->prune_db($ARGV[1] || 7);
 }
-elsif ( $command eq 'list' ) {
+elsif ($command eq 'search' && is_ip($ARGV[1])) {
+    $self->show_ip($ARGV[1]);
+}
+elsif ($command eq 'list' | $command eq 'search') {
     $self->main();
-};
+}
 
 exit(0);
 
@@ -38,7 +41,7 @@ sub usage {
 
 list takes no arguments.
 
-search [ naughty nice both ]
+search [ naughty nice both <ip> ]
   and returns a list of matching IPs
 
 capture [ IP ]
@@ -51,135 +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 $lock = $self->get_db_lock($db) or return;
-    my $tied = $self->get_db_tie( $db, $lock ) or return;
+    my $tied = $self->get_db_tie($db, $lock) or return;
-    my $key  = $self->get_db_key( $ip );
+    my $key  = $self->get_db_key($ip);
 
-    $tied->{$key} = join(':', time, 1, 0, 1);
+    my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/,
-    return $self->cleanup_and_return( $tied, $lock );
+      $tied->{$key};
-};
+
+    $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 {
+    is_ip($ip) or do { warn "not an IP: $ip\n"; return; };
-        warn "not an IP: $ip\n";
-        return;
-    };
 
     my $db   = $self->get_db_location();
-    my $lock = $self->get_db_lock( $db ) or return;
+    my $lock = $self->get_db_lock($db) or return;
-    my $tied = $self->get_db_tie( $db, $lock ) or return;
+    my $tied = $self->get_db_tie($db, $lock) or return;
-    my $key  = $self->get_db_key( $ip );
+    my $key  = $self->get_db_key($ip);
 
-    $tied->{$key} = join(':', 0, 1, 0, 1);
+    my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/,
-    return $self->cleanup_and_return( $tied, $lock );
+      $tied->{$key};
-};
+
+    $tied->{$key} = join(':', 0, 0, $nice, $connects);
+    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;
 
     my $db   = $self->get_db_location();
-    my $lock = $self->get_db_lock( $db ) or return;
+    my $lock = $self->get_db_lock($db) or return;
-    my $tied = $self->get_db_tie( $db, $lock ) or return;
+    my $tied = $self->get_db_tie($db, $lock) or return;
     my %totals;
 
-    print "      IP Address                 Penalty        Naughty  Nice  Connects  Hostname\n";
+    print
-    foreach my $r ( sort keys %$tied ) {
+"      IP Address                 Penalty        Naughty  Nice  Connects  Hostname\n";
-        my $ip = ip_bintoip( ip_inttobin( $r, 4 ), 4);
+    foreach my $r (sort keys %$tied) {
-        my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/, $tied->{$r};
+        my $ip = ip_bintoip(ip_inttobin($r, 4), 4);
-        $naughty ||= '';
+        my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/,
-        $nice    ||= '';
+          $tied->{$r};
+        $naughty  ||= '';
+        $nice     ||= '';
         $connects ||= '';
         my $time_human = '';
-        if ( $command eq 'search' ) {
+        if ($command eq 'search') {
             my $search = $ARGV[1];
-            if ( $search eq 'nice' ) {
+            if ($search eq 'nice') {
-                next if ! $nice;
+                next if !$nice;
             }
-            elsif ( $search eq 'naughty' ) {
+            elsif ($search eq 'naughty') {
-                next if ! $naughty;
+                next if !$naughty;
             }
-            elsif ( $search eq 'both' ) {
+            elsif ($search eq 'both') {
-                next if ! $naughty || ! $nice;
+                next if !$naughty || !$nice;
             }
-            elsif ( is_ip() && $search ne $ip ) {
+            elsif (is_ip($ARGV[1]) && $search ne $ip) {
                 next;
             }
-        };
+        }
-        if ( $penalty_start_ts ) {
+        if ($penalty_start_ts) {
-            $time_human = strftime "%a %b %e %H:%M", localtime $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;
+
-        };
+            #$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];
-    return 1 if $ip =~ /^(\d{1,3}\.){3}\d{1,3}$/;
+    new Net::IP($ip) or return;
-    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 );
+    my $nip = Net::IP->new(shift) or 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 {
         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},
+    my @candidate_dirs = (
-        "/var/lib/qpsmtpd/karma", "./var/db", "./config", '.' );
+                          $self->{args}{db_dir},
+                          "/var/lib/qpsmtpd/karma", "./var/db", "./config", '.'
+                         );
 
     my $dbdir;
-    for my $d ( @candidate_dirs ) {
+    for my $d (@candidate_dirs) {
-        next if ! $d || ! -d $d;   # impossible
+        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) = @_;
@@ -187,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;
@@ -208,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",
+                             file               => "$db.lock",
-        lock_type => LOCK_EX|LOCK_NB,
+                             lock_type          => LOCK_EX | LOCK_NB,
-        blocking_timeout   => 10,      # 10 sec
+                             blocking_timeout   => 10,                  # 10 sec
-        stale_lock_timeout => 30 * 60, # 30 min
+                             stale_lock_timeout => 30 * 60,             # 30 min
-    } or do {
+                                    }
+      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 $db    = $self->get_db_location();
-    my $lock = $self->get_db_lock( $db ) or return;
+    my $lock  = $self->get_db_lock($db) or return;
-    my $tied = $self->get_db_tie( $db, $lock ) 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);
-};
+}