Merge pull request #35 from msimerson/master

Merging in changes from qpsmtpd-dev fork
This commit is contained in:
Matt Simerson 2013-08-05 15:08:56 -07:00
commit 423c35aab3
187 changed files with 28029 additions and 7886 deletions

4
.gitignore vendored
View File

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

View File

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

129
Changes
View File

@ -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)
@ -36,7 +145,7 @@ Next Version
AUTH PLAIN bug with Alpine (Rick Richard)
require_resolvable_fromhost: Moved DENYSOFT for temp_resolver_failed
resolvable_fromhost: Moved DENYSOFT for temp_resolver_failed
to the RCPT TO hook. (Larry Nedry)
Note Net::IP dependency (Larry Nedry)
@ -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

View File

@ -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/check_badmailfromto
plugins/check_badrcptto
plugins/check_badrcptto_patterns
plugins/check_bogus_bounce
plugins/check_basicheaders
plugins/check_earlytalker
plugins/check_loop
plugins/relay
plugins/check_spamhelo
plugins/badmailfrom
plugins/badmailfromto
plugins/badrcptto
plugins/bogus_bounce
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/greylisting
t/plugin_tests/badmailfrom
t/plugin_tests/badmailfromto
t/plugin_tests/badrcptto
t/plugin_tests/count_unrecognized_commands
t/plugin_tests/dmarc
t/plugin_tests/dnsbl
t/plugin_tests/dspam
t/plugin_tests/earlytalker
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

View File

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

33
META.yml Normal file
View File

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

View File

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

10
README
View File

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

48
STATUS
View File

@ -1,16 +1,42 @@
New Name Suggestions
====================
ignite
flare(mta)
quench
pez (or pezmail)
Qpsmtpd-dev is a fork of Qpsmtpd. Qpsmtpd is a very good SMTP daemon for
developers and hackers (admittedly, its focus). The plugin system is great
but the plugin organization, documentation, and consistency left much
to be desired.
The primary focus of the -dev branch is improving the consistency and
behavior of the plugins. After using one plugin, the knowledge gained
should carry over to other plugins.
Secondary goals are 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

26
UPGRADING Normal file
View File

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

400
bin/install_deps.pl Executable file
View File

@ -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 => { } };
};

View File

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

View File

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

4
config.sample/log2sql Normal file
View File

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

View File

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

View File

@ -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 <>
dont_require_anglebrackets
quit_fortune
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
domainkeys
# DATA plugins
#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

File diff suppressed because it is too large Load Diff

View File

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

View File

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

View File

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

View File

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

View File

@ -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>
and F<check_badmailfrom>.
Example plugins for the C<hook_mail> are F<resolvable_fromhost>
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

View File

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

View File

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

View File

@ -56,7 +56,8 @@ sub config_dir {
$cdir =~ /^(.*)$/; # detaint
my $configdir = $1 if -e "$1/$config";
$cdir_memo{$config} = $configdir;
} else {
}
else {
$cdir_memo{$config} = $self->SUPER::config_dir(@_);
}
return $cdir_memo{$config};
@ -67,9 +68,12 @@ sub start_connection {
my %opts = @_;
$self->{conn} = $opts{conn};
$self->{conn}->client_socket->timeout_set($self->config('timeout') * 1_000_000);
$self->{bb_in} = APR::Brigade->new($self->{conn}->pool, $self->{conn}->bucket_alloc);
$self->{bb_out} = APR::Brigade->new($self->{conn}->pool, $self->{conn}->bucket_alloc);
$self->{conn}
->client_socket->timeout_set($self->config('timeout') * 1_000_000);
$self->{bb_in} =
APR::Brigade->new($self->{conn}->pool, $self->{conn}->bucket_alloc);
$self->{bb_out} =
APR::Brigade->new($self->{conn}->pool, $self->{conn}->bucket_alloc);
my $remote_host = $opts{host} || ($opts{ip} ? "[$opts{ip}]" : "[noip!]");
my $remote_info = $opts{info} ? "$opts{info}\@$remote_host" : $remote_host;
@ -119,7 +123,8 @@ sub getline {
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;
@ -156,6 +161,7 @@ sub respond {
my $bucket = APR::Bucket->new(($c->bucket_alloc), "$line\r\n");
$bb->insert_tail($bucket);
$c->output_filters->fflush($bb);
# $bucket->remove;
$bb->cleanup;
}

View File

@ -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->{data_bytes},
$self->{read_bytes}, # negative offset
0 - $self->{read_bytes}, # to end of str
""); # truncate that substr
""
); # truncate that substr
}
$callback->($self->{data_bytes});
return;
@ -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;
@ -155,16 +158,24 @@ sub process_read_buf {
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(
0,
sub {
if (length($self->{line}) && !$self->paused) {
$self->process_read_buf(\""); # " for bad syntax highlighters
$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(
0,
sub {
if (length($self->{line}) && !$self->paused) {
$self->process_read_buf(\""); # " for bad syntax highlighters
$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;

View File

@ -7,7 +7,7 @@ use Qpsmtpd::Constants;
#use DashProfiler;
$VERSION = "0.84";
$VERSION = "0.93";
my $git;
@ -33,6 +33,7 @@ sub _restart {
my $self = shift;
my %args = @_;
if ($args{restart}) {
# reset all global vars to defaults
$self->clear_config_cache;
$hooks = {};
@ -44,19 +45,19 @@ sub _restart {
}
}
sub DESTROY {
#warn $_ for DashProfiler->profile_as_text("qpsmtpd");
}
sub version { $VERSION . ($git ? "/$git" : "") };
sub version { $VERSION . ($git ? "/$git" : "") }
sub TRACE_LEVEL { $TraceLevel }; # leave for plugin compatibility
sub hooks { $hooks; }
sub load_logging {
# need to do this differently than other plugins so as to
# not trigger logging activity
return if $LOGGING_LOADED;
@ -125,16 +126,19 @@ sub varlog {
$self->load_logging; # in case we don't have this loaded yet
my ($rc) = $self->run_hooks_no_respond("logging", $trace, $hook, $plugin, @log)
my ($rc) =
$self->run_hooks_no_respond("logging", $trace, $hook, $plugin, @log)
or return;
return if $rc == DECLINED || $rc == OK; # plugin success
return if $trace > $TraceLevel;
# no logging plugins registered, fall back to STDERR
my $prefix = defined $plugin && defined $hook ? " ($hook) $plugin:" :
defined $plugin ? " $plugin:" :
defined $hook ? " ($hook) running plugin:" : '';
my $prefix =
defined $plugin && defined $hook ? " ($hook) $plugin:"
: defined $plugin ? " $plugin:"
: defined $hook ? " ($hook) running plugin:"
: '';
warn join(' ', $$ . $prefix, @log), "\n";
}
@ -157,7 +161,8 @@ sub config {
# XXX - is this always the right thing to do? what if a config hook
# can return different values on subsequent calls?
if ($_config_cache->{$c}) {
$self->log(LOGDEBUG, "config($c) returning (@{$_config_cache->{$c}}) from cache");
$self->log(LOGDEBUG,
"config($c) returning (@{$_config_cache->{$c}}) from cache");
return wantarray ? @{$_config_cache->{$c}} : $_config_cache->{$c}->[0];
}
@ -165,7 +170,9 @@ sub config {
my ($rc, @config) = $self->run_hooks_no_respond("config", $c);
$self->log(LOGDEBUG, "config($c): hook returned ($rc, @config) ");
if ($rc == OK) {
$self->log(LOGDEBUG, "setting _config_cache for $c to [@config] from hooks and returning it");
$self->log(LOGDEBUG,
"setting _config_cache for $c to [@config] from hooks and returning it"
);
$_config_cache->{$c} = \@config;
return wantarray ? @{$_config_cache->{$c}} : $_config_cache->{$c}->[0];
}
@ -173,14 +180,18 @@ sub config {
# and then get_qmail_config
@config = $self->get_qmail_config($c, $type);
if (@config) {
$self->log(LOGDEBUG, "setting _config_cache for $c to [@config] from get_qmail_config and returning it");
$self->log(LOGDEBUG,
"setting _config_cache for $c to [@config] from get_qmail_config and returning it"
);
$_config_cache->{$c} = \@config;
return wantarray ? @{$_config_cache->{$c}} : $_config_cache->{$c}->[0];
}
# finally we use the default if there is any:
if (exists($defaults{$c})) {
$self->log(LOGDEBUG, "setting _config_cache for $c to @{[$defaults{$c}]} from defaults and returning it");
$self->log(LOGDEBUG,
"setting _config_cache for $c to @{[$defaults{$c}]} from defaults and returning it"
);
$_config_cache->{$c} = [$defaults{$c}];
return wantarray ? @{$_config_cache->{$c}} : $_config_cache->{$c}->[0];
}
@ -229,7 +240,9 @@ sub get_qmail_config {
eval { require CDB_File };
if ($@) {
$self->log(LOGERROR, "No CDB Support! Did NOT read $configfile.cdb, could not load CDB_File module: $@");
$self->log(LOGERROR,
"No CDB Support! Did NOT read $configfile.cdb, could not load CDB_File module: $@"
);
return +{};
}
@ -238,6 +251,7 @@ sub get_qmail_config {
$self->log(LOGERROR, "tie of $configfile.cdb failed: $!");
return +{};
}
# We explicitly don't cache cdb entries. The assumption is that
# the data is in a CDB file in the first place because there's
# lots of data and the cache hit ratio would be low.
@ -257,7 +271,8 @@ sub _config_from_file {
$visited ||= [];
push @{$visited}, $configfile;
open CF, "<$configfile" or warn "$$ could not open configfile $configfile: $!" and return;
open CF, "<$configfile"
or warn "$$ could not open configfile $configfile: $!" and return;
my @config = <CF>;
chomp @config;
@config = grep { length($_) and $_ !~ m/^\s*#/ and $_ =~ m/\S/ }
@ -267,6 +282,7 @@ sub _config_from_file {
my $pos = 0;
while ($pos < @config) {
# recursively pursue an $include reference, if found. An inclusion which
# begins with a leading slash is interpreted as a path to a file and will
# supercede the usual config path resolution. Otherwise, the normal
@ -283,7 +299,8 @@ sub _config_from_file {
}
if (grep($_ eq $inclusion, @{$visited})) {
$self->log(LOGERROR, "Circular \$include reference in config $config:");
$self->log(LOGERROR,
"Circular \$include reference in config $config:");
$self->log(LOGERROR, "From $visited->[0]:");
$self->log(LOGERROR, " includes $_")
for (@{$visited}[1 .. $#{$visited}], $inclusion);
@ -292,11 +309,13 @@ sub _config_from_file {
push @{$visited}, $inclusion;
for my $inc ($self->expand_inclusion_($inclusion, $configfile)) {
my @insertion = $self->_config_from_file($inc, $config, $visited);
my @insertion =
$self->_config_from_file($inc, $config, $visited);
splice @config, $pos, 0, @insertion; # insert the inclusion
$pos += @insertion;
}
} else {
}
else {
$pos++;
}
}
@ -319,18 +338,21 @@ sub expand_inclusion_ {
@includes = map { "$inclusion/$_" }
(grep { -f "$inclusion/$_" and !/^\./ } sort readdir INCD);
closedir INCD;
} else {
$self->log(LOGERROR, "Couldn't open directory $inclusion,".
" referenced from $context ($!)");
}
} else {
else {
$self->log(LOGERROR,
"Couldn't open directory $inclusion,"
. " referenced from $context ($!)"
);
}
}
else {
$self->log(LOGDEBUG, "inclusion of file $inclusion from $context");
@includes = ($inclusion);
}
return @includes;
}
sub load_plugins {
my $self = shift;
@ -338,6 +360,7 @@ sub load_plugins {
my @loaded;
if ($hooks->{queue}) {
#$self->log(LOGWARN, "Plugins already loaded");
return @plugins;
}
@ -354,24 +377,15 @@ sub _load_plugin {
my $self = shift;
my ($plugin_line, @plugin_dirs) = @_;
my ($plugin, @args) = split ' ', $plugin_line;
my $package;
# untaint the config data before passing it to plugins
my ($safe_line) = $plugin_line =~ /^([ -~]+)$/ # all ascii printable
or die "unsafe characters in config line: $plugin_line\n";
my ($plugin, @args) = split /\s+/, $safe_line;
if ($plugin =~ m/::/) {
# "full" package plugin (My::Plugin)
$package = $plugin;
$package =~ s/[^_a-z0-9:]+//gi;
my $eval = qq[require $package;\n]
.qq[sub ${plugin}::plugin_name { '$plugin' }];
$eval =~ m/(.*)/s;
$eval = $1;
eval $eval;
die "Failed loading $package - eval $@" if $@;
$self->log(LOGDEBUG, "Loading $package ($plugin_line)")
unless $plugin_line =~ /logging/;
}
else {
return $self->_load_package_plugin($plugin, $safe_line, \@args);
};
# regular plugins/$plugin plugin
my $plugin_name = $plugin;
$plugin =~ s/:\d+$//; # after this point, only used for filename
@ -387,7 +401,7 @@ sub _load_plugin {
"::" . (length $2 ? sprintf("_%2x",unpack("C",$2)) : "")
]egx;
$package = "Qpsmtpd::Plugin::$plugin_name";
my $package = "Qpsmtpd::Plugin::$plugin_name";
# don't reload plugins if they are already loaded
unless (defined &{"${package}::plugin_name"}) {
@ -395,8 +409,8 @@ sub _load_plugin {
if (-e "$dir/$plugin") {
Qpsmtpd::Plugin->compile($plugin_name, $package,
"$dir/$plugin", $self->{_test_mode}, $plugin);
$self->log(LOGDEBUG, "Loading $plugin_line from $dir/$plugin")
unless $plugin_line =~ /logging/;
$self->log(LOGDEBUG, "Loading $safe_line from $dir/$plugin")
unless $safe_line =~ /logging/;
last PLUGIN_DIR;
}
}
@ -404,7 +418,6 @@ sub _load_plugin {
join(", ", @plugin_dirs), ")"
unless defined &{"${package}::plugin_name"};
}
}
my $plug = $package->new();
$plug->_register($self, @args);
@ -412,6 +425,26 @@ sub _load_plugin {
return $plug;
}
sub _load_package_plugin {
my ($self, $plugin, $plugin_line, $args) = @_;
# "full" package plugin (My::Plugin)
my $package = $plugin;
$package =~ s/[^_a-z0-9:]+//gi;
my $eval = qq[require $package;\n]
. qq[sub ${plugin}::plugin_name { '$plugin' }];
$eval =~ m/(.*)/s;
$eval = $1;
eval $eval;
die "Failed loading $package - eval $@" if $@;
$self->log(LOGDEBUG, "Loading $package ($plugin_line)")
unless $plugin_line =~ /logging/;
my $plug = $package->new();
$plug->_register($self, @$args);
return $plug;
};
sub transaction { return {}; } # base class implements empty transaction
sub run_hooks {
@ -431,7 +464,9 @@ sub run_hooks_no_respond {
my @r;
for my $code (@{$hooks->{$hook}}) {
eval { (@r) = $code->{code}->($self, $self->transaction, @_); };
$@ and warn("FATAL PLUGIN ERROR [" . $code->{name} . "]: ", $@) and next;
$@
and warn("FATAL PLUGIN ERROR [" . $code->{name} . "]: ", $@)
and next;
if ($r[0] == YIELD) {
die "YIELD not valid from $hook hook";
}
@ -448,6 +483,7 @@ sub pause_read { die "Continuations only work in qpsmtpd-async" }
sub run_continuation {
my $self = shift;
#my $t1 = $SAMPLER->("run_hooks", undef, 1);
die "No continuation in progress" unless $self->{_continuation};
$self->continue_read();
@ -456,18 +492,27 @@ sub run_continuation {
my $hook = shift @$todo || die "No hook in the continuation";
my $args = shift @$todo || die "No hook args in the continuation";
my @r;
while (@$todo) {
my $code = shift @$todo;
#my $t2 = $SAMPLER->($hook . "_" . $code->{name}, undef, 1);
#warn("Got sampler called: ${hook}_$code->{name}\n");
$self->varlog(LOGDEBUG, $hook, $code->{name});
my $tran = $self->transaction;
eval { (@r) = $code->{code}->($self, $tran, @$args); };
$@ and $self->log(LOGCRIT, "FATAL PLUGIN ERROR [" . $code->{name} . "]: ", $@) and next;
$@
and
$self->log(LOGCRIT, "FATAL PLUGIN ERROR [" . $code->{name} . "]: ",
$@)
and next;
!defined $r[0]
and $self->log(LOGERROR, "plugin ".$code->{name}
." running the $hook hook returned undef!")
and $self->log(LOGERROR,
"plugin "
. $code->{name}
. " running the $hook hook returned undef!"
)
and next;
# note this is wrong as $tran is always true in the
@ -488,24 +533,39 @@ sub run_continuation {
$self->{_continuation} = [$hook, $args, @$todo];
return @r;
}
elsif ($r[0] == DENY or $r[0] == DENYSOFT or
$r[0] == DENY_DISCONNECT or $r[0] == DENYSOFT_DISCONNECT)
elsif ( $r[0] == DENY
or $r[0] == DENYSOFT
or $r[0] == DENY_DISCONNECT
or $r[0] == DENYSOFT_DISCONNECT)
{
$r[1] = "" if not defined $r[1];
$self->log(LOGDEBUG, "Plugin ".$code->{name}.
", hook $hook returned ".return_code($r[0]).", $r[1]");
$self->run_hooks_no_respond("deny", $code->{name}, $r[0], $r[1]) unless ($hook eq "deny");
$self->log(LOGDEBUG,
"Plugin "
. $code->{name}
. ", hook $hook returned "
. return_code($r[0])
. ", $r[1]"
);
$self->run_hooks_no_respond("deny", $code->{name}, $r[0], $r[1])
unless ($hook eq "deny");
}
else {
$r[1] = "" if not defined $r[1];
$self->log(LOGDEBUG, "Plugin ".$code->{name}.
", hook $hook returned ".return_code($r[0]).", $r[1]");
$self->run_hooks_no_respond("ok", $code->{name}, $r[0], $r[1]) unless ($hook eq "ok");
$self->log(LOGDEBUG,
"Plugin "
. $code->{name}
. ", hook $hook returned "
. return_code($r[0])
. ", $r[1]"
);
$self->run_hooks_no_respond("ok", $code->{name}, $r[0], $r[1])
unless ($hook eq "ok");
}
last unless $r[0] == DECLINED;
}
$r[0] = DECLINED if not defined $r[0];
# hook_*_parse() may return a CODE ref..
# ... which breaks when splitting as string:
@r = map { split /\n/ } @r unless (ref($r[1]) eq "CODE");
@ -554,7 +614,8 @@ sub spool_dir {
if (!-d $Spool_dir) { # create it if it doesn't exist
mkdir($Spool_dir, oct($Spool_perms))
or die "Could not create spool_dir $Spool_dir: $!";
};
}
# Make sure the spool dir has appropriate rights
$self->log(LOGWARN,
"Permissions on spool_dir $Spool_dir are not $Spool_perms")
@ -570,8 +631,8 @@ my $transaction_counter = 0;
sub temp_file {
my $self = shift;
my $filename = $self->spool_dir()
. join(":", time, $$, $transaction_counter++);
my $filename =
$self->spool_dir() . join(":", time, $$, $transaction_counter++);
return $filename;
}
@ -579,7 +640,8 @@ sub temp_dir {
my $self = shift;
my $mask = shift || 0700;
my $dirname = $self->temp_file();
-d $dirname or mkdir($dirname, $mask)
-d $dirname
or mkdir($dirname, $mask)
or die "Could not create temporary directory $dirname: $!";
return $dirname;
}
@ -588,7 +650,7 @@ sub size_threshold {
my $self = shift;
unless (defined $Size_threshold) {
$Size_threshold = $self->config('size_threshold') || 0;
$self->log(LOGNOTICE, "size_threshold set to $Size_threshold");
$self->log(LOGDEBUG, "size_threshold set to $Size_threshold");
}
return $Size_threshold;
}

View File

@ -196,8 +196,11 @@ sub canonify {
return undef unless ($path =~ /^<(.*)>$/);
$path = $1;
my $domain = $domain_expr ? $domain_expr
my $domain =
$domain_expr
? $domain_expr
: "$subdomain_expr(?:\.$subdomain_expr)*";
# it is possible for $address_literal_expr to be empty, if a site
# doesn't want to allow them
$domain = "(?:$address_literal_expr|$domain)"
@ -216,6 +219,7 @@ sub canonify {
return (undef) unless defined $localpart;
if ($localpart =~ /^$atom_expr(\.$atom_expr)*/) {
# simple case, we are done
return ($localpart, $domainpart);
}
@ -279,7 +283,8 @@ sub format {
my $qchar = '[^a-zA-Z0-9!#\$\%\&\x27\*\+\x2D\/=\?\^_`{\|}~.]';
return '<>' unless defined $self->{_user};
if ((my $user = $self->{_user}) =~ s/($qchar)/\\$1/g) {
return qq(<"$user")
return
qq(<"$user")
. (defined $self->{_host} ? '@' . $self->{_host} : '') . ">";
}
return "<" . $self->address() . ">";
@ -327,6 +332,7 @@ use this to pass data between plugins.
sub notes {
my ($self, $key) = (shift, shift);
# Check for any additional arguments passed by the caller -- including undef
return $self->{_notes}->{$key} unless @_;
return $self->{_notes}->{$key} = shift;
@ -342,8 +348,8 @@ sub _addr_cmp {
}
#invert the address so we can sort by domain then user
($left = join( '=', reverse( split('@', $left->format))) ) =~ tr/[<>]//d;
($right = join( '=', reverse( split('@',$right->format))) ) =~ tr/[<>]//d;
($left = join('=', reverse(split(/@/, $left->format)))) =~ tr/[<>]//d;
($right = join('=', reverse(split(/@/, $right->format)))) =~ tr/[<>]//d;
if ($swap) {
($right, $left) = ($left, $right);

View File

@ -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;
@ -23,7 +24,8 @@ sub SASL {
my ($user, $passClear, $passHash, $ticket, $loginas);
if ($mechanism eq 'plain') {
($loginas, $user, $passClear) = get_auth_details_plain($session,$prekey);
($loginas, $user, $passClear) =
get_auth_details_plain($session, $prekey);
return DECLINED if !$user || !$passClear;
}
elsif ($mechanism eq 'login') {
@ -48,15 +50,21 @@ sub SASL {
# try running the polymorphous hooks next
if (!$rc || $rc == DECLINED) {
($rc, $msg) =
$session->run_hooks( "auth", $mechanism, $user, $passClear,
$passHash, $ticket );
$session->run_hooks("auth", $mechanism, $user,
$passClear, $passHash, $ticket);
}
if ($rc == OK) {
$msg = uc($mechanism) . " authentication successful for $user" .
( $msg ? " - $msg" : '');
$msg =
uc($mechanism)
. " authentication successful for $user"
. ($msg ? " - $msg" : '');
$session->respond(235, $msg);
$session->connection->relay_client(1);
if ($session->connection->notes('naughty')) {
$session->log(LOGINFO, "auth success cleared naughty");
$session->connection->notes('naughty', 0);
}
$session->log(LOGDEBUG, $msg); # already logged by $session->respond
$session->{_auth_user} = $user;
@ -66,8 +74,10 @@ sub SASL {
return OK;
}
else {
$msg = uc($mechanism) . " authentication failed for $user" .
( $msg ? " - $msg" : '');
$msg =
uc($mechanism)
. " authentication failed for $user"
. ($msg ? " - $msg" : '');
$session->respond(535, $msg);
$session->log(LOGDEBUG, $msg); # already logged by $session->respond
return DENY;
@ -92,7 +102,7 @@ sub get_auth_details_plain {
$session->respond(535, "Authentication invalid");
}
return;
};
}
# Authorization ID must not be different from Authentication ID
if ($loginas ne '' && $loginas ne $user) {
@ -101,7 +111,7 @@ sub get_auth_details_plain {
}
return ($loginas, $user, $passClear);
};
}
sub get_auth_details_login {
my ($session, $prekey) = @_;
@ -118,7 +128,7 @@ sub get_auth_details_login {
my $passClear = get_base64_response($session, 'Password:') or return;
return ($user, $passClear);
};
}
sub get_auth_details_cram_md5 {
my ($session, $ticket) = @_;
@ -127,9 +137,9 @@ sub get_auth_details_cram_md5 {
# rand() is not cryptographic, but we only need to generate a globally
# unique number. The rand() is there in case the user logs in more than
# once in the same second, or if the clock is skewed.
$ticket = sprintf( '<%x.%x@%s>',
rand(1000000), time(), $session->config('me') );
};
$ticket =
sprintf('<%x.%x@%s>', rand(1000000), time(), $session->config('me'));
}
# send the base64 encoded ticket
$session->respond(334, encode_base64($ticket, ''));
@ -138,9 +148,9 @@ sub get_auth_details_cram_md5 {
if ($line eq '*') {
$session->respond(501, "Authentication canceled");
return;
};
}
my ( $user, $passHash ) = split( ' ', decode_base64($line) );
my ($user, $passHash) = split(/ /, decode_base64($line));
unless ($user && $passHash) {
$session->respond(504, "Invalid authentication string");
return;
@ -148,7 +158,7 @@ sub get_auth_details_cram_md5 {
$session->{auth}{ticket} = $ticket;
return ($ticket, $user, $passHash);
};
}
sub get_base64_response {
my ($session, $question) = @_;
@ -160,13 +170,13 @@ sub get_base64_response {
return;
}
return $answer;
};
}
sub validate_password {
my ($self, %a) = @_;
my ($pkg, $file, $line) = caller();
$file = (split '/', $file)[-1]; # strip off the path
$file = (split /\//, $file)[-1]; # strip off the path
my $src_clear = $a{src_clear};
my $src_crypt = $a{src_crypt};
@ -179,7 +189,7 @@ sub validate_password {
if (!$src_crypt && !$src_clear) {
$self->log(LOGINFO, "fail: missing password");
return ($deny, "$file - no such user");
};
}
if (!$src_clear && $method =~ /CRAM-MD5/i) {
$self->log(LOGINFO, "skip: cram-md5 not supported w/o clear pass");
@ -190,29 +200,29 @@ sub validate_password {
if ($src_clear && $src_clear eq $attempt_clear) {
$self->log(LOGINFO, "pass: clear match");
return (OK, $file);
};
}
if ($src_crypt && $src_crypt eq crypt($attempt_clear, $src_crypt)) {
$self->log(LOGINFO, "pass: crypt match");
return (OK, $file);
}
};
}
if (defined $attempt_hash && $src_clear) {
if (!$ticket) {
$self->log(LOGERROR, "skip: missing ticket");
return (DECLINED, $file);
};
}
if ($attempt_hash eq hmac_md5_hex($ticket, $src_clear)) {
$self->log(LOGINFO, "pass: hash match");
return (OK, $file);
};
};
}
}
$self->log(LOGINFO, "fail: wrong password");
return ($deny, "$file - wrong password");
};
}
# tag: qpsmtpd plugin that sets RELAYCLIENT when the user authenticates

View File

@ -80,6 +80,7 @@ sub parse {
}
my $parse = "parse_$cmd";
if ($self->can($parse)) {
# print "CMD=$cmd,line=$line\n";
my @out = eval { $self->$parse($cmd, $line); };
if ($@) {
@ -137,6 +138,7 @@ sub _get_mail_params {
# let's see if $line contains nothing and use the first value as address:
if ($line) {
# parameter syntax error, i.e. not all of the arguments were
# stripped by the while() loop:
return (DENY, "Syntax error in parameters")

View File

@ -71,9 +71,7 @@ sub _process_line {
my ($cmd, @params) = split(/ +/, $line);
my $meth = "cmd_" . lc($cmd);
if (my $lookup = $self->can($meth)) {
my $resp = eval {
$lookup->($self, @params);
};
my $resp = eval { $lookup->($self, @params); };
if ($@) {
my $error = $@;
chomp($error);
@ -91,8 +89,10 @@ sub _process_line {
my %helptext = (
help => "HELP [CMD] - Get help on all commands or a specific command",
status => "STATUS - Returns status information about current connections",
list => "LIST [LIMIT] - List the connections, specify limit or negative limit to shrink list",
kill => "KILL (\$IP | \$REF) - Disconnect all connections from \$IP or connection reference \$REF",
list =>
"LIST [LIMIT] - List the connections, specify limit or negative limit to shrink list",
kill =>
"KILL (\$IP | \$REF) - Disconnect all connections from \$IP or connection reference \$REF",
pause => "PAUSE - Stop accepting new connections",
continue => "CONTINUE - Resume accepting connections",
reload => "RELOAD - Reload all plugins and config",
@ -107,10 +107,13 @@ sub cmd_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";
}
@ -158,6 +161,7 @@ sub cmd_status {
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;
}
@ -176,8 +180,8 @@ sub cmd_status {
}
}
$output .= "Curr Connections: $current_connections / $::MAXconn\n".
"Curr DNS Queries: $current_dns";
$output .= "Curr Connections: $current_connections / $::MAXconn\n"
. "Curr DNS Queries: $current_dns";
return $output;
}
@ -188,14 +192,20 @@ sub cmd_list {
my $descriptors = Danga::Socket->DescriptorMap;
my $list = "Current" . ($count ? (($count > 0) ? " Oldest $count" : " Newest ".-$count) : "") . " Connections: \n\n";
my $list =
"Current"
. ($count ? (($count > 0) ? " Oldest $count" : " Newest " . -$count) : "")
. " Connections: \n\n";
my @all;
foreach my $fd (keys %$descriptors) {
my $pob = $descriptors->{$fd};
if ($pob->isa("Qpsmtpd::PollServer")) {
next unless $pob->connection->remote_ip; # haven't even started yet
push @all, [$pob+0, $pob->connection->remote_ip,
$pob->connection->remote_host, $pob->uptime];
push @all,
[
$pob + 0, $pob->connection->remote_ip,
$pob->connection->remote_host, $pob->uptime
];
}
}
@ -209,7 +219,8 @@ sub cmd_list {
}
}
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;
@ -229,9 +240,11 @@ sub cmd_kill {
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++;
}
@ -239,7 +252,8 @@ sub cmd_kill {
else {
# match by ID
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++;
}

View File

@ -15,7 +15,6 @@ my @parameters = qw(
relay_client
);
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
@ -44,10 +43,12 @@ sub clone {
$new->$f($self->$f()) if $self->$f();
}
$new->{_notes} = $self->{_notes} if defined $self->{_notes};
# reset the old connection object like it's done at the end of a connection
# to prevent leaks (like prefork/tls problem with the old SSL file handle
# still around)
$self->reset unless $args{no_reset};
# should we generate a new id here?
return $new;
}
@ -82,7 +83,6 @@ sub local_port {
$self->{_local_port};
}
sub remote_info {
my $self = shift;
@_ and $self->{_remote_info} = shift;
@ -109,6 +109,7 @@ sub hello_host {
sub notes {
my ($self, $key) = (shift, shift);
# Check for any additional arguments passed by the caller -- including undef
return $self->{_notes}->{$key} unless @_;
return $self->{_notes}->{$key} = shift;

View File

@ -384,8 +384,7 @@ default: DENYSOFT
=cut
sub temp_resolver_failed {
shift->_dsn(shift,
(shift || "Temporary address resolution failure"),
shift->_dsn(shift, (shift || "Temporary address resolution failure"),
DENYSOFT, 4, 3);
}
sub net_directory_server_failed { shift->_dsn(shift, shift, DENYSOFT, 4, 3); }
@ -417,7 +416,10 @@ Why do we want to DENYSOFT something like this?
=cut
sub net_routing_loop { shift->_dsn(shift, shift, DENY, 4, 6); }
sub too_many_hops { shift->_dsn(shift,(shift || "Too many hops"),DENY,4,6,); }
sub 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
@ -553,9 +555,11 @@ default: DENY
=cut
sub sec_sender_unauthorized { shift->_dsn(shift, shift, DENY, 7, 1); }
sub bad_sender_ip {
shift->_dsn(shift, (shift || "Bad sender's IP"), DENY, 7, 1,);
}
sub relaying_denied {
shift->_dsn(shift, (shift || "Relaying denied"), DENY, 7, 1);
}
@ -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

View File

@ -3,6 +3,8 @@ package Qpsmtpd::Plugin;
use strict;
use warnings;
use Net::DNS;
use Qpsmtpd::Constants;
# more or less in the order they will fire
@ -36,11 +38,13 @@ sub register_hook {
# I can't quite decide if it's better to parse this code ref or if
# we should pass the plugin object and method name ... hmn.
$plugin->qp->_register_hook
($hook,
{ code => sub { local $plugin->{_qp} = shift;
$plugin->qp->_register_hook(
$hook,
{
code => sub {
local $plugin->{_qp} = shift;
local $plugin->{_hook} = $hook;
$plugin->$method(@_)
$plugin->$method(@_);
},
name => $plugin->plugin_name,
},
@ -76,23 +80,26 @@ sub adjust_log_level {
return $adj if $adj =~ m/^[01234567]$/; # a raw syslog numeral
if ($adj !~ /^[\+\-][\d]$/) {
$self->log( LOGERROR, $self-"invalid $plugin_name loglevel setting ($adj)" );
$self->log(LOGERROR,
$self - "invalid $plugin_name loglevel setting ($adj)");
undef $self->{_args}{loglevel}; # only complain once per plugin
return $cur_level;
};
}
my $operator = substr($adj, 0, 1);
my $adjust = substr($adj, -1, 1);
my $new_level = $operator eq '+' ? $cur_level + $adjust : $cur_level - $adjust;
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;
}
@ -156,8 +163,7 @@ sub isa_plugin {
die "cannot find plugin '$parent'" unless $parent_dir;
$self->compile($self->plugin_name . "_isa_$cleanParent",
$newPackage,
"$parent_dir/$parent");
$newPackage, "$parent_dir/$parent");
warn "---- $newPackage\n";
no strict 'refs';
push @{"${currentPackage}::ISA"}, $newPackage;
@ -210,36 +216,139 @@ 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()) {
# set by plugins/relay, or Qpsmtpd::Auth
$self->log(LOGINFO, "skip, relay client");
return 1;
};
}
if ($self->qp->connection->notes('whitelisthost')) {
# set by plugins/dns_whitelist_soft or plugins/whitelist
$self->log(LOGINFO, "skip, whitelisted host");
return 1;
};
}
if ($self->qp->transaction->notes('whitelistsender')) {
# set by plugins/whitelist
$self->log(LOGINFO, "skip, whitelisted sender");
return 1;
}
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')) {
# see plugins/naughty
$self->log(LOGINFO, "skip, naughty");
return 1;
};
}
if ($self->connection->notes('rejected')) {
# http://www.steve.org.uk/Software/ms-lite/
$self->log(LOGINFO, "skip, already rejected");
return 1;
};
}
return;
};
}
sub 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) = @_;
@ -252,5 +361,4 @@ sub _register_standard_hooks {
}
}
1;

View File

@ -1,6 +1,7 @@
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(
@ -127,11 +128,12 @@ sub process_line {
$self->connection->notes('original_string', $line);
my ($cmd, @params) = split(/ +/, $line, 2);
my $meth = lc($cmd);
if (my $lookup = $cmd_cache{$meth} || $self->{_commands}->{$meth} && $self->can($meth)) {
if (my $lookup =
$cmd_cache{$meth}
|| $self->{_commands}->{$meth} && $self->can($meth))
{
$cmd_cache{$meth} = $lookup;
eval {
$lookup->($self, @params);
};
eval { $lookup->($self, @params); };
if ($@) {
my $error = $@;
chomp($error);
@ -141,11 +143,13 @@ sub process_line {
}
else {
# No such method - i.e. unrecognized command
my ($rc, $msg) = $self->run_hooks("unrecognized_command", $meth, @params);
my ($rc, $msg) =
$self->run_hooks("unrecognized_command", $meth, @params);
}
}
elsif ($self->{mode} eq 'connect') {
$self->{mode} = 'cmd';
# I've removed an eval{} from around this. It shouldn't ever die()
# but if it does we're a bit screwed... Ah well :-)
$self->start_conversation;
@ -173,18 +177,20 @@ 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") },
# NB: Setting remote_info to the same as remote_host
callback => sub { $conn->remote_info($conn->remote_host($_[0])) },
host => $ip,
@ -231,14 +237,16 @@ sub data_respond {
return;
}
return $self->respond(503, "MAIL first") unless $self->transaction->sender;
return $self->respond(503, "RCPT first") unless $self->transaction->recipients;
return $self->respond(503, "RCPT first")
unless $self->transaction->recipients;
$self->{header_lines} = '';
$self->{data_size} = 0;
$self->{in_header} = 1;
$self->{max_size} = ($self->config('databytes'))[0] || 0;
$self->log(LOGDEBUG, "max_size: $self->{max_size} / size: $self->{data_size}");
$self->log(LOGDEBUG,
"max_size: $self->{max_size} / size: $self->{data_size}");
$self->respond(354, "go ahead");
@ -268,6 +276,7 @@ sub got_data {
if ($self->{header_lines} =~ s/\n(\n.*)\z/\n/ms) {
$data = $1;
# end of headers
$self->{in_header} = 0;
@ -279,8 +288,12 @@ sub got_data {
# way a Received: line that is already in the header.
my @header_lines = split(/^/m, $self->{header_lines});
my $header = Mail::Header->new(\@header_lines,
Modify => 0, MailFrom => "COERCE");
my $header =
Mail::Header->new(
\@header_lines,
Modify => 0,
MailFrom => "COERCE"
);
$self->transaction->header($header);
$self->transaction->body_write($self->{header_lines});
$self->{header_lines} = '';
@ -299,7 +312,6 @@ sub got_data {
$self->{data_size} += length $data;
}
if ($done) {
$self->end_of_data;
$self->end_get_chunks($remainder);
@ -312,7 +324,8 @@ sub end_of_data {
#$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) {
@ -329,17 +342,22 @@ sub end_of_data {
and $self->connection->notes('tls_enabled'))
{
$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
$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;

View File

@ -77,7 +77,8 @@ sub print_rec {
sub print_rec_size {
my ($self, $content_size, $data_offset, $rcpt_count) = @_;
my $s = sprintf("%15ld %15ld %15ld", $content_size, $data_offset, $rcpt_count);
my $s =
sprintf("%15ld %15ld %15ld", $content_size, $data_offset, $rcpt_count);
$self->print_rec('REC_TYPE_SIZE', $s);
}
@ -97,18 +98,24 @@ sub open_cleanup {
if ($socket =~ m#^(/.+)#) {
$socket = $1; # un-taint socket path
$self = IO::Socket::UNIX->new(Type => SOCK_STREAM,
Peer => $socket) if $socket;
Peer => $socket)
if $socket;
} elsif ($socket =~ /(.*):(\d+)/) {
}
elsif ($socket =~ /(.*):(\d+)/) {
my ($host, $port) = ($1, $2); # un-taint address and port
$self = IO::Socket::INET->new(Proto => 'tcp',
PeerAddr => $host,PeerPort => $port)
$self = IO::Socket::INET->new(
Proto => 'tcp',
PeerAddr => $host,
PeerPort => $port
)
if $host and $port;
}
unless (ref $self) {
warn "Couldn't open \"$socket\": $!";
return;
}
# allow buffered writes
$self->autoflush(0);
bless($self, $class);
@ -139,7 +146,6 @@ sub get_attr {
return %kv;
}
=head2 print_msg_line($line)
print one line of a message to cleanup.
@ -189,6 +195,7 @@ sub inject_mail {
for (map { $_->address } $transaction->recipients) {
$strm->print_rec('REC_TYPE_RCPT', $_);
}
# add an empty message length record.
# cleanup is supposed to understand that.
# see src/pickup/pickup.c
@ -204,6 +211,7 @@ sub inject_mail {
}
$transaction->body_resetpos;
while (my $line = $transaction->body_getline) {
# print STDERR "body: $line\n";
$strm->print_msg_line($line);
}
@ -220,4 +228,5 @@ sub inject_mail {
}
1;
# vim:sw=2

View File

@ -51,13 +51,17 @@ use constant CLEANUP_FLAG_BOUNCE => (1<<0); # /* Bounce bad messages */
use constant CLEANUP_FLAG_FILTER => (1 << 1); # /* Enable header/body checks */
use constant CLEANUP_FLAG_HOLD => (1 << 2); # /* Place message on hold */
use constant CLEANUP_FLAG_DISCARD => (1 << 3); # /* Discard message silently */
use constant CLEANUP_FLAG_BCC_OK => (1<<4); # /* Ok to add auto-BCC addresses */
use constant CLEANUP_FLAG_BCC_OK => (1 << 4)
; # /* Ok to add auto-BCC addresses */
use constant CLEANUP_FLAG_MAP_OK => (1 << 5); # /* Ok to map addresses */
use constant CLEANUP_FLAG_MILTER => (1 << 6); # /* Enable Milter applications */
use constant CLEANUP_FLAG_FILTER_ALL => (CLEANUP_FLAG_FILTER | CLEANUP_FLAG_MILTER);
use constant CLEANUP_FLAG_MASK_EXTERNAL => (CLEANUP_FLAG_FILTER_ALL | CLEANUP_FLAG_BCC_OK | CLEANUP_FLAG_MAP_OK);
use constant CLEANUP_FLAG_FILTER_ALL =>
(CLEANUP_FLAG_FILTER | CLEANUP_FLAG_MILTER);
use constant CLEANUP_FLAG_MASK_EXTERNAL =>
(CLEANUP_FLAG_FILTER_ALL | CLEANUP_FLAG_BCC_OK | CLEANUP_FLAG_MAP_OK);
use constant CLEANUP_FLAG_MASK_INTERNAL => CLEANUP_FLAG_MAP_OK;
use constant CLEANUP_FLAG_MASK_EXTRA => (CLEANUP_FLAG_HOLD | CLEANUP_FLAG_DISCARD);
use constant CLEANUP_FLAG_MASK_EXTRA =>
(CLEANUP_FLAG_HOLD | CLEANUP_FLAG_DISCARD);
use constant CLEANUP_STAT_OK => 0; # /* Success. */
use constant CLEANUP_STAT_BAD => (1 << 0); # /* Internal protocol error */
@ -68,8 +72,11 @@ use constant CLEANUP_STAT_HOPS => (1<<4); # /* Too many hops */
use constant CLEANUP_STAT_RCPT => (1 << 6); # /* No recipients found */
use constant CLEANUP_STAT_PROXY => (1 << 7); # /* Proxy reject */
use constant CLEANUP_STAT_DEFER => (1 << 8); # /* Temporary reject */
use constant CLEANUP_STAT_MASK_CANT_BOUNCE => (CLEANUP_STAT_BAD | CLEANUP_STAT_WRITE | CLEANUP_STAT_DEFER);
use constant CLEANUP_STAT_MASK_INCOMPLETE => (CLEANUP_STAT_BAD | CLEANUP_STAT_WRITE | CLEANUP_STAT_SIZE | CLEANUP_STAT_DEFER);
use constant CLEANUP_STAT_MASK_CANT_BOUNCE =>
(CLEANUP_STAT_BAD | CLEANUP_STAT_WRITE | CLEANUP_STAT_DEFER);
use constant CLEANUP_STAT_MASK_INCOMPLETE =>
(CLEANUP_STAT_BAD | CLEANUP_STAT_WRITE | CLEANUP_STAT_SIZE |
CLEANUP_STAT_DEFER);
%cleanup_soft = (
CLEANUP_STAT_DEFER => "service unavailable (#4.7.1)",

View File

@ -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, "";

View File

@ -16,6 +16,7 @@ use Qpsmtpd::Address ();
use Qpsmtpd::Command;
use Mail::Header ();
#use Data::Dumper;
use POSIX qw(strftime);
use Net::DNS;
@ -34,7 +35,9 @@ sub new {
my $self = bless({args => \%args}, $class);
my (@commands) = qw(ehlo helo rset mail rcpt data help vrfy noop quit);
my (%commands); @commands{@commands} = ('') x @commands;
my (%commands);
@commands{@commands} = ('') x @commands;
# this list of valid commands should probably be a method or a set of methods
$self->{_commands} = \%commands;
$self->SUPER::_restart(%args) if $args{restart}; # calls Qpsmtpd::_restart()
@ -48,7 +51,12 @@ sub command_counter {
sub dispatch {
my $self = shift;
my ($cmd) = lc shift;
my ($cmd) = shift;
if (!$cmd) {
$self->run_hooks("unrecognized_command", '', @_);
return 1;
}
$cmd = lc $cmd;
$self->{_counter}++;
@ -86,9 +94,9 @@ sub fault {
return $self->respond(451, "Internal error - try again later - " . $msg);
}
sub start_conversation {
my $self = shift;
# this should maybe be called something else than "connect", see
# lib/Qpsmtpd/TcpServer.pm for more confusion.
$self->run_hooks("connect");
@ -113,7 +121,8 @@ sub connect_respond {
$greets .= " ESMTP" unless $greets =~ /(^|\W)ESMTP(\W|$)/;
}
else {
$greets = $self->config('me')
$greets =
$self->config('me')
. " ESMTP qpsmtpd "
. $self->version
. " ready; send us your mail, but not your spam.";
@ -134,20 +143,22 @@ sub reset_transaction {
return $self->{_transaction} = Qpsmtpd::Transaction->new();
}
sub connection {
my $self = shift;
@_ and $self->{_connection} = shift;
return $self->{_connection} || ($self->{_connection} = Qpsmtpd::Connection->new());
return $self->{_connection}
|| ($self->{_connection} = Qpsmtpd::Connection->new());
}
sub helo {
my ($self, $line) = @_;
my ($rc, @msg) = $self->run_hooks('helo_parse');
my ($ok, $hello_host, @stuff) = Qpsmtpd::Command->parse('helo', $line, $msg[0]);
my ($ok, $hello_host, @stuff) =
Qpsmtpd::Command->parse('helo', $line, $msg[0]);
return $self->respond(501,
"helo requires domain/address - see RFC-2821 4.1.1.1") unless $hello_host;
"helo requires domain/address - see RFC-2821 4.1.1.1")
unless $hello_host;
my $conn = $self->connection;
return $self->respond(503, "but you already said HELO ...") if $conn->hello;
@ -158,33 +169,47 @@ sub helo_respond {
my ($self, $rc, $msg, $args) = @_;
my ($hello_host) = @$args;
if ($rc == DONE) {
# do nothing:
1;
} elsif ($rc == DENY) {
}
elsif ($rc == DENY) {
$self->respond(550, @$msg);
} elsif ($rc == DENYSOFT) {
}
elsif ($rc == DENYSOFT) {
$self->respond(450, @$msg);
} elsif ($rc == DENY_DISCONNECT) {
}
elsif ($rc == DENY_DISCONNECT) {
$self->respond(550, @$msg);
$self->disconnect;
} elsif ($rc == DENYSOFT_DISCONNECT) {
}
elsif ($rc == DENYSOFT_DISCONNECT) {
$self->respond(450, @$msg);
$self->disconnect;
} else {
}
else {
my $conn = $self->connection;
$conn->hello("helo");
$conn->hello_host($hello_host);
$self->transaction;
$self->respond(250, $self->config('me') ." Hi " . $conn->remote_info . " [" . $conn->remote_ip ."]; I am so happy to meet you.");
$self->respond(
250,
$self->config('me') . " Hi "
. $conn->remote_info . " ["
. $conn->remote_ip
. "]; I am so happy to meet you."
);
}
}
sub ehlo {
my ($self, $line) = @_;
my ($rc, @msg) = $self->run_hooks('ehlo_parse');
my ($ok, $hello_host, @stuff) = Qpsmtpd::Command->parse('ehlo', $line, $msg[0]);
my ($ok, $hello_host, @stuff) =
Qpsmtpd::Command->parse('ehlo', $line, $msg[0]);
return $self->respond(501,
"ehlo requires domain/address - see RFC-2821 4.1.1.1") unless $hello_host;
"ehlo requires domain/address - see RFC-2821 4.1.1.1")
unless $hello_host;
my $conn = $self->connection;
return $self->respond(503, "but you already said HELO ...") if $conn->hello;
@ -195,25 +220,32 @@ sub ehlo_respond {
my ($self, $rc, $msg, $args) = @_;
my ($hello_host) = @$args;
if ($rc == DONE) {
# do nothing:
1;
} elsif ($rc == DENY) {
}
elsif ($rc == DENY) {
$self->respond(550, @$msg);
} elsif ($rc == DENYSOFT) {
}
elsif ($rc == DENYSOFT) {
$self->respond(450, @$msg);
} elsif ($rc == DENY_DISCONNECT) {
}
elsif ($rc == DENY_DISCONNECT) {
$self->respond(550, @$msg);
$self->disconnect;
} elsif ($rc == DENYSOFT_DISCONNECT) {
}
elsif ($rc == DENYSOFT_DISCONNECT) {
$self->respond(450, @$msg);
$self->disconnect;
} else {
}
else {
my $conn = $self->connection;
$conn->hello("ehlo");
$conn->hello_host($hello_host);
$self->transaction;
my @capabilities = $self->transaction->notes('capabilities')
my @capabilities =
$self->transaction->notes('capabilities')
? @{$self->transaction->notes('capabilities')}
: ();
@ -231,17 +263,28 @@ HOOK: foreach my $hook ( keys %{$self->hooks} ) {
}
# Check if we should only offer AUTH after TLS is completed
my $tls_before_auth = ($self->config('tls_before_auth') ? ($self->config('tls_before_auth'))[0] && $self->transaction->notes('tls_enabled') : 0);
my $tls_before_auth =
($self->config('tls_before_auth')
? ($self->config('tls_before_auth'))[0]
&& $self->transaction->notes('tls_enabled')
: 0);
if (%auth_mechanisms && !$tls_before_auth) {
push @capabilities, 'AUTH ' . join(" ", keys(%auth_mechanisms));
$self->{_commands}->{'auth'} = "";
}
$self->respond(250,
$self->config("me") . " Hi " . $conn->remote_info . " [" . $conn->remote_ip ."]",
$self->respond(
250,
$self->config("me") . " Hi "
. $conn->remote_info . " ["
. $conn->remote_ip . "]",
"PIPELINING",
"8BITMIME",
($self->config('databytes') ? "SIZE ". ($self->config('databytes'))[0] : ()),
(
$self->config('databytes')
? "SIZE " . ($self->config('databytes'))[0]
: ()
),
@capabilities,
);
}
@ -256,7 +299,8 @@ sub auth_parse_respond {
my ($self, $rc, $msg, $args) = @_;
my ($line) = @$args;
my ($ok, $mechanism, @stuff) = Qpsmtpd::Command->parse('auth', $line, $msg->[0]);
my ($ok, $mechanism, @stuff) =
Qpsmtpd::Command->parse('auth', $line, $msg->[0]);
return $self->respond(501, $mechanism || "Syntax error in command")
unless ($ok == OK);
@ -276,7 +320,7 @@ sub auth_parse_respond {
# we don't have a plugin implementing this auth mechanism, 504
if (exists $auth_mechanisms{uc($mechanism)}) {
return $self->{_auth} = Qpsmtpd::Auth::SASL($self, $mechanism, @stuff);
};
}
$self->respond(504, "Unimplemented authentification mechanism: $mechanism");
return DENY;
@ -284,6 +328,7 @@ sub auth_parse_respond {
sub mail {
my ($self, $line) = @_;
# -> from RFC2821
# The MAIL command (or the obsolete SEND, SOML, or SAML commands)
# begins a mail transaction. Once started, a mail transaction
@ -304,19 +349,20 @@ sub mail {
$self->reset_transaction;
unless ($self->connection->hello) {
if (!$self->connection->hello) {
return $self->respond(503, "please say hello first ...");
}
else {
$self->log(LOGDEBUG, "full from_parameter: $line");
$self->connection->notes('envelope_from', $line);
$self->run_hooks("mail_parse", $line);
}
}
sub mail_parse_respond {
my ($self, $rc, $msg, $args) = @_;
my ($line) = @$args;
my ($ok, $from, @params) = Qpsmtpd::Command->parse('mail', $line, $msg->[0]);
my ($ok, $from, @params) =
Qpsmtpd::Command->parse('mail', $line, $msg->[0]);
return $self->respond(501, $from || "Syntax error in command")
unless ($ok == OK);
my %param;
@ -324,6 +370,7 @@ sub mail_parse_respond {
my ($k, $v) = split /=/, $_, 2;
$param{lc $k} = $v;
}
# to support addresses without <> we now require a plugin
# hooking "mail_pre" to
# return (OK, "<$from>");
@ -349,7 +396,8 @@ sub mail_pre_respond {
else {
$from = (Qpsmtpd::Address->parse($from))[0];
}
return $self->respond(501, "could not parse your mail from command") unless $from;
return $self->respond(501, "could not parse your mail from command")
unless $from;
$self->run_hooks("mail", $from, %$param);
}
@ -384,13 +432,18 @@ sub mail_respond {
}
else { # includes OK
$self->log(LOGDEBUG, "getting mail from " . $from->format);
$self->respond(250, $from->format . ", sender OK - how exciting to get mail from you!");
$self->respond(
250,
$from->format
. ", sender OK - how exciting to get mail from you!"
);
$self->transaction->sender($from);
}
}
sub rcpt {
my ($self, $line) = @_;
$self->connection->notes('envelope_rcpt', $line);
$self->run_hooks("rcpt_parse", $line);
}
@ -400,20 +453,22 @@ sub rcpt_parse_respond {
my ($ok, $rcpt, @param) = Qpsmtpd::Command->parse("rcpt", $line, $msg->[0]);
return $self->respond(501, $rcpt || "Syntax error in command")
unless ($ok == OK);
return $self->respond(503, "Use MAIL before RCPT") unless $self->transaction->sender;
return $self->respond(503, "Use MAIL before RCPT")
unless $self->transaction->sender;
my %param;
foreach (@param) {
my ($k, $v) = split /=/, $_, 2;
$param{lc $k} = $v;
}
# to support addresses without <> we now require a plugin
# hooking "rcpt_pre" to
# return (OK, "<$rcpt>");
# (... or anything else parseable by Qpsmtpd::Address ;-))
# this means, a plugin can decide to (pre-)accept
# addresses like <user@example.com.> or <user@example.com >
# by removing the trailing "."/" " from this example...
# by removing the trailing dot or space from this example.
$self->run_hooks("rcpt_pre", $rcpt, \%param);
}
@ -451,13 +506,13 @@ sub rcpt_respond {
}
elsif ($rc == DENY_DISCONNECT) {
$msg->[0] ||= 'delivery denied';
$self->log(LOGINFO, "delivery denied (@$msg)");
$self->log(LOGDEBUG, "delivery denied (@$msg)");
$self->respond(550, @$msg);
$self->disconnect;
}
elsif ($rc == DENYSOFT_DISCONNECT) {
$msg->[0] ||= 'relaying denied';
$self->log(LOGINFO, "delivery denied (@$msg)");
$self->log(LOGDEBUG, "delivery denied (@$msg)");
$self->respond(421, @$msg);
$self->disconnect;
}
@ -489,9 +544,11 @@ sub help_respond {
else {
unless ($msg->[0]) {
@$msg = (
"This is qpsmtpd " . ($self->config('smtpgreeting') ? '' : $self->version),
"This is qpsmtpd "
. ($self->config('smtpgreeting') ? '' : $self->version),
"See http://smtpd.develooper.com/",
'To report bugs or send comments, mail to <ask@develooper.com>.');
'To report bugs or send comments, mail to <ask@develooper.com>.'
);
}
$self->respond(214, @$msg);
}
@ -545,7 +602,8 @@ sub vrfy_respond {
return 1;
}
else { # $rc == DECLINED or anything else
$self->respond(252, "Just try sending a mail and we'll see how it turns out ...");
$self->respond(252,
"Just try sending a mail and we'll see how it turns out ...");
return 1;
}
}
@ -564,7 +622,8 @@ sub quit {
sub quit_respond {
my ($self, $rc, $msg, $args) = @_;
if ($rc != DONE) {
$msg->[0] ||= $self->config('me') . " closing connection. Have a wonderful day.";
$msg->[0] ||=
$self->config('me') . " closing connection. Have a wonderful day.";
$self->respond(221, @$msg);
}
$self->disconnect();
@ -611,14 +670,17 @@ sub data_respond {
$self->disconnect;
return 1;
}
$self->respond(503, "MAIL first"), return 1 unless $self->transaction->sender;
$self->respond(503, "RCPT first"), return 1 unless $self->transaction->recipients;
$self->respond(503, "MAIL first"), return 1
unless $self->transaction->sender;
$self->respond(503, "RCPT first"), return 1
unless $self->transaction->recipients;
$self->respond(354, "go ahead");
my $buffer = '';
my $size = 0;
my $i = 0;
my $max_size = ($self->config('databytes'))[0] || 0; # this should work in scalar context
my $max_size =
($self->config('databytes'))[0] || 0; # this should work in scalar context
my $blocked = "";
my %matches;
my $in_header = 1;
@ -630,7 +692,10 @@ sub data_respond {
my $timeout = $self->config('timeout');
while (defined($_ = $self->getline($timeout))) {
$complete++, last if $_ eq ".\r\n";
if ($_ eq ".\r\n") {
$complete++;
$_ = '';
}
$i++;
# should probably use \012 and \015 in these checks instead of \r and \n ...
@ -646,7 +711,7 @@ sub data_respond {
unless (($max_size and $size > $max_size)) {
s/\r\n$/\n/;
s/^\.\./\./;
if ($in_header and m/^$/) {
if ($in_header && (m/^$/ || $complete > 0)) {
$in_header = 0;
my @headers = split /^/m, $buffer;
@ -658,6 +723,7 @@ sub data_respond {
# way a Received: line that is already in the header.
$header->extract(\@headers);
#$header->add("X-SMTPD", "qpsmtpd/".$self->version.", http://smtpd.develooper.com/");
$buffer = "";
@ -671,7 +737,8 @@ sub data_respond {
$self->respond(554, $msg || "Message denied");
$self->disconnect;
return 1;
} elsif ($rc == DENYSOFT_DISCONNECT) {
}
elsif ($rc == DENYSOFT_DISCONNECT) {
$self->respond(421, $msg || "Message denied temporarily");
$self->disconnect;
return 1;
@ -689,32 +756,16 @@ sub data_respond {
# copy all lines into the spool file, including the headers
# we will create a new header later before sending onwards
$self->transaction->body_write($_);
$self->transaction->body_write($_) if !$complete;
$size += length $_;
}
last if $complete > 0;
#$self->log(LOGDEBUG, "size is at $size\n") unless ($i % 300);
}
$self->log(LOGDEBUG, "max_size: $max_size / size: $size");
my $smtp = $self->connection->hello eq "ehlo" ? "ESMTP" : "SMTP";
my $esmtp = substr($smtp,0,1) eq "E";
my $authheader = '';
my $sslheader = '';
if (defined $self->connection->notes('tls_enabled')
and $self->connection->notes('tls_enabled')) {
$smtp .= "S" if $esmtp; # RFC3848
$sslheader = "(".$self->connection->notes('tls_socket')->get_cipher()." encrypted) ";
}
if (defined $self->{_auth} and $self->{_auth} == OK) {
$smtp .= "A" if $esmtp; # RFC3848
$authheader = "(smtp-auth username $self->{_auth_user}, mechanism $self->{_auth_mechanism})\n";
}
$header->add("Received", $self->received_line($smtp, $authheader, $sslheader), 0);
# if we get here without seeing a terminator, the connection is
# probably dead.
unless ($complete) {
@ -725,7 +776,8 @@ sub data_respond {
#$self->respond(550, $self->transaction->blocked),return 1 if ($self->transaction->blocked);
if ($max_size and $size > $max_size) {
$self->log(LOGALERT, "Message too big: size: $size (max size: $max_size)");
$self->log(LOGALERT,
"Message too big: size: $size (max size: $max_size)");
$self->respond(552, "Message too big!");
$self->reset_transaction; # clean up after ourselves
return 1;
@ -734,9 +786,77 @@ sub data_respond {
$self->run_hooks("data_post");
}
sub authentication_results {
my ($self) = @_;
my @auth_list = $self->config('me');
# $self->clean_authentication_results();
if ( ! defined $self->{_auth} ) {
push @auth_list, 'auth=none';
}
else {
my $mechanism = "(" . $self->{_auth_mechanism} . ")";
my $user = "smtp.auth=" . $self->{_auth_user};
if ( $self->{_auth} == OK) {
push @auth_list, "auth=pass $mechanism $user";
}
else {
push @auth_list, "auth=fail $mechanism $user";
};
};
# RFC 5451: used in AUTH, DKIM, DOMAINKEYS, SENDERID, SPF
if ( $self->connection->notes('authentication_results') ) {
push @auth_list, $self->connection->notes('authentication_results');
};
$self->log(LOGDEBUG, "adding auth results header" );
$self->transaction->header->add('Authentication-Results', join('; ', @auth_list), 0);
};
sub clean_authentication_results {
my $self = shift;
# On messages received from the internet, we may want to remove
# the Authentication-Results headers added by other MTAs, so our downstream
# can trust the new A-R header we insert.
# We do not want to invalidate DKIM signatures.
# TODO: parse the DKIM signature(s) to see if A-R header is signed
return if $self->transaction->header->get('DKIM-Signature');
my @headers = $self->transaction->header->get('Authentication-Results');
for ( my $i = 0; $i < scalar @headers; $i++ ) {
$self->transaction->header->delete('Authentication-Results', $i);
}
};
sub received_line {
my ($self, $smtp, $authheader, $sslheader) = @_;
my ($rc, @received) = $self->run_hooks("received_line", $smtp, $authheader, $sslheader);
my ($self) = @_;
my $smtp = $self->connection->hello eq "ehlo" ? "ESMTP" : "SMTP";
my $esmtp = substr($smtp, 0, 1) eq "E";
my $authheader = '';
my $sslheader = '';
if (defined $self->connection->notes('tls_enabled')
and $self->connection->notes('tls_enabled'))
{
$smtp .= "S" if $esmtp; # RFC3848
$sslheader = "("
. $self->connection->notes('tls_socket')->get_cipher()
. " encrypted) ";
}
if (defined $self->{_auth} && $self->{_auth} == OK) {
my $mech = $self->{_auth_mechanism};
my $user = $self->{_auth_user};
$smtp .= "A" if $esmtp; # RFC3848
$authheader = "(smtp-auth username $user, mechanism $mech)\n";
}
my $header_str;
my ($rc, @received) =
$self->run_hooks("received_line", $smtp, $authheader, $sslheader);
if ($rc == YIELD) {
die "YIELD not supported for received_line hook";
}
@ -744,11 +864,20 @@ sub received_line {
return join("\n", @received);
}
else { # assume $rc == DECLINED
return "from ".$self->connection->remote_info
." (HELO ".$self->connection->hello_host . ") (".$self->connection->remote_ip
. ")\n $authheader by ".$self->config('me')." (qpsmtpd/".$self->version
.") with $sslheader$smtp; ". (strftime('%a, %d %b %Y %H:%M:%S %z', localtime))
$header_str =
"from "
. $self->connection->remote_info
. " (HELO "
. $self->connection->hello_host . ") ("
. $self->connection->remote_ip
. ")\n by "
. $self->config('me')
. " (qpsmtpd/"
. $self->version
. ") with $sslheader$smtp; "
. (strftime('%a, %d %b %Y %H:%M:%S %z', localtime));
}
$self->transaction->header->add('Received', $header_str, 0 );
}
sub data_post_respond {
@ -759,12 +888,14 @@ sub data_post_respond {
elsif ($rc == DENY) {
$msg->[0] ||= "Message denied";
$self->respond(552, @$msg);
# DATA is always the end of a "transaction"
return $self->reset_transaction;
}
elsif ($rc == DENYSOFT) {
$msg->[0] ||= "Message denied temporarily";
$self->respond(452, @$msg);
# DATA is always the end of a "transaction"
return $self->reset_transaction;
}
@ -781,6 +912,8 @@ sub data_post_respond {
return 1;
}
else {
$self->authentication_results();
$self->received_line();
$self->queue($self->transaction);
}
}
@ -850,5 +983,4 @@ sub queue_post_respond {
$self->log(LOGERROR, @$msg) unless ($rc == OK or $rc == 0);
}
1;

View File

@ -19,7 +19,8 @@ sub dispatch {
my ($result) = eval { $self->$cmd(@_) };
if ($@ =~ /^disconnect_tcpserver/) {
die "disconnect_tcpserver";
} elsif ($@) {
}
elsif ($@) {
$self->log(LOGERROR, "XX: $@") if $@;
}
return $result if defined $result;

View File

@ -8,18 +8,18 @@ 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"); }
) {
import Socket6;
)
{
Socket6->import(qw(inet_ntop));
$has_ipv6 = 1;
}
else {
$has_ipv6=0;
}
sub has_ipv6 {
return $has_ipv6;
@ -36,21 +36,27 @@ sub start_connection {
);
if ($ENV{TCPREMOTEIP}) {
# started from tcpserver (or some other superserver which
# exports the TCPREMOTE* variables.
$remote_ip = $ENV{TCPREMOTEIP};
$remote_host = $ENV{TCPREMOTEHOST} || "[$remote_ip]";
$remote_info = $ENV{TCPREMOTEINFO} ? "$ENV{TCPREMOTEINFO}\@$remote_host" : $remote_host;
$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 {
}
else {
# Started from inetd or similar.
# get info on the remote host from the socket.
# ignore ident/tap/...
my $hersockaddr = getpeername(STDIN)
or die "getpeername failed: $0 must be called from tcpserver, (x)inetd or a similar program which passes a socket to stdin";
or die
"getpeername failed: $0 must be called from tcpserver, (x)inetd or a similar program which passes a socket to stdin";
my ($port, $iaddr) = sockaddr_in($hersockaddr);
$remote_ip = inet_ntoa($iaddr);
$remote_host = gethostbyaddr($iaddr, AF_INET) || "[$remote_ip]";
@ -67,14 +73,16 @@ 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 {
@ -95,8 +103,7 @@ sub run {
sub read_input {
my $self = shift;
my $timeout =
$self->config('timeoutsmtpd') # qmail smtpd control file
my $timeout = $self->config('timeoutsmtpd') # qmail smtpd control file
|| $self->config('timeout') # qpsmtpd control file
|| 1200; # default value
@ -122,7 +129,8 @@ sub respond {
my $buf = '';
if (!$self->check_socket()) {
$self->log(LOGERROR, "Lost connection to client, cannot send response.");
$self->log(LOGERROR,
"Lost connection to client, cannot send response.");
return (0);
}
@ -131,7 +139,8 @@ sub respond {
$self->log(LOGINFO, $line);
$buf .= "$line\r\n";
}
print $buf or ($self->log(LOGERROR, "Could not print [$buf]: $!"), return 0);
print $buf
or ($self->log(LOGERROR, "Could not print [$buf]: $!"), return 0);
return 1;
}
@ -148,12 +157,24 @@ sub disconnect {
sub lrpip {
my ($server, $client, $hisaddr) = @_;
my ($port, $iaddr) = ($server->sockdomain == AF_INET) ? (sockaddr_in($hisaddr)) : (sockaddr_in6($hisaddr));
my ($port, $iaddr) =
($server->sockdomain == AF_INET)
? (sockaddr_in($hisaddr))
: (sockaddr_in6($hisaddr));
my $localsockaddr = getsockname($client);
my ($lport, $laddr) = ($server->sockdomain == AF_INET) ? (sockaddr_in($localsockaddr)) : (sockaddr_in6($localsockaddr));
my ($lport, $laddr) =
($server->sockdomain == AF_INET)
? (sockaddr_in($localsockaddr))
: (sockaddr_in6($localsockaddr));
my $nto_iaddr = ($server->sockdomain == AF_INET) ? (inet_ntoa($iaddr)) : (inet_ntop(AF_INET6(), $iaddr));
my $nto_laddr = ($server->sockdomain == AF_INET) ? (inet_ntoa($laddr)) : (inet_ntop(AF_INET6(), $laddr));
my $nto_iaddr =
($server->sockdomain == AF_INET)
? (inet_ntoa($iaddr))
: (inet_ntop(AF_INET6(), $iaddr));
my $nto_laddr =
($server->sockdomain == AF_INET)
? (inet_ntoa($laddr))
: (inet_ntop(AF_INET6(), $laddr));
$nto_iaddr =~ s/::ffff://;
$nto_laddr =~ s/::ffff://;
@ -167,7 +188,8 @@ sub tcpenv {
my $TCPREMOTEIP = $nto_iaddr;
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);

View File

@ -19,8 +19,7 @@ sub start_connection {
sub read_input {
my $self = shift;
my $timeout =
$self->config('timeoutsmtpd') # qmail smtpd control file
my $timeout = $self->config('timeoutsmtpd') # qmail smtpd control file
|| $self->config('timeout') # qpsmtpd control file
|| 1200; # default value
@ -43,7 +42,8 @@ sub read_input {
};
if ($@ =~ /^disconnect_tcpserver/) {
die "disconnect_tcpserver";
} else {
}
else {
$self->run_hooks("post-connection");
$self->connection->reset;
die "died while reading from STDIN (probably broken sender) - $@";
@ -55,14 +55,16 @@ sub respond {
my ($self, $code, @messages) = @_;
if (!$self->check_socket()) {
$self->log(LOGERROR, "Lost connection to client, cannot send response.");
$self->log(LOGERROR,
"Lost connection to client, cannot send response.");
return (0);
}
while (my $msg = shift @messages) {
my $line = $code . (@messages ? "-" : " ") . $msg;
$self->log(LOGINFO, $line);
print "$line\r\n" or ($self->log(LOGERROR, "Could not print [$line]: $!"), return 0);
print "$line\r\n"
or ($self->log(LOGERROR, "Could not print [$line]: $!"), return 0);
}
return 1;
}

View File

@ -2,14 +2,16 @@ package Qpsmtpd::Transaction;
use Qpsmtpd;
@ISA = qw(Qpsmtpd);
use strict;
use warnings;
use Qpsmtpd::Utils;
use Qpsmtpd::Constants;
use IO::File qw(O_RDWR O_CREAT);
use Socket qw(inet_aton);
use Sys::Hostname;
use Time::HiRes qw(gettimeofday);
use IO::File qw(O_RDWR O_CREAT);
sub new { start(@_) }
sub start {
@ -29,8 +31,9 @@ sub add_recipient {
sub remove_recipient {
my ($self, $rcpt) = @_;
$self->{_recipients} = [grep {$_->address ne $rcpt->address}
@{$self->{_recipients} || []}] if $rcpt;
$self->{_recipients} =
[grep { $_->address ne $rcpt->address } @{$self->{_recipients} || []}]
if $rcpt;
}
sub recipients {
@ -62,6 +65,7 @@ sub header {
sub notes {
my ($self, $key) = (shift, shift);
# Check for any additional arguments passed by the caller -- including undef
return $self->{_notes}->{$key} unless @_;
return $self->{_notes}->{$key} = shift;
@ -108,14 +112,20 @@ sub body_spool {
my $self = shift;
$self->log(LOGINFO, "spooling message to disk");
$self->{_filename} = $self->temp_file();
$self->{_body_file} = IO::File->new($self->{_filename}, O_RDWR|O_CREAT, 0600)
or die "Could not open file $self->{_filename} - $! "; # . $self->{_body_file}->error;
$self->{_body_file} =
IO::File->new($self->{_filename}, O_RDWR | O_CREAT, 0600)
or die "Could not open file $self->{_filename} - $! "
; # . $self->{_body_file}->error;
if ($self->{_body_array}) {
foreach my $line (@{$self->{_body_array}}) {
$self->{_body_file}->print($line) or die "Cannot print to temp file: $!";
$self->{_body_file}->print($line)
or die "Cannot print to temp file: $!";
}
$self->{_body_start} = $self->{_header_size};
}
else {
$self->log(LOGERROR, "no message body");
}
$self->{_body_array} = undef;
}
@ -123,13 +133,15 @@ sub body_write {
my $self = shift;
my $data = shift;
if ($self->{_body_file}) {
#warn("body_write to file\n");
# go to the end of the file
seek($self->{_body_file}, 0, 2)
unless $self->{_body_file_writing};
$self->{_body_file_writing} = 1;
$self->{_body_file}->print(ref $data eq "SCALAR" ? $$data : $data)
and $self->{_body_size} += length (ref $data eq "SCALAR" ? $$data : $data);
and $self->{_body_size} +=
length(ref $data eq "SCALAR" ? $$data : $data);
}
else {
#warn("body_write to array\n");
@ -152,7 +164,8 @@ sub body_write {
sub body_size { # depreceated, use data_size() instead
my $self = shift;
$self->log(LOGWARN, "WARNING: body_size() is depreceated, use data_size() instead");
$self->log(LOGWARN,
"WARNING: body_size() is depreceated, use data_size() instead");
$self->{_body_size} || 0;
}
@ -224,12 +237,24 @@ sub dup_body_fh {
sub DESTROY {
my $self = shift;
# would we save some disk flushing if we unlinked the file before
# closing it?
undef $self->{_body_file} if $self->{_body_file};
$self->log(LOGDEBUG, sprintf("DESTROY called by %s, %s, %s", (caller)));
if ($self->{_body_file}) {
undef $self->{_body_file};
}
if ($self->{_filename} and -e $self->{_filename}) {
unlink $self->{_filename} or $self->log(LOGERROR, "Could not unlink ", $self->{_filename}, ": $!");
if (unlink $self->{_filename}) {
$self->log(LOGDEBUG, "unlinked ", $self->{_filename});
}
else {
$self->log(LOGERROR, "Could not unlink ",
$self->{_filename}, ": $!");
}
}
# These may not exist
@ -237,22 +262,24 @@ sub DESTROY {
$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, ": $!");
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, ": $!");
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( )

View File

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

629
log/log2sql Executable file
View File

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

140
log/log2sql.sql Normal file
View File

@ -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 */;

View File

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

72
log/show_message Executable file
View File

@ -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();
}
}

436
log/summarize Executable file
View File

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

44
log/watch Executable file
View File

@ -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();
}
}

View File

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

141
plugins/async/earlytalker Normal file
View File

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

View File

@ -45,7 +45,8 @@ sub init {
$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");
@ -61,8 +62,11 @@ sub start_queue {
my $PORT = $self->{_smtp_port};
$self->log(LOGINFO, "forwarding to $SERVER:$PORT");
$transaction->notes('async_sender',
AsyncSMTPSender->new($SERVER, $PORT, $qp, $self, $transaction)
$transaction->notes(
'async_sender',
AsyncSMTPSender->new(
$SERVER, $PORT, $qp, $self, $transaction
)
);
return YIELD;
@ -112,7 +116,8 @@ sub new {
PeerAddr => $server,
PeerPort => $port,
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');
@ -125,10 +130,12 @@ sub new {
$self->{command} = 'connect';
$self->{buf} = '';
$self->{resp} = [];
# copy the recipients so we can pop them off one by one
$self->{to} = [$transaction->recipients];
$self->SUPER::new($sock);
# Watch for write first, this is when the TCP session is established.
$self->watch_write(1);
@ -158,7 +165,8 @@ sub command {
$self->log(LOGDEBUG, ">> $command $params");
$self->write( ($command =~ m/ / ? "$command:" : $command)
. ($params ? " $params" : "") . "\r\n");
. ($params ? " $params" : "")
. "\r\n");
$self->watch_read(1);
$self->{command} = ($command =~ /(\S+)/)[0];
}
@ -183,7 +191,8 @@ 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);
}
}
@ -321,6 +330,7 @@ sub event_read {
if ($self->{state} == ST_COMMANDS) {
my $in = $self->read(1024);
if (!$in) {
# XXX: connection closed
$self->close("lost connection");
return;
@ -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");
@ -385,6 +396,7 @@ sub event_err {
my ($self) = @_;
eval { $self->read(1); }; # gives us the correct error in errno
$self->{rmsg} = "Read error from remote server: $!";
#print "lost connection: $!\n";
$self->close;
$self->cont;
@ -394,6 +406,7 @@ sub event_hup {
my ($self) = @_;
eval { $self->read(1); }; # gives us the correct error in errno
$self->{rmsg} = "HUP error from remote server: $!";
#print "lost connection: $!\n";
$self->close;
$self->cont;

View File

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

View File

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

View File

@ -31,10 +31,13 @@ sub start_data_post {
my @names;
my $queries = $self->lookup_start($transaction, sub {
my $queries = $self->lookup_start(
$transaction,
sub {
my ($self, $name) = @_;
push @names, $name;
});
}
);
my @hosts;
foreach my $z (keys %{$self->{uribl_zones}}) {
@ -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});
}
}
@ -110,10 +115,14 @@ sub collect_results {
if (exists $results->{$z}->{$n}->{a}) {
if ($self->evaluate($z, $results->{$z}->{$n}->{a})) {
$self->log(LOGDEBUG, "match $n in $z");
push @matches, {
push @matches,
{
action => $self->{uribl_zones}->{$z}->{action},
desc => "$n in $z: " .
($results->{$z}->{$n}->{txt} || $results->{$z}->{$n}->{a}),
desc => "$n in $z: "
. (
$results->{$z}->{$n}->{txt}
|| $results->{$z}->{$n}->{a}
),
};
}
}

View File

@ -136,11 +136,12 @@ sub auth_checkpassword {
my $status = $?;
if ($status != 0) {
$self->log(LOGNOTICE, "authentication failed ($status)");
$self->log(LOGNOTICE, "fail, auth failed: $status");
return (DECLINED);
};
}
$self->connection->notes('authuser', $user);
$self->log(LOGINFO, "pass, auth success with $method");
return (OK, "auth_checkpassword");
}
@ -153,12 +154,13 @@ sub get_checkpw {
return ($checkpw, $true)
if ($checkpw && $true && -x $checkpw && -x $true);
my $missing_config = "disabled due to invalid configuration. See 'perldoc plugins/auth/auth_checkpassword' for how to configure.";
my $missing_config =
"disabled due to invalid configuration. See 'perldoc plugins/auth/auth_checkpassword' for how to configure.";
if (!$self->qp->config('smtpauth-checkpassword')) {
$self->log(LOGERROR, $missing_config);
return;
};
}
$self->log(LOGNOTICE, "reading config from smtpauth-checkpassword");
my $config = $self->qp->config("smtpauth-checkpassword");
@ -167,9 +169,9 @@ sub get_checkpw {
if (!$checkpw || !$true || !-x $checkpw || !-x $true) {
$self->log(LOGERROR, $missing_config);
return;
};
}
return ($checkpw, $true);
};
}
sub get_sudo {
my $binary = shift;

View File

@ -55,7 +55,7 @@ sub register {
unless ($arg{cvm_socket}) {
$self->log(LOGERROR, "skip: requires cvm_socket argument");
return 0;
};
}
$self->{_args} = {%arg};
$self->{_enable_smtp} = $arg{enable_smtp} || 'no';
@ -77,6 +77,7 @@ sub register {
$self->register_hook("auth-plain", "authcvm_plain");
$self->register_hook("auth-login", "authcvm_plain");
# $self->register_hook("auth-cram-md5", "authcvm_hash");
}
@ -98,7 +99,9 @@ sub authcvm_plain {
return (DENY, "authcvm");
};
my $o = select(SOCK); $| = 1; select($o);
my $o = select(SOCK);
$| = 1;
select($o);
my ($u, $host) = split(/\@/, $user);
$host ||= "localhost";
@ -113,17 +116,17 @@ sub authcvm_plain {
if (!defined $s) {
$self->log(LOGERROR, "skip: no response from cvm for $user");
return (DECLINED);
};
}
if ($s == 0) {
$self->log(LOGINFO, "pass: authentication for: $user");
return (OK, "auth success for $user");
};
}
if ($s == 100) {
$self->log(LOGINFO, "fail: authentication failure for: $user");
return (DENY, 'auth failure (100)');
};
}
$self->log(LOGERROR, "skip: unknown response from cvm for $user");
return (DECLINED, "unknown result code ($s)");

View File

@ -53,14 +53,15 @@ sub auth_flat_file {
return (DENY, "authflat - missing password");
}
my ( $pw_name, $pw_domain ) = split '@', lc($user);
my ($pw_name, $pw_domain) = split /@/, lc($user);
unless (defined $pw_domain) {
$self->log(LOGINFO, "fail: missing domain");
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) {
$self->log(LOGINFO, "fail: no such user: $user");
@ -70,7 +71,9 @@ 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
Qpsmtpd::Auth::validate_password(
$self,
src_clear => $auth_pass,
src_crypt => undef,
attempt_clear => $passClear,

View File

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

View File

@ -61,17 +61,20 @@ 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
Qpsmtpd::Auth::validate_password(
$self,
src_clear => $pw->{pw_clear_passwd},
src_crypt => $pw->{pw_passwd},
attempt_clear => $passClear,
@ -84,13 +87,14 @@ sub auth_vpopmail {
sub test_vpopmail_module {
my $self = shift;
# vpopmail will not allow vauth_getpw to succeed unless the requesting user is vpopmail or root.
# by default, qpsmtpd runs as the user 'qpsmtpd' and does not have permission.
eval 'use vpopmail';
if ($@) {
$self->log(LOGERROR, "skip: is vpopmail perl module installed?");
return;
};
}
my ($domain) = vpopmail::vlistdomains();
my $r = vauth_getpw('postmaster', $domain) or do {

View File

@ -79,7 +79,7 @@ sub register {
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,7 +89,8 @@ 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";
@ -99,17 +100,17 @@ sub get_db_handle {
};
$dbh->{ShowErrorStatement} = 1;
return $dbh;
};
}
sub get_vpopmail_user {
my ($self, $dbh, $user) = @_;
my ( $pw_name, $pw_domain ) = split '@', lc($user);
my ($pw_name, $pw_domain) = split /@/, lc($user);
if (!defined $pw_domain) {
$self->log(LOGINFO, "skip: missing domain: " . lc $user);
return;
};
}
$self->log(LOGDEBUG, "auth_vpopmail_sql: $user");
@ -124,10 +125,11 @@ FROM vpopmail
$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;
@ -139,11 +141,13 @@ sub auth_vmysql {
if (!$u->{pw_passwd} && !$u->{pw_clear_passwd}) {
$self->log(LOGINFO, "fail: no such user");
return (DENY, "auth_vmysql - no such user");
};
}
# at this point, the user name has matched
return Qpsmtpd::Auth::validate_password( $self,
return
Qpsmtpd::Auth::validate_password(
$self,
src_clear => $u->{pw_clear_passwd},
src_crypt => $u->{pw_passwd},
attempt_clear => $passClear,

View File

@ -6,7 +6,7 @@ use warnings;
use Qpsmtpd::Constants;
use IO::Socket;
use version;
my $VERSION = qv('1.0.3');
my $VERSION = qv('1.0.4');
sub register {
my ($self, $qp, %args) = @_;
@ -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) {
$self->log(LOGINFO, "skip: vpopmaild does not support cram-md5");
return DECLINED;
}
# create socket
my $vpopmaild_socket = IO::Socket::INET->new(
PeerAddr => $self->{_vpopmaild_host},
PeerPort => $self->{_vpopmaild_port},
Proto => 'tcp',
Type => SOCK_STREAM
) or do {
$self->log(LOGERROR, "skip: socket connection to vpopmaild failed");
return DECLINED;
};
my $socket = $self->get_socket() or return DECLINED;
$self->log(LOGDEBUG, "attempting $method");
# Get server greeting (+OK)
my $connect_response = <$vpopmaild_socket>;
if ( ! $connect_response ) {
$self->log(LOGERROR, "skip: no connection response");
close($vpopmaild_socket);
return DECLINED;
};
my $response = $self->get_response( $socket, '' )
or return DECLINED;
if ( $connect_response !~ /^\+OK/ ) {
$self->log(LOGERROR, "skip: bad connection response: $connect_response");
close($vpopmaild_socket);
return DECLINED;
};
print $vpopmaild_socket "login $user $passClear\n\r"; # send login details
my $login_response = <$vpopmaild_socket>; # get response from server
close($vpopmaild_socket);
if ( ! $login_response ) {
$self->log(LOGERROR, "skip: no login response");
return DECLINED;
};
# check for successful login (single line (+OK) or multiline (+OK+))
if ( $login_response =~ /^\+OK/ ) {
$self->log(LOGINFO, "pass: clear");
return (OK, 'auth_vpopmaild');
};
chomp $login_response;
$self->log(LOGNOTICE, "fail: $login_response");
if ($response !~ /^\+OK/) {
$self->log(LOGERROR, "skip, bad connection response: $response");
close $socket;
return DECLINED;
}
print $socket "login $user $passClear\n\r"; # send login details
$response = $self->get_response( $socket, "login $user $passClear\n\r" )
or return DECLINED;
close $socket;
# check for successful login (single line (+OK) or multiline (+OK+))
if ($response =~ /^\+OK/) {
$self->log(LOGINFO, "pass, clear");
return (OK, 'auth_vpopmaild');
}
chomp $response;
$self->log(LOGNOTICE, "fail, $response");
return DECLINED;
}
sub get_response {
my ($self, $socket, $send) = @_;
print $socket $send if $send; # send request
my $response = <$socket>; # get response
chomp $response;
if ( ! defined $response ) {
$self->log(LOGERROR, "error, no connection response");
close $socket;
return;
}
if ($response =~ /^([ -~\n\r]+)$/) { # match ascii printable
$response = $1; # $response now untainted
}
else {
$self->log(LOGERROR, "error, response unsafe.");
};
return $response;
};
sub get_socket {
my ($self) = @_;
# create socket
my $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

View File

@ -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,35 +44,36 @@ 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) = @_;
return DECLINED if $self->is_immune();
my @badmailfrom = $self->qp->config('badmailfrom');
if (defined $self->{_badmailfrom_config}) { # testing
@badmailfrom = @{$self->{_badmailfrom_config}};
};
return DECLINED if $self->is_immune();
}
return DECLINED if $self->is_immune_sender($sender, \@badmailfrom);
my $host = lc $sender->host;
@ -70,58 +85,55 @@ sub hook_mail {
next unless $bad;
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) = @_;
if ( $bad =~ /[\/\^\$\*\+]/ ) { # it's a regexp
if ($bad =~ /[\/\^\$\*\+\!\%\?\\]/) { # it's a regexp
if ($from =~ /$bad/) {
$self->log(LOGDEBUG, "badmailfrom pattern ($bad) match for $from");
return 1 if $from =~ /$bad/;
return 1;
}
return;
};
}
$bad = lc $bad;
if ($bad !~ m/\@/) {
$self->log(LOGWARN, "badmailfrom: bad config: no \@ sign in $bad");
return;
};
}
if (substr($bad, 0, 1) eq '@') {
return 1 if $bad eq "\@$host";
return;
};
}
return if $bad ne $from;
return 1;
};
sub 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) = @_;
if (!scalar @$badmf) {
$self->log(LOGDEBUG, 'skip: empty list');
$self->log(LOGDEBUG, 'skip, empty list');
return 1;
};
}
if (!$sender || $sender->format eq '<>') {
$self->log(LOGDEBUG, 'skip: null sender');
$self->log(LOGDEBUG, 'skip, null sender');
return 1;
};
}
if (!$sender->host || !$sender->user) {
$self->log(LOGDEBUG, 'skip: missing user or host');
$self->log(LOGDEBUG, 'skip, missing user or host');
return 1;
};
}
return;
};
}

83
plugins/badmailfromto Normal file
View File

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

View File

@ -55,7 +55,7 @@ sub hook_rcpt {
or return (DECLINED);
my @badrcptto = $self->qp->config("badrcptto") or do {
$self->log(LOGINFO, "skip: empty config");
$self->log(LOGINFO, "skip, empty config");
return (DECLINED);
};
@ -64,13 +64,15 @@ sub hook_rcpt {
my ($bad, $reason) = split /\s+/, $line, 2;
next if !$bad;
if ($self->is_match($to, lc($bad), $host)) {
$self->adjust_karma(-2);
if ($reason) {
return (DENY, "mail to $bad not accepted here");
}
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);
@ -79,19 +81,19 @@ sub hook_rcpt {
sub is_match {
my ($self, $to, $bad, $host) = @_;
if ( $bad =~ /[\/\^\$\*\+\!\%]/ ) { # it's a regexp
if ($bad =~ /[\/\^\$\*\+\!\%\?\\]/) { # it's a regexp
$self->log(LOGDEBUG, "badmailfrom pattern ($bad) match for $to");
if ($to =~ /$bad/i) {
$self->log(LOGINFO, 'fail: pattern match');
return 1;
};
}
return;
};
}
if ($bad !~ m/\@/) {
$self->log(LOGERROR, "badrcptto: bad config: no \@ sign in $bad");
return;
};
}
$bad = lc $bad;
$to = lc $to;
@ -100,16 +102,16 @@ sub is_match {
if ($bad eq "\@$host") {
$self->log(LOGINFO, 'fail: host match');
return 1;
};
}
return;
};
}
if ($bad eq $to) {
$self->log(LOGINFO, 'fail: rcpt match');
return 1;
}
return;
};
}
sub get_host_and_to {
my ($self, $recipient) = @_;
@ -117,13 +119,13 @@ sub get_host_and_to {
if (!$recipient) {
$self->log(LOGERROR, 'skip: no recipient!');
return;
};
}
if (!$recipient->host || !$recipient->user) {
$self->log(LOGINFO, 'skip: missing host or user');
return;
};
}
my $host = lc $recipient->host;
return ($host, lc($recipient->user) . '@' . $host);
};
}

98
plugins/bogus_bounce Normal file
View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -31,12 +31,13 @@ use Qpsmtpd::Constants;
use Time::HiRes qw(gettimeofday tv_interval);
sub register {
my ($self, $qp) = shift, shift;
my ($self, $qp) = (shift, shift);
if (@_ == 1) { # backwards compatible
$self->{_args}{loglevel} = shift;
if ($self->{_args}{loglevel} =~ /\D/) {
$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) {
@ -44,22 +45,20 @@ sub register {
}
else {
$self->{_args} = {@_}; # named args, inherits loglevel
};
}
sub hook_pre_connection {
my $self = shift;
$self->{_connection_start} = [gettimeofday];
$self->log(LOGDEBUG, "started at " . $self->{_connection_start} );
return (DECLINED);
# 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_connect {
sub connect_handler {
my $self = shift;
# this method is needed to function with the tcpserver deployment model
return (DECLINED) if defined $self->{_connection_start};
return DECLINED
if ($self->hook_name eq 'connect' && defined $self->{_connection_start});
$self->{_connection_start} = [gettimeofday];
$self->log(LOGDEBUG, "started at " . $self->{_connection_start} );
$self->log(LOGDEBUG, "started at " . scalar gettimeofday);
return (DECLINED);
}
@ -69,7 +68,7 @@ sub hook_post_connection {
if (!$self->{_connection_start}) {
$self->log(LOGERROR, "Start time not set?!");
return (DECLINED);
};
}
my $elapsed = tv_interval($self->{_connection_start}, [gettimeofday]);

View File

@ -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,7 +22,7 @@ use warnings;
use Qpsmtpd::Constants;
sub register {
my ($self, $qp ) = shift, shift;
my ($self, $qp) = (shift, shift);
$self->{_unrec_cmd_max} = shift || 4;
@ -31,29 +31,21 @@ sub register {
}
}
sub hook_connect {
my $self = shift;
$self->connection->notes('unrec_cmd_count', 0);
return DECLINED;
}
sub hook_unrecognized_command {
my ($self, $cmd) = @_[0, 2];
$self->log(LOGINFO, "Unrecognized command '$cmd'");
my $badcmdcount =
$self->connection->notes( 'unrec_cmd_count',
($self->connection->notes('unrec_cmd_count') || 0) + 1
);
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?");
}
my $count = $self->connection->notes('unrec_cmd_count') || 0;
$count = $count + 1;
$self->connection->notes('unrec_cmd_count', $count);
if ($count < $self->{_unrec_cmd_max}) {
$self->log(LOGINFO, "'$cmd', ($count)");
return DECLINED;
}
$self->log(LOGINFO, "fail, '$cmd' ($count)");
return (DENY_DISCONNECT,
"Closing connection, $count unrecognized commands. Perhaps you should read RFC 2821?"
);
}

535
plugins/dkim Normal file
View File

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

478
plugins/dmarc Normal file
View File

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

View File

@ -1,4 +1,5 @@
#!perl -w
=head1 NAME
dns_whitelist_soft - dns-based whitelist override for other qpsmtpd plugins
@ -48,17 +49,28 @@ 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 $remote_ip = $self->qp->connection->remote_ip;
my %whitelist_zones = map { (split /\s+/, $_, 2)[0,1] }
$self->qp->config('whitelist_zones');
my %whitelist_zones =
map { (split /\s+/, $_, 2)[0, 1] } $self->qp->config('whitelist_zones');
return DECLINED unless %whitelist_zones;
my $reversed_ip = join(".", reverse(split(/\./, $remote_ip)));
my $reversed_ip = join('.', reverse(split(/\./, $remote_ip)));
# we queue these lookups in the background and just fetch the
# results in the first rcpt handler
@ -68,11 +80,10 @@ sub hook_connect {
for my $dnsbl (keys %whitelist_zones) {
$self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl in the background");
$sel->add($res->bgsend("$reversed_ip.$dnsbl", "TXT"));
$sel->add($res->bgsend("$reversed_ip.$dnsbl", 'TXT'));
}
$self->connection->notes('whitelist_sockets', $sel);
return DECLINED;
}
@ -81,23 +92,24 @@ sub process_sockets {
my $conn = $self->connection;
return $conn->notes('whitelisthost')
if $conn->notes('whitelisthost');
return $conn->notes('whitelisthost') if $conn->notes('whitelisthost');
my $res = new Net::DNS::Resolver;
my $sel = $conn->notes('whitelist_sockets') or return "";
my $result;
my $sel = $conn->notes('whitelist_sockets') or return '';
$self->log(LOGDEBUG, "waiting for whitelist dns");
# don't wait more than 4 seconds here
my @ready = $sel->can_read(4);
$self->log(LOGDEBUG, "DONE waiting for whitelist dns, got ",
scalar @ready, " answers ...") ;
$self->log(LOGDEBUG,
"done waiting for whitelist dns, got ",
scalar @ready,
" answers ...");
return '' unless @ready;
my $result;
for my $socket (@ready) {
my $query = $res->bgread($socket);
$sel->remove($socket);
@ -108,12 +120,12 @@ sub process_sockets {
if ($query) {
my $a_record = 0;
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;
($whitelist) = ($name =~ m/(?:\d+\.){4}(.*)/) unless $whitelist;
$whitelist = $name unless $whitelist;
$self->log(LOGDEBUG, "name ", $rr->name);
next unless $rr->type eq "TXT";
$self->log(LOGDEBUG, 'name ', $rr->name);
next unless $rr->type eq 'TXT';
$self->log(LOGDEBUG, "got txt record");
$result = $rr->txtdata and last;
}
@ -121,10 +133,11 @@ sub process_sockets {
}
else {
$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);
@ -132,6 +145,7 @@ sub process_sockets {
}
if ($sel->count) {
# loop around if we have dns blacklists left to see results from
return $self->process_sockets();
}
@ -142,12 +156,11 @@ sub process_sockets {
$conn->notes('whitelist_sockets', undef);
return $conn->notes('whitelisthost', $result);
}
sub hook_rcpt {
my ($self, $transaction, $rcpt, %param) = @_;
my $ip = $self->qp->connection->remote_ip || return (DECLINED);
my $ip = $self->qp->connection->remote_ip or return (DECLINED);
my $note = $self->process_sockets;
if ($note) {
$self->log(LOGNOTICE, "Host $ip is whitelisted: $note");
@ -155,4 +168,3 @@ sub hook_rcpt {
return DECLINED;
}
1;

View File

@ -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) {
$self->{_args}{reject_type} = shift; # backwards compatibility
}
else {
$self->{_args} = {@_};
};
}
# explicitly state legacy reject behavior
if (!defined $self->{_args}{reject_type}) {
$self->{_args}{reject_type} = 'perm';
}
if (!defined $self->{_args}{reject}) {
$self->{_args}{reject} = 1;
}
}
sub hook_connect {
my ($self, $transaction) = @_;
# perform RBLSMTPD checks to mimic Dan Bernstein's rblsmtpd
return DECLINED if $self->is_set_rblsmtpd();
# perform RBLSMTPD checks to mimic DJB's rblsmtpd
# RBLSMTPD being non-empty means it contains the failure message to return
if (defined $ENV{'RBLSMTPD'} && $ENV{'RBLSMTPD'} ne '') {
my $reject = $self->{_args}{reject};
return $self->return_env_message() if $reject && $reject eq 'connect';
}
return DECLINED if $self->is_immune();
return DECLINED if $self->is_set_rblsmtpd();
return DECLINED if $self->ip_whitelisted();
my %dnsbl_zones = map { (split /:/, $_, 2)[0,1] } $self->qp->config('dnsbl_zones');
if ( ! %dnsbl_zones ) {
$self->log( LOGDEBUG, "skip: no list configured");
return DECLINED;
my $dnsbl_zones = $self->get_dnsbl_zones() or return DECLINED;
my $resolv = $self->get_resolver() or return DECLINED;
for my $dnsbl (keys %$dnsbl_zones) {
my $query = $self->get_query($dnsbl) or do {
if ($resolv->errorstring ne 'NXDOMAIN') {
$self->log(LOGERROR, "$dnsbl query failed: ",
$resolv->errorstring);
}
next;
};
my $a_record = 0;
my $result;
foreach my $rr ($query->answer) {
if ($rr->type eq 'A') {
$result = $rr->name;
$self->log(LOGDEBUG,
"found A for $result with IP " . $rr->address);
}
elsif ($rr->type eq 'TXT') {
$self->log(LOGDEBUG, "found TXT, " . $rr->txtdata);
$result = $rr->txtdata;
}
next if !$result;
$self->adjust_karma(-1);
if (!$dnsbl) { ($dnsbl) = ($result =~ m/(?:\d+\.){4}(.*)/); }
if (!$dnsbl) { $dnsbl = $result; }
if ($a_record) {
if (defined $dnsbl_zones->{$dnsbl}) {
my $smtp_msg = $dnsbl_zones->{$dnsbl};
my $remote_ip = $self->qp->connection->remote_ip;
$smtp_msg =~ s/%IP%/$remote_ip/g;
return $self->get_reject($smtp_msg, $dnsbl);
}
return $self->get_reject("Blocked by $dnsbl");
}
return $self->get_reject($result, $dnsbl);
}
}
$self->log(LOGINFO, 'pass');
return DECLINED;
}
sub get_dnsbl_zones {
my $self = shift;
my %dnsbl_zones =
map { (split /:/, $_, 2)[0, 1] } $self->qp->config('dnsbl_zones');
if (!%dnsbl_zones) {
$self->log(LOGDEBUG, "skip, no zones");
return;
}
$self->{_dnsbl}{zones} = \%dnsbl_zones;
return \%dnsbl_zones;
}
sub get_query {
my ($self, $dnsbl) = @_;
my $remote_ip = $self->qp->connection->remote_ip;
my $reversed_ip = join('.', reverse(split(/\./, $remote_ip)));
# we queue these lookups in the background and fetch the
# results in the first rcpt handler
my $res = new Net::DNS::Resolver;
$res->tcp_timeout(30);
$res->udp_timeout(30);
my $sel = IO::Select->new();
my $dom;
for my $dnsbl (keys %dnsbl_zones) {
# fix to find A records, if the dnsbl_zones line has a second field 20/1/04 ++msp
$dom->{"$reversed_ip.$dnsbl"} = 1;
if (defined($dnsbl_zones{$dnsbl})) {
$self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for A record in the background");
$sel->add($res->bgsend("$reversed_ip.$dnsbl"));
}
else {
$self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for TXT record in the background");
$sel->add($res->bgsend("$reversed_ip.$dnsbl", "TXT"));
}
if (defined $self->{_dnsbl}{zones}{$dnsbl}) {
$self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for A record");
return $self->{_resolver}->query("$reversed_ip.$dnsbl");
}
$self->connection->notes('dnsbl_sockets', $sel);
$self->connection->notes('dnsbl_domains', $dom);
return DECLINED;
$self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for TXT record");
return $self->{_resolver}->query("$reversed_ip.$dnsbl", 'TXT');
}
sub is_set_rblsmtpd {
@ -185,7 +254,7 @@ sub is_set_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");
@ -194,150 +263,51 @@ 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
};
}
sub ip_whitelisted {
my $self = shift;
my $remote_ip = shift || $self->qp->connection->remote_ip;
return
grep { s/\.?$/./; $_ eq substr($remote_ip . '.', 0, length $_) }
$self->qp->config('dnsbl_allow');
};
sub process_sockets {
my ($self) = @_;
my $conn = $self->connection;
return $conn->notes('dnsbl') if $conn->notes('dnsbl');
my %dnsbl_zones = map { (split /:/, $_, 2)[0,1] } $self->qp->config('dnsbl_zones');
my $sel = $conn->notes('dnsbl_sockets') or return '';
my $dom = $conn->notes('dnsbl_domains');
my $remote_ip = $self->qp->connection->remote_ip;
my $result;
my $res = new Net::DNS::Resolver;
$res->tcp_timeout(30);
$res->udp_timeout(30);
$self->log(LOGDEBUG, "waiting for dnsbl dns");
# don't wait more than 8 seconds here
my @ready = $sel->can_read(8);
$self->log(LOGDEBUG, "DONE waiting for dnsbl dns, got ", scalar @ready, " answers ...");
return '' unless @ready;
for my $socket (@ready) {
my $query = $res->bgread($socket);
$sel->remove($socket);
undef $socket;
my $dnsbl;
if ($query) {
my $a_record = 0;
foreach my $rr ($query->answer) {
my $name = $rr->name;
$self->log(LOGDEBUG, "name $name");
next unless $dom->{$name};
$self->log(LOGDEBUG, "name $name was queried");
$a_record = 1 if $rr->type eq "A";
($dnsbl) = ($name =~ m/(?:\d+\.){4}(.*)/) unless $dnsbl;
$dnsbl = $name unless $dnsbl;
next unless $rr->type eq "TXT";
$self->log(LOGDEBUG, "got txt record");
$result = $rr->txtdata and last;
return grep {
s/\.?$/./;
$_ eq substr($remote_ip . '.', 0, length $_)
} $self->qp->config('dnsbl_allow');
}
#$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;
sub return_env_message {
my $self = shift;
my $result = $ENV{'RBLSMTPD'};
my $remote_ip = $self->qp->connection->remote_ip;
$result =~ s/%IP%/$remote_ip/g;
}
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);
my $msg = $self->qp->config('dnsbl_rejectmsg');
$self->log(LOGINFO, "fail, $msg");
return ($self->get_reject_type(), join(' ', $msg, $result));
}
sub hook_rcpt {
my ($self, $transaction, $rcpt, %param) = @_;
return DECLINED if $self->is_immune();
# RBLSMTPD being non-empty means it contains the failure message to return
if (defined $ENV{'RBLSMTPD'} && $ENV{'RBLSMTPD'} ne '') {
my $result = $ENV{'RBLSMTPD'};
my $remote_ip = $self->qp->connection->remote_ip;
$result =~ s/%IP%/$remote_ip/g;
my $msg = $self->qp->config('dnsbl_rejectmsg');
$self->log(LOGINFO, "fail: $msg");
return ( $self->get_reject_type(), join(' ', $msg, $result));
}
my $note = $self->process_sockets or return DECLINED;
if ( $self->ip_whitelisted() ) {
$self->log(LOGINFO, "skip: whitelisted");
return DECLINED;
};
if ($rcpt->user =~ /^(?:postmaster|abuse|mailer-daemon|root)$/i) {
$self->log(LOGWARN, "skip: don't blacklist special account: ".$rcpt->user);
return DECLINED;
$self->log(LOGWARN,
"skip, don't blacklist special account: " . $rcpt->user);
# clear the naughty connection note here, if desired.
$self->is_naughty(0);
}
$self->log(LOGINFO, 'fail');
return ( $self->get_reject_type(), $note);
}
sub hook_disconnect {
my ($self, $transaction) = @_;
$self->connection->notes('dnsbl_sockets', undef);
return DECLINED;
}
sub get_reject_type {
sub get_resolver {
my $self = shift;
my $default = shift || DENY;
my $deny = $self->{_args}{reject_type} or return $default;
return $self->{_args}{reject_type} eq 'temp' ? DENYSOFT
: $self->{_args}{reject_type} eq 'disconnect' ? DENY_DISCONNECT
: $default;
};
return $self->{_resolver} if $self->{_resolver};
$self->log(LOGDEBUG, "initializing Net::DNS::Resolver");
$self->{_resolver} = Net::DNS::Resolver->new(dnsrch => 0);
my $timeout = $self->{_args}{timeout} || 30;
$self->{_resolver}->tcp_timeout($timeout);
$self->{_resolver}->udp_timeout($timeout);
return $self->{_resolver};
}

View File

@ -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
@ -62,7 +68,7 @@ sub init {
if ($args{'warn_only'}) {
$self->log(LOGNOTICE, "warn_only is deprecated. Use reject instead");
$self->{'reject'} = 0;
};
}
}
sub register {
@ -74,49 +80,51 @@ sub register {
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();
if (!$transaction->header->get('DomainKey-Signature')) {
$self->log(LOGINFO, "skip, unsigned");
return DECLINED;
}
my $body = $self->assemble_body($transaction);
my $message = load Mail::DomainKeys::Message(
my $message =
load Mail::DomainKeys::Message(
HeadString => $transaction->header->as_string,
BodyReference => $body) or do {
$self->log(LOGWARN, "skip: unable to load message"),
return DECLINED;
BodyReference => $body)
or do {
$self->log(LOGWARN, "skip, unable to load message"), return DECLINED;
};
# no sender domain means no verification
if (!$message->senderdomain) {
$self->log(LOGINFO, "skip: failed to parse sender domain"),
$self->log(LOGINFO, "skip, failed to parse sender domain"),
return DECLINED;
};
}
my $status = $self->get_message_status($message);
if (defined $status) {
$transaction->header->replace("DomainKey-Status", $status);
$self->log(LOGINFO, "pass: $status");
#$transaction->header->add("DomainKey-Status", $status, 0);
$self->store_auth_results('domainkey=' . $status);
$self->log(LOGINFO, "pass, $status");
return DECLINED;
};
}
$self->log(LOGERROR, "fail: signature failed to verify");
$self->log(LOGERROR, "fail, signature invalid");
return DECLINED if !$self->{reject};
my $deny = $self->{reject_type} eq 'temp' ? DENYSOFT : DENY;
return ($deny, "DomainKeys signature failed to verify");
return ($deny, "DomainKeys signature validation failed");
}
sub get_message_status {
@ -124,33 +132,32 @@ sub get_message_status {
if ($message->testing) {
return "testing"; # key testing, don't do anything else
};
}
if ($message->signed && $message->verify) {
return $message->signature->status; # verified: add good header
};
}
# not signed or not verified
my $policy = fetch Mail::DomainKeys::Policy(
Protocol => 'dns',
Domain => $message->senderdomain
);
my $policy =
fetch Mail::DomainKeys::Policy(Protocol => 'dns',
Domain => $message->senderdomain);
if (!$policy) {
return $message->signed ? "non-participant" : "no signature";
};
}
if ($policy->testing) {
return "testing"; # Don't do anything else
};
}
if ($policy->signall) {
return undef; # policy requires all mail to be signed
};
}
# $policy->signsome
return "no signature"; # not signed and domain doesn't sign all
};
}
sub assemble_body {
my ($self, $transaction) = @_;
@ -163,4 +170,4 @@ sub assemble_body {
push @body, $line;
}
return \@body;
};
}

View File

@ -26,6 +26,7 @@ sub hook_mail_pre {
unless ($addr =~ /^<.*>$/) {
$self->log(LOGINFO, "added MAIL angle brackets");
$addr = '<' . $addr . '>';
$self->adjust_karma(-1);
}
return (OK, $addr);
}
@ -35,6 +36,7 @@ sub hook_rcpt_pre {
unless ($addr =~ /^<.*>$/) {
$self->log(LOGINFO, "added RCPT angle brackets");
$addr = '<' . $addr . '>';
$self->adjust_karma(-1);
}
return (OK, $addr);
}

View File

@ -6,31 +6,31 @@ dspam - dspam integration for qpsmtpd
=head1 DESCRIPTION
qpsmtpd plugin that uses dspam to classify messages. Can use SpamAssassin to
train dspam.
Uses dspam to classify messages. Use B<spamassassin>, B<karma>, and B<naughty>
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
good news is; dspam learns very, very fast.
If you enable dspam rejection without training first, you will lose valid
mail. The dspam false positive rate is high when untrained. The good news is;
dspam learns very, very fast.
To get dspam into a useful state, it must be trained. The best method way to
train dspam is to feed it two large equal sized corpuses of spam and ham from
your mail server. The dspam authors suggest avoiding public corpuses. I train
dspam as follows:
The best method way to train dspam is to feed it two large equal sized
corpuses of spam and ham from your mail server. The dspam authors suggest
avoiding public corpuses. I train dspam as follows:
=over 4
=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
Dspam can be trained by SpamAssassin. This relationship between them requires
attention to several important details:
=head2 autolearn [ naughty | karma | spamassassin | any ]
=over 4
=item 1
=item naughty
dspam must be listed B<after> spamassassin in the config/plugins file.
Because SA runs first, I crank the SA reject_threshold up above 100 so that
all spam messages will be used to train dspam.
learn naughty messages as spam (see plugins/naughty)
Once dspam is trained and errors are rare, I plan to run dspam first and
reduce the SA load.
=item karma
=item 2
learn messages with negative karma as spam (see plugins/karma)
Autolearn must be enabled and configured in SpamAssassin. SA autolearn
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.
=item spamassassin
If you are using learn_from_sa and reject, then messages that exceed the SA
threshholds will cause dspam to reject them. Again I say, make sure them SA
autolearn threshholds are set high enough to avoid false positives.
learn from spamassassins messages with autolearn=(ham|spam). See SPAMASSASSIN.
=item 3
=item any
dspam must be configured and working properly. I have modified the following
dspam values on my system:
all of the above, and any future tests too!
=back
=head2 reject
Set to a floating point value between 0 and 1.00 where 0 is no confidence
and 1.0 is 100% confidence.
If dspam's confidence is greater than or equal to this threshold, the
message will be rejected. The default is 1.00.
dspam reject .95
To only reject mail if dspam and spamassassin both think the message is spam,
set I<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
is dramatically slowed by MyISAM table locks and dspam requires lots
When using the dspam MySQL backend, use InnoDB tables. DSPAM training
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}{reject} = defined $args{reject} ? $args{reject} : 1;
$self->{_args}{reject_type} = $args{reject_type} || 'perm';
$self->{_args} = {@_};
$self->{_args}{reject} = 1 if !defined $self->{_args}{reject};
$self->{_args}{reject_type} ||= 'perm';
$self->{_args}{dspam_bin} ||= '/usr/local/bin/dspam';
$self->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 {
my ($self, $transaction) = @_;
sub get_dspam_bin {
my $self = shift;
my $bin = $self->{_args}{dspam_bin};
if (!-e $bin) {
$self->log(LOGERROR,
"error, dspam CLI binary not found: install dspam and/or set dspam_bin"
);
return;
}
if (!-x $bin) {
$self->log(LOGERROR, "error, no permission to run $bin");
return;
}
return $bin;
}
sub data_post_handler {
my $self = shift;
my $transaction = shift || $self->qp->transaction;
return (DECLINED) if $self->is_immune();
$self->log(LOGDEBUG, "check_dspam");
if ($transaction->data_size > 500_000) {
$self->log(LOGINFO, "skip: message too large (" . $transaction->data_size . ")" );
$self->log(LOGINFO, "skip, too big (" . $transaction->data_size . ")");
return (DECLINED);
};
}
my $username = $self->select_username( $transaction );
my $message = $self->assemble_message($transaction);
my $filtercmd = $self->get_filter_cmd( $transaction, $username );
my $user = $self->select_username($transaction);
my $bin = $self->{_args}{dspam_bin};
my $filtercmd =
"$bin --user $user --mode=tum --process --deliver=summary --stdout";
$self->log(LOGDEBUG, $filtercmd);
my $response = $self->dspam_process( $filtercmd, $message );
if ( ! $response ) {
$self->log(LOGWARN, "skip: no response from dspam. Check logs for errors.");
my $response = $self->dspam_process($filtercmd, $transaction);
if (!$response->{result}) {
$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
# 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);
$transaction->notes('dspam', $response);
# the signature header is required if you intend to train dspam later.
# In dspam.conf, set: Preference "signatureLocation=headers"
$transaction->header->add('X-DSPAM-Signature', $sig, 0);
$self->attach_headers($response, $transaction);
$self->autolearn($response, $transaction);
return (DECLINED);
};
return $self->log_and_return($transaction);
}
sub select_username {
my ($self, $transaction) = @_;
@ -218,189 +277,461 @@ sub select_username {
$self->log(LOGDEBUG, "Message has $recipient_count recipients");
if ($recipient_count > 1) {
$self->log(LOGINFO, "skipping user prefs, $recipient_count recipients detected.");
$self->log(LOGINFO,
"multiple recipients ($recipient_count), ignoring user prefs");
return getpwuid($>);
};
}
# use the recipients email address as username. This enables user prefs
my $username = ($transaction->recipients)[0]->address;
return lc($username);
};
}
sub assemble_message {
my ($self, $transaction) = @_;
$transaction->body_resetpos;
my $message = "X-Envelope-From: "
my $message =
"X-Envelope-From: "
. $transaction->sender->format . "\n"
. $transaction->header->as_string . "\n\n";
while (my $line = $transaction->body_getline) { $message .= $line; };
$transaction->body_resetpos;
while (my $line = $transaction->body_getline) { $message .= $line; }
$message = join(CRLF, split /\n/, $message);
return $message . CRLF;
}
sub parse_response {
my $self = shift;
my $response = shift or do {
$self->log(LOGDEBUG, "missing dspam response!");
return;
};
# example DSPAM results:
# user@example.com; result="Spam"; class="Spam"; probability=1.0000; confidence=1.00; signature=N/A
# smtpd; result="Innocent"; class="Innocent"; probability=0.0023; confidence=1.00; signature=4f8dae6a446008399211546
#return $self->parse_response_regexp( $response ); # probably slower
my ($user, $result, $class, $prob, $conf, $sig) = split /; /, $response;
(undef, $result) = split /=/, $result;
(undef, $class) = split /=/, $class;
(undef, $prob) = split /=/, $prob;
(undef, $conf) = split /=/, $conf;
(undef, $sig) = split /=/, $sig;
$result = substr($result, 1, -1); # strip off quotes
$class = substr($class, 1, -1);
return {
class => $class,
result => $result,
probability => $prob,
confidence => $conf,
signature => $sig,
};
}
sub parse_response_regexp {
my ($self, $response) = @_;
my ($result, $class, $prob, $conf, $sig) = $response =~ /
result=\"(Spam|Innocent)\";\s
class=\"(Spam|Innocent)\";\s
probability=([\d\.]+);\s
confidence=([\d\.]+);\s
signature=(.*)
/x;
return {
class => $class,
result => $result,
probability => $prob,
confidence => $conf,
signature => $sig,
};
}
sub dspam_process {
my ( $self, $filtercmd, $message ) = @_;
my ($self, $filtercmd, $transaction) = @_;
#return $self->dspam_process_open2( $filtercmd, $message );
my $response = $self->dspam_process_backticks($filtercmd);
my ($in_fh, $out_fh);
if (! open($in_fh, '-|')) {
open($out_fh, "|$filtercmd") or die "Can't run $filtercmd: $!\n";
#my $response = $self->dspam_process_open2( $filtercmd, $transaction );
#my $response = $self->dspam_process_fork( $filtercmd );
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) = @_;
my $message = $self->assemble_message($transaction);
# not sure why, but this is not as reliable as I'd like. What's a dspam
# error -5 mean anyway?
use FileHandle;
use IPC::Open2;
my ($dspam_in, $dspam_out);
my $pid = open2($dspam_out, $dspam_in, $filtercmd);
print $dspam_in $message;
close $dspam_in;
use IPC::Open3;
my ($read, $write, $err);
use Symbol 'gensym';
$err = gensym;
my $pid = open3($write, $read, $err, $filtercmd);
print $write $message;
close $write;
#my $response = join('', <$dspam_out>); # get full response
my $response = <$dspam_out>; # get first line only
my $response = <$read>; # get first line only
waitpid $pid, 0;
my $child_exit_status = $? >> 8;
#$self->log(LOGINFO, "exit status: $child_exit_status");
if ($response) {
chomp $response;
$self->log(LOGDEBUG, $response);
}
my $err_msg = <$err>;
if ($err_msg) {
$self->log(LOGDEBUG, $err_msg);
}
return $response;
};
}
sub dspam_reject {
my ($self, $transaction) = @_;
sub log_and_return {
my $self = shift;
my $transaction = shift || $self->qp->transaction;
my $d = $self->get_dspam_results($transaction) or return DECLINED;
if (!$d->{class}) {
$self->log(LOGWARN, "skip: no dspam class detected");
$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') {
return $self->dspam_reject_agree( $transaction, $d );
};
return $self->reject_agree($transaction);
}
if ($d->{class} eq 'Innocent') {
$self->log(LOGINFO, "pass: $status");
$self->log(LOGINFO, "pass, $status");
return DECLINED;
};
}
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) {
$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) {
$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)");
my $deny = $self->{_args}{reject_type} eq 'temp' ? DENYSOFT : DENY;
$self->log(LOGINFO, "fail, $d->{class}, ($d->{confidence} confident)");
my $deny = $self->get_reject_type();
return Qpsmtpd::DSN->media_unsupported($deny, 'dspam says, no spam please');
}
sub dspam_reject_agree {
my ($self, $transaction, $d ) = @_;
sub reject_agree {
my ($self, $transaction) = @_;
my $sa = $transaction->notes('spamassassin');
my $d = $transaction->notes('dspam');
my $status = "$d->{class}, $d->{confidence} c";
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' ) {
$self->log(LOGINFO, "fail: agree, $status");
return Qpsmtpd::DSN->media_unsupported(DENY,'we agree, no spam please');
};
if ($d->{class} eq 'Spam') {
if ($sa->{is_spam} eq 'Yes') {
$self->adjust_karma(-2);
$self->log(LOGINFO, "fail, agree, $status");
my $reject = $self->get_reject_type();
return ($reject, 'we agree, no spam please');
}
$self->log(LOGINFO, "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')) {
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}) {
$message .= ", prob: $d{probability}, conf: $d{confidence}";
};
}
$self->log(LOGDEBUG, $message);
$transaction->notes('dspam', \%d);
return \%d;
};
}
sub get_filter_cmd {
my ($self, $transaction, $user) = @_;
sub attach_headers {
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 $min_score = $self->{_args}{learn_from_sa} or return $default;
my $cmd =
"$dspam_bin --user $user --mode=toe --source=error --class=innocent --deliver=summary --stdout";
my $response = $self->dspam_process($cmd, $transaction);
if ($response) {
$transaction->notes('dspam', $response);
}
else {
$transaction->notes(
'dspam',
{
class => 'Innocent',
result => 'Innocent',
confidence => 1
}
);
}
}
#$self->log(LOGDEBUG, "attempting to learn from SA");
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');
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";
if (!$sa || !$sa->{is_spam}) {
if (!$self->is_naughty()) {
$self->log(LOGERROR, "SA results missing"); # SA skips naughty
}
return;
}
elsif ( $sa->{is_spam} eq 'No' && $sa->{autolearn} eq 'ham' ) {
return "$dspam_bin --user $user --mode=tum --source=corpus --class=innocent --deliver=summary --stdout";
};
return $default;
};
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;
}

View File

@ -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 ]
@ -92,16 +92,21 @@ sub register {
@args,
'check-at' => \%check_at,
};
# backwards compat with old 'action' argument
if (defined $self->{_args}{action} && !defined $self->{_args}{reject}) {
$self->{_args}{reject} = $self->{_args}{action} =~ /^deny/i ? 1 : 0;
};
if ( defined $self->{_args}{'defer-reject'} && ! defined $self->{_args}{reject_type} ) {
$self->{_args}{reject_type} = $self->{_args}{action} == 'denysoft' ? 'temp' : 'perm';
};
}
if (defined $self->{_args}{'defer-reject'}
&& !defined $self->{_args}{reject_type})
{
$self->{_args}{reject_type} =
$self->{_args}{action} == 'denysoft' ? 'temp' : 'perm';
}
if (!defined $self->{_args}{reject_type}) {
$self->{_args}{reject_type} = 'perm';
};
}
# /end compat
if ($qp->{conn} && $qp->{conn}->isa('Apache2::Connection')) {
require APR::Const;
@ -131,11 +136,11 @@ sub apr_connect_handler {
my $rc = $socket->poll($c->pool, $timeout, APR::Const::POLLIN());
if ($rc == APR::Const::SUCCESS()) {
if ($self->{_args}{'defer-reject'}) {
$self->qp->connection->notes('earlytalker', 1);
$self->connection->notes('earlytalker', 1);
return DECLINED;
};
}
return $self->log_and_deny();
};
}
return $self->log_and_pass();
}
@ -152,7 +157,7 @@ sub apr_data_handler {
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'})) {
return $self->log_and_pass();
};
}
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;
}
@ -186,15 +199,15 @@ sub data_handler {
$in->add(\*STDIN) or return DECLINED;
if (!$in->can_read($self->{_args}{'wait'})) {
return $self->log_and_pass();
};
}
return $self->log_and_deny();
};
}
sub log_and_pass {
my $self = shift;
my $ip = $self->qp->connection->remote_ip || 'remote host';
$self->log(LOGINFO, "pass: $ip said nothing spontaneous");
$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->log(LOGNOTICE, "fail: $ip started talking before we said hello");
$self->connection->notes('earlytalker', 1);
$self->adjust_karma(-1);
return ( $self->get_reject_type(), $msg ) if $self->{_args}{reject};
return DECLINED;
my $log_mess = "remote started talking before we said hello";
my $smtp_msg = 'Connecting host started transmitting before SMTP greeting';
return $self->get_reject($smtp_msg, $log_mess);
}
sub mail_handler {
my ($self, $transaction) = @_;
return DECLINED unless $self->qp->connection->notes('earlytalker');
return DECLINED unless $self->connection->notes('earlytalker');
return $self->log_and_deny();
}
sub get_reject_type {
my $self = shift;
my $deny = $self->{_args}{reject_type} or return DENY;
return $deny eq 'temp' ? DENYSOFT
: $deny eq 'disconnect' ? DENY_DISCONNECT
: DENY;
};

308
plugins/fcrdns Normal file
View File

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

View File

@ -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
@ -197,26 +197,30 @@ my %DEFAULTS = (
sub register {
my ($self, $qp, %arg) = @_;
my $config = { %DEFAULTS,
my $config = {
%DEFAULTS,
map { split /\s+/, $_, 2 } $self->qp->config('denysoft_greylist'),
%arg };
%arg
};
if (my @bad = grep { !exists $PERMITTED_ARGS{$_} } sort keys %$config) {
$self->log(LOGALERT, "invalid parameter(s): " . join(',', @bad));
}
# backwards compatibility with deprecated 'mode' setting
if (defined $config->{mode} && !defined $config->{reject}) {
$config->{reject} = $config->{mode} =~ /testonly|off/i ? 0 : 1;
};
}
$self->{_args} = $config;
unless ($config->{recipient} || $config->{per_recipient}) {
$self->register_hook('mail', 'mail_handler');
} else {
}
else {
$self->register_hook('rcpt', 'rcpt_handler');
}
$self->prune_db();
if ($self->{_args}{upgrade}) {
$self->convert_db();
};
}
}
sub mail_handler {
@ -228,7 +232,7 @@ sub mail_handler {
if (!$self->{_args}{deny_late}) {
return (DENYSOFT, $msg);
};
}
$transaction->notes('greylist', $msg);
return DECLINED;
@ -236,13 +240,19 @@ sub mail_handler {
sub rcpt_handler {
my ($self, $transaction, $rcpt) = @_;
# Load per_recipient configs
my $config = { %{$self->{_args}},
map { split /\s+/, $_, 2 } $self->qp->config('denysoft_greylist', { rcpt => $rcpt }) };
my $config = {
%{$self->{_args}},
map { split /\s+/, $_, 2 }
$self->qp->config('denysoft_greylist', {rcpt => $rcpt})
};
# Check greylisting
my $sender = $transaction->sender;
my ($status, $msg) = $self->greylist($transaction, $sender, $rcpt, $config);
if ($status == DENYSOFT) {
# Deny here (per-rcpt) unless this is a <> sender, for smtp probes
return DENYSOFT, $msg if $sender->address;
$transaction->notes('greylist', $msg);
@ -253,8 +263,11 @@ sub rcpt_handler {
sub hook_data {
my ($self, $transaction) = @_;
return DECLINED unless $transaction->notes('greylist');
# Decline if ALL recipients are whitelisted
if (($transaction->notes('whitelistrcpt')||0) == scalar($transaction->recipients)) {
if (($transaction->notes('whitelistrcpt') || 0) ==
scalar($transaction->recipients))
{
$self->log(LOGWARN, "skip: all recipients whitelisted");
return DECLINED;
}
@ -264,8 +277,11 @@ sub hook_data {
sub greylist {
my ($self, $transaction, $sender, $rcpt, $config) = @_;
$config ||= $self->{_args};
$self->log(LOGDEBUG, "config: " .
join(',',map { $_ . '=' . $config->{$_} } sort keys %$config));
$self->log(LOGDEBUG,
"config: "
. join(',',
map { $_ . '=' . $config->{$_} } sort keys %$config)
);
return DECLINED if $self->is_immune();
return DECLINED if !$self->is_p0f_match();
@ -283,12 +299,13 @@ sub greylist {
$tied->{$key} = sprintf $fmt, time, 1, 0, 0;
$self->log(LOGWARN, "fail: initial DENYSOFT, unknown");
return $self->cleanup_and_return($tied, $lock);
};
}
my ($ts, $new, $black, $white) = split /:/, $tied->{$key};
$self->log(LOGDEBUG, "ts: " . localtime($ts) . ", now: " . localtime);
if ($white) {
# white IP - accept unless timed out
if (time - $ts < $config->{white_timeout}) {
$tied->{$key} = sprintf $fmt, time, $new, $black, ++$white;
@ -298,12 +315,13 @@ sub greylist {
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");
$self->log(LOGWARN,
"fail: black DENYSOFT - $black deferred connections");
return $self->cleanup_and_return($tied, $lock);
}
@ -318,48 +336,16 @@ sub greylist {
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) = @_;
untie $tied;
close $lock;
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;
@ -370,16 +356,16 @@ sub get_db_key {
if ($self->{_args}{remote_ip}) {
my $nip = Net::IP->new($self->qp->connection->remote_ip);
push @key, $nip->intip; # convert IP to integer
};
}
push @key, $sender->address || '' if $self->{_args}{sender};
push @key, $rcpt->address if $rcpt && $self->{_args}{recipient};
if (!scalar @key) {
$self->log(LOGERROR, "enable one of remote_ip, sender, or recipient!");
return;
};
}
return join ':', @key;
};
}
sub get_db_tie {
my ($self, $db, $lock) = @_;
@ -390,7 +376,7 @@ sub get_db_tie {
return;
};
return \%db;
};
}
sub get_db_location {
my $self = shift;
@ -406,10 +392,13 @@ sub get_db_location {
my $dbdir;
if ($config->{per_recipient_db}) {
$dbdir = $transaction->notes('per_rcpt_configdir');
};
}
my @candidate_dirs = ( $dbdir, $config->{db_dir},
"/var/lib/qpsmtpd/greylisting", "$QPHOME/var/db", "$QPHOME/config", '.' );
my @candidate_dirs = (
$dbdir, $config->{db_dir},
"/var/lib/qpsmtpd/greylisting",
"$QPHOME/var/db", "$QPHOME/config", '.'
);
for my $d (@candidate_dirs) {
next if !$d || !-d $d; # impossible
@ -422,7 +411,7 @@ sub get_db_location {
}
$self->log(LOGDEBUG, "using $db as greylisting database");
return $db;
};
}
sub get_db_lock {
my ($self, $db) = @_;
@ -455,7 +444,8 @@ sub get_db_lock_nfs {
lock_type => LOCK_EX | LOCK_NB,
blocking_timeout => 10, # 10 sec
stale_lock_timeout => 30 * 60, # 30 min
} or do {
}
or do {
$self->log(LOGCRIT, "nfs lockfile failed: $!");
return;
};
@ -466,7 +456,7 @@ sub get_db_lock_nfs {
};
return $lock;
};
}
sub convert_db {
my $self = shift;
@ -486,12 +476,12 @@ sub convert_db {
my $new_key = join ':', @parts;
$tied->{$new_key} = $tied->{$key};
delete $tied->{$key};
};
}
untie $tied;
close $lock;
$self->log(LOGINFO, "converted $converted of $count DB entries");
return $self->cleanup_and_return($tied, $lock, DECLINED);
};
}
sub prune_db {
my $self = shift;
@ -508,12 +498,12 @@ sub prune_db {
next if $age < $self->{_args}{white_timeout};
$pruned++;
delete $tied->{$key};
};
}
untie $tied;
close $lock;
$self->log(LOGINFO, "pruned $pruned of $count DB entries");
return $self->cleanup_and_return($tied, $lock, DECLINED);
};
}
sub p0f_match {
my $self = shift;
@ -524,7 +514,7 @@ sub p0f_match {
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});
@ -534,7 +524,7 @@ sub p0f_match {
if (!defined $valid_matches{$key}) {
$self->log(LOGERROR, "discarding invalid match key ($key)");
next;
};
}
my $value = $requested_matches{$key};
next if !defined $value; # bad config setting?
next if !defined $p0f->{$key}; # p0f didn't detect the value
@ -542,19 +532,19 @@ sub p0f_match {
if ($key eq 'distance' && $p0f->{$key} > $value) {
$self->log(LOGDEBUG, "p0f distance match ($value)");
return 1;
};
}
if ($key eq 'genre' && $p0f->{$key} =~ /$value/i) {
$self->log(LOGDEBUG, "p0f genre match ($value)");
return 1;
};
}
if ($key eq 'uptime' && $p0f->{$key} < $value) {
$self->log(LOGDEBUG, "p0f uptime match ($value)");
return 1;
};
}
if ($key eq 'link' && $p0f->{$key} =~ /$value/i) {
$self->log(LOGDEBUG, "p0f link match ($value)");
return 1;
};
}
}
$self->log(LOGINFO, "skip: no p0f match");
return;
@ -571,13 +561,13 @@ sub geoip_match {
if (!$country) {
$self->LOGINFO(LOGNOTICE, "skip: no geoip country");
return;
};
}
my @countries = split /,/, $self->{_args}{geoip};
foreach (@countries) {
$self->LOGINFO(LOGINFO, "pass: geoip country match ($_, $c_name)");
return 1 if lc $_ eq lc $country;
};
}
$self->LOGINFO(LOGINFO, "skip: no geoip match ($c_name)");
return;

220
plugins/headers Normal file
View File

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

View File

@ -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
is_forged_literal.
Runs the following tests: is_in_badhelo, invalid_localhost,
is_forged_literal, and is_plain_ip.
This setting is lenient enough not to cause problems for your Windows users.
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
no_reverse_dns.
the following are tested: is_not_fqdn, no_forward_dns, and no_reverse_dns.
If you have Windows users that send mail via your server, do not choose
I<policy rfc> without I<reject naughty> and the B<naughty> plugin. Windows
users often send unqualified HELO names and will have trouble sending mail.
<Naughty> can defer the rejection, and if the user subsequently authenticates,
the rejection will be cancelled.
I<policy rfc> without setting I<reject> to 0 or naughty.
Windows PCs often send unqualified HELO names and will have trouble
sending mail. The B<naughty> plugin defers the rejection, giving the user
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}{reject_type} = 'disconnect';
$self->{_args}{policy} ||= 'lenient';
$self->{_args}{timeout} ||= 5;
$self->{_args}{dns_timeout} ||= $self->{_args}{timeout} || 5;
if (!defined $self->{_args}{reject}) {
$self->{_args}{reject} = 1;
};
}
$self->populate_tests();
$self->init_resolver();
$self->init_resolver() or return;
$self->register_hook('helo', 'helo_handler');
$self->register_hook('ehlo', 'helo_handler');
$self->register_hook('data_post', 'data_post_handler');
};
}
sub helo_handler {
my ($self, $transaction, $host) = @_;
if (!$host) {
$self->log(LOGINFO, "fail, no helo host");
$self->log(LOGINFO, "fail, tolerated, no helo host");
return DECLINED;
};
}
return DECLINED if $self->is_immune();
foreach my $test (@{$self->{_helo_tests}}) {
my @err = $self->$test($host);
return $self->get_reject( @err ) if scalar @err;
};
if (scalar @err) {
$self->adjust_karma(-1);
return $self->get_reject(@err);
}
}
$self->log(LOGINFO, "pass");
return DECLINED;
@ -253,34 +277,24 @@ sub data_post_handler {
$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') {
push @{ $self->{_helo_tests} }, qw/ is_plain_ip is_not_fqdn no_forward_dns
no_reverse_dns /;
};
push @{$self->{_helo_tests}},
qw/ is_not_fqdn no_forward_dns no_reverse_dns /;
}
if ($policy eq 'strict') {
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) = @_;
@ -291,13 +305,13 @@ sub is_in_badhelo {
foreach my $bad ($self->qp->config('badhelo')) {
if ($bad =~ /[\{\}\[\]\(\)\^\$\|\*\+\?\\\!]/) { # it's a regexp
return $self->is_regex_match($host, $bad);
};
}
if ($host eq lc $bad) {
return ($error, "in badhelo");
}
}
return;
};
}
sub is_regex_match {
my ($self, $host, $pattern) = @_;
@ -308,15 +322,17 @@ sub is_regex_match {
if (substr($pattern, 0, 1) eq '!') {
$pattern = substr $pattern, 1;
if ($host !~ /$pattern/) {
#$self->log( LOGDEBUG, "matched ($pattern)");
return ($error, "badhelo pattern match ($pattern)");
};
}
return;
}
if ($host =~ /$pattern/) {
#$self->log( LOGDEBUG, "matched ($pattern)");
return ($error, "badhelo pattern match ($pattern)");
};
}
return;
}
@ -324,12 +340,13 @@ sub invalid_localhost {
my ($self, $host) = @_;
return if lc $host ne 'localhost';
if ($self->qp->connection->remote_ip ne '127.0.0.1') {
#$self->log( LOGINFO, "fail, not localhost" );
return ("You are not localhost", "invalid localhost");
};
}
$self->log(LOGDEBUG, "pass, is localhost");
return;
};
}
sub is_plain_ip {
my ($self, $host) = @_;
@ -338,40 +355,45 @@ sub is_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) = @_;
return if $host !~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/;
$self->log(LOGDEBUG, "fail, bracketed IP");
return ("RFC 2821 allows an address literal, but we do not", "bracketed IP");
};
return ("RFC 2821 allows an address literal, but we do not",
"bracketed IP");
}
sub is_forged_literal {
my ($self, $host) = @_;
return if $host !~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/;
# should we add exceptions for reserved internal IP space? (192.168,10., etc?)
$host = substr $host, 1, -1;
return if $host eq $self->qp->connection->remote_ip;
return ("Forged IPs not accepted here", "forged IP literal");
};
}
sub is_not_fqdn {
my ($self, $host) = @_;
return if $host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/; # address literal, skip
if ($host !~ /\./) { # has no dots
return ("HELO name is not fully qualified. Read RFC 2821", "not FQDN");
};
}
if ($host =~ /[^a-zA-Z0-9\-\.]/) {
return ("HELO name contains invalid FQDN characters. Read RFC 1035", "invalid FQDN chars");
};
return ("HELO name contains invalid FQDN characters. Read RFC 1035",
"invalid FQDN chars");
}
return;
};
}
sub no_forward_dns {
my ($self, $host) = @_;
return if $self->is_address_literal($host);
my $res = $self->init_resolver();
$host = "$host." if $host !~ /\.$/; # fully qualify name
@ -379,23 +401,24 @@ sub no_forward_dns {
if (!$query) {
if ($res->errorstring eq 'NXDOMAIN') {
return ("HELO hostname does not exist", "HELO hostname does not exist");
return ("HELO hostname does not exist", "no such host");
}
$self->log(LOGERROR, "skip, query failed (", $res->errorstring, ")");
return;
};
}
my $hits = 0;
foreach my $rr ($query->answer) {
next unless $rr->type =~ /^(?:A|AAAA)$/;
$self->check_ip_match($rr->address);
$hits++;
last if $self->connection->notes('helo_forward_match');
}
if ($hits) {
$self->log(LOGDEBUG, "pass, forward DNS") if $hits;
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) = @_;
@ -406,9 +429,10 @@ sub no_reverse_dns {
my $query = $res->query($ip) or do {
if ($res->errorstring eq 'NXDOMAIN') {
return ("no rDNS for $ip", "no rDNS");
};
}
$self->log(LOGINFO, $res->errorstring);
return ("error getting reverse DNS for $ip", "rDNS " . $res->errorstring);
return ("error getting reverse DNS for $ip",
"rDNS " . $res->errorstring);
};
my $hits = 0;
@ -417,23 +441,29 @@ sub no_reverse_dns {
$self->log(LOGDEBUG, "PTR: " . $rr->ptrdname);
$self->check_name_match(lc $rr->ptrdname, lc $host);
$hits++;
};
}
if ($hits) {
$self->log(LOGDEBUG, "has rDNS");
return;
};
}
return ("no reverse DNS for $ip", "no rDNS");
};
}
sub no_matching_dns {
my ($self, $host) = @_;
if ( $self->connection->notes('helo_forward_match') &&
$self->connection->notes('helo_reverse_match') ) {
# this is called iprev, or "Forward-confirmed reverse DNS" and is discussed
# in RFC 5451. FCrDNS is done for the remote IP in the fcrdns plugin. Here
# we do it on the HELO hostname.
# consider adding status to Authentication-Results header
if ( $self->connection->notes('helo_forward_match')
&& $self->connection->notes('helo_reverse_match'))
{
$self->log(LOGDEBUG, "foward and reverse match");
# TODO: consider adding some karma here
$self->adjust_karma(1); # a perfect match
return;
};
}
if ($self->connection->notes('helo_forward_match')) {
$self->log(LOGDEBUG, "name matches IP");
@ -442,11 +472,11 @@ sub no_matching_dns {
if ($self->connection->notes('helo_reverse_match')) {
$self->log(LOGDEBUG, "reverse matches name");
return;
};
}
$self->log(LOGINFO, "fail, no forward or reverse DNS match");
return ("That HELO hostname fails forward and reverse DNS checks", "no matching DNS");
};
return ("That HELO hostname fails FCrDNS", "no matching DNS");
}
sub check_ip_match {
my $self = shift;
@ -456,33 +486,37 @@ sub check_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 $rem_net = join('.', (split('\.', $self->qp->connection->remote_ip))[0,1,2] );
my $dns_net = join('.', (split(/\./, $ip))[0, 1, 2]);
my $rem_net =
join('.', (split(/\./, $self->qp->connection->remote_ip))[0, 1, 2]);
if ($dns_net eq $rem_net) {
$self->log(LOGNOTICE, "forward network match");
$self->connection->notes('helo_forward_match', 1);
};
};
}
}
sub check_name_match {
my $self = shift;
my ($dns_name, $helo_name) = @_;
return if !$dns_name;
return if split(/\./, $dns_name) < 2; # not a FQDN
if ($dns_name eq $helo_name) {
$self->log(LOGDEBUG, "reverse name match");
$self->connection->notes('helo_reverse_match', 1);
return;
};
}
my $dns_dom = join('.', (split('\.', $dns_name ))[-2,-1] );
my $helo_dom = join('.', (split('\.', $helo_name))[-2,-1] );
my $dns_dom = join('.', (split(/\./, $dns_name))[-2, -1]);
my $helo_dom = join('.', (split(/\./, $helo_name))[-2, -1]);
if ($dns_dom eq $helo_dom) {
$self->log(LOGNOTICE, "reverse domain match");
$self->connection->notes('helo_reverse_match', 1);
};
};
}
}

View File

@ -48,8 +48,8 @@ sub register {
$config{help_dir} = './help/';
}
foreach (keys %args) {
/^(\w+)$/ or
$self->log(LOGWARN, "Invalid argument for the 'help' plugin $_"),
/^(\w+)$/
or $self->log(LOGWARN, "Invalid argument for the 'help' plugin $_"),
next;
$cmd = $1;
if ($cmd eq 'not_implemented') {

View File

@ -68,6 +68,7 @@ sub hook_pre_connection {
my $remote = $args{remote_ip};
my $max = $args{max_conn_ip};
my $karma = $self->connection->notes('karma_history');
if ($max) {
my $num_conn = 1; # seed with current value
@ -75,31 +76,56 @@ sub hook_pre_connection {
foreach my $rip (@{$args{child_addrs}}) {
++$num_conn if (defined $rip && $rip eq $raddr);
}
$max = $self->karma_bump($karma, $max) if defined $karma;
if ($num_conn > $max) {
my $err_mess = "too many connections from $remote";
$self->log(LOGINFO, "fail: $err_mess ($num_conn > $max)");
return (DENYSOFT, "Sorry, $err_mess, try again later");
return (DENYSOFT, "$err_mess, try again later");
}
}
foreach ($self->qp->config("hosts_allow")) {
s/^\s*//;
my ($ipmask, $const, $message) = split /\s+/, $_, 3;
next unless defined $const;
my ($net,$mask) = split '/', $ipmask, 2;
$mask = 32 if !defined $mask;
$mask = pack "B32", "1"x($mask)."0"x(32-$mask);
if (join(".", unpack("C4", inet_aton($remote) & $mask)) eq $net) {
$const = Qpsmtpd::Constants::return_code($const) || DECLINED;
if ( $const =~ /deny/i ) {
$self->log( LOGINFO, "fail: $message" );
};
$self->log( LOGDEBUG, "pass: $const, $message" );
return($const, $message);
}
}
my @r = $self->in_hosts_allow($remote);
return @r if scalar @r;
$self->log(LOGDEBUG, "pass");
return (DECLINED);
}
sub in_hosts_allow {
my $self = shift;
my $remote = shift;
foreach ($self->qp->config('hosts_allow')) {
s/^\s*//; # trim leading whitespace
my ($ipmask, $const, $message) = split /\s+/, $_, 3;
next unless defined $const;
my ($net, $mask) = split /\//, $ipmask, 2;
$mask = 32 if !defined $mask;
$mask = pack "B32", "1" x ($mask) . "0" x (32 - $mask);
if (join('.', unpack('C4', inet_aton($remote) & $mask)) eq $net) {
$const = Qpsmtpd::Constants::return_code($const) || DECLINED;
if ($const =~ /deny/i) {
$self->log(LOGINFO, "fail, $message");
}
$self->log(LOGDEBUG, "pass, $const, $message");
return ($const, $message);
}
}
return;
}
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;
}

View File

@ -1,4 +1,5 @@
#!perl -w
=head1 NAME
http_config
@ -43,6 +44,7 @@ sub hook_config {
chomp @config;
@config = grep { $_ and $_ !~ m/^\s*#/ and $_ =~ m/\S/ } @config;
close CF;
# $self->log(LOGNOTICE, "returning http_config for $config ",Data::Dumper->Dump([\@config], [qw(config)]));
return (OK, @config) if @config;
}

View File

@ -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
do a lookup on incoming connections and record the country of origin.
Use MaxMind's GeoIP databases and the Geo::IP perl module to report geographic
information about incoming connections.
Thats all it does.
=head1 DESCRIPTION
It logs the 2 char country code to connection note I<geoip_country>.
It logs the country name to the connection note I<geoip_country_name>.
This plugin saves geographic information in the following connection notes:
Other plugins can use that info to do things to the connection, like
reject or greylist.
geoip_country - 2 char country code
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 Math::Trig; # eval'ed in set_distance_gc
sub register {
my $self = shift;
my ($self, $qp) = shift, shift;
$self->log(LOGERROR, "Bad arguments") if @_ % 2;
$self->{_args} = {@_};
$self->{_args}{db_dir} ||= '/usr/local/share/GeoIP';
eval 'use Geo::IP';
if ($@) {
warn "could not load Geo::IP";
$self->log(LOGERROR, "could not load Geo::IP");
return;
};
}
# Note that opening the GeoIP DB only in register has caused problems before:
# https://github.com/smtpd/qpsmtpd/commit/29ea9516806e9a8ca6519fcf987dbd684793ebdd#plugins/ident/geoip
# Opening the DB anew for every connection is horribly inefficient.
# Instead, attempt to reopen upon connect if the DB connection fails.
$self->open_geoip_db();
$self->init_my_country_code();
$self->register_hook('connect', 'connect_handler');
};
}
sub connect_handler {
my $self = shift;
my $geoip = Geo::IP->new();
my $remote_ip = $self->qp->connection->remote_ip;
# reopen the DB if Geo::IP failed due to DB update
$self->open_geoip_db();
my $c_code = $geoip->country_code_by_addr( $remote_ip ) or do {
$self->log( LOGINFO, "fail: no results" );
my $c_code = $self->set_country_code() or do {
$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 );
if ( $c_name ) {
$self->connection->notes('geoip_country_name', $c_name);
};
my $c_name = $self->set_country_name();
my ($city, $continent_code, $distance) = '';
$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;
$message .= ", $c_name" if $c_name;
$self->log(LOGINFO, $message);
my @msg_parts;
push @msg_parts, $continent_code
if $continent_code && $continent_code ne '--';
push @msg_parts, $c_code if $c_code;
#push @msg_parts, $c_name if $c_name;
push @msg_parts, $city if $city;
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);
}

View File

@ -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
@ -172,12 +180,13 @@ sub get_v2_query {
my $local_ip = $self->{_args}{local_ip} || $self->qp->connection->local_ip;
my $src = new Net::IP($self->qp->connection->remote_ip)
or $self->log(LOGERROR, "p0f: ".Net::IP::Error()), return;
or $self->log(LOGERROR, "skip, " . Net::IP::Error()), return;
my $dst = new Net::IP($local_ip)
or $self->log(LOGERROR, "p0f: ".NET::IP::Error()), return;
or $self->log(LOGERROR, "skip, " . NET::IP::Error()), return;
return pack("L L L N N S S",
return
pack("L L L N N S S",
$QUERY_MAGIC_V2,
1,
rand ^ 42 ^ time,
@ -185,30 +194,32 @@ sub get_v2_query {
$dst->intip(),
$self->qp->connection->remote_port,
$self->qp->connection->local_port);
};
}
sub get_v3_query {
my $self = shift;
my $src_ip = $self->qp->connection->remote_ip or do {
$self->log( LOGERROR, "unable to determine remote IP");
$self->log(LOGERROR, "skip, unable to determine remote IP");
return;
};
if ($src_ip =~ /:/) { # IPv6
my @bits = split(/\:/, $src_ip);
return pack( "L C C C C C C C C C C C C C C C C C", $QUERY_MAGIC_V3, 0x06, @bits );
};
return
pack("L C C C C C C C C C C C C C C C C C",
$QUERY_MAGIC_V3, 0x06, @bits);
}
my @octets = split(/\./, $src_ip);
return pack("L C C16", $QUERY_MAGIC_V3, 0x04, @octets);
};
}
sub query_p0f_v3 {
my $self = shift;
my $p0f_socket = $self->{_args}{p0f_socket} or do {
$self->log(LOGERROR, "socket not defined in config.");
$self->log(LOGERROR, "skip, socket not defined in config.");
return;
};
my $query = $self->get_v3_query() or return;
@ -219,32 +230,33 @@ sub query_p0f_v3 {
$sock = IO::Socket::UNIX->new(Peer => $p0f_socket, Type => SOCK_STREAM);
};
if (!$sock) {
$self->log(LOGERROR, "p0f: could not open socket: $@");
$self->log(LOGERROR, "skip, could not open socket: $@");
return;
};
}
$sock->autoflush(1); # paranoid redundancy
$sock->connected or do {
$self->log(LOGERROR, "p0f: socket not connected: $!");
$self->log(LOGERROR, "skip, socket not connected: $!");
return;
};
my $sent = $sock->send($query, 0) or do {
$self->log(LOGERROR, "p0f: send failed: $!");
$self->log(LOGERROR, "skip, send failed: $!");
return;
};
print $sock $query; # yes, this is redundant, but I get no response from p0f otherwise
print $sock $query
; # yes, this is redundant, but I get no response from p0f otherwise
$self->log(LOGDEBUG, "p0f: send $sent byte request");
$self->log(LOGDEBUG, "sent $sent byte request");
my $response;
$sock->recv($response, 232);
my $length = length $response;
$self->log(LOGDEBUG, "p0f: received $length byte response");
$self->log(LOGDEBUG, "received $length byte response");
close $sock;
return $response;
};
}
sub query_p0f_v2 {
my $self = shift;
@ -254,18 +266,18 @@ 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) = @_;
@ -275,20 +287,20 @@ sub test_v2_response {
# $self->log(LOGERROR, $response);
if ($magic != $QUERY_MAGIC_V2) {
$self->log(LOGERROR, "p0f: Bad response magic.");
$self->log(LOGERROR, "skip, Bad response magic.");
return;
}
if ($type == 1) {
$self->log(LOGERROR, "p0f: p0f did not honor our query");
$self->log(LOGERROR, "skip, p0f did not honor our query");
return;
}
elsif ($type == 2) {
$self->log(LOGWARN, "p0f: This connection is no longer in the cache");
$self->log(LOGWARN, "skip, connection not in the cache");
return;
}
return 1;
};
}
sub test_v3_response {
my ($self, $response) = @_;
@ -297,32 +309,34 @@ sub test_v3_response {
# check the magic response value (a p0f constant)
if ($magic != $RESP_MAGIC_V3) {
$self->log(LOGERROR, "p0f: Bad response magic.");
$self->log(LOGERROR, "skip, Bad response magic.");
return;
}
# check the response status
if ($status == $P0F_STATUS_BADQUERY) {
$self->log(LOGERROR, "p0f: bad query");
$self->log(LOGERROR, "skip, bad query");
return;
}
elsif ($status == $P0F_STATUS_NOMATCH) {
$self->log(LOGINFO, "p0f: no match");
$self->log(LOGINFO, "skip, no match");
return;
}
if ($status == $P0F_STATUS_OK) {
$self->log(LOGDEBUG, "p0f: query ok");
$self->log(LOGDEBUG, "pass, query ok");
return 1;
}
return;
};
}
sub store_v2_results {
my ($self, $response) = @_;
my ($magic, $id, $type, $genre, $detail, $dist, $link, $tos, $fw,
$nat, $real, $score, $mflags, $uptime) =
unpack ("L L C Z20 Z40 c Z30 Z30 C C C s S N", $response);
my (
$magic, $id, $type, $genre, $detail, $dist, $link,
$tos, $fw, $nat, $real, $score, $mflags, $uptime
)
= unpack("L L C Z20 Z40 c Z30 Z30 C C C s S N", $response);
my $p0f = {
genre => $genre,
@ -336,7 +350,7 @@ sub store_v2_results {
$self->log(LOGINFO, $genre . " (" . $detail . ")");
$self->log(LOGERROR, "error: $@") if $@;
return $p0f;
};
}
sub store_v3_results {
my ($self, $response) = @_;
@ -344,24 +358,29 @@ sub store_v3_results {
my @labels = qw/ magic status first_seen last_seen total_conn uptime_min
up_mod_days last_nat last_chg distance bad_sw os_match_q os_name os_flavor
http_name http_flavor link_type language /;
my @values = unpack ("L L L L L L L L L s C C A32 A32 A32 A32 A32 A32 A32", $response);
my @values =
unpack("L L L L L L L L L s C C A32 A32 A32 A32 A32 A32 A32", $response);
my %r;
foreach my $i (0 .. (scalar @labels - 1)) {
next if !defined $values[$i];
next if !defined $values[$i];
$r{$labels[$i]} = $values[$i];
};
}
if ($r{os_name}) { # compat with p0f v2
$r{genre} = "$r{os_name} $r{os_flavor}";
$r{link} = $r{link_type} if $r{link_type};
$r{uptime} = $r{uptime_min} if $r{uptime_min};
};
}
if ($r{genre} && $self->{_args}{smite_os}) {
my $sos = $self->{_args}{smite_os};
$self->adjust_karma(-1) if $r{genre} =~ /$sos/i;
}
$self->connection->notes('p0f', \%r);
$self->log(LOGINFO, "$r{os_name} $r{os_flavor}");
$self->log(LOGDEBUG, join(' ', @values));
$self->log(LOGERROR, "error: $@") if $@;
return \%r;
};
}

View File

@ -6,7 +6,7 @@ karma - reward nice and penalize naughty mail senders
=head1 SYNOPSIS
Karma tracks sender history, providing the ability to deliver differing levels
Karma tracks sender history, allowing us to provide differing levels
of service to naughty, nice, and unknown senders.
=head1 DESCRIPTION
@ -14,7 +14,7 @@ of service to naughty, nice, and unknown senders.
Karma records the number of nice, naughty, and total connections from mail
senders. After sending a naughty message, if a sender has more naughty than
nice connections, they are penalized for I<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.
@ -24,10 +24,9 @@ custom connection policies such as these two examples:
=over 4
Hi there, well behaved sender. Please help yourself to TLS, AUTH, greater
concurrency, multiple recipients, no delays, and other privileges.
Hi there, well known and well behaved sender. Please help yourself to greater concurrency (hosts_allow), multiple recipients (karma), and no delays (early_sender).
Hi there, naughty sender. 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
@ -62,7 +61,7 @@ Default: 1
=head2 reject
karma reject [ 0 | 1 | connect | zombie ]
karma reject [ 0 | 1 | connect | naughty ]
I<0> will not reject any connections.
@ -70,8 +69,8 @@ I<1> will reject naughty senders.
I<connect> is the most efficient setting.
To reject at any other connection hook, use the I<zombie> setting and the
B<reaper> plugin.
To reject at any other connection hook, use the I<naughty> setting and the
B<naughty> plugin.
=head2 db_dir <path>
@ -95,12 +94,11 @@ Adjust the quantity of logging for this plugin. See docs/logging.pod
=head1 BENEFITS
Karma reduces the resources wasted by naughty mailers.
When used with the
I<reject connect> setting, naughty senders are disconnected in about 0.1 seconds.
Karma reduces the resources wasted by naughty mailers. When used with
I<reject connect>, 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.
@ -112,16 +110,9 @@ 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
other plugins to make that determination and communicate it to this plugin by
incrementing or decrementing the transaction note B<karma>. Raise it for good
karma and lower it for bad karma. This is best done like so:
# only if karma plugin loaded
if ( defined $connection->notes('karma') ) {
$connection->notes('karma', $connection->notes('karma') - 1); # bad
$connection->notes('karma', $connection->notes('karma') + 1); # good
};
No attempt is made by this plugin to determine karma. It is up to other
plugins to reward well behaved senders with positive karma and smite poorly
behaved senders with negative karma. See B<USING KARMA IN OTHER PLUGINS>
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
plugins should skip processing. However, if you wish to toy with spammers by
teergrubing, extending banner delays, limiting connections, limiting
recipients, random disconnects, handoffs to rblsmtpd, and other fun tricks,
then connections with the I<zombie> note set are for you!
To alter a connections karma based on its behavior, do this:
$self->adjust_karma( -1 ); # lower karma (naughty)
$self->adjust_karma( 1 ); # raise karma (good)
=head1 EFFECTIVENESS
@ -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
form of the remote IP. The value is a : delimited list containing a penalty
Connection summaries are stored in a database. The database key is the integer
value of the remote IP. The DB value is a : delimited list containing a penalty
box start time (if the server is/was on timeout) and the count of naughty,
nice, and total connections. The database can be listed and searched with the
karma_dump.pl script.
karma_tool script.
=head1 BUGS & LIMITATIONS
This plugin is reactionary. Like the FBI, it doesn't punish until
after a crime has been committed. It an "abuse me once, shame on you,
abuse me twice, shame on me" policy.
This plugin is reactionary. Like the FBI, it doesn't do anything until
after a crime has been committed.
There is little to be gained by listing servers that are already on DNS
blacklists, send to non-existent users, earlytalkers, etc. Those already have
blacklists, send to invalid users, earlytalkers, etc. Those already have
very lightweight tests.
=head1 AUTHOR
@ -230,7 +231,7 @@ use Fcntl qw(:DEFAULT :flock LOCK_EX LOCK_NB);
use Net::IP;
sub register {
my ($self, $qp ) = shift, shift;
my ($self, $qp) = (shift, shift);
$self->log(LOGERROR, "Bad arguments") if @_ % 2;
$self->{_args} = {@_};
$self->{_args}{negative} ||= 1;
@ -238,13 +239,44 @@ sub register {
$self->{_args}{reject_type} ||= 'disconnect';
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('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;
@ -255,41 +287,102 @@ sub connect_handler {
my $db = $self->get_db_location();
my $lock = $self->get_db_lock($db) or return DECLINED;
my $tied = $self->get_db_tie($db, $lock) or return DECLINED;
my $key = $self->get_db_key();
my $key = $self->get_db_key() or do {
$self->log(LOGINFO, "skip, unable to get DB key");
return DECLINED;
};
if (!$tied->{$key}) {
$self->log(LOGINFO, "pass, no record");
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;
if ( $naughty || $nice ) {
$karma = $nice || 0 - $naughty || 0;
$self->connection->notes('karma_history', $karma );
};
my $karma = $self->calc_karma($naughty, $nice);
my $happy_return = $karma > 3 ? DONE : DECLINED; # skip other connection tests?
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);
};
}
my $days_old = (time - $penalty_start_ts) / 86400;
if ($days_old >= $self->{_args}{penalty_days}) {
$self->log(LOGINFO, "pass, penalty expired ($summary)");
return $self->cleanup_and_return($tied, $lock);
};
}
$tied->{$key} = join(':', $penalty_start_ts, $naughty, $nice, ++$connects);
$self->cleanup_and_return($tied, $lock);
my $left = sprintf "%.2f", $self->{_args}{penalty_days} - $days_old;
my $mess = "You were naughty. You are penalized for $left more days.";
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 {
@ -305,30 +398,52 @@ sub disconnect_handler {
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 ) {
$naughty++;
if ($karma < -1) { # they achieved at least 2 strikes
$history--;
my $negative_limit = 0 - $self->{_args}{negative};
my $karma_history = ($nice || 0) - $naughty;
if ( $karma_history <= $negative_limit ) {
$self->log(LOGINFO, "negative, sent to penalty box");
$penalty_start_ts = sprintf "%s", time;
if ($history <= $negative_limit) {
if ($nice == 0 && $history < -5) {
$log_mess = ", penalty box bonus!";
$penalty_start_ts = sprintf "%s", time + abs($history) * 86400;
}
else {
$self->log(LOGINFO, "negative");
};
$penalty_start_ts = sprintf "%s", time;
}
$log_mess = "negative, sent to penalty box" . $log_mess;
}
else {
$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);
}
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;
@ -338,9 +453,19 @@ sub parse_value {
$nice ||= 0;
$naughty ||= 0;
$connects ||= 0;
};
}
return ($penalty_start_ts, $naughty, $nice, $connects);
};
}
sub calc_karma {
my ($self, $naughty, $nice) = @_;
return 0 if (!$naughty && !$nice);
my $karma = ($nice || 0) - ($naughty || 0);
$self->connection->notes('karma_history', $karma);
$self->adjust_karma(1) if $karma > 10;
return $karma;
}
sub cleanup_and_return {
my ($self, $tied, $lock, $return_val) = @_;
@ -349,32 +474,39 @@ sub cleanup_and_return {
close $lock;
return ($return_val) if defined $return_val; # explicit override
return (DECLINED);
};
}
sub get_db_key {
my $self = shift;
my $nip = Net::IP->new( $self->qp->connection->remote_ip );
return $nip->intip; # convert IP to an int
my $ip = shift || $self->qp->connection->remote_ip;
my $nip = Net::IP->new($ip) or do {
$self->log(LOGERROR, "skip, unable to determine remote IP");
return;
};
return $nip->intip; # convert IP to an int
}
sub get_db_tie {
my ($self, $db, $lock) = @_;
tie(my %db, 'AnyDBM_File', $db, O_CREAT | O_RDWR, 0600) or do {
$self->log(LOGCRIT, "tie to database $db failed: $!");
$self->log(LOGCRIT, "error, tie to database $db failed: $!");
close $lock;
return;
};
return \%db;
};
}
sub get_db_location {
my $self = shift;
# Setup database location
my ($QPHOME) = ($0 =~ m!(.*?)/([^/]+)$!);
my @candidate_dirs = ( $self->{args}{db_dir},
"/var/lib/qpsmtpd/karma", "$QPHOME/var/db", "$QPHOME/config", '.' );
my @candidate_dirs = (
$self->{args}{db_dir},
"/var/lib/qpsmtpd/karma", "$QPHOME/var/db",
"$QPHOME/config", '.'
);
my $dbdir;
for my $d (@candidate_dirs) {
@ -385,7 +517,7 @@ sub get_db_location {
my $db = "$dbdir/karma.dbm";
$self->log(LOGDEBUG, "using $db as karma database");
return $db;
};
}
sub get_db_lock {
my ($self, $db) = @_;
@ -394,12 +526,12 @@ sub get_db_lock {
# Check denysoft db
open(my $lock, ">$db.lock") or do {
$self->log(LOGCRIT, "opening lockfile failed: $!");
$self->log(LOGCRIT, "error, opening lockfile failed: $!");
return;
};
flock($lock, LOCK_EX) or do {
$self->log(LOGCRIT, "flock of lockfile failed: $!");
$self->log(LOGCRIT, "error, flock of lockfile failed: $!");
close $lock;
return;
};
@ -418,18 +550,19 @@ sub get_db_lock_nfs {
lock_type => LOCK_EX | LOCK_NB,
blocking_timeout => 10, # 10 sec
stale_lock_timeout => 30 * 60, # 30 min
} or do {
$self->log(LOGCRIT, "nfs lockfile failed: $!");
}
or do {
$self->log(LOGCRIT, "error, nfs lockfile failed: $!");
return;
};
open(my $lock, "+<$db.lock") or do {
$self->log(LOGCRIT, "opening nfs lockfile failed: $!");
$self->log(LOGCRIT, "error, opening nfs lockfile failed: $!");
return;
};
return $lock;
};
}
sub prune_db {
my $self = shift;
@ -446,10 +579,10 @@ sub prune_db {
next if $days_old < $self->{_args}{penalty_days} * 2;
delete $tied->{$key};
$pruned++;
};
}
untie $tied;
close $lock;
$self->log(LOGINFO, "pruned $pruned of $count DB entries");
return $self->cleanup_and_return($tied, $lock, DECLINED);
};
}

View File

@ -21,14 +21,17 @@ elsif ( $command eq 'capture' ) {
$self->capture($ARGV[1]);
}
elsif ($command eq 'release') {
$self->capture( $ARGV[1] );
$self->release($ARGV[1]);
}
elsif ($command eq 'prune') {
$self->prune_db($ARGV[1] || 7);
}
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 ]
@ -52,7 +55,7 @@ prune takes no arguments.
EO_HELP
;
};
}
sub capture {
my $self = shift;
@ -67,26 +70,54 @@ sub capture {
my $tied = $self->get_db_tie($db, $lock) or return;
my $key = $self->get_db_key($ip);
$tied->{$key} = join(':', time, 1, 0, 1);
my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/,
$tied->{$key};
$tied->{$key} = join(':', time, $naughty + 1, $nice, $connects);
return $self->cleanup_and_return($tied, $lock);
};
}
sub release {
my $self = shift;
my $ip = shift or return;
is_ip( $ip ) or do {
warn "not an IP: $ip\n";
return;
};
is_ip($ip) or do { warn "not an IP: $ip\n"; return; };
my $db = $self->get_db_location();
my $lock = $self->get_db_lock($db) or return;
my $tied = $self->get_db_tie($db, $lock) or return;
my $key = $self->get_db_key($ip);
$tied->{$key} = join(':', 0, 1, 0, 1);
my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/,
$tied->{$key};
$tied->{$key} = join(':', 0, 0, $nice, $connects);
return $self->cleanup_and_return($tied, $lock);
};
}
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;
@ -96,10 +127,12 @@ sub main {
my $tied = $self->get_db_tie($db, $lock) or return;
my %totals;
print " IP Address Penalty Naughty Nice Connects Hostname\n";
print
" IP Address Penalty Naughty Nice Connects Hostname\n";
foreach my $r (sort keys %$tied) {
my $ip = ip_bintoip(ip_inttobin($r, 4), 4);
my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/, $tied->{$r};
my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/,
$tied->{$r};
$naughty ||= '';
$nice ||= '';
$connects ||= '';
@ -115,42 +148,45 @@ sub main {
elsif ($search eq 'both') {
next if !$naughty || !$nice;
}
elsif ( is_ip() && $search ne $ip ) {
elsif (is_ip($ARGV[1]) && $search ne $ip) {
next;
}
};
}
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) {
$hostname = `dig +short -x $ip`; chomp $hostname;
};
printf(" %-18s %24s %3s %3s %3s %30s\n", $ip, $time_human, $naughty, $nice, $connects, $hostname);
#$hostname = `dig +short -x $ip`; chomp $hostname;
}
printf(" %-18s %24s %3s %3s %3s %30s\n",
$ip, $time_human, $naughty, $nice, $connects, $hostname);
$totals{naughty} += $naughty if $naughty;
$totals{nice} += $nice if $nice;
$totals{connects} += $connects if $connects;
};
}
print Dumper(\%totals);
}
sub is_ip {
my $ip = shift || $ARGV[0];
return 1 if $ip =~ /^(\d{1,3}\.){3}\d{1,3}$/;
return;
};
new Net::IP($ip) or return;
return 1;
}
sub cleanup_and_return {
my ($self, $tied, $lock) = @_;
untie $tied;
close $lock;
};
}
sub get_db_key {
my $self = shift;
my $nip = Net::IP->new( shift );
my $nip = Net::IP->new(shift) or return;
return $nip->intip; # convert IP to an int
};
}
sub get_db_tie {
my ($self, $db, $lock) = @_;
@ -161,14 +197,16 @@ sub get_db_tie {
return;
};
return \%db;
};
}
sub get_db_location {
my $self = shift;
# Setup database location
my @candidate_dirs = ( $self->{args}{db_dir},
"/var/lib/qpsmtpd/karma", "./var/db", "./config", '.' );
my @candidate_dirs = (
$self->{args}{db_dir},
"/var/lib/qpsmtpd/karma", "./var/db", "./config", '.'
);
my $dbdir;
for my $d (@candidate_dirs) {
@ -179,7 +217,7 @@ sub get_db_location {
my $db = "$dbdir/karma.dbm";
print "using karma db at $db\n";
return $db;
};
}
sub get_db_lock {
my ($self, $db) = @_;
@ -212,7 +250,8 @@ sub get_db_lock_nfs {
lock_type => LOCK_EX | LOCK_NB,
blocking_timeout => 10, # 10 sec
stale_lock_timeout => 30 * 60, # 30 min
} or do {
}
or do {
warn "nfs lockfile failed: $!";
return;
};
@ -223,7 +262,7 @@ sub get_db_lock_nfs {
};
return $lock;
};
}
sub prune_db {
my $self = shift;
@ -241,10 +280,10 @@ sub prune_db {
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);
};
}

View File

@ -45,8 +45,9 @@ sub hook_logging { # wlog
if (defined $self->{_maxlevel} && $trace <= $self->{_maxlevel}) {
warn join(
" ", $$.
(
" ",
$$
. (
defined $plugin ? " $plugin plugin:"
: defined $hook ? " running plugin ($hook):"
: ""
@ -79,8 +80,8 @@ sub hook_reset_transaction { # slog
my ($trace, $hook, $plugin, @log) = @$row;
warn join(
" ", $$,
$self->{_prefix}.
(
$self->{_prefix}
. (
defined $plugin ? " $plugin plugin:"
: defined $hook ? " running plugin ($hook):"
: ""

View File

@ -31,12 +31,19 @@ sub hook_logging {
return DECLINED if defined $plugin and $plugin eq $self->plugin_name;
my $connection = $self->qp && $self->qp->connection;
# warn "connection = $connection\n";
warn
join(" ", ($connection ? $connection->id : "???") .
(defined $plugin ? " $plugin plugin:" :
defined $hook ? " running plugin ($hook):" : ""),
@log), "\n"
warn join(
" ",
($connection ? $connection->id : "???")
. (
defined $plugin ? " $plugin plugin:"
: defined $hook ? " running plugin ($hook):"
: ""
),
@log
),
"\n"
if ($trace <= $self->{_level});
return DECLINED;

View File

@ -173,7 +173,8 @@ sub register {
if ($output =~ /^\s*\|(.*)/) {
$self->{_log_pipe} = 1;
$self->{_log_format} = $1;
} else {
}
else {
$output =~ /^(.*)/; # detaint
$self->{_log_format} = $1;
}
@ -198,7 +199,8 @@ sub open_log {
warn "Error opening log output to command $output: $!";
return undef;
}
} else {
}
else {
unless ($self->{_f} = new IO::File ">>$output") {
warn "Error opening log output to path $output: $!";
return undef;
@ -209,7 +211,6 @@ sub open_log {
1;
}
# Reopen the output iff the interpolated output filename has changed
# from the one currently open, or if reopening was selected and we haven't
# yet done so during this session.
@ -219,10 +220,13 @@ sub maybe_reopen {
my ($self, $transaction) = @_;
my $new_output = $self->log_output($transaction);
if (!$self->{_current_output} ||
$self->{_current_output} ne $new_output ||
($self->{_reopen} &&
!$transaction->notes('file-reopened-this-session'))) {
if (
!$self->{_current_output}
|| $self->{_current_output} ne $new_output
|| ($self->{_reopen}
&& !$transaction->notes('file-reopened-this-session'))
)
{
unless ($self->open_log($new_output, $transaction)) {
return undef;
}
@ -237,9 +241,12 @@ sub hook_connect {
$transaction->notes('file-logged-this-session', 0);
$transaction->notes('file-reopened-this-session', 0);
$transaction->notes('logging-session-id',
$transaction->notes(
'logging-session-id',
sprintf("%08d-%04d-%d",
scalar time, $$, ++$self->{_session_counter}));
scalar time, $$,
++$self->{_session_counter})
);
return DECLINED;
}
@ -255,8 +262,9 @@ sub hook_disconnect {
sub hook_logging {
my ($self, $transaction, $trace, $hook, $plugin, @log) = @_;
return DECLINED if !defined $self->{_loglevel} or
$trace > $self->{_loglevel};
return DECLINED
if !defined $self->{_loglevel}
or $trace > $self->{_loglevel};
return DECLINED if defined $plugin and $plugin eq $self->plugin_name;
# Possibly reopen the log iff:
@ -264,10 +272,11 @@ sub hook_logging {
# - We're allowed to split sessions across logfiles
# - We haven't logged anything yet this session
# - We aren't in a session
if (!$self->{_f} ||
!$self->{_nosplit} ||
!$transaction ||
!$transaction->notes('file-logged-this-session')) {
if ( !$self->{_f}
|| !$self->{_nosplit}
|| !$transaction
|| !$transaction->notes('file-logged-this-session'))
{
unless (defined $self->maybe_reopen($transaction)) {
return DECLINED;
}

View File

@ -116,7 +116,8 @@ sub register {
if (@args % 2 == 0) {
%args = @args;
} else {
}
else {
warn "Malformed arguments to syslog plugin";
return;
}
@ -177,8 +178,8 @@ sub hook_logging {
return DECLINED if $trace > $self->{_loglevel};
return DECLINED if defined $plugin and $plugin eq $self->plugin_name;
my $priority = $self->{_priority} ?
$self->{_priority} : $priorities_{$trace};
my $priority =
$self->{_priority} ? $self->{_priority} : $priorities_{$trace};
syslog $priority, '%s', join(' ', @log);
return DECLINED;

View File

@ -31,11 +31,17 @@ sub hook_logging {
# out this line and it will not cause an infinite loop.
return DECLINED if defined $plugin and $plugin eq $self->plugin_name;
warn
join(" ", ($transaction ? $transaction->id : "???") .
(defined $plugin ? " $plugin plugin:" :
defined $hook ? " running plugin ($hook):" : ""),
@log), "\n"
warn join(
" ",
($transaction ? $transaction->id : "???")
. (
defined $plugin ? " $plugin plugin:"
: defined $hook ? " running plugin ($hook):"
: ""
),
@log
),
"\n"
if ($trace <= $self->{_level});
return DECLINED;

View File

@ -65,9 +65,11 @@ sub hook_logging {
return DECLINED if $trace > $self->{_level};
my $prefix = defined $plugin && defined $hook ? " ($hook) $plugin:" :
defined $plugin ? " $plugin:" :
defined $hook ? " ($hook) running plugin:" : '';
my $prefix =
defined $plugin && defined $hook ? " ($hook) $plugin:"
: defined $plugin ? " $plugin:"
: defined $hook ? " ($hook) running plugin:"
: '';
warn join(' ', $$ . $prefix, @log), "\n";

Some files were not shown because too many files have changed in this diff Show More