Merge pull request #34 from msimerson/master

apply pending commits from my fork
This commit is contained in:
Matt Simerson 2013-08-05 12:29:32 -07:00
commit 15eca9cc51
34 changed files with 1266 additions and 226 deletions

View File

@ -78,8 +78,7 @@ plugins/check_bogus_bounce
plugins/check_basicheaders
plugins/check_earlytalker
plugins/check_loop
plugins/check_norelay
plugins/check_relay
plugins/relay
plugins/check_spamhelo
plugins/connection_time
plugins/content_log
@ -114,7 +113,6 @@ plugins/quit_fortune
plugins/random_error
plugins/rcpt_ok
plugins/rcpt_regexp
plugins/relay_only
plugins/require_resolvable_fromhost
plugins/rhsbl
plugins/sender_permitted_from

View File

@ -1,2 +1,4 @@
# used by plugins/auth/auth_flat_file
# example entries
good@example.com:good_pass
bad@example.com:bad_pass

View File

@ -0,0 +1,6 @@
# used by plugins/relay
# test entries - http://tools.ietf.org/html/rfc5737
192.0.99.5
192.0.99.6
192.0.98.
# add your own entries below...

View File

@ -32,7 +32,7 @@ quit_fortune
#tls
check_earlytalker
count_unrecognized_commands 4
check_relay
relay
require_resolvable_fromhost
@ -45,6 +45,10 @@ check_spamhelo
# sender_permitted_from
# greylisting p0f genre,windows
#auth/auth_checkpassword checkpw /usr/local/vpopmail/bin/vchkpw true /usr/bin/true
#auth/auth_vpopmail
#auth/auth_vpopmaild
#auth/auth_vpopmail_sql
auth/auth_flat_file
auth/authdeny
@ -85,6 +89,6 @@ dspam learn_from_sa 7 reject 1
# If you need to run the same plugin multiple times, you can do
# something like the following
# check_relay
# check_relay:0 somearg
# check_relay:1 someotherarg
# relay
# relay:0 somearg
# relay:1 someotherarg

View File

@ -1,5 +1,6 @@
# used by plugins/relay
# Format is IP, or IP part with trailing dot
# e.g. "127.0.0.1", or "192.168."
127.0.0.1
# leading/trailing whitespace is ignored
192.168.
192.0.

View File

@ -0,0 +1 @@
/usr/local/vpopmail/bin/vchkpw /bin/true

View File

@ -210,6 +210,37 @@ sub compile {
die "eval $@" if $@;
}
sub is_immune {
my $self = shift;
if ( $self->qp->connection->relay_client() ) {
# set by plugins/relay, or Qpsmtpd::Auth
$self->log(LOGINFO, "skip, relay client");
return 1;
};
if ( $self->qp->connection->notes('whitelisthost') ) {
# set by plugins/dns_whitelist_soft or plugins/whitelist
$self->log(LOGINFO, "skip, whitelisted host");
return 1;
};
if ( $self->qp->transaction->notes('whitelistsender') ) {
# set by plugins/whitelist
$self->log(LOGINFO, "skip, whitelisted sender");
return 1;
};
if ( $self->connection->notes('naughty') ) {
# see plugins/naughty
$self->log(LOGINFO, "skip, naughty");
return 1;
};
if ( $self->connection->notes('rejected') ) {
# http://www.steve.org.uk/Software/ms-lite/
$self->log(LOGINFO, "skip, already rejected");
return 1;
};
return;
};
sub _register_standard_hooks {
my ($plugin, $qp) = @_;

View File

@ -358,7 +358,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 it's I<Received:> header.
may add headers and qpsmtpd will add its I<Received:> header.
=head2 body_length( )

View File

@ -124,6 +124,7 @@ sub auth_checkpassword {
my $binary = $self->connection->notes('auth_checkpassword_bin');
my $true = $self->connection->notes('auth_checkpassword_true');
chomp ($binary, $true);
my $sudo = get_sudo($binary);

View File

@ -45,7 +45,7 @@ use warnings;
use Qpsmtpd::Auth;
use Qpsmtpd::Constants;
#use vpopmail; # we eval this in $test_vpopmail
#use vpopmail; # we eval this in $test_vpopmail_module
sub register {
my ($self, $qp) = @_;
@ -86,7 +86,7 @@ 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";
eval 'use vpopmail';
if ( $@ ) {
$self->log(LOGERROR, "skip: is vpopmail perl module installed?");
return;

View File

@ -69,11 +69,18 @@ use warnings;
use Qpsmtpd::Auth;
use Qpsmtpd::Constants;
use DBI;
#use DBI; # done in ->register
sub register {
my ( $self, $qp ) = @_;
eval 'use DBI';
if ( $@ ) {
warn "plugin disabled. is DBI installed?\n";
$self->log(LOGERROR, "skip: plugin disabled. is DBI installed?\n");
return;
};
$self->register_hook('auth-plain', 'auth_vmysql');
$self->register_hook('auth-login', 'auth_vmysql');
$self->register_hook('auth-cram-md5', 'auth_vmysql');

View File

@ -35,7 +35,7 @@ I would be surprised if a valid message ever had a date header older than a week
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 ]
check_basicheaders reject [ 0 | 1 ]
Default policy is to reject.
@ -116,7 +116,7 @@ sub hook_data_post {
if ( ! $header->get('From') ) {
$self->log(LOGINFO, "fail: no from");
return ($deny, "We require a valid From header")
return ($deny, "We require a valid From header");
};
my $date = $header->get('Date') or do {

View File

@ -1,58 +0,0 @@
#!perl -w
=pod
=head1 SYNOPSIS
This plugin checks the norelayclients config file to see if
relaying is denied.
This allows specific clients, such as the gateway, to be denied
relaying, even though they would be allowed relaying by the
relayclients file.
=head1 CONFIG
config/norelayclients
Each line is:
- a full IP address
- partial IP address terminated by a dot for matching whole networks
e.g. 192.168.42.
=head1 BUGS AND LIMITATIONS
This plugin does not have a more_norelayclients map equivalent
of the more_relayclients map of the check_relay plugin.
=head1 AUTHOR
Based on check_relay plugin from the qpsmtpd distribution.
Copyright 2005 Gordon Rowell <gordonr@gormand.com.au>
This software is free software and may be distributed under the same
terms as qpsmtpd itself.
=cut
sub hook_connect {
my ($self, $transaction) = @_;
my $connection = $self->qp->connection;
# Check if this IP is not allowed to relay
my @no_relay_clients = $self->qp->config("norelayclients");
my %no_relay_clients = map { $_ => 1 } @no_relay_clients;
my $client_ip = $self->qp->connection->remote_ip;
while ($client_ip) {
if ( exists($no_relay_clients{$client_ip}) )
{
$connection->relay_client(0);
delete $ENV{RELAYCLIENT};
$self->log(LOGNOTICE, "check_norelay: $client_ip denied relaying");
last;
}
$client_ip =~ s/\d+\.?$//; # strip off another 8 bits
}
return (DECLINED);
}

View File

@ -1,83 +0,0 @@
#!perl -w
=head1 NAME
check_relay
=head1 SYNOPSIS
Checks the relayclients config file and $ENV{RELAYCLIENT} to see if relaying is allowed.
=cut
use strict;
use warnings;
use Qpsmtpd::Constants;
use Net::IP qw(:PROC);
sub hook_connect {
my ($self, $transaction) = @_;
my $connection = $self->qp->connection;
# Check if this IP is allowed to relay
my $client_ip = $self->qp->connection->remote_ip;
# @crelay... for comparing, @srelay... for stripping
my (@crelay_clients, @srelay_clients);
my @relay_clients = $self->qp->config("relayclients");
for (@relay_clients) {
my ($range_ip, $range_prefix) = ip_splitprefix($_);
if($range_prefix){
# has a prefix, so due for comparing
push @crelay_clients, $_;
}
else {
# has no prefix, so due for splitting
push @srelay_clients, $_;
}
}
if (@crelay_clients){
my ($range_ip, $range_prefix, $rversion, $begin, $end, $bin_client_ip);
my $cversion = ip_get_version($client_ip);
for (@crelay_clients) {
# Get just the IP from the CIDR range, to get the IP version, so we can
# get the start and end of the range
($range_ip, $range_prefix) = ip_splitprefix($_);
$rversion = ip_get_version($range_ip);
($begin, $end) = ip_normalize($_, $rversion);
# expand the client address (zero pad it) before converting to binary
$bin_client_ip = ip_iptobin(ip_expand_address($client_ip, $cversion), $cversion);
if (ip_bincomp($bin_client_ip, 'gt', ip_iptobin($begin, $rversion))
&& ip_bincomp($bin_client_ip, 'lt', ip_iptobin($end, $rversion)))
{
$connection->relay_client(1);
last;
}
}
}
# If relay_client is already set, no point checking again
if (@srelay_clients && !$connection->relay_client) {
my $more_relay_clients = $self->qp->config("morerelayclients", "map");
my %srelay_clients = map { $_ => 1 } @srelay_clients;
$client_ip =~ s/::/:/;
($connection->relay_client(1) && undef($client_ip)) if $client_ip eq ":1";
while ($client_ip) {
if (exists($ENV{RELAYCLIENT}) or
exists($srelay_clients{$client_ip}) or
exists($more_relay_clients->{$client_ip}))
{
$connection->relay_client(1);
last;
}
$client_ip =~ s/(\d|\w)+(:|\.)?$//; # strip off another 8 bits
}
}
return (DECLINED);
}

View File

@ -11,9 +11,9 @@ implement more sophisticated anti-spam policies.
=head1 DESCRIPTION
This p0f module inserts a 'p0f' note that other qpsmtpd plugins can inspect.
It includes the following information about the TCP fingerprint (link,
detail, distance, uptime, genre). Here's an example connection note:
This p0f module inserts a I<p0f> connection note with information deduced
from the TCP fingerprint. The note typically includes at least the link,
detail, distance, uptime, genre. Here's a p0f v2 example:
genre => FreeBSD
detail => 6.x (1)
@ -26,20 +26,29 @@ Which was parsed from this p0f fingerprint:
24.18.227.2:39435 - FreeBSD 6.x (1) (up: 1390 hrs)
-> 208.75.177.101:25 (distance 17, link: ethernet/modem)
When using p0f v3, the following additional values may also be available in
the I<p0f> connection note:
=over 4
magic, status, first_seen, last_seen, total_conn, uptime_min, up_mod_days, last_nat, last_chg, distance, bad_sw, os_match_q, os_name, os_flavor, http_name, http_flavor, link_type, and language.
=back
=head1 MOTIVATION
This p0f plugin provides a way to make sophisticated policies for email
messages. For example, the vast majority of email connections to my server
from Windows computers are spam (>99%). But, I have a few clients that use
Exchange servers so I can't just block email from all Windows computers.
from Windows computers are spam (>99%). But, I have clients with
Exchange servers so I can't block email from all Windows computers.
Same goes for greylisting. Finance companies (AmEx, BoA, etc) just love to
send notices that they won't queue and retry. Either they deliver at that
instant or never. When I enable greylisting, I lose valid messages. Grrr.
Same goes for greylisting. Finance companies (AmEx, BoA, etc) send notices
that they don't queue and retry. They deliver immediately or never. Enabling
greylisting means maintaining manual whitelists or losing valid messages.
So, while I'm not willing to use greylisting, and I'm not willing to block
connections from Windows computers, I am quite willing to greylist all email
from Windows computers.
While I'm not willing to use greylisting for every connection, and I'm not
willing to block connections from Windows computers, I am willing to greylist
all email from Windows computers.
=head1 CONFIGURATION
@ -47,7 +56,7 @@ Configuration consists of two steps: starting p0f and configuring this plugin.
=head2 start p0f
Create a startup script for PF that creates a communication socket when your
Create a startup script for p0f that creates a communication socket when your
server starts up.
p0f v2 example:
@ -73,10 +82,9 @@ It's even possible to run both versions of p0f simultaneously:
=head2 local_ip
Use the local_ip option to override the IP address of your mail server. This
is useful if your mail server has a private IP because it is running behind
a firewall. For example, my mail server has the IP 127.0.0.6, but the world
knows my mail server as 208.75.177.101.
Use I<local_ip> to override the IP address of your mail server. This is useful
if your mail server runs on a private IP behind a firewall. My mail server has
the IP 127.0.0.6, but the world knows my mail server as 208.75.177.101.
Example config/plugins entry with local_ip override:
@ -107,15 +115,11 @@ Version 2 code heavily based upon the p0fq.pl included with the p0f distribution
=head1 AUTHORS
Robert Spier ( original author )
2004 - Robert Spier ( original author )
Matt Simerson
2010 - Matt Simerson - added local_ip option
=head1 CHANGES
Added local_ip option - Matt Simerson (5/2010)
Refactored and added p0f v3 support - Matt Simerson (4/2012)
2012 - Matt Simerson - refactored, v3 support
=cut

455
plugins/karma Normal file
View File

@ -0,0 +1,455 @@
#!perl -w
=head1 NAME
karma - reward nice and penalize naughty mail senders
=head1 SYNOPSIS
Karma tracks sender history, providing the ability to deliver differing levels
of service to naughty, nice, and unknown senders.
=head1 DESCRIPTION
Karma records the number of nice, naughty, and total connections from mail
senders. After sending a naughty message, if a sender has more naughty than
nice connections, they are penalized for I<penalty_days>. Connections
from senders in the penalty box are tersely disconnected.
Karma provides other plugins with a karma value they can use to be more
lenient, strict, or skip processing entirely.
Karma is small, fast, and ruthlessly efficient. Karma can be used to craft
custom connection policies such as these two examples:
=over 4
Hi there, well behaved sender. Please help yourself to TLS, AUTH, greater
concurrency, multiple recipients, no delays, and other privileges.
Hi there, naughty sender. Enjoy this poke in the eye with a sharp stick. Bye.
=back
=head1 CONFIG
=head2 negative <integer>
How negative a senders karma can get before we penalize them for sending a
naughty message. Karma is the number of nice - naughty connections.
Default: 1
Examples:
negative 1: 0 nice - 1 naughty = karma -1, penalize
negative 1: 1 nice - 1 naughty = karma 0, okay
negative 2: 1 nice - 2 naughty = karma -1, okay
negative 2: 1 nice - 3 naughty = karma -2, penalize
With the default negative limit of one, there's a very small chance you could
penalize a "mostly good" sender. Raising it to 2 reduces that possibility to
improbable.
=head2 penalty_days <days>
The number of days a naughty sender is refused connections. Use a decimal
value to penalize for portions of days.
karma penalty_days 1
Default: 1
=head2 reject
karma reject [ 0 | 1 | connect | zombie ]
I<0> will not reject any connections.
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.
=head2 db_dir <path>
Path to a directory in which the DB will be stored. This directory must be
writable by the qpsmtpd user. If unset, the first usable directory from the
following list will be used:
=over 4
=item /var/lib/qpsmtpd/karma
=item I<BINDIR>/var/db (where BINDIR is the location of the qpsmtpd binary)
=item I<BINDIR>/config
=back
=head2 loglevel
Adjust the quantity of logging for this plugin. See docs/logging.pod
=head1 BENEFITS
Karma reduces the resources wasted by naughty mailers.
When used with the
I<reject connect> setting, naughty senders are disconnected in about 0.1 seconds.
The biggest gains to be had are by having heavy plugins (spamassassin, dspam,
virus filters) set the B<karma> transaction note (see KARMA) when they encounter
naughty senders. Reasons to send servers to the penalty box could include
sending a virus, early talking, or sending messages with a very high spam
score.
This plugin does not penalize connections with transaction notes I<relayclient>
or I<whitelisthost> set. These notes would have been set by the B<relay>,
B<whitelist>, and B<dns_whitelist_soft> plugins. Obviously, those plugins must
run before B<karma> for that to work.
=head1 KARMA
No attempt is made by this plugin to determine what karma is. It is up to
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
};
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
the penalty box will be tersely disconnected for I<penalty_days>. Here is
an example connection from an IP in the penalty box:
73122 Connection from smtp.midsetmediacorp.com [64.185.226.65]
73122 (connect) ident::geoip: US, United States
73122 (connect) ident::p0f: Windows 7 or 8
73122 (connect) earlytalker: pass: 64.185.226.65 said nothing spontaneous
73122 (connect) relay: skip: no match
73122 (connect) karma: fail
73122 550 You were naughty. You are penalized for 0.99 more days.
73122 click, disconnecting
73122 (post-connection) connection_time: 1.048 s.
If we only sets 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 USING KARMA
To get rid of naughty connections as fast as possible, run karma before other
connection plugins. Plugins that trigger DNS lookups or impose time delays
should run after B<karma>. In this example, karma runs before all but the
ident plugins.
89011 Connection from Unknown [69.61.27.204]
89011 (connect) ident::geoip: US, United States
89011 (connect) ident::p0f: Linux 3.x
89011 (connect) karma: fail, 1 naughty, 0 nice, 1 connects
89011 550 You were naughty. You are penalized for 0.99 more days.
89011 click, disconnecting
89011 (post-connection) connection_time: 0.118 s.
88798 cleaning up after 89011
Unlike RBLs, B<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.
=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
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!
=head1 EFFECTIVENESS
In the first 24 hours, B<karma> rejected 8% of all connections. After one
week of running with I<penalty_days 1>, karma has rejected 15% of all
connections.
This plugins effectiveness results from the propensity of naughty senders
to be repeat offenders. Limiting them to a single offense per day(s) greatly
reduces the number of useless tokens miscreants add to our Bayes databases.
Of the connections that had previously passed all other checks and were caught
only by spamassassin and/or dspam, B<karma> rejected 31 percent. Since
spamassassin and dspam consume more resources than others plugins, this plugin
seems to be a very big win.
=head1 DATABASE
Connection summaries are stored in a database. The database key is the int
form of the remote IP. The value is a : delimited list containing a penalty
box start time (if the server is/was on timeout) and the count of naughty,
nice, and total connections. The database can be listed and searched with the
karma_dump.pl script.
=head1 BUGS & LIMITATIONS
This plugin is reactionary. Like the FBI, it doesn't punish until
after a crime has been committed. It an "abuse me once, shame on you,
abuse me twice, shame on me" policy.
There is little to be gained by listing servers that are already on DNS
blacklists, send to non-existent users, earlytalkers, etc. Those already have
very lightweight tests.
=head1 AUTHOR
2012 - Matt Simerson - msimerson@cpan.org
=head1 ACKNOWLEDGEMENTS
Gavin Carr's DB implementation in the greylisting plugin.
=cut
use strict;
use warnings;
use Qpsmtpd::Constants;
BEGIN { @AnyDBM_File::ISA = qw(DB_File GDBM_File NDBM_File) }
use AnyDBM_File;
use Fcntl qw(:DEFAULT :flock LOCK_EX LOCK_NB);
use Net::IP;
sub register {
my ($self, $qp ) = shift, shift;
$self->log(LOGERROR, "Bad arguments") if @_ % 2;
$self->{_args} = { @_ };
$self->{_args}{negative} ||= 1;
$self->{_args}{penalty_days} ||= 1;
$self->{_args}{reject_type} ||= 'disconnect';
if ( ! defined $self->{_args}{reject} ) {
$self->{_args}{reject} = 'zombie';
};
#$self->prune_db(); # keep the DB compact
$self->register_hook('connect', 'connect_handler');
$self->register_hook('disconnect', 'disconnect_handler');
}
sub connect_handler {
my $self = shift;
$self->connection->notes('karma', 0); # default
return DECLINED if $self->is_immune();
my $db = $self->get_db_location();
my $lock = $self->get_db_lock( $db ) or return DECLINED;
my $tied = $self->get_db_tie( $db, $lock ) or return DECLINED;
my $key = $self->get_db_key();
if ( ! $tied->{$key} ) {
$self->log(LOGINFO, "pass, no record");
return $self->cleanup_and_return($tied, $lock );
};
my ($penalty_start_ts, $naughty, $nice, $connects) = $self->parse_value( $tied->{$key} );
my $summary = "$naughty naughty, $nice nice, $connects connects";
my $karma = 0;
if ( $naughty || $nice ) {
$karma = $nice || 0 - $naughty || 0;
$self->connection->notes('karma_history', $karma );
};
my $happy_return = $karma > 3 ? DONE : DECLINED; # skip other connection tests?
if ( ! $penalty_start_ts ) {
$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.";
return $self->get_reject( $mess );
}
sub disconnect_handler {
my $self = shift;
my $karma = $self->connection->notes('karma') or do {
$self->log(LOGDEBUG, "no karma");
return DECLINED;
};
my $db = $self->get_db_location();
my $lock = $self->get_db_lock( $db ) or return DECLINED;
my $tied = $self->get_db_tie( $db, $lock ) or return DECLINED;
my $key = $self->get_db_key();
my ($penalty_start_ts, $naughty, $nice, $connects) = $self->parse_value( $tied->{$key} );
if ( $karma < 0 ) {
$naughty++;
my $negative_limit = 0 - $self->{_args}{negative};
my $karma_history = ($nice || 0) - $naughty;
if ( $karma_history <= $negative_limit ) {
$self->log(LOGINFO, "negative, sent to penalty box");
$penalty_start_ts = sprintf "%s", time;
}
else {
$self->log(LOGINFO, "negative");
};
}
elsif ($karma > 1) {
$nice++;
$self->log(LOGINFO, "positive");
}
$tied->{$key} = join(':', $penalty_start_ts, $naughty, $nice, ++$connects);
return $self->cleanup_and_return($tied, $lock );
}
sub parse_value {
my ($self, $value) = @_;
my $penalty_start_ts = my $naughty = my $nice = my $connects = 0;
if ( $value ) {
($penalty_start_ts, $naughty, $nice, $connects) = split /:/, $value;
$penalty_start_ts ||= 0;
$nice ||= 0;
$naughty ||= 0;
$connects ||= 0;
};
return ($penalty_start_ts, $naughty, $nice, $connects );
};
sub cleanup_and_return {
my ($self, $tied, $lock, $return_val ) = @_;
untie $tied;
close $lock;
return ($return_val) if defined $return_val; # explicit override
return (DECLINED);
};
sub get_db_key {
my $self = shift;
my $nip = Net::IP->new( $self->qp->connection->remote_ip );
return $nip->intip; # convert IP to an int
};
sub get_db_tie {
my ( $self, $db, $lock ) = @_;
tie( my %db, 'AnyDBM_File', $db, O_CREAT|O_RDWR, 0600) or do {
$self->log(LOGCRIT, "tie to database $db failed: $!");
close $lock;
return;
};
return \%db;
};
sub get_db_location {
my $self = shift;
# Setup database location
my ($QPHOME) = ($0 =~ m!(.*?)/([^/]+)$!);
my @candidate_dirs = ( $self->{args}{db_dir},
"/var/lib/qpsmtpd/karma", "$QPHOME/var/db", "$QPHOME/config", '.' );
my $dbdir;
for my $d ( @candidate_dirs ) {
next if ! $d || ! -d $d; # impossible
$dbdir = $d;
last; # first match wins
}
my $db = "$dbdir/karma.dbm";
$self->log(LOGDEBUG,"using $db as karma database");
return $db;
};
sub get_db_lock {
my ($self, $db) = @_;
return $self->get_db_lock_nfs($db) if $self->{_args}{nfslock};
# Check denysoft db
open( my $lock, ">$db.lock" ) or do {
$self->log(LOGCRIT, "opening lockfile failed: $!");
return;
};
flock( $lock, LOCK_EX ) or do {
$self->log(LOGCRIT, "flock of lockfile failed: $!");
close $lock;
return;
};
return $lock;
}
sub get_db_lock_nfs {
my ($self, $db) = @_;
require File::NFSLock;
### set up a lock - lasts until object looses scope
my $nfslock = new File::NFSLock {
file => "$db.lock",
lock_type => LOCK_EX|LOCK_NB,
blocking_timeout => 10, # 10 sec
stale_lock_timeout => 30 * 60, # 30 min
} or do {
$self->log(LOGCRIT, "nfs lockfile failed: $!");
return;
};
open( my $lock, "+<$db.lock") or do {
$self->log(LOGCRIT, "opening nfs lockfile failed: $!");
return;
};
return $lock;
};
sub prune_db {
my $self = shift;
my $db = $self->get_db_location();
my $lock = $self->get_db_lock( $db ) or return DECLINED;
my $tied = $self->get_db_tie( $db, $lock ) or return DECLINED;
my $count = keys %$tied;
my $pruned = 0;
foreach my $key ( keys %$tied ) {
my $ts = $tied->{$key};
my $days_old = ( time - $ts ) / 86400;
next if $days_old < $self->{_args}{penalty_days} * 2;
delete $tied->{$key};
$pruned++;
};
untie $tied;
close $lock;
$self->log( LOGINFO, "pruned $pruned of $count DB entries" );
return $self->cleanup_and_return( $tied, $lock, DECLINED );
};

250
plugins/karma_tool Executable file
View File

@ -0,0 +1,250 @@
#!/usr/bin/perl
package Karma;
use strict;
use warnings;
BEGIN { @AnyDBM_File::ISA = qw(DB_File GDBM_File NDBM_File) }
use AnyDBM_File;
use Data::Dumper;
use Fcntl qw(:DEFAULT :flock LOCK_EX LOCK_NB);
use Net::IP qw(:PROC);
use POSIX qw(strftime);
my $self = bless( { args => { db_dir => 'config' }, }, 'Karma' );
my $command = $ARGV[0];
if ( ! $command ) {
$self->usage();
}
elsif ( $command eq 'capture' ) {
$self->capture( $ARGV[1] );
}
elsif ( $command eq 'release' ) {
$self->capture( $ARGV[1] );
}
elsif ( $command eq 'prune' ) {
$self->prune_db( $ARGV[1] || 7 );
}
elsif ( $command eq 'list' ) {
$self->main();
};
exit(0);
sub usage {
print <<EO_HELP
karma_tool [ list search prune capture release ]
list takes no arguments.
search [ naughty nice both ]
and returns a list of matching IPs
capture [ IP ]
sends an IP to the penalty box
release [ IP ]
remove an IP from the penalty box
prune takes no arguments.
prunes database of entries older than 7 days
EO_HELP
;
};
sub capture {
my $self = shift;
my $ip = shift or return;
is_ip( $ip ) or do {
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(':', time, 1, 0, 1);
return $self->cleanup_and_return( $tied, $lock );
};
sub release {
my $self = shift;
my $ip = shift or return;
is_ip( $ip ) or do {
warn "not an IP: $ip\n";
return;
};
my $db = $self->get_db_location();
my $lock = $self->get_db_lock( $db ) or return;
my $tied = $self->get_db_tie( $db, $lock ) or return;
my $key = $self->get_db_key( $ip );
$tied->{$key} = join(':', 0, 1, 0, 1);
return $self->cleanup_and_return( $tied, $lock );
};
sub main {
my $self = shift;
my $db = $self->get_db_location();
my $lock = $self->get_db_lock( $db ) or return;
my $tied = $self->get_db_tie( $db, $lock ) or return;
my %totals;
print " IP Address Penalty Naughty Nice Connects Hostname\n";
foreach my $r ( sort keys %$tied ) {
my $ip = ip_bintoip( ip_inttobin( $r, 4 ), 4);
my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/, $tied->{$r};
$naughty ||= '';
$nice ||= '';
$connects ||= '';
my $time_human = '';
if ( $command eq 'search' ) {
my $search = $ARGV[1];
if ( $search eq 'nice' ) {
next if ! $nice;
}
elsif ( $search eq 'naughty' ) {
next if ! $naughty;
}
elsif ( $search eq 'both' ) {
next if ! $naughty || ! $nice;
}
elsif ( is_ip() && $search ne $ip ) {
next;
}
};
if ( $penalty_start_ts ) {
$time_human = strftime "%a %b %e %H:%M", localtime $penalty_start_ts;
};
my $hostname = '';
if ( $naughty && $nice ) {
$hostname = `dig +short -x $ip`; chomp $hostname;
};
printf(" %-18s %24s %3s %3s %3s %30s\n", $ip, $time_human, $naughty, $nice, $connects, $hostname);
$totals{naughty} += $naughty if $naughty;
$totals{nice} += $nice if $nice;
$totals{connects} += $connects if $connects;
};
print Dumper(\%totals);
}
sub is_ip {
my $ip = shift || $ARGV[0];
return 1 if $ip =~ /^(\d{1,3}\.){3}\d{1,3}$/;
return;
};
sub cleanup_and_return {
my ($self, $tied, $lock ) = @_;
untie $tied;
close $lock;
};
sub get_db_key {
my $self = shift;
my $nip = Net::IP->new( shift );
return $nip->intip; # convert IP to an int
};
sub get_db_tie {
my ( $self, $db, $lock ) = @_;
tie( my %db, 'AnyDBM_File', $db, O_CREAT|O_RDWR, 0600) or do {
warn "tie to database $db failed: $!";
close $lock;
return;
};
return \%db;
};
sub get_db_location {
my $self = shift;
# Setup database location
my @candidate_dirs = ( $self->{args}{db_dir},
"/var/lib/qpsmtpd/karma", "./var/db", "./config", '.' );
my $dbdir;
for my $d ( @candidate_dirs ) {
next if ! $d || ! -d $d; # impossible
$dbdir = $d;
last; # first match wins
}
my $db = "$dbdir/karma.dbm";
print "using karma db at $db\n";
return $db;
};
sub get_db_lock {
my ($self, $db) = @_;
return $self->get_db_lock_nfs($db) if $self->{_args}{nfslock};
# Check denysoft db
open( my $lock, ">$db.lock" ) or do {
warn "opening lockfile failed: $!";
return;
};
flock( $lock, LOCK_EX ) or do {
warn "flock of lockfile failed: $!";
close $lock;
return;
};
return $lock;
}
sub get_db_lock_nfs {
my ($self, $db) = @_;
require File::NFSLock;
### set up a lock - lasts until object looses scope
my $nfslock = new File::NFSLock {
file => "$db.lock",
lock_type => LOCK_EX|LOCK_NB,
blocking_timeout => 10, # 10 sec
stale_lock_timeout => 30 * 60, # 30 min
} or do {
warn "nfs lockfile failed: $!";
return;
};
open( my $lock, "+<$db.lock") or do {
warn "opening nfs lockfile failed: $!";
return;
};
return $lock;
};
sub prune_db {
my $self = shift;
my $prune_days = shift;
my $db = $self->get_db_location();
my $lock = $self->get_db_lock( $db ) or return;
my $tied = $self->get_db_tie( $db, $lock ) or return;
my $count = keys %$tied;
my $pruned = 0;
foreach my $key ( keys %$tied ) {
my ($ts, $naughty, $nice, $connects) = split /:/, $tied->{$key};
my $days_old = ( time - $ts ) / 86400;
next if $days_old < $prune_days;
delete $tied->{$key};
$pruned++;
};
untie $tied;
close $lock;
warn "pruned $pruned of $count DB entries";
return $self->cleanup_and_return( $tied, $lock );
};

237
plugins/relay Normal file
View File

@ -0,0 +1,237 @@
#!perl -w
=head1 SYNOPSIS
relay - control whether relaying is permitted
=head1 DESCRIPTION
relay - check the following places to see if relaying is allowed:
I<$ENV{RELAYCLIENT}>
I<config/norelayclients>, I<config/relayclients>, I<config/morerelayclients>
The search order is as shown and cascades until a match is found or the list
is exhausted.
Note that I<norelayclients> is the first file checked. A match there will
override matches in the subsequent files.
=head1 CONFIG
Enable this plugin by adding it to config/plugins above the rcpt_* plugins
# other plugins...
relay
# rcpt_* go here
=head2 relayclients
A list of IP addresses that are permitted to relay mail through this server.
Each line in I<relayclients> is one of:
- a full IP address
- partial IP address terminated by a dot or colon for matching whole networks
192.168.42.
fdda:b13d:e431:ae06:
...
- a network/mask, aka a CIDR block
10.1.0.0/24
fdda:b13d:e431:ae06::/64
...
=head2 morerelayclients
Additional IP addresses that are permitted to relay. The syntax of the config
file is identical to I<relayclients> except that CIDR (net/mask) entries are
not supported. If you have many (>50) IPs allowed to relay, most should likely
be listed in I<morerelayclients> where lookups are faster.
=head2 norelayclients
I<norelayclients> allows specific clients, such as a mail gateway, to be denied
relaying, even though they would be allowed by I<relayclients>. This is most
useful when a block of IPs is allowed in relayclients, but several IPs need to
be excluded.
The file format is the same as morerelayclients.
=head2 RELAY ONLY
The relay only option restricts connections to only clients that have relay
permission. All other connections are denied during the RCPT phase of the
SMTP conversation.
This option is useful when a server is used as the smart relay host for
internal users and external/authenticated users, but should not be considered
a normal inbound MX server.
It should be configured to be run before other RCPT hooks! Only clients that
have authenticated or are listed in the relayclient file will be allowed to
send mail.
To enable relay only mode, set the B<only> option to any true value in
I<config/plugins> as shown:
relay only 1
=head1 AUTHOR
2012 - Matt Simerson - Merged check_relay, check_norelay, and relayonly
2006 - relay_only - John Peackock
2005 - check_norelay - Copyright Gordon Rowell <gordonr@gormand.com.au>
2002 - check_relay - Ask Bjorn Hansen
=head1 LICENSE
This software is free software and may be distributed under the same
terms as qpsmtpd itself.
=cut
use strict;
use warnings;
use Qpsmtpd::Constants;
use Net::IP qw(:PROC);
sub register {
my ($self, $qp) = shift, shift;
$self->log(LOGERROR, "Bad arguments") if @_ % 2;
$self->{_args} = { @_ };
if ( $self->{_args}{only} ) {
$self->register_hook('rcpt', 'relay_only');
};
};
sub is_in_norelayclients {
my $self = shift;
my %no_relay_clients = map { $_ => 1 } $self->qp->config('norelayclients');
my $ip = $self->qp->connection->remote_ip;
while ( $ip ) {
if ( exists $no_relay_clients{$ip} ) {
$self->log(LOGNOTICE, "$ip in norelayclients");
return 1;
}
$ip =~ s/(\d|\w)+(:|\.)?$// or last; # strip off another octet
};
$self->log(LOGDEBUG, "no match in norelayclients");
return;
};
sub populate_relayclients {
my $self = shift;
foreach ( $self->qp->config('relayclients') ) {
my ($network, $netmask) = ip_splitprefix($_);
if ( $netmask ) {
push @{ $self->{_cidr_blocks} }, $_;
next;
}
$self->{_octets}{$_} = 1; # no prefix, split
}
};
sub is_in_cidr_block {
my $self = shift;
my $ip = $self->qp->connection->remote_ip;
my $cversion = ip_get_version($ip);
for ( @{ $self->{_cidr_blocks} } ) {
my ($network, $mask) = ip_splitprefix($_); # split IP & CIDR range
my $rversion = ip_get_version($network); # get IP version (4 vs 6)
my ($begin, $end) = ip_normalize($_, $rversion); # get pool start/end
# expand the client address (zero pad it) before converting to binary
my $bin_ip = ip_iptobin(ip_expand_address($ip, $cversion), $cversion);
if ( ip_bincomp($bin_ip, 'gt', ip_iptobin($begin, $rversion))
&& ip_bincomp($bin_ip, 'lt', ip_iptobin($end, $rversion))
) {
$self->log(LOGINFO, "pass: cidr match ($ip)");
return 1;
}
}
$self->log(LOGDEBUG, "no cidr match");
return;
};
sub is_octet_match {
my $self = shift;
my $ip = $self->qp->connection->remote_ip;
$ip =~ s/::/:/;
if ( $ip eq ':1' ) {
$self->log(LOGINFO, "pass: octet matched localhost ($ip)");
return 1;
};
my $more_relay_clients = $self->qp->config('morerelayclients', 'map');
while ($ip) {
if ( exists $self->{_octets}{$ip} ) {
$self->log(LOGINFO, "pass: octet match in relayclients ($ip)");
return 1;
};
if ( exists $more_relay_clients->{$ip} ) {
$self->log(LOGINFO, "pass: octet match in morerelayclients ($ip)");
return 1;
};
$ip =~ s/(\d|\w)+(:|\.)?$// or last; # strip off another 8 bits
}
$self->log(LOGDEBUG, "no octet match" );
return;
}
sub hook_connect {
my ($self, $transaction) = @_;
if ( $self->is_in_norelayclients() ) {
$self->qp->connection->relay_client(0);
delete $ENV{RELAYCLIENT};
return (DECLINED);
}
if ( $ENV{RELAYCLIENT} ) {
$self->qp->connection->relay_client(1);
$self->log(LOGINFO, "pass: enabled by env");
return (DECLINED);
};
$self->populate_relayclients();
if ( $self->is_in_cidr_block() || $self->is_octet_match() ) {
$self->qp->connection->relay_client(1);
return (DECLINED);
};
$self->log(LOGINFO, "skip: no match");
return (DECLINED);
}
sub relay_only {
my $self = shift;
if ( $self->qp->connection->relay_client ) {
return (OK);
};
return (DENY);
}

View File

@ -1,36 +0,0 @@
#!perl -w
=head1 NAME
relay_only - this plugin only permits relaying
=head1 SYNOPSIS
# in config/plugins
check_relay
relay_only
# other rcpt hooks go here
=head1 DESCRIPTION
This plugin can be used for the case where a server is used as the smart
relay host for internal users and external/authenticated users, but should
not be considered a normal inbound MX server
It should be configured to be run _AFTER_ check_relay and before other
RCPT hooks! Only clients that have authenticated or are listed in the
relayclient file will be allowed to send mail.
=cut
sub hook_rcpt {
if ( shift->qp->connection->relay_client ) {
return (OK);
}
else {
return (DENY);
}
}

View File

@ -167,7 +167,7 @@ sub hook_rcpt {
}
elsif ( $code eq 'permerror' ) {
return (DENY, "SPF - $code: $why") if $reject >= 6;
return (DENYSOFT, "SPF - $code: $why") if $reject >= 2;
return (DENYSOFT, "SPF - $code: $why") if $reject >= 3;
}
elsif ( $code eq 'temperror' ) {
return (DENYSOFT, "SPF - $code: $why") if $reject >= 2;

View File

@ -69,6 +69,7 @@ sub input {
}
sub config_dir {
return './t/config' if $ENV{QPSMTPD_DEVELOPER};
'./config.sample';
}

View File

@ -5,8 +5,10 @@ package Test::Qpsmtpd::Plugin;
package Qpsmtpd::Plugin;
use strict;
use Test::More;
use warnings;
use Qpsmtpd::Constants;
use Test::More;
sub register_tests {
# Virtual base method - implement in plugin

View File

@ -5,12 +5,17 @@ use strict;
use lib 't';
use_ok('Test::Qpsmtpd');
my @mes;
BEGIN { # need this to happen before anything else
my $cwd = `pwd`;
chomp($cwd);
open my $me_config, '>', "./config.sample/me";
print $me_config "some.host.example.org";
close $me_config;
@mes = qw{ ./config.sample/me ./t/config/me };
foreach my $f ( @mes ) {
open my $me_config, '>', $f;
print $me_config "some.host.example.org";
close $me_config;
};
}
ok(my ($smtpd, $conn) = Test::Qpsmtpd->new_conn(), "get new connection");
@ -20,8 +25,10 @@ is($smtpd->config('me'), 'some.host.example.org', 'config("me")');
# test for ignoring leading/trailing whitespace (relayclients has a
# line with both)
my $relayclients = join ",", sort $smtpd->config('relayclients');
is($relayclients, '127.0.0.1,192.168.', 'config("relayclients") are trimmed');
is($relayclients, '127.0.0.1,192.0.', 'config("relayclients") are trimmed');
unlink "./config.sample/me";
foreach my $f ( @mes ) {
unlink $f if -f $f;
};

4
t/config/badhelo Normal file
View File

@ -0,0 +1,4 @@
# these domains never uses their domain when greeting us, so reject transactions
aol.com
yahoo.com

9
t/config/badrcptto Normal file
View File

@ -0,0 +1,9 @@
######## entries used for testing ###
bad@example.com
@bad.example.com
######## Example patterns #######
# Format is pattern\s+Response
# Don't forget to anchor the pattern if required
! Sorry, bang paths not accepted here
@.*@ Sorry, multiple at signs not accepted here
% Sorry, percent hack not accepted here

1
t/config/dnsbl_zones Normal file
View File

@ -0,0 +1 @@
zen.spamhaus.org

2
t/config/flat_auth_pw Normal file
View File

@ -0,0 +1,2 @@
good@example.com:good_pass
bad@example.com:bad_pass

94
t/config/plugins Normal file
View File

@ -0,0 +1,94 @@
#
# Example configuration file for plugins
#
# enable this to get configuration via http; see perldoc
# plugins/http_config for details.
# http_config http://localhost/~smtpd/config/ http://www.example.com/smtp.pl?config=
# hosts_allow does not work with the tcpserver deployment model!
# perldoc plugins/hosts_allow for an alternative.
#
# The hosts_allow module must be loaded if you want the -m / --max-from-ip /
# my $MAXCONNIP = 5; # max simultaneous connections from one IP
# settings... without this it will NOT refuse more than $MAXCONNIP connections
# from one IP!
hosts_allow
# information plugins
ident/geoip
#ident/p0f /tmp/.p0f_socket version 3
connection_time
# enable to accept MAIL FROM:/RCPT TO: addresses without surrounding <>
dont_require_anglebrackets
# enable to reject MAIL FROM:/RCPT TO: parameters if client helo was HELO
# (strict RFC 821)... this is not used in EHLO ...
parse_addr_withhelo
quit_fortune
# tls should load before count_unrecognized_commands
#tls
check_earlytalker
count_unrecognized_commands 4
check_relay
require_resolvable_fromhost
rhsbl
dnsbl
check_badmailfrom
check_badrcptto
check_spamhelo
sender_permitted_from
greylisting p0f genre,windows
auth/auth_checkpassword checkpw /usr/local/vpopmail/bin/vchkpw true /usr/bin/true
auth/auth_vpopmail
auth/auth_vpopmaild
auth/auth_vpopmail_sql
auth/auth_flat_file
auth/authdeny
# this plugin needs to run after all other "rcpt" plugins
rcpt_ok
check_basicheaders days 5 reject_type temp
domainkeys
# content filters
virus/klez_filter
# You can run the spamassassin plugin with options. See perldoc
# plugins/spamassassin for details.
#
spamassassin
# rejects mails with a SA score higher than 20 and munges the subject
# of the score is higher than 10.
#
# spamassassin reject_threshold 20 munge_subject_threshold 10
# dspam must run after spamassassin for the learn_from_sa feature to work
dspam learn_from_sa 7 reject 1
# run the clamav virus checking plugin
virus/clamav
# You must enable a queue plugin - see the options in plugins/queue/ - for example:
# queue to a maildir
# queue/maildir /home/spamtrap/mail
# queue the mail with qmail-queue
queue/qmail-queue
# If you need to run the same plugin multiple times, you can do
# something like the following
# check_relay
# check_relay:0 somearg
# check_relay:1 someotherarg

1
t/config/rcpthosts Normal file
View File

@ -0,0 +1 @@
localhost

5
t/config/relayclients Normal file
View File

@ -0,0 +1,5 @@
# Format is IP, or IP part with trailing dot
# e.g. "127.0.0.1", or "192.168."
127.0.0.1
# leading/trailing whitespace is ignored
192.168.

View File

@ -7,3 +7,11 @@ my $qp = Test::Qpsmtpd->new();
$qp->run_plugin_tests();
foreach my $file (
"./t/config/greylist.dbm",
"./t/config/greylist.dbm.lock"
) {
next if ! -f $file;
unlink $file;
};

View File

@ -23,7 +23,7 @@ sub test_auth_vpopmail {
if ( ! $self->test_vpopmail_module ) {
warn "vpopmail plugin not configured\n";
foreach ( 0..2) { ok( 1, "test_auth_vpopmail, skipped") };
foreach ( 0..2) { ok( 1, "skipped") };
return;
};

View File

@ -6,6 +6,11 @@ use warnings;
sub register_tests {
my $self = shift;
eval 'use DBI';
if ( $@ ) {
warn "skipping auth_vpopmail_sql tests, is DBI installed?\n";
return;
};
$self->register_test("auth_vpopmail_sql", 3);
}
@ -15,7 +20,7 @@ sub auth_vpopmail_sql {
my $dbh = $self->get_db_handle() or do {
foreach ( 0..2 ) {
ok( 1, "auth_vpopmail_sql, skipped (no DB)" );
ok( 1, "skipped (no DB)" );
};
return;
};
@ -24,11 +29,11 @@ sub auth_vpopmail_sql {
my $vuser = $self->get_vpopmail_user( $dbh, 'postmaster@example.com' );
if ( ! $vuser || ! $vuser->{pw_passwd} ) {
foreach ( 0..1 ) {
ok( 1, "auth_vpopmail_sql, no example.com domain" );
ok( 1, "no example.com domain" );
};
return;
};
ok( ref $vuser, "auth_vpopmail_sql, found example.com domain" );
ok( ref $vuser, "found example.com domain" );
ok( $self->auth_vmysql(
$self->qp->transaction,
@ -38,6 +43,6 @@ sub auth_vpopmail_sql {
$vuser->{pw_passwd},
$ticket,
),
"auth_vpopmail_sql, postmaster"
"postmaster"
);
}

81
t/plugin_tests/relay Normal file
View File

@ -0,0 +1,81 @@
#!perl -w
use strict;
use warnings;
use Qpsmtpd::Constants;
sub register_tests {
my $self = shift;
$self->register_test('test_relay_only', 2);
$self->register_test('test_is_octet_match', 3);
$self->register_test('test_is_in_cidr_block', 4);
$self->register_test('test_is_in_norelayclients', 5);
}
sub test_relay_only {
my $self = shift;
$self->qp->connection->relay_client(0);
my $r = $self->relay_only();
cmp_ok( $r, '==', DENY, "relay_only -");
$self->qp->connection->relay_client(1);
$r = $self->relay_only();
cmp_ok( $r, '==', OK, "relay_only +");
$self->qp->connection->relay_client(0);
};
sub test_is_octet_match {
my $self = shift;
$self->populate_relayclients();
$self->qp->connection->remote_ip('192.0.1.1');
ok( $self->is_octet_match(), "match, +");
$self->qp->connection->remote_ip('192.51.1.1');
ok( ! $self->is_octet_match(), "nope, -");
$self->qp->connection->remote_ip('203.0.113.0');
ok( ! $self->is_octet_match(), "nope, -");
};
sub test_is_in_cidr_block {
my $self = shift;
$self->qp->connection->remote_ip('192.0.1.1');
$self->{_cidr_blocks} = [ '192.0.1.0/24' ];
ok( $self->is_in_cidr_block(), "match, +" );
$self->{_cidr_blocks} = [ '192.0.0.0/24' ];
ok( ! $self->is_in_cidr_block(), "nope, -" );
$self->qp->connection->remote_ip('fdda:b13d:e431:ae06:00a1::');
$self->{_cidr_blocks} = [ 'fdda:b13d:e431:ae06::/64' ];
ok( $self->is_in_cidr_block(), "match, +" );
$self->{_cidr_blocks} = [ 'fdda:b13d:e431:be17::' ];
ok( ! $self->is_in_cidr_block(), "nope, -" );
};
sub test_is_in_norelayclients {
my $self = shift;
my @matches = qw/ 192.0.99.5 192.0.98.1 192.0.98.255 /;
my @false = qw/ 192.0.99.7 192.0.109.7 /;
foreach ( @matches ) {
$self->qp->connection->remote_ip($_);
ok( $self->is_in_norelayclients(), "match, + ($_)");
};
foreach ( @false ) {
$self->qp->connection->remote_ip($_);
ok( ! $self->is_in_norelayclients(), "match, + ($_)");
};
};