byterazor/qpsmtpd
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

find plugins -type f -exec perltidy -b {} \;

Browse Source
This commit is contained in:
Matt Simerson 2013-04-21 00:50:39 -04:00
parent 5a0662b64a
commit f988f0337c
81 changed files with 4188 additions and 3696 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
plugins/async/earlytalker
View File

@ -91,7 +91,12 @@ sub check_talker_poll {
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'}) });
$qp->AddTimer(
1,
sub {
read_now($qp, $conn, $check_until, $self->{_args}{'check-at'});
}
);
return YIELD;
}
@ -99,12 +104,14 @@ 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->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;
}
@ -118,8 +125,8 @@ sub check_talker_post {
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 (DENY, $MSG) if $self->{_args}->{'action'} eq 'deny';
return (DENYSOFT, $MSG) if $self->{_args}->{'action'} eq 'denysoft';
return DECLINED; # assume action eq 'log'
}
@ -127,8 +134,8 @@ 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 (DENY, $MSG) if $self->{_args}->{'action'} eq 'deny';
return (DENYSOFT, $MSG) if $self->{_args}->{'action'} eq 'denysoft';
return DECLINED;
}

35
plugins/async/queue/smtp-forward
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->{to} = [$transaction->recipients];
$self->SUPER::new($sock);
# Watch for write first, this is when the TCP session is established.
$self->watch_write(1);
@ -137,7 +144,7 @@ sub new {
sub results {
my AsyncSMTPSender $self = shift;
return ( $self->{rcode}, $self->{rmsg} );
return ($self->{rcode}, $self->{rmsg});
}
sub log {
@ -157,8 +164,9 @@ sub command {
$self->log(LOGDEBUG, ">> $command $params");
$self->write(($command =~ m/ / ? "$command:" : $command)
. ($params ? " $params" : "") . "\r\n");
$self->write( ($command =~ m/ / ? "$command:" : $command)
. ($params ? " $params" : "")
. "\r\n");
$self->watch_read(1);
$self->{command} = ($command =~ /(\S+)/)[0];
}
@ -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;
@ -329,12 +339,12 @@ sub event_read {
my @lines = split /\r?\n/, $self->{buf} . $$in, -1;
$self->{buf} = delete $lines[-1];
for(@lines) {
for (@lines) {
if (my ($code, $cont, $rest) = /^([0-9]{3})([ -])(.*)/) {
$self->log(LOGDEBUG, "<< $code$cont$rest");
push @{$self->{resp}}, $rest;
if($cont eq ' ') {
if ($cont eq ' ') {
$self->handle_response($code, $self->{resp});
$self->{resp} = [];
}
@ -363,6 +373,7 @@ sub event_write {
$self->watch_read(1);
}
elsif (0 && $self->{state} == ST_DATA) {
# send more data
if (my $line = $self->{tran}->body_getline) {
$self->log(LOGDEBUG, ">> $line");
@ -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;

89
plugins/async/resolvable_fromhost
View File

@ -14,45 +14,47 @@ my %invalid = ();
my $has_ipv6 = Qpsmtpd::TcpServer::has_ipv6();
sub register {
my ( $self, $qp ) = @_;
my ($self, $qp) = @_;
foreach my $i ( $self->qp->config("invalid_resolvable_fromhost") ) {
foreach my $i ($self->qp->config("invalid_resolvable_fromhost")) {
$i =~ s/^\s*//;
$i =~ s/\s*$//;
if ( $i =~ m#^((\d{1,3}\.){3}\d{1,3})/(\d\d?)# ) {
if ($i =~ m#^((\d{1,3}\.){3}\d{1,3})/(\d\d?)#) {
$invalid{$1} = $3;
}
}
eval 'use ParaDNS';
if ( $@ ) {
if ($@) {
warn "could not load ParaDNS, plugin disabled";
return DECLINED;
};
$self->register_hook( mail => 'hook_mail_start' );
$self->register_hook( mail => 'hook_mail_done' );
}
$self->register_hook(mail => 'hook_mail_start');
$self->register_hook(mail => 'hook_mail_done');
}
sub hook_mail_start {
my ( $self, $transaction, $sender ) = @_;
my ($self, $transaction, $sender) = @_;
return DECLINED
if ($self->connection->notes('whitelisthost'));
if ( $sender ne '<>' ) {
if ($sender ne '<>') {
unless ($sender->host) {
unless ( $sender->host ) {
# default of addr_bad_from_system is DENY, we use DENYSOFT here to
# get the same behaviour as without Qpsmtpd::DSN...
return Qpsmtpd::DSN->addr_bad_from_system( DENYSOFT,
"FQDN required in the envelope sender" );
return
Qpsmtpd::DSN->addr_bad_from_system(DENYSOFT,
"FQDN required in the envelope sender");
}
return DECLINED if $sender->host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/;
unless ($self->check_dns( $sender->host )) {
unless ($self->check_dns($sender->host)) {
return Qpsmtpd::DSN->temp_resolver_failed(
"Could not resolve " . $sender->host );
"Could not resolve " . $sender->host);
}
return YIELD;
@ -62,21 +64,22 @@ sub hook_mail_start {
}
sub hook_mail_done {
my ( $self, $transaction, $sender ) = @_;
my ($self, $transaction, $sender) = @_;
return DECLINED
if ( $self->connection->notes('whitelisthost') );
if ($self->connection->notes('whitelisthost'));
if ($sender ne "<>" && !$transaction->notes('resolvable_fromhost')) {
if ( $sender ne "<>" && !$transaction->notes('resolvable_fromhost') ) {
# default of temp_resolver_failed is DENYSOFT
return Qpsmtpd::DSN->temp_resolver_failed(
"Could not resolve " . $sender->host );
"Could not resolve " . $sender->host);
}
return DECLINED;
}
sub check_dns {
my ( $self, $host ) = @_;
my ($self, $host) = @_;
my @host_answers;
my $qp = $self->qp;
@ -96,8 +99,13 @@ sub check_dns {
$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) },
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',
);
@ -105,8 +113,13 @@ sub check_dns {
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) },
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',
);
@ -118,8 +131,13 @@ sub check_dns {
$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) },
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',
);
@ -127,8 +145,13 @@ sub check_dns {
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) },
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',
);
@ -141,7 +164,8 @@ sub check_dns {
},
host => $host,
type => 'MX',
) or $qp->input_sock->continue_read, return;
)
or $qp->input_sock->continue_read, return;
return 1;
}
@ -161,6 +185,7 @@ sub finish_up {
}
unless ($num_queries) {
# all queries returned no valid response
$qp->transaction->notes('resolvable_fromhost', 0);
$qp->input_sock->continue_read;
@ -170,12 +195,12 @@ sub finish_up {
sub is_valid {
my $ip = shift;
my ( $net, $mask );
foreach $net ( keys %invalid ) {
my ($net, $mask);
foreach $net (keys %invalid) {
$mask = $invalid{$net};
$mask = pack "B32", "1" x ($mask) . "0" x ( 32 - $mask );
$mask = pack "B32", "1" x ($mask) . "0" x (32 - $mask);
return 0
if join( ".", unpack( "C4", inet_aton($ip) & $mask ) ) eq $net;
if join(".", unpack("C4", inet_aton($ip) & $mask)) eq $net;
}
return 1;
}

25
plugins/async/uribl
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}}) {
@ -45,7 +48,7 @@ sub start_data_post {
$transaction->notes(uribl_zones => $self->{uribl_zones});
return DECLINED
unless @hosts && $class->lookup($self->qp, [ @hosts ], [ @hosts ]);
unless @hosts && $class->lookup($self->qp, [@hosts], [@hosts]);
return YIELD;
}
@ -58,9 +61,11 @@ sub finish_data_post {
$self->log(LOGWARN, $_->{desc});
if ($_->{action} eq 'add-header') {
$transaction->header->add('X-URIBL-Match', $_->{desc});
} elsif ($_->{action} eq 'deny') {
}
elsif ($_->{action} eq 'deny') {
return (DENY, $_->{desc});
} elsif ($_->{action} eq 'denysoft') {
}
elsif ($_->{action} eq 'denysoft') {
return (DENYSOFT, $_->{desc});
}
}
@ -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}
),
};
}
}

33
plugins/auth/auth_checkpassword
View File

@ -106,10 +106,10 @@ Please see the LICENSE file included with qpsmtpd for details.
=cut
sub register {
my ($self, $qp, %args ) = @_;
my ($self, $qp, %args) = @_;
my ($checkpw, $true) = $self->get_checkpw( \%args );
return DECLINED if ! $checkpw || ! $true;
my ($checkpw, $true) = $self->get_checkpw(\%args);
return DECLINED if !$checkpw || !$true;
$self->connection->notes('auth_checkpassword_bin', $checkpw);
$self->connection->notes('auth_checkpassword_true', $true);
@ -124,7 +124,7 @@ sub auth_checkpassword {
my $binary = $self->connection->notes('auth_checkpassword_bin');
my $true = $self->connection->notes('auth_checkpassword_true');
chomp ($binary, $true);
chomp($binary, $true);
my $sudo = get_sudo($binary);
@ -138,7 +138,7 @@ sub auth_checkpassword {
if ($status != 0) {
$self->log(LOGNOTICE, "authentication failed ($status)");
return (DECLINED);
};
}
$self->connection->notes('authuser', $user);
return (OK, "auth_checkpassword");
@ -150,26 +150,27 @@ sub get_checkpw {
my ($checkpw) = $args->{checkpw} =~ /^(.*)$/ if $args->{checkpw}; # untaint
my ($true) = $args->{true} =~ /^(.*)$/ if $args->{true}; # untaint
return ( $checkpw, $true )
if ( $checkpw && $true && -x $checkpw && -x $true );
return ($checkpw, $true)
if ($checkpw && $true && -x $checkpw && -x $true);
my $missing_config = "disabled due to invalid configuration. See 'perldoc plugins/auth/auth_checkpassword' for how to configure.";
my $missing_config =
"disabled due to invalid configuration. See 'perldoc plugins/auth/auth_checkpassword' for how to configure.";
if ( ! $self->qp->config('smtpauth-checkpassword') ) {
$self->log(LOGERROR, $missing_config );
if (!$self->qp->config('smtpauth-checkpassword')) {
$self->log(LOGERROR, $missing_config);
return;
};
}
$self->log(LOGNOTICE, "reading config from smtpauth-checkpassword");
my $config = $self->qp->config("smtpauth-checkpassword");
($checkpw, $true) = $config =~ /^(\S+)\s+(\S+)\s*$/;
if ( ! $checkpw || ! $true || ! -x $checkpw || ! -x $true ) {
$self->log(LOGERROR, $missing_config );
if (!$checkpw || !$true || !-x $checkpw || !-x $true) {
$self->log(LOGERROR, $missing_config);
return;
};
}
return ($checkpw, $true);
};
}
sub get_sudo {
my $binary = shift;
@ -182,7 +183,7 @@ sub get_sudo {
return '' if $mode eq '4711'; # $binary is setuid
my $sudo = `which sudo` || '/usr/local/bin/sudo';
return '' if ! -x $sudo;
return '' if !-x $sudo;
$sudo .= ' -C4'; # prevent sudo from clobbering file descriptor 3

35
plugins/auth/auth_cvm_unix_local
View File

@ -50,14 +50,14 @@ use constant SMTP_PORT => getservbyname("smtp", "tcp") || 25;
use constant SSMTP_PORT => getservbyname("ssmtp", "tcp") || 465;
sub register {
my ( $self, $qp, %arg ) = @_;
my ($self, $qp, %arg) = @_;
unless ($arg{cvm_socket}) {
$self->log(LOGERROR, "skip: requires cvm_socket argument");
return 0;
};
}
$self->{_args} = { %arg };
$self->{_args} = {%arg};
$self->{_enable_smtp} = $arg{enable_smtp} || 'no';
$self->{_enable_ssmtp} = $arg{enable_ssmtp} || 'yes';
@ -77,11 +77,12 @@ sub register {
$self->register_hook("auth-plain", "authcvm_plain");
$self->register_hook("auth-login", "authcvm_plain");
# $self->register_hook("auth-cram-md5", "authcvm_hash");
# $self->register_hook("auth-cram-md5", "authcvm_hash");
}
sub authcvm_plain {
my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) =
my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) =
@_;
socket(SOCK, PF_UNIX, SOCK_STREAM, 0) or do {
@ -89,16 +90,18 @@ sub authcvm_plain {
return (DENY, "authcvm");
};
# DENY, really? Should this plugin return a DENY when it cannot connect
# to the cvs socket? I'd expect such a failure to return DECLINED, so
# any other auth plugins could take a stab at authenticating the user
# DENY, really? Should this plugin return a DENY when it cannot connect
# to the cvs socket? I'd expect such a failure to return DECLINED, so
# any other auth plugins could take a stab at authenticating the user
connect(SOCK, sockaddr_un($self->{_cvm_socket})) or do {
$self->log(LOGERROR, "skip: socket connection attempt for: $user");
return (DENY, "authcvm");
};
my $o = select(SOCK); $| = 1; select($o);
my $o = select(SOCK);
$| = 1;
select($o);
my ($u, $host) = split(/\@/, $user);
$host ||= "localhost";
@ -108,22 +111,22 @@ sub authcvm_plain {
shutdown SOCK, 1; # tell remote we're finished
my $ret = <SOCK>;
my ($s) = unpack ("C", $ret);
my ($s) = unpack("C", $ret);
if ( ! defined $s ) {
if (!defined $s) {
$self->log(LOGERROR, "skip: no response from cvm for $user");
return (DECLINED);
};
}
if ( $s == 0 ) {
if ($s == 0) {
$self->log(LOGINFO, "pass: authentication for: $user");
return (OK, "auth success for $user");
};
}
if ( $s == 100 ) {
if ($s == 100) {
$self->log(LOGINFO, "fail: authentication failure for: $user");
return (DENY, 'auth failure (100)');
};
}
$self->log(LOGERROR, "skip: unknown response from cvm for $user");
return (DECLINED, "unknown result code ($s)");

21
plugins/auth/auth_flat_file
View File

@ -37,7 +37,7 @@ use Qpsmtpd::Auth;
use Qpsmtpd::Constants;
sub register {
my ( $self, $qp ) = @_;
my ($self, $qp) = @_;
$self->register_hook('auth-plain', 'auth_flat_file');
$self->register_hook('auth-login', 'auth_flat_file');
@ -45,24 +45,25 @@ sub register {
}
sub auth_flat_file {
my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) =
my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) =
@_;
if ( ! defined $passClear && ! defined $passHash ) {
if (!defined $passClear && !defined $passHash) {
$self->log(LOGINFO, "fail: missing password");
return ( DENY, "authflat - missing password" );
return (DENY, "authflat - missing password");
}
my ( $pw_name, $pw_domain ) = split /@/, lc($user);
my ($pw_name, $pw_domain) = split /@/, lc($user);
unless ( defined $pw_domain ) {
unless (defined $pw_domain) {
$self->log(LOGINFO, "fail: missing domain");
return DECLINED;
}
my ($auth_line) = grep {/^$pw_name\@$pw_domain:/} $self->qp->config('flat_auth_pw');
my ($auth_line) =
grep { /^$pw_name\@$pw_domain:/ } $self->qp->config('flat_auth_pw');
if ( ! defined $auth_line) {
if (!defined $auth_line) {
$self->log(LOGINFO, "fail: no such user: $user");
return DECLINED;
}
@ -70,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,

15
plugins/auth/auth_ldap_bind
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");
}
@ -170,10 +173,10 @@ sub authldap {
$ldh->unbind if $ldh;
# bind against directory as user with password supplied
if ( ! $mesg->count || $lduserdn = $mesg->entry->dn ) {
if (!$mesg->count || $lduserdn = $mesg->entry->dn) {
$self->log(LOGALERT, "fail: user not found");
return (DECLINED, "authldap - wrong username or password");
};
}
$ldh = Net::LDAP->new($ldhost, port => $ldport, timeout => $ldwait) or do {
$self->log(LOGALERT, "skip: err in user conn");

18
plugins/auth/auth_vpopmail
View File

@ -50,10 +50,10 @@ use Qpsmtpd::Constants;
sub register {
my ($self, $qp) = @_;
return (DECLINED) if ! $self->test_vpopmail_module();
return (DECLINED) if !$self->test_vpopmail_module();
$self->register_hook("auth-plain", "auth_vpopmail" );
$self->register_hook("auth-login", "auth_vpopmail" );
$self->register_hook("auth-plain", "auth_vpopmail");
$self->register_hook("auth-login", "auth_vpopmail");
$self->register_hook("auth-cram-md5", "auth_vpopmail");
}
@ -61,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 ( $@ ) {
if ($@) {
$self->log(LOGERROR, "skip: is vpopmail perl module installed?");
return;
};
}
my ($domain) = vpopmail::vlistdomains();
my $r = vauth_getpw('postmaster', $domain) or do {

42
plugins/auth/auth_vpopmail_sql
View File

@ -72,14 +72,14 @@ use Qpsmtpd::Constants;
#use DBI; # done in ->register
sub register {
my ( $self, $qp ) = @_;
my ($self, $qp) = @_;
eval 'use DBI';
if ( $@ ) {
if ($@) {
warn "plugin disabled. is DBI installed?\n";
$self->log(LOGERROR, "skip: plugin disabled. is DBI installed?\n");
return;
};
}
$self->register_hook('auth-plain', 'auth_vmysql');
$self->register_hook('auth-login', 'auth_vmysql');
@ -89,27 +89,28 @@ sub register {
sub get_db_handle {
my $self = shift;
my $dsn = $self->qp->config("vpopmail_mysql_dsn") || "dbi:mysql:dbname=vpopmail;host=127.0.0.1";
my $dsn = $self->qp->config("vpopmail_mysql_dsn")
|| "dbi:mysql:dbname=vpopmail;host=127.0.0.1";
my $dbuser = $self->qp->config("vpopmail_mysql_user") || "vpopmailuser";
my $dbpass = $self->qp->config("vpopmail_mysql_pass") || "vpoppasswd";
my $dbh = DBI->connect( $dsn, $dbuser, $dbpass ) or do {
my $dbh = DBI->connect($dsn, $dbuser, $dbpass) or do {
$self->log(LOGERROR, "skip: db connection failed");
return;
};
$dbh->{ShowErrorStatement} = 1;
return $dbh;
};
}
sub get_vpopmail_user {
my ( $self, $dbh, $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 );
if (!defined $pw_domain) {
$self->log(LOGINFO, "skip: missing domain: " . lc $user);
return;
};
}
$self->log(LOGDEBUG, "auth_vpopmail_sql: $user");
@ -118,16 +119,17 @@ FROM vpopmail
WHERE pw_name = ?
AND pw_domain = ?";
my $sth = $dbh->prepare( $query );
$sth->execute( $pw_name, $pw_domain );
my $sth = $dbh->prepare($query);
$sth->execute($pw_name, $pw_domain);
my $userd_ref = $sth->fetchrow_hashref;
$sth->finish;
$dbh->disconnect;
return $userd_ref;
};
}
sub auth_vmysql {
my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) = @_;
my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) =
@_;
my $dbh = $self->get_db_handle() or return DECLINED;
my $u = $self->get_vpopmail_user($dbh, $user) or return DECLINED;
@ -136,14 +138,16 @@ sub auth_vmysql {
# then pw_clear_passwd may not even exist
# my $pw_clear_passwd = $db_user->{'pw_clear_passwd'};
if ( ! $u->{pw_passwd} && ! $u->{pw_clear_passwd} ) {
if (!$u->{pw_passwd} && !$u->{pw_clear_passwd}) {
$self->log(LOGINFO, "fail: no such user");
return ( DENY, "auth_vmysql - no such user" );
};
return (DENY, "auth_vmysql - no such user");
}
# at this point, the user name has matched
return Qpsmtpd::Auth::validate_password( $self,
return
Qpsmtpd::Auth::validate_password(
$self,
src_clear => $u->{pw_clear_passwd},
src_crypt => $u->{pw_passwd},
attempt_clear => $passClear,

31
plugins/auth/auth_vpopmaild
View File

@ -16,24 +16,28 @@ sub register {
$self->register_hook('auth-plain', 'auth_vpopmaild');
$self->register_hook('auth-login', 'auth_vpopmaild');
#$self->register_hook('auth-cram-md5', 'auth_vpopmaild'); # not supported
}
sub auth_vpopmaild {
my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) = @_;
my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) =
@_;
if ( ! $passClear ) {
if (!$passClear) {
$self->log(LOGINFO, "skip: vpopmaild does not support cram-md5");
return DECLINED;
}
# create socket
my $vpopmaild_socket = IO::Socket::INET->new(
my $vpopmaild_socket =
IO::Socket::INET->new(
PeerAddr => $self->{_vpopmaild_host},
PeerPort => $self->{_vpopmaild_port},
Proto => 'tcp',
Type => SOCK_STREAM
) or do {
)
or do {
$self->log(LOGERROR, "skip: socket connection to vpopmaild failed");
return DECLINED;
};
@ -42,32 +46,33 @@ sub auth_vpopmaild {
# Get server greeting (+OK)
my $connect_response = <$vpopmaild_socket>;
if ( ! $connect_response ) {
if (!$connect_response) {
$self->log(LOGERROR, "skip: no connection response");
close($vpopmaild_socket);
return DECLINED;
};
}
if ( $connect_response !~ /^\+OK/ ) {
$self->log(LOGERROR, "skip: bad connection response: $connect_response");
if ($connect_response !~ /^\+OK/) {
$self->log(LOGERROR,
"skip: bad connection response: $connect_response");
close($vpopmaild_socket);
return DECLINED;
};
}
print $vpopmaild_socket "login $user $passClear\n\r"; # send login details
my $login_response = <$vpopmaild_socket>; # get response from server
close($vpopmaild_socket);
if ( ! $login_response ) {
if (!$login_response) {
$self->log(LOGERROR, "skip: no login response");
return DECLINED;
};
}
# check for successful login (single line (+OK) or multiline (+OK+))
if ( $login_response =~ /^\+OK/ ) {
if ($login_response =~ /^\+OK/) {
$self->log(LOGINFO, "pass: clear");
return (OK, 'auth_vpopmaild');
};
}
chomp $login_response;
$self->log(LOGNOTICE, "fail: $login_response");

6
plugins/auth/authdeny
View File

@ -13,11 +13,11 @@ the Qpsmtpd::Auth module. Don't run this in production!!!
=cut
sub hook_auth {
my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) =
my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) =
@_;
$self->log( LOGWARN, "fail: cannot authenticate" );
$self->log(LOGWARN, "fail: cannot authenticate");
return ( DECLINED, "$user is not free to abuse my relay" );
return (DECLINED, "$user is not free to abuse my relay");
}

56
plugins/badmailfrom
View File

@ -59,11 +59,11 @@ anywhere in the string.
=cut
sub register {
my ($self,$qp) = (shift, shift);
$self->{_args} = { @_ };
my ($self, $qp) = (shift, shift);
$self->{_args} = {@_};
$self->{_args}{reject} = 1 if ! defined $self->{_args}{reject};
};
$self->{_args}{reject} = 1 if !defined $self->{_args}{reject};
}
sub hook_mail {
my ($self, $transaction, $sender, %param) = @_;
@ -71,10 +71,10 @@ sub hook_mail {
return DECLINED if $self->is_immune();
my @badmailfrom = $self->qp->config('badmailfrom');
if ( defined $self->{_badmailfrom_config} ) { # testing
if (defined $self->{_badmailfrom_config}) { # testing
@badmailfrom = @{$self->{_badmailfrom_config}};
};
return DECLINED if $self->is_immune_sender( $sender, \@badmailfrom );
}
return DECLINED if $self->is_immune_sender($sender, \@badmailfrom);
my $host = lc $sender->host;
my $from = lc($sender->user) . '@' . $host;
@ -83,10 +83,10 @@ sub hook_mail {
$config =~ s/^\s+//g; # trim leading whitespace
my ($bad, $reason) = split /\s+/, $config, 2;
next unless $bad;
next unless $self->is_match( $from, $bad, $host );
next unless $self->is_match($from, $bad, $host);
$reason ||= "Your envelope sender is in my badmailfrom list";
$self->adjust_karma( -1 );
return $self->get_reject( $reason );
$self->adjust_karma(-1);
return $self->get_reject($reason);
}
$self->log(LOGINFO, "pass");
@ -94,46 +94,46 @@ sub hook_mail {
}
sub is_match {
my ( $self, $from, $bad, $host ) = @_;
my ($self, $from, $bad, $host) = @_;
if ( $bad =~ /[\/\^\$\*\+\!\%\?\\]/ ) { # it's a regexp
if ( $from =~ /$bad/ ) {
if ($bad =~ /[\/\^\$\*\+\!\%\?\\]/) { # it's a regexp
if ($from =~ /$bad/) {
$self->log(LOGDEBUG, "badmailfrom pattern ($bad) match for $from");
return 1;
};
}
return;
};
}
$bad = lc $bad;
if ( $bad !~ m/\@/ ) {
if ($bad !~ m/\@/) {
$self->log(LOGWARN, "badmailfrom: bad config: no \@ sign in $bad");
return;
};
if ( substr($bad,0,1) eq '@' ) {
}
if (substr($bad, 0, 1) eq '@') {
return 1 if $bad eq "\@$host";
return;
};
}
return if $bad ne $from;
return 1;
};
}
sub is_immune_sender {
my ($self, $sender, $badmf ) = @_;
my ($self, $sender, $badmf) = @_;
if ( ! scalar @$badmf ) {
if (!scalar @$badmf) {
$self->log(LOGDEBUG, 'skip, empty list');
return 1;
};
}
if ( ! $sender || $sender->format eq '<>' ) {
if (!$sender || $sender->format eq '<>') {
$self->log(LOGDEBUG, 'skip, null sender');
return 1;
};
}
if ( ! $sender->host || ! $sender->user ) {
if (!$sender->host || !$sender->user) {
$self->log(LOGDEBUG, 'skip, missing user or host');
return 1;
};
}
return;
};
}

30
plugins/badmailfromto
View File

@ -24,7 +24,7 @@ sub hook_mail {
my ($self, $transaction, $sender, %param) = @_;
my @badmailfromto = $self->qp->config("badmailfromto");
return DECLINED if $self->is_sender_immune( $sender, \@badmailfromto );
return DECLINED if $self->is_sender_immune($sender, \@badmailfromto);
my $host = lc $sender->host;
my $from = lc($sender->user) . '@' . $host;
@ -33,13 +33,13 @@ sub hook_mail {
$bad =~ s/^\s*(\S+).*/$1/;
next unless $bad;
$bad = lc $bad;
if ( $bad !~ m/\@/ ) {
$self->log(LOGWARN, 'bad config, no @ sign in '. $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") ) {
}
if ($bad eq $from || (substr($bad, 0, 1) eq '@' && $bad eq "\@$host")) {
$transaction->notes('badmailfromto', $bad);
};
}
}
return (DECLINED);
}
@ -52,7 +52,7 @@ sub hook_rcpt {
return (DECLINED);
};
foreach ( $self->qp->config("badmailfromto") ) {
foreach ($self->qp->config("badmailfromto")) {
my ($from, $to) = m/^\s*(\S+)\t(\S+).*/;
return (DENY, "mail to $recipient not accepted here")
if lc($from) eq $sender && lc($to) eq $recipient;
@ -62,22 +62,22 @@ sub hook_rcpt {
}
sub is_sender_immune {
my ($self, $sender, $badmf ) = @_;
my ($self, $sender, $badmf) = @_;
if ( ! scalar @$badmf ) {
if (!scalar @$badmf) {
$self->log(LOGDEBUG, 'skip, empty list');
return 1;
};
}
if ( ! $sender || $sender->format eq '<>' ) {
if (!$sender || $sender->format eq '<>') {
$self->log(LOGDEBUG, 'skip, null sender');
return 1;
};
}
if ( ! $sender->host || ! $sender->user ) {
if (!$sender->host || !$sender->user) {
$self->log(LOGDEBUG, 'skip, missing user or host');
return 1;
};
}
return;
};
}

55
plugins/badrcptto
View File

@ -51,7 +51,7 @@ sub hook_rcpt {
return (DECLINED) if $self->is_immune();
my ($host, $to) = $self->get_host_and_to( $recipient )
my ($host, $to) = $self->get_host_and_to($recipient)
or return (DECLINED);
my @badrcptto = $self->qp->config("badrcptto") or do {
@ -62,69 +62,70 @@ sub hook_rcpt {
for my $line (@badrcptto) {
$line =~ s/^\s+//g; # trim leading whitespace
my ($bad, $reason) = split /\s+/, $line, 2;
next if ! $bad;
if ( $self->is_match( $to, lc($bad), $host ) ) {
$self->adjust_karma( -2 );
if ( $reason ) {
next if !$bad;
if ($self->is_match($to, lc($bad), $host)) {
$self->adjust_karma(-2);
if ($reason) {
return (DENY, "mail to $bad not accepted here");
}
else {
return Qpsmtpd::DSN->no_such_user("mail to $bad not accepted here");
return Qpsmtpd::DSN->no_such_user(
"mail to $bad not accepted here");
}
}
};
}
$self->log(LOGINFO, 'pass');
return (DECLINED);
}
sub is_match {
my ( $self, $to, $bad, $host ) = @_;
my ($self, $to, $bad, $host) = @_;
if ( $bad =~ /[\/\^\$\*\+\!\%\?\\]/ ) { # it's a regexp
if ($bad =~ /[\/\^\$\*\+\!\%\?\\]/) { # it's a regexp
$self->log(LOGDEBUG, "badmailfrom pattern ($bad) match for $to");
if ( $to =~ /$bad/i ) {
if ($to =~ /$bad/i) {
$self->log(LOGINFO, 'fail: pattern match');
return 1;
};
}
return;
};
}
if ( $bad !~ m/\@/ ) {
if ($bad !~ m/\@/) {
$self->log(LOGERROR, "badrcptto: bad config: no \@ sign in $bad");
return;
};
}
$bad = lc $bad;
$to = lc $to;
if ( substr($bad,0,1) eq '@' ) {
if ( $bad eq "\@$host" ) {
if (substr($bad, 0, 1) eq '@') {
if ($bad eq "\@$host") {
$self->log(LOGINFO, 'fail: host match');
return 1;
};
}
return;
};
}
if ( $bad eq $to ) {
if ($bad eq $to) {
$self->log(LOGINFO, 'fail: rcpt match');
return 1;
}
return;
};
}
sub get_host_and_to {
my ( $self, $recipient ) = @_;
my ($self, $recipient) = @_;
if ( ! $recipient ) {
if (!$recipient) {
$self->log(LOGERROR, 'skip: no recipient!');
return;
};
}
if ( ! $recipient->host || ! $recipient->user ) {
if (!$recipient->host || !$recipient->user) {
$self->log(LOGINFO, 'skip: missing host or user');
return;
};
}
my $host = lc $recipient->host;
return ( $host, lc($recipient->user) . '@' . $host );
};
return ($host, lc($recipient->user) . '@' . $host);
}

32
plugins/bogus_bounce
View File

@ -40,23 +40,22 @@ Deny with a soft error code.
=cut
sub register {
my ($self, $qp) = (shift, shift);
if ( @_ % 2 ) {
if (@_ % 2) {
$self->{_args}{action} = shift;
}
else {
$self->{_args} = { @_ };
};
$self->{_args} = {@_};
}
if ( ! defined $self->{_args}{reject} ) {
if (!defined $self->{_args}{reject}) {
$self->{_args}{reject} = 0; # legacy default
};
}
# we only need to check for deferral, default is DENY
if ( $self->{_args}{action} && $self->{_args}{action} =~ /soft/i ) {
if ($self->{_args}{action} && $self->{_args}{action} =~ /soft/i) {
$self->{_args}{reject_type} = 'temp';
}
}
@ -68,10 +67,10 @@ sub hook_data_post {
# Find the sender, quit processing if this isn't a bounce.
#
my $sender = $transaction->sender->address || undef;
if ( $sender && $sender ne '<>') {
if ($sender && $sender ne '<>') {
$self->log(LOGINFO, "pass, not a null sender");
return DECLINED;
};
}
# at this point we know it is a bounce, via the null-envelope.
#
@ -80,16 +79,19 @@ sub hook_data_post {
my @to = $transaction->recipients || ();
if (scalar @to != 1) {
$self->log(LOGINFO, "fail, bogus bounce to: " . join(',', @to));
return $self->get_reject( "fail, this bounce message does not have 1 recipient" );
};
return $self->get_reject(
"fail, this bounce message does not have 1 recipient");
}
# validate that Return-Path is empty, RFC 3834
my $rp = $transaction->header->get('Return-Path');
if ( $rp && $rp ne '<>' ) {
$self->log(LOGINFO, "fail, bounce messages must not have a Return-Path");
return $self->get_reject( "a bounce return path must be empty (RFC 3834)" );
};
if ($rp && $rp ne '<>') {
$self->log(LOGINFO,
"fail, bounce messages must not have a Return-Path");
return $self->get_reject(
"a bounce return path must be empty (RFC 3834)");
}
$self->log(LOGINFO, "pass, single recipient, empty Return-Path");
return DECLINED;

33
plugins/connection_time
View File

@ -32,44 +32,47 @@ use Time::HiRes qw(gettimeofday tv_interval);
sub register {
my ($self, $qp) = (shift, shift);
if ( @_ == 1 ) { # backwards compatible
if (@_ == 1) { # backwards compatible
$self->{_args}{loglevel} = shift;
if ( $self->{_args}{loglevel} =~ /\D/ ) {
$self->{_args}{loglevel} = Qpsmtpd::Constants::log_level($self->{_args}{loglevel});
};
if ($self->{_args}{loglevel} =~ /\D/) {
$self->{_args}{loglevel} =
Qpsmtpd::Constants::log_level($self->{_args}{loglevel});
}
$self->{_args}{loglevel} ||= 6;
}
elsif ( @_ % 2 ) {
elsif (@_ % 2) {
$self->log(LOGERROR, "invalid arguments");
}
else {
$self->{_args} = { @_ }; # named args, inherits loglevel
};
# pre-connection is not available in the tcpserver deployment model.
# duplicate the handler, so it works both ways with no redudant methods
$self->{_args} = {@_}; # named args, inherits loglevel
}
# pre-connection is not available in the tcpserver deployment model.
# duplicate the handler, so it works both ways with no redudant methods
$self->register_hook('pre-connection', 'connect_handler');
$self->register_hook('connect', 'connect_handler');
}
sub connect_handler {
my $self = shift;
return DECLINED if ( $self->hook_name eq 'connect' && defined $self->{_connection_start} );
return DECLINED
if ($self->hook_name eq 'connect' && defined $self->{_connection_start});
$self->{_connection_start} = [gettimeofday];
$self->log(LOGDEBUG, "started at " . scalar gettimeofday );
$self->log(LOGDEBUG, "started at " . scalar gettimeofday);
return (DECLINED);
}
sub hook_post_connection {
my $self = shift;
if ( ! $self->{_connection_start} ) {
if (!$self->{_connection_start}) {
$self->log(LOGERROR, "Start time not set?!");
return (DECLINED);
};
}
my $elapsed = tv_interval( $self->{_connection_start}, [gettimeofday] );
my $elapsed = tv_interval($self->{_connection_start}, [gettimeofday]);
$self->log(LOGINFO, sprintf "%.3f s.", $elapsed );
$self->log(LOGINFO, sprintf "%.3f s.", $elapsed);
return (DECLINED);
}

6
plugins/content_log
View File

@ -9,9 +9,9 @@ sub hook_data_post {
my ($self, $transaction) = @_;
# as a decent default, log on a per-day-basis
my $date = strftime("%Y%m%d",localtime(time));
open(my $out,">>mail/$date")
or return(DECLINED,"Could not open log file.. continuing anyway");
my $date = strftime("%Y%m%d", localtime(time));
open(my $out, ">>mail/$date")
or return (DECLINED, "Could not open log file.. continuing anyway");
$transaction->header->print($out);
$transaction->body_resetpos;

14
plugins/count_unrecognized_commands
View File

@ -22,28 +22,30 @@ use warnings;
use Qpsmtpd::Constants;
sub register {
my ($self, $qp ) = (shift, shift);
my ($self, $qp) = (shift, shift);
$self->{_unrec_cmd_max} = shift || 4;
if ( scalar @_ ) {
if (scalar @_) {
$self->log(LOGWARN, "Ignoring additional arguments.");
}
}
sub hook_unrecognized_command {
my ($self, $cmd) = @_[0,2];
my ($self, $cmd) = @_[0, 2];
my $count = $self->connection->notes('unrec_cmd_count') || 0;
$count = $count + 1;
$self->connection->notes('unrec_cmd_count', $count);
if ( $count < $self->{_unrec_cmd_max} ) {
if ($count < $self->{_unrec_cmd_max}) {
$self->log(LOGINFO, "'$cmd', ($count)");
return DECLINED;
};
}
$self->log(LOGINFO, "fail, '$cmd' ($count)");
return (DENY_DISCONNECT, "Closing connection, $count unrecognized commands. Perhaps you should read RFC 2821?" );
return (DENY_DISCONNECT,
"Closing connection, $count unrecognized commands. Perhaps you should read RFC 2821?"
);
}

300
plugins/dkim
View File

@ -172,8 +172,8 @@ use Socket qw(:DEFAULT :crlf);
sub init {
my ($self, $qp) = (shift, shift);
$self->{_args} = { @_ };
$self->{_args}{reject} = 1 if ! defined $self->{_args}{reject};
$self->{_args} = {@_};
$self->{_args}{reject} = 1 if !defined $self->{_args}{reject};
$self->{_args}{reject_type} ||= 'perm';
}
@ -181,52 +181,55 @@ sub register {
my $self = shift;
# Mail::DKIM::TextWrap - nice idea, clients get mangled headers though
foreach my $mod ( qw/ Mail::DKIM::Verifier Mail::DKIM::Signer / ) {
foreach my $mod (qw/ Mail::DKIM::Verifier Mail::DKIM::Signer /) {
eval "use $mod";
if ( $@ ) {
if ($@) {
warn "error, plugin disabled, could not load $mod\n";
$self->log(LOGERROR, "skip, plugin disabled, is Mail::DKIM installed?");
$self->log(LOGERROR,
"skip, plugin disabled, is Mail::DKIM installed?");
return;
};
};
}
}
$self->register_hook('data_post', 'data_post_handler');
};
}
sub data_post_handler {
my ($self, $transaction) = @_;
if ( $self->qp->connection->relay_client() ) {
if ($self->qp->connection->relay_client()) {
# this is an authenticated user sending a message.
return $self->sign_it( $transaction );
};
return $self->sign_it($transaction);
}
return DECLINED if $self->is_immune();
return $self->validate_it( $transaction );
};
return $self->validate_it($transaction);
}
sub validate_it {
my ($self, $transaction) = @_;
# Incoming message, perform DKIM validation
my $dkim = Mail::DKIM::Verifier->new() or do {
$self->log(LOGERROR, "error, could not instantiate a new Mail::DKIM::Verifier");
$self->log(LOGERROR,
"error, could not instantiate a new Mail::DKIM::Verifier");
return DECLINED;
};
$self->send_message_to_dkim( $dkim, $transaction );
$self->send_message_to_dkim($dkim, $transaction);
my $result = $dkim->result;
my $mess = $self->get_details( $dkim );
my $mess = $self->get_details($dkim);
foreach my $t ( qw/ pass fail invalid temperror none / ) {
foreach my $t (qw/ pass fail invalid temperror none /) {
next if $t ne $result;
my $handler = 'handle_sig_' . $t;
$self->log(LOGDEBUG, "dispatching $result to $handler");
return $self->$handler( $dkim, $mess );
};
return $self->$handler($dkim, $mess);
}
$self->log( LOGERROR, "error, unknown result: $result, $mess" );
$self->log(LOGERROR, "error, unknown result: $result, $mess");
return DECLINED;
}
@ -244,18 +247,18 @@ sub sign_it {
KeyFile => "$keydir/private",
);
$self->send_message_to_dkim( $dkim, $transaction );
$self->send_message_to_dkim($dkim, $transaction);
my $signature = $dkim->signature; # what is the signature result?
$self->qp->transaction->header->add(
'DKIM-Signature', $signature->as_string, 0 );
$self->qp->transaction->header->add('DKIM-Signature',
$signature->as_string, 0);
$self->log(LOGINFO, "pass, we signed the message" );
$self->log(LOGINFO, "pass, we signed the message");
return DECLINED;
};
}
sub get_details {
my ($self, $dkim ) = @_;
my ($self, $dkim) = @_;
my @data;
my $string;
@ -263,147 +266,145 @@ sub get_details {
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;
foreach my $policy ($dkim->policies) {
next if !$policy;
push @data, "policy: " . $policy->as_string;
push @data, "name: " . $policy->name;
push @data, "policy_location: " . $policy->location if $policy->location;
push @data, "policy_location: " . $policy->location
if $policy->location;
my $policy_result;
$policy_result = $policy->apply($dkim);
$policy_result or next;
push @data, "policy_result: " . $policy_result if $policy_result;
};
}
return join(', ', @data);
};
}
sub handle_sig_fail {
my ( $self, $dkim, $mess ) = @_;
my ($self, $dkim, $mess) = @_;
$self->adjust_karma( -1 );
return $self->get_reject( "DKIM signature invalid: " . $dkim->result_detail, $mess );
};
$self->adjust_karma(-1);
return
$self->get_reject("DKIM signature invalid: " . $dkim->result_detail,
$mess);
}
sub handle_sig_temperror {
my ( $self, $dkim, $mess ) = @_;
my ($self, $dkim, $mess) = @_;
$self->log(LOGINFO, "error, $mess" );
return ( DENYSOFT, "Please try again later - $dkim->result_detail" );
};
$self->log(LOGINFO, "error, $mess");
return (DENYSOFT, "Please try again later - $dkim->result_detail");
}
sub handle_sig_invalid {
my ( $self, $dkim, $mess ) = @_;
my ($self, $dkim, $mess) = @_;
my ( $prs, $policies) = $self->get_policy_results( $dkim );
my ($prs, $policies) = $self->get_policy_results($dkim);
foreach my $policy ( @$policies ) {
if ( $policy->signall && ! $policy->is_implied_default_policy ) {
$self->log(LOGINFO, $mess );
return $self->get_reject(
"invalid DKIM signature with sign-all policy",
"invalid signature, sign-all policy"
);
foreach my $policy (@$policies) {
if ($policy->signall && !$policy->is_implied_default_policy) {
$self->log(LOGINFO, $mess);
return
$self->get_reject("invalid DKIM signature with sign-all policy",
"invalid signature, sign-all policy");
}
}
};
$self->adjust_karma( -1 );
$self->log(LOGINFO, $mess );
$self->adjust_karma(-1);
$self->log(LOGINFO, $mess);
if ( $prs->{accept} ) {
$self->add_header( $mess );
$self->log( LOGERROR, "error, invalid signature but accept policy!?" );
if ($prs->{accept}) {
$self->add_header($mess);
$self->log(LOGERROR, "error, invalid signature but accept policy!?");
return DECLINED;
}
elsif ( $prs->{neutral} ) {
$self->add_header( $mess );
$self->log( LOGERROR, "error, invalid signature but neutral policy?!" );
elsif ($prs->{neutral}) {
$self->add_header($mess);
$self->log(LOGERROR, "error, invalid signature but neutral policy?!");
return DECLINED;
}
elsif ( $prs->{reject} ) {
return $self->get_reject(
"invalid DKIM signature: " . $dkim->result_detail,
"fail, invalid signature, reject policy"
);
elsif ($prs->{reject}) {
return
$self->get_reject("invalid DKIM signature: " . $dkim->result_detail,
"fail, invalid signature, reject policy");
}
# this should never happen
$self->log( LOGINFO, "error, invalid signature, unhandled" );
$self->add_header( $mess );
$self->log(LOGINFO, "error, invalid signature, unhandled");
$self->add_header($mess);
return DECLINED;
};
}
sub handle_sig_pass {
my ( $self, $dkim, $mess ) = @_;
my ($self, $dkim, $mess) = @_;
$self->save_signatures_to_note( $dkim );
$self->save_signatures_to_note($dkim);
my ($prs) = $self->get_policy_results( $dkim );
my ($prs) = $self->get_policy_results($dkim);
if ( $prs->{accept} ) {
$self->add_header( $mess );
if ($prs->{accept}) {
$self->add_header($mess);
$self->log(LOGINFO, "pass, valid signature, accept policy");
$self->adjust_karma( 1 );
$self->adjust_karma(1);
return DECLINED;
}
elsif ( $prs->{neutral} ) {
$self->add_header( $mess );
elsif ($prs->{neutral}) {
$self->add_header($mess);
$self->log(LOGINFO, "pass, valid signature, neutral policy");
$self->log(LOGINFO, $mess );
$self->log(LOGINFO, $mess);
return DECLINED;
}
elsif ( $prs->{reject} ) {
$self->log(LOGINFO, $mess );
$self->adjust_karma( -1 );
return $self->get_reject(
"DKIM signature valid but fails policy, $mess",
"fail, valid sig, reject policy"
);
};
elsif ($prs->{reject}) {
$self->log(LOGINFO, $mess);
$self->adjust_karma(-1);
return
$self->get_reject("DKIM signature valid but fails policy, $mess",
"fail, valid sig, reject policy");
}
# this should never happen
$self->add_header( $mess );
$self->log(LOGERROR, "pass, valid sig, no policy results" );
$self->log(LOGINFO, $mess );
$self->add_header($mess);
$self->log(LOGERROR, "pass, valid sig, no policy results");
$self->log(LOGINFO, $mess);
return DECLINED;
};
}
sub handle_sig_none {
my ( $self, $dkim, $mess ) = @_;
my ($self, $dkim, $mess) = @_;
my ( $prs, $policies) = $self->get_policy_results( $dkim );
my ($prs, $policies) = $self->get_policy_results($dkim);
foreach my $policy ( @$policies ) {
if ( $policy->signall && ! $policy->is_implied_default_policy ) {
$self->log(LOGINFO, $mess );
return $self->get_reject(
"no DKIM signature with sign-all policy",
"no signature, sign-all policy"
);
foreach my $policy (@$policies) {
if ($policy->signall && !$policy->is_implied_default_policy) {
$self->log(LOGINFO, $mess);
return
$self->get_reject("no DKIM signature with sign-all policy",
"no signature, sign-all policy");
}
}
};
if ( $prs->{accept} ) {
$self->log( LOGINFO, "pass, no signature, accept policy" );
if ($prs->{accept}) {
$self->log(LOGINFO, "pass, no signature, accept policy");
return DECLINED;
}
elsif ( $prs->{neutral} ) {
$self->log( LOGINFO, "pass, no signature, neutral policy" );
elsif ($prs->{neutral}) {
$self->log(LOGINFO, "pass, no signature, neutral policy");
return DECLINED;
}
elsif ( $prs->{reject} ) {
$self->log(LOGINFO, $mess );
elsif ($prs->{reject}) {
$self->log(LOGINFO, $mess);
$self->get_reject(
"no DKIM signature, policy says reject: " . $dkim->result_detail,
"no signature, reject policy"
);
};
"no signature, reject policy");
}
# should never happen
$self->log( LOGINFO, "error, no signature, no policy" );
$self->log(LOGINFO, $mess );
$self->log(LOGINFO, "error, no signature, no policy");
$self->log(LOGINFO, $mess);
return DECLINED;
};
}
sub get_keydir {
my ($self, $transaction) = @_;
@ -411,103 +412,104 @@ sub get_keydir {
my $domain = $transaction->sender->host;
my $dir = "config/dkim/$domain";
if ( ! -e $dir ) { # the dkim key dir doesn't exist
if (!-e $dir) { # the dkim key dir doesn't exist
my @labels = split /\./, $domain; # split the domain into labels
while ( @labels > 1 ) {
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
if (-e "config/dkim/$zone") { # if the directory exists
$dir = "config/dkim/$zone"; # use the parent domain's key
$self->log(LOGINFO, "info, using $zone key for $domain");
};
};
};
}
}
}
if ( -l $dir ) {
if (-l $dir) {
$dir = readlink($dir);
$dir = "config/dkim/$dir" if $dir !~ /\//; # no /, relative path
($domain) = (split /\//, $dir)[-1];
};
}
if ( ! -d $dir ) {
if (!-d $dir) {
$self->log(LOGINFO, "skip, DKIM not configured for $domain");
return;
};
if ( ! -r $dir ) {
}
if (!-r $dir) {
$self->log(LOGINFO, "error, unable to read key from $dir");
return;
};
if ( ! -r "$dir/private" ) {
}
if (!-r "$dir/private") {
$self->log(LOGINFO, "error, unable to read dkim key from $dir/private");
return;
};
}
return ($domain, $dir);
};
}
sub save_signatures_to_note {
my ( $self, $dkim ) = @_;
my ($self, $dkim) = @_;
foreach my $sig ( $dkim->signatures ) {
foreach my $sig ($dkim->signatures) {
next if $sig->result ne 'pass';
my $doms = $self->connection->notes('dkim_pass_domains') || [];
push @$doms, $sig->domain;
$self->connection->notes('dkim_pass_domains', $doms);
$self->log(LOGINFO, "info, added " . $sig->domain );
};
};
$self->log(LOGINFO, "info, added " . $sig->domain);
}
}
sub send_message_to_dkim {
my ($self, $dkim, $transaction) = @_;
foreach ( split ( /\n/s, $transaction->header->as_string ) ) {
foreach (split(/\n/s, $transaction->header->as_string)) {
$_ =~ s/\r?$//s;
eval { $dkim->PRINT ( $_ . CRLF ); };
$self->log(LOGERROR, $@ ) if $@;
eval { $dkim->PRINT($_ . CRLF); };
$self->log(LOGERROR, $@) if $@;
}
$transaction->body_resetpos;
while (my $line = $transaction->body_getline) {
chomp $line;
$line =~ s/\015$//;
eval { $dkim->PRINT($line . CRLF ); };
$self->log(LOGERROR, $@ ) if $@;
};
eval { $dkim->PRINT($line . CRLF); };
$self->log(LOGERROR, $@) if $@;
}
$dkim->CLOSE;
};
}
sub get_policies {
my ($self, $dkim) = @_;
my @policies;
eval { @policies = $dkim->policies };
$self->log(LOGERROR, $@ ) if $@;
$self->log(LOGERROR, $@) if $@;
return @policies;
};
}
sub get_policy_results {
my ( $self, $dkim ) = @_;
my ($self, $dkim) = @_;
my %prs;
my @policies = $self->get_policies( $dkim );
my @policies = $self->get_policies($dkim);
foreach my $policy ( @policies ) {
foreach my $policy (@policies) {
my $policy_result;
eval { $policy_result = $policy->apply($dkim); }; # accept, reject, neutral
if ( $@ ) {
$self->log(LOGERROR, $@ );
};
if ($@) {
$self->log(LOGERROR, $@);
}
$prs{$policy_result}++ if $policy_result;
};
}
return \%prs, \@policies;
};
}
sub get_selector {
my ($self, $keydir) = @_;
open my $SFH, '<', "$keydir/selector" or do {
$self->log(LOGINFO, "error, unable to read selector from $keydir/selector");
$self->log(LOGINFO,
"error, unable to read selector from $keydir/selector");
return DECLINED;
};
my $selector = <$SFH>;
@ -515,13 +517,13 @@ sub get_selector {
close $SFH;
$self->log(LOGINFO, "info, selector: $selector");
return $selector;
};
}
sub add_header {
my $self = shift;
my $header = shift or return;
# consider adding Authentication-Results header, (RFC 5451)
$self->qp->transaction->header->add( 'X-DKIM-Authentication', $header, 0 );
# consider adding Authentication-Results header, (RFC 5451)
$self->qp->transaction->header->add('X-DKIM-Authentication', $header, 0);
}

278
plugins/dmarc
View File

@ -104,261 +104,267 @@ use Qpsmtpd::Constants;
sub init {
my ($self, $qp) = (shift, shift);
$self->{_args} = { @_ };
$self->{_args}{reject} = 1 if ! defined $self->{_args}{reject};
$self->{_args} = {@_};
$self->{_args}{reject} = 1 if !defined $self->{_args}{reject};
$self->{_args}{reject_type} ||= 'perm';
$self->{_args}{p_vals} = { map { $_ => 1 } qw/ none reject quarantine / };
$self->{_args}{p_vals} = {map { $_ => 1 } qw/ none reject quarantine /};
}
sub register {
my $self = shift;
$self->register_hook('data_post', 'data_post_handler');
};
}
sub data_post_handler {
my ($self, $transaction) = @_;
return DECLINED if $self->is_immune();
# 11.1. Extract Author Domain
# 11.1. Extract Author Domain
# TODO: check exists_in_dns result, and possibly reject here if domain non-exist
my $from_host = $self->get_from_host( $transaction ) or return DECLINED;
if ( ! $self->exists_in_dns( $from_host ) ) {
my $org_host = $self->get_organizational_domain( $from_host );
if ( ! $self->exists_in_dns( $org_host ) ) {
$self->log( LOGINFO, "fail, domain/org not in DNS" );
my $from_host = $self->get_from_host($transaction) or return DECLINED;
if (!$self->exists_in_dns($from_host)) {
my $org_host = $self->get_organizational_domain($from_host);
if (!$self->exists_in_dns($org_host)) {
$self->log(LOGINFO, "fail, domain/org not in DNS");
#return $self->get_reject();
return DECLINED;
};
};
}
}
# 11.2. Determine Handling Policy
my $policy = $self->discover_policy( $from_host )
# 11.2. Determine Handling Policy
my $policy = $self->discover_policy($from_host)
or return DECLINED;
# 3. Perform DKIM signature verification checks. A single email may
# contain multiple DKIM signatures. The results of this step are
# passed to the remainder of the algorithm and MUST include the
# value of the "d=" tag from all DKIM signatures that successfully
# validated.
# 3. Perform DKIM signature verification checks. A single email may
# contain multiple DKIM signatures. The results of this step are
# passed to the remainder of the algorithm and MUST include the
# value of the "d=" tag from all DKIM signatures that successfully
# validated.
my $dkim_sigs = $self->connection->notes('dkim_pass_domains') || [];
# 4. Perform SPF validation checks. The results of this step are
# passed to the remainder of the algorithm and MUST include the
# domain name from the RFC5321.MailFrom if SPF evaluation returned
# a "pass" result.
# 4. Perform SPF validation checks. The results of this step are
# passed to the remainder of the algorithm and MUST include the
# domain name from the RFC5321.MailFrom if SPF evaluation returned
# a "pass" result.
my $spf_dom = $transaction->notes('spf_pass_host');
# 5. Conduct identifier alignment checks. With authentication checks
# and policy discovery performed, the Mail Receiver checks if
# Authenticated Identifiers fall into alignment as decribed in
# Section 4. If one or more of the Authenticated Identifiers align
# with the RFC5322.From domain, the message is considered to pass
# the DMARC mechanism check. All other conditions (authentication
# failures, identifier mismatches) are considered to be DMARC
# mechanism check failures.
foreach ( @$dkim_sigs ) {
if ( $_ eq $from_host ) { # strict alignment
# 5. Conduct identifier alignment checks. With authentication checks
# and policy discovery performed, the Mail Receiver checks if
# Authenticated Identifiers fall into alignment as decribed in
# Section 4. If one or more of the Authenticated Identifiers align
# with the RFC5322.From domain, the message is considered to pass
# the DMARC mechanism check. All other conditions (authentication
# failures, identifier mismatches) are considered to be DMARC
# mechanism check failures.
foreach (@$dkim_sigs) {
if ($_ eq $from_host) { # strict alignment
$self->log(LOGINFO, "pass, DKIM alignment");
$self->adjust_karma( 2 ); # big karma boost
$self->adjust_karma(2); # big karma boost
return DECLINED;
};
};
}
}
if ( $spf_dom && $spf_dom eq $from_host ) {
$self->adjust_karma( 2 ); # big karma boost
if ($spf_dom && $spf_dom eq $from_host) {
$self->adjust_karma(2); # big karma boost
$self->log(LOGINFO, "pass, SPF alignment");
return DECLINED;
};
}
# 6. Apply policy. Emails that fail the DMARC mechanism check are
# disposed of in accordance with the discovered DMARC policy of the
# Domain Owner. See Section 6.2 for details.
# 6. Apply policy. Emails that fail the DMARC mechanism check are
# disposed of in accordance with the discovered DMARC policy of the
# Domain Owner. See Section 6.2 for details.
$self->log(LOGINFO, "skip, NEED RELAXED alignment");
return DECLINED;
};
}
sub discover_policy {
my ($self, $from_host) = @_;
# 1. Mail Receivers MUST query the DNS for a DMARC TXT record at the
# DNS domain matching the one found in the RFC5322.From domain in
# the message. A possibly empty set of records is returned.
# 1. Mail Receivers MUST query the DNS for a DMARC TXT record at the
# DNS domain matching the one found in the RFC5322.From domain in
# the message. A possibly empty set of records is returned.
my @matches = $self->fetch_dmarc_record($from_host); # 2. within
if ( 0 == scalar @matches ) {
# 3. If the set is now empty, the Mail Receiver MUST query the DNS for
# a DMARC TXT record at the DNS domain matching the Organizational
# Domain in place of the RFC5322.From domain in the message (if
# different). This record can contain policy to be asserted for
# subdomains of the Organizational Domain.
if (0 == scalar @matches) {
my $org_dom = $self->get_organizational_domain( $from_host ) or return;
if ( $org_dom eq $from_host ) {
$self->log( LOGINFO, "skip, no policy for $from_host (same org)" );
# 3. If the set is now empty, the Mail Receiver MUST query the DNS for
# a DMARC TXT record at the DNS domain matching the Organizational
# Domain in place of the RFC5322.From domain in the message (if
# different). This record can contain policy to be asserted for
# subdomains of the Organizational Domain.
my $org_dom = $self->get_organizational_domain($from_host) or return;
if ($org_dom eq $from_host) {
$self->log(LOGINFO, "skip, no policy for $from_host (same org)");
return;
};
}
@matches = $self->fetch_dmarc_record($org_dom);
if ( 0 == scalar @matches ) {
$self->log( LOGINFO, "skip, no policy for $from_host" );
if (0 == scalar @matches) {
$self->log(LOGINFO, "skip, no policy for $from_host");
return;
};
};
}
}
# 4. Records that do not include a "v=" tag that identifies the
# current version of DMARC are discarded.
# 4. Records that do not include a "v=" tag that identifies the
# current version of DMARC are discarded.
@matches = grep /v=DMARC1/i, @matches;
if ( 0 == scalar @matches ) {
$self->log( LOGINFO, "skip, no valid record for $from_host" );
if (0 == scalar @matches) {
$self->log(LOGINFO, "skip, no valid record for $from_host");
return;
};
}
# 5. If the remaining set contains multiple records, processing
# terminates and the Mail Receiver takes no action.
if ( @matches > 1 ) {
$self->log( LOGINFO, "skip, too many records" );
# 5. If the remaining set contains multiple records, processing
# terminates and the Mail Receiver takes no action.
if (@matches > 1) {
$self->log(LOGINFO, "skip, too many records");
return;
};
}
# 6. If a retrieved policy record does not contain a valid "p" tag, or
# contains an "sp" tag that is not valid, then:
my %policy = $self->parse_policy( $matches[0] );
if ( ! $self->has_valid_p(\%policy) || $self->has_invalid_sp(\%policy) ) {
# 6. If a retrieved policy record does not contain a valid "p" tag, or
# contains an "sp" tag that is not valid, then:
my %policy = $self->parse_policy($matches[0]);
if (!$self->has_valid_p(\%policy) || $self->has_invalid_sp(\%policy)) {
# A. if an "rua" tag is present and contains at least one
# syntactically valid reporting URI, the Mail Receiver SHOULD
# act as if a record containing a valid "v" tag and "p=none"
# was retrieved, and continue processing;
# B. otherwise, the Mail Receiver SHOULD take no action.
# A. if an "rua" tag is present and contains at least one
# syntactically valid reporting URI, the Mail Receiver SHOULD
# act as if a record containing a valid "v" tag and "p=none"
# was retrieved, and continue processing;
# B. otherwise, the Mail Receiver SHOULD take no action.
my $rua = $policy{rua};
if ( ! $rua || ! $self->has_valid_reporting_uri($rua) ) {
$self->log( LOGINFO, "skip, no valid reporting rua" );
if (!$rua || !$self->has_valid_reporting_uri($rua)) {
$self->log(LOGINFO, "skip, no valid reporting rua");
return;
};
}
$policy{v} = 'DMARC1';
$policy{p} = 'none';
};
}
return \%policy;
};
}
sub has_valid_p {
my ($self, $policy) = @_;
return 1 if $self->{_args}{p_vals}{$policy};
return 0;
};
}
sub has_invalid_sp {
my ($self, $policy) = @_;
return 0 if ! $self->{_args}{p_vals}{$policy};
return 0 if !$self->{_args}{p_vals}{$policy};
return 1;
};
}
sub has_valid_reporting_uri {
my ($self, $rua) = @_;
return 1 if 'mailto:' eq lc substr($rua, 0, 7);
return 0;
};
}
sub get_organizational_domain {
my ($self, $from_host) = @_;
# 1. Acquire a "public suffix" list, i.e., a list of DNS domain
# names reserved for registrations. http://publicsuffix.org/list/
# $self->qp->config('public_suffix_list')
# 1. Acquire a "public suffix" list, i.e., a list of DNS domain
# names reserved for registrations. http://publicsuffix.org/list/
# $self->qp->config('public_suffix_list')
# 2. Break the subject DNS domain name into a set of "n" ordered
# labels. Number these labels from right-to-left; e.g. for
# "example.com", "com" would be label 1 and "example" would be
# label 2.;
# 2. Break the subject DNS domain name into a set of "n" ordered
# labels. Number these labels from right-to-left; e.g. for
# "example.com", "com" would be label 1 and "example" would be
# label 2.;
my @labels = reverse split /\./, $from_host;
# 3. Search the public suffix list for the name that matches the
# largest number of labels found in the subject DNS domain. Let
# that number be "x".
# 3. Search the public suffix list for the name that matches the
# largest number of labels found in the subject DNS domain. Let
# that number be "x".
my $greatest = 0;
for ( my $i = 0; $i <= scalar @labels; $i++ ) {
next if ! $labels[$i];
my $tld = join '.', reverse( (@labels)[0..$i] );
# $self->log( LOGINFO, "i: $i, $tld" );
#warn "i: $i - tld: $tld\n";
if ( grep /$tld/, $self->qp->config('public_suffix_list') ) {
for (my $i = 0 ; $i <= scalar @labels ; $i++) {
next if !$labels[$i];
my $tld = join '.', reverse((@labels)[0 .. $i]);
# $self->log( LOGINFO, "i: $i, $tld" );
#warn "i: $i - tld: $tld\n";
if (grep /$tld/, $self->qp->config('public_suffix_list')) {
$greatest = $i + 1;
};
};
}
}
return $from_host if $greatest == scalar @labels; # same
# 4. Construct a new DNS domain name using the name that matched
# from the public suffix list and prefixing to it the "x+1"th
# label from the subject domain. This new name is the
# Organizational Domain.
return join '.', reverse( (@labels)[0..$greatest]);
};
# 4. Construct a new DNS domain name using the name that matched
# from the public suffix list and prefixing to it the "x+1"th
# label from the subject domain. This new name is the
# Organizational Domain.
return join '.', reverse((@labels)[0 .. $greatest]);
}
sub exists_in_dns {
my ($self, $domain) = @_;
my $res = $self->init_resolver();
my $query = $res->send( $domain, 'NS' ) or do {
if ( $res->errorstring eq 'NXDOMAIN' ) {
$self->log( LOGDEBUG, "fail, non-existent domain: $domain" );
my $query = $res->send($domain, 'NS') or do {
if ($res->errorstring eq 'NXDOMAIN') {
$self->log(LOGDEBUG, "fail, non-existent domain: $domain");
return;
};
$self->log( LOGINFO, "error, looking up NS for $domain: " . $res->errorstring );
}
$self->log(LOGINFO,
"error, looking up NS for $domain: " . $res->errorstring);
return;
};
my @matches;
for my $rr ($query->answer) {
next if $rr->type ne 'NS';
push @matches, $rr->nsdname;
};
if ( 0 == scalar @matches ) {
$self->log( LOGDEBUG, "fail, zero NS for $domain" );
};
}
if (0 == scalar @matches) {
$self->log(LOGDEBUG, "fail, zero NS for $domain");
}
return @matches;
};
}
sub fetch_dmarc_record {
my ($self, $zone) = @_;
my $res = $self->init_resolver();
my $query = $res->send( '_dmarc.' . $zone, 'TXT' );
my $query = $res->send('_dmarc.' . $zone, 'TXT');
my @matches;
for my $rr ($query->answer) {
next if $rr->type ne 'TXT';
# 2. Records that do not start with a "v=" tag that identifies the
# current version of DMARC are discarded.
next if 'v=' ne substr( $rr->txtdata, 0, 2);
$self->log( LOGINFO, $rr->txtdata );
# 2. Records that do not start with a "v=" tag that identifies the
# current version of DMARC are discarded.
next if 'v=' ne substr($rr->txtdata, 0, 2);
$self->log(LOGINFO, $rr->txtdata);
push @matches, join('', $rr->txtdata);
};
}
return @matches;
};
}
sub get_from_host {
my ($self, $transaction) = @_;
my $from = $transaction->header->get('From') or do {
$self->log( LOGINFO, "error, unable to retrieve From header!" );
$self->log(LOGINFO, "error, unable to retrieve From header!");
return;
};
my ($from_host) = (split /@/, $from)[-1]; # grab everything after the @
($from_host) = split /\s+/, $from_host; # remove any trailing cruft
chomp $from_host;
chop $from_host if '>' eq substr($from_host,-1,1);
$self->log( LOGDEBUG, "info, from_host is $from_host" );
chop $from_host if '>' eq substr($from_host, -1, 1);
$self->log(LOGDEBUG, "info, from_host is $from_host");
return $from_host;
};
}
sub parse_policy {
my ($self, $str) = @_;
$str =~ s/\s//g; # remove all whitespace
my %dmarc = map { split /=/, $_ } split /;/, $str;
#warn Data::Dumper::Dumper(\%dmarc);
#warn Data::Dumper::Dumper(\%dmarc);
return %dmarc;
};
}
sub verify_external_reporting {
@ -396,4 +402,4 @@ sub verify_external_reporting {
=cut
};
}

20
plugins/dns_whitelist_soft
View File

@ -55,9 +55,9 @@ use warnings;
use Qpsmtpd::Constants;
sub register {
my ( $self, $qp ) = (shift, shift);
my ($self, $qp) = (shift, shift);
$self->log(LOGERROR, "Bad arguments") if @_ % 2;
$self->{_args} = { @_ };
$self->{_args} = {@_};
}
sub hook_connect {
@ -65,8 +65,8 @@ sub hook_connect {
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;
@ -102,8 +102,10 @@ sub process_sockets {
# 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;
@ -135,6 +137,7 @@ sub process_sockets {
}
if ($result) {
# kill any other pending I/O
$conn->notes('whitelist_sockets', undef);
return $conn->notes('whitelisthost', $result);
@ -142,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();
}
@ -158,8 +162,8 @@ sub hook_rcpt {
my ($self, $transaction, $rcpt, %param) = @_;
my $ip = $self->qp->connection->remote_ip or return (DECLINED);
my $note = $self->process_sockets;
if ( $note ) {
$self->log(LOGNOTICE,"Host $ip is whitelisted: $note");
if ($note) {
$self->log(LOGNOTICE, "Host $ip is whitelisted: $note");
}
return DECLINED;
}

98
plugins/dnsbl
View File

@ -135,20 +135,20 @@ See: https://github.com/smtpd/qpsmtpd/commits/master/plugins/dnsbl
sub register {
my ($self, $qp) = (shift, shift);
if ( @_ % 2 ) {
if (@_ % 2) {
$self->{_args}{reject_type} = shift; # backwards compatibility
}
else {
$self->{_args} = { @_ };
};
$self->{_args} = {@_};
}
# explicitly state legacy reject behavior
if ( ! defined $self->{_args}{reject_type} ) {
if (!defined $self->{_args}{reject_type}) {
$self->{_args}{reject_type} = 'perm';
};
if ( ! defined $self->{_args}{reject} ) {
}
if (!defined $self->{_args}{reject}) {
$self->{_args}{reject} = 1;
};
}
}
sub hook_connect {
@ -156,10 +156,10 @@ sub hook_connect {
# perform RBLSMTPD checks to mimic DJB's rblsmtpd
# RBLSMTPD being non-empty means it contains the failure message to return
if ( defined $ENV{'RBLSMTPD'} && $ENV{'RBLSMTPD'} ne '' ) {
if (defined $ENV{'RBLSMTPD'} && $ENV{'RBLSMTPD'} ne '') {
my $reject = $self->{_args}{reject};
return $self->return_env_message() if $reject && $reject eq 'connect';
};
}
return DECLINED if $self->is_immune();
return DECLINED if $self->is_set_rblsmtpd();
@ -168,64 +168,67 @@ sub hook_connect {
my $dnsbl_zones = $self->get_dnsbl_zones() or return DECLINED;
my $resolv = $self->get_resolver() or return DECLINED;
for my $dnsbl ( keys %$dnsbl_zones ) {
for my $dnsbl (keys %$dnsbl_zones) {
my $query = $self->get_query( $dnsbl ) or do {
if ( $resolv->errorstring ne 'NXDOMAIN' ) {
$self->log(LOGERROR, "$dnsbl query failed: ", $resolv->errorstring);
};
my $query = $self->get_query($dnsbl) or do {
if ($resolv->errorstring ne 'NXDOMAIN') {
$self->log(LOGERROR, "$dnsbl query failed: ",
$resolv->errorstring);
}
next;
};
my $a_record = 0;
my $result;
foreach my $rr ($query->answer) {
if ( $rr->type eq 'A' ) {
if ($rr->type eq 'A') {
$result = $rr->name;
$self->log(LOGDEBUG, "found A for $result with IP " . $rr->address);
$self->log(LOGDEBUG,
"found A for $result with IP " . $rr->address);
}
elsif ($rr->type eq 'TXT') {
$self->log(LOGDEBUG, "found TXT, " . $rr->txtdata);
$result = $rr->txtdata;
};
}
next if ! $result;
next if !$result;
$self->adjust_karma( -1 );
$self->adjust_karma(-1);
if ( ! $dnsbl ) { ($dnsbl) = ($result =~ m/(?:\d+\.){4}(.*)/); };
if ( ! $dnsbl ) { $dnsbl = $result; };
if (!$dnsbl) { ($dnsbl) = ($result =~ m/(?:\d+\.){4}(.*)/); }
if (!$dnsbl) { $dnsbl = $result; }
if ($a_record) {
if (defined $dnsbl_zones->{$dnsbl}) {
my $smtp_msg = $dnsbl_zones->{$dnsbl};
my $remote_ip= $self->qp->connection->remote_ip;
my $remote_ip = $self->qp->connection->remote_ip;
$smtp_msg =~ s/%IP%/$remote_ip/g;
return $self->get_reject( $smtp_msg, $dnsbl );
return $self->get_reject($smtp_msg, $dnsbl);
}
return $self->get_reject( "Blocked by $dnsbl" );
return $self->get_reject("Blocked by $dnsbl");
}
return $self->get_reject( $result, $dnsbl );
return $self->get_reject($result, $dnsbl);
}
}
$self->log(LOGINFO, 'pass');
return DECLINED;
};
}
sub get_dnsbl_zones {
my $self = shift;
my %dnsbl_zones = map { (split /:/, $_, 2)[0,1] } $self->qp->config('dnsbl_zones');
if ( ! %dnsbl_zones ) {
$self->log( LOGDEBUG, "skip, no zones");
my %dnsbl_zones =
map { (split /:/, $_, 2)[0, 1] } $self->qp->config('dnsbl_zones');
if (!%dnsbl_zones) {
$self->log(LOGDEBUG, "skip, no zones");
return;
};
}
$self->{_dnsbl}{zones} = \%dnsbl_zones;
return \%dnsbl_zones;
};
}
sub get_query {
my ($self, $dnsbl) = @_;
@ -234,24 +237,24 @@ sub get_query {
my $reversed_ip = join('.', reverse(split(/\./, $remote_ip)));
# fix to find A records, if the dnsbl_zones line has a second field 20/1/04 ++msp
if ( defined $self->{_dnsbl}{zones}{$dnsbl} ) {
if (defined $self->{_dnsbl}{zones}{$dnsbl}) {
$self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for A record");
return $self->{_resolver}->query("$reversed_ip.$dnsbl");
};
}
$self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for TXT record");
return $self->{_resolver}->query("$reversed_ip.$dnsbl", 'TXT');
};
}
sub is_set_rblsmtpd {
my $self = shift;
my $remote_ip = $self->qp->connection->remote_ip;
if ( ! defined $ENV{'RBLSMTPD'} ) {
if (!defined $ENV{'RBLSMTPD'}) {
$self->log(LOGDEBUG, "RBLSMTPD not set for $remote_ip");
return;
};
}
if ($ENV{'RBLSMTPD'} ne '') {
$self->log(LOGINFO, "RBLSMTPD=\"$ENV{'RBLSMTPD'}\" for $remote_ip");
@ -260,18 +263,18 @@ 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) = @_;
my $remote_ip = $self->qp->connection->remote_ip;
return grep { s/\.?$/./;
return grep {
s/\.?$/./;
$_ eq substr($remote_ip . '.', 0, length $_)
}
$self->qp->config('dnsbl_allow');
};
} $self->qp->config('dnsbl_allow');
}
sub return_env_message {
my $self = shift;
@ -280,17 +283,18 @@ sub return_env_message {
$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));
return ($self->get_reject_type(), join(' ', $msg, $result));
}
sub hook_rcpt {
my ($self, $transaction, $rcpt, %param) = @_;
if ( $rcpt->user =~ /^(?:postmaster|abuse|mailer-daemon|root)$/i ) {
$self->log(LOGWARN, "skip, don't blacklist special account: ".$rcpt->user);
if ($rcpt->user =~ /^(?:postmaster|abuse|mailer-daemon|root)$/i) {
$self->log(LOGWARN,
"skip, don't blacklist special account: " . $rcpt->user);
# clear the naughty connection note here, if desired.
$self->connection->notes('naughty', 0 );
$self->connection->notes('naughty', 0);
}
return DECLINED;
@ -299,11 +303,11 @@ sub hook_rcpt {
sub get_resolver {
my $self = shift;
return $self->{_resolver} if $self->{_resolver};
$self->log( LOGDEBUG, "initializing Net::DNS::Resolver");
$self->log(LOGDEBUG, "initializing Net::DNS::Resolver");
$self->{_resolver} = Net::DNS::Resolver->new(dnsrch => 0);
my $timeout = $self->{_args}{timeout} || 30;
$self->{_resolver}->tcp_timeout($timeout);
$self->{_resolver}->udp_timeout($timeout);
return $self->{_resolver};
};
}

78
plugins/domainkeys
View File

@ -57,68 +57,69 @@ use Qpsmtpd::Constants;
sub init {
my ($self, $qp, %args) = @_;
foreach my $key ( %args ) {
foreach my $key (%args) {
$self->{$key} = $args{$key};
}
$self->{reject} = 1 if ! defined $self->{reject}; # default reject
$self->{reject_type} = 'perm' if ! defined $self->{reject_type};
$self->{reject} = 1 if !defined $self->{reject}; # default reject
$self->{reject_type} = 'perm' if !defined $self->{reject_type};
if ( $args{'warn_only'} ) {
if ($args{'warn_only'}) {
$self->log(LOGNOTICE, "warn_only is deprecated. Use reject instead");
$self->{'reject'} = 0;
};
}
}
sub register {
my $self = shift;
for my $m ( qw/ Mail::DomainKeys::Message Mail::DomainKeys::Policy / ) {
for my $m (qw/ Mail::DomainKeys::Message Mail::DomainKeys::Policy /) {
eval "use $m";
if ( $@ ) {
if ($@) {
warn "skip: plugin disabled, could not load $m\n";
$self->log(LOGERROR, "skip: plugin disabled, is $m installed?");
return;
};
};
}
}
$self->register_hook('data_post', 'data_post_handler');
};
}
sub data_post_handler {
my ($self, $transaction) = @_;
return DECLINED if $self->is_immune();
if ( ! $transaction->header->get('DomainKey-Signature') ) {
if (!$transaction->header->get('DomainKey-Signature')) {
$self->log(LOGINFO, "skip, unsigned");
return DECLINED;
};
}
my $body = $self->assemble_body( $transaction );
my $body = $self->assemble_body($transaction);
my $message = load Mail::DomainKeys::Message(
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 ) {
if (!$message->senderdomain) {
$self->log(LOGINFO, "skip, failed to parse sender domain"),
return DECLINED;
};
}
my $status = $self->get_message_status( $message );
my $status = $self->get_message_status($message);
if ( defined $status ) {
if (defined $status) {
$transaction->header->add("DomainKey-Status", $status, 0);
$self->log(LOGINFO, "pass, $status");
return DECLINED;
};
}
$self->log(LOGERROR, "fail, signature invalid");
return DECLINED if ! $self->{reject};
return DECLINED if !$self->{reject};
my $deny = $self->{reject_type} eq 'temp' ? DENYSOFT : DENY;
return ($deny, "DomainKeys signature validation failed");
}
@ -126,35 +127,34 @@ sub data_post_handler {
sub get_message_status {
my ($self, $message) = @_;
if ( $message->testing ) {
if ($message->testing) {
return "testing"; # key testing, don't do anything else
};
}
if ( $message->signed && $message->verify ) {
if ($message->signed && $message->verify) {
return $message->signature->status; # verified: add good header
};
}
# not signed or not verified
my $policy = fetch Mail::DomainKeys::Policy(
Protocol => 'dns',
Domain => $message->senderdomain
);
my $policy =
fetch Mail::DomainKeys::Policy(Protocol => 'dns',
Domain => $message->senderdomain);
if ( ! $policy ) {
if (!$policy) {
return $message->signed ? "non-participant" : "no signature";
};
}
if ( $policy->testing ) {
if ($policy->testing) {
return "testing"; # Don't do anything else
};
}
if ( $policy->signall ) {
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) = @_;
@ -167,4 +167,4 @@ sub assemble_body {
push @body, $line;
}
return \@body;
};
}

8
plugins/dont_require_anglebrackets
View File

@ -22,19 +22,19 @@ MAIL FROM:user@example.com
=cut
sub hook_mail_pre {
my ($self,$transaction, $addr) = @_;
my ($self, $transaction, $addr) = @_;
unless ($addr =~ /^<.*>$/) {
$self->log(LOGINFO, "added MAIL angle brackets");
$addr = '<'.$addr.'>';
$addr = '<' . $addr . '>';
}
return (OK, $addr);
}
sub hook_rcpt_pre {
my ($self,$transaction, $addr) = @_;
my ($self, $transaction, $addr) = @_;
unless ($addr =~ /^<.*>$/) {
$self->log(LOGINFO, "added RCPT angle brackets");
$addr = '<'.$addr.'>';
$addr = '<' . $addr . '>';
}
return (OK, $addr);
}

363
plugins/dspam
View File

@ -212,8 +212,8 @@ sub register {
$self->log(LOGERROR, "Bad parameters for the dspam plugin") if @_ % 2;
$self->{_args} = { @_ };
$self->{_args}{reject} = 1 if ! defined $self->{_args}{reject};
$self->{_args} = {@_};
$self->{_args}{reject} = 1 if !defined $self->{_args}{reject};
$self->{_args}{reject_type} ||= 'perm';
$self->{_args}{dspam_bin} ||= '/usr/local/bin/dspam';
@ -226,16 +226,18 @@ sub get_dspam_bin {
my $self = shift;
my $bin = $self->{_args}{dspam_bin};
if ( ! -e $bin ) {
$self->log(LOGERROR, "error, dspam CLI binary not found: install dspam and/or set dspam_bin");
if (!-e $bin) {
$self->log(LOGERROR,
"error, dspam CLI binary not found: install dspam and/or set dspam_bin"
);
return;
};
if ( ! -x $bin ) {
}
if (!-x $bin) {
$self->log(LOGERROR, "error, no permission to run $bin");
return;
};
}
return $bin;
};
}
sub data_post_handler {
my $self = shift;
@ -243,29 +245,30 @@ sub data_post_handler {
return (DECLINED) if $self->is_immune();
if ( $transaction->data_size > 500_000 ) {
$self->log(LOGINFO, "skip, too big (" . $transaction->data_size . ")" );
if ($transaction->data_size > 500_000) {
$self->log(LOGINFO, "skip, too big (" . $transaction->data_size . ")");
return (DECLINED);
};
}
my $user = $self->select_username( $transaction );
my $user = $self->select_username($transaction);
my $bin = $self->{_args}{dspam_bin};
my $filtercmd = "$bin --user $user --mode=tum --process --deliver=summary --stdout";
my $filtercmd =
"$bin --user $user --mode=tum --process --deliver=summary --stdout";
$self->log(LOGDEBUG, $filtercmd);
my $response = $self->dspam_process( $filtercmd, $transaction );
if ( ! $response->{result} ) {
my $response = $self->dspam_process($filtercmd, $transaction);
if (!$response->{result}) {
$self->log(LOGWARN, "error, no dspam response. Check logs for errors.");
return (DECLINED);
};
}
$transaction->notes('dspam', $response);
$self->attach_headers( $response, $transaction );
$self->autolearn( $response, $transaction );
$self->attach_headers($response, $transaction);
$self->autolearn($response, $transaction);
return $self->log_and_return( $transaction );
};
return $self->log_and_return($transaction);
}
sub select_username {
my ($self, $transaction) = @_;
@ -273,34 +276,36 @@ sub select_username {
my $recipient_count = scalar $transaction->recipients;
$self->log(LOGDEBUG, "Message has $recipient_count recipients");
if ( $recipient_count > 1 ) {
$self->log(LOGINFO, "multiple recipients ($recipient_count), ignoring user prefs");
if ($recipient_count > 1) {
$self->log(LOGINFO,
"multiple recipients ($recipient_count), ignoring user prefs");
return getpwuid($>);
};
}
# use the recipients email address as username. This enables user prefs
# use the recipients email address as username. This enables user prefs
my $username = ($transaction->recipients)[0]->address;
return lc($username);
};
}
sub assemble_message {
my ($self, $transaction) = @_;
my $message = "X-Envelope-From: "
my $message =
"X-Envelope-From: "
. $transaction->sender->format . "\n"
. $transaction->header->as_string . "\n\n";
$transaction->body_resetpos;
while (my $line = $transaction->body_getline) { $message .= $line; };
while (my $line = $transaction->body_getline) { $message .= $line; }
$message = join(CRLF, split /\n/, $message);
return $message . CRLF;
};
}
sub parse_response {
my $self = shift;
my $response = shift or do {
$self->log( LOGDEBUG, "missing dspam response!" );
$self->log(LOGDEBUG, "missing dspam response!");
return;
};
@ -313,10 +318,10 @@ sub parse_response {
my ($user, $result, $class, $prob, $conf, $sig) = split /; /, $response;
(undef, $result) = split /=/, $result;
(undef, $class ) = split /=/, $class;
(undef, $prob ) = split /=/, $prob;
(undef, $conf ) = split /=/, $conf;
(undef, $sig ) = split /=/, $sig;
(undef, $class) = split /=/, $class;
(undef, $prob) = split /=/, $prob;
(undef, $conf) = split /=/, $conf;
(undef, $sig) = split /=/, $sig;
$result = substr($result, 1, -1); # strip off quotes
$class = substr($class, 1, -1);
@ -328,7 +333,7 @@ sub parse_response {
confidence => $conf,
signature => $sig,
};
};
}
sub parse_response_regexp {
my ($self, $response) = @_;
@ -348,101 +353,108 @@ sub parse_response_regexp {
confidence => $conf,
signature => $sig,
};
};
}
sub dspam_process {
my ( $self, $filtercmd, $transaction ) = @_;
my ($self, $filtercmd, $transaction) = @_;
my $response = $self->dspam_process_backticks($filtercmd);
my $response = $self->dspam_process_backticks( $filtercmd );
#my $response = $self->dspam_process_open2( $filtercmd, $transaction );
#my $response = $self->dspam_process_fork( $filtercmd );
return $self->parse_response( $response );
};
return $self->parse_response($response);
}
sub dspam_process_fork {
my ( $self, $filtercmd, $transaction ) = @_;
my ($self, $filtercmd, $transaction) = @_;
# yucky. This method (which forks) exercises a bug in qpsmtpd. When the
# child exits, the Transaction::DESTROY method is called, which deletes
# the spooled file from disk. The contents of $self->qp->transaction
# needed to spool it again are also destroyed. Don't use this.
my $message = $self->assemble_message( $transaction );
my $message = $self->assemble_message($transaction);
my $in_fh;
if (! open($in_fh, '-|')) { # forks child for writing
if (!open($in_fh, '-|')) { # forks child for writing
open(my $out_fh, "|$filtercmd") or die "Can't run $filtercmd: $!\n";
print $out_fh $message;
close $out_fh;
exit(0);
};
}
my $response = <$in_fh>;
close $in_fh;
chomp $response;
$self->log(LOGDEBUG, $response);
return $response;
};
}
sub dspam_process_backticks {
my ( $self, $filtercmd ) = @_;
my ($self, $filtercmd) = @_;
my $transaction = $self->qp->transaction;
my $message = $self->temp_file();
open my $fh, '>', $message;
print $fh "X-Envelope-From: "
. $transaction->sender->format . CRLF
. $transaction->header->as_string . CRLF . CRLF;
. $transaction->sender->format
. CRLF
. $transaction->header->as_string
. CRLF
. CRLF;
$transaction->body_resetpos;
while (my $line = $transaction->body_getline) { print $fh $line; };
while (my $line = $transaction->body_getline) { print $fh $line; }
close $fh;
my ($line1) = split /[\r|\n]/, `$filtercmd < $message`;
$self->log(LOGDEBUG, $line1);
return $line1;
};
}
sub dspam_process_open2 {
my ( $self, $filtercmd, $transaction ) = @_;
my ($self, $filtercmd, $transaction) = @_;
my $message = $self->assemble_message( $transaction );
my $message = $self->assemble_message($transaction);
# not sure why, but this is not as reliable as I'd like. What's a dspam
# error -5 mean anyway?
# not sure why, but this is not as reliable as I'd like. What's a dspam
# error -5 mean anyway?
use FileHandle;
use IPC::Open3;
my ($read, $write, $err);
use Symbol 'gensym'; $err = gensym;
use Symbol 'gensym';
$err = gensym;
my $pid = open3($write, $read, $err, $filtercmd);
print $write $message;
close $write;
#my $response = join('', <$dspam_out>); # get full response
my $response = <$read>; # get first line only
waitpid $pid, 0;
my $child_exit_status = $? >> 8;
#$self->log(LOGINFO, "exit status: $child_exit_status");
if ( $response ) {
if ($response) {
chomp $response;
$self->log(LOGDEBUG, $response);
};
}
my $err_msg = <$err>;
if ( $err_msg ) {
$self->log(LOGDEBUG, $err_msg );
};
if ($err_msg) {
$self->log(LOGDEBUG, $err_msg);
}
return $response;
};
}
sub log_and_return {
my $self = shift;
my $transaction = shift || $self->qp->transaction;
my $d = $self->get_dspam_results( $transaction ) or return DECLINED;
my $d = $self->get_dspam_results($transaction) or return DECLINED;
if ( ! $d->{class} ) {
if (!$d->{class}) {
$self->log(LOGWARN, "skip, no dspam class detected");
return DECLINED;
};
}
my $status = "$d->{class}, $d->{confidence} c.";
my $reject = $self->{_args}{reject} or do {
@ -450,26 +462,30 @@ sub log_and_return {
return DECLINED;
};
if ( $reject eq 'agree' ) {
return $self->reject_agree( $transaction );
};
if ($reject eq 'agree') {
return $self->reject_agree($transaction);
}
if ( $d->{class} eq 'Innocent' ) {
if ($d->{class} eq 'Innocent') {
$self->log(LOGINFO, "pass, $status");
return DECLINED;
};
if ( $self->qp->connection->relay_client ) {
$self->log(LOGINFO, "skip, allowing spam, user authenticated ($status)");
}
if ($self->qp->connection->relay_client) {
$self->log(LOGINFO,
"skip, allowing spam, user authenticated ($status)");
return DECLINED;
};
if ( $d->{probability} <= $reject ) {
$self->log(LOGINFO, "pass, $d->{class} probability is too low ($d->{probability} < $reject)");
}
if ($d->{probability} <= $reject) {
$self->log(LOGINFO,
"pass, $d->{class} probability is too low ($d->{probability} < $reject)"
);
return DECLINED;
};
if ( $d->{confidence} != 1 ) {
$self->log(LOGINFO, "pass, $d->{class} confidence is too low ($d->{confidence})");
}
if ($d->{confidence} != 1) {
$self->log(LOGINFO,
"pass, $d->{class} confidence is too low ($d->{confidence})");
return DECLINED;
};
}
# dspam is more than $reject percent sure this message is spam
$self->log(LOGINFO, "fail, $d->{class}, ($d->{confidence} confident)");
@ -478,82 +494,84 @@ sub log_and_return {
}
sub reject_agree {
my ($self, $transaction ) = @_;
my ($self, $transaction) = @_;
my $sa = $transaction->notes('spamassassin' );
my $d = $transaction->notes('dspam' );
my $sa = $transaction->notes('spamassassin');
my $d = $transaction->notes('dspam');
my $status = "$d->{class}, $d->{confidence} c";
if ( ! $sa->{is_spam} ) {
if (!$sa->{is_spam}) {
$self->log(LOGINFO, "pass, cannot agree, SA results missing ($status)");
return DECLINED;
};
}
if ( $d->{class} eq 'Spam' ) {
if ( $sa->{is_spam} eq 'Yes' ) {
$self->adjust_karma( -2 );
if ($d->{class} eq 'Spam') {
if ($sa->{is_spam} eq 'Yes') {
$self->adjust_karma(-2);
$self->log(LOGINFO, "fail, agree, $status");
my $reject = $self->get_reject_type();
return ($reject, 'we agree, no spam please');
};
}
$self->log(LOGINFO, "fail, disagree, $status");
return DECLINED;
};
}
if ( $d->{class} eq 'Innocent' ) {
if ( $sa->{is_spam} eq 'No' ) {
if ( $d->{confidence} > .9 ) {
$self->adjust_karma( 1 );
};
if ($d->{class} eq 'Innocent') {
if ($sa->{is_spam} eq 'No') {
if ($d->{confidence} > .9) {
$self->adjust_karma(1);
}
$self->log(LOGINFO, "pass, agree, $status");
return DECLINED;
};
}
$self->log(LOGINFO, "pass, disagree, $status");
return DECLINED;
};
}
$self->log(LOGINFO, "pass, other $status");
return DECLINED;
};
}
sub get_dspam_results {
my $self = shift;
my $transaction = shift || $self->qp->transaction;
if ( $transaction->notes('dspam') ) {
if ($transaction->notes('dspam')) {
return $transaction->notes('dspam');
};
}
my $string = $transaction->header->get('X-DSPAM-Result') or do {
$self->log(LOGWARN, "get_dspam_results: failed to find the header");
return;
};
my @bits = split /,\s+/, $string; chomp @bits;
my @bits = split /,\s+/, $string;
chomp @bits;
my $class = shift @bits;
my %d;
foreach (@bits) {
my ($key,$val) = split /=/, $_;
my ($key, $val) = split /=/, $_;
$d{$key} = $val;
};
}
$d{class} = $class;
my $message = $d{class};
if ( defined $d{probability} && defined $d{confidence} ) {
if (defined $d{probability} && defined $d{confidence}) {
$message .= ", prob: $d{probability}, conf: $d{confidence}";
};
}
$self->log(LOGDEBUG, $message);
$transaction->notes('dspam', \%d);
return \%d;
};
}
sub attach_headers {
my ($self, $r, $transaction) = @_;
$transaction ||= $self->qp->transaction;
my $header_str = "$r->{result}, probability=$r->{probability}, confidence=$r->{confidence}";
my $header_str =
"$r->{result}, probability=$r->{probability}, confidence=$r->{confidence}";
$self->log(LOGDEBUG, $header_str);
my $name = 'X-DSPAM-Result';
$transaction->header->delete($name) if $transaction->header->get($name);
@ -562,135 +580,160 @@ sub attach_headers {
# the signature header is required if you intend to train dspam later.
# In dspam.conf, set: Preference "signatureLocation=headers"
$transaction->header->add('X-DSPAM-Signature', $r->{signature}, 0);
};
}
sub train_error_as_ham {
my $self = shift;
my $transaction = shift;
my $user = $self->select_username( $transaction );
my $user = $self->select_username($transaction);
my $dspam_bin = $self->{_args}{dspam_bin} || '/usr/local/bin/dspam';
my $cmd = "$dspam_bin --user $user --mode=toe --source=error --class=innocent --deliver=summary --stdout";
my $response = $self->dspam_process( $cmd, $transaction );
if ( $response ) {
my $cmd =
"$dspam_bin --user $user --mode=toe --source=error --class=innocent --deliver=summary --stdout";
my $response = $self->dspam_process($cmd, $transaction);
if ($response) {
$transaction->notes('dspam', $response);
}
else {
$transaction->notes('dspam', { class => 'Innocent', result => 'Innocent', confidence=>1 } );
};
};
$transaction->notes(
'dspam',
{
class => 'Innocent',
result => 'Innocent',
confidence => 1
}
);
}
}
sub train_error_as_spam {
my $self = shift;
my $transaction = shift;
my $user = $self->select_username( $transaction );
my $user = $self->select_username($transaction);
my $dspam_bin = $self->{_args}{dspam_bin} || '/usr/local/bin/dspam';
my $cmd = "$dspam_bin --user $user --mode=toe --source=error --class=spam --deliver=summary --stdout";
my $response = $self->dspam_process( $cmd, $transaction );
if ( $response ) {
my $cmd =
"$dspam_bin --user $user --mode=toe --source=error --class=spam --deliver=summary --stdout";
my $response = $self->dspam_process($cmd, $transaction);
if ($response) {
$transaction->notes('dspam', $response);
}
else {
$transaction->notes('dspam', { class => 'Spam', result => 'Spam', confidence=>1 } );
};
};
$transaction->notes(
'dspam',
{
class => 'Spam',
result => 'Spam',
confidence => 1
}
);
}
}
sub autolearn {
my ( $self, $response, $transaction ) = @_;
my ($self, $response, $transaction) = @_;
defined $self->{_args}{autolearn} or return;
if ( $self->{_args}{autolearn} ne 'any'
&& $self->{_args}{autolearn} ne 'karma'
&& $self->{_args}{autolearn} ne 'naughty'
&& $self->{_args}{autolearn} ne 'spamassassin'
) {
$self->log(LOGERROR, "bad autolearn setting! Read 'perldoc plugins/dspam' again!");
&& $self->{_args}{autolearn} ne 'spamassassin')
{
$self->log(LOGERROR,
"bad autolearn setting! Read 'perldoc plugins/dspam' again!");
return;
};
}
# only train once.
$self->autolearn_naughty( $response, $transaction ) and return;
$self->autolearn_karma( $response, $transaction ) and return;
$self->autolearn_spamassassin( $response, $transaction ) and return;
};
$self->autolearn_naughty($response, $transaction) and return;
$self->autolearn_karma($response, $transaction) and return;
$self->autolearn_spamassassin($response, $transaction) and return;
}
sub autolearn_naughty {
my ( $self, $response, $transaction ) = @_;
my ($self, $response, $transaction) = @_;
my $learn = $self->{_args}{autolearn} or return;
if ( $learn ne 'naughty' && $learn ne 'any' ) {
if ($learn ne 'naughty' && $learn ne 'any') {
$self->log(LOGDEBUG, "skipping naughty autolearn");
return;
};
}
if ( $self->connection->notes('naughty') && $response->{result} eq 'Innocent' ) {
if ( $self->connection->notes('naughty')
&& $response->{result} eq 'Innocent')
{
$self->log(LOGINFO, "training naughty FN message as spam");
$self->train_error_as_spam( $transaction );
$self->train_error_as_spam($transaction);
return 1;
};
}
$self->log(LOGDEBUG, "falling through naughty autolearn");
return;
};
}
sub autolearn_karma {
my ( $self, $response, $transaction ) = @_;
my ($self, $response, $transaction) = @_;
my $learn = $self->{_args}{autolearn} or return;
return if ( $learn ne 'karma' && $learn ne 'any' );
return if ($learn ne 'karma' && $learn ne 'any');
my $karma = $self->connection->notes('karma');
return if ! defined $karma;
return if !defined $karma;
if ( $karma < -2 && $response->{result} eq 'Innocent' ) {
if ($karma < -2 && $response->{result} eq 'Innocent') {
$self->log(LOGINFO, "training bad karma ($karma) FN as spam");
$self->train_error_as_spam( $transaction );
$self->train_error_as_spam($transaction);
return 1;
};
}
if ( $karma > 2 && $response->{result} eq 'Spam' ) {
if ($karma > 2 && $response->{result} eq 'Spam') {
$self->log(LOGINFO, "training good karma ($karma) FP as ham");
$self->train_error_as_ham( $transaction );
$self->train_error_as_ham($transaction);
return 1;
};
}
return;
};
}
sub autolearn_spamassassin {
my ( $self, $response, $transaction ) = @_;
my ($self, $response, $transaction) = @_;
my $learn = $self->{_args}{autolearn} or return;
return if ( $learn ne 'spamassassin' && $learn ne 'any' );
return if ($learn ne 'spamassassin' && $learn ne 'any');
my $sa = $transaction->notes('spamassassin' );
if ( ! $sa || ! $sa->{is_spam} ) {
if ( ! $self->connection->notes('naughty') ) {
my $sa = $transaction->notes('spamassassin');
if (!$sa || !$sa->{is_spam}) {
if (!$self->connection->notes('naughty')) {
$self->log(LOGERROR, "SA results missing"); # SA skips naughty
};
}
return;
};
}
if ( ! $sa->{autolearn} ) {
if (!$sa->{autolearn}) {
$self->log(LOGERROR, "SA autolearn unset");
return;
};
}
if ( $sa->{is_spam} eq 'Yes' && $sa->{autolearn} eq 'spam' && $response->{result} eq 'Innocent' ) {
if ( $sa->{is_spam} eq 'Yes'
&& $sa->{autolearn} eq 'spam'
&& $response->{result} eq 'Innocent')
{
$self->log(LOGINFO, "training SA FN as spam");
$self->train_error_as_spam( $transaction );
$self->train_error_as_spam($transaction);
return 1;
}
elsif ( $sa->{is_spam} eq 'No' && $sa->{autolearn} eq 'ham' && $response->{result} eq 'Spam' ) {
elsif ( $sa->{is_spam} eq 'No'
&& $sa->{autolearn} eq 'ham'
&& $response->{result} eq 'Spam')
{
$self->log(LOGINFO, "training SA FP as ham");
$self->train_error_as_ham( $transaction );
$self->train_error_as_ham($transaction);
return 1;
};
}
return;
};
}

57
plugins/earlytalker
View File

@ -77,7 +77,7 @@ sub register {
return;
}
my %check_at;
for (0..$#args) {
for (0 .. $#args) {
next if $_ % 2;
if (lc($args[$_]) eq 'check-at') {
my $val = $args[$_ + 1];
@ -92,18 +92,23 @@ sub register {
@args,
'check-at' => \%check_at,
};
# backwards compat with old 'action' argument
if ( defined $self->{_args}{action} && ! defined $self->{_args}{reject} ) {
# backwards compat with old 'action' argument
if (defined $self->{_args}{action} && !defined $self->{_args}{reject}) {
$self->{_args}{reject} = $self->{_args}{action} =~ /^deny/i ? 1 : 0;
};
if ( defined $self->{_args}{'defer-reject'} && ! defined $self->{_args}{reject_type} ) {
$self->{_args}{reject_type} = $self->{_args}{action} == 'denysoft' ? 'temp' : 'perm';
};
if ( ! defined $self->{_args}{reject_type} ) {
}
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')) {
}
# /end compat
if ($qp->{conn} && $qp->{conn}->isa('Apache2::Connection')) {
require APR::Const;
APR::Const->import(qw(POLLIN SUCCESS));
$self->register_hook('connect', 'apr_connect_handler');
@ -115,7 +120,7 @@ sub register {
}
$self->register_hook('mail', 'mail_handler')
if $self->{_args}{'defer-reject'};
$self->{_args}{reject} = 1 if ! defined $self->{_args}{reject};
$self->{_args}{reject} = 1 if !defined $self->{_args}{reject};
}
sub apr_connect_handler {
@ -133,9 +138,9 @@ sub apr_connect_handler {
if ($self->{_args}{'defer-reject'}) {
$self->connection->notes('earlytalker', 1);
return DECLINED;
};
}
return $self->log_and_deny();
};
}
return $self->log_and_pass();
}
@ -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();
}
@ -168,19 +173,19 @@ sub connect_handler {
if (defined $karma && $karma > 5) {
$self->log(LOGINFO, "skip, karma $karma");
return DECLINED;
};
}
$in->add(\*STDIN) or return DECLINED;
if (! $in->can_read($self->{_args}{'wait'})) {
if (!$in->can_read($self->{_args}{'wait'})) {
return $self->log_and_pass();
};
}
if ( ! $self->{_args}{'defer-reject'}) {
if (!$self->{_args}{'defer-reject'}) {
return $self->log_and_deny();
};
}
$self->connection->notes('earlytalker', 1);
$self->adjust_karma( -1 );
$self->adjust_karma(-1);
return DECLINED;
}
@ -192,12 +197,12 @@ sub data_handler {
return DECLINED if $self->is_immune();
$in->add(\*STDIN) or return DECLINED;
if ( ! $in->can_read($self->{_args}{'wait'})) {
if (!$in->can_read($self->{_args}{'wait'})) {
return $self->log_and_pass();
};
}
return $self->log_and_deny();
};
}
sub log_and_pass {
my $self = shift;
@ -212,12 +217,12 @@ sub log_and_deny {
my $ip = $self->qp->connection->remote_ip || 'remote host';
$self->connection->notes('earlytalker', 1);
$self->adjust_karma( -1 );
$self->adjust_karma(-1);
my $log_mess = "remote started talking before we said hello";
my $smtp_msg = 'Connecting host started transmitting before SMTP greeting';
return $self->get_reject( $smtp_msg, $log_mess );
return $self->get_reject($smtp_msg, $log_mess);
}
sub mail_handler {

125
plugins/fcrdns
View File

@ -102,20 +102,20 @@ use Qpsmtpd::Constants;
sub register {
my ($self, $qp) = (shift, shift);
$self->{_args} = { @_ };
$self->{_args} = {@_};
$self->{_args}{reject_type} = 'temp';
$self->{_args}{timeout} ||= 5;
$self->{_args}{ptr_hosts} = {};
if ( ! defined $self->{_args}{reject} ) {
if (!defined $self->{_args}{reject}) {
$self->{_args}{reject} = 0;
};
}
$self->init_resolver() or return;
$self->register_hook('connect', 'connect_handler');
$self->register_hook('data_post', 'data_post_handler');
};
}
sub connect_handler {
my ($self) = @_;
@ -123,9 +123,9 @@ sub connect_handler {
return DECLINED if $self->is_immune();
# run a couple cheap tests before the more expensive DNS tests
foreach my $test ( qw/ invalid_localhost is_not_fqdn / ) {
foreach my $test (qw/ invalid_localhost is_not_fqdn /) {
$self->$test() or return DECLINED;
};
}
$self->has_reverse_dns() or return DECLINED;
$self->has_forward_dns() or return DECLINED;
@ -138,23 +138,24 @@ sub data_post_handler {
my ($self, $transaction) = @_;
my $match = $self->connection->notes('fcrdns_match') || 0;
$transaction->header->add('X-Fcrdns', $match ? 'Yes' : 'No', 0 );
$transaction->header->add('X-Fcrdns', $match ? 'Yes' : 'No', 0);
return (DECLINED);
};
}
sub invalid_localhost {
my ( $self ) = @_;
my ($self) = @_;
return 1 if lc $self->qp->connection->remote_host ne 'localhost';
if ( $self->qp->connection->remote_ip ne '127.0.0.1'
&& $self->qp->connection->remote_ip ne '::1' ) {
$self->adjust_karma( -1 );
$self->log( LOGINFO, "fail, not localhost" );
&& $self->qp->connection->remote_ip ne '::1')
{
$self->adjust_karma(-1);
$self->log(LOGINFO, "fail, not localhost");
return;
};
$self->adjust_karma( 1 );
$self->log( LOGDEBUG, "pass, is localhost" );
}
$self->adjust_karma(1);
$self->log(LOGDEBUG, "pass, is localhost");
return 1;
};
}
sub is_not_fqdn {
my ($self) = @_;
@ -162,32 +163,32 @@ sub is_not_fqdn {
return 1 if $host eq 'Unknown'; # QP assigns this to a "no DNS result"
# Since QP looked it up, perform some quick validation
if ( $host !~ /\./ ) { # has no dots
$self->adjust_karma( -1 );
if ($host !~ /\./) { # has no dots
$self->adjust_karma(-1);
$self->log(LOGINFO, "fail, not FQDN");
return;
};
if ( $host =~ /[^a-zA-Z0-9\-\.]/ ) {
$self->adjust_karma( -1 );
}
if ($host =~ /[^a-zA-Z0-9\-\.]/) {
$self->adjust_karma(-1);
$self->log(LOGINFO, "fail, invalid FQDN chars");
return;
};
}
return 1;
};
}
sub has_reverse_dns {
my ( $self ) = @_;
my ($self) = @_;
my $res = $self->init_resolver();
my $ip = $self->qp->connection->remote_ip;
my $query = $res->query( $ip ) or do {
if ( $res->errorstring eq 'NXDOMAIN' ) {
$self->adjust_karma( -1 );
$self->log( LOGINFO, "fail, no rDNS: ".$res->errorstring );
my $query = $res->query($ip) or do {
if ($res->errorstring eq 'NXDOMAIN') {
$self->adjust_karma(-1);
$self->log(LOGINFO, "fail, no rDNS: " . $res->errorstring);
return;
};
$self->log( LOGINFO, "fail, error getting rDNS: ".$res->errorstring );
}
$self->log(LOGINFO, "fail, error getting rDNS: " . $res->errorstring);
return;
};
@ -196,33 +197,34 @@ sub has_reverse_dns {
for my $rr ($query->answer) {
next if $rr->type ne 'PTR';
$hits++;
$self->{_args}{ptr_hosts}{ $rr->ptrdname } = 1;
$self->log(LOGDEBUG, "PTR: " . $rr->ptrdname );
};
if ( ! $hits ) {
$self->adjust_karma( -1 );
$self->log( LOGINFO, "fail, no PTR records");
$self->{_args}{ptr_hosts}{$rr->ptrdname} = 1;
$self->log(LOGDEBUG, "PTR: " . $rr->ptrdname);
}
if (!$hits) {
$self->adjust_karma(-1);
$self->log(LOGINFO, "fail, no PTR records");
return;
};
}
$self->log(LOGDEBUG, "has rDNS");
return 1;
};
}
sub has_forward_dns {
my ( $self ) = @_;
my ($self) = @_;
my $res = $self->init_resolver();
foreach my $host ( keys %{ $self->{_args}{ptr_hosts} } ) {
foreach my $host (keys %{$self->{_args}{ptr_hosts}}) {
$host .= '.' if '.' ne substr( $host, -1, 1); # fully qualify name
$host .= '.' if '.' ne substr($host, -1, 1); # fully qualify name
my $query = $res->search($host) or do {
if ( $res->errorstring eq 'NXDOMAIN' ) {
$self->log(LOGDEBUG, "host $host does not exist" );
if ($res->errorstring eq 'NXDOMAIN') {
$self->log(LOGDEBUG, "host $host does not exist");
next;
}
$self->log(LOGDEBUG, "query for $host failed (", $res->errorstring, ")" );
$self->log(LOGDEBUG, "query for $host failed (",
$res->errorstring, ")");
next;
};
@ -230,38 +232,39 @@ sub has_forward_dns {
foreach my $rr ($query->answer) {
next unless $rr->type =~ /^(?:A|AAAA)$/;
$hits++;
$self->check_ip_match( $rr->address ) and return 1;
$self->check_ip_match($rr->address) and return 1;
}
if ( $hits ) {
if ($hits) {
$self->log(LOGDEBUG, "PTR host has forward DNS") if $hits;
return 1;
};
};
$self->adjust_karma( -1 );
}
}
$self->adjust_karma(-1);
$self->log(LOGINFO, "fail, no PTR hosts have forward DNS");
return;
};
}
sub check_ip_match {
my $self = shift;
my $ip = shift or return;
if ( $ip eq $self->qp->connection->remote_ip ) {
$self->log( LOGDEBUG, "forward ip match" );
if ($ip eq $self->qp->connection->remote_ip) {
$self->log(LOGDEBUG, "forward ip match");
$self->connection->notes('fcrdns_match', 1);
$self->adjust_karma( 1 );
$self->adjust_karma(1);
return 1;
};
}
# TODO: make this IPv6 compatible
my $dns_net = join('.', (split(/\./, $ip))[0,1,2] );
my $rem_net = join('.', (split(/\./, $self->qp->connection->remote_ip))[0,1,2] );
# TODO: make this IPv6 compatible
my $dns_net = join('.', (split(/\./, $ip))[0, 1, 2]);
my $rem_net =
join('.', (split(/\./, $self->qp->connection->remote_ip))[0, 1, 2]);
if ( $dns_net eq $rem_net ) {
$self->log( LOGNOTICE, "forward network match" );
if ($dns_net eq $rem_net) {
$self->log(LOGNOTICE, "forward network match");
$self->connection->notes('fcrdns_match', 1);
return 1;
};
}
return;
};
}

237
plugins/greylisting
View File

@ -193,30 +193,34 @@ my %DEFAULTS = (
white_timeout => 36 * 3600 * 24, # 36 days
nfslock => 0,
p0f => undef,
);
);
sub register {
my ($self, $qp, %arg) = @_;
my $config = { %DEFAULTS,
my $config = {
%DEFAULTS,
map { split /\s+/, $_, 2 } $self->qp->config('denysoft_greylist'),
%arg };
if (my @bad = grep { ! exists $PERMITTED_ARGS{$_} } sort keys %$config) {
$self->log(LOGALERT, "invalid parameter(s): " . join(',',@bad));
}
# backwards compatibility with deprecated 'mode' setting
if ( defined $config->{mode} && ! defined $config->{reject} ) {
$config->{reject} = $config->{mode} =~ /testonly|off/i ? 0 : 1;
%arg
};
if (my @bad = grep { !exists $PERMITTED_ARGS{$_} } sort keys %$config) {
$self->log(LOGALERT, "invalid parameter(s): " . join(',', @bad));
}
# backwards compatibility with deprecated 'mode' setting
if (defined $config->{mode} && !defined $config->{reject}) {
$config->{reject} = $config->{mode} =~ /testonly|off/i ? 0 : 1;
}
$self->{_args} = $config;
unless ($config->{recipient} || $config->{per_recipient}) {
$self->register_hook('mail', 'mail_handler');
} else {
}
else {
$self->register_hook('rcpt', 'rcpt_handler');
}
$self->prune_db();
if ( $self->{_args}{upgrade} ) {
if ($self->{_args}{upgrade}) {
$self->convert_db();
};
}
}
sub mail_handler {
@ -226,9 +230,9 @@ sub mail_handler {
return DECLINED if $status != DENYSOFT;
if ( ! $self->{_args}{deny_late} ) {
if (!$self->{_args}{deny_late}) {
return (DENYSOFT, $msg);
};
}
$transaction->notes('greylist', $msg);
return DECLINED;
@ -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,9 +263,12 @@ 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)) {
$self->log(LOGWARN,"skip: all recipients whitelisted");
if (($transaction->notes('whitelistrcpt') || 0) ==
scalar($transaction->recipients))
{
$self->log(LOGWARN, "skip: all recipients whitelisted");
return DECLINED;
}
return DENYSOFT, $transaction->notes('greylist');
@ -264,69 +277,75 @@ 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();
return DECLINED if !$self->is_p0f_match();
return DECLINED if $self->geoip_match();
my $db = $self->get_db_location();
my $lock = $self->get_db_lock( $db ) or return DECLINED;
my $tied = $self->get_db_tie( $db, $lock ) or return DECLINED;
my $key = $self->get_db_key( $sender, $rcpt ) or return DECLINED;
my $lock = $self->get_db_lock($db) or return DECLINED;
my $tied = $self->get_db_tie($db, $lock) or return DECLINED;
my $key = $self->get_db_key($sender, $rcpt) or return DECLINED;
my $fmt = "%s:%d:%d:%d";
# new IP or entry timed out - record new
if ( ! $tied->{$key} ) {
# new IP or entry timed out - record new
if (!$tied->{$key}) {
$tied->{$key} = sprintf $fmt, time, 1, 0, 0;
$self->log(LOGWARN, "fail: initial DENYSOFT, unknown");
return $self->cleanup_and_return( $tied, $lock );
};
return $self->cleanup_and_return($tied, $lock);
}
my ($ts, $new, $black, $white) = split /:/, $tied->{$key};
$self->log(LOGDEBUG, "ts: " . localtime($ts) . ", now: " . localtime);
if ( $white ) {
# white IP - accept unless timed out
if ($white) {
# white IP - accept unless timed out
if (time - $ts < $config->{white_timeout}) {
$tied->{$key} = sprintf $fmt, time, $new, $black, ++$white;
$self->log(LOGINFO, "pass: white, $white deliveries");
return $self->cleanup_and_return( $tied, $lock, DECLINED );
return $self->cleanup_and_return($tied, $lock, DECLINED);
}
else {
$self->log(LOGINFO, "key $key has timed out (white)");
}
};
# Black IP - deny, but don't update timestamp
if (time - $ts < $config->{black_timeout}) {
$tied->{$key} = sprintf $fmt, $ts, $new, ++$black, 0;
$self->log(LOGWARN, "fail: black DENYSOFT - $black deferred connections");
return $self->cleanup_and_return( $tied, $lock );
}
# Grey IP - accept unless timed out
# Black IP - deny, but don't update timestamp
if (time - $ts < $config->{black_timeout}) {
$tied->{$key} = sprintf $fmt, $ts, $new, ++$black, 0;
$self->log(LOGWARN,
"fail: black DENYSOFT - $black deferred connections");
return $self->cleanup_and_return($tied, $lock);
}
# Grey IP - accept unless timed out
elsif (time - $ts < $config->{grey_timeout}) {
$tied->{$key} = sprintf $fmt, time, $new, $black, 1;
$self->log(LOGWARN, "pass: updated grey->white");
return $self->cleanup_and_return( $tied, $lock, DECLINED );
return $self->cleanup_and_return($tied, $lock, DECLINED);
}
$self->log(LOGWARN, "pass: timed out (grey)");
return $self->cleanup_and_return( $tied, $lock, DECLINED );
return $self->cleanup_and_return($tied, $lock, DECLINED);
}
sub cleanup_and_return {
my ($self, $tied, $lock, $return_val ) = @_;
my ($self, $tied, $lock, $return_val) = @_;
untie $tied;
close $lock;
return $return_val if defined $return_val; # explicit override
return DECLINED if defined $self->{_args}{reject} && ! $self->{_args}{reject};
return DECLINED
if defined $self->{_args}{reject} && !$self->{_args}{reject};
return (DENYSOFT, $DENYMSG);
};
}
sub get_db_key {
my $self = shift;
@ -334,30 +353,30 @@ sub get_db_key {
my $rcpt = shift || ($self->qp->transaction->recipients)[0];
my @key;
if ( $self->{_args}{remote_ip} ) {
my $nip = Net::IP->new( $self->qp->connection->remote_ip );
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 ) {
if (!scalar @key) {
$self->log(LOGERROR, "enable one of remote_ip, sender, or recipient!");
return;
};
}
return join ':', @key;
};
}
sub get_db_tie {
my ( $self, $db, $lock ) = @_;
my ($self, $db, $lock) = @_;
tie( my %db, 'AnyDBM_File', $db, O_CREAT|O_RDWR, 0600) or do {
tie(my %db, 'AnyDBM_File', $db, O_CREAT | O_RDWR, 0600) or do {
$self->log(LOGCRIT, "tie to database $db failed: $!");
close $lock;
return;
};
return \%db;
};
}
sub get_db_location {
my $self = shift;
@ -371,25 +390,28 @@ sub get_db_location {
# Setup database location
my $dbdir;
if ( $config->{per_recipient_db} ) {
if ($config->{per_recipient_db}) {
$dbdir = $transaction->notes('per_rcpt_configdir');
};
}
my @candidate_dirs = ( $dbdir, $config->{db_dir},
"/var/lib/qpsmtpd/greylisting", "$QPHOME/var/db", "$QPHOME/config", '.' );
my @candidate_dirs = (
$dbdir, $config->{db_dir},
"/var/lib/qpsmtpd/greylisting",
"$QPHOME/var/db", "$QPHOME/config", '.'
);
for my $d ( @candidate_dirs ) {
next if ! $d || ! -d $d; # impossible
for my $d (@candidate_dirs) {
next if !$d || !-d $d; # impossible
$dbdir = $d;
last; # first match wins
}
my $db = "$dbdir/$DB";
if ( ! -f $db && -f "$dbdir/denysoft_greylist.dbm" ) {
if (!-f $db && -f "$dbdir/denysoft_greylist.dbm") {
$db = "$dbdir/denysoft_greylist.dbm"; # old DB name
}
$self->log(LOGDEBUG,"using $db as greylisting database");
$self->log(LOGDEBUG, "using $db as greylisting database");
return $db;
};
}
sub get_db_lock {
my ($self, $db) = @_;
@ -397,12 +419,12 @@ sub get_db_lock {
return $self->get_db_lock_nfs($db) if $self->{_args}{nfslock};
# Check denysoft db
open( my $lock, ">$db.lock" ) or do {
open(my $lock, ">$db.lock") or do {
$self->log(LOGCRIT, "opening lockfile failed: $!");
return;
};
flock( $lock, LOCK_EX ) or do {
flock($lock, LOCK_EX) or do {
$self->log(LOGCRIT, "flock of lockfile failed: $!");
close $lock;
return;
@ -419,109 +441,110 @@ sub get_db_lock_nfs {
### set up a lock - lasts until object looses scope
my $nfslock = new File::NFSLock {
file => "$db.lock",
lock_type => LOCK_EX|LOCK_NB,
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;
};
open( my $lock, "+<$db.lock") or do {
open(my $lock, "+<$db.lock") or do {
$self->log(LOGCRIT, "opening nfs lockfile failed: $!");
return;
};
return $lock;
};
}
sub convert_db {
my $self = shift;
my $db = $self->get_db_location();
my $lock = $self->get_db_lock( $db ) or return DECLINED;
my $tied = $self->get_db_tie( $db, $lock ) or return DECLINED;
my $lock = $self->get_db_lock($db) or return DECLINED;
my $tied = $self->get_db_tie($db, $lock) or return DECLINED;
my $count = keys %$tied;
my $converted = 0;
foreach my $key ( keys %$tied ) {
my ( @parts ) = split /:/, $key;
foreach my $key (keys %$tied) {
my (@parts) = split /:/, $key;
next if $parts[0] =~ /^[\d]+$/; # already converted
$converted++;
my $nip = Net::IP->new( $parts[0] );
my $nip = Net::IP->new($parts[0]);
$parts[0] = $nip->intip; # convert IP to integer
my $new_key = join ':', @parts;
$tied->{$new_key} = $tied->{$key};
delete $tied->{$key};
};
}
untie $tied;
close $lock;
$self->log( LOGINFO, "converted $converted of $count DB entries" );
return $self->cleanup_and_return( $tied, $lock, DECLINED );
};
$self->log(LOGINFO, "converted $converted of $count DB entries");
return $self->cleanup_and_return($tied, $lock, DECLINED);
}
sub prune_db {
my $self = shift;
my $db = $self->get_db_location();
my $lock = $self->get_db_lock( $db ) or return DECLINED;
my $tied = $self->get_db_tie( $db, $lock ) or return DECLINED;
my $lock = $self->get_db_lock($db) or return DECLINED;
my $tied = $self->get_db_tie($db, $lock) or return DECLINED;
my $count = keys %$tied;
my $pruned = 0;
foreach my $key ( keys %$tied ) {
foreach my $key (keys %$tied) {
my ($ts, $new, $black, $white) = split /:/, $tied->{$key};
my $age = time - $ts;
next if $age < $self->{_args}{white_timeout};
$pruned++;
delete $tied->{$key};
};
}
untie $tied;
close $lock;
$self->log( LOGINFO, "pruned $pruned of $count DB entries" );
return $self->cleanup_and_return( $tied, $lock, DECLINED );
};
$self->log(LOGINFO, "pruned $pruned of $count DB entries");
return $self->cleanup_and_return($tied, $lock, DECLINED);
}
sub p0f_match {
my $self = shift;
return if ! $self->{_args}{p0f};
return if !$self->{_args}{p0f};
my $p0f = $self->connection->notes('p0f');
if ( !$p0f || !ref $p0f ) { # p0f fingerprint info not found
if (!$p0f || !ref $p0f) { # p0f fingerprint info not found
$self->LOGINFO(LOGERROR, "p0f info missing");
return;
};
}
my %valid_matches = map { $_ => 1 } qw( genre detail uptime link distance );
my %requested_matches = split(/\,/, $self->{_args}{p0f} );
my %requested_matches = split(/\,/, $self->{_args}{p0f});
foreach my $key (keys %requested_matches) {
next if ! $key;
if ( ! defined $valid_matches{$key} ) {
$self->log(LOGERROR, "discarding invalid match key ($key)" );
next if !$key;
if (!defined $valid_matches{$key}) {
$self->log(LOGERROR, "discarding invalid match key ($key)");
next;
};
}
my $value = $requested_matches{$key};
next if ! defined $value; # bad config setting?
next if ! defined $p0f->{$key}; # p0f didn't detect the value
next if !defined $value; # bad config setting?
next if !defined $p0f->{$key}; # p0f didn't detect the value
if ( $key eq 'distance' && $p0f->{$key} > $value ) {
if ($key eq 'distance' && $p0f->{$key} > $value) {
$self->log(LOGDEBUG, "p0f distance match ($value)");
return 1;
};
if ( $key eq 'genre' && $p0f->{$key} =~ /$value/i ) {
}
if ($key eq 'genre' && $p0f->{$key} =~ /$value/i) {
$self->log(LOGDEBUG, "p0f genre match ($value)");
return 1;
};
if ( $key eq 'uptime' && $p0f->{$key} < $value ) {
}
if ($key eq 'uptime' && $p0f->{$key} < $value) {
$self->log(LOGDEBUG, "p0f uptime match ($value)");
return 1;
};
if ( $key eq 'link' && $p0f->{$key} =~ /$value/i ) {
}
if ($key eq 'link' && $p0f->{$key} =~ /$value/i) {
$self->log(LOGDEBUG, "p0f link match ($value)");
return 1;
};
}
}
$self->log(LOGINFO, "skip: no p0f match");
return;
@ -530,21 +553,21 @@ sub p0f_match {
sub geoip_match {
my $self = shift;
return if ! $self->{_args}{geoip};
return if !$self->{_args}{geoip};
my $country = $self->connection->notes('geoip_country');
my $c_name = $self->connection->notes('geoip_country_name') || '';
if ( !$country ) {
if (!$country) {
$self->LOGINFO(LOGNOTICE, "skip: no geoip country");
return;
};
}
my @countries = split /,/, $self->{_args}{geoip};
foreach ( @countries ) {
foreach (@countries) {
$self->LOGINFO(LOGINFO, "pass: geoip country match ($_, $c_name)");
return 1 if lc $_ eq lc $country;
};
}
$self->LOGINFO(LOGINFO, "skip: no geoip match ($c_name)");
return;

64
plugins/headers
View File

@ -97,71 +97,73 @@ use Qpsmtpd::Constants;
use Date::Parse qw(str2time);
my @required_headers = qw/ From /; # <- to be RFC 5322 compliant, add Date here
#my @should_headers = qw/ Message-ID /;
my @singular_headers = qw/ Date From Sender Reply-To To Cc Bcc
Message-Id In-Reply-To References
Subject /;
sub register {
my ($self, $qp ) = (shift, shift);
my ($self, $qp) = (shift, shift);
$self->log(LOGWARN, "invalid arguments") if @_ % 2;
$self->{_args} = { @_ };
$self->{_args} = {@_};
$self->{_args}{reject_type} ||= 'perm'; # set default
if ( ! defined $self->{_args}{reject} ) {
if (!defined $self->{_args}{reject}) {
$self->{_args}{reject} = 1; # set default
};
}
if ( $self->{_args}{require} ) {
if ($self->{_args}{require}) {
@required_headers = split /,/, $self->{_args}{require};
};
}
}
sub hook_data_post {
my ($self, $transaction) = @_;
if ( $transaction->data_size == 0 ) {
return $self->get_reject( "You must send some data first", "no data" );
};
if ($transaction->data_size == 0) {
return $self->get_reject("You must send some data first", "no data");
}
my $header = $transaction->header or do {
return $self->get_reject( "Headers are missing", "missing headers" );
return $self->get_reject("Headers are missing", "missing headers");
};
return (DECLINED, "immune") if $self->is_immune();
foreach my $h ( @required_headers ) {
foreach my $h (@required_headers) {
next if $header->get($h);
$self->adjust_karma( -1 );
return $self->get_reject( "We require a valid $h header", "no $h header");
};
$self->adjust_karma(-1);
return $self->get_reject("We require a valid $h header",
"no $h header");
}
foreach my $h ( @singular_headers ) {
next if ! $header->get($h); # doesn't exist
foreach my $h (@singular_headers) {
next if !$header->get($h); # doesn't exist
my @qty = $header->get($h);
next if @qty == 1; # only 1 header
$self->adjust_karma( -1 );
return $self->get_reject(
$self->adjust_karma(-1);
return
$self->get_reject(
"Only one $h header allowed. See RFC 5322, Section 3.6",
"too many $h headers",
);
};
"too many $h headers",);
}
my $err_msg = $self->invalid_date_range();
if ( $err_msg ) {
$self->adjust_karma( -1 );
if ($err_msg) {
$self->adjust_karma(-1);
return $self->get_reject($err_msg, $err_msg);
};
}
$self->log( LOGINFO, 'pass' );
$self->log(LOGINFO, 'pass');
return (DECLINED);
};
}
sub invalid_date_range {
my $self = shift;
return if ! $self->transaction->header;
return if !$self->transaction->header;
my $date = shift || $self->transaction->header->get('Date') or return;
chomp $date;
@ -171,16 +173,16 @@ sub invalid_date_range {
};
my $past = $self->{_args}{past};
if ( $past && $ts < time - ($past*24*3600) ) {
if ($past && $ts < time - ($past * 24 * 3600)) {
$self->log(LOGINFO, "fail, date too old ($date)");
return "The Date header is too far in the past";
};
}
my $future = $self->{_args}{future};
if ( $future && $ts > time + ($future*24*3600) ) {
if ($future && $ts > time + ($future * 24 * 3600)) {
$self->log(LOGINFO, "fail, date in future ($date)");
return "The Date header is too far in the future";
};
}
return;
}

244
plugins/helo
View File

@ -225,40 +225,40 @@ use Qpsmtpd::Constants;
sub register {
my ($self, $qp) = (shift, shift);
$self->{_args} = { @_ };
$self->{_args} = {@_};
$self->{_args}{reject_type} = 'disconnect';
$self->{_args}{policy} ||= 'lenient';
$self->{_args}{dns_timeout} ||= $self->{_args}{timeout} || 5;
if ( ! defined $self->{_args}{reject} ) {
if (!defined $self->{_args}{reject}) {
$self->{_args}{reject} = 1;
};
}
$self->populate_tests();
$self->init_resolver() or return;
$self->register_hook('helo', 'helo_handler');
$self->register_hook('ehlo', 'helo_handler');
$self->register_hook('data_post', 'data_post_handler');
};
}
sub helo_handler {
my ($self, $transaction, $host) = @_;
if ( ! $host ) {
if (!$host) {
$self->log(LOGINFO, "fail, no helo host");
return DECLINED;
};
}
return DECLINED if $self->is_immune();
foreach my $test ( @{ $self->{_helo_tests} } ) {
my @err = $self->$test( $host );
if ( scalar @err ) {
$self->adjust_karma( -1 );
return $self->get_reject( @err );
};
};
foreach my $test (@{$self->{_helo_tests}}) {
my @err = $self->$test($host);
if (scalar @err) {
$self->adjust_karma(-1);
return $self->get_reject(@err);
}
}
$self->log(LOGINFO, "pass");
return DECLINED;
@ -268,239 +268,249 @@ sub data_post_handler {
my ($self, $transaction) = @_;
$transaction->header->delete('X-HELO');
$transaction->header->add('X-HELO', $self->qp->connection->hello_host, 0 );
$transaction->header->add('X-HELO', $self->qp->connection->hello_host, 0);
return (DECLINED);
};
}
sub populate_tests {
my $self = shift;
my $policy = $self->{_args}{policy};
@{ $self->{_helo_tests} } = qw/ is_in_badhelo invalid_localhost is_forged_literal is_plain_ip /;
@{$self->{_helo_tests}} =
qw/ is_in_badhelo invalid_localhost is_forged_literal is_plain_ip /;
if ( $policy eq 'rfc' || $policy eq 'strict' ) {
push @{ $self->{_helo_tests} }, qw/ is_not_fqdn no_forward_dns no_reverse_dns /;
};
if ($policy eq 'rfc' || $policy eq 'strict') {
push @{$self->{_helo_tests}},
qw/ is_not_fqdn no_forward_dns no_reverse_dns /;
}
if ( $policy eq 'strict' ) {
push @{ $self->{_helo_tests} }, qw/ is_address_literal no_matching_dns /;
};
};
if ($policy eq 'strict') {
push @{$self->{_helo_tests}}, qw/ is_address_literal no_matching_dns /;
}
}
sub is_in_badhelo {
my ( $self, $host ) = @_;
my ($self, $host) = @_;
my $error = "I do not believe you are $host.";
$host = lc $host;
foreach my $bad ($self->qp->config('badhelo')) {
if ( $bad =~ /[\{\}\[\]\(\)\^\$\|\*\+\?\\\!]/ ) { # it's a regexp
return $self->is_regex_match( $host, $bad );
};
if ( $host eq lc $bad) {
if ($bad =~ /[\{\}\[\]\(\)\^\$\|\*\+\?\\\!]/) { # it's a regexp
return $self->is_regex_match($host, $bad);
}
if ($host eq lc $bad) {
return ($error, "in badhelo");
}
}
return;
};
}
sub is_regex_match {
my ( $self, $host, $pattern ) = @_;
my ($self, $host, $pattern) = @_;
my $error = "Your HELO hostname is not allowed";
#$self->log( LOGDEBUG, "is regex ($pattern)");
if ( substr( $pattern, 0, 1) eq '!' ) {
if (substr($pattern, 0, 1) eq '!') {
$pattern = substr $pattern, 1;
if ( $host !~ /$pattern/ ) {
if ($host !~ /$pattern/) {
#$self->log( LOGDEBUG, "matched ($pattern)");
return ($error, "badhelo pattern match ($pattern)");
};
}
return;
}
if ( $host =~ /$pattern/ ) {
if ($host =~ /$pattern/) {
#$self->log( LOGDEBUG, "matched ($pattern)");
return ($error, "badhelo pattern match ($pattern)");
};
}
return;
}
sub invalid_localhost {
my ( $self, $host ) = @_;
my ($self, $host) = @_;
return if lc $host ne 'localhost';
if ( $self->qp->connection->remote_ip ne '127.0.0.1' ) {
if ($self->qp->connection->remote_ip ne '127.0.0.1') {
#$self->log( LOGINFO, "fail, not localhost" );
return ("You are not localhost", "invalid localhost");
};
$self->log( LOGDEBUG, "pass, is localhost" );
}
$self->log(LOGDEBUG, "pass, is localhost");
return;
};
}
sub is_plain_ip {
my ( $self, $host ) = @_;
my ($self, $host) = @_;
return if $host =~ /[^\d\.]+/; # has chars other than digits and a dot
return if $host !~ m/^(\d{1,3}\.){3}\d{1,3}$/;
$self->log( LOGDEBUG, "fail, plain IP" );
$self->log(LOGDEBUG, "fail, plain IP");
return ("Plain IP is invalid HELO hostname (RFC 2821)", "plain IP");
};
}
sub is_address_literal {
my ( $self, $host ) = @_;
my ($self, $host) = @_;
return if $host !~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/;
$self->log( LOGDEBUG, "fail, bracketed IP" );
return ("RFC 2821 allows an address literal, but we do not", "bracketed IP");
};
$self->log(LOGDEBUG, "fail, bracketed IP");
return ("RFC 2821 allows an address literal, but we do not",
"bracketed IP");
}
sub is_forged_literal {
my ( $self, $host ) = @_;
my ($self, $host) = @_;
return if $host !~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/;
# should we add exceptions for reserved internal IP space? (192.168,10., etc?)
# should we add exceptions for reserved internal IP space? (192.168,10., etc?)
$host = substr $host, 1, -1;
return if $host eq $self->qp->connection->remote_ip;
return ("Forged IPs not accepted here", "forged IP literal");
};
}
sub is_not_fqdn {
my ($self, $host) = @_;
return if $host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/; # address literal, skip
if ( $host !~ /\./ ) { # has no dots
if ($host !~ /\./) { # has no dots
return ("HELO name is not fully qualified. Read RFC 2821", "not FQDN");
};
if ( $host =~ /[^a-zA-Z0-9\-\.]/ ) {
return ("HELO name contains invalid FQDN characters. Read RFC 1035", "invalid FQDN chars");
};
}
if ($host =~ /[^a-zA-Z0-9\-\.]/) {
return ("HELO name contains invalid FQDN characters. Read RFC 1035",
"invalid FQDN chars");
}
return;
};
}
sub no_forward_dns {
my ( $self, $host ) = @_;
my ($self, $host) = @_;
return if $self->is_address_literal( $host );
return if $self->is_address_literal($host);
my $res = $self->init_resolver();
$host = "$host." if $host !~ /\.$/; # fully qualify name
my $query = $res->search($host);
if (! $query) {
if ( $res->errorstring eq 'NXDOMAIN' ) {
if (!$query) {
if ($res->errorstring eq 'NXDOMAIN') {
return ("HELO hostname does not exist", "no such host");
}
$self->log(LOGERROR, "skip, query failed (", $res->errorstring, ")" );
$self->log(LOGERROR, "skip, query failed (", $res->errorstring, ")");
return;
};
}
my $hits = 0;
foreach my $rr ($query->answer) {
next unless $rr->type =~ /^(?:A|AAAA)$/;
$self->check_ip_match( $rr->address );
$self->check_ip_match($rr->address);
$hits++;
last if $self->connection->notes('helo_forward_match');
}
if ( $hits ) {
if ($hits) {
$self->log(LOGDEBUG, "pass, forward DNS") if $hits;
return;
};
}
return ("HELO hostname did not resolve", "no forward DNS");
};
}
sub no_reverse_dns {
my ( $self, $host, $ip ) = @_;
my ($self, $host, $ip) = @_;
my $res = $self->init_resolver();
$ip ||= $self->qp->connection->remote_ip;
my $query = $res->query( $ip ) or do {
if ( $res->errorstring eq 'NXDOMAIN' ) {
my $query = $res->query($ip) or do {
if ($res->errorstring eq 'NXDOMAIN') {
return ("no rDNS for $ip", "no rDNS");
};
$self->log( LOGINFO, $res->errorstring );
return ("error getting reverse DNS for $ip", "rDNS " . $res->errorstring);
}
$self->log(LOGINFO, $res->errorstring);
return ("error getting reverse DNS for $ip",
"rDNS " . $res->errorstring);
};
my $hits = 0;
for my $rr ($query->answer) {
next if $rr->type ne 'PTR';
$self->log(LOGDEBUG, "PTR: " . $rr->ptrdname );
$self->check_name_match( lc $rr->ptrdname, lc $host );
$self->log(LOGDEBUG, "PTR: " . $rr->ptrdname);
$self->check_name_match(lc $rr->ptrdname, lc $host);
$hits++;
};
if ( $hits ) {
}
if ($hits) {
$self->log(LOGDEBUG, "has rDNS");
return;
};
}
return ("no reverse DNS for $ip", "no rDNS");
};
}
sub no_matching_dns {
my ( $self, $host ) = @_;
my ($self, $host) = @_;
# this is called iprev, or "Forward-confirmed reverse DNS" and is discussed
# in RFC 5451. FCrDNS is done for the remote IP in the fcrdns plugin. Here
# we do it on the HELO hostname.
# consider adding status to Authentication-Results header
# this is called iprev, or "Forward-confirmed reverse DNS" and is discussed
# in RFC 5451. FCrDNS is done for the remote IP in the fcrdns plugin. Here
# we do it on the HELO hostname.
# consider adding status to Authentication-Results header
if ( $self->connection->notes('helo_forward_match') &&
$self->connection->notes('helo_reverse_match') ) {
$self->log( LOGDEBUG, "foward and reverse match" );
$self->adjust_karma( 1 ); # a perfect match
return;
};
if ( $self->connection->notes('helo_forward_match') ) {
$self->log( LOGDEBUG, "name matches IP" );
if ( $self->connection->notes('helo_forward_match')
&& $self->connection->notes('helo_reverse_match'))
{
$self->log(LOGDEBUG, "foward and reverse match");
$self->adjust_karma(1); # a perfect match
return;
}
if ( $self->connection->notes('helo_reverse_match') ) {
$self->log( LOGDEBUG, "reverse matches name" );
return;
};
$self->log( LOGINFO, "fail, no forward or reverse DNS match" );
if ($self->connection->notes('helo_forward_match')) {
$self->log(LOGDEBUG, "name matches IP");
return;
}
if ($self->connection->notes('helo_reverse_match')) {
$self->log(LOGDEBUG, "reverse matches name");
return;
}
$self->log(LOGINFO, "fail, no forward or reverse DNS match");
return ("That HELO hostname fails FCrDNS", "no matching DNS");
};
}
sub check_ip_match {
my $self = shift;
my $ip = shift or return;
if ( $ip eq $self->qp->connection->remote_ip ) {
$self->log( LOGDEBUG, "forward ip match" );
if ($ip eq $self->qp->connection->remote_ip) {
$self->log(LOGDEBUG, "forward ip match");
$self->connection->notes('helo_forward_match', 1);
return;
};
}
my $dns_net = join('.', (split(/\./, $ip))[0,1,2] );
my $rem_net = join('.', (split(/\./, $self->qp->connection->remote_ip))[0,1,2] );
my $dns_net = join('.', (split(/\./, $ip))[0, 1, 2]);
my $rem_net =
join('.', (split(/\./, $self->qp->connection->remote_ip))[0, 1, 2]);
if ( $dns_net eq $rem_net ) {
$self->log( LOGNOTICE, "forward network match" );
if ($dns_net eq $rem_net) {
$self->log(LOGNOTICE, "forward network match");
$self->connection->notes('helo_forward_match', 1);
};
};
}
}
sub check_name_match {
my $self = shift;
my ($dns_name, $helo_name) = @_;
return if ! $dns_name;
return if !$dns_name;
return if split(/\./, $dns_name) < 2; # not a FQDN
if ( $dns_name eq $helo_name ) {
$self->log( LOGDEBUG, "reverse name match" );
if ($dns_name eq $helo_name) {
$self->log(LOGDEBUG, "reverse name match");
$self->connection->notes('helo_reverse_match', 1);
return;
};
}
my $dns_dom = join('.', (split(/\./, $dns_name ))[-2,-1] );
my $helo_dom = join('.', (split(/\./, $helo_name))[-2,-1] );
my $dns_dom = join('.', (split(/\./, $dns_name))[-2, -1]);
my $helo_dom = join('.', (split(/\./, $helo_name))[-2, -1]);
if ( $dns_dom eq $helo_dom ) {
$self->log( LOGNOTICE, "reverse domain match" );
if ($dns_dom eq $helo_dom) {
$self->log(LOGNOTICE, "reverse domain match");
$self->connection->notes('helo_reverse_match', 1);
};
};
}
}

12
plugins/help
View File

@ -42,14 +42,14 @@ The hard coded F<help/> path should be changed.
my %config = ();
sub register {
my ($self,$qp,%args) = @_;
my ($self, $qp, %args) = @_;
my ($file, $cmd);
unless (%args) {
$config{help_dir} = './help/';
}
foreach (keys %args) {
/^(\w+)$/ or
$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') {
@ -117,8 +117,8 @@ sub hook_help {
or $self->log(LOGERROR, "failed to open help file for $cmd: $!"),
return OK, "No help available for SMTP command: $cmd";
}
elsif (exists $config{'help_dir'} && -e $config{'help_dir'}."/$cmd") {
$help = read_helpfile($config{help_dir}."/$cmd", $cmd)
elsif (exists $config{'help_dir'} && -e $config{'help_dir'} . "/$cmd") {
$help = read_helpfile($config{help_dir} . "/$cmd", $cmd)
or $self->log(LOGERROR, "failed to open help file for $cmd: $!"),
return OK, "No help available for SMTP command: $cmd";
}
@ -128,7 +128,7 @@ sub hook_help {
}
sub read_helpfile {
my ($file,$cmd) = @_;
my ($file, $cmd) = @_;
my $help;
open HELP, $file
or return undef;

42
plugins/hosts_allow
View File

@ -57,7 +57,7 @@ use Qpsmtpd::Constants;
use Socket;
sub hook_pre_connection {
my ($self,$transaction,%args) = @_;
my ($self, $transaction, %args) = @_;
# remote_ip => inet_ntoa($iaddr),
# remote_port => $port,
@ -70,24 +70,24 @@ sub hook_pre_connection {
my $max = $args{max_conn_ip};
my $karma = $self->connection->notes('karma_history');
if ( $max ) {
if ($max) {
my $num_conn = 1; # seed with current value
my $raddr = inet_aton($remote);
foreach my $rip (@{$args{child_addrs}}) {
++$num_conn if (defined $rip && $rip eq $raddr);
}
$max = $self->karma_bump( $karma, $max ) if defined $karma;
if ($num_conn > $max ) {
$max = $self->karma_bump($karma, $max) if defined $karma;
if ($num_conn > $max) {
my $err_mess = "too many connections from $remote";
$self->log(LOGINFO, "fail: $err_mess ($num_conn > $max)");
return (DENYSOFT, "$err_mess, try again later");
}
}
my @r = $self->in_hosts_allow( $remote );
my @r = $self->in_hosts_allow($remote);
return @r if scalar @r;
$self->log(LOGDEBUG, "pass" );
$self->log(LOGDEBUG, "pass");
return (DECLINED);
}
@ -95,37 +95,37 @@ sub in_hosts_allow {
my $self = shift;
my $remote = shift;
foreach ( $self->qp->config('hosts_allow') ) {
foreach ($self->qp->config('hosts_allow')) {
s/^\s*//; # trim leading whitespace
my ($ipmask, $const, $message) = split /\s+/, $_, 3;
next unless defined $const;
my ($net,$mask) = split /\//, $ipmask, 2;
$mask = 32 if ! defined $mask;
$mask = pack "B32", "1"x($mask)."0"x(32-$mask);
my ($net, $mask) = split /\//, $ipmask, 2;
$mask = 32 if !defined $mask;
$mask = pack "B32", "1" x ($mask) . "0" x (32 - $mask);
if (join('.', unpack('C4', inet_aton($remote) & $mask)) eq $net) {
$const = Qpsmtpd::Constants::return_code($const) || DECLINED;
if ( $const =~ /deny/i ) {
$self->log( LOGINFO, "fail, $message" );
};
$self->log( LOGDEBUG, "pass, $const, $message" );
return($const, $message);
if ($const =~ /deny/i) {
$self->log(LOGINFO, "fail, $message");
}
$self->log(LOGDEBUG, "pass, $const, $message");
return ($const, $message);
}
}
return;
};
}
sub karma_bump {
my ($self, $karma, $max) = @_;
if ( $karma > 5 ) {
if ($karma > 5) {
$self->log(LOGDEBUG, "connect limit +3 for positive karma");
return $max + 3;
};
if ( $karma <= 0 ) {
}
if ($karma <= 0) {
$self->log(LOGINFO, "connect limit 1, karma $karma");
return 1;
};
}
return $max;
};
}

4
plugins/http_config
View File

@ -1,4 +1,5 @@
#!perl -w
=head1 NAME
http_config
@ -43,7 +44,8 @@ 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)]));
# $self->log(LOGNOTICE, "returning http_config for $config ",Data::Dumper->Dump([\@config], [qw(config)]));
return (OK, @config) if @config;
}
return DECLINED;

136
plugins/ident/geoip
View File

@ -111,22 +111,23 @@ use strict;
use warnings;
use Qpsmtpd::Constants;
#use Geo::IP; # eval'ed in register()
#use Math::Trig; # eval'ed in set_distance_gc
sub register {
my ($self, $qp ) = shift, shift;
my ($self, $qp) = shift, shift;
$self->log(LOGERROR, "Bad arguments") if @_ % 2;
$self->{_args} = { @_ };
$self->{_args} = {@_};
$self->{_args}{db_dir} ||= '/usr/local/share/GeoIP';
eval 'use Geo::IP';
if ( $@ ) {
if ($@) {
warn "could not load Geo::IP";
$self->log( LOGERROR, "could not load Geo::IP" );
$self->log(LOGERROR, "could not load Geo::IP");
return;
};
}
# Note that opening the GeoIP DB only in register has caused problems before:
# https://github.com/smtpd/qpsmtpd/commit/29ea9516806e9a8ca6519fcf987dbd684793ebdd#plugins/ident/geoip
@ -136,8 +137,8 @@ sub register {
$self->init_my_country_code();
$self->register_hook( 'connect', 'connect_handler' );
};
$self->register_hook('connect', 'connect_handler');
}
sub connect_handler {
my $self = shift;
@ -146,7 +147,7 @@ sub connect_handler {
$self->open_geoip_db();
my $c_code = $self->set_country_code() or do {
$self->log( LOGINFO, "skip, no results" );
$self->log(LOGINFO, "skip, no results");
return DECLINED;
};
$self->qp->connection->notes('geoip_country', $c_code);
@ -154,24 +155,26 @@ sub connect_handler {
my $c_name = $self->set_country_name();
my ($city, $continent_code, $distance) = '';
if ( $self->{_my_country_code} ) {
$continent_code = $self->set_continent( $c_code );
if ($self->{_my_country_code}) {
$continent_code = $self->set_continent($c_code);
$city = $self->set_city_gc();
$distance = $self->set_distance_gc();
};
}
my @msg_parts;
push @msg_parts, $continent_code if $continent_code && $continent_code ne '--';
push @msg_parts, $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 ) {
if ($distance) {
push @msg_parts, "\t$distance km";
if ( $self->{_args}{too_far} && $distance > $self->{_args}{too_far} ) {
$self->adjust_karma( -1 );
};
};
$self->log(LOGINFO, join( ", ", @msg_parts) );
if ($self->{_args}{too_far} && $distance > $self->{_args}{too_far}) {
$self->adjust_karma(-1);
}
}
$self->log(LOGINFO, join(", ", @msg_parts));
return DECLINED;
}
@ -181,30 +184,30 @@ sub open_geoip_db {
# this might detect if the DB connection failed. If not, this is where
# to add more code to do it.
return if ( defined $self->{_geoip_city} || defined $self->{_geoip} );
return if (defined $self->{_geoip_city} || defined $self->{_geoip});
# The methods for using GeoIP work differently for the City vs Country DB
# save the handles in different locations
my $db_dir = $self->{_args}{db_dir};
foreach my $db ( qw/ GeoIPCity GeoLiteCity / ) {
if ( -f "$db_dir/$db.dat" ) {
foreach my $db (qw/ GeoIPCity GeoLiteCity /) {
if (-f "$db_dir/$db.dat") {
$self->log(LOGDEBUG, "using db $db");
$self->{_geoip_city} = Geo::IP->open( "$db_dir/$db.dat" );
$self->{_geoip_city} = Geo::IP->open("$db_dir/$db.dat");
}
}
};
# can't think of a good reason to load country if city data is present
if ( ! $self->{_geoip_city} ) {
if (!$self->{_geoip_city}) {
$self->log(LOGDEBUG, "using default db");
$self->{_geoip} = Geo::IP->new(); # loads default Country DB
};
};
}
}
sub init_my_country_code {
my $self = shift;
my $ip = $self->{_args}{distance} or return;
$self->{_my_country_code} = $self->get_country_code( $ip );
};
$self->{_my_country_code} = $self->get_country_code($ip);
}
sub set_country_code {
my $self = shift;
@ -213,124 +216,127 @@ sub set_country_code {
my $code = $self->get_country_code();
$self->qp->connection->notes('geoip_country', $code);
return $code;
};
}
sub get_country_code {
my $self = shift;
my $ip = shift || $self->qp->connection->remote_ip;
return $self->get_country_code_gc( $ip ) if $self->{_geoip_city};
return $self->{_geoip}->country_code_by_addr( $ip );
};
return $self->get_country_code_gc($ip) if $self->{_geoip_city};
return $self->{_geoip}->country_code_by_addr($ip);
}
sub get_country_code_gc {
my $self = shift;
my $ip = shift || $self->qp->connection->remote_ip;
$self->{_geoip_record} = $self->{_geoip_city}->record_by_addr($ip) or return;
$self->{_geoip_record} = $self->{_geoip_city}->record_by_addr($ip)
or return;
return $self->{_geoip_record}->country_code;
};
}
sub set_country_name {
my $self = shift;
return $self->set_country_name_gc() if $self->{_geoip_city};
my $remote_ip = $self->qp->connection->remote_ip;
my $name = $self->{_geoip}->country_name_by_addr( $remote_ip ) or return;
my $name = $self->{_geoip}->country_name_by_addr($remote_ip) or return;
$self->qp->connection->notes('geoip_country_name', $name);
return $name;
};
}
sub set_country_name_gc {
my $self = shift;
return if ! $self->{_geoip_record};
return if !$self->{_geoip_record};
my $remote_ip = $self->qp->connection->remote_ip;
my $name = $self->{_geoip_record}->country_name() or return;
$self->qp->connection->notes('geoip_country_name', $name);
return $name;
};
}
sub set_continent {
my $self = shift;
return $self->set_continent_gc() if $self->{_geoip_city};
my $c_code = shift or return;
my $continent = $self->{_geoip}->continent_code_by_country_code( $c_code )
my $continent = $self->{_geoip}->continent_code_by_country_code($c_code)
or return;
$self->qp->connection->notes('geoip_continent', $continent);
return $continent;
};
}
sub set_continent_gc {
my $self = shift;
return if ! $self->{_geoip_record};
return if !$self->{_geoip_record};
my $continent = $self->{_geoip_record}->continent_code() or return;
$self->qp->connection->notes('geoip_continent', $continent);
return $continent;
};
}
sub set_city_gc {
my $self = shift;
return if ! $self->{_geoip_record};
return if !$self->{_geoip_record};
my $remote_ip = $self->qp->connection->remote_ip;
my $city = $self->{_geoip_record}->city() or return;
$self->qp->connection->notes('geoip_city', $city);
return $city;
};
}
sub set_distance_gc {
my $self = shift;
return if ! $self->{_geoip_record};
return if !$self->{_geoip_record};
my ($self_lat, $self_lon) = $self->get_my_lat_lon() or return;
my ($sender_lat, $sender_lon) = $self->get_sender_lat_lon() or return;
eval 'use Math::Trig qw(great_circle_distance deg2rad)';
if ( $@ ) {
$self->log( LOGERROR, "can't calculate distance, Math::Trig not installed");
if ($@) {
$self->log(LOGERROR,
"can't calculate distance, Math::Trig not installed");
return;
};
}
# Notice the 90 - latitude: phi zero is at the North Pole.
sub NESW { deg2rad($_[0]), deg2rad(90 - $_[1]) };
my @me = NESW($self_lon, $self_lat );
sub NESW { deg2rad($_[0]), deg2rad(90 - $_[1]) }
my @me = NESW($self_lon, $self_lat);
my @sender = NESW($sender_lon, $sender_lat);
my $km = great_circle_distance(@me, @sender, 6378);
$km = sprintf("%.0f", $km);
$self->qp->connection->notes('geoip_distance', $km);
#$self->log( LOGINFO, "distance $km km");
return $km;
};
}
sub get_my_lat_lon {
my $self = shift;
return if ! $self->{_geoip_city};
return if !$self->{_geoip_city};
if ( $self->{_latitude} && $self->{_longitude} ) {
return ( $self->{_latitude}, $self->{_longitude} ); # cached
};
if ($self->{_latitude} && $self->{_longitude}) {
return ($self->{_latitude}, $self->{_longitude}); # cached
}
my $ip = $self->{_args}{distance} or return;
my $record = $self->{_geoip_city}->record_by_addr($ip) or do {
$self->log( LOGERROR, "no record for my Geo::IP location");
$self->log(LOGERROR, "no record for my Geo::IP location");
return;
};
$self->{_latitude} = $record->latitude();
$self->{_longitude} = $record->longitude();
if ( ! $self->{_latitude} || ! $self->{_longitude} ) {
$self->log( LOGNOTICE, "could not get my lat/lon");
};
return ( $self->{_latitude}, $self->{_longitude} );
};
if (!$self->{_latitude} || !$self->{_longitude}) {
$self->log(LOGNOTICE, "could not get my lat/lon");
}
return ($self->{_latitude}, $self->{_longitude});
}
sub get_sender_lat_lon {
my $self = shift;
my $lat = $self->{_geoip_record}->latitude();
my $lon = $self->{_geoip_record}->longitude();
if ( ! $lat || ! $lon ) {
$self->log( LOGNOTICE, "could not get sender lat/lon");
if (!$lat || !$lon) {
$self->log(LOGNOTICE, "could not get sender lat/lon");
return;
};
}
return ($lat, $lon);
};
}

123
plugins/ident/p0f
View File

@ -157,18 +157,18 @@ sub register {
}
sub hook_connect {
my($self, $qp) = @_;
my ($self, $qp) = @_;
my $p0f_version = $self->{_args}{version} || 3;
if ( $p0f_version == 3 ) {
if ($p0f_version == 3) {
my $response = $self->query_p0f_v3() or return DECLINED;
$self->test_v3_response( $response ) or return DECLINED;
$self->store_v3_results( $response );
$self->test_v3_response($response) or return DECLINED;
$self->store_v3_results($response);
}
else {
my $response = $self->query_p0f_v2() or return DECLINED;
$self->test_v2_response( $response ) or return DECLINED;
$self->store_v2_results( $response );
$self->test_v2_response($response) or return DECLINED;
$self->store_v2_results($response);
}
return DECLINED;
@ -179,13 +179,14 @@ sub get_v2_query {
my $local_ip = $self->{_args}{local_ip} || $self->qp->connection->local_ip;
my $src = new Net::IP ($self->qp->connection->remote_ip)
or $self->log(LOGERROR, "skip, ".Net::IP::Error()), return;
my $src = new Net::IP($self->qp->connection->remote_ip)
or $self->log(LOGERROR, "skip, " . Net::IP::Error()), return;
my $dst = new Net::IP($local_ip)
or $self->log(LOGERROR, "skip, ".NET::IP::Error()), return;
or $self->log(LOGERROR, "skip, " . NET::IP::Error()), return;
return pack("L L L N N S S",
return
pack("L L L N N S S",
$QUERY_MAGIC_V2,
1,
rand ^ 42 ^ time,
@ -193,24 +194,26 @@ 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, "skip, unable to determine remote IP");
$self->log(LOGERROR, "skip, unable to determine remote IP");
return;
};
if ( $src_ip =~ /:/ ) { # IPv6
my @bits = split(/\:/, $src_ip );
return pack( "L C C C C C C C C C C C C C C C C C", $QUERY_MAGIC_V3, 0x06, @bits );
};
if ($src_ip =~ /:/) { # IPv6
my @bits = split(/\:/, $src_ip);
return
pack("L C C C C C C C C C C C C C C C C C",
$QUERY_MAGIC_V3, 0x06, @bits);
}
my @octets = split(/\./, $src_ip);
return pack( "L C C16", $QUERY_MAGIC_V3, 0x04, @octets );
};
return pack("L C C16", $QUERY_MAGIC_V3, 0x04, @octets);
}
sub query_p0f_v3 {
my $self = shift;
@ -221,15 +224,15 @@ sub query_p0f_v3 {
};
my $query = $self->get_v3_query() or return;
# Open the connection to p0f
# Open the connection to p0f
my $sock;
eval {
$sock = IO::Socket::UNIX->new(Peer => $p0f_socket, Type => SOCK_STREAM );
$sock = IO::Socket::UNIX->new(Peer => $p0f_socket, Type => SOCK_STREAM);
};
if ( ! $sock ) {
if (!$sock) {
$self->log(LOGERROR, "skip, could not open socket: $@");
return;
};
}
$sock->autoflush(1); # paranoid redundancy
$sock->connected or do {
@ -242,17 +245,18 @@ sub query_p0f_v3 {
return;
};
print $sock $query; # yes, this is redundant, but I get no response from p0f otherwise
print $sock $query
; # yes, this is redundant, but I get no response from p0f otherwise
$self->log(LOGDEBUG, "sent $sent byte request");
my $response;
$sock->recv( $response, 232 );
$sock->recv($response, 232);
my $length = length $response;
$self->log(LOGDEBUG, "received $length byte response");
close $sock;
return $response;
};
}
sub query_p0f_v2 {
my $self = shift;
@ -273,13 +277,13 @@ sub query_p0f_v2 {
or $self->log(LOGERROR, "read: $!"), close SOCK, return;
close SOCK;
return $response;
};
}
sub test_v2_response {
my ($self, $response ) = @_;
my ($self, $response) = @_;
# Extract part of the p0f response
my ($magic, $id, $type) = unpack ("L L C", $response);
my ($magic, $id, $type) = unpack("L L C", $response);
# $self->log(LOGERROR, $response);
if ($magic != $QUERY_MAGIC_V2) {
@ -296,41 +300,43 @@ sub test_v2_response {
return;
}
return 1;
};
}
sub test_v3_response {
my ($self, $response ) = @_;
my ($self, $response) = @_;
my ($magic,$status) = unpack ("L L", $response);
my ($magic, $status) = unpack("L L", $response);
# check the magic response value (a p0f constant)
if ($magic != $RESP_MAGIC_V3 ) {
if ($magic != $RESP_MAGIC_V3) {
$self->log(LOGERROR, "skip, Bad response magic.");
return;
}
# check the response status
if ($status == $P0F_STATUS_BADQUERY ) {
if ($status == $P0F_STATUS_BADQUERY) {
$self->log(LOGERROR, "skip, bad query");
return;
}
elsif ($status == $P0F_STATUS_NOMATCH ) {
elsif ($status == $P0F_STATUS_NOMATCH) {
$self->log(LOGINFO, "skip, no match");
return;
}
if ($status == $P0F_STATUS_OK ) {
if ($status == $P0F_STATUS_OK) {
$self->log(LOGDEBUG, "pass, query ok");
return 1;
}
return;
};
}
sub store_v2_results {
my ($self, $response ) = @_;
my ($self, $response) = @_;
my ($magic, $id, $type, $genre, $detail, $dist, $link, $tos, $fw,
$nat, $real, $score, $mflags, $uptime) =
unpack ("L L C Z20 Z40 c Z30 Z30 C C C s S N", $response);
my (
$magic, $id, $type, $genre, $detail, $dist, $link,
$tos, $fw, $nat, $real, $score, $mflags, $uptime
)
= unpack("L L C Z20 Z40 c Z30 Z30 C C C s S N", $response);
my $p0f = {
genre => $genre,
@ -341,39 +347,40 @@ sub store_v2_results {
};
$self->connection->notes('p0f', $p0f);
$self->log(LOGINFO, $genre." (".$detail.")");
$self->log(LOGERROR,"error: $@") if $@;
$self->log(LOGINFO, $genre . " (" . $detail . ")");
$self->log(LOGERROR, "error: $@") if $@;
return $p0f;
};
}
sub store_v3_results {
my ($self, $response ) = @_;
my ($self, $response) = @_;
my @labels = qw/ magic status first_seen last_seen total_conn uptime_min
up_mod_days last_nat last_chg distance bad_sw os_match_q os_name os_flavor
http_name http_flavor link_type language /;
my @values = unpack ("L L L L L L L L L s C C A32 A32 A32 A32 A32 A32 A32", $response);
my @values =
unpack("L L L L L L L L L s C C A32 A32 A32 A32 A32 A32 A32", $response);
my %r;
foreach my $i ( 0 .. ( scalar @labels -1 ) ) {
next if ! defined $values[$i];
next if ! defined $values[$i];
$r{ $labels[$i] } = $values[$i];
};
if ( $r{os_name} ) { # compat with p0f v2
foreach my $i (0 .. (scalar @labels - 1)) {
next if !defined $values[$i];
next if !defined $values[$i];
$r{$labels[$i]} = $values[$i];
}
if ($r{os_name}) { # compat with p0f v2
$r{genre} = "$r{os_name} $r{os_flavor}";
$r{link} = $r{link_type} if $r{link_type};
$r{uptime} = $r{uptime_min} if $r{uptime_min};
};
}
if ( $r{genre} && $self->{_args}{smite_os} ) {
if ($r{genre} && $self->{_args}{smite_os}) {
my $sos = $self->{_args}{smite_os};
$self->adjust_karma( -1 ) if $r{genre} =~ /$sos/i;
};
$self->adjust_karma(-1) if $r{genre} =~ /$sos/i;
}
$self->connection->notes('p0f', \%r);
$self->log(LOGINFO, "$r{os_name} $r{os_flavor}");
$self->log(LOGDEBUG, join(' ', @values ));
$self->log(LOGERROR,"error: $@") if $@;
$self->log(LOGDEBUG, join(' ', @values));
$self->log(LOGERROR, "error: $@") if $@;
return \%r;
};
}

175
plugins/karma
View File

@ -231,48 +231,51 @@ use Fcntl qw(:DEFAULT :flock LOCK_EX LOCK_NB);
use Net::IP;
sub register {
my ($self, $qp ) = (shift, shift);
my ($self, $qp) = (shift, shift);
$self->log(LOGERROR, "Bad arguments") if @_ % 2;
$self->{_args} = { @_ };
$self->{_args} = {@_};
$self->{_args}{negative} ||= 1;
$self->{_args}{penalty_days} ||= 1;
$self->{_args}{reject_type} ||= 'disconnect';
if ( ! defined $self->{_args}{reject} ) {
if (!defined $self->{_args}{reject}) {
$self->{_args}{reject} = 'naughty';
};
}
#$self->prune_db(); # keep the DB compact
$self->register_hook('connect', 'connect_handler');
$self->register_hook('data', 'data_handler' );
$self->register_hook('data', 'data_handler');
$self->register_hook('disconnect', 'disconnect_handler');
$self->register_hook('received_line', 'rcpt_handler');
}
sub hook_pre_connection {
my ($self,$transaction,%args) = @_;
my ($self, $transaction, %args) = @_;
$self->connection->notes('karma_history', 0);
my $remote_ip = $args{remote_ip};
#my $max_conn = $args{max_conn_ip};
my $db = $self->get_db_location();
my $lock = $self->get_db_lock( $db ) or return DECLINED;
my $tied = $self->get_db_tie( $db, $lock ) or return DECLINED;
my $key = $self->get_db_key( $remote_ip ) or do {
$self->log( LOGINFO, "skip, unable to get DB key" );
my $lock = $self->get_db_lock($db) or return DECLINED;
my $tied = $self->get_db_tie($db, $lock) or return DECLINED;
my $key = $self->get_db_key($remote_ip) or do {
$self->log(LOGINFO, "skip, unable to get DB key");
return DECLINED;
};
if ( ! $tied->{$key} ) {
if (!$tied->{$key}) {
$self->log(LOGDEBUG, "pass, no record");
return $self->cleanup_and_return($tied, $lock );
};
return $self->cleanup_and_return($tied, $lock);
}
my ($penalty_start_ts, $naughty, $nice, $connects) = $self->parse_value( $tied->{$key} );
my ($penalty_start_ts, $naughty, $nice, $connects) =
$self->parse_value($tied->{$key});
$self->calc_karma($naughty, $nice);
return $self->cleanup_and_return($tied, $lock );
};
return $self->cleanup_and_return($tied, $lock);
}
sub connect_handler {
my $self = shift;
@ -282,40 +285,41 @@ sub connect_handler {
return DECLINED if $self->is_immune();
my $db = $self->get_db_location();
my $lock = $self->get_db_lock( $db ) or return DECLINED;
my $tied = $self->get_db_tie( $db, $lock ) or return DECLINED;
my $lock = $self->get_db_lock($db) or return DECLINED;
my $tied = $self->get_db_tie($db, $lock) or return DECLINED;
my $key = $self->get_db_key() or do {
$self->log( LOGINFO, "skip, unable to get DB key" );
$self->log(LOGINFO, "skip, unable to get DB key");
return DECLINED;
};
if ( ! $tied->{$key} ) {
if (!$tied->{$key}) {
$self->log(LOGINFO, "pass, no record");
return $self->cleanup_and_return($tied, $lock );
};
return $self->cleanup_and_return($tied, $lock);
}
my ($penalty_start_ts, $naughty, $nice, $connects) = $self->parse_value( $tied->{$key} );
my ($penalty_start_ts, $naughty, $nice, $connects) =
$self->parse_value($tied->{$key});
my $summary = "$naughty naughty, $nice nice, $connects connects";
my $karma = $self->calc_karma($naughty, $nice);
if ( ! $penalty_start_ts ) {
if (!$penalty_start_ts) {
$self->log(LOGINFO, "pass, no penalty ($summary)");
return $self->cleanup_and_return($tied, $lock );
};
return $self->cleanup_and_return($tied, $lock);
}
my $days_old = (time - $penalty_start_ts) / 86400;
if ( $days_old >= $self->{_args}{penalty_days} ) {
if ($days_old >= $self->{_args}{penalty_days}) {
$self->log(LOGINFO, "pass, penalty expired ($summary)");
return $self->cleanup_and_return($tied, $lock );
};
return $self->cleanup_and_return($tied, $lock);
}
$tied->{$key} = join(':', $penalty_start_ts, $naughty, $nice, ++$connects);
$self->cleanup_and_return($tied, $lock );
$self->cleanup_and_return($tied, $lock);
my $left = sprintf "%.2f", $self->{_args}{penalty_days} - $days_old;
my $mess = "You were naughty. You cannot connect for $left more days.";
return $self->get_reject( $mess, $karma );
return $self->get_reject($mess, $karma);
}
sub rcpt_handler {
@ -327,17 +331,17 @@ sub rcpt_handler {
my $karma = $self->connection->notes('karma_history');
return DECLINED if $karma > 0; # good karma, no limit
# limit # of recipients if host has negative or unknown karma
return $self->get_reject( "too many recipients");
};
# limit # of recipients if host has negative or unknown karma
return $self->get_reject("too many recipients");
}
sub data_handler {
my ($self, $transaction) = @_;
return DECLINED if ! $self->qp->connection->relay_client;
return DECLINED if !$self->qp->connection->relay_client;
$self->adjust_karma( 5 ); # big karma boost for authenticated user/IP
$self->adjust_karma(5); # big karma boost for authenticated user/IP
return DECLINED;
};
}
sub disconnect_handler {
my $self = shift;
@ -348,30 +352,31 @@ sub disconnect_handler {
};
my $db = $self->get_db_location();
my $lock = $self->get_db_lock( $db ) or return DECLINED;
my $tied = $self->get_db_tie( $db, $lock ) or return DECLINED;
my $lock = $self->get_db_lock($db) or return DECLINED;
my $tied = $self->get_db_tie($db, $lock) or return DECLINED;
my $key = $self->get_db_key();
my ($penalty_start_ts, $naughty, $nice, $connects) = $self->parse_value( $tied->{$key} );
my ($penalty_start_ts, $naughty, $nice, $connects) =
$self->parse_value($tied->{$key});
my $history = ($nice || 0) - $naughty;
my $log_mess = '';
if ( $karma < -1 ) { # they achieved at least 2 strikes
if ($karma < -1) { # they achieved at least 2 strikes
$history--;
my $negative_limit = 0 - $self->{_args}{negative};
if ( $history <= $negative_limit ) {
if ( $nice == 0 && $history < -5 ) {
if ($history <= $negative_limit) {
if ($nice == 0 && $history < -5) {
$log_mess = ", penalty box bonus!";
$penalty_start_ts = sprintf "%s", time + abs($history) * 86400;
}
else {
$penalty_start_ts = sprintf "%s", time;
};
}
$log_mess = "negative, sent to penalty box" . $log_mess;
}
else {
$log_mess = "negative";
};
}
}
elsif ($karma > 1) {
$nice++;
@ -380,84 +385,87 @@ sub disconnect_handler {
else {
$log_mess = "neutral";
}
$self->log(LOGINFO, $log_mess . ", (msg: $karma, his: $history)" );
$self->log(LOGINFO, $log_mess . ", (msg: $karma, his: $history)");
$tied->{$key} = join(':', $penalty_start_ts, $naughty, $nice, ++$connects);
return $self->cleanup_and_return($tied, $lock );
return $self->cleanup_and_return($tied, $lock);
}
sub parse_value {
my ($self, $value) = @_;
my $penalty_start_ts = my $naughty = my $nice = my $connects = 0;
if ( $value ) {
if ($value) {
($penalty_start_ts, $naughty, $nice, $connects) = split /:/, $value;
$penalty_start_ts ||= 0;
$nice ||= 0;
$naughty ||= 0;
$connects ||= 0;
};
return ($penalty_start_ts, $naughty, $nice, $connects );
};
}
return ($penalty_start_ts, $naughty, $nice, $connects);
}
sub calc_karma {
my ($self, $naughty, $nice) = @_;
return 0 if ( ! $naughty && ! $nice );
return 0 if (!$naughty && !$nice);
my $karma = ( $nice || 0 ) - ( $naughty || 0 );
$self->connection->notes('karma_history', $karma );
$self->adjust_karma( 1 ) if $karma > 10;
my $karma = ($nice || 0) - ($naughty || 0);
$self->connection->notes('karma_history', $karma);
$self->adjust_karma(1) if $karma > 10;
return $karma;
};
}
sub cleanup_and_return {
my ($self, $tied, $lock, $return_val ) = @_;
my ($self, $tied, $lock, $return_val) = @_;
untie $tied;
close $lock;
return ($return_val) if defined $return_val; # explicit override
return (DECLINED);
};
}
sub get_db_key {
my $self = shift;
my $ip = shift || $self->qp->connection->remote_ip;
my $nip = Net::IP->new( $ip ) or do {
my $nip = Net::IP->new($ip) or do {
$self->log(LOGERROR, "skip, unable to determine remote IP");
return;
};
return $nip->intip; # convert IP to an int
};
}
sub get_db_tie {
my ( $self, $db, $lock ) = @_;
my ($self, $db, $lock) = @_;
tie( my %db, 'AnyDBM_File', $db, O_CREAT|O_RDWR, 0600) or do {
tie(my %db, 'AnyDBM_File', $db, O_CREAT | O_RDWR, 0600) or do {
$self->log(LOGCRIT, "error, tie to database $db failed: $!");
close $lock;
return;
};
return \%db;
};
}
sub get_db_location {
my $self = shift;
# Setup database location
my ($QPHOME) = ($0 =~ m!(.*?)/([^/]+)$!);
my @candidate_dirs = ( $self->{args}{db_dir},
"/var/lib/qpsmtpd/karma", "$QPHOME/var/db", "$QPHOME/config", '.' );
my @candidate_dirs = (
$self->{args}{db_dir},
"/var/lib/qpsmtpd/karma", "$QPHOME/var/db",
"$QPHOME/config", '.'
);
my $dbdir;
for my $d ( @candidate_dirs ) {
next if ! $d || ! -d $d; # impossible
for my $d (@candidate_dirs) {
next if !$d || !-d $d; # impossible
$dbdir = $d;
last; # first match wins
}
my $db = "$dbdir/karma.dbm";
$self->log(LOGDEBUG,"using $db as karma database");
$self->log(LOGDEBUG, "using $db as karma database");
return $db;
};
}
sub get_db_lock {
my ($self, $db) = @_;
@ -465,12 +473,12 @@ sub get_db_lock {
return $self->get_db_lock_nfs($db) if $self->{_args}{nfslock};
# Check denysoft db
open( my $lock, ">$db.lock" ) or do {
open(my $lock, ">$db.lock") or do {
$self->log(LOGCRIT, "error, opening lockfile failed: $!");
return;
};
flock( $lock, LOCK_EX ) or do {
flock($lock, LOCK_EX) or do {
$self->log(LOGCRIT, "error, flock of lockfile failed: $!");
close $lock;
return;
@ -487,41 +495,42 @@ sub get_db_lock_nfs {
### set up a lock - lasts until object looses scope
my $nfslock = new File::NFSLock {
file => "$db.lock",
lock_type => LOCK_EX|LOCK_NB,
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, "error, nfs lockfile failed: $!");
return;
};
open( my $lock, "+<$db.lock") or do {
open(my $lock, "+<$db.lock") or do {
$self->log(LOGCRIT, "error, opening nfs lockfile failed: $!");
return;
};
return $lock;
};
}
sub prune_db {
my $self = shift;
my $db = $self->get_db_location();
my $lock = $self->get_db_lock( $db ) or return DECLINED;
my $tied = $self->get_db_tie( $db, $lock ) or return DECLINED;
my $lock = $self->get_db_lock($db) or return DECLINED;
my $tied = $self->get_db_tie($db, $lock) or return DECLINED;
my $count = keys %$tied;
my $pruned = 0;
foreach my $key ( keys %$tied ) {
foreach my $key (keys %$tied) {
my $ts = $tied->{$key};
my $days_old = ( time - $ts ) / 86400;
my $days_old = (time - $ts) / 86400;
next if $days_old < $self->{_args}{penalty_days} * 2;
delete $tied->{$key};
$pruned++;
};
}
untie $tied;
close $lock;
$self->log( LOGINFO, "pruned $pruned of $count DB entries" );
return $self->cleanup_and_return( $tied, $lock, DECLINED );
};
$self->log(LOGINFO, "pruned $pruned of $count DB entries");
return $self->cleanup_and_return($tied, $lock, DECLINED);
}

190
plugins/karma_tool
View File

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

45
plugins/logging/adaptive
View File

@ -3,50 +3,51 @@
# one level for DENY'd messages
sub register {
my ( $self, $qp, %args ) = @_;
my ($self, $qp, %args) = @_;
$self->{_minlevel} = LOGERROR;
if ( defined( $args{accept} ) ) {
if ( $args{accept} =~ /^\d+$/ ) {
if (defined($args{accept})) {
if ($args{accept} =~ /^\d+$/) {
$self->{_minlevel} = $args{accept};
}
else {
$self->{_minlevel} = log_level( $args{accept} );
$self->{_minlevel} = log_level($args{accept});
}
}
$self->{_maxlevel} = LOGWARN;
if ( defined( $args{reject} ) ) {
if ( $args{reject} =~ /^\d+$/ ) {
if (defined($args{reject})) {
if ($args{reject} =~ /^\d+$/) {
$self->{_maxlevel} = $args{reject};
}
else {
$self->{_maxlevel} = log_level( $args{reject} );
$self->{_maxlevel} = log_level($args{reject});
}
}
$self->{_prefix} = '`';
if ( defined $args{prefix} and $args{prefix} =~ /^(.+)$/ ) {
if (defined $args{prefix} and $args{prefix} =~ /^(.+)$/) {
$self->{_prefix} = $1;
}
# If you want to capture this log entry with this plugin, you need to
# wait until after you register the plugin
$self->log( LOGINFO, 'Initializing logging::adaptive plugin' );
$self->log(LOGINFO, 'Initializing logging::adaptive plugin');
}
sub hook_logging { # wlog
my ( $self, $transaction, $trace, $hook, $plugin, @log ) = @_;
my ($self, $transaction, $trace, $hook, $plugin, @log) = @_;
# Don't log your own log entries! If this is the only logging plugin
# then these lines will not be logged at all. You can safely comment
# out this line and it will not cause an infinite loop.
return DECLINED if defined $plugin and $plugin eq $self->plugin_name;
if ( defined $self->{_maxlevel} && $trace <= $self->{_maxlevel} ) {
if (defined $self->{_maxlevel} && $trace <= $self->{_maxlevel}) {
warn join(
" ", $$.
(
" ",
$$
. (
defined $plugin ? " $plugin plugin:"
: defined $hook ? " running plugin ($hook):"
: ""
@ -55,32 +56,32 @@ sub hook_logging { # wlog
),
"\n"
unless $log[0] =~ /logging::adaptive/;
push @{ $transaction->{_log} }, [ $trace, $hook, $plugin, @log ]
if ( defined $self->{_minlevel} && $trace <= $self->{_minlevel} );
push @{$transaction->{_log}}, [$trace, $hook, $plugin, @log]
if (defined $self->{_minlevel} && $trace <= $self->{_minlevel});
}
return DECLINED;
}
sub hook_deny { # dlog
my ( $self, $transaction, $prev_hook, $return, $return_text ) = @_;
my ($self, $transaction, $prev_hook, $return, $return_text) = @_;
$self->{_denied} = 1;
}
sub hook_reset_transaction { # slog
# fires when a message is accepted
my ( $self, $transaction, @args ) = @_;
my ($self, $transaction, @args) = @_;
return DECLINED if $self->{_denied};
foreach my $row ( @{ $transaction->{_log} } ) {
foreach my $row (@{$transaction->{_log}}) {
next unless scalar @$row; # skip over empty log lines
my ( $trace, $hook, $plugin, @log ) = @$row;
my ($trace, $hook, $plugin, @log) = @$row;
warn join(
" ", $$,
$self->{_prefix}.
(
$self->{_prefix}
. (
defined $plugin ? " $plugin plugin:"
: defined $hook ? " running plugin ($hook):"
: ""
@ -88,7 +89,7 @@ sub hook_reset_transaction { # slog
@log
),
"\n"
if ( $trace <= $self->{_minlevel} );
if ($trace <= $self->{_minlevel});
}
return DECLINED;

21
plugins/logging/connection_id
View File

@ -8,7 +8,7 @@ sub register {
my ($self, $qp, $loglevel) = @_;
die "The connection ID feature is currently unsupported";
$self->{_level} = LOGWARN;
if ( defined($loglevel) ) {
if (defined($loglevel)) {
if ($loglevel =~ /^\d+$/) {
$self->{_level} = $loglevel;
}
@ -19,7 +19,7 @@ sub register {
# If you want to capture this log entry with this plugin, you need to
# wait until after you register the plugin
$self->log(LOGINFO,'Initializing logging::connection_id plugin');
$self->log(LOGINFO, 'Initializing logging::connection_id plugin');
}
sub hook_logging {
@ -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;

41
plugins/logging/file
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;
}
@ -191,14 +192,15 @@ sub log_output {
}
sub open_log {
my ($self,$output,$qp) = @_;
my ($self, $output, $qp) = @_;
if ($self->{_log_pipe}) {
unless ($self->{_f} = new IO::File "|$output") {
warn "Error opening log output to command $output: $!";
return undef;
}
} else {
}
else {
unless ($self->{_f} = new IO::File ">>$output") {
warn "Error opening log output to path $output: $!";
return undef;
@ -209,7 +211,6 @@ sub open_log {
1;
}
# Reopen the output iff the interpolated output filename has changed
# from the one currently open, or if reopening was selected and we haven't
# yet done so during this session.
@ -219,10 +220,13 @@ sub maybe_reopen {
my ($self, $transaction) = @_;
my $new_output = $self->log_output($transaction);
if (!$self->{_current_output} ||
$self->{_current_output} ne $new_output ||
($self->{_reopen} &&
!$transaction->notes('file-reopened-this-session'))) {
if (
!$self->{_current_output}
|| $self->{_current_output} ne $new_output
|| ($self->{_reopen}
&& !$transaction->notes('file-reopened-this-session'))
)
{
unless ($self->open_log($new_output, $transaction)) {
return undef;
}
@ -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;
}

9
plugins/logging/syslog
View File

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

20
plugins/logging/transaction_id
View File

@ -9,7 +9,7 @@ sub register {
die "The transaction ID feature is currently unsupported";
$self->{_level} = LOGWARN;
if ( defined($loglevel) ) {
if (defined($loglevel)) {
if ($loglevel =~ /^\d+$/) {
$self->{_level} = $loglevel;
}
@ -20,7 +20,7 @@ sub register {
# If you want to capture this log entry with this plugin, you need to
# wait until after you register the plugin
$self->log(LOGINFO,'Initializing logging::transaction_id plugin');
$self->log(LOGINFO, 'Initializing logging::transaction_id plugin');
}
sub hook_logging {
@ -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;

12
plugins/logging/warn
View File

@ -41,7 +41,7 @@ sub register {
my ($self, $qp, $loglevel) = @_;
$self->{_level} = LOGWARN;
if ( defined($loglevel) ) {
if (defined($loglevel)) {
if ($loglevel =~ /^\d+$/) {
$self->{_level} = $loglevel;
}
@ -52,7 +52,7 @@ sub register {
# If you want to capture this log entry with this plugin, you need to
# wait until after you register the plugin
$self->log(LOGINFO,'Initializing logging::warn plugin');
$self->log(LOGINFO, 'Initializing logging::warn plugin');
}
sub hook_logging {
@ -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";

8
plugins/loop
View File

@ -33,7 +33,7 @@ sub init {
$self->{_max_hops} = $args[0] || 100;
if ( $self->{_max_hops} !~ /^\d+$/ ) {
if ($self->{_max_hops} !~ /^\d+$/) {
$self->log(LOGWARN, "Invalid max_hops value -- using default");
$self->{_max_hops} = 100;
}
@ -44,10 +44,12 @@ sub hook_data_post {
my ($self, $transaction) = @_;
my $hops = 0;
$hops++ for $transaction->header->get('Received'),
$hops++
for $transaction->header->get('Received'),
$transaction->header->get('Delivered-To');
if ( $hops >= $self->{_max_hops} ) {
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();
}

98
plugins/milter
View File

@ -1,4 +1,5 @@
#!perl -w
=head1 NAME
milter
@ -62,9 +63,11 @@ sub check_results {
my ($self, $transaction, $where, @results) = @_;
foreach my $result (@results) {
next if $result->{action} eq 'continue';
$self->log(LOGINFO, "milter $self->{name} result action: $result->{action}");
$self->log(LOGINFO,
"milter $self->{name} result action: $result->{action}");
if ($result->{action} eq 'reject') {
die("Rejected at $where by $self->{name} milter ($result->{explanation})");
die(
"Rejected at $where by $self->{name} milter ($result->{explanation})");
}
elsif ($result->{action} eq 'add') {
if ($result->{header} eq 'body') {
@ -80,6 +83,7 @@ sub check_results {
$result->{header};
}
elsif ($result->{action} eq 'accept') {
# TODO - figure out what this is used for
}
elsif ($result->{action} eq 'replace') {
@ -92,7 +96,8 @@ sub check_results {
sub hook_connect {
my ($self, $transaction) = @_;
$self->log(LOGDEBUG, "milter $self->{name} opening connection to milter backend");
$self->log(LOGDEBUG,
"milter $self->{name} opening connection to milter backend");
my $milter = Net::Milter->new();
$milter->open($self->{host}, $self->{port}, 'tcp');
$milter->protocol_negotiation();
@ -100,15 +105,21 @@ sub hook_connect {
$self->connection->notes(milter => $milter);
$self->connection->notes(
milter_header_changes => { add => [], delete => [], replace => [], }
);
milter_header_changes => {add => [], delete => [], replace => [],});
my $remote_ip = $self->qp->connection->remote_ip;
my $remote_host = $self->qp->connection->remote_host;
$self->log(LOGDEBUG, "milter $self->{name} checking connect from $remote_host\[$remote_ip\]");
$self->log(LOGDEBUG,
"milter $self->{name} checking connect from $remote_host\[$remote_ip\]"
);
eval {
$self->check_results($transaction, "connection",
$milter->send_connect($remote_host, 'tcp4', 0, $remote_ip));
$self->check_results(
$transaction,
"connection",
$milter->send_connect(
$remote_host, 'tcp4', 0, $remote_ip
)
);
};
$self->connection->notes('spam', $@) if $@;
@ -129,9 +140,10 @@ sub hook_helo {
$self->log(LOGDEBUG, "milter $self->{name} checking HELO $host");
eval { $self->check_results($transaction, "HELO",
$milter->send_helo($host)) };
return(DENY, $@) if $@;
eval {
$self->check_results($transaction, "HELO", $milter->send_helo($host));
};
return (DENY, $@) if $@;
return DECLINED;
}
@ -141,10 +153,13 @@ sub hook_mail {
my $milter = $self->connection->notes('milter');
$self->log(LOGDEBUG, "milter $self->{name} checking MAIL FROM " . $address->format);
eval { $self->check_results($transaction, "MAIL FROM",
$milter->send_mail_from($address->format)) };
return(DENY, $@) if $@;
$self->log(LOGDEBUG,
"milter $self->{name} checking MAIL FROM " . $address->format);
eval {
$self->check_results($transaction, "MAIL FROM",
$milter->send_mail_from($address->format));
};
return (DENY, $@) if $@;
return DECLINED;
}
@ -154,11 +169,14 @@ sub hook_rcpt {
my $milter = $self->connection->notes('milter');
$self->log(LOGDEBUG, "milter $self->{name} checking RCPT TO " . $address->format);
$self->log(LOGDEBUG,
"milter $self->{name} checking RCPT TO " . $address->format);
eval { $self->check_results($transaction, "RCPT TO",
$milter->send_rcpt_to($address->format)) };
return(DENY, $@) if $@;
eval {
$self->check_results($transaction, "RCPT TO",
$milter->send_rcpt_to($address->format));
};
return (DENY, $@) if $@;
return DECLINED;
}
@ -172,20 +190,26 @@ sub hook_data_post {
my $headers = $transaction->header(); # Mail::Header object
foreach my $h ($headers->tags) {
# munge these headers because milters prefer them this way
$h =~ s/\b(\w)/\U$1/g;
$h =~ s/\bid\b/ID/g;
foreach my $val ($headers->get($h)) {
# $self->log(LOGDEBUG, "milter $self->{name} checking header: $h: $val");
eval { $self->check_results($transaction, "header $h",
$milter->send_header($h, $val)) };
return(DENY, $@) if $@;
eval {
$self->check_results($transaction, "header $h",
$milter->send_header($h, $val));
};
return (DENY, $@) if $@;
}
}
eval { $self->check_results($transaction, "end headers",
$milter->send_end_headers()) };
return(DENY, $@) if $@;
eval {
$self->check_results($transaction, "end headers",
$milter->send_end_headers());
};
return (DENY, $@) if $@;
$transaction->body_resetpos;
@ -202,23 +226,29 @@ sub hook_data_post {
while (my $line = $transaction->body_getline) {
$data .= $line;
if (length($data) > 60000) {
eval { $self->check_results($transaction, "body",
$milter->send_body($data)) };
return(DENY, $@) if $@;
eval {
$self->check_results($transaction, "body",
$milter->send_body($data));
};
return (DENY, $@) if $@;
$data = '';
}
}
if (length($data)) {
eval { $self->check_results($transaction, "body",
$milter->send_body($data)) };
return(DENY, $@) if $@;
eval {
$self->check_results($transaction, "body",
$milter->send_body($data));
};
return (DENY, $@) if $@;
$data = '';
}
eval { $self->check_results($transaction, "end of DATA",
$milter->send_end_body()) };
return(DENY, $@) if $@;
eval {
$self->check_results($transaction, "end of DATA",
$milter->send_end_body());
};
return (DENY, $@) if $@;
my $milter_header_changes = $transaction->notes('milter_header_changes');

33
plugins/naughty
View File

@ -109,28 +109,28 @@ use Qpsmtpd::Constants;
sub register {
my ($self, $qp) = (shift, shift);
$self->log(LOGERROR, "Bad arguments") if @_ % 2;
$self->{_args} = { @_ };
$self->{_args} = {@_};
$self->{_args}{reject} ||= 'rcpt';
$self->{_args}{reject_type} ||= 'disconnect';
my $reject = lc $self->{_args}{reject};
my %hooks = map { $_ => 1 }
qw/ connect mail rcpt data data_post hook_queue_post /;
my %hooks =
map { $_ => 1 } qw/ connect mail rcpt data data_post hook_queue_post /;
if ( ! $hooks{$reject} ) {
$self->log( LOGERROR, "fail, invalid hook $reject" );
$self->register_hook( 'data_post', 'naughty');
if (!$hooks{$reject}) {
$self->log(LOGERROR, "fail, invalid hook $reject");
$self->register_hook('data_post', 'naughty');
return;
};
}
# just in case naughty doesn't disconnect, which can happen if a plugin
# with the same hook returned OK before naughty ran, or ....
if ( $reject ne 'data_post' && $reject ne 'hook_queue_post' ) {
$self->register_hook( 'data_post', 'naughty');
};
if ($reject ne 'data_post' && $reject ne 'hook_queue_post') {
$self->register_hook('data_post', 'naughty');
}
$self->log(LOGDEBUG, "registering hook $reject");
$self->register_hook( $reject, 'naughty');
$self->register_hook($reject, 'naughty');
}
sub naughty {
@ -140,8 +140,11 @@ sub naughty {
return DECLINED;
};
$self->log(LOGINFO, "disconnecting");
my $type = $self->get_reject_type( 'disconnect',
$self->connection->notes('naughty_reject_type') );
return ( $type, $naughty );
};
my $type = $self->get_reject_type(
'disconnect',
$self->connection->notes(
'naughty_reject_type')
);
return ($type, $naughty);
}

10
plugins/parse_addr_withhelo
View File

@ -35,20 +35,20 @@ sub hook_rcpt_parse {
}
sub _parse {
my ($self,$cmd,$line) = @_;
my ($self, $cmd, $line) = @_;
$self->log(LOGDEBUG, "_parse() cmd=[$cmd], line=[$line]");
if ($cmd eq 'mail') {
return(DENY, "Syntax error in command")
return (DENY, "Syntax error in command")
unless ($line =~ s/^from:\s*//i);
}
else { # cmd eq 'rcpt'
return(DENY, "Syntax error in command")
return (DENY, "Syntax error in command")
unless ($line =~ s/^to:\s*//i);
}
if ($line =~ s/^(<.*>)\s*//) {
my $addr = $1;
return (DENY, "No parameters allowed in ".uc($cmd))
return (DENY, "No parameters allowed in " . uc($cmd))
if ($line =~ /^\S/);
return (OK, $addr, ());
}
@ -56,7 +56,7 @@ sub _parse {
## now, no <> are given
$line =~ s/\s*$//;
if ($line =~ /\@/) {
return (DENY, "No parameters allowed in ".uc($cmd))
return (DENY, "No parameters allowed in " . uc($cmd))
if ($line =~ /\@\S+\s+\S/);
return (OK, $line, ());
}

37
plugins/qmail_deliverable Executable file → Normal file
View File

@ -141,7 +141,8 @@ sub register {
my ($self, $qp, @args) = @_;
if (@args % 2) {
$self->log(LOGWARN, "Odd number of arguments, using default config");
} else {
}
else {
my %args = @args;
if ($args{server} && $args{server} =~ /^smtproutes:/) {
@ -161,16 +162,17 @@ sub register {
return;
};
} elsif ($args{server}) {
}
elsif ($args{server}) {
$Qmail::Deliverable::Client::SERVER = $args{server};
}
if ( $args{vpopmail_ext} ) {
if ($args{vpopmail_ext}) {
$Qmail::Deliverable::VPOPMAIL_EXT = $args{vpopmail_ext};
};
if ( $args{reject} ) {
}
if ($args{reject}) {
$self->{_args}{reject} = $args{reject};
};
}
}
$self->register_hook("rcpt", "rcpt_handler");
}
@ -194,17 +196,20 @@ sub rcpt_handler {
my $k = 0; # known status code
$self->log(LOGINFO, "error, permission failure"), $k++ if $rv == 0x11;
$self->log(LOGINFO, "pass, qmail-command in dot-qmail"),$k++ if $rv == 0x12;
$self->log(LOGINFO, "pass, qmail-command in dot-qmail"), $k++
if $rv == 0x12;
$self->log(LOGINFO, "pass, bouncesaying with program"), $k++ if $rv == 0x13;
if ( $rv == 0x14 ) {
if ($rv == 0x14) {
my $s = $transaction->sender->address;
return (DENY, "mailing lists do not accept null senders")
if ( ! $s || $s eq '<>');
$self->log(LOGINFO, "pass, ezmlm list"); $k++;
};
if (!$s || $s eq '<>');
$self->log(LOGINFO, "pass, ezmlm list");
$k++;
}
$self->log(LOGINFO, "Temporarily undeliverable: group/world writable"), $k++
if $rv == 0x21;
$self->log(LOGINFO, "Temporarily undeliverable: sticky home directory"),$k++
$self->log(LOGINFO, "Temporarily undeliverable: sticky home directory"),
$k++
if $rv == 0x22;
$self->log(LOGINFO, "error, $Qmail::Deliverable::Client::ERROR"), $k++
if $rv == 0x2f;
@ -217,13 +222,13 @@ sub rcpt_handler {
$self->log(LOGINFO, "error, SHOULD NOT HAPPEN"), $k++ if $rv == 0xfe;
$self->log(LOGINFO, "fail, address not local"), $k++ if $rv == 0xff;
if ( $rv ) {
if ($rv) {
$self->log(LOGINFO, sprintf("error, unknown: 0x%02x", $rv)) if not $k;
return DECLINED;
};
}
$self->adjust_karma( -1 );
return $self->get_reject( "Sorry, no mailbox by that name. qd (#5.1.1)" );
$self->adjust_karma(-1);
return $self->get_reject("Sorry, no mailbox by that name. qd (#5.1.1)");
}
sub _smtproute {

21
plugins/queue/exim-bsmtp
View File

@ -1,4 +1,5 @@
#!perl -w
=head1 NAME
exim-bsmtp
@ -69,8 +70,10 @@ sub register {
$self->{_exim_path} = $args{exim_path} || '/usr/sbin/rsmtp';
$self->{_exim_path} = $1 if $self->{_exim_path} =~ /(.*)/;
unless (-x $self->{_exim_path}) {
$self->log(LOGERROR, "Could not find exim at $self->{_exim_path};".
" please set exim_path in config/plugins");
$self->log(LOGERROR,
"Could not find exim at $self->{_exim_path};"
. " please set exim_path in config/plugins"
);
return undef;
}
}
@ -111,6 +114,7 @@ sub hook_queue {
unlink $tmpfn or $self->log(LOGERROR, "unlink: $tmpfn: $!");
return (DECLINED, "Internal error enqueuing mail");
}
# Normally exim produces no output in BSMTP mode; anything that
# does come out is an error worth logging.
my $start = time;
@ -122,20 +126,23 @@ sub hook_queue {
($bsmtp_error, $bsmtp_msg) = ($1, $2);
}
}
$self->log(LOGDEBUG, "BSMTP finished (".(time - $start)." sec)");
$self->log(LOGDEBUG, "BSMTP finished (" . (time - $start) . " sec)");
$exim->close;
my $exit = $?;
unlink $tmpfn or $self->log(LOGERROR, "unlink: $tmpfn: $!");
$self->log(LOGDEBUG, "Exitcode from exim: $exit");
if ($bsmtp_error && $bsmtp_error >= 400 && $bsmtp_error < 600) {
$self->log(LOGERROR, "BSMTP enqueue failed; response $bsmtp_error".
" ($bsmtp_msg)");
$self->log(LOGERROR,
"BSMTP enqueue failed; response $bsmtp_error" . " ($bsmtp_msg)");
return ($bsmtp_error < 400 ? DECLINED : DENY, $bsmtp_msg);
}
elsif (($exit >> 8) != 0 || $bsmtp_error) {
$self->log(LOGERROR, 'BSMTP enqueue failed; exitcode '.($exit >> 8).
" from $self->{_exim_path} -bS");
$self->log(LOGERROR,
'BSMTP enqueue failed; exitcode '
. ($exit >> 8)
. " from $self->{_exim_path} -bS"
);
return (DECLINED, 'Internal error enqueuing mail');
}

54
plugins/queue/maildir
View File

@ -91,8 +91,10 @@ sub register {
if (@args > 1) {
($self->{_subdirs}) = ($args[1] =~ m#^(.*\%[ldu].*)$#);
unless ($self->{_subdirs}) {
$self->log(LOGWARN, "WARNING: sub directory does not contain a "
."substitution parameter");
$self->log(LOGWARN,
"WARNING: sub directory does not contain a "
. "substitution parameter"
);
return 0;
}
}
@ -115,9 +117,13 @@ sub register {
}
unless ($self->{_subdirs}) {
# mkpath is influenced by umask...
my $old_umask = umask 000;
map { my $d = $self->{_maildir} . "/$_"; -e $d or mkpath $d, 0, $self->{_perms} } qw(cur tmp new);
map {
my $d = $self->{_maildir} . "/$_";
-e $d or mkpath $d, 0, $self->{_perms}
} qw(cur tmp new);
umask $old_umask;
}
@ -136,7 +142,7 @@ sub hook_queue {
if ($self->{_subdirs}) {
foreach my $addr ($transaction->recipients) {
($rc, @msg) = $self->deliver_user($transaction, $addr);
unless($rc == OK) {
unless ($rc == OK) {
umask $old_umask;
return ($rc, @msg);
}
@ -162,13 +168,13 @@ sub write_file {
my $unique = "P$$" . "M$microseconds" . "Q" . $maildir_counter++;
my $file = join ".", $time, $unique, $self->{_hostname};
open (MF, ">$maildir/tmp/$file") or
$self->log(LOGWARN, "could not open $maildir/tmp/$file: $!"),
return(DECLINED, "queue error (open)");
open(MF, ">$maildir/tmp/$file")
or $self->log(LOGWARN, "could not open $maildir/tmp/$file: $!"),
return (DECLINED, "queue error (open)");
print MF "Return-Path: ", $transaction->sender->format , "\n";
print MF "Return-Path: ", $transaction->sender->format, "\n";
print MF "Delivered-To: ",$addr->address,"\n"
print MF "Delivered-To: ", $addr->address, "\n"
if $addr; # else it had been added before...
$transaction->header->print(\*MF);
@ -176,13 +182,15 @@ sub write_file {
while (my $line = $transaction->body_getline) {
print MF $line;
}
close MF or
$self->log(LOGWARN, "could not close $maildir/tmp/$file: $!")
and return(DECLINED, "queue error (close)");
close MF
or $self->log(LOGWARN, "could not close $maildir/tmp/$file: $!")
and return (DECLINED, "queue error (close)");
link "$maildir/tmp/$file", "$maildir/new/$file" or
$self->log(LOGWARN, "could not link $maildir/tmp/$file to $maildir/new/$file: $!")
and return(DECLINED, "queue error (link)");
link "$maildir/tmp/$file",
"$maildir/new/$file"
or $self->log(LOGWARN,
"could not link $maildir/tmp/$file to $maildir/new/$file: $!")
and return (DECLINED, "queue error (link)");
unlink "$maildir/tmp/$file";
@ -194,19 +202,23 @@ sub write_file {
sub deliver_user {
my ($self, $transaction, $addr) = @_;
my $user = $addr->user; $user =~ tr/-A-Za-z0-9+_.,@=/_/c;
my $host = $addr->host; $host =~ tr/-A-Za-z0-9+_.,@=/_/c;
my $rcpt = $user.'@'.$host;
my $user = $addr->user;
$user =~ tr/-A-Za-z0-9+_.,@=/_/c;
my $host = $addr->host;
$host =~ tr/-A-Za-z0-9+_.,@=/_/c;
my $rcpt = $user . '@' . $host;
my $subdir = $self->{_subdirs};
$subdir =~ s/\%l/$user/g;
$subdir =~ s/\%d/$host/g;
$subdir =~ s/\%u/$rcpt/g;
# $subdir =~ s/\%%/%/g;
my $maildir = $self->{_maildir}."/$subdir";
# $subdir =~ s/\%%/%/g;
my $maildir = $self->{_maildir} . "/$subdir";
my $old_umask = umask 000;
map { my $d = $maildir . "/$_"; -e $d or mkpath $d, 0, $self->{_perms} } qw(cur tmp new);
map { my $d = $maildir . "/$_"; -e $d or mkpath $d, 0, $self->{_perms} }
qw(cur tmp new);
umask $old_umask;
return $self->write_file($transaction, $maildir, $addr);

15
plugins/queue/postfix-queue
View File

@ -128,20 +128,22 @@ use Qpsmtpd::Postfix::Constants;
sub register {
my ($self, $qp, @args) = @_;
$self->log(LOGDEBUG, "using constants generated from Postfix"
."v$postfix_version");
$self->log(LOGDEBUG,
"using constants generated from Postfix" . "v$postfix_version");
$self->{_queue_flags} = 0;
if (@args > 0) {
if ($args[0] =~ m#^(/.+)#) {
# untaint socket path
$self->{_queue_socket} = $1;
shift @args;
}
foreach (@args) {
if ($self->can("CLEANUP_".$_) and /^(FLAG_[A-Z0-9_]+)$/) {
if ($self->can("CLEANUP_" . $_) and /^(FLAG_[A-Z0-9_]+)$/) {
$_ = $1;
$self->{_queue_flags} |= (eval "CLEANUP_$_;" || 0);
#print STDERR "queue flag: $_: ".$self->{_queue_flags}."\n";
}
else {
@ -166,9 +168,10 @@ sub hook_queue {
@queue = ($self->{_queue_socket} // ()) unless @queue;
$transaction->notes('postfix-queue-sockets', \@queue) if @queue;
# $self->log(LOGDEBUG, "queue-flags=".$transaction->notes('postfix-queue-flags'));
# $self->log(LOGDEBUG, "queue-flags=".$transaction->notes('postfix-queue-flags'));
my ($status, $qid, $reason) = Qpsmtpd::Postfix->inject_mail($transaction);
if ($status) {
# this split is needed, because if cleanup returns
# CLEANUP_STAT_MASK_INCOMPLETE we might return DENY (CLEANUP_STAT_SIZE)
# instead of DENYSOFT (CLEANUP_STAT_WRITE, CLEANUP_STAT_BAD,
@ -187,8 +190,10 @@ sub hook_queue {
return (DENY, $reason || $cleanup_hard{$key});
}
}
# we have no idea why we're here.
return (DECLINED, $reason || "Unable to queue message ($status, $reason)");
return (DECLINED,
$reason || "Unable to queue message ($status, $reason)");
}
my $msg_id = $transaction->header->get('Message-Id') || '';

54
plugins/queue/qmail-queue
View File

@ -20,7 +20,6 @@ If set the environment variable QMAILQUEUE overrides this setting.
=cut
use strict;
use warnings;
@ -32,7 +31,8 @@ sub register {
if (@args > 0) {
$self->{_queue_exec} = $args[0];
$self->log(LOGWARN, "WARNING: Ignoring additional arguments.") if @args > 1;
$self->log(LOGWARN, "WARNING: Ignoring additional arguments.")
if @args > 1;
}
$self->{_queue_exec} ||= ($ENV{QMAIL} || '/var/qmail') . "/bin/qmail-queue";
@ -42,19 +42,23 @@ sub register {
sub hook_queue {
my ($self, $transaction) = @_;
# these bits inspired by Peter Samuels "qmail-queue wrapper"
# these bits inspired by Peter Samuels "qmail-queue wrapper"
pipe(MESSAGE_READER, MESSAGE_WRITER) or die "Could not create message pipe";
pipe(ENVELOPE_READER, ENVELOPE_WRITER) or die "Could not create envelope pipe";
pipe(ENVELOPE_READER, ENVELOPE_WRITER)
or die "Could not create envelope pipe";
local $SIG{PIPE} = sub { die 'SIGPIPE' };
my $child = fork();
! defined $child and die "Could not fork";
!defined $child and die "Could not fork";
if ($child) {
# Parent
my $oldfh = select MESSAGE_WRITER; $| = 1;
select ENVELOPE_WRITER; $| = 1;
# Parent
my $oldfh = select MESSAGE_WRITER;
$| = 1;
select ENVELOPE_WRITER;
$| = 1;
select $oldfh;
close MESSAGE_READER or die "close msg reader fault";
@ -68,14 +72,15 @@ sub hook_queue {
close MESSAGE_WRITER;
my @rcpt = map { "T" . $_->address } $transaction->recipients;
my $from = "F".($transaction->sender->address|| "" );
print ENVELOPE_WRITER "$from\0", join("\0",@rcpt), "\0\0"
or return(DECLINED,"Could not print addresses to queue");
my $from = "F" . ($transaction->sender->address || "");
print ENVELOPE_WRITER "$from\0", join("\0", @rcpt), "\0\0"
or return (DECLINED, "Could not print addresses to queue");
close ENVELOPE_WRITER;
waitpid($child, 0);
my $exit_code = $? >> 8;
$exit_code and return(DECLINED, "Unable to queue message ($exit_code)");
$exit_code
and return (DECLINED, "Unable to queue message ($exit_code)");
my $msg_id = $transaction->header->get('Message-Id') || '';
$msg_id =~ s/[\r\n].*//s; # don't allow newlines in the Message-Id here
@ -83,33 +88,40 @@ sub hook_queue {
return (OK, "Queued! " . time . " qp $child $msg_id");
}
elsif (defined $child) {
# Child
# Child
close MESSAGE_WRITER or exit 1;
close ENVELOPE_WRITER or exit 2;
# Untaint $self->{_queue_exec}
# Untaint $self->{_queue_exec}
my $queue_exec = $self->{_queue_exec};
if ($queue_exec =~ /^(\/[\/\-\_\.a-z0-9A-Z]*)$/) {
$queue_exec = $1;
} else {
$self->log(LOGERROR, "FATAL ERROR: Unexpected characters in qmail-queue plugin argument");
# This exit is ok as we're exiting a forked child process.
}
else {
$self->log(LOGERROR,
"FATAL ERROR: Unexpected characters in qmail-queue plugin argument"
);
# This exit is ok as we're exiting a forked child process.
exit 3;
}
# save the original STDIN and STDOUT in case exec() fails below
# save the original STDIN and STDOUT in case exec() fails below
open(SAVE_STDIN, "<&STDIN");
open(SAVE_STDOUT, ">&STDOUT");
POSIX::dup2(fileno(MESSAGE_READER), 0) or die "Unable to dup MESSAGE_READER: $!";
POSIX::dup2(fileno(ENVELOPE_READER), 1) or die "Unable to dup ENVELOPE_READER: $!";
POSIX::dup2(fileno(MESSAGE_READER), 0)
or die "Unable to dup MESSAGE_READER: $!";
POSIX::dup2(fileno(ENVELOPE_READER), 1)
or die "Unable to dup ENVELOPE_READER: $!";
my $ppid = getppid();
$self->log(LOGNOTICE, "(for $ppid) Queuing to $queue_exec");
my $rc = exec $queue_exec;
# close the pipe
# close the pipe
close(MESSAGE_READER);
close(MESSAGE_WRITER);

31
plugins/queue/smtp-forward
View File

@ -1,4 +1,5 @@
#!perl -w
=head1 NAME
smtp-forward
@ -36,8 +37,10 @@ sub init {
if (@args > 1 and $args[1] =~ /^(\d+)$/) {
$self->{_smtp_port} = $1;
}
$self->log(LOGWARN, "WARNING: Ignoring additional arguments.") if (@args > 2);
} else {
$self->log(LOGWARN, "WARNING: Ignoring additional arguments.")
if (@args > 2);
}
else {
die("No SMTP server specified in smtp-forward config");
}
@ -46,25 +49,31 @@ sub init {
sub hook_queue {
my ($self, $transaction) = @_;
$self->log(LOGINFO, "forwarding to $self->{_smtp_server}:$self->{_smtp_port}");
$self->log(LOGINFO,
"forwarding to $self->{_smtp_server}:$self->{_smtp_port}");
my $smtp = Net::SMTP->new(
$self->{_smtp_server},
Port => $self->{_smtp_port},
Timeout => 60,
Hello => $self->qp->config("me"),
) || die $!;
$smtp->mail( $transaction->sender->address || "" ) or return(DECLINED, "Unable to queue message ($!)");
)
|| die $!;
$smtp->mail($transaction->sender->address || "")
or return (DECLINED, "Unable to queue message ($!)");
for ($transaction->recipients) {
$smtp->to($_->address) or return(DECLINED, "Unable to queue message ($!)");
$smtp->to($_->address)
or return (DECLINED, "Unable to queue message ($!)");
}
$smtp->data() or return(DECLINED, "Unable to queue message ($!)");
$smtp->datasend($transaction->header->as_string) or return(DECLINED, "Unable to queue message ($!)");
$smtp->data() or return (DECLINED, "Unable to queue message ($!)");
$smtp->datasend($transaction->header->as_string)
or return (DECLINED, "Unable to queue message ($!)");
$transaction->body_resetpos;
while (my $line = $transaction->body_getline) {
$smtp->datasend($line) or return(DECLINED, "Unable to queue message ($!)");
$smtp->datasend($line)
or return (DECLINED, "Unable to queue message ($!)");
}
$smtp->dataend() or return(DECLINED, "Unable to queue message ($!)");
$smtp->quit() or return(DECLINED, "Unable to queue message ($!)");
$smtp->dataend() or return (DECLINED, "Unable to queue message ($!)");
$smtp->quit() or return (DECLINED, "Unable to queue message ($!)");
$self->log(LOGINFO, "finished queueing");
return (OK, "Queued!");
}

25
plugins/random_error
View File

@ -30,7 +30,7 @@ sub register {
my ($self, $qp, @args) = @_;
die "Invalid args: '@args'" unless @args < 2;
($self->{__PACKAGE__.'_how'}) = $args[0] || 1;
($self->{__PACKAGE__ . '_how'}) = $args[0] || 1;
}
@ -52,40 +52,41 @@ or
x = 1 - ( (1 - input_number ) ** (1/6) )
=cut
my $successp = 1 - ($fpct / 100);
$_[0]->log(LOGINFO, "to fail, rand(1) must be more than ". ($successp ** (1 / 6)) );
rand(1) < ($successp ** (1 / 6)) and return NEXT;
$_[0]->log(LOGINFO,
"to fail, rand(1) must be more than " . ($successp**(1 / 6)));
rand(1) < ($successp**(1 / 6)) and return NEXT;
rand(5) < 2 and return (DENYSOFT_DISCONNECT, "random failure");
return (DENYSOFT, "random failure");
}
sub hook_connect {
$_[0]->connection->notes('random_fail_%', $_[0]->{__PACKAGE__.'_how'});
goto &random_fail
$_[0]->connection->notes('random_fail_%', $_[0]->{__PACKAGE__ . '_how'});
goto &random_fail;
}
sub hook_helo {
goto &random_fail
goto &random_fail;
}
sub hook_ehlo {
goto &random_fail
goto &random_fail;
}
sub hook_mail {
goto &random_fail
goto &random_fail;
}
sub hook_rcpt {
goto &random_fail
goto &random_fail;
}
sub hook_data {
goto &random_fail
goto &random_fail;
}
sub hook_data_post {
goto &random_fail
goto &random_fail;
}

8
plugins/rcpt_map
View File

@ -121,9 +121,9 @@ sub register {
$self->{_domain} = lc $self->{_domain};
$self->log(LOGDEBUG,
"Using map ".$self->{_file}." for domain ".$self->{_domain});
"Using map " . $self->{_file} . " for domain " . $self->{_domain});
%map = $self->read_map(1);
die "Empty map file ".$self->{_file}
die "Empty map file " . $self->{_file}
unless keys %map;
}
@ -158,13 +158,13 @@ sub read_map {
unless ($code) {
$self->log(LOGERROR,
"No constant in line $line in ".$self->{_file});
"No constant in line $line in " . $self->{_file});
next;
}
$code = Qpsmtpd::Constants::return_code($code);
unless (defined $code) {
$self->log(LOGERROR,
"Not a valid constant in line $line in ".$self->{_file});
"Not a valid constant in line $line in " . $self->{_file});
next;
}
$msg or $msg = "No such user.";

48
plugins/rcpt_ok
View File

@ -33,10 +33,10 @@ sub hook_rcpt {
# Allow 'no @' addresses for 'postmaster' and 'abuse'
# qmail-smtpd will do this for all users without a domain, but we'll
# be a bit more picky. Maybe that's a bad idea.
my $host = $self->get_rcpt_host( $recipient ) or return (OK);
my $host = $self->get_rcpt_host($recipient) or return (OK);
return (OK) if $self->is_in_rcpthosts( $host );
return (OK) if $self->is_in_morercpthosts( $host );
return (OK) if $self->is_in_rcpthosts($host);
return (OK) if $self->is_in_morercpthosts($host);
return (OK) if $self->qp->connection->relay_client; # failsafe
# default of relaying_denied is obviously DENY,
@ -45,55 +45,55 @@ sub hook_rcpt {
}
sub is_in_rcpthosts {
my ( $self, $host ) = @_;
my ($self, $host) = @_;
my @rcpt_hosts = ($self->qp->config('me'), $self->qp->config('rcpthosts'));
# Check if this recipient host is allowed
for my $allowed (@rcpt_hosts) {
$allowed =~ s/^\s*(\S+)/$1/;
if ( $host eq lc $allowed ) {
$self->log( LOGINFO, "pass: $host in rcpthosts" );
if ($host eq lc $allowed) {
$self->log(LOGINFO, "pass: $host in rcpthosts");
return 1;
};
}
if ( substr($allowed,0,1) eq '.' and $host =~ m/\Q$allowed\E$/i ) {
$self->log( LOGINFO, "pass: $host in rcpthosts as $allowed" );
if (substr($allowed, 0, 1) eq '.' and $host =~ m/\Q$allowed\E$/i) {
$self->log(LOGINFO, "pass: $host in rcpthosts as $allowed");
return 1;
};
}
}
return;
};
}
sub is_in_morercpthosts {
my ( $self, $host ) = @_;
my ($self, $host) = @_;
my $more_rcpt_hosts = $self->qp->config('morercpthosts', 'map');
if ( exists $more_rcpt_hosts->{$host} ) {
$self->log( LOGINFO, "pass: $host found in morercpthosts" );
if (exists $more_rcpt_hosts->{$host}) {
$self->log(LOGINFO, "pass: $host found in morercpthosts");
return 1;
};
}
$self->log( LOGINFO, "fail: $host not in morercpthosts" );
$self->log(LOGINFO, "fail: $host not in morercpthosts");
return;
};
}
sub get_rcpt_host {
my ( $self, $recipient ) = @_;
my ($self, $recipient) = @_;
return if ! $recipient; # Qpsmtpd::Address couldn't parse the recipient
return if !$recipient; # Qpsmtpd::Address couldn't parse the recipient
if ( $recipient->host ) {
if ($recipient->host) {
return lc $recipient->host;
};
}
# no host portion exists
my $user = $recipient->user or return;
if ( lc $user eq 'postmaster' || lc $user eq 'abuse' ) {
if (lc $user eq 'postmaster' || lc $user eq 'abuse') {
return $self->qp->config('me');
};
}
return;
};
}

1
plugins/rcpt_regexp
View File

@ -1,4 +1,5 @@
#!perl -w
=head1 NAME
rcpt_regexp - check recipients against a list of regular expressions

76
plugins/relay
View File

@ -105,14 +105,14 @@ use Qpsmtpd::Constants;
use Net::IP qw(:PROC);
sub register {
my ($self, $qp) = ( shift, shift );
my ($self, $qp) = (shift, shift);
$self->log(LOGERROR, "Bad arguments") if @_ % 2;
$self->{_args} = { @_ };
$self->{_args} = {@_};
if ( $self->{_args}{only} ) {
if ($self->{_args}{only}) {
$self->register_hook('rcpt', 'relay_only');
};
};
}
}
sub is_in_norelayclients {
my $self = shift;
@ -121,30 +121,30 @@ sub is_in_norelayclients {
my $ip = $self->qp->connection->remote_ip;
while ( $ip ) {
if ( exists $no_relay_clients{$ip} ) {
while ($ip) {
if (exists $no_relay_clients{$ip}) {
$self->log(LOGINFO, "$ip in norelayclients");
return 1;
}
$ip =~ s/(\d|\w)+(:|\.)?$// or last; # strip off another octet
};
}
$self->log(LOGDEBUG, "no match in norelayclients");
return;
};
}
sub populate_relayclients {
my $self = shift;
foreach ( $self->qp->config('relayclients') ) {
foreach ($self->qp->config('relayclients')) {
my ($network, $netmask) = ip_splitprefix($_);
if ( $netmask ) {
push @{ $self->{_cidr_blocks} }, $_;
if ($netmask) {
push @{$self->{_cidr_blocks}}, $_;
next;
}
$self->{_octets}{$_} = 1; # no prefix, split
}
};
}
sub is_in_cidr_block {
my $self = shift;
@ -154,20 +154,20 @@ sub is_in_cidr_block {
return;
};
my $cversion = ip_get_version($ip);
for ( @{ $self->{_cidr_blocks} } ) {
for (@{$self->{_cidr_blocks}}) {
my ($network, $mask) = ip_splitprefix($_); # split IP & CIDR range
my $rversion = ip_get_version($network); # get IP version (4 vs 6)
my ($begin, $end) = ip_normalize($_, $rversion); # get pool start/end
# expand the client address (zero pad it) before converting to binary
# expand the client address (zero pad it) before converting to binary
my $bin_ip = ip_iptobin(ip_expand_address($ip, $cversion), $cversion)
or next;
next if ! $begin || ! $end; # probably not a netmask entry
next if !$begin || !$end; # probably not a netmask entry
if ( ip_bincomp($bin_ip, 'gt', ip_iptobin($begin, $rversion))
&& ip_bincomp($bin_ip, 'lt', ip_iptobin($end, $rversion))
) {
&& ip_bincomp($bin_ip, 'lt', ip_iptobin($end, $rversion)))
{
$self->log(LOGINFO, "pass, cidr match ($ip)");
return 1;
}
@ -175,39 +175,39 @@ sub is_in_cidr_block {
$self->log(LOGDEBUG, "no cidr match");
return;
};
}
sub is_octet_match {
my $self = shift;
my $ip = $self->qp->connection->remote_ip;
if ( $ip eq '::1' ) {
if ($ip eq '::1') {
$self->log(LOGINFO, "pass, octet matched localhost ($ip)");
return 1;
};
}
my $more_relay_clients = $self->qp->config('morerelayclients', 'map');
my $ipv6 = $ip =~ /:/ ? 1 : 0;
if ( $ipv6 && $ip =~ /::/ ) { # IPv6 compressed notation
$ip = Net::IP::ip_expand_address($ip,6);
};
if ($ipv6 && $ip =~ /::/) { # IPv6 compressed notation
$ip = Net::IP::ip_expand_address($ip, 6);
}
while ($ip) {
if ( exists $self->{_octets}{$ip} ) {
if (exists $self->{_octets}{$ip}) {
$self->log(LOGINFO, "pass, octet match in relayclients ($ip)");
return 1;
};
}
if ( exists $more_relay_clients->{$ip} ) {
if (exists $more_relay_clients->{$ip}) {
$self->log(LOGINFO, "pass, octet match in morerelayclients ($ip)");
return 1;
};
}
# added IPv6 support (Michael Holzt - 2012-11-14)
if ( $ipv6 ) {
if ($ipv6) {
$ip =~ s/[0-9a-f]:?$//; # strip off another nibble
chop $ip if ':' eq substr($ip, -1, 1);
}
@ -216,34 +216,34 @@ sub is_octet_match {
}
}
$self->log(LOGDEBUG, "no octet match" );
$self->log(LOGDEBUG, "no octet match");
return;
}
sub hook_connect {
my ($self, $transaction) = @_;
if ( $self->is_in_norelayclients() ) {
if ($self->is_in_norelayclients()) {
$self->qp->connection->relay_client(0);
delete $ENV{RELAYCLIENT};
$self->log(LOGINFO, "fail, disabled by norelayclients");
return (DECLINED);
}
if ( $ENV{RELAYCLIENT} ) {
if ($ENV{RELAYCLIENT}) {
$self->qp->connection->relay_client(1);
$self->log(LOGINFO, "pass, enabled by env");
return (DECLINED);
};
}
$self->populate_relayclients();
# 95586 (connect) relay: pass, octet match in relayclients (127.0.0.)
# 95586 (connect) relay: pass, octet match in relayclients (127.0.0.)
if ( $self->is_in_cidr_block() || $self->is_octet_match() ) {
if ($self->is_in_cidr_block() || $self->is_octet_match()) {
$self->qp->connection->relay_client(1);
return (DECLINED);
};
}
$self->log(LOGINFO, "skip, no match");
return (DECLINED);
@ -251,9 +251,9 @@ sub hook_connect {
sub relay_only {
my $self = shift;
if ( $self->qp->connection->relay_client ) {
if ($self->qp->connection->relay_client) {
return (OK);
};
}
return (DENY);
}

100
plugins/resolvable_fromhost
View File

@ -86,9 +86,9 @@ sub register {
foreach (keys %args) {
$self->{_args}->{$_} = $args{$_};
}
if ( ! defined $self->{_args}{reject} ) {
if (!defined $self->{_args}{reject}) {
$self->{_args}{reject} = 1;
};
}
$self->{_args}{reject_type} ||= 'soft';
}
@ -97,11 +97,11 @@ sub hook_mail {
return DECLINED if $self->is_immune();
if ( $sender eq '<>' ) {
if ($sender eq '<>') {
$transaction->notes('resolvable_fromhost', 'null');
$self->log(LOGINFO, "pass, null sender");
return DECLINED;
};
}
$self->populate_invalid_networks();
my $resolved = $self->check_dns($sender->host, $transaction);
@ -110,26 +110,30 @@ sub hook_mail {
#return DECLINED if $sender->host; # reject later
my $result = $transaction->notes('resolvable_fromhost') or do {
if ( $self->{_args}{reject} ) {;
$self->log(LOGINFO, 'fail, missing result' );
return Qpsmtpd::DSN->temp_resolver_failed( $self->get_reject_type(), '' );
};
$self->log(LOGINFO, 'fail, missing result, reject disabled' );
if ($self->{_args}{reject}) {
;
$self->log(LOGINFO, 'fail, missing result');
return Qpsmtpd::DSN->temp_resolver_failed($self->get_reject_type(),
'');
}
$self->log(LOGINFO, 'fail, missing result, reject disabled');
return DECLINED;
};
return DECLINED if $result =~ /^(?:a|ip|mx)$/; # success
return DECLINED if $result =~ /^(?:whitelist|null|naughty)$/; # immunity
$self->adjust_karma( -1 );
$self->adjust_karma(-1);
if ( ! $self->{_args}{reject} ) {;
$self->log(LOGINFO, "fail, reject disabled, $result" );
if (!$self->{_args}{reject}) {
;
$self->log(LOGINFO, "fail, reject disabled, $result");
return DECLINED;
};
}
$self->log(LOGINFO, "fail, $result" ); # log error
return Qpsmtpd::DSN->addr_bad_from_system( $self->get_reject_type(),
$self->log(LOGINFO, "fail, $result"); # log error
return
Qpsmtpd::DSN->addr_bad_from_system($self->get_reject_type(),
"FQDN required in the envelope sender");
}
@ -137,42 +141,42 @@ sub check_dns {
my ($self, $host, $transaction) = @_;
# we can't even parse a hostname out of the address
if ( ! $host ) {
if (!$host) {
$transaction->notes('resolvable_fromhost', 'unparsable host');
$self->adjust_karma( -1 );
$self->adjust_karma(-1);
return;
};
}
$transaction->notes('resolvable_fromhost_host', $host);
if ( $host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/ ) {
if ($host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/) {
$self->log(LOGINFO, "skip, $host is an IP");
$transaction->notes('resolvable_fromhost', 'ip');
$self->adjust_karma( -1 );
$self->adjust_karma(-1);
return 1;
};
}
my $res = new Net::DNS::Resolver(dnsrch => 0);
$res->tcp_timeout(30);
$res->udp_timeout(30);
my $has_mx = $self->get_and_validate_mx( $res, $host, $transaction );
my $has_mx = $self->get_and_validate_mx($res, $host, $transaction);
return 1 if $has_mx == 1; # success, has MX!
return if $has_mx == -1; # has invalid MX records
# at this point, no MX for fh is resolvable
my @host_answers = $self->get_host_records( $res, $host, $transaction );
my @host_answers = $self->get_host_records($res, $host, $transaction);
foreach my $rr (@host_answers) {
if ( $rr->type eq 'A' || $rr->type eq 'AAAA' ) {
if ($rr->type eq 'A' || $rr->type eq 'AAAA') {
$self->log(LOGINFO, "pass, found A for $host");
$transaction->notes('resolvable_fromhost', 'a');
return $self->ip_is_valid($rr->address);
};
if ( $rr->type eq 'MX' ) {
}
if ($rr->type eq 'MX') {
$self->log(LOGINFO, "pass, found MX for $host");
$transaction->notes('resolvable_fromhost', 'mx');
return $self->mx_address_resolves($rr->exchange, $host);
};
}
}
return;
}
@ -193,33 +197,34 @@ sub ip_is_valid {
}
sub get_and_validate_mx {
my ($self, $res, $host, $transaction ) = @_;
my ($self, $res, $host, $transaction) = @_;
my @mx = mx($res, $host);
if ( ! scalar @mx ) { # no mx records
$self->adjust_karma( -1 );
if (!scalar @mx) { # no mx records
$self->adjust_karma(-1);
$self->log(LOGINFO, "$host has no MX");
return 0;
};
}
foreach my $mx (@mx) {
# if any MX is valid, then we consider the domain resolvable
if ( $self->mx_address_resolves($mx->exchange, $host) ) {
if ($self->mx_address_resolves($mx->exchange, $host)) {
$self->log(LOGINFO, "pass, $host has MX at " . $mx->exchange);
$transaction->notes('resolvable_fromhost', 'mx');
return 1;
};
}
}
# if there are MX records, and we got here, none are valid
#$self->log(LOGINFO, "fail, invalid MX for $host");
$transaction->notes('resolvable_fromhost', "invalid MX for $host");
$self->adjust_karma( -1 );
$self->adjust_karma(-1);
return -1;
};
}
sub get_host_records {
my ($self, $res, $host, $transaction ) = @_;
my ($self, $res, $host, $transaction) = @_;
my @answers;
my $query = $res->search($host);
@ -239,15 +244,15 @@ sub get_host_records {
}
}
if ( ! scalar @answers) {
if ( $res->errorstring ne 'NXDOMAIN' ) {
if (!scalar @answers) {
if ($res->errorstring ne 'NXDOMAIN') {
$self->log(LOGWARN, "fail, query for $host, ", $res->errorstring);
};
}
return;
};
}
return @answers;
};
}
sub mx_address_resolves {
my ($self, $name, $fromhost) = @_;
@ -271,15 +276,16 @@ sub mx_address_resolves {
}
}
}
if (! @mx_answers) {
if ( $res->errorstring eq 'NXDOMAIN' ) {
$self->log(LOGWARN, "fail, query for $fromhost, ", $res->errorstring);
};
if (!@mx_answers) {
if ($res->errorstring eq 'NXDOMAIN') {
$self->log(LOGWARN, "fail, query for $fromhost, ",
$res->errorstring);
}
return;
}
foreach my $rr (@mx_answers) {
next if ( $rr->type ne 'A' && $rr->type ne 'AAAA' );
next if ($rr->type ne 'A' && $rr->type ne 'AAAA');
return $self->ip_is_valid($rr->address);
}
@ -296,5 +302,5 @@ sub populate_invalid_networks {
$invalid{$1} = $3;
}
}
};
}

67
plugins/rhsbl
View File

@ -31,29 +31,29 @@ use warnings;
use Qpsmtpd::Constants;
sub register {
my ($self, $qp ) = (shift, shift);
my ($self, $qp) = (shift, shift);
if ( @_ == 1 ) {
$self->legacy_positional_args( @_ );
if (@_ == 1) {
$self->legacy_positional_args(@_);
}
else {
$self->{_args} = { @_ };
};
$self->{_args} = {@_};
}
$self->{_args}{reject} = 1 if ! defined $self->{_args}{reject};
$self->{_args}{reject} = 1 if !defined $self->{_args}{reject};
$self->{_args}{reject_type} ||= 'perm';
}
sub legacy_positional_args {
my ($self, $denial) = @_;
if ( defined $denial && $denial =~ /^disconnect$/i ) {
if (defined $denial && $denial =~ /^disconnect$/i) {
$self->{_args}{reject_type} = 'disconnect';
}
else {
$self->{_args}{reject_type} = 'perm';
}
};
}
sub hook_mail {
my ($self, $transaction, $sender, %param) = @_;
@ -63,7 +63,7 @@ sub hook_mail {
if ($sender->format eq '<>') {
$self->log(LOGINFO, 'pass, null sender');
return DECLINED;
};
}
my %rhsbl_zones = $self->populate_zones() or return DECLINED;
@ -73,47 +73,53 @@ sub hook_mail {
for my $host (@hosts) {
for my $rhsbl (keys %rhsbl_zones) {
my $query;
# fix to find TXT records, if the rhsbl_zones line doesn't have second field
# fix to find TXT records, if the rhsbl_zones line doesn't have second field
if (defined($rhsbl_zones{$rhsbl})) {
$self->log(LOGDEBUG, "Checking $host.$rhsbl for A record");
$query = $res->query("$host.$rhsbl");
} else {
}
else {
$self->log(LOGDEBUG, "Checking $host.$rhsbl for TXT record");
$query = $res->query("$host.$rhsbl", 'TXT');
}
if ( ! $query) {
if ( $res->errorstring ne 'NXDOMAIN' ) {
if (!$query) {
if ($res->errorstring ne 'NXDOMAIN') {
$self->log(LOGCRIT, "query failed: ", $res->errorstring);
};
}
next;
};
}
my $result;
foreach my $rr ($query->answer) {
$self->log(LOGDEBUG, 'got an ' . $rr->type . ' record ' . $rr->name);
$self->log(LOGDEBUG,
'got an ' . $rr->type . ' record ' . $rr->name);
if ($rr->type eq 'A') {
$self->log(LOGDEBUG, "A record found for $result with IP " . $rr->address);
$self->log(LOGDEBUG,
"A record found for $result with IP " . $rr->address);
$result = $rr->name;
}
elsif ($rr->type eq 'TXT') {
$result = $rr->txtdata;
$self->log(LOGDEBUG, "TXT record found: " . $rr->txtdata);
};
}
next if ! $result;
next if !$result;
$self->log(LOGINFO, "fail, $result");
if ( $transaction->sender ) {
if ($transaction->sender) {
my $host = $transaction->sender->host;
if ($result =~ /^$host\./ ) {
return $self->get_reject( "Mail from $host rejected because it $result" );
};
};
if ($result =~ /^$host\./) {
return $self->get_reject(
"Mail from $host rejected because it $result");
}
}
my $hello = $self->qp->connection->hello_host;
return $self->get_reject( "Mail from HELO $hello rejected because it $result" );
return $self->get_reject(
"Mail from HELO $hello rejected because it $result");
}
}
}
@ -125,15 +131,14 @@ sub hook_mail {
sub populate_zones {
my $self = shift;
my %rhsbl_zones
= map { (split /\s+/, $_, 2)[0,1] }
$self->qp->config('rhsbl_zones');
my %rhsbl_zones =
map { (split /\s+/, $_, 2)[0, 1] } $self->qp->config('rhsbl_zones');
if ( ! keys %rhsbl_zones ) {
if (!keys %rhsbl_zones) {
$self->log(LOGINFO, 'pass, no zones');
return;
};
}
return %rhsbl_zones;
};
}

146
plugins/sender_permitted_from
View File

@ -68,19 +68,19 @@ use Qpsmtpd::Constants;
sub register {
my ($self, $qp, %args) = @_;
eval 'use Mail::SPF';
if ( $@ ) {
if ($@) {
warn "skip: plugin disabled, is Mail::SPF installed?\n";
$self->log(LOGERROR, "skip: plugin disabled, is Mail::SPF installed?");
return;
};
$self->{_args} = { %args };
if ( $self->{_args}{spf_deny} ) {
}
$self->{_args} = {%args};
if ($self->{_args}{spf_deny}) {
$self->{_args}{reject} = 3 if $self->{_args}{spf_deny} == 1;
$self->{_args}{reject} = 4 if $self->{_args}{spf_deny} == 2;
};
if ( ! $self->{_args}{reject} && $self->qp->config('spfbehavior') ) {
}
if (!$self->{_args}{reject} && $self->qp->config('spfbehavior')) {
$self->{_args}{reject} = $self->qp->config('spfbehavior');
};
}
$self->register_hook('mail', 'mail_handler');
$self->register_hook('data_post', 'data_post_handler');
}
@ -91,26 +91,27 @@ sub mail_handler {
return (DECLINED) if $self->is_immune();
my $format = $sender->format;
if ( $format eq '<>' || ! $sender->host || ! $sender->user ) {
$self->log( LOGINFO, "skip, null sender" );
if ($format eq '<>' || !$sender->host || !$sender->user) {
$self->log(LOGINFO, "skip, null sender");
return (DECLINED, "SPF - null sender");
};
}
if ( $self->qp->connection->relay_client ) {
$self->log( LOGINFO, "skip, relay_client" );
if ($self->qp->connection->relay_client) {
$self->log(LOGINFO, "skip, relay_client");
return (DECLINED, "SPF - relaying permitted");
};
}
if ( ! $self->{_args}{reject} ) {
$self->log( LOGINFO, "skip, reject disabled" );
if (!$self->{_args}{reject}) {
$self->log(LOGINFO, "skip, reject disabled");
return (DECLINED);
};
}
my $client_ip = $self->qp->connection->remote_ip;
my $from = $sender->user . '@' . lc($sender->host);
my $helo = $self->qp->connection->hello_host;
my $scope = $from ? 'mfrom' : 'helo';
my %req_params = ( versions => [1, 2], # optional
my %req_params = (
versions => [1, 2], # optional
scope => $scope,
ip_address => $client_ip,
);
@ -127,7 +128,7 @@ sub mail_handler {
my $spf_server = Mail::SPF::Server->new();
my $request = Mail::SPF::Request->new(%req_params);
my $result = $spf_server->process($request) or do {
$self->log( LOGINFO, "fail, no result" );
$self->log(LOGINFO, "fail, no result");
return DECLINED;
};
@ -137,49 +138,49 @@ sub mail_handler {
my $why = $result->local_explanation;
my $reject = $self->{_args}{reject};
if ( ! $code ) {
$self->log( LOGINFO, "fail, no response" );
if (!$code) {
$self->log(LOGINFO, "fail, no response");
return (DENYSOFT, "SPF - no response") if $reject >= 2;
return (DECLINED, "SPF - no response");
};
}
if ( ! $reject ) {
$self->log( LOGINFO, "fail, no reject policy ($code: $why)" );
return (DECLINED, "SPF - $code: $why")
};
if (!$reject) {
$self->log(LOGINFO, "fail, no reject policy ($code: $why)");
return (DECLINED, "SPF - $code: $why");
}
# SPF result codes: pass fail softfail neutral none error permerror temperror
# SPF result codes: pass fail softfail neutral none error permerror temperror
return $self->handle_code_none($reject, $why) if $code eq 'none';
if ( $code eq 'fail' ) {
$self->adjust_karma( -1 );
if ($code eq 'fail') {
$self->adjust_karma(-1);
return $self->handle_code_fail($reject, $why);
}
elsif ( $code eq 'softfail' ) {
$self->adjust_karma( -1 );
elsif ($code eq 'softfail') {
$self->adjust_karma(-1);
return $self->handle_code_softfail($reject, $why);
}
elsif ( $code eq 'pass' ) {
$self->adjust_karma( 1 );
elsif ($code eq 'pass') {
$self->adjust_karma(1);
$transaction->notes('spf_pass_host', lc $sender->host);
$self->log(LOGINFO, "pass, $code: $why" );
$self->log(LOGINFO, "pass, $code: $why");
return (DECLINED);
}
elsif ( $code eq 'neutral' ) {
$self->log(LOGINFO, "fail, $code, $why" );
elsif ($code eq 'neutral') {
$self->log(LOGINFO, "fail, $code, $why");
return (DENY, "SPF - $code: $why") if $reject >= 5;
}
elsif ( $code eq 'error' ) {
$self->log(LOGINFO, "fail, $code, $why" );
elsif ($code eq 'error') {
$self->log(LOGINFO, "fail, $code, $why");
return (DENY, "SPF - $code: $why") if $reject >= 6;
return (DENYSOFT, "SPF - $code: $why") if $reject > 3;
}
elsif ( $code eq 'permerror' ) {
$self->log(LOGINFO, "fail, $code, $why" );
elsif ($code eq 'permerror') {
$self->log(LOGINFO, "fail, $code, $why");
return (DENY, "SPF - $code: $why") if $reject >= 6;
return (DENYSOFT, "SPF - $code: $why") if $reject > 3;
}
elsif ( $code eq 'temperror' ) {
$self->log(LOGINFO, "fail, $code, $why" );
elsif ($code eq 'temperror') {
$self->log(LOGINFO, "fail, $code, $why");
return (DENYSOFT, "SPF - $code: $why") if $reject >= 2;
}
@ -188,60 +189,61 @@ sub mail_handler {
}
sub handle_code_none {
my ($self, $reject, $why ) = @_;
my ($self, $reject, $why) = @_;
if ( $reject >= 6 ) {
$self->log(LOGINFO, "fail, none, $why" );
if ($reject >= 6) {
$self->log(LOGINFO, "fail, none, $why");
return (DENY, "SPF - none: $why");
};
}
$self->log(LOGINFO, "pass, none, $why" );
$self->log(LOGINFO, "pass, none, $why");
return DECLINED;
};
}
sub handle_code_fail {
my ($self, $reject, $why ) = @_;
my ($self, $reject, $why) = @_;
if ( $reject >= 2 ) {
$self->log(LOGINFO, "fail, $why" );
if ($reject >= 2) {
$self->log(LOGINFO, "fail, $why");
return (DENY, "SPF - forgery: $why") if $reject >= 3;
return (DENYSOFT, "SPF - fail: $why")
};
return (DENYSOFT, "SPF - fail: $why");
}
$self->log(LOGINFO, "pass, fail tolerated, $why" );
$self->log(LOGINFO, "pass, fail tolerated, $why");
return DECLINED;
};
}
sub handle_code_softfail {
my ($self, $reject, $why ) = @_;
my ($self, $reject, $why) = @_;
if ( $reject >= 3 ) {
$self->log(LOGINFO, "fail, soft, $why" );
if ($reject >= 3) {
$self->log(LOGINFO, "fail, soft, $why");
return (DENY, "SPF - fail: $why") if $reject >= 4;
return (DENYSOFT, "SPF - fail: $why") if $reject >= 3;
};
}
$self->log(LOGINFO, "pass, softfail tolerated, $why" );
$self->log(LOGINFO, "pass, softfail tolerated, $why");
return DECLINED;
};
}
sub data_post_handler {
my ($self, $transaction) = @_;
my $result = $transaction->notes('spfquery') or return DECLINED;
# if we skipped processing in mail_handler, we should skip here too
# if we skipped processing in mail_handler, we should skip here too
return (DECLINED) if $self->is_immune();
$self->log(LOGDEBUG, "result was $result->code");
if ( ! $transaction->header ) {
if (!$transaction->header) {
$self->log(LOGERROR, "missing headers!");
return DECLINED;
};
}
$transaction->header->add('Received-SPF', $result->received_spf_header, 0);
# consider also adding SPF status to Authentication-Results header
# consider also adding SPF status to Authentication-Results header
return DECLINED;
}
@ -249,20 +251,20 @@ sub data_post_handler {
sub is_special_recipient {
my ($self, $rcpt) = @_;
if ( ! $rcpt ) {
if (!$rcpt) {
$self->log(LOGINFO, "skip: missing recipient");
return 1;
};
if ( ! $rcpt->user ) {
}
if (!$rcpt->user) {
$self->log(LOGINFO, "skip: missing user");
return 1;
};
}
# special addresses don't get SPF-tested.
if ( $rcpt->user =~ /^(?:postmaster|abuse|mailer-daemon|root)$/i ) {
$self->log(LOGINFO, "skip: special user (".$rcpt->user.")");
if ($rcpt->user =~ /^(?:postmaster|abuse|mailer-daemon|root)$/i) {
$self->log(LOGINFO, "skip: special user (" . $rcpt->user . ")");
return 1;
};
}
return;
};
}

207
plugins/spamassassin
View File

@ -153,17 +153,20 @@ use IO::Handle;
sub register {
my ($self, $qp, %args) = @_;
$self->log(LOGERROR, "Bad parameters for the spamassassin plugin") if @_ % 2;
$self->log(LOGERROR, "Bad parameters for the spamassassin plugin")
if @_ % 2;
$self->{_args} = { %args };
$self->{_args} = {%args};
# backwards compatibility with previous config syntax
if ( ! defined $self->{_args}{reject} && defined $self->{_args}{reject_threshold} ) {
if ( !defined $self->{_args}{reject}
&& defined $self->{_args}{reject_threshold})
{
$self->{_args}{reject} = $self->{_args}{reject_threshold};
};
if ( ! defined $self->{_args}{reject_type} ) {
}
if (!defined $self->{_args}{reject_type}) {
$self->{_args}{reject_type} = 'perm';
};
}
$self->register_hook('data_post', 'data_post_handler');
}
@ -173,24 +176,25 @@ sub data_post_handler {
return (DECLINED) if $self->is_immune();
if ( $transaction->data_size > 500_000 ) {
$self->log(LOGINFO, "skip: too large (".$transaction->data_size.")");
if ($transaction->data_size > 500_000) {
$self->log(LOGINFO,
"skip: too large (" . $transaction->data_size . ")");
return (DECLINED);
};
}
my $SPAMD = $self->connect_to_spamd() or return (DECLINED);
my $username = $self->select_spamd_username( $transaction );
my $username = $self->select_spamd_username($transaction);
my $message = $self->assemble_message($transaction);
my $length = length $message;
$self->print_to_spamd( $SPAMD, $message, $length, $username );
$self->print_to_spamd($SPAMD, $message, $length, $username);
shutdown($SPAMD, 1); # close our side of the socket (tell spamd we're done)
my $headers = $self->parse_spamd_response( $SPAMD ) or return (DECLINED);
my $headers = $self->parse_spamd_response($SPAMD) or return (DECLINED);
$self->insert_spam_headers( $transaction, $headers, $username );
$self->munge_subject( $transaction );
return $self->reject( $transaction );
};
$self->insert_spam_headers($transaction, $headers, $username);
$self->munge_subject($transaction);
return $self->reject($transaction);
}
sub select_spamd_username {
my ($self, $transaction) = @_;
@ -198,40 +202,41 @@ sub select_spamd_username {
my $username = $self->{_args}{spamd_user} || getpwuid($>);
my $recipient_count = scalar $transaction->recipients;
if ( $recipient_count > 1 ) {
if ($recipient_count > 1) {
$self->log(LOGDEBUG, "Message has $recipient_count recipients");
return $username;
};
}
if ( $username eq 'vpopmail' ) {
# use the recipients email address as username. This enables per-user SA prefs
if ($username eq 'vpopmail') {
# use the recipients email address as username. This enables per-user SA prefs
$username = ($transaction->recipients)[0]->address;
}
else {
$self->log(LOGDEBUG, "skipping per-user SA prefs");
};
}
return $username;
};
}
sub parse_spamd_response {
my ( $self, $SPAMD ) = @_;
my ($self, $SPAMD) = @_;
my $line0 = <$SPAMD>; # get the first protocol line
if ( $line0 !~ /EX_OK/ ) {
if ($line0 !~ /EX_OK/) {
$self->log(LOGERROR, "invalid response from spamd: $line0");
return;
};
}
my (%new_headers, $last_header);
while (<$SPAMD>) {
s/[\r\n]//g;
if ( m/^(X-Spam-.*?): (.*)?/ ) {
if (m/^(X-Spam-.*?): (.*)?/) {
$new_headers{$1} = $2 || '';
$last_header = $1;
next;
}
if ( $last_header && m/^(\s+.*)/ ) { # a folded line, append to last
if ($last_header && m/^(\s+.*)/) { # a folded line, append to last
$new_headers{$last_header} .= CRLF . "\t" . $1;
next;
}
@ -241,37 +246,41 @@ sub parse_spamd_response {
$self->log(LOGDEBUG, "finished reading from spamd");
return scalar keys %new_headers ? \%new_headers : undef;
};
}
sub insert_spam_headers {
my ( $self, $transaction, $new_headers, $username ) = @_;
my ($self, $transaction, $new_headers, $username) = @_;
if ( $self->{_args}{headers} && $self->{_args}{headers} eq 'none' ) {
my $r = $self->parse_spam_header( $new_headers->{'X-Spam-Status'} );
if ($self->{_args}{headers} && $self->{_args}{headers} eq 'none') {
my $r = $self->parse_spam_header($new_headers->{'X-Spam-Status'});
$transaction->notes('spamassassin', $r);
return;
};
}
my $recipient_count = scalar $transaction->recipients;
$self->_cleanup_spam_header($transaction, 'X-Spam-User'); # always clean up
if ( $recipient_count > 1 ) { # add for multiple recipients
$transaction->header->add('X-Spam-User', $username . ", $recipient_count recipients", 0);
};
if ($recipient_count > 1) { # add for multiple recipients
$transaction->header->add('X-Spam-User',
$username . ", $recipient_count recipients",
0);
}
foreach my $name ( keys %$new_headers ) {
next if $name eq 'X-Spam-Prev-Subject'; # might exist if SA rewrote subject
if ( $name eq 'X-Spam-Report' ) {
foreach my $name (keys %$new_headers) {
next
if $name eq 'X-Spam-Prev-Subject'; # might exist if SA rewrote subject
if ($name eq 'X-Spam-Report') {
next; # Mail::Header mangles this prefolded header
# $self->log(LOGDEBUG, $new_headers->{$name} );
};
if ( $name eq 'X-Spam-Status' ) {
$self->parse_spam_header( $new_headers->{$name} );
};
# $self->log(LOGDEBUG, $new_headers->{$name} );
}
if ($name eq 'X-Spam-Status') {
$self->parse_spam_header($new_headers->{$name});
}
$new_headers->{$name} =~ s/\015//; # hack for outlook
$self->_cleanup_spam_header($transaction, $name);
$transaction->header->add($name, $new_headers->{$name}, 0);
};
}
}
sub assemble_message {
@ -279,39 +288,40 @@ sub assemble_message {
$transaction->body_resetpos;
my $message = "X-Envelope-From: "
my $message =
"X-Envelope-From: "
. $transaction->sender->format . "\n"
. $transaction->header->as_string . "\n\n";
while (my $line = $transaction->body_getline) { $message .= $line; };
while (my $line = $transaction->body_getline) { $message .= $line; }
$message = join(CRLF, split/\n/, $message);
$message = join(CRLF, split /\n/, $message);
return $message . CRLF;
};
}
sub connect_to_spamd {
my $self = shift;
my $socket = $self->{_args}{spamd_socket};
my $SPAMD;
if ( $socket && $socket =~ /\// ) { # file path
$SPAMD = $self->connect_to_spamd_socket( $socket );
if ($socket && $socket =~ /\//) { # file path
$SPAMD = $self->connect_to_spamd_socket($socket);
}
else {
$SPAMD = $self->connect_to_spamd_tcpip( $socket );
};
$SPAMD = $self->connect_to_spamd_tcpip($socket);
}
return if ! $SPAMD;
return if !$SPAMD;
$SPAMD->autoflush(1);
return $SPAMD;
};
}
sub connect_to_spamd_socket {
my ( $self, $socket ) = @_;
my ($self, $socket) = @_;
if ( ! $socket || $socket !~ /^([\w\/.-]+)$/ ) { # Unix Domain Socket
if (!$socket || $socket !~ /^([\w\/.-]+)$/) { # Unix Domain Socket
$self->log(LOGERROR, "not a valid path");
return;
};
}
# Sanitize for use with taint mode
$socket =~ /^([\w\/.-]+)$/;
@ -321,7 +331,7 @@ sub connect_to_spamd_socket {
$self->log(LOGERROR, "Could not open socket: $!");
return;
};
my $paddr = sockaddr_un( $socket );
my $paddr = sockaddr_un($socket);
connect($SPAMD, $paddr) or do {
$self->log(LOGERROR, "Could not connect to spamd socket: $!");
@ -330,10 +340,10 @@ sub connect_to_spamd_socket {
$self->log(LOGDEBUG, "connected to spamd");
return $SPAMD;
};
}
sub connect_to_spamd_tcpip {
my ( $self, $socket ) = @_;
my ($self, $socket) = @_;
my $remote = 'localhost';
my $port = 783;
@ -342,11 +352,11 @@ sub connect_to_spamd_tcpip {
$remote = $1;
$port = $2;
}
if ($port =~ /\D/) { $port = getservbyname($port, 'tcp') };
if ( ! $port ) {
if ($port =~ /\D/) { $port = getservbyname($port, 'tcp') }
if (!$port) {
$self->log(LOGERROR, "No spamd port, check your spamd_socket config.");
return;
};
}
my $iaddr = inet_aton($remote) or do {
$self->log(LOGERROR, "Could not resolve host: $remote");
return;
@ -366,19 +376,20 @@ sub connect_to_spamd_tcpip {
$self->log(LOGDEBUG, "connected to spamd");
return $SPAMD;
};
}
sub print_to_spamd {
my ( $self, $SPAMD, $message, $length, $username ) = @_;
my ($self, $SPAMD, $message, $length, $username) = @_;
print $SPAMD "HEADERS SPAMC/1.4" . CRLF;
print $SPAMD "Content-length: $length" . CRLF;
print $SPAMD "User: $username" . CRLF;
print $SPAMD CRLF;
print $SPAMD $message or $self->log(LOGWARN, "Could not print to spamd: $!");
print $SPAMD $message
or $self->log(LOGWARN, "Could not print to spamd: $!");
$self->log(LOGDEBUG, "check_spam: finished sending to spamd");
};
}
sub reject {
my ($self, $transaction) = @_;
@ -388,31 +399,31 @@ sub reject {
return DECLINED;
};
my $score = $sa_results->{score};
if ( ! defined $score ) {
if (!defined $score) {
$self->log(LOGERROR, "error, error getting score");
return DECLINED;
};
}
my $ham_or_spam = $sa_results->{is_spam} eq 'Yes' ? 'Spam' : 'Ham';
if ( $ham_or_spam eq 'Spam' ) {
$self->adjust_karma( -1 );
};
if ($ham_or_spam eq 'Spam') {
$self->adjust_karma(-1);
}
my $status = "$ham_or_spam, $score";
my $learn = '';
my $al = $sa_results->{autolearn}; # subject to local SA learn scores
if ( $al ) {
$self->adjust_karma( 1 ) if $al eq 'ham';
$self->adjust_karma( -1 ) if $al eq 'spam';
$learn = "learn=". $al;
};
if ($al) {
$self->adjust_karma(1) if $al eq 'ham';
$self->adjust_karma(-1) if $al eq 'spam';
$learn = "learn=" . $al;
}
my $reject = $self->{_args}{reject} or do {
$self->log(LOGERROR, "error, reject disabled ($status, $learn)");
return DECLINED;
};
if ( $score < $reject ) {
if ( $ham_or_spam eq 'Spam' ) {
if ($score < $reject) {
if ($ham_or_spam eq 'Spam') {
$self->log(LOGINFO, "fail, $status < $reject, $learn");
return DECLINED;
}
@ -448,12 +459,12 @@ sub munge_subject {
sub get_spam_results {
my ($self, $transaction) = @_;
if ( defined $transaction->notes('spamassassin') ) {
if (defined $transaction->notes('spamassassin')) {
return $transaction->notes('spamassassin');
};
}
my $header = $transaction->header->get('X-Spam-Status') or return;
my $r = $self->parse_spam_header( $header );
my $r = $self->parse_spam_header($header);
$self->log(LOGDEBUG, "$r->{is_spam}, $r->{score}");
$transaction->notes('spamassassin', $r);
@ -464,44 +475,48 @@ sub get_spam_results {
sub parse_spam_header {
my ($self, $string) = @_;
# the X-Spam-Score header contents vary based on the settings in
# the spamassassin *.cf files. Rather than parse via regexp, split
# on the consistent whitespace and = delimiters. More reliable and
# likely faster.
# the X-Spam-Score header contents vary based on the settings in
# the spamassassin *.cf files. Rather than parse via regexp, split
# on the consistent whitespace and = delimiters. More reliable and
# likely faster.
my @parts = split(/\s+/, $string);
my $is_spam = shift @parts;
chomp @parts;
chop $is_spam; # remove trailing ,
my %r;
foreach ( @parts ) {
my ($key,$val) = split(/=/, $_);
foreach (@parts) {
my ($key, $val) = split(/=/, $_);
$r{$key} = $val;
}
$r{is_spam} = $is_spam;
# compatibility for SA versions < 3
if ( defined $r{hits} && ! defined $r{score} ) {
if (defined $r{hits} && !defined $r{score}) {
$r{score} = delete $r{hits};
};
}
return \%r;
};
}
sub _cleanup_spam_header {
my ($self, $transaction, $header_name) = @_;
my $action = 'rename';
if ( $self->{_args}->{leave_old_headers} ) {
if ($self->{_args}->{leave_old_headers}) {
$action = lc($self->{_args}->{leave_old_headers});
};
}
return unless $action eq 'drop' || $action eq 'rename';
my $old_header_name = $header_name;
$old_header_name = ($old_header_name =~ s/^X-//) ? "X-Old-$old_header_name" : "Old-$old_header_name";
$old_header_name =
($old_header_name =~ s/^X-//)
? "X-Old-$old_header_name"
: "Old-$old_header_name";
for my $header ( $transaction->header->get($header_name) ) {
$transaction->header->add($old_header_name, $header, 0) if $action eq 'rename';
for my $header ($transaction->header->get($header_name)) {
$transaction->header->add($old_header_name, $header, 0)
if $action eq 'rename';
$transaction->header->delete($header_name);
}
}

69
plugins/tls
View File

@ -67,8 +67,9 @@ sub init {
$cert ||= "$dir/qpsmtpd-server.crt";
$key ||= "$dir/qpsmtpd-server.key";
$ca ||= "$dir/qpsmtpd-ca.crt";
unless ( -f $cert && -f $key && -f $ca ) {
$self->log(LOGERROR, "Cannot locate cert/key! Run plugins/tls_cert to generate");
unless (-f $cert && -f $key && -f $ca) {
$self->log(LOGERROR,
"Cannot locate cert/key! Run plugins/tls_cert to generate");
return;
}
$self->tls_cert($cert);
@ -76,26 +77,29 @@ sub init {
$self->tls_ca($ca);
$self->tls_ciphers($self->qp->config('tls_ciphers') || 'HIGH');
$self->log(LOGDEBUG, "ciphers: ".$self->tls_ciphers);
$self->log(LOGDEBUG, "ciphers: " . $self->tls_ciphers);
local $^W; # this bit is very noisy...
my $ssl_ctx = IO::Socket::SSL::SSL_Context->new(
my $ssl_ctx =
IO::Socket::SSL::SSL_Context->new(
SSL_use_cert => 1,
SSL_cert_file => $self->tls_cert,
SSL_key_file => $self->tls_key,
SSL_ca_file => $self->tls_ca,
SSL_cipher_list => $self->tls_ciphers,
SSL_server => 1
) or die "Could not create SSL context: $!";
)
or die "Could not create SSL context: $!";
# now extract the password...
$self->ssl_context($ssl_ctx);
# Check for possible AUTH mechanisms
HOOK: foreach my $hook ( keys %{$qp->hooks} ) {
HOOK: foreach my $hook (keys %{$qp->hooks}) {
no strict 'refs';
if ( $hook =~ m/^auth-?(.+)?$/ ) {
if ( defined $1 ) {
if ($hook =~ m/^auth-?(.+)?$/) {
if (defined $1) {
my $hooksub = "hook_$hook";
$hooksub =~ s/\W/_/g;
*$hooksub = \&bad_ssl_hook;
@ -111,7 +115,8 @@ sub hook_ehlo {
my ($self, $transaction) = @_;
return DECLINED unless $self->can_do_tls;
return DECLINED if $self->connection->notes('tls_enabled');
return DENY, "Command refused due to lack of security" if $transaction->notes('ssl_failed');
return DENY, "Command refused due to lack of security"
if $transaction->notes('ssl_failed');
my $cap = $transaction->notes('capabilities') || [];
push @$cap, 'STARTTLS';
$transaction->notes('tls_enabled', 1);
@ -126,9 +131,10 @@ sub hook_unrecognized_command {
return DENY, "Syntax error (no parameters allowed)" if @args;
# OK, now we setup TLS
$self->qp->respond (220, "Go ahead with TLS");
$self->qp->respond(220, "Go ahead with TLS");
unless (_convert_to_ssl($self)) {
unless ( _convert_to_ssl($self) ) {
# SSL setup failed. Now we must respond to every command with 5XX
warn("TLS failed: $@\n");
$transaction->notes('ssl_failed', 1);
@ -145,7 +151,7 @@ sub hook_connect {
my $local_port = $self->qp->connection->local_port;
return DECLINED unless defined $local_port && $local_port == 465; # SMTPS
unless ( _convert_to_ssl($self) ) {
unless (_convert_to_ssl($self)) {
return (DENY_DISCONNECT, "Cannot establish SSL session");
}
$self->log(LOGWARN, "Connected via SMTPS");
@ -156,7 +162,8 @@ sub hook_post_connection {
my ($self, $transaction) = @_;
my $tls_socket = $self->connection->notes('tls_socket');
if (defined $tls_socket && $self->connection->notes('tls_socket_is_duped')) {
if (defined $tls_socket && $self->connection->notes('tls_socket_is_duped'))
{
$tls_socket->close;
$self->connection->notes('tls_socket', undef);
$self->connection->notes('tls_socked_is_duped', 0);
@ -173,7 +180,8 @@ sub _convert_to_ssl {
}
eval {
my $tlssocket = IO::Socket::SSL->new_from_fd(
my $tlssocket =
IO::Socket::SSL->new_from_fd(
fileno(STDIN), '+>',
SSL_use_cert => 1,
SSL_cert_file => $self->tls_cert,
@ -182,7 +190,8 @@ sub _convert_to_ssl {
SSL_cipher_list => $self->tls_ciphers,
SSL_server => 1,
SSL_reuse_ctx => $self->ssl_context,
) or die "Could not create SSL socket: $!";
)
or die "Could not create SSL socket: $!";
# Clone connection object (without data received from client)
$self->qp->connection($self->connection->clone());
@ -193,14 +202,14 @@ sub _convert_to_ssl {
};
if ($@) {
return 0;
};
}
return 1;
}
sub _convert_to_ssl_async {
my ($self) = @_;
my $upgrader = $self->connection
->notes( 'tls_upgrader', UpgradeClientSSL->new($self) );
my $upgrader =
$self->connection->notes('tls_upgrader', UpgradeClientSSL->new($self));
$upgrader->upgrade_socket();
return 1;
}
@ -243,7 +252,8 @@ sub ssl_context {
# Fulfill RFC 2487 secn 5.1
sub bad_ssl_hook {
my ($self, $transaction) = @_;
return DENY, "Command refused due to lack of security" if $transaction->notes('ssl_failed');
return DENY, "Command refused due to lack of security"
if $transaction->notes('ssl_failed');
return DECLINED;
}
*hook_helo = *hook_data = *hook_rcpt = *hook_mail = \&bad_ssl_hook;
@ -272,10 +282,11 @@ sub new {
sub upgrade_socket {
my UpgradeClientSSL $self = shift;
unless ( $self->{_ssl_started} ) {
unless ($self->{_ssl_started}) {
$self->{_stashed_qp}->clear_data();
IO::Socket::SSL->start_SSL(
$self->{_stashed_qp}->{sock}, {
$self->{_stashed_qp}->{sock},
{
SSL_use_cert => 1,
SSL_cert_file => $self->{_stashed_plugin}->tls_cert,
SSL_key_file => $self->{_stashed_plugin}->tls_key,
@ -285,7 +296,8 @@ sub upgrade_socket {
SSL_server => 1,
SSL_reuse_ctx => $self->{_stashed_plugin}->ssl_context,
}
) or die "Could not upgrade socket to SSL: $!";
)
or die "Could not upgrade socket to SSL: $!";
$self->{_ssl_started} = 1;
}
@ -296,12 +308,12 @@ sub event_read {
my UpgradeClientSSL $self = shift;
my $qp = shift;
$qp->watch_read( 0 );
$qp->watch_read(0);
my $sock = $qp->{sock}->accept_SSL;
if (defined $sock) {
$qp->connection( $qp->connection->clone );
$qp->connection($qp->connection->clone);
$qp->reset_transaction;
$self->connection->notes('tls_socket', $sock);
$self->connection->notes('tls_enabled', 1);
@ -314,12 +326,15 @@ sub event_read {
$qp->set_reader_object($self);
if ($SSL_ERROR == SSL_WANT_READ) {
$qp->watch_read(1);
} elsif ($SSL_ERROR == SSL_WANT_WRITE) {
}
elsif ($SSL_ERROR == SSL_WANT_WRITE) {
$qp->watch_write(1);
} else {
}
else {
$qp->disconnect();
}
} else {
}
else {
$qp->disconnect();
}
}

149
plugins/uribl
View File

@ -133,7 +133,7 @@ my %strict_twolevel_cctlds = (
'lv' => 1,
'sg' => 1,
'za' => 1,
);
);
# async version: OK
sub init {
@ -141,6 +141,7 @@ sub init {
$self->{action} = $args{action} || 'add-header';
$self->{timeout} = $args{timeout} || 30;
# scan-headers was the originally documented name for this option, while
# check-headers actually implements it, so tolerate both.
$self->{check_headers} = $args{'check-headers'} || $args{'scan-headers'};
@ -152,7 +153,7 @@ sub init {
for (@zones) {
chomp;
next if !$_ or /^\s*#/;
my @z = split (/\s+/, $_);
my @z = split(/\s+/, $_);
next unless $z[0];
my $mask = 0;
@ -178,9 +179,7 @@ sub init {
keys %{$self->{uribl_zones}} or return 0;
my @whitelist = $self->qp->config('uribl_whitelist_domains');
$self->{whitelist_zones} = {
( map { ($_ => 1) } @whitelist )
};
$self->{whitelist_zones} = {(map { ($_ => 1) } @whitelist)};
$self->init_resolver;
}
@ -214,10 +213,12 @@ sub send_query {
$self->{socket_select}->add($s);
$self->{socket_idx}->{"$s"} = $index;
$count++;
} else {
}
else {
$self->log(LOGERROR,
"Couldn't open socket for A record '$name.$z': ".
($self->{resolver}->errorstring || 'unknown error'));
"Couldn't open socket for A record '$name.$z': "
. ($self->{resolver}->errorstring || 'unknown error')
);
}
$s1 = $self->{resolver}->bgsend("$name.$z", 'TXT');
@ -226,10 +227,12 @@ sub send_query {
$self->{socket_select}->add($s1);
$self->{socket_idx}->{"$s1"} = $index;
$count++;
} else {
}
else {
$self->log(LOGERROR,
"Couldn't open socket for TXT record '$name.$z': ".
($self->{resolver}->errorstring || 'unknown error'));
"Couldn't open socket for TXT record '$name.$z': "
. ($self->{resolver}->errorstring || 'unknown error')
);
}
$self->{sockets}->{$z}->{$name} = {};
@ -253,9 +256,8 @@ sub evaluate {
my $mask = $self->{uribl_zones}->{$zone}->{mask} || $self->{mask};
$a =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/ or return undef;
my $v = (($1 & 0xff) << 24) |
(($2 & 0xff) << 16) |
(($3 & 0xff) << 8) |
my $v =
(($1 & 0xff) << 24) | (($2 & 0xff) << 16) | (($3 & 0xff) << 8) |
($4 & 0xff);
return ($v & $mask);
}
@ -270,6 +272,7 @@ sub lookup_start {
my @qp_continuations;
$transaction->body_resetpos;
# if we're not looking for URIs in the headers, read past that point
# before starting to actually look for any
while (!$self->{check_headers} and $l = $transaction->body_getline) {
@ -281,25 +284,31 @@ sub lookup_start {
if ($l =~ /(.*)=$/) {
push @qp_continuations, $1;
} elsif (@qp_continuations) {
}
elsif (@qp_continuations) {
$l = join('', @qp_continuations, $l);
@qp_continuations = ();
}
# Undo URI escape munging
$l =~ s/[=%]([0-9A-Fa-f]{2,2})/chr(hex($1))/ge;
# Undo HTML entity munging (e.g. in parameterized redirects)
$l =~ s/&#(\d{2,3});?/chr($1)/ge;
# Dodge inserted-semicolon munging
$l =~ tr/;//d;
while ($l =~ m{
while (
$l =~ m{
\w{3,16}:/+ # protocol
(?:\S+@)? # user/pass
(\d{7,}) # raw-numeric IP
(?::\d*)?([/?\s]|$) # port, slash
# or EOL
}gx) {
}gx
)
{
my @octets = (
(($1 >> 24) & 0xff),
(($1 >> 16) & 0xff),
@ -308,24 +317,29 @@ sub lookup_start {
);
my $fwd = join('.', @octets);
my $rev = join('.', reverse @octets);
$self->log(LOGDEBUG, "uribl: matched pure-integer ipaddr $1 ($fwd)");
$self->log(LOGDEBUG,
"uribl: matched pure-integer ipaddr $1 ($fwd)");
unless (exists $pending{$rev}) {
$queries += $start_query->($self, $rev);
$pending{$rev} = 1;
}
}
while ($l =~ m{
while (
$l =~ m{
\w{3,16}:/+ # protocol
(?:\S+@)? # user/pass
(\d+|0[xX][0-9A-Fa-f]+)\. # IP address
(\d+|0[xX][0-9A-Fa-f]+)\.
(\d+|0[xX][0-9A-Fa-f]+)\.
(\d+|0[xX][0-9A-Fa-f]+)
}gx) {
my @octets = ($1,$2,$3,$4);
}gx
)
{
my @octets = ($1, $2, $3, $4);
# return any octal/hex octets in the IP addr back
# to decimal form (e.g. http://0x7f.0.0.00001)
for (0..$#octets) {
for (0 .. $#octets) {
$octets[$_] =~ s/^0([0-7]+)$/oct($1)/e;
$octets[$_] =~ s/^0x([0-9a-fA-F]+)$/hex($1)/e;
}
@ -337,7 +351,8 @@ sub lookup_start {
$pending{$rev} = 1;
}
}
while ($l =~ m{
while (
$l =~ m{
((?:www\.)? # www?
[a-zA-Z0-9][a-zA-Z0-9\-.]+\. # hostname
(?:aero|arpa|asia|biz|cat|com|coop| # tld
@ -345,22 +360,33 @@ sub lookup_start {
museum|name|net|org|pro|tel|travel|
[a-zA-Z]{2})
)(?!\w)
}gix) {
}gix
)
{
my $host = lc $1;
my @host_domains = split /\./, $host;
$self->log(LOGDEBUG, "uribl: matched 'www.' hostname $host");
my $cutoff = exists
$strict_twolevel_cctlds{$host_domains[$#host_domains]} ? 3 : 2;
if (exists $self->{whitelist_zones}->{
my $cutoff =
exists $strict_twolevel_cctlds{$host_domains[$#host_domains]}
? 3
: 2;
if (
exists $self->{whitelist_zones}->{
join('.',
@host_domains[($#host_domains-$cutoff+1)..$#host_domains])}) {
@host_domains[($#host_domains - $cutoff + 1)
.. $#host_domains])
}
)
{
$self->log(LOGINFO, "Skipping whitelist URI domain '$host'");
} else {
}
else {
while (@host_domains >= $cutoff) {
my $subhost = join('.', @host_domains);
unless (exists $pending{$subhost}) {
$self->log(LOGINFO, "URIBL: checking sub-host $subhost");
$self->log(LOGINFO,
"URIBL: checking sub-host $subhost");
$queries += $start_query->($self, $subhost);
$pending{$subhost} = 1;
}
@ -368,7 +394,8 @@ sub lookup_start {
}
}
}
while ($l =~ m{
while (
$l =~ m{
\w{3,16}:/+ # protocol
(?:\S+@)? # user/pass
(
@ -378,22 +405,30 @@ sub lookup_start {
museum|name|net|org|pro|tel|travel|
[a-zA-Z]{2})
)
}gix) {
}gix
)
{
my $host = lc $1;
my @host_domains = split /\./, $host;
$self->log(LOGDEBUG, "uribl: matched full URI hostname $host");
my $cutoff = exists
$strict_twolevel_cctlds{$host_domains[$#host_domains]} ? 3 : 2;
if (exists $self->{whitelist_zones}->{
join('.', @host_domains[($cutoff-1)..$#host_domains])}) {
my $cutoff =
exists $strict_twolevel_cctlds{$host_domains[$#host_domains]}
? 3
: 2;
if (
exists $self->{whitelist_zones}
->{join('.', @host_domains[($cutoff - 1) .. $#host_domains])})
{
$self->log(LOGINFO, "Skipping whitelist URI domain '$host'");
} else {
}
else {
while (@host_domains >= $cutoff) {
my $subhost = join('.', @host_domains);
unless (exists $pending{$subhost}) {
$self->log(LOGINFO, "URIBL: checking sub-host $subhost");
$self->log(LOGINFO,
"URIBL: checking sub-host $subhost");
$queries += $start_query->($self, $subhost);
$pending{$subhost} = 1;
}
@ -423,8 +458,10 @@ sub collect_results {
SOCK: for my $s (@ready) {
$self->{socket_select}->remove($s);
my $r = $self->{socket_idx}->{"$s"} or next SOCK;
$self->log(LOGDEBUG, "from $r: socket $s: ".
join(', ', map { "$_=$r->{$_}" } keys %{$r}));
$self->log(LOGDEBUG,
"from $r: socket $s: "
. join(', ', map { "$_=$r->{$_}" } keys %{$r})
);
my $zone = $r->{zone};
my $name = $r->{name};
my $h = $self->{sockets}->{$zone}->{$name};
@ -438,8 +475,7 @@ sub collect_results {
elsif ($a->type eq 'A') {
$h->{a} = $a->address;
if ($self->evaluate($zone, $h->{a})) {
$self->log(LOGDEBUG,
"match in $zone");
$self->log(LOGDEBUG, "match in $zone");
$h->{match} = 1;
$matches++;
}
@ -451,20 +487,22 @@ sub collect_results {
}
my $elapsed = time - $start_time;
$self->log(LOGINFO,
sprintf("$complete lookup%s finished in %.2f sec (%d match%s)",
sprintf(
"$complete lookup%s finished in %.2f sec (%d match%s)",
$complete == 1 ? '' : 's', $elapsed,
$matches, $matches == 1 ? '' : 'es'));
$matches, $matches == 1 ? '' : 'es'
)
);
my @matches = ();
for my $z (keys %{$self->{sockets}}) {
for my $n (keys %{$self->{sockets}->{$z}}) {
my $h = $self->{sockets}->{$z}->{$n};
next unless $h->{match};
push @matches, {
action =>
$self->{uribl_zones}->{$z}->{action},
desc => "$n in $z: ".
($h->{txt} || $h->{a}),
push @matches,
{
action => $self->{uribl_zones}->{$z}->{action},
desc => "$n in $z: " . ($h->{txt} || $h->{a}),
};
}
}
@ -480,10 +518,13 @@ sub data_handler {
return (DECLINED) if $self->is_immune();
my $queries = $self->lookup_start($transaction, sub {
my $queries = $self->lookup_start(
$transaction,
sub {
my ($self, $name) = @_;
return $self->send_query($name);
});
}
);
unless ($queries) {
$self->log(LOGINFO, "pass, No URIs found in mail");
@ -495,9 +536,11 @@ sub data_handler {
$self->log(LOGWARN, $_->{desc});
if ($_->{action} eq 'add-header') {
$transaction->header->add('X-URIBL-Match', $_->{desc}, 0);
} elsif ($_->{action} eq 'deny') {
}
elsif ($_->{action} eq 'deny') {
return (DENY, $_->{desc});
} elsif ($_->{action} eq 'denysoft') {
}
elsif ($_->{action} eq 'denysoft') {
return (DENYSOFT, $_->{desc});
}
}

48
plugins/virus/aveclient
View File

@ -1,4 +1,5 @@
#!perl -w
=head1 NAME
aveclient
@ -111,10 +112,16 @@ sub register {
# Untaint client location
# socket will be tested during scan (response-code)
if (exists $self->{_avclient_bin} && $self->{_avclient_bin} =~ /^(\/[\/\-\_\.a-z0-9A-Z]*)$/) {
if (exists $self->{_avclient_bin}
&& $self->{_avclient_bin} =~ /^(\/[\/\-\_\.a-z0-9A-Z]*)$/)
{
$self->{_avclient_bin} = $1;
} else {
$self->log(LOGALERT, "FATAL ERROR: No binary aveclient found: '".$self->{_avclient_bin}."'");
}
else {
$self->log(LOGALERT,
"FATAL ERROR: No binary aveclient found: '"
. $self->{_avclient_bin} . "'"
);
exit 3;
}
}
@ -136,7 +143,10 @@ sub hook_data_post {
seek($temp_fh, 0, 0);
# Now scan this file
my $cmd = $self->{_avclient_bin}." -p ".$self->{_avdaemon_sock}." -s $filename 2>&1";
my $cmd =
$self->{_avclient_bin} . " -p "
. $self->{_avdaemon_sock}
. " -s $filename 2>&1";
my @output = `$cmd`;
chomp(@output);
@ -160,21 +170,35 @@ sub hook_data_post {
# ok a somewhat virus was found
shift @output;
$description = "REPORT: ".join(", ",@output);
$description = "REPORT: " . join(", ", @output);
$self->log(LOGWARN, "Virus found! ($description)");
# we don't want to be disturbed be these, so block mail and DENY connection
return(DENY, "Virus found: $description");
return (DENY, "Virus found: $description");
} else {
$self->log(LOGCRIT, "aveserver: no viruses have been detected.") if($result =~ /^0$/);
$self->log(LOGCRIT, "aveserver: system error launching the application (file not found, unable to read the file).") if($result =~ /^0$/);
$self->log(LOGCRIT, "aveserver: some of the required parameters are missing from the command line.") if($result =~ /^9$/);
return(DENY, "Unable to scan for virus, please contact admin of ".$self->qp->config("me").", if you feel this is an error!") if $self->{_blockonerror};
}
else {
$self->log(LOGCRIT, "aveserver: no viruses have been detected.")
if ($result =~ /^0$/);
$self->log(LOGCRIT,
"aveserver: system error launching the application (file not found, unable to read the file)."
)
if ($result =~ /^0$/);
$self->log(LOGCRIT,
"aveserver: some of the required parameters are missing from the command line."
)
if ($result =~ /^9$/);
return (DENY,
"Unable to scan for virus, please contact admin of "
. $self->qp->config("me")
. ", if you feel this is an error!"
)
if $self->{_blockonerror};
}
}
$self->log(LOGINFO, "kavscanner results: $description");
$transaction->header->add('X-Virus-Checked', 'Checked by Kaspersky on '.$self->qp->config("me"));
$transaction->header->add('X-Virus-Checked',
'Checked by Kaspersky on ' . $self->qp->config("me"));
return (DECLINED);
}

24
plugins/virus/bitdefender
View File

@ -67,10 +67,10 @@ use File::Path;
use Qpsmtpd::Constants;
sub register {
my ( $self, $qp, @args ) = @_;
my ($self, $qp, @args) = @_;
while (@args) {
$self->{"_bitd"}->{ pop @args } = pop @args;
$self->{"_bitd"}->{pop @args} = pop @args;
}
$self->{"_bitd"}->{"bitdefender_location"} ||= "/opt/bdc/bdc";
$self->{"_bitd"}->{"deny_viruses"} ||= "yes";
@ -79,14 +79,14 @@ sub register {
}
sub hook_data_post {
my ( $self, $transaction ) = @_;
my ($self, $transaction) = @_;
if ( $transaction->data_size > $self->{"_bitd"}->{"max_size"} ) {
$self->log( LOGWARN,
if ($transaction->data_size > $self->{"_bitd"}->{"max_size"}) {
$self->log(LOGWARN,
'Mail too large to scan ('
. $transaction->data_size . " vs "
. $self->{"_bitd"}->{"max_size"}
. ")" );
. $self->{"_bitd"}->{"max_size"} . ")"
);
return (DECLINED);
}
@ -94,9 +94,9 @@ sub hook_data_post {
my $content_type = $transaction->header->get('Content-Type');
$content_type =~ s/\s/ /g if defined $content_type;
unless ( $content_type
&& $content_type =~ m!\bmultipart/.*\bboundary="?([^"]+)!i )
&& $content_type =~ m!\bmultipart/.*\bboundary="?([^"]+)!i)
{
$self->log( LOGERROR, "non-multipart mail - skipping" );
$self->log(LOGERROR, "non-multipart mail - skipping");
return DECLINED;
}
@ -121,9 +121,9 @@ sub hook_data_post {
close $bdc;
if ($output) {
$self->log( LOGINFO, "Virus(es) found: $output" );
if ( $self->{"_bitd"}->{"deny_viruses"} eq "yes" ) {
return ( DENY, "Virus Found: $output" );
$self->log(LOGINFO, "Virus(es) found: $output");
if ($self->{"_bitd"}->{"deny_viruses"} eq "yes") {
return (DENY, "Virus Found: $output");
}
}

22
plugins/virus/clamav
View File

@ -169,8 +169,11 @@ sub hook_data_post {
my ($self, $transaction) = @_;
if ($transaction->data_size > $self->{_max_size}) {
$self->log(LOGWARN, 'Mail too large to scan ('.
$transaction->data_size . " vs $self->{_max_size})" );
$self->log(LOGWARN,
'Mail too large to scan ('
. $transaction->data_size
. " vs $self->{_max_size})"
);
return (DECLINED);
}
@ -180,17 +183,19 @@ sub hook_data_post {
return DECLINED;
}
my $mode = (stat($self->{_spool_dir}))[2];
if ( $mode & 07077 ) { # must be sharing spool directory with external app
if ($mode & 07077) { # must be sharing spool directory with external app
$self->log(LOGWARN,
"Changing permissions on file to permit scanner access");
chmod $mode, $filename;
}
# Now do the actual scanning!
my $cmd = $self->{_clamscan_loc}
my $cmd =
$self->{_clamscan_loc}
. " --stdout "
. $self->{_back_compat}
. " --config-file=" . $self->{_clamd_conf}
. " --config-file="
. $self->{_clamd_conf}
. " --no-summary $filename 2>&1";
$self->log(LOGDEBUG, "Running: $cmd");
my $output = `$cmd`;
@ -214,7 +219,8 @@ sub hook_data_post {
if ($self->{_action} eq 'add-header') {
$transaction->header->add('X-Virus-Found', 'Yes');
$transaction->header->add('X-Virus-Details', $output);
} else {
}
else {
return (DENY, "Virus Found: $output");
}
}
@ -223,8 +229,8 @@ sub hook_data_post {
return (DENYSOFT) if (!$self->{_declined_on_fail});
}
else {
$transaction->header->add( 'X-Virus-Checked',
"Checked by ClamAV on " . $self->qp->config("me") );
$transaction->header->add('X-Virus-Checked',
"Checked by ClamAV on " . $self->qp->config("me"));
}
return (DECLINED);
}

150
plugins/virus/clamdscan
View File

@ -109,17 +109,17 @@ use warnings;
use Qpsmtpd::Constants;
sub register {
my ( $self, $qp ) = shift, shift;
my ($self, $qp) = shift, shift;
$self->log(LOGERROR, "Bad parameters for the clamdscan plugin") if @_ % 2;
$self->{'_args'} = { @_ };
$self->{'_args'} = {@_};
eval 'use ClamAV::Client';
if ( $@ ) {
if ($@) {
warn "unable to load ClamAV::Client\n";
$self->log(LOGERROR, "unable to load ClamAV::Client");
return;
};
}
# Set some sensible defaults
$self->{'_args'}{'deny_viruses'} ||= 'yes';
@ -127,73 +127,75 @@ sub register {
$self->{'_args'}{'scan_all'} ||= 0;
for my $setting ('deny_viruses', 'defer_on_error') {
next unless $self->{'_args'}{$setting};
if ( lc $self->{'_args'}{$setting} eq 'no' ) {
if (lc $self->{'_args'}{$setting} eq 'no') {
$self->{'_args'}{$setting} = 0;
};
}
}
$self->register_hook('data_post', 'data_post_handler');
}
sub data_post_handler {
my ( $self, $transaction ) = @_;
my ($self, $transaction) = @_;
my $filename = $self->get_filename( $transaction ) or return DECLINED;
my $filename = $self->get_filename($transaction) or return DECLINED;
if ( $self->connection->notes('naughty') ) {
$self->log( LOGINFO, "skip, naughty" );
if ($self->connection->notes('naughty')) {
$self->log(LOGINFO, "skip, naughty");
return (DECLINED);
};
return (DECLINED) if $self->is_too_big( $transaction );
return (DECLINED) if $self->is_not_multipart( $transaction );
}
return (DECLINED) if $self->is_too_big($transaction);
return (DECLINED) if $self->is_not_multipart($transaction);
$self->set_permission( $filename ) or return DECLINED;
$self->set_permission($filename) or return DECLINED;
my $clamd = $self->get_clamd()
or return $self->err_and_return( "Cannot instantiate ClamAV::Client" );
or return $self->err_and_return("Cannot instantiate ClamAV::Client");
unless ( eval { $clamd->ping() } ) {
return $self->err_and_return( "Cannot ping clamd server: $@" );
unless (eval { $clamd->ping() }) {
return $self->err_and_return("Cannot ping clamd server: $@");
}
my ($version) = split(/\//, $clamd->version);
$version ||= 'ClamAV';
my ( $path, $found ) = eval { $clamd->scan_path( $filename ) };
my ($path, $found) = eval { $clamd->scan_path($filename) };
if ($@) {
return $self->err_and_return( "Error scanning mail: $@" );
};
if ( $found ) {
$self->log( LOGNOTICE, "fail, found virus $found" );
$self->connection->notes('naughty', 1); # see plugins/naughty
$self->adjust_karma( -1 );
if ( $self->{_args}{deny_viruses} ) {
return ( DENY, "Virus found: $found" );
return $self->err_and_return("Error scanning mail: $@");
}
$transaction->header->add( 'X-Virus-Found', 'Yes', 0 );
$transaction->header->add( 'X-Virus-Details', $found, 0 );
if ($found) {
$self->log(LOGNOTICE, "fail, found virus $found");
$self->connection->notes('naughty', 1); # see plugins/naughty
$self->adjust_karma(-1);
if ($self->{_args}{deny_viruses}) {
return (DENY, "Virus found: $found");
}
$transaction->header->add('X-Virus-Found', 'Yes', 0);
$transaction->header->add('X-Virus-Details', $found, 0);
return (DECLINED);
}
$self->log( LOGINFO, "pass, clean");
$transaction->header->add( 'X-Virus-Found', 'No', 0 );
$transaction->header->add( 'X-Virus-Checked', "by $version on " . $self->qp->config('me'), 0);
$self->log(LOGINFO, "pass, clean");
$transaction->header->add('X-Virus-Found', 'No', 0);
$transaction->header->add('X-Virus-Checked',
"by $version on " . $self->qp->config('me'), 0);
return (DECLINED);
}
sub err_and_return {
my $self = shift;
my $message = shift;
if ( $message ) {
$self->log( LOGERROR, $message );
};
return (DENYSOFT, "Unable to scan for viruses") if $self->{_args}{defer_on_error};
if ($message) {
$self->log(LOGERROR, $message);
}
return (DENYSOFT, "Unable to scan for viruses")
if $self->{_args}{defer_on_error};
return (DECLINED, "skip");
};
}
sub get_filename {
my $self = shift;
@ -201,25 +203,25 @@ sub get_filename {
my $filename = $transaction->body_filename;
if ( ! $filename ) {
$self->log( LOGWARN, "Cannot process due to lack of filename" );
if (!$filename) {
$self->log(LOGWARN, "Cannot process due to lack of filename");
return;
}
if ( ! -f $filename ) {
$self->log( LOGERROR, "spool file missing! Attempting to respool" );
if (!-f $filename) {
$self->log(LOGERROR, "spool file missing! Attempting to respool");
$transaction->body_spool;
$filename = $transaction->body_filename;
if ( ! -f $filename ) {
$self->log( LOGERROR, "skip: failed spool to $filename! Giving up" );
if (!-f $filename) {
$self->log(LOGERROR, "skip: failed spool to $filename! Giving up");
return;
};
}
my $size = (stat($filename))[7];
$self->log( LOGDEBUG, "Spooled $size bytes to $filename" );
$self->log(LOGDEBUG, "Spooled $size bytes to $filename");
}
return $filename;
};
}
sub set_permission {
my ($self, $filename) = @_;
@ -227,26 +229,28 @@ sub set_permission {
# the spool directory must be readable and executable by the scanner;
# this generally means either group or world exec; if
# neither of these is set, issue a warning but try to proceed anyway
my $dir_mode = ( stat( $self->spool_dir() ) )[2];
$self->log( LOGDEBUG, "spool dir mode: $dir_mode" );
my $dir_mode = (stat($self->spool_dir()))[2];
$self->log(LOGDEBUG, "spool dir mode: $dir_mode");
if ($dir_mode & 0010 || $dir_mode & 0001) {
if ( $dir_mode & 0010 || $dir_mode & 0001 ) {
# match the spool file mode with the mode of the directory -- add
# the read bit for group, world, or both, depending on what the
# spool dir had, and strip all other bits, especially the sticky bit
my $fmode = ($dir_mode & 0044) |
($dir_mode & 0010 ? 0040 : 0) |
my $fmode =
($dir_mode & 0044) | ($dir_mode & 0010 ? 0040 : 0) |
($dir_mode & 0001 ? 0004 : 0);
unless ( chmod $fmode, $filename ) {
$self->log( LOGERROR, "chmod: $filename: $!" );
unless (chmod $fmode, $filename) {
$self->log(LOGERROR, "chmod: $filename: $!");
return;
}
return 1;
}
$self->log( LOGWARN, "spool directory permissions do not permit scanner access" );
$self->log(LOGWARN,
"spool directory permissions do not permit scanner access");
return 1;
};
}
sub get_clamd {
my $self = shift;
@ -254,34 +258,34 @@ sub get_clamd {
my $port = $self->{'_args'}{'clamd_port'};
my $host = $self->{'_args'}{'clamd_host'} || 'localhost';
if ( $port && $port =~ /^(\d+)/ ) {
return new ClamAV::Client( socket_host => $host, socket_port => $1 );
};
if ($port && $port =~ /^(\d+)/) {
return new ClamAV::Client(socket_host => $host, socket_port => $1);
}
my $socket = $self->{'_args'}{'clamd_socket'};
if ( $socket ) {
if ( $socket =~ /([\w\/.]+)/ ) {
return new ClamAV::Client( socket_name => $1 );
if ($socket) {
if ($socket =~ /([\w\/.]+)/) {
return new ClamAV::Client(socket_name => $1);
}
$self->log( LOGERROR, "invalid characters in socket name" );
$self->log(LOGERROR, "invalid characters in socket name");
}
return new ClamAV::Client;
};
}
sub is_too_big {
my $self = shift;
my $transaction = shift || $self->qp->transaction;
my $size = $transaction->data_size;
if ( $size > $self->{_args}{max_size} * 1024 ) {
$self->log( LOGINFO, "skip, too big ($size)" );
if ($size > $self->{_args}{max_size} * 1024) {
$self->log(LOGINFO, "skip, too big ($size)");
return 1;
}
$self->log( LOGDEBUG, "data_size, $size" );
$self->log(LOGDEBUG, "data_size, $size");
return;
};
}
sub is_not_multipart {
my $self = shift;
@ -289,15 +293,15 @@ sub is_not_multipart {
return if $self->{'_args'}{'scan_all'};
return 1 if ! $transaction->header;
return 1 if !$transaction->header;
# Ignore non-multipart emails
my $content_type = $transaction->header->get('Content-Type') or return 1;
$content_type =~ s/\s/ /g;
if ( $content_type !~ m!\bmultipart/.*\bboundary="?([^"]+)!i ) {
$self->log( LOGNOTICE, "skip, not multipart" );
if ($content_type !~ m!\bmultipart/.*\bboundary="?([^"]+)!i) {
$self->log(LOGNOTICE, "skip, not multipart");
return 1;
}
return;
};
}

32
plugins/virus/hbedv
View File

@ -60,11 +60,14 @@ sub register {
my %args = @args;
if (!exists $args{hbedvscanner}) {
$self->{_hbedvscan_loc} = "/usr/bin/antivir";
} else {
}
else {
if ($args{hbedvscanner} =~ /^(\/[\/\-\_\.a-z0-9A-Z]*)$/) {
$self->{_hbedvscan_loc} = $1;
} else {
$self->log(LOGERROR, "FATAL ERROR: Unexpected characters in hbedvscanner argument");
}
else {
$self->log(LOGERROR,
"FATAL ERROR: Unexpected characters in hbedvscanner argument");
exit 3;
}
}
@ -80,7 +83,8 @@ sub hook_data_post {
}
# Now do the actual scanning!
my $cmd = $self->{_hbedvscan_loc}." --archive-max-recursion=50 --alltypes -z -noboot -nombr -rs $filename 2>&1";
my $cmd = $self->{_hbedvscan_loc}
. " --archive-max-recursion=50 --alltypes -z -noboot -nombr -rs $filename 2>&1";
$self->log(LOGDEBUG, "Running: $cmd");
my @output = `$cmd`;
@ -90,12 +94,14 @@ sub hook_data_post {
chomp(@output);
my @virii = ();
foreach my $line (@output) {
next unless $line =~ /^ALERT: \[([^\]]+)\s+(\w+)?\]/; # $2 =~ /^(virus|worm)$/;
next
unless $line =~
/^ALERT: \[([^\]]+)\s+(\w+)?\]/; # $2 =~ /^(virus|worm)$/;
push @virii, $1;
}
@virii = unique(@virii);
$self->log(LOGDEBUG, "results: ".join("//",@output));
$self->log(LOGDEBUG, "results: " . join("//", @output));
if ($signal) {
$self->log(LOGWARN, "scanner exited with signal: $signal");
@ -105,6 +111,7 @@ sub hook_data_post {
$output = substr($output, 0, 60);
if ($result == 1 || $result == 3) {
$self->log(LOGWARN, "Virus(es) found: $output");
# return (DENY, "Virus Found: $output");
# $transaction->header->add('X-Virus-Found', 'Yes', 0);
# $transaction->header->add('X-Virus-Details', $output, 0);
@ -121,8 +128,11 @@ sub hook_data_post {
$self->log(LOGWARN, "License key not found");
}
elsif ($result) {
$self->log(LOGWARN, "Error: $result, look for exit codes in the output of '"
.$self->{_hbedvscan_loc}." --help' for more info\n");
$self->log(LOGWARN,
"Error: $result, look for exit codes in the output of '"
. $self->{_hbedvscan_loc}
. " --help' for more info\n"
);
}
# $transaction->header->add('X-Virus-Checked', 'Checked', 0);
@ -130,13 +140,13 @@ sub hook_data_post {
return (DECLINED) unless $result;
if (@virii) {
return(DENY, "Virus found: $output")
return (DENY, "Virus found: $output")
unless $self->qp->config("hbedv_deny");
foreach my $d ($self->qp->config("hbedv_deny")) {
foreach my $v (@virii) {
if ($v =~ /^$d$/i) {
$self->log(LOGWARN, "Denying mail with virus '$v'");
return(DENY, "Virus found: $output");
return (DENY, "Virus found: $output");
}
}
}
@ -154,5 +164,5 @@ sub unique {
foreach my $item (@list) {
exists $hash{$item} || ($hash{$item} = 1);
}
return keys(%hash)
return keys(%hash);
}

60
plugins/virus/kavscanner
View File

@ -61,19 +61,24 @@ sub register {
if (@args % 2) {
$self->log(LOGWARN, "kavscanner: Wrong number of arguments");
$self->{_kavscanner_bin} = "/opt/AVP/kavscanner";
} else {
}
else {
my %args = @args;
foreach my $key (keys %args) {
my $arg = $key;
$key =~ s/^/_/;
$self->{$key} = $args{$arg};
}
# Untaint scanner location
if (exists $self->{_kavscanner_bin} &&
$self->{_kavscanner_bin} =~ /^(\/[\/\-\_\.a-z0-9A-Z]*)$/) {
if (exists $self->{_kavscanner_bin}
&& $self->{_kavscanner_bin} =~ /^(\/[\/\-\_\.a-z0-9A-Z]*)$/)
{
$self->{_kavscanner_bin} = $1;
} else {
$self->log(LOGALERT, "FATAL ERROR: Unexpected characters in kavscanner argument");
}
else {
$self->log(LOGALERT,
"FATAL ERROR: Unexpected characters in kavscanner argument");
exit 3;
}
}
@ -92,7 +97,7 @@ sub hook_data_post {
seek($temp_fh, 0, 0);
# Now do the actual scanning!
my $cmd = $self->{_kavscanner_bin}." -Y -P -B -MP -MD -* $filename 2>&1";
my $cmd = $self->{_kavscanner_bin} . " -Y -P -B -MP -MD -* $filename 2>&1";
$self->log(LOGNOTICE, "Running: $cmd");
my @output = `$cmd`;
chomp(@output);
@ -115,17 +120,24 @@ sub hook_data_post {
if ($result =~ /^(2|3|4|8)$/) {
foreach (@output) {
if (/^.* infected: (.*)$/) {
# This covers the specific
push @infected, $1;
} elsif (/^\s*.* suspicion: (.*)$/) {
}
elsif (/^\s*.* suspicion: (.*)$/) {
# This covers the potential viruses
push @suspicious, $1;
}
}
$description = "infected by: ".join(", ",@infected)."; "
."suspicions: ".join(", ", @suspicious);
$description =
"infected by: "
. join(", ", @infected) . "; "
. "suspicions: "
. join(", ", @suspicious);
# else we may get a veeeery long X-Virus-Details: line or log entry
$description = substr($description,0,60);
$description = substr($description, 0, 60);
$self->log(LOGWARN, "There be a virus! ($description)");
### Untested by now, need volunteers ;-)
#if ($self->qp->config("kav_deny")) {
@ -150,27 +162,31 @@ sub hook_data_post {
$transaction->notes('virus_flag', 'Yes');
#### requires modification of Qpsmtpd/Transaction.pm:
# if ($self->{_to_virusadmin}) {
# my @addrs = ();
# foreach (@{$transaction->recipients}) {
# push @addr, $_->address;
# }
# $transaction->header->add('X-Virus-Orig-RcptTo', join(", ", @addrs));
# $transaction->set_recipients(@{ Mail::Address->parse($self->{_to_virusadmin}) });
# } elsif ($self->{_bcc_virusadmin}) {
# if ($self->{_to_virusadmin}) {
# my @addrs = ();
# foreach (@{$transaction->recipients}) {
# push @addr, $_->address;
# }
# $transaction->header->add('X-Virus-Orig-RcptTo', join(", ", @addrs));
# $transaction->set_recipients(@{ Mail::Address->parse($self->{_to_virusadmin}) });
# } elsif ($self->{_bcc_virusadmin}) {
if ($self->{_bcc_virusadmin}) {
foreach ( @{ Mail::Address->parse($self->{_bcc_virusadmin}) } ) {
foreach (@{Mail::Address->parse($self->{_bcc_virusadmin})}) {
$transaction->add_recipient($_);
}
}
} else {
$self->log(LOGEMERG, "corrupt or unknown Kaspersky scanner/resource problems - exit status $result");
}
else {
$self->log(LOGEMERG,
"corrupt or unknown Kaspersky scanner/resource problems - exit status $result"
);
}
}
$self->log(LOGINFO, "kavscanner results: $description");
$transaction->header->add('X-Virus-Checked', 'Checked by '.$self->qp->config("me"));
$transaction->header->add('X-Virus-Checked',
'Checked by ' . $self->qp->config("me"));
return (DECLINED);
}

4
plugins/virus/klez_filter
View File

@ -6,6 +6,7 @@ sub hook_data_post {
# klez files are always sorta big .. how big? Dunno.
return (DECLINED)
if $transaction->data_size < 60_000;
# 220k was too little, so let's just disable the "big size check"
# or $transaction->data_size > 1_000_000;
@ -22,7 +23,8 @@ sub hook_data_post {
last if $line_number++ > 40;
m/^Content-type:.*(?:audio|application)/i
and ++$seen_klez_signature and next;
and ++$seen_klez_signature
and next;
return (DENY, "Klez Virus Detected")
if $seen_klez_signature

48
plugins/virus/sophie
View File

@ -2,9 +2,9 @@
use IO::Socket;
sub register {
my ( $self, $qp, @args ) = @_;
my ($self, $qp, @args) = @_;
%{ $self->{"_sophie"} } = @args;
%{$self->{"_sophie"}} = @args;
# Set some sensible defaults
$self->{"_sophie"}->{"sophie_socket"} ||= "/var/run/sophie";
@ -13,11 +13,11 @@ sub register {
}
sub hook_data_post {
my ( $self, $transaction ) = @_;
my ($self, $transaction) = @_;
$DB::single = 1;
if ( $transaction->data_size > $self->{"_sophie"}->{"max_size"} * 1024 ) {
$self->log( LOGNOTICE, "Declining due to data_size" );
if ($transaction->data_size > $self->{"_sophie"}->{"max_size"} * 1024) {
$self->log(LOGNOTICE, "Declining due to data_size");
return (DECLINED);
}
@ -25,22 +25,22 @@ sub hook_data_post {
my $content_type = $transaction->header->get('Content-Type');
$content_type =~ s/\s/ /g if defined $content_type;
unless ( $content_type
&& $content_type =~ m!\bmultipart/.*\bboundary="?([^"]+)!i )
&& $content_type =~ m!\bmultipart/.*\bboundary="?([^"]+)!i)
{
$self->log( LOGWARN, "non-multipart mail - skipping" );
$self->log(LOGWARN, "non-multipart mail - skipping");
return DECLINED;
}
my $filename = $transaction->body_filename;
unless ($filename) {
$self->log( LOGWARN, "Cannot process due to lack of filename" );
$self->log(LOGWARN, "Cannot process due to lack of filename");
return (DECLINED); # unless $filename;
}
my $mode = ( stat( $self->spool_dir() ) )[2];
if ( $mode & 07077 ) { # must be sharing spool directory with external app
$self->log( LOGWARN,
"Changing permissions on file to permit scanner access" );
my $mode = (stat($self->spool_dir()))[2];
if ($mode & 07077) { # must be sharing spool directory with external app
$self->log(LOGWARN,
"Changing permissions on file to permit scanner access");
chmod $mode, $filename;
}
@ -51,30 +51,28 @@ sub hook_data_post {
connect(\*SOPHIE, pack_sockaddr_un $self->{"_sophie"}->{"sophie_socket"})
|| die "Couldn't connect() to the socket ($!)\n";
syswrite(\*SOPHIE, $filename."\n", length($filename)+1);
syswrite(\*SOPHIE, $filename . "\n", length($filename) + 1);
sysread(\*SOPHIE, $response, 256);
close (\*SOPHIE);
close(\*SOPHIE);
my $virus;
if ( ($virus) = ( $response =~ m/^1:?(.*)?$/ ) ) {
$self->log( LOGERROR, "One or more virus(es) found: $virus" );
if (($virus) = ($response =~ m/^1:?(.*)?$/)) {
$self->log(LOGERROR, "One or more virus(es) found: $virus");
if ( lc( $self->{"_sophie"}->{"deny_viruses"} ) eq "yes" ) {
return ( DENY,
"Virus"
. ( $virus =~ /,/ ? "es " : " " )
. "Found: $virus" );
if (lc($self->{"_sophie"}->{"deny_viruses"}) eq "yes") {
return (DENY,
"Virus" . ($virus =~ /,/ ? "es " : " ") . "Found: $virus");
}
else {
$transaction->header->add( 'X-Virus-Found', 'Yes' );
$transaction->header->add( 'X-Virus-Details', $virus );
$transaction->header->add('X-Virus-Found', 'Yes');
$transaction->header->add('X-Virus-Details', $virus);
return (DECLINED);
}
}
$transaction->header->add( 'X-Virus-Checked',
"Checked by SOPHIE on " . $self->qp->config("me") );
$transaction->header->add('X-Virus-Checked',
"Checked by SOPHIE on " . $self->qp->config("me"));
return (DECLINED);
}

44
plugins/virus/uvscan
View File

@ -47,9 +47,9 @@ sub register {
my ($self, $qp, @args) = @_;
while (@args) {
$self->{"_uvscan"}->{pop @args}=pop @args;
$self->{"_uvscan"}->{pop @args} = pop @args;
}
$self->{"_uvscan"}->{"uvscan_location"}||="/usr/local/bin/uvscan";
$self->{"_uvscan"}->{"uvscan_location"} ||= "/usr/local/bin/uvscan";
}
sub hook_data_post {
@ -62,9 +62,9 @@ sub hook_data_post {
my $content_type = $transaction->header->get('Content-Type');
$content_type =~ s/\s/ /g if defined $content_type;
unless ( $content_type
&& $content_type =~ m!\bmultipart/.*\bboundary="?([^"]+)!i )
&& $content_type =~ m!\bmultipart/.*\bboundary="?([^"]+)!i)
{
$self->log( LOGWARN, "non-multipart mail - skipping" );
$self->log(LOGWARN, "non-multipart mail - skipping");
return DECLINED;
}
@ -72,15 +72,16 @@ sub hook_data_post {
return (DECLINED) unless $filename;
# Now do the actual scanning!
my @cmd =($self->{"_uvscan"}->{"uvscan_location"},
'--mime', '--unzip', '--secure', '--noboot',
$filename, '2>&1 |');
$self->log(LOGINFO, "Running: ",join(' ', @cmd));
my @cmd = (
$self->{"_uvscan"}->{"uvscan_location"},
'--mime', '--unzip', '--secure', '--noboot', $filename, '2>&1 |'
);
$self->log(LOGINFO, "Running: ", join(' ', @cmd));
open(FILE, join(' ', @cmd)); #perl 5.6 doesn't properly support the pipe
# mode list form of open, but this is basically the same thing. This form
# of exec is safe(ish).
my $output;
while (<FILE>) { $output.=$_; }
while (<FILE>) { $output .= $_; }
close FILE;
my $result = ($? >> 8);
@ -88,7 +89,7 @@ sub hook_data_post {
my $virus;
if ($output && $output =~ m/.*\W+Found (.*)\n/m) {
$virus=$1;
$virus = $1;
}
if ($output && $output =~ m/password-protected/m) {
return (DENY, 'We do not accept password-protected zip files!');
@ -101,21 +102,28 @@ sub hook_data_post {
if ($result == 2) {
$self->log(LOGERROR, "Integrity check for a DAT file failed.");
return (DECLINED);
} elsif ($result == 6) {
}
elsif ($result == 6) {
$self->log(LOGERROR, "A general problem has occurred.");
return (DECLINED);
} elsif ($result == 8) {
}
elsif ($result == 8) {
$self->log(LOGERROR, "The program could not find a DAT file.");
return (DECLINED);
} elsif ($result == 15) {
}
elsif ($result == 15) {
$self->log(LOGERROR, "The program self-check failed");
return (DECLINED);
} elsif ( $result ) { # all of the possible virus returns
}
elsif ($result) { # all of the possible virus returns
if ($result == 12) {
$self->log(LOGERROR, "The program tried to clean a file but failed.");
} elsif ($result == 13) {
$self->log(LOGERROR,
"The program tried to clean a file but failed.");
}
elsif ($result == 13) {
$self->log(LOGERROR, "One or more virus(es) found");
} elsif ($result == 19) {
}
elsif ($result == 19) {
$self->log(LOGERROR, "Successfully cleaned the file");
}
@ -128,7 +136,7 @@ sub hook_data_post {
}
$transaction->header->add('X-Virus-Checked',
"Checked by McAfee uvscan on ".$self->qp->config("me"));
"Checked by McAfee uvscan on " . $self->qp->config("me"));
return (DECLINED);
}

4
plugins/whitelist
View File

@ -139,7 +139,7 @@ sub check_host {
if (exists $ENV{WHITELISTCLIENT}) {
$self->qp->connection->notes('whitelistclient', 1);
$self->log(2, "pass, is whitelisted client");
$self->adjust_karma( 5 );
$self->adjust_karma(5);
return OK;
}
@ -148,7 +148,7 @@ sub check_host {
if ($h eq $ip or $ip =~ /^\Q$h\E/) {
$self->qp->connection->notes('whitelisthost', 1);
$self->log(2, "pass, is a whitelisted host");
$self->adjust_karma( 5 );
$self->adjust_karma(5);
return OK;
}
}