diff --git a/plugins/async/dns_whitelist_soft b/plugins/async/dns_whitelist_soft index 1d42a03..95066a6 100644 --- a/plugins/async/dns_whitelist_soft +++ b/plugins/async/dns_whitelist_soft @@ -3,7 +3,7 @@ use Qpsmtpd::Plugin::Async::DNSBLBase; sub init { - my $self = shift; + my $self = shift; my $class = ref $self; no strict 'refs'; diff --git a/plugins/async/earlytalker b/plugins/async/earlytalker index 9e3fb22..989848a 100644 --- a/plugins/async/earlytalker +++ b/plugins/async/earlytalker @@ -62,73 +62,80 @@ Note that defer-reject has no meaning if check-at is I. my $MSG = 'Connecting host started transmitting before SMTP greeting'; sub register { - my ($self, $qp, @args) = @_; + my ($self, $qp, @args) = @_; - if (@args % 2) { - $self->log(LOGERROR, "Unrecognized/mismatched arguments"); - return undef; - } - $self->{_args} = { - 'wait' => 1, - 'action' => 'denysoft', - 'defer-reject' => 0, - 'check-at' => 'connect', - @args, - }; - print STDERR "Check at: ", $self->{_args}{'check-at'}, "\n"; - $self->register_hook($self->{_args}->{'check-at'}, 'check_talker_poll'); - $self->register_hook($self->{_args}->{'check-at'}, 'check_talker_post'); - if ($self->{_args}{'check-at'} eq 'connect') { - $self->register_hook('mail', 'hook_mail') - if $self->{_args}->{'defer-reject'}; - } - 1; + if (@args % 2) { + $self->log(LOGERROR, "Unrecognized/mismatched arguments"); + return undef; + } + $self->{_args} = { + 'wait' => 1, + 'action' => 'denysoft', + 'defer-reject' => 0, + 'check-at' => 'connect', + @args, + }; + print STDERR "Check at: ", $self->{_args}{'check-at'}, "\n"; + $self->register_hook($self->{_args}->{'check-at'}, 'check_talker_poll'); + $self->register_hook($self->{_args}->{'check-at'}, 'check_talker_post'); + if ($self->{_args}{'check-at'} eq 'connect') { + $self->register_hook('mail', 'hook_mail') + if $self->{_args}->{'defer-reject'}; + } + 1; } sub check_talker_poll { - my ($self, $transaction) = @_; + my ($self, $transaction) = @_; - my $qp = $self->qp; - my $conn = $qp->connection; - my $check_until = time + $self->{_args}{'wait'}; - $qp->AddTimer(1, sub { read_now($qp, $conn, $check_until, $self->{_args}{'check-at'}) }); - return YIELD; + my $qp = $self->qp; + my $conn = $qp->connection; + my $check_until = time + $self->{_args}{'wait'}; + $qp->AddTimer( + 1, + sub { + read_now($qp, $conn, $check_until, $self->{_args}{'check-at'}); + } + ); + return YIELD; } sub read_now { - my ($qp, $conn, $until, $phase) = @_; + my ($qp, $conn, $until, $phase) = @_; - if ($qp->has_data) { - $qp->log(LOGNOTICE, 'remote host started talking after $phase before we responded'); - $qp->clear_data if $phase eq 'data'; - $conn->notes('earlytalker', 1); - $qp->run_continuation; - } - elsif (time >= $until) { - # no early talking - $qp->run_continuation; - } - else { - $qp->AddTimer(1, sub { read_now($qp, $conn, $until, $phase) }); - } + if ($qp->has_data) { + $qp->log(LOGNOTICE, + 'remote host started talking after $phase before we responded'); + $qp->clear_data if $phase eq 'data'; + $conn->notes('earlytalker', 1); + $qp->run_continuation; + } + elsif (time >= $until) { + + # no early talking + $qp->run_continuation; + } + else { + $qp->AddTimer(1, sub { read_now($qp, $conn, $until, $phase) }); + } } sub check_talker_post { - my ($self, $transaction) = @_; + my ($self, $transaction) = @_; - return DECLINED unless $self->connection->notes('earlytalker'); - return DECLINED if $self->{'defer-reject'}; - return (DENY,$MSG) if $self->{_args}->{'action'} eq 'deny'; - return (DENYSOFT,$MSG) if $self->{_args}->{'action'} eq 'denysoft'; - return DECLINED; # assume action eq 'log' + return DECLINED unless $self->connection->notes('earlytalker'); + return DECLINED if $self->{'defer-reject'}; + return (DENY, $MSG) if $self->{_args}->{'action'} eq 'deny'; + return (DENYSOFT, $MSG) if $self->{_args}->{'action'} eq 'denysoft'; + return DECLINED; # assume action eq 'log' } sub hook_mail { - my ($self, $transaction) = @_; + my ($self, $transaction) = @_; - return DECLINED unless $self->connection->notes('earlytalker'); - return (DENY,$MSG) if $self->{_args}->{'action'} eq 'deny'; - return (DENYSOFT,$MSG) if $self->{_args}->{'action'} eq 'denysoft'; - return DECLINED; + return DECLINED unless $self->connection->notes('earlytalker'); + return (DENY, $MSG) if $self->{_args}->{'action'} eq 'deny'; + return (DENYSOFT, $MSG) if $self->{_args}->{'action'} eq 'denysoft'; + return DECLINED; } diff --git a/plugins/async/queue/smtp-forward b/plugins/async/queue/smtp-forward index 10665bf..818190d 100644 --- a/plugins/async/queue/smtp-forward +++ b/plugins/async/queue/smtp-forward @@ -25,7 +25,7 @@ use Qpsmtpd::Constants; sub register { my ($self, $qp) = @_; - + $self->register_hook(queue => "start_queue"); $self->register_hook(queue => "finish_queue"); } @@ -44,8 +44,9 @@ sub init { if (@args > 1 and $args[1] =~ /^(\d+)$/) { $self->{_smtp_port} = $1; } - - $self->log(LOGWARN, "WARNING: Ignoring additional arguments.") if (@args > 2); + + $self->log(LOGWARN, "WARNING: Ignoring additional arguments.") + if (@args > 2); } else { die("No SMTP server specified in smtp-forward config"); @@ -55,27 +56,30 @@ sub init { sub start_queue { my ($self, $transaction) = @_; - - my $qp = $self->qp; + + my $qp = $self->qp; my $SERVER = $self->{_smtp_server}; my $PORT = $self->{_smtp_port}; $self->log(LOGINFO, "forwarding to $SERVER:$PORT"); - - $transaction->notes('async_sender', - AsyncSMTPSender->new($SERVER, $PORT, $qp, $self, $transaction) - ); - + + $transaction->notes( + 'async_sender', + AsyncSMTPSender->new( + $SERVER, $PORT, $qp, $self, $transaction + ) + ); + return YIELD; } sub finish_queue { my ($self, $transaction) = @_; - + my $sender = $transaction->notes('async_sender'); $transaction->notes('async_sender', undef); - + my ($rc, $msg) = $sender->results; - + return $rc, $msg; } @@ -85,17 +89,17 @@ use IO::Socket; use base qw(Danga::Socket); use fields qw( - qp - pkg - tran - state - rcode - rmsg - buf - command - resp - to - ); + qp + pkg + tran + state + rcode + rmsg + buf + command + resp + to + ); use constant ST_CONNECTING => 0; use constant ST_CONNECTED => 1; @@ -107,28 +111,31 @@ use Qpsmtpd::Constants; sub new { my ($self, $server, $port, $qp, $pkg, $transaction) = @_; $self = fields::new($self) unless ref $self; - + my $sock = IO::Socket::INET->new( - PeerAddr => $server, - PeerPort => $port, - Blocking => 0, - ) or die "Error connecting to server $server:$port : $!\n"; + PeerAddr => $server, + PeerPort => $port, + Blocking => 0, + ) + or die "Error connecting to server $server:$port : $!\n"; IO::Handle::blocking($sock, 0); binmode($sock, ':raw'); - - $self->{qp} = $qp; - $self->{pkg} = $pkg; - $self->{tran} = $transaction; - $self->{state} = ST_CONNECTING; - $self->{rcode} = DECLINED; + + $self->{qp} = $qp; + $self->{pkg} = $pkg; + $self->{tran} = $transaction; + $self->{state} = ST_CONNECTING; + $self->{rcode} = DECLINED; $self->{command} = 'connect'; - $self->{buf} = ''; - $self->{resp} = []; + $self->{buf} = ''; + $self->{resp} = []; + # copy the recipients so we can pop them off one by one - $self->{to} = [ $transaction->recipients ]; - + $self->{to} = [$transaction->recipients]; + $self->SUPER::new($sock); + # Watch for write first, this is when the TCP session is established. $self->watch_write(1); @@ -137,7 +144,7 @@ sub new { sub results { my AsyncSMTPSender $self = shift; - return ( $self->{rcode}, $self->{rmsg} ); + return ($self->{rcode}, $self->{rmsg}); } sub log { @@ -154,27 +161,28 @@ sub command { my AsyncSMTPSender $self = shift; my ($command, $params) = @_; $params ||= ''; - + $self->log(LOGDEBUG, ">> $command $params"); - - $self->write(($command =~ m/ / ? "$command:" : $command) - . ($params ? " $params" : "") . "\r\n"); + + $self->write( ($command =~ m/ / ? "$command:" : $command) + . ($params ? " $params" : "") + . "\r\n"); $self->watch_read(1); $self->{command} = ($command =~ /(\S+)/)[0]; } sub handle_response { my AsyncSMTPSender $self = shift; - + my $method = "cmd_" . lc($self->{command}); - + $self->$method(@_); } sub cmd_connect { my AsyncSMTPSender $self = shift; my ($code, $response) = @_; - + if ($code != 220) { $self->{rmsg} = "Error on connect: @$response"; $self->close; @@ -183,14 +191,15 @@ sub cmd_connect { else { my $host = $self->{qp}->config('me'); print "HELOing with $host\n"; - $self->command((join '', @$response) =~ m/ ESMTP/ ? "EHLO" : "HELO", $host); + $self->command((join '', @$response) =~ m/ ESMTP/ ? "EHLO" : "HELO", + $host); } } sub cmd_helo { my AsyncSMTPSender $self = shift; my ($code, $response) = @_; - + if ($code != 250) { $self->{rmsg} = "Error on HELO: @$response"; $self->close; @@ -204,7 +213,7 @@ sub cmd_helo { sub cmd_ehlo { my AsyncSMTPSender $self = shift; my ($code, $response) = @_; - + if ($code != 250) { $self->{rmsg} = "Error on EHLO: @$response"; $self->close; @@ -218,7 +227,7 @@ sub cmd_ehlo { sub cmd_mail { my AsyncSMTPSender $self = shift; my ($code, $response) = @_; - + if ($code != 250) { $self->{rmsg} = "Error on MAIL FROM: @$response"; $self->close; @@ -232,7 +241,7 @@ sub cmd_mail { sub cmd_rcpt { my AsyncSMTPSender $self = shift; my ($code, $response) = @_; - + if ($code != 250) { $self->{rmsg} = "Error on RCPT TO: @$response"; $self->close; @@ -251,7 +260,7 @@ sub cmd_rcpt { sub cmd_data { my AsyncSMTPSender $self = shift; my ($code, $response) = @_; - + if ($code != 354) { $self->{rmsg} = "Error on DATA: @$response"; $self->close; @@ -265,7 +274,7 @@ sub cmd_data { while (my $line = $self->{tran}->body_getline) { $line =~ s/\r?\n/\r\n/; $write_buf .= $line; - if (length($write_buf) >= 131072) { # 128KB, arbitrary value + if (length($write_buf) >= 131072) { # 128KB, arbitrary value $self->log(LOGDEBUG, ">> $write_buf"); $self->datasend($write_buf); $write_buf = ''; @@ -283,7 +292,7 @@ sub cmd_data { sub cmd_dataend { my AsyncSMTPSender $self = shift; my ($code, $response) = @_; - + if ($code != 250) { $self->{rmsg} = "Error after DATA: @$response"; $self->close; @@ -297,9 +306,9 @@ sub cmd_dataend { sub cmd_quit { my AsyncSMTPSender $self = shift; my ($code, $response) = @_; - + $self->{rcode} = OK; - $self->{rmsg} = "Queued!"; + $self->{rmsg} = "Queued!"; $self->close; $self->cont; } @@ -313,7 +322,7 @@ sub datasend { sub event_read { my AsyncSMTPSender $self = shift; - + if ($self->{state} == ST_CONNECTED) { $self->{state} = ST_COMMANDS; } @@ -321,20 +330,21 @@ sub event_read { if ($self->{state} == ST_COMMANDS) { my $in = $self->read(1024); if (!$in) { + # XXX: connection closed $self->close("lost connection"); return; } - + my @lines = split /\r?\n/, $self->{buf} . $$in, -1; $self->{buf} = delete $lines[-1]; - - for(@lines) { + + for (@lines) { if (my ($code, $cont, $rest) = /^([0-9]{3})([ -])(.*)/) { $self->log(LOGDEBUG, "<< $code$cont$rest"); push @{$self->{resp}}, $rest; - if($cont eq ' ') { + if ($cont eq ' ') { $self->handle_response($code, $self->{resp}); $self->{resp} = []; } @@ -363,6 +373,7 @@ sub event_write { $self->watch_read(1); } elsif (0 && $self->{state} == ST_DATA) { + # send more data if (my $line = $self->{tran}->body_getline) { $self->log(LOGDEBUG, ">> $line"); @@ -383,8 +394,9 @@ sub event_write { sub event_err { my ($self) = @_; - eval { $self->read(1); }; # gives us the correct error in errno + eval { $self->read(1); }; # gives us the correct error in errno $self->{rmsg} = "Read error from remote server: $!"; + #print "lost connection: $!\n"; $self->close; $self->cont; @@ -392,8 +404,9 @@ sub event_err { sub event_hup { my ($self) = @_; - eval { $self->read(1); }; # gives us the correct error in errno + eval { $self->read(1); }; # gives us the correct error in errno $self->{rmsg} = "HUP error from remote server: $!"; + #print "lost connection: $!\n"; $self->close; $self->cont; diff --git a/plugins/async/resolvable_fromhost b/plugins/async/resolvable_fromhost index acf93d6..fa471de 100644 --- a/plugins/async/resolvable_fromhost +++ b/plugins/async/resolvable_fromhost @@ -14,45 +14,47 @@ my %invalid = (); my $has_ipv6 = Qpsmtpd::TcpServer::has_ipv6(); sub register { - my ( $self, $qp ) = @_; + my ($self, $qp) = @_; - foreach my $i ( $self->qp->config("invalid_resolvable_fromhost") ) { + foreach my $i ($self->qp->config("invalid_resolvable_fromhost")) { $i =~ s/^\s*//; $i =~ s/\s*$//; - if ( $i =~ m#^((\d{1,3}\.){3}\d{1,3})/(\d\d?)# ) { + if ($i =~ m#^((\d{1,3}\.){3}\d{1,3})/(\d\d?)#) { $invalid{$1} = $3; } } eval 'use ParaDNS'; - if ( $@ ) { + if ($@) { warn "could not load ParaDNS, plugin disabled"; return DECLINED; - }; - $self->register_hook( mail => 'hook_mail_start' ); - $self->register_hook( mail => 'hook_mail_done' ); + } + $self->register_hook(mail => 'hook_mail_start'); + $self->register_hook(mail => 'hook_mail_done'); } sub hook_mail_start { - my ( $self, $transaction, $sender ) = @_; + my ($self, $transaction, $sender) = @_; return DECLINED if ($self->connection->notes('whitelisthost')); - if ( $sender ne '<>' ) { + if ($sender ne '<>') { + + unless ($sender->host) { - unless ( $sender->host ) { # default of addr_bad_from_system is DENY, we use DENYSOFT here to # get the same behaviour as without Qpsmtpd::DSN... - return Qpsmtpd::DSN->addr_bad_from_system( DENYSOFT, - "FQDN required in the envelope sender" ); + return + Qpsmtpd::DSN->addr_bad_from_system(DENYSOFT, + "FQDN required in the envelope sender"); } return DECLINED if $sender->host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/; - unless ($self->check_dns( $sender->host )) { + unless ($self->check_dns($sender->host)) { return Qpsmtpd::DSN->temp_resolver_failed( - "Could not resolve " . $sender->host ); + "Could not resolve " . $sender->host); } return YIELD; @@ -62,76 +64,97 @@ sub hook_mail_start { } sub hook_mail_done { - my ( $self, $transaction, $sender ) = @_; + my ($self, $transaction, $sender) = @_; return DECLINED - if ( $self->connection->notes('whitelisthost') ); + if ($self->connection->notes('whitelisthost')); + + if ($sender ne "<>" && !$transaction->notes('resolvable_fromhost')) { - if ( $sender ne "<>" && !$transaction->notes('resolvable_fromhost') ) { # default of temp_resolver_failed is DENYSOFT return Qpsmtpd::DSN->temp_resolver_failed( - "Could not resolve " . $sender->host ); + "Could not resolve " . $sender->host); } return DECLINED; } sub check_dns { - my ( $self, $host ) = @_; + my ($self, $host) = @_; my @host_answers; my $qp = $self->qp; $qp->input_sock->pause_read; - my $a_records = []; + my $a_records = []; my $num_queries = 1; # queries in progress - my $mx_found = 0; + my $mx_found = 0; ParaDNS->new( - callback => sub { + callback => sub { my $mx = shift; - return if $mx =~ /^[A-Z]+$/; # error + return if $mx =~ /^[A-Z]+$/; # error my $addr = $mx->[0]; $mx_found = 1; $num_queries++; ParaDNS->new( - callback => sub { push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/; }, - finished => sub { $num_queries--; $self->finish_up($qp, $a_records, $num_queries) }, - host => $addr, - type => 'A', - ); + callback => sub { + push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/; + }, + finished => sub { + $num_queries--; + $self->finish_up($qp, $a_records, $num_queries); + }, + host => $addr, + type => 'A', + ); if ($has_ipv6) { $num_queries++; ParaDNS->new( - callback => sub { push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/; }, - finished => sub { $num_queries--; $self->finish_up($qp, $a_records, $num_queries) }, - host => $addr, - type => 'AAAA', - ); + callback => sub { + push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/; + }, + finished => sub { + $num_queries--; + $self->finish_up($qp, $a_records, $num_queries); + }, + host => $addr, + type => 'AAAA', + ); } }, - finished => sub { + finished => sub { unless ($mx_found) { $num_queries++; ParaDNS->new( - callback => sub { push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/; }, - finished => sub { $num_queries--; $self->finish_up($qp, $a_records, $num_queries) }, - host => $host, - type => 'A', - ); + callback => sub { + push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/; + }, + finished => sub { + $num_queries--; + $self->finish_up($qp, $a_records, $num_queries); + }, + host => $host, + type => 'A', + ); if ($has_ipv6) { $num_queries++; ParaDNS->new( - callback => sub { push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/; }, - finished => sub { $num_queries--; $self->finish_up($qp, $a_records, $num_queries) }, - host => $host, - type => 'AAAA', - ); + callback => sub { + push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/; + }, + finished => sub { + $num_queries--; + $self->finish_up($qp, $a_records, $num_queries); + }, + host => $host, + type => 'AAAA', + ); } } @@ -139,9 +162,10 @@ sub check_dns { $num_queries--; $self->finish_up($qp, $a_records, $num_queries); }, - host => $host, - type => 'MX', - ) or $qp->input_sock->continue_read, return; + host => $host, + type => 'MX', + ) + or $qp->input_sock->continue_read, return; return 1; } @@ -161,6 +185,7 @@ sub finish_up { } unless ($num_queries) { + # all queries returned no valid response $qp->transaction->notes('resolvable_fromhost', 0); $qp->input_sock->continue_read; @@ -170,12 +195,12 @@ sub finish_up { sub is_valid { my $ip = shift; - my ( $net, $mask ); - foreach $net ( keys %invalid ) { + my ($net, $mask); + foreach $net (keys %invalid) { $mask = $invalid{$net}; - $mask = pack "B32", "1" x ($mask) . "0" x ( 32 - $mask ); + $mask = pack "B32", "1" x ($mask) . "0" x (32 - $mask); return 0 - if join( ".", unpack( "C4", inet_aton($ip) & $mask ) ) eq $net; + if join(".", unpack("C4", inet_aton($ip) & $mask)) eq $net; } return 1; } diff --git a/plugins/async/rhsbl b/plugins/async/rhsbl index c0a5e53..2672808 100644 --- a/plugins/async/rhsbl +++ b/plugins/async/rhsbl @@ -3,7 +3,7 @@ use Qpsmtpd::Plugin::Async::DNSBLBase; sub init { - my $self = shift; + my $self = shift; my $class = ref $self; no strict 'refs'; diff --git a/plugins/async/uribl b/plugins/async/uribl index 27b991b..026982a 100644 --- a/plugins/async/uribl +++ b/plugins/async/uribl @@ -31,10 +31,13 @@ sub start_data_post { my @names; - my $queries = $self->lookup_start($transaction, sub { - my ($self, $name) = @_; - push @names, $name; - }); + my $queries = $self->lookup_start( + $transaction, + sub { + my ($self, $name) = @_; + push @names, $name; + } + ); my @hosts; foreach my $z (keys %{$self->{uribl_zones}}) { @@ -42,10 +45,10 @@ sub start_data_post { } $transaction->notes(uribl_results => {}); - $transaction->notes(uribl_zones => $self->{uribl_zones}); + $transaction->notes(uribl_zones => $self->{uribl_zones}); return DECLINED - unless @hosts && $class->lookup($self->qp, [ @hosts ], [ @hosts ]); + unless @hosts && $class->lookup($self->qp, [@hosts], [@hosts]); return YIELD; } @@ -58,9 +61,11 @@ sub finish_data_post { $self->log(LOGWARN, $_->{desc}); if ($_->{action} eq 'add-header') { $transaction->header->add('X-URIBL-Match', $_->{desc}); - } elsif ($_->{action} eq 'deny') { + } + elsif ($_->{action} eq 'deny') { return (DENY, $_->{desc}); - } elsif ($_->{action} eq 'denysoft') { + } + elsif ($_->{action} eq 'denysoft') { return (DENYSOFT, $_->{desc}); } } @@ -73,8 +78,8 @@ sub process_a_result { my ($class, $qp, $result, $query) = @_; my $transaction = $qp->transaction; - my $results = $transaction->notes('uribl_results'); - my $zones = $transaction->notes('uribl_zones'); + my $results = $transaction->notes('uribl_results'); + my $zones = $transaction->notes('uribl_zones'); foreach my $z (keys %$zones) { if ($query =~ /^(.*)\.$z$/) { @@ -88,8 +93,8 @@ sub process_txt_result { my ($class, $qp, $result, $query) = @_; my $transaction = $qp->transaction; - my $results = $transaction->notes('uribl_results'); - my $zones = $transaction->notes('uribl_zones'); + my $results = $transaction->notes('uribl_results'); + my $zones = $transaction->notes('uribl_zones'); foreach my $z (keys %$zones) { if ($query =~ /^(.*)\.$z$/) { @@ -110,11 +115,15 @@ sub collect_results { if (exists $results->{$z}->{$n}->{a}) { if ($self->evaluate($z, $results->{$z}->{$n}->{a})) { $self->log(LOGDEBUG, "match $n in $z"); - push @matches, { + push @matches, + { action => $self->{uribl_zones}->{$z}->{action}, - desc => "$n in $z: " . - ($results->{$z}->{$n}->{txt} || $results->{$z}->{$n}->{a}), - }; + desc => "$n in $z: " + . ( + $results->{$z}->{$n}->{txt} + || $results->{$z}->{$n}->{a} + ), + }; } } } diff --git a/plugins/auth/auth_checkpassword b/plugins/auth/auth_checkpassword index 28d7894..cb84758 100644 --- a/plugins/auth/auth_checkpassword +++ b/plugins/auth/auth_checkpassword @@ -106,12 +106,12 @@ Please see the LICENSE file included with qpsmtpd for details. =cut sub register { - my ($self, $qp, %args ) = @_; + my ($self, $qp, %args) = @_; - my ($checkpw, $true) = $self->get_checkpw( \%args ); - return DECLINED if ! $checkpw || ! $true; + my ($checkpw, $true) = $self->get_checkpw(\%args); + return DECLINED if !$checkpw || !$true; - $self->connection->notes('auth_checkpassword_bin', $checkpw); + $self->connection->notes('auth_checkpassword_bin', $checkpw); $self->connection->notes('auth_checkpassword_true', $true); $self->register_hook('auth-plain', 'auth_checkpassword'); @@ -123,8 +123,8 @@ sub auth_checkpassword { @_; my $binary = $self->connection->notes('auth_checkpassword_bin'); - my $true = $self->connection->notes('auth_checkpassword_true'); - chomp ($binary, $true); + my $true = $self->connection->notes('auth_checkpassword_true'); + chomp($binary, $true); my $sudo = get_sudo($binary); @@ -138,7 +138,7 @@ sub auth_checkpassword { if ($status != 0) { $self->log(LOGNOTICE, "authentication failed ($status)"); return (DECLINED); - }; + } $self->connection->notes('authuser', $user); return (OK, "auth_checkpassword"); @@ -147,42 +147,43 @@ sub auth_checkpassword { sub get_checkpw { my ($self, $args) = @_; - my ($checkpw) = $args->{checkpw} =~ /^(.*)$/ if $args->{checkpw}; # untaint - my ($true) = $args->{true} =~ /^(.*)$/ if $args->{true}; # untaint + my ($checkpw) = $args->{checkpw} =~ /^(.*)$/ if $args->{checkpw}; # untaint + my ($true) = $args->{true} =~ /^(.*)$/ if $args->{true}; # untaint - return ( $checkpw, $true ) - if ( $checkpw && $true && -x $checkpw && -x $true ); + return ($checkpw, $true) + if ($checkpw && $true && -x $checkpw && -x $true); - my $missing_config = "disabled due to invalid configuration. See 'perldoc plugins/auth/auth_checkpassword' for how to configure."; + my $missing_config = +"disabled due to invalid configuration. See 'perldoc plugins/auth/auth_checkpassword' for how to configure."; - if ( ! $self->qp->config('smtpauth-checkpassword') ) { - $self->log(LOGERROR, $missing_config ); + if (!$self->qp->config('smtpauth-checkpassword')) { + $self->log(LOGERROR, $missing_config); return; - }; + } $self->log(LOGNOTICE, "reading config from smtpauth-checkpassword"); my $config = $self->qp->config("smtpauth-checkpassword"); ($checkpw, $true) = $config =~ /^(\S+)\s+(\S+)\s*$/; - if ( ! $checkpw || ! $true || ! -x $checkpw || ! -x $true ) { - $self->log(LOGERROR, $missing_config ); + if (!$checkpw || !$true || !-x $checkpw || !-x $true) { + $self->log(LOGERROR, $missing_config); return; - }; + } return ($checkpw, $true); -}; +} sub get_sudo { my $binary = shift; - return '' if $> == 0; # running as root - return '' if $> == 89 && $binary =~ /vchkpw$/; # running as vpopmail + return '' if $> == 0; # running as root + return '' if $> == 89 && $binary =~ /vchkpw$/; # running as vpopmail my $mode = (stat($binary))[2]; $mode = sprintf "%lo", $mode & 07777; - return '' if $mode eq '4711'; # $binary is setuid + return '' if $mode eq '4711'; # $binary is setuid my $sudo = `which sudo` || '/usr/local/bin/sudo'; - return '' if ! -x $sudo; + return '' if !-x $sudo; $sudo .= ' -C4'; # prevent sudo from clobbering file descriptor 3 diff --git a/plugins/auth/auth_cvm_unix_local b/plugins/auth/auth_cvm_unix_local index c468381..80c893e 100644 --- a/plugins/auth/auth_cvm_unix_local +++ b/plugins/auth/auth_cvm_unix_local @@ -46,24 +46,24 @@ use warnings; use Qpsmtpd::Constants; use Socket; -use constant SMTP_PORT => getservbyname("smtp", "tcp") || 25; +use constant SMTP_PORT => getservbyname("smtp", "tcp") || 25; use constant SSMTP_PORT => getservbyname("ssmtp", "tcp") || 465; sub register { - my ( $self, $qp, %arg ) = @_; + my ($self, $qp, %arg) = @_; unless ($arg{cvm_socket}) { $self->log(LOGERROR, "skip: requires cvm_socket argument"); return 0; - }; + } - $self->{_args} = { %arg }; - $self->{_enable_smtp} = $arg{enable_smtp} || 'no'; + $self->{_args} = {%arg}; + $self->{_enable_smtp} = $arg{enable_smtp} || 'no'; $self->{_enable_ssmtp} = $arg{enable_ssmtp} || 'yes'; my $port = $ENV{PORT} || SMTP_PORT; - return 0 if ($port == SMTP_PORT && $arg{enable_smtp} ne 'yes'); + return 0 if ($port == SMTP_PORT && $arg{enable_smtp} ne 'yes'); return 0 if ($port == SSMTP_PORT && $arg{enable_ssmtp} ne 'yes'); if ($arg{cvm_socket} =~ /^([\w\/.-]+)$/) { @@ -77,11 +77,12 @@ sub register { $self->register_hook("auth-plain", "authcvm_plain"); $self->register_hook("auth-login", "authcvm_plain"); -# $self->register_hook("auth-cram-md5", "authcvm_hash"); + + # $self->register_hook("auth-cram-md5", "authcvm_hash"); } sub authcvm_plain { - my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) = + my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) = @_; socket(SOCK, PF_UNIX, SOCK_STREAM, 0) or do { @@ -89,41 +90,43 @@ sub authcvm_plain { return (DENY, "authcvm"); }; -# DENY, really? Should this plugin return a DENY when it cannot connect -# to the cvs socket? I'd expect such a failure to return DECLINED, so -# any other auth plugins could take a stab at authenticating the user + # DENY, really? Should this plugin return a DENY when it cannot connect + # to the cvs socket? I'd expect such a failure to return DECLINED, so + # any other auth plugins could take a stab at authenticating the user connect(SOCK, sockaddr_un($self->{_cvm_socket})) or do { $self->log(LOGERROR, "skip: socket connection attempt for: $user"); return (DENY, "authcvm"); }; - my $o = select(SOCK); $| = 1; select($o); + my $o = select(SOCK); + $| = 1; + select($o); my ($u, $host) = split(/\@/, $user); $host ||= "localhost"; print SOCK "\001$u\000$host\000$passClear\000\000"; - shutdown SOCK, 1; # tell remote we're finished + shutdown SOCK, 1; # tell remote we're finished my $ret = ; - my ($s) = unpack ("C", $ret); + my ($s) = unpack("C", $ret); - if ( ! defined $s ) { + if (!defined $s) { $self->log(LOGERROR, "skip: no response from cvm for $user"); return (DECLINED); - }; + } - if ( $s == 0 ) { + if ($s == 0) { $self->log(LOGINFO, "pass: authentication for: $user"); return (OK, "auth success for $user"); - }; + } - if ( $s == 100 ) { + if ($s == 100) { $self->log(LOGINFO, "fail: authentication failure for: $user"); return (DENY, 'auth failure (100)'); - }; + } $self->log(LOGERROR, "skip: unknown response from cvm for $user"); return (DECLINED, "unknown result code ($s)"); diff --git a/plugins/auth/auth_flat_file b/plugins/auth/auth_flat_file index 2045009..3d862f8 100644 --- a/plugins/auth/auth_flat_file +++ b/plugins/auth/auth_flat_file @@ -37,7 +37,7 @@ use Qpsmtpd::Auth; use Qpsmtpd::Constants; sub register { - my ( $self, $qp ) = @_; + my ($self, $qp) = @_; $self->register_hook('auth-plain', 'auth_flat_file'); $self->register_hook('auth-login', 'auth_flat_file'); @@ -45,24 +45,25 @@ sub register { } sub auth_flat_file { - my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) = + my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) = @_; - if ( ! defined $passClear && ! defined $passHash ) { + if (!defined $passClear && !defined $passHash) { $self->log(LOGINFO, "fail: missing password"); - return ( DENY, "authflat - missing password" ); + return (DENY, "authflat - missing password"); } - my ( $pw_name, $pw_domain ) = split /@/, lc($user); + my ($pw_name, $pw_domain) = split /@/, lc($user); - unless ( defined $pw_domain ) { + unless (defined $pw_domain) { $self->log(LOGINFO, "fail: missing domain"); return DECLINED; } - my ($auth_line) = grep {/^$pw_name\@$pw_domain:/} $self->qp->config('flat_auth_pw'); + my ($auth_line) = + grep { /^$pw_name\@$pw_domain:/ } $self->qp->config('flat_auth_pw'); - if ( ! defined $auth_line) { + if (!defined $auth_line) { $self->log(LOGINFO, "fail: no such user: $user"); return DECLINED; } @@ -70,14 +71,16 @@ sub auth_flat_file { my ($auth_user, $auth_pass) = split(/:/, $auth_line, 2); # at this point we can assume the user name matched - return Qpsmtpd::Auth::validate_password( $self, - src_clear => $auth_pass, - src_crypt => undef, - attempt_clear => $passClear, - attempt_hash => $passHash, - method => $method, - ticket => $ticket, - deny => DENY, - ); + return + Qpsmtpd::Auth::validate_password( + $self, + src_clear => $auth_pass, + src_crypt => undef, + attempt_clear => $passClear, + attempt_hash => $passHash, + method => $method, + ticket => $ticket, + deny => DENY, + ); } diff --git a/plugins/auth/auth_ldap_bind b/plugins/auth/auth_ldap_bind index 76acae3..a2721b3 100644 --- a/plugins/auth/auth_ldap_bind +++ b/plugins/auth/auth_ldap_bind @@ -136,7 +136,7 @@ sub authldap { unless ($ldbase) { $self->log(LOGERROR, "skip: please configure ldap_base"); return (DECLINED, "authldap - temporary auth error"); - }; + } $ldwait = $self->{"ldconf"}->{'ldap_timeout'}; $ldmattr = $self->{"ldconf"}->{'ldap_auth_filter_attr'}; @@ -149,20 +149,23 @@ sub authldap { }; # find the user's DN - $mesg = $ldh->search( base => $ldbase, - scope => 'sub', - filter => "$ldmattr=$pw_name", - attrs => ['uid'], - timeout => $ldwait, - sizelimit => '1' - ) or do { + $mesg = $ldh->search( + base => $ldbase, + scope => 'sub', + filter => "$ldmattr=$pw_name", + attrs => ['uid'], + timeout => $ldwait, + sizelimit => '1' + ) + or do { $self->log(LOGALERT, "skip: err in search for user"); return (DECLINED, "authldap - temporary auth error"); - }; + }; # deal with errors if they exist if ($mesg->code) { - $self->log(LOGALERT, "skip: err " . $mesg->code . " in search for user"); + $self->log(LOGALERT, + "skip: err " . $mesg->code . " in search for user"); return (DECLINED, "authldap - temporary auth error"); } @@ -170,10 +173,10 @@ sub authldap { $ldh->unbind if $ldh; # bind against directory as user with password supplied - if ( ! $mesg->count || $lduserdn = $mesg->entry->dn ) { + if (!$mesg->count || $lduserdn = $mesg->entry->dn) { $self->log(LOGALERT, "fail: user not found"); return (DECLINED, "authldap - wrong username or password"); - }; + } $ldh = Net::LDAP->new($ldhost, port => $ldport, timeout => $ldwait) or do { $self->log(LOGALERT, "skip: err in user conn"); diff --git a/plugins/auth/auth_vpopmail b/plugins/auth/auth_vpopmail index e1dc423..e698cc7 100644 --- a/plugins/auth/auth_vpopmail +++ b/plugins/auth/auth_vpopmail @@ -50,10 +50,10 @@ use Qpsmtpd::Constants; sub register { my ($self, $qp) = @_; - return (DECLINED) if ! $self->test_vpopmail_module(); + return (DECLINED) if !$self->test_vpopmail_module(); - $self->register_hook("auth-plain", "auth_vpopmail" ); - $self->register_hook("auth-login", "auth_vpopmail" ); + $self->register_hook("auth-plain", "auth_vpopmail"); + $self->register_hook("auth-login", "auth_vpopmail"); $self->register_hook("auth-cram-md5", "auth_vpopmail"); } @@ -61,41 +61,45 @@ sub auth_vpopmail { my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) = @_; - my $pw = vauth_getpw( split /@/, lc($user) ); + my $pw = vauth_getpw(split /@/, lc($user)); my $pw_clear_passwd = $pw->{pw_clear_passwd}; my $pw_passwd = $pw->{pw_passwd}; if (!$pw || (!$pw_clear_passwd && !$pw_passwd)) { $self->log(LOGINFO, "fail: invalid user $user"); return (DENY, "auth_vpopmail - invalid user"); + # change DENY to DECLINED to support multiple auth plugins } - return Qpsmtpd::Auth::validate_password( $self, - src_clear => $pw->{pw_clear_passwd}, - src_crypt => $pw->{pw_passwd}, - attempt_clear => $passClear, - attempt_hash => $passHash, - method => $method, - ticket => $ticket, - deny => DENY, - ); + return + Qpsmtpd::Auth::validate_password( + $self, + src_clear => $pw->{pw_clear_passwd}, + src_crypt => $pw->{pw_passwd}, + attempt_clear => $passClear, + attempt_hash => $passHash, + method => $method, + ticket => $ticket, + deny => DENY, + ); } sub test_vpopmail_module { my $self = shift; + # vpopmail will not allow vauth_getpw to succeed unless the requesting user is vpopmail or root. # by default, qpsmtpd runs as the user 'qpsmtpd' and does not have permission. eval 'use vpopmail'; - if ( $@ ) { + if ($@) { $self->log(LOGERROR, "skip: is vpopmail perl module installed?"); return; - }; + } my ($domain) = vpopmail::vlistdomains(); my $r = vauth_getpw('postmaster', $domain) or do { - $self->log(LOGERROR, "skip: could not query vpopmail"); - return; - }; + $self->log(LOGERROR, "skip: could not query vpopmail"); + return; + }; return 1; } diff --git a/plugins/auth/auth_vpopmail_sql b/plugins/auth/auth_vpopmail_sql index 90f08e8..b561cd3 100644 --- a/plugins/auth/auth_vpopmail_sql +++ b/plugins/auth/auth_vpopmail_sql @@ -72,14 +72,14 @@ use Qpsmtpd::Constants; #use DBI; # done in ->register sub register { - my ( $self, $qp ) = @_; + my ($self, $qp) = @_; eval 'use DBI'; - if ( $@ ) { + if ($@) { warn "plugin disabled. is DBI installed?\n"; $self->log(LOGERROR, "skip: plugin disabled. is DBI installed?\n"); return; - }; + } $self->register_hook('auth-plain', 'auth_vmysql'); $self->register_hook('auth-login', 'auth_vmysql'); @@ -89,27 +89,28 @@ sub register { sub get_db_handle { my $self = shift; - my $dsn = $self->qp->config("vpopmail_mysql_dsn") || "dbi:mysql:dbname=vpopmail;host=127.0.0.1"; + my $dsn = $self->qp->config("vpopmail_mysql_dsn") + || "dbi:mysql:dbname=vpopmail;host=127.0.0.1"; my $dbuser = $self->qp->config("vpopmail_mysql_user") || "vpopmailuser"; my $dbpass = $self->qp->config("vpopmail_mysql_pass") || "vpoppasswd"; - my $dbh = DBI->connect( $dsn, $dbuser, $dbpass ) or do { - $self->log(LOGERROR, "skip: db connection failed"); - return; - }; - $dbh->{ShowErrorStatement} = 1; - return $dbh; -}; - -sub get_vpopmail_user { - my ( $self, $dbh, $user ) = @_; - - my ( $pw_name, $pw_domain ) = split /@/, lc($user); - - if ( ! defined $pw_domain ) { - $self->log(LOGINFO, "skip: missing domain: " . lc $user ); + my $dbh = DBI->connect($dsn, $dbuser, $dbpass) or do { + $self->log(LOGERROR, "skip: db connection failed"); return; }; + $dbh->{ShowErrorStatement} = 1; + return $dbh; +} + +sub get_vpopmail_user { + my ($self, $dbh, $user) = @_; + + my ($pw_name, $pw_domain) = split /@/, lc($user); + + if (!defined $pw_domain) { + $self->log(LOGINFO, "skip: missing domain: " . lc $user); + return; + } $self->log(LOGDEBUG, "auth_vpopmail_sql: $user"); @@ -118,16 +119,17 @@ FROM vpopmail WHERE pw_name = ? AND pw_domain = ?"; - my $sth = $dbh->prepare( $query ); - $sth->execute( $pw_name, $pw_domain ); + my $sth = $dbh->prepare($query); + $sth->execute($pw_name, $pw_domain); my $userd_ref = $sth->fetchrow_hashref; $sth->finish; $dbh->disconnect; return $userd_ref; -}; +} sub auth_vmysql { - my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) = @_; + my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) = + @_; my $dbh = $self->get_db_handle() or return DECLINED; my $u = $self->get_vpopmail_user($dbh, $user) or return DECLINED; @@ -136,21 +138,23 @@ sub auth_vmysql { # then pw_clear_passwd may not even exist # my $pw_clear_passwd = $db_user->{'pw_clear_passwd'}; - if ( ! $u->{pw_passwd} && ! $u->{pw_clear_passwd} ) { + if (!$u->{pw_passwd} && !$u->{pw_clear_passwd}) { $self->log(LOGINFO, "fail: no such user"); - return ( DENY, "auth_vmysql - no such user" ); - }; + return (DENY, "auth_vmysql - no such user"); + } # at this point, the user name has matched - return Qpsmtpd::Auth::validate_password( $self, - src_clear => $u->{pw_clear_passwd}, - src_crypt => $u->{pw_passwd}, - attempt_clear => $passClear, - attempt_hash => $passHash, - method => $method, - ticket => $ticket, - deny => DENY, - ); + return + Qpsmtpd::Auth::validate_password( + $self, + src_clear => $u->{pw_clear_passwd}, + src_crypt => $u->{pw_passwd}, + attempt_clear => $passClear, + attempt_hash => $passHash, + method => $method, + ticket => $ticket, + deny => DENY, + ); } diff --git a/plugins/auth/auth_vpopmaild b/plugins/auth/auth_vpopmaild index fe51c0c..08e3970 100644 --- a/plugins/auth/auth_vpopmaild +++ b/plugins/auth/auth_vpopmaild @@ -5,7 +5,7 @@ use warnings; use Qpsmtpd::Constants; use IO::Socket; -use version; +use version; my $VERSION = qv('1.0.3'); sub register { @@ -16,58 +16,63 @@ sub register { $self->register_hook('auth-plain', 'auth_vpopmaild'); $self->register_hook('auth-login', 'auth_vpopmaild'); + #$self->register_hook('auth-cram-md5', 'auth_vpopmaild'); # not supported } sub auth_vpopmaild { - my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) = @_; + my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) = + @_; - if ( ! $passClear ) { + if (!$passClear) { $self->log(LOGINFO, "skip: vpopmaild does not support cram-md5"); return DECLINED; } # create socket - my $vpopmaild_socket = IO::Socket::INET->new( + my $vpopmaild_socket = + IO::Socket::INET->new( PeerAddr => $self->{_vpopmaild_host}, PeerPort => $self->{_vpopmaild_port}, Proto => 'tcp', Type => SOCK_STREAM - ) or do { + ) + or do { $self->log(LOGERROR, "skip: socket connection to vpopmaild failed"); return DECLINED; - }; + }; $self->log(LOGDEBUG, "attempting $method"); # Get server greeting (+OK) my $connect_response = <$vpopmaild_socket>; - if ( ! $connect_response ) { + if (!$connect_response) { $self->log(LOGERROR, "skip: no connection response"); close($vpopmaild_socket); return DECLINED; - }; + } - if ( $connect_response !~ /^\+OK/ ) { - $self->log(LOGERROR, "skip: bad connection response: $connect_response"); + if ($connect_response !~ /^\+OK/) { + $self->log(LOGERROR, + "skip: bad connection response: $connect_response"); close($vpopmaild_socket); return DECLINED; - }; + } - print $vpopmaild_socket "login $user $passClear\n\r"; # send login details - my $login_response = <$vpopmaild_socket>; # get response from server + print $vpopmaild_socket "login $user $passClear\n\r"; # send login details + my $login_response = <$vpopmaild_socket>; # get response from server close($vpopmaild_socket); - if ( ! $login_response ) { + if (!$login_response) { $self->log(LOGERROR, "skip: no login response"); return DECLINED; - }; + } # check for successful login (single line (+OK) or multiline (+OK+)) - if ( $login_response =~ /^\+OK/ ) { + if ($login_response =~ /^\+OK/) { $self->log(LOGINFO, "pass: clear"); return (OK, 'auth_vpopmaild'); - }; + } chomp $login_response; $self->log(LOGNOTICE, "fail: $login_response"); diff --git a/plugins/auth/authdeny b/plugins/auth/authdeny index deb8537..a06759b 100644 --- a/plugins/auth/authdeny +++ b/plugins/auth/authdeny @@ -13,11 +13,11 @@ the Qpsmtpd::Auth module. Don't run this in production!!! =cut sub hook_auth { - my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) = + my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) = @_; - $self->log( LOGWARN, "fail: cannot authenticate" ); + $self->log(LOGWARN, "fail: cannot authenticate"); - return ( DECLINED, "$user is not free to abuse my relay" ); + return (DECLINED, "$user is not free to abuse my relay"); } diff --git a/plugins/badmailfrom b/plugins/badmailfrom index 4aea3fe..4a8a1b8 100644 --- a/plugins/badmailfrom +++ b/plugins/badmailfrom @@ -59,11 +59,11 @@ anywhere in the string. =cut sub register { - my ($self,$qp) = (shift, shift); - $self->{_args} = { @_ }; + my ($self, $qp) = (shift, shift); + $self->{_args} = {@_}; - $self->{_args}{reject} = 1 if ! defined $self->{_args}{reject}; -}; + $self->{_args}{reject} = 1 if !defined $self->{_args}{reject}; +} sub hook_mail { my ($self, $transaction, $sender, %param) = @_; @@ -71,22 +71,22 @@ sub hook_mail { return DECLINED if $self->is_immune(); my @badmailfrom = $self->qp->config('badmailfrom'); - if ( defined $self->{_badmailfrom_config} ) { # testing + if (defined $self->{_badmailfrom_config}) { # testing @badmailfrom = @{$self->{_badmailfrom_config}}; - }; - return DECLINED if $self->is_immune_sender( $sender, \@badmailfrom ); + } + return DECLINED if $self->is_immune_sender($sender, \@badmailfrom); my $host = lc $sender->host; my $from = lc($sender->user) . '@' . $host; for my $config (@badmailfrom) { - $config =~ s/^\s+//g; # trim leading whitespace + $config =~ s/^\s+//g; # trim leading whitespace my ($bad, $reason) = split /\s+/, $config, 2; next unless $bad; - next unless $self->is_match( $from, $bad, $host ); + next unless $self->is_match($from, $bad, $host); $reason ||= "Your envelope sender is in my badmailfrom list"; - $self->adjust_karma( -1 ); - return $self->get_reject( $reason ); + $self->adjust_karma(-1); + return $self->get_reject($reason); } $self->log(LOGINFO, "pass"); @@ -94,46 +94,46 @@ sub hook_mail { } sub is_match { - my ( $self, $from, $bad, $host ) = @_; + my ($self, $from, $bad, $host) = @_; - if ( $bad =~ /[\/\^\$\*\+\!\%\?\\]/ ) { # it's a regexp - if ( $from =~ /$bad/ ) { + if ($bad =~ /[\/\^\$\*\+\!\%\?\\]/) { # it's a regexp + if ($from =~ /$bad/) { $self->log(LOGDEBUG, "badmailfrom pattern ($bad) match for $from"); return 1; - }; + } return; - }; + } $bad = lc $bad; - if ( $bad !~ m/\@/ ) { + if ($bad !~ m/\@/) { $self->log(LOGWARN, "badmailfrom: bad config: no \@ sign in $bad"); return; - }; - if ( substr($bad,0,1) eq '@' ) { + } + if (substr($bad, 0, 1) eq '@') { return 1 if $bad eq "\@$host"; return; - }; + } return if $bad ne $from; return 1; -}; +} sub is_immune_sender { - my ($self, $sender, $badmf ) = @_; + my ($self, $sender, $badmf) = @_; - if ( ! scalar @$badmf ) { + if (!scalar @$badmf) { $self->log(LOGDEBUG, 'skip, empty list'); return 1; - }; + } - if ( ! $sender || $sender->format eq '<>' ) { + if (!$sender || $sender->format eq '<>') { $self->log(LOGDEBUG, 'skip, null sender'); return 1; - }; + } - if ( ! $sender->host || ! $sender->user ) { + if (!$sender->host || !$sender->user) { $self->log(LOGDEBUG, 'skip, missing user or host'); return 1; - }; + } return; -}; +} diff --git a/plugins/badmailfromto b/plugins/badmailfromto index 351345a..efe46c4 100644 --- a/plugins/badmailfromto +++ b/plugins/badmailfromto @@ -21,27 +21,27 @@ use strict; use Qpsmtpd::Constants; sub hook_mail { - my ($self, $transaction, $sender, %param) = @_; + my ($self, $transaction, $sender, %param) = @_; my @badmailfromto = $self->qp->config("badmailfromto"); - return DECLINED if $self->is_sender_immune( $sender, \@badmailfromto ); + return DECLINED if $self->is_sender_immune($sender, \@badmailfromto); - my $host = lc $sender->host; - my $from = lc($sender->user) . '@' . $host; + my $host = lc $sender->host; + my $from = lc($sender->user) . '@' . $host; - for my $bad (@badmailfromto) { - $bad =~ s/^\s*(\S+).*/$1/; - next unless $bad; - $bad = lc $bad; - if ( $bad !~ m/\@/ ) { - $self->log(LOGWARN, 'bad config, no @ sign in '. $bad); - next; - }; - if ( $bad eq $from || (substr($bad,0,1) eq '@' && $bad eq "\@$host") ) { - $transaction->notes('badmailfromto', $bad); - }; - } - return (DECLINED); + for my $bad (@badmailfromto) { + $bad =~ s/^\s*(\S+).*/$1/; + next unless $bad; + $bad = lc $bad; + if ($bad !~ m/\@/) { + $self->log(LOGWARN, 'bad config, no @ sign in ' . $bad); + next; + } + if ($bad eq $from || (substr($bad, 0, 1) eq '@' && $bad eq "\@$host")) { + $transaction->notes('badmailfromto', $bad); + } + } + return (DECLINED); } sub hook_rcpt { @@ -52,32 +52,32 @@ sub hook_rcpt { return (DECLINED); }; - foreach ( $self->qp->config("badmailfromto") ) { + foreach ($self->qp->config("badmailfromto")) { my ($from, $to) = m/^\s*(\S+)\t(\S+).*/; return (DENY, "mail to $recipient not accepted here") - if lc($from) eq $sender && lc($to) eq $recipient; + if lc($from) eq $sender && lc($to) eq $recipient; } $self->log(LOGDEBUG, "pass, recipient not listed"); return (DECLINED); } sub is_sender_immune { - my ($self, $sender, $badmf ) = @_; + my ($self, $sender, $badmf) = @_; - if ( ! scalar @$badmf ) { + if (!scalar @$badmf) { $self->log(LOGDEBUG, 'skip, empty list'); return 1; - }; + } - if ( ! $sender || $sender->format eq '<>' ) { + if (!$sender || $sender->format eq '<>') { $self->log(LOGDEBUG, 'skip, null sender'); return 1; - }; + } - if ( ! $sender->host || ! $sender->user ) { + if (!$sender->host || !$sender->user) { $self->log(LOGDEBUG, 'skip, missing user or host'); return 1; - }; + } return; -}; +} diff --git a/plugins/badrcptto b/plugins/badrcptto index 3d15776..3069289 100644 --- a/plugins/badrcptto +++ b/plugins/badrcptto @@ -51,8 +51,8 @@ sub hook_rcpt { return (DECLINED) if $self->is_immune(); - my ($host, $to) = $self->get_host_and_to( $recipient ) - or return (DECLINED); + my ($host, $to) = $self->get_host_and_to($recipient) + or return (DECLINED); my @badrcptto = $self->qp->config("badrcptto") or do { $self->log(LOGINFO, "skip, empty config"); @@ -60,71 +60,72 @@ sub hook_rcpt { }; for my $line (@badrcptto) { - $line =~ s/^\s+//g; # trim leading whitespace + $line =~ s/^\s+//g; # trim leading whitespace my ($bad, $reason) = split /\s+/, $line, 2; - next if ! $bad; - if ( $self->is_match( $to, lc($bad), $host ) ) { - $self->adjust_karma( -2 ); - if ( $reason ) { + next if !$bad; + if ($self->is_match($to, lc($bad), $host)) { + $self->adjust_karma(-2); + if ($reason) { return (DENY, "mail to $bad not accepted here"); } else { - return Qpsmtpd::DSN->no_such_user("mail to $bad not accepted here"); + return Qpsmtpd::DSN->no_such_user( + "mail to $bad not accepted here"); } - }; + } } $self->log(LOGINFO, 'pass'); return (DECLINED); } sub is_match { - my ( $self, $to, $bad, $host ) = @_; + my ($self, $to, $bad, $host) = @_; - if ( $bad =~ /[\/\^\$\*\+\!\%\?\\]/ ) { # it's a regexp + if ($bad =~ /[\/\^\$\*\+\!\%\?\\]/) { # it's a regexp $self->log(LOGDEBUG, "badmailfrom pattern ($bad) match for $to"); - if ( $to =~ /$bad/i ) { + if ($to =~ /$bad/i) { $self->log(LOGINFO, 'fail: pattern match'); return 1; - }; + } return; - }; + } - if ( $bad !~ m/\@/ ) { + if ($bad !~ m/\@/) { $self->log(LOGERROR, "badrcptto: bad config: no \@ sign in $bad"); return; - }; + } $bad = lc $bad; $to = lc $to; - if ( substr($bad,0,1) eq '@' ) { - if ( $bad eq "\@$host" ) { + if (substr($bad, 0, 1) eq '@') { + if ($bad eq "\@$host") { $self->log(LOGINFO, 'fail: host match'); return 1; - }; + } return; - }; + } - if ( $bad eq $to ) { + if ($bad eq $to) { $self->log(LOGINFO, 'fail: rcpt match'); return 1; } return; -}; +} sub get_host_and_to { - my ( $self, $recipient ) = @_; + my ($self, $recipient) = @_; - if ( ! $recipient ) { + if (!$recipient) { $self->log(LOGERROR, 'skip: no recipient!'); return; - }; + } - if ( ! $recipient->host || ! $recipient->user ) { + if (!$recipient->host || !$recipient->user) { $self->log(LOGINFO, 'skip: missing host or user'); return; - }; + } my $host = lc $recipient->host; - return ( $host, lc($recipient->user) . '@' . $host ); -}; + return ($host, lc($recipient->user) . '@' . $host); +} diff --git a/plugins/bogus_bounce b/plugins/bogus_bounce index a05a5a2..8ab1362 100644 --- a/plugins/bogus_bounce +++ b/plugins/bogus_bounce @@ -40,23 +40,22 @@ Deny with a soft error code. =cut - sub register { my ($self, $qp) = (shift, shift); - if ( @_ % 2 ) { + if (@_ % 2) { $self->{_args}{action} = shift; } else { - $self->{_args} = { @_ }; - }; + $self->{_args} = {@_}; + } - if ( ! defined $self->{_args}{reject} ) { - $self->{_args}{reject} = 0; # legacy default - }; + if (!defined $self->{_args}{reject}) { + $self->{_args}{reject} = 0; # legacy default + } # we only need to check for deferral, default is DENY - if ( $self->{_args}{action} && $self->{_args}{action} =~ /soft/i ) { + if ($self->{_args}{action} && $self->{_args}{action} =~ /soft/i) { $self->{_args}{reject_type} = 'temp'; } } @@ -68,10 +67,10 @@ sub hook_data_post { # Find the sender, quit processing if this isn't a bounce. # my $sender = $transaction->sender->address || undef; - if ( $sender && $sender ne '<>') { + if ($sender && $sender ne '<>') { $self->log(LOGINFO, "pass, not a null sender"); return DECLINED; - }; + } # at this point we know it is a bounce, via the null-envelope. # @@ -80,16 +79,19 @@ sub hook_data_post { my @to = $transaction->recipients || (); if (scalar @to != 1) { $self->log(LOGINFO, "fail, bogus bounce to: " . join(',', @to)); - return $self->get_reject( "fail, this bounce message does not have 1 recipient" ); - }; + return $self->get_reject( + "fail, this bounce message does not have 1 recipient"); + } # validate that Return-Path is empty, RFC 3834 my $rp = $transaction->header->get('Return-Path'); - if ( $rp && $rp ne '<>' ) { - $self->log(LOGINFO, "fail, bounce messages must not have a Return-Path"); - return $self->get_reject( "a bounce return path must be empty (RFC 3834)" ); - }; + if ($rp && $rp ne '<>') { + $self->log(LOGINFO, + "fail, bounce messages must not have a Return-Path"); + return $self->get_reject( + "a bounce return path must be empty (RFC 3834)"); + } $self->log(LOGINFO, "pass, single recipient, empty Return-Path"); return DECLINED; diff --git a/plugins/connection_time b/plugins/connection_time index 2c9d8f7..74ed735 100644 --- a/plugins/connection_time +++ b/plugins/connection_time @@ -32,44 +32,47 @@ use Time::HiRes qw(gettimeofday tv_interval); sub register { my ($self, $qp) = (shift, shift); - if ( @_ == 1 ) { # backwards compatible + if (@_ == 1) { # backwards compatible $self->{_args}{loglevel} = shift; - if ( $self->{_args}{loglevel} =~ /\D/ ) { - $self->{_args}{loglevel} = Qpsmtpd::Constants::log_level($self->{_args}{loglevel}); - }; + if ($self->{_args}{loglevel} =~ /\D/) { + $self->{_args}{loglevel} = + Qpsmtpd::Constants::log_level($self->{_args}{loglevel}); + } $self->{_args}{loglevel} ||= 6; } - elsif ( @_ % 2 ) { - $self->log(LOGERROR, "invalid arguments"); + elsif (@_ % 2) { + $self->log(LOGERROR, "invalid arguments"); } else { - $self->{_args} = { @_ }; # named args, inherits loglevel - }; -# pre-connection is not available in the tcpserver deployment model. -# duplicate the handler, so it works both ways with no redudant methods + $self->{_args} = {@_}; # named args, inherits loglevel + } + + # pre-connection is not available in the tcpserver deployment model. + # duplicate the handler, so it works both ways with no redudant methods $self->register_hook('pre-connection', 'connect_handler'); $self->register_hook('connect', 'connect_handler'); } sub connect_handler { my $self = shift; - return DECLINED if ( $self->hook_name eq 'connect' && defined $self->{_connection_start} ); + return DECLINED + if ($self->hook_name eq 'connect' && defined $self->{_connection_start}); $self->{_connection_start} = [gettimeofday]; - $self->log(LOGDEBUG, "started at " . scalar gettimeofday ); + $self->log(LOGDEBUG, "started at " . scalar gettimeofday); return (DECLINED); } sub hook_post_connection { my $self = shift; - if ( ! $self->{_connection_start} ) { + if (!$self->{_connection_start}) { $self->log(LOGERROR, "Start time not set?!"); return (DECLINED); - }; + } - my $elapsed = tv_interval( $self->{_connection_start}, [gettimeofday] ); + my $elapsed = tv_interval($self->{_connection_start}, [gettimeofday]); - $self->log(LOGINFO, sprintf "%.3f s.", $elapsed ); + $self->log(LOGINFO, sprintf "%.3f s.", $elapsed); return (DECLINED); } diff --git a/plugins/content_log b/plugins/content_log index 696c9e0..3ac6f4d 100644 --- a/plugins/content_log +++ b/plugins/content_log @@ -6,20 +6,20 @@ use POSIX qw:strftime:; sub hook_data_post { - my ($self, $transaction) = @_; + my ($self, $transaction) = @_; - # as a decent default, log on a per-day-basis - my $date = strftime("%Y%m%d",localtime(time)); - open(my $out,">>mail/$date") - or return(DECLINED,"Could not open log file.. continuing anyway"); + # as a decent default, log on a per-day-basis + my $date = strftime("%Y%m%d", localtime(time)); + open(my $out, ">>mail/$date") + or return (DECLINED, "Could not open log file.. continuing anyway"); - $transaction->header->print($out); - $transaction->body_resetpos; - while (my $line = $transaction->body_getline) { - print $out $line; - } + $transaction->header->print($out); + $transaction->body_resetpos; + while (my $line = $transaction->body_getline) { + print $out $line; + } - close $out; + close $out; - return (DECLINED, "successfully saved message.. continuing"); + return (DECLINED, "successfully saved message.. continuing"); } diff --git a/plugins/count_unrecognized_commands b/plugins/count_unrecognized_commands index 5cb6d69..eb02cc0 100644 --- a/plugins/count_unrecognized_commands +++ b/plugins/count_unrecognized_commands @@ -22,28 +22,30 @@ use warnings; use Qpsmtpd::Constants; sub register { - my ($self, $qp ) = (shift, shift); + my ($self, $qp) = (shift, shift); $self->{_unrec_cmd_max} = shift || 4; - if ( scalar @_ ) { + if (scalar @_) { $self->log(LOGWARN, "Ignoring additional arguments."); } } sub hook_unrecognized_command { - my ($self, $cmd) = @_[0,2]; - - my $count = $self->connection->notes('unrec_cmd_count') || 0; - $count = $count + 1; - $self->connection->notes('unrec_cmd_count', $count); + my ($self, $cmd) = @_[0, 2]; - if ( $count < $self->{_unrec_cmd_max} ) { + my $count = $self->connection->notes('unrec_cmd_count') || 0; + $count = $count + 1; + $self->connection->notes('unrec_cmd_count', $count); + + if ($count < $self->{_unrec_cmd_max}) { $self->log(LOGINFO, "'$cmd', ($count)"); return DECLINED; - }; + } $self->log(LOGINFO, "fail, '$cmd' ($count)"); - return (DENY_DISCONNECT, "Closing connection, $count unrecognized commands. Perhaps you should read RFC 2821?" ); + return (DENY_DISCONNECT, +"Closing connection, $count unrecognized commands. Perhaps you should read RFC 2821?" + ); } diff --git a/plugins/dkim b/plugins/dkim index 2b5b5d4..39c6759 100644 --- a/plugins/dkim +++ b/plugins/dkim @@ -172,8 +172,8 @@ use Socket qw(:DEFAULT :crlf); sub init { my ($self, $qp) = (shift, shift); - $self->{_args} = { @_ }; - $self->{_args}{reject} = 1 if ! defined $self->{_args}{reject}; + $self->{_args} = {@_}; + $self->{_args}{reject} = 1 if !defined $self->{_args}{reject}; $self->{_args}{reject_type} ||= 'perm'; } @@ -181,52 +181,55 @@ sub register { my $self = shift; # Mail::DKIM::TextWrap - nice idea, clients get mangled headers though - foreach my $mod ( qw/ Mail::DKIM::Verifier Mail::DKIM::Signer / ) { + foreach my $mod (qw/ Mail::DKIM::Verifier Mail::DKIM::Signer /) { eval "use $mod"; - if ( $@ ) { + if ($@) { warn "error, plugin disabled, could not load $mod\n"; - $self->log(LOGERROR, "skip, plugin disabled, is Mail::DKIM installed?"); + $self->log(LOGERROR, + "skip, plugin disabled, is Mail::DKIM installed?"); return; - }; - }; + } + } $self->register_hook('data_post', 'data_post_handler'); -}; +} sub data_post_handler { my ($self, $transaction) = @_; - if ( $self->qp->connection->relay_client() ) { + if ($self->qp->connection->relay_client()) { + # this is an authenticated user sending a message. - return $self->sign_it( $transaction ); - }; + return $self->sign_it($transaction); + } return DECLINED if $self->is_immune(); - return $self->validate_it( $transaction ); -}; + return $self->validate_it($transaction); +} sub validate_it { my ($self, $transaction) = @_; # Incoming message, perform DKIM validation my $dkim = Mail::DKIM::Verifier->new() or do { - $self->log(LOGERROR, "error, could not instantiate a new Mail::DKIM::Verifier"); + $self->log(LOGERROR, + "error, could not instantiate a new Mail::DKIM::Verifier"); return DECLINED; }; - $self->send_message_to_dkim( $dkim, $transaction ); + $self->send_message_to_dkim($dkim, $transaction); my $result = $dkim->result; - my $mess = $self->get_details( $dkim ); + my $mess = $self->get_details($dkim); - foreach my $t ( qw/ pass fail invalid temperror none / ) { + foreach my $t (qw/ pass fail invalid temperror none /) { next if $t ne $result; my $handler = 'handle_sig_' . $t; $self->log(LOGDEBUG, "dispatching $result to $handler"); - return $self->$handler( $dkim, $mess ); - }; + return $self->$handler($dkim, $mess); + } - $self->log( LOGERROR, "error, unknown result: $result, $mess" ); + $self->log(LOGERROR, "error, unknown result: $result, $mess"); return DECLINED; } @@ -237,277 +240,276 @@ sub sign_it { my $selector = $self->get_selector($keydir); my $dkim = Mail::DKIM::Signer->new( - Algorithm => "rsa-sha256", - Method => "relaxed", - Domain => $domain, - Selector => $selector, - KeyFile => "$keydir/private", - ); + Algorithm => "rsa-sha256", + Method => "relaxed", + Domain => $domain, + Selector => $selector, + KeyFile => "$keydir/private", + ); - $self->send_message_to_dkim( $dkim, $transaction ); + $self->send_message_to_dkim($dkim, $transaction); - my $signature = $dkim->signature; # what is the signature result? - $self->qp->transaction->header->add( - 'DKIM-Signature', $signature->as_string, 0 ); + my $signature = $dkim->signature; # what is the signature result? + $self->qp->transaction->header->add('DKIM-Signature', + $signature->as_string, 0); - $self->log(LOGINFO, "pass, we signed the message" ); + $self->log(LOGINFO, "pass, we signed the message"); return DECLINED; -}; +} sub get_details { - my ($self, $dkim ) = @_; + my ($self, $dkim) = @_; my @data; my $string; - push @data, "domain: " . $dkim->signature->domain if $dkim->signature; + push @data, "domain: " . $dkim->signature->domain if $dkim->signature; push @data, "selector: " . $dkim->signature->selector if $dkim->signature; - push @data, "result: " . $dkim->result_detail if $dkim->result_detail; + push @data, "result: " . $dkim->result_detail if $dkim->result_detail; - foreach my $policy ( $dkim->policies ) { - next if ! $policy; + foreach my $policy ($dkim->policies) { + next if !$policy; push @data, "policy: " . $policy->as_string; - push @data, "name: " . $policy->name; - push @data, "policy_location: " . $policy->location if $policy->location; + push @data, "name: " . $policy->name; + push @data, "policy_location: " . $policy->location + if $policy->location; my $policy_result; $policy_result = $policy->apply($dkim); $policy_result or next; push @data, "policy_result: " . $policy_result if $policy_result; - }; + } return join(', ', @data); -}; +} sub handle_sig_fail { - my ( $self, $dkim, $mess ) = @_; + my ($self, $dkim, $mess) = @_; - $self->adjust_karma( -1 ); - return $self->get_reject( "DKIM signature invalid: " . $dkim->result_detail, $mess ); -}; + $self->adjust_karma(-1); + return + $self->get_reject("DKIM signature invalid: " . $dkim->result_detail, + $mess); +} sub handle_sig_temperror { - my ( $self, $dkim, $mess ) = @_; + my ($self, $dkim, $mess) = @_; - $self->log(LOGINFO, "error, $mess" ); - return ( DENYSOFT, "Please try again later - $dkim->result_detail" ); -}; + $self->log(LOGINFO, "error, $mess"); + return (DENYSOFT, "Please try again later - $dkim->result_detail"); +} sub handle_sig_invalid { - my ( $self, $dkim, $mess ) = @_; + my ($self, $dkim, $mess) = @_; - my ( $prs, $policies) = $self->get_policy_results( $dkim ); + my ($prs, $policies) = $self->get_policy_results($dkim); - foreach my $policy ( @$policies ) { - if ( $policy->signall && ! $policy->is_implied_default_policy ) { - $self->log(LOGINFO, $mess ); - return $self->get_reject( - "invalid DKIM signature with sign-all policy", - "invalid signature, sign-all policy" - ); + foreach my $policy (@$policies) { + if ($policy->signall && !$policy->is_implied_default_policy) { + $self->log(LOGINFO, $mess); + return + $self->get_reject("invalid DKIM signature with sign-all policy", + "invalid signature, sign-all policy"); } - }; + } - $self->adjust_karma( -1 ); - $self->log(LOGINFO, $mess ); + $self->adjust_karma(-1); + $self->log(LOGINFO, $mess); - if ( $prs->{accept} ) { - $self->add_header( $mess ); - $self->log( LOGERROR, "error, invalid signature but accept policy!?" ); + if ($prs->{accept}) { + $self->add_header($mess); + $self->log(LOGERROR, "error, invalid signature but accept policy!?"); return DECLINED; } - elsif ( $prs->{neutral} ) { - $self->add_header( $mess ); - $self->log( LOGERROR, "error, invalid signature but neutral policy?!" ); + elsif ($prs->{neutral}) { + $self->add_header($mess); + $self->log(LOGERROR, "error, invalid signature but neutral policy?!"); return DECLINED; } - elsif ( $prs->{reject} ) { - return $self->get_reject( - "invalid DKIM signature: " . $dkim->result_detail, - "fail, invalid signature, reject policy" - ); + elsif ($prs->{reject}) { + return + $self->get_reject("invalid DKIM signature: " . $dkim->result_detail, + "fail, invalid signature, reject policy"); } # this should never happen - $self->log( LOGINFO, "error, invalid signature, unhandled" ); - $self->add_header( $mess ); + $self->log(LOGINFO, "error, invalid signature, unhandled"); + $self->add_header($mess); return DECLINED; -}; +} sub handle_sig_pass { - my ( $self, $dkim, $mess ) = @_; + my ($self, $dkim, $mess) = @_; - $self->save_signatures_to_note( $dkim ); + $self->save_signatures_to_note($dkim); - my ($prs) = $self->get_policy_results( $dkim ); + my ($prs) = $self->get_policy_results($dkim); - if ( $prs->{accept} ) { - $self->add_header( $mess ); + if ($prs->{accept}) { + $self->add_header($mess); $self->log(LOGINFO, "pass, valid signature, accept policy"); - $self->adjust_karma( 1 ); + $self->adjust_karma(1); return DECLINED; } - elsif ( $prs->{neutral} ) { - $self->add_header( $mess ); + elsif ($prs->{neutral}) { + $self->add_header($mess); $self->log(LOGINFO, "pass, valid signature, neutral policy"); - $self->log(LOGINFO, $mess ); + $self->log(LOGINFO, $mess); return DECLINED; } - elsif ( $prs->{reject} ) { - $self->log(LOGINFO, $mess ); - $self->adjust_karma( -1 ); - return $self->get_reject( - "DKIM signature valid but fails policy, $mess", - "fail, valid sig, reject policy" - ); - }; + elsif ($prs->{reject}) { + $self->log(LOGINFO, $mess); + $self->adjust_karma(-1); + return + $self->get_reject("DKIM signature valid but fails policy, $mess", + "fail, valid sig, reject policy"); + } # this should never happen - $self->add_header( $mess ); - $self->log(LOGERROR, "pass, valid sig, no policy results" ); - $self->log(LOGINFO, $mess ); + $self->add_header($mess); + $self->log(LOGERROR, "pass, valid sig, no policy results"); + $self->log(LOGINFO, $mess); return DECLINED; -}; +} sub handle_sig_none { - my ( $self, $dkim, $mess ) = @_; + my ($self, $dkim, $mess) = @_; - my ( $prs, $policies) = $self->get_policy_results( $dkim ); + my ($prs, $policies) = $self->get_policy_results($dkim); - foreach my $policy ( @$policies ) { - if ( $policy->signall && ! $policy->is_implied_default_policy ) { - $self->log(LOGINFO, $mess ); - return $self->get_reject( - "no DKIM signature with sign-all policy", - "no signature, sign-all policy" - ); + foreach my $policy (@$policies) { + if ($policy->signall && !$policy->is_implied_default_policy) { + $self->log(LOGINFO, $mess); + return + $self->get_reject("no DKIM signature with sign-all policy", + "no signature, sign-all policy"); } - }; + } - if ( $prs->{accept} ) { - $self->log( LOGINFO, "pass, no signature, accept policy" ); + if ($prs->{accept}) { + $self->log(LOGINFO, "pass, no signature, accept policy"); return DECLINED; } - elsif ( $prs->{neutral} ) { - $self->log( LOGINFO, "pass, no signature, neutral policy" ); + elsif ($prs->{neutral}) { + $self->log(LOGINFO, "pass, no signature, neutral policy"); return DECLINED; } - elsif ( $prs->{reject} ) { - $self->log(LOGINFO, $mess ); + elsif ($prs->{reject}) { + $self->log(LOGINFO, $mess); $self->get_reject( - "no DKIM signature, policy says reject: " . $dkim->result_detail, - "no signature, reject policy" - ); - }; + "no DKIM signature, policy says reject: " . $dkim->result_detail, + "no signature, reject policy"); + } # should never happen - $self->log( LOGINFO, "error, no signature, no policy" ); - $self->log(LOGINFO, $mess ); + $self->log(LOGINFO, "error, no signature, no policy"); + $self->log(LOGINFO, $mess); return DECLINED; -}; +} sub get_keydir { my ($self, $transaction) = @_; my $domain = $transaction->sender->host; - my $dir = "config/dkim/$domain"; + my $dir = "config/dkim/$domain"; - if ( ! -e $dir ) { # the dkim key dir doesn't exist - my @labels = split /\./, $domain; # split the domain into labels - while ( @labels > 1 ) { - shift @labels; # remove the first label (ie: www) - my $zone = join '.', @labels; # reassemble the labels - if ( -e "config/dkim/$zone" ) { # if the directory exists - $dir = "config/dkim/$zone"; # use the parent domain's key + if (!-e $dir) { # the dkim key dir doesn't exist + my @labels = split /\./, $domain; # split the domain into labels + while (@labels > 1) { + shift @labels; # remove the first label (ie: www) + my $zone = join '.', @labels; # reassemble the labels + if (-e "config/dkim/$zone") { # if the directory exists + $dir = "config/dkim/$zone"; # use the parent domain's key $self->log(LOGINFO, "info, using $zone key for $domain"); - }; - }; - }; + } + } + } - if ( -l $dir ) { + if (-l $dir) { $dir = readlink($dir); - $dir = "config/dkim/$dir" if $dir !~ /\//; # no /, relative path + $dir = "config/dkim/$dir" if $dir !~ /\//; # no /, relative path ($domain) = (split /\//, $dir)[-1]; - }; + } - if ( ! -d $dir ) { + if (!-d $dir) { $self->log(LOGINFO, "skip, DKIM not configured for $domain"); return; - }; - if ( ! -r $dir ) { + } + if (!-r $dir) { $self->log(LOGINFO, "error, unable to read key from $dir"); return; - }; - if ( ! -r "$dir/private" ) { + } + if (!-r "$dir/private") { $self->log(LOGINFO, "error, unable to read dkim key from $dir/private"); return; - }; + } return ($domain, $dir); -}; +} sub save_signatures_to_note { - my ( $self, $dkim ) = @_; + my ($self, $dkim) = @_; - foreach my $sig ( $dkim->signatures ) { + foreach my $sig ($dkim->signatures) { next if $sig->result ne 'pass'; my $doms = $self->connection->notes('dkim_pass_domains') || []; push @$doms, $sig->domain; $self->connection->notes('dkim_pass_domains', $doms); - $self->log(LOGINFO, "info, added " . $sig->domain ); - }; -}; + $self->log(LOGINFO, "info, added " . $sig->domain); + } +} sub send_message_to_dkim { my ($self, $dkim, $transaction) = @_; - foreach ( split ( /\n/s, $transaction->header->as_string ) ) { + foreach (split(/\n/s, $transaction->header->as_string)) { $_ =~ s/\r?$//s; - eval { $dkim->PRINT ( $_ . CRLF ); }; - $self->log(LOGERROR, $@ ) if $@; + eval { $dkim->PRINT($_ . CRLF); }; + $self->log(LOGERROR, $@) if $@; } $transaction->body_resetpos; while (my $line = $transaction->body_getline) { chomp $line; $line =~ s/\015$//; - eval { $dkim->PRINT($line . CRLF ); }; - $self->log(LOGERROR, $@ ) if $@; - }; + eval { $dkim->PRINT($line . CRLF); }; + $self->log(LOGERROR, $@) if $@; + } $dkim->CLOSE; -}; +} sub get_policies { my ($self, $dkim) = @_; my @policies; eval { @policies = $dkim->policies }; - $self->log(LOGERROR, $@ ) if $@; + $self->log(LOGERROR, $@) if $@; return @policies; -}; +} sub get_policy_results { - my ( $self, $dkim ) = @_; + my ($self, $dkim) = @_; my %prs; - my @policies = $self->get_policies( $dkim ); + my @policies = $self->get_policies($dkim); - foreach my $policy ( @policies ) { + foreach my $policy (@policies) { my $policy_result; eval { $policy_result = $policy->apply($dkim); }; # accept, reject, neutral - if ( $@ ) { - $self->log(LOGERROR, $@ ); - }; + if ($@) { + $self->log(LOGERROR, $@); + } $prs{$policy_result}++ if $policy_result; - }; + } return \%prs, \@policies; -}; +} sub get_selector { my ($self, $keydir) = @_; open my $SFH, '<', "$keydir/selector" or do { - $self->log(LOGINFO, "error, unable to read selector from $keydir/selector"); + $self->log(LOGINFO, + "error, unable to read selector from $keydir/selector"); return DECLINED; }; my $selector = <$SFH>; @@ -515,13 +517,13 @@ sub get_selector { close $SFH; $self->log(LOGINFO, "info, selector: $selector"); return $selector; -}; +} sub add_header { my $self = shift; my $header = shift or return; -# consider adding Authentication-Results header, (RFC 5451) - $self->qp->transaction->header->add( 'X-DKIM-Authentication', $header, 0 ); + # consider adding Authentication-Results header, (RFC 5451) + $self->qp->transaction->header->add('X-DKIM-Authentication', $header, 0); } diff --git a/plugins/dmarc b/plugins/dmarc index c74776b..b3896d3 100644 --- a/plugins/dmarc +++ b/plugins/dmarc @@ -104,261 +104,267 @@ use Qpsmtpd::Constants; sub init { my ($self, $qp) = (shift, shift); - $self->{_args} = { @_ }; - $self->{_args}{reject} = 1 if ! defined $self->{_args}{reject}; + $self->{_args} = {@_}; + $self->{_args}{reject} = 1 if !defined $self->{_args}{reject}; $self->{_args}{reject_type} ||= 'perm'; - $self->{_args}{p_vals} = { map { $_ => 1 } qw/ none reject quarantine / }; + $self->{_args}{p_vals} = {map { $_ => 1 } qw/ none reject quarantine /}; } sub register { my $self = shift; $self->register_hook('data_post', 'data_post_handler'); -}; +} sub data_post_handler { my ($self, $transaction) = @_; return DECLINED if $self->is_immune(); -# 11.1. Extract Author Domain + # 11.1. Extract Author Domain # TODO: check exists_in_dns result, and possibly reject here if domain non-exist - my $from_host = $self->get_from_host( $transaction ) or return DECLINED; - if ( ! $self->exists_in_dns( $from_host ) ) { - my $org_host = $self->get_organizational_domain( $from_host ); - if ( ! $self->exists_in_dns( $org_host ) ) { - $self->log( LOGINFO, "fail, domain/org not in DNS" ); + my $from_host = $self->get_from_host($transaction) or return DECLINED; + if (!$self->exists_in_dns($from_host)) { + my $org_host = $self->get_organizational_domain($from_host); + if (!$self->exists_in_dns($org_host)) { + $self->log(LOGINFO, "fail, domain/org not in DNS"); + #return $self->get_reject(); return DECLINED; - }; - }; + } + } -# 11.2. Determine Handling Policy - my $policy = $self->discover_policy( $from_host ) - or return DECLINED; + # 11.2. Determine Handling Policy + my $policy = $self->discover_policy($from_host) + or return DECLINED; -# 3. Perform DKIM signature verification checks. A single email may -# contain multiple DKIM signatures. The results of this step are -# passed to the remainder of the algorithm and MUST include the -# value of the "d=" tag from all DKIM signatures that successfully -# validated. + # 3. Perform DKIM signature verification checks. A single email may + # contain multiple DKIM signatures. The results of this step are + # passed to the remainder of the algorithm and MUST include the + # value of the "d=" tag from all DKIM signatures that successfully + # validated. my $dkim_sigs = $self->connection->notes('dkim_pass_domains') || []; -# 4. Perform SPF validation checks. The results of this step are -# passed to the remainder of the algorithm and MUST include the -# domain name from the RFC5321.MailFrom if SPF evaluation returned -# a "pass" result. + # 4. Perform SPF validation checks. The results of this step are + # passed to the remainder of the algorithm and MUST include the + # domain name from the RFC5321.MailFrom if SPF evaluation returned + # a "pass" result. my $spf_dom = $transaction->notes('spf_pass_host'); -# 5. Conduct identifier alignment checks. With authentication checks -# and policy discovery performed, the Mail Receiver checks if -# Authenticated Identifiers fall into alignment as decribed in -# Section 4. If one or more of the Authenticated Identifiers align -# with the RFC5322.From domain, the message is considered to pass -# the DMARC mechanism check. All other conditions (authentication -# failures, identifier mismatches) are considered to be DMARC -# mechanism check failures. - foreach ( @$dkim_sigs ) { - if ( $_ eq $from_host ) { # strict alignment + # 5. Conduct identifier alignment checks. With authentication checks + # and policy discovery performed, the Mail Receiver checks if + # Authenticated Identifiers fall into alignment as decribed in + # Section 4. If one or more of the Authenticated Identifiers align + # with the RFC5322.From domain, the message is considered to pass + # the DMARC mechanism check. All other conditions (authentication + # failures, identifier mismatches) are considered to be DMARC + # mechanism check failures. + foreach (@$dkim_sigs) { + if ($_ eq $from_host) { # strict alignment $self->log(LOGINFO, "pass, DKIM alignment"); - $self->adjust_karma( 2 ); # big karma boost + $self->adjust_karma(2); # big karma boost return DECLINED; - }; - }; + } + } - if ( $spf_dom && $spf_dom eq $from_host ) { - $self->adjust_karma( 2 ); # big karma boost + if ($spf_dom && $spf_dom eq $from_host) { + $self->adjust_karma(2); # big karma boost $self->log(LOGINFO, "pass, SPF alignment"); return DECLINED; - }; + } -# 6. Apply policy. Emails that fail the DMARC mechanism check are -# disposed of in accordance with the discovered DMARC policy of the -# Domain Owner. See Section 6.2 for details. + # 6. Apply policy. Emails that fail the DMARC mechanism check are + # disposed of in accordance with the discovered DMARC policy of the + # Domain Owner. See Section 6.2 for details. $self->log(LOGINFO, "skip, NEED RELAXED alignment"); return DECLINED; -}; +} sub discover_policy { my ($self, $from_host) = @_; -# 1. Mail Receivers MUST query the DNS for a DMARC TXT record at the -# DNS domain matching the one found in the RFC5322.From domain in -# the message. A possibly empty set of records is returned. - my @matches = $self->fetch_dmarc_record($from_host); # 2. within - if ( 0 == scalar @matches ) { -# 3. If the set is now empty, the Mail Receiver MUST query the DNS for -# a DMARC TXT record at the DNS domain matching the Organizational -# Domain in place of the RFC5322.From domain in the message (if -# different). This record can contain policy to be asserted for -# subdomains of the Organizational Domain. + # 1. Mail Receivers MUST query the DNS for a DMARC TXT record at the + # DNS domain matching the one found in the RFC5322.From domain in + # the message. A possibly empty set of records is returned. + my @matches = $self->fetch_dmarc_record($from_host); # 2. within + if (0 == scalar @matches) { - my $org_dom = $self->get_organizational_domain( $from_host ) or return; - if ( $org_dom eq $from_host ) { - $self->log( LOGINFO, "skip, no policy for $from_host (same org)" ); + # 3. If the set is now empty, the Mail Receiver MUST query the DNS for + # a DMARC TXT record at the DNS domain matching the Organizational + # Domain in place of the RFC5322.From domain in the message (if + # different). This record can contain policy to be asserted for + # subdomains of the Organizational Domain. + + my $org_dom = $self->get_organizational_domain($from_host) or return; + if ($org_dom eq $from_host) { + $self->log(LOGINFO, "skip, no policy for $from_host (same org)"); return; - }; + } @matches = $self->fetch_dmarc_record($org_dom); - if ( 0 == scalar @matches ) { - $self->log( LOGINFO, "skip, no policy for $from_host" ); + if (0 == scalar @matches) { + $self->log(LOGINFO, "skip, no policy for $from_host"); return; - }; - }; + } + } -# 4. Records that do not include a "v=" tag that identifies the -# current version of DMARC are discarded. + # 4. Records that do not include a "v=" tag that identifies the + # current version of DMARC are discarded. @matches = grep /v=DMARC1/i, @matches; - if ( 0 == scalar @matches ) { - $self->log( LOGINFO, "skip, no valid record for $from_host" ); + if (0 == scalar @matches) { + $self->log(LOGINFO, "skip, no valid record for $from_host"); return; - }; + } -# 5. If the remaining set contains multiple records, processing -# terminates and the Mail Receiver takes no action. - if ( @matches > 1 ) { - $self->log( LOGINFO, "skip, too many records" ); + # 5. If the remaining set contains multiple records, processing + # terminates and the Mail Receiver takes no action. + if (@matches > 1) { + $self->log(LOGINFO, "skip, too many records"); return; - }; + } -# 6. If a retrieved policy record does not contain a valid "p" tag, or -# contains an "sp" tag that is not valid, then: - my %policy = $self->parse_policy( $matches[0] ); - if ( ! $self->has_valid_p(\%policy) || $self->has_invalid_sp(\%policy) ) { + # 6. If a retrieved policy record does not contain a valid "p" tag, or + # contains an "sp" tag that is not valid, then: + my %policy = $self->parse_policy($matches[0]); + if (!$self->has_valid_p(\%policy) || $self->has_invalid_sp(\%policy)) { -# A. if an "rua" tag is present and contains at least one -# syntactically valid reporting URI, the Mail Receiver SHOULD -# act as if a record containing a valid "v" tag and "p=none" -# was retrieved, and continue processing; -# B. otherwise, the Mail Receiver SHOULD take no action. + # A. if an "rua" tag is present and contains at least one + # syntactically valid reporting URI, the Mail Receiver SHOULD + # act as if a record containing a valid "v" tag and "p=none" + # was retrieved, and continue processing; + # B. otherwise, the Mail Receiver SHOULD take no action. my $rua = $policy{rua}; - if ( ! $rua || ! $self->has_valid_reporting_uri($rua) ) { - $self->log( LOGINFO, "skip, no valid reporting rua" ); + if (!$rua || !$self->has_valid_reporting_uri($rua)) { + $self->log(LOGINFO, "skip, no valid reporting rua"); return; - }; + } $policy{v} = 'DMARC1'; $policy{p} = 'none'; - }; + } return \%policy; -}; +} sub has_valid_p { my ($self, $policy) = @_; return 1 if $self->{_args}{p_vals}{$policy}; return 0; -}; +} sub has_invalid_sp { my ($self, $policy) = @_; - return 0 if ! $self->{_args}{p_vals}{$policy}; + return 0 if !$self->{_args}{p_vals}{$policy}; return 1; -}; +} sub has_valid_reporting_uri { my ($self, $rua) = @_; return 1 if 'mailto:' eq lc substr($rua, 0, 7); return 0; -}; +} sub get_organizational_domain { my ($self, $from_host) = @_; -# 1. Acquire a "public suffix" list, i.e., a list of DNS domain -# names reserved for registrations. http://publicsuffix.org/list/ -# $self->qp->config('public_suffix_list') + # 1. Acquire a "public suffix" list, i.e., a list of DNS domain + # names reserved for registrations. http://publicsuffix.org/list/ + # $self->qp->config('public_suffix_list') -# 2. Break the subject DNS domain name into a set of "n" ordered -# labels. Number these labels from right-to-left; e.g. for -# "example.com", "com" would be label 1 and "example" would be -# label 2.; + # 2. Break the subject DNS domain name into a set of "n" ordered + # labels. Number these labels from right-to-left; e.g. for + # "example.com", "com" would be label 1 and "example" would be + # label 2.; my @labels = reverse split /\./, $from_host; -# 3. Search the public suffix list for the name that matches the -# largest number of labels found in the subject DNS domain. Let -# that number be "x". + # 3. Search the public suffix list for the name that matches the + # largest number of labels found in the subject DNS domain. Let + # that number be "x". my $greatest = 0; - for ( my $i = 0; $i <= scalar @labels; $i++ ) { - next if ! $labels[$i]; - my $tld = join '.', reverse( (@labels)[0..$i] ); -# $self->log( LOGINFO, "i: $i, $tld" ); -#warn "i: $i - tld: $tld\n"; - if ( grep /$tld/, $self->qp->config('public_suffix_list') ) { + for (my $i = 0 ; $i <= scalar @labels ; $i++) { + next if !$labels[$i]; + my $tld = join '.', reverse((@labels)[0 .. $i]); + + # $self->log( LOGINFO, "i: $i, $tld" ); + #warn "i: $i - tld: $tld\n"; + if (grep /$tld/, $self->qp->config('public_suffix_list')) { $greatest = $i + 1; - }; - }; + } + } - return $from_host if $greatest == scalar @labels; # same + return $from_host if $greatest == scalar @labels; # same -# 4. Construct a new DNS domain name using the name that matched -# from the public suffix list and prefixing to it the "x+1"th -# label from the subject domain. This new name is the -# Organizational Domain. - return join '.', reverse( (@labels)[0..$greatest]); -}; + # 4. Construct a new DNS domain name using the name that matched + # from the public suffix list and prefixing to it the "x+1"th + # label from the subject domain. This new name is the + # Organizational Domain. + return join '.', reverse((@labels)[0 .. $greatest]); +} sub exists_in_dns { my ($self, $domain) = @_; my $res = $self->init_resolver(); - my $query = $res->send( $domain, 'NS' ) or do { - if ( $res->errorstring eq 'NXDOMAIN' ) { - $self->log( LOGDEBUG, "fail, non-existent domain: $domain" ); + my $query = $res->send($domain, 'NS') or do { + if ($res->errorstring eq 'NXDOMAIN') { + $self->log(LOGDEBUG, "fail, non-existent domain: $domain"); return; - }; - $self->log( LOGINFO, "error, looking up NS for $domain: " . $res->errorstring ); + } + $self->log(LOGINFO, + "error, looking up NS for $domain: " . $res->errorstring); return; }; my @matches; for my $rr ($query->answer) { next if $rr->type ne 'NS'; push @matches, $rr->nsdname; - }; - if ( 0 == scalar @matches ) { - $self->log( LOGDEBUG, "fail, zero NS for $domain" ); - }; + } + if (0 == scalar @matches) { + $self->log(LOGDEBUG, "fail, zero NS for $domain"); + } return @matches; -}; +} sub fetch_dmarc_record { my ($self, $zone) = @_; my $res = $self->init_resolver(); - my $query = $res->send( '_dmarc.' . $zone, 'TXT' ); + my $query = $res->send('_dmarc.' . $zone, 'TXT'); my @matches; for my $rr ($query->answer) { next if $rr->type ne 'TXT'; -# 2. Records that do not start with a "v=" tag that identifies the -# current version of DMARC are discarded. - next if 'v=' ne substr( $rr->txtdata, 0, 2); - $self->log( LOGINFO, $rr->txtdata ); + + # 2. Records that do not start with a "v=" tag that identifies the + # current version of DMARC are discarded. + next if 'v=' ne substr($rr->txtdata, 0, 2); + $self->log(LOGINFO, $rr->txtdata); push @matches, join('', $rr->txtdata); - }; + } return @matches; -}; +} sub get_from_host { my ($self, $transaction) = @_; my $from = $transaction->header->get('From') or do { - $self->log( LOGINFO, "error, unable to retrieve From header!" ); + $self->log(LOGINFO, "error, unable to retrieve From header!"); return; }; - my ($from_host) = (split /@/, $from)[-1]; # grab everything after the @ - ($from_host) = split /\s+/, $from_host; # remove any trailing cruft + my ($from_host) = (split /@/, $from)[-1]; # grab everything after the @ + ($from_host) = split /\s+/, $from_host; # remove any trailing cruft chomp $from_host; - chop $from_host if '>' eq substr($from_host,-1,1); - $self->log( LOGDEBUG, "info, from_host is $from_host" ); + chop $from_host if '>' eq substr($from_host, -1, 1); + $self->log(LOGDEBUG, "info, from_host is $from_host"); return $from_host; -}; +} sub parse_policy { my ($self, $str) = @_; - $str =~ s/\s//g; # remove all whitespace + $str =~ s/\s//g; # remove all whitespace my %dmarc = map { split /=/, $_ } split /;/, $str; -#warn Data::Dumper::Dumper(\%dmarc); + + #warn Data::Dumper::Dumper(\%dmarc); return %dmarc; -}; +} sub verify_external_reporting { @@ -396,4 +402,4 @@ sub verify_external_reporting { =cut -}; +} diff --git a/plugins/dns_whitelist_soft b/plugins/dns_whitelist_soft index dc3785d..9ac5cf4 100644 --- a/plugins/dns_whitelist_soft +++ b/plugins/dns_whitelist_soft @@ -55,56 +55,58 @@ use warnings; use Qpsmtpd::Constants; sub register { - my ( $self, $qp ) = (shift, shift); + my ($self, $qp) = (shift, shift); $self->log(LOGERROR, "Bad arguments") if @_ % 2; - $self->{_args} = { @_ }; + $self->{_args} = {@_}; } sub hook_connect { - my ($self, $transaction) = @_; + my ($self, $transaction) = @_; - my $remote_ip = $self->qp->connection->remote_ip; + my $remote_ip = $self->qp->connection->remote_ip; - my %whitelist_zones = map { (split /\s+/, $_, 2)[0,1] } - $self->qp->config('whitelist_zones'); + my %whitelist_zones = + map { (split /\s+/, $_, 2)[0, 1] } $self->qp->config('whitelist_zones'); - return DECLINED unless %whitelist_zones; + return DECLINED unless %whitelist_zones; - my $reversed_ip = join('.', reverse(split(/\./, $remote_ip))); + my $reversed_ip = join('.', reverse(split(/\./, $remote_ip))); - # we queue these lookups in the background and just fetch the - # results in the first rcpt handler + # we queue these lookups in the background and just fetch the + # results in the first rcpt handler - my $res = new Net::DNS::Resolver; - my $sel = IO::Select->new(); + my $res = new Net::DNS::Resolver; + my $sel = IO::Select->new(); - for my $dnsbl (keys %whitelist_zones) { - $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl in the background"); - $sel->add($res->bgsend("$reversed_ip.$dnsbl", 'TXT')); - } + for my $dnsbl (keys %whitelist_zones) { + $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl in the background"); + $sel->add($res->bgsend("$reversed_ip.$dnsbl", 'TXT')); + } - $self->connection->notes('whitelist_sockets', $sel); - return DECLINED; + $self->connection->notes('whitelist_sockets', $sel); + return DECLINED; } sub process_sockets { - my ($self) = @_; + my ($self) = @_; - my $conn = $self->connection; + my $conn = $self->connection; - return $conn->notes('whitelisthost') if $conn->notes('whitelisthost'); + return $conn->notes('whitelisthost') if $conn->notes('whitelisthost'); - my $res = new Net::DNS::Resolver; - my $sel = $conn->notes('whitelist_sockets') or return ''; + my $res = new Net::DNS::Resolver; + my $sel = $conn->notes('whitelist_sockets') or return ''; - $self->log(LOGDEBUG, "waiting for whitelist dns"); + $self->log(LOGDEBUG, "waiting for whitelist dns"); - # don't wait more than 4 seconds here - my @ready = $sel->can_read(4); + # don't wait more than 4 seconds here + my @ready = $sel->can_read(4); - $self->log(LOGDEBUG, "done waiting for whitelist dns, got ", - scalar @ready, " answers ..."); - return '' unless @ready; + $self->log(LOGDEBUG, + "done waiting for whitelist dns, got ", + scalar @ready, + " answers ..."); + return '' unless @ready; my $result; @@ -131,36 +133,38 @@ sub process_sockets { } else { $self->log(LOGERROR, "$whitelist query failed: ", $res->errorstring) - if $res->errorstring ne "NXDOMAIN"; + if $res->errorstring ne "NXDOMAIN"; } if ($result) { + # kill any other pending I/O $conn->notes('whitelist_sockets', undef); return $conn->notes('whitelisthost', $result); } } - if ($sel->count) { - # loop around if we have dns blacklists left to see results from - return $self->process_sockets(); - } + if ($sel->count) { - # er, the following code doesn't make much sense anymore... + # loop around if we have dns blacklists left to see results from + return $self->process_sockets(); + } - # if there was more to read; then forget it - $conn->notes('whitelist_sockets', undef); + # er, the following code doesn't make much sense anymore... - return $conn->notes('whitelisthost', $result); + # if there was more to read; then forget it + $conn->notes('whitelist_sockets', undef); + + return $conn->notes('whitelisthost', $result); } sub hook_rcpt { - my ($self, $transaction, $rcpt, %param) = @_; - my $ip = $self->qp->connection->remote_ip or return (DECLINED); - my $note = $self->process_sockets; - if ( $note ) { - $self->log(LOGNOTICE,"Host $ip is whitelisted: $note"); - } - return DECLINED; + my ($self, $transaction, $rcpt, %param) = @_; + my $ip = $self->qp->connection->remote_ip or return (DECLINED); + my $note = $self->process_sockets; + if ($note) { + $self->log(LOGNOTICE, "Host $ip is whitelisted: $note"); + } + return DECLINED; } diff --git a/plugins/dnsbl b/plugins/dnsbl index 4a055fc..4f48270 100644 --- a/plugins/dnsbl +++ b/plugins/dnsbl @@ -135,20 +135,20 @@ See: https://github.com/smtpd/qpsmtpd/commits/master/plugins/dnsbl sub register { my ($self, $qp) = (shift, shift); - if ( @_ % 2 ) { - $self->{_args}{reject_type} = shift; # backwards compatibility + if (@_ % 2) { + $self->{_args}{reject_type} = shift; # backwards compatibility } else { - $self->{_args} = { @_ }; - }; + $self->{_args} = {@_}; + } # explicitly state legacy reject behavior - if ( ! defined $self->{_args}{reject_type} ) { + if (!defined $self->{_args}{reject_type}) { $self->{_args}{reject_type} = 'perm'; - }; - if ( ! defined $self->{_args}{reject} ) { + } + if (!defined $self->{_args}{reject}) { $self->{_args}{reject} = 1; - }; + } } sub hook_connect { @@ -156,76 +156,79 @@ sub hook_connect { # perform RBLSMTPD checks to mimic DJB's rblsmtpd # RBLSMTPD being non-empty means it contains the failure message to return - if ( defined $ENV{'RBLSMTPD'} && $ENV{'RBLSMTPD'} ne '' ) { + if (defined $ENV{'RBLSMTPD'} && $ENV{'RBLSMTPD'} ne '') { my $reject = $self->{_args}{reject}; return $self->return_env_message() if $reject && $reject eq 'connect'; - }; + } return DECLINED if $self->is_immune(); return DECLINED if $self->is_set_rblsmtpd(); return DECLINED if $self->ip_whitelisted(); my $dnsbl_zones = $self->get_dnsbl_zones() or return DECLINED; - my $resolv = $self->get_resolver() or return DECLINED; + my $resolv = $self->get_resolver() or return DECLINED; - for my $dnsbl ( keys %$dnsbl_zones ) { + for my $dnsbl (keys %$dnsbl_zones) { - my $query = $self->get_query( $dnsbl ) or do { - if ( $resolv->errorstring ne 'NXDOMAIN' ) { - $self->log(LOGERROR, "$dnsbl query failed: ", $resolv->errorstring); - }; + my $query = $self->get_query($dnsbl) or do { + if ($resolv->errorstring ne 'NXDOMAIN') { + $self->log(LOGERROR, "$dnsbl query failed: ", + $resolv->errorstring); + } next; }; my $a_record = 0; my $result; foreach my $rr ($query->answer) { - if ( $rr->type eq 'A' ) { + if ($rr->type eq 'A') { $result = $rr->name; - $self->log(LOGDEBUG, "found A for $result with IP " . $rr->address); + $self->log(LOGDEBUG, + "found A for $result with IP " . $rr->address); } elsif ($rr->type eq 'TXT') { $self->log(LOGDEBUG, "found TXT, " . $rr->txtdata); $result = $rr->txtdata; - }; + } - next if ! $result; + next if !$result; - $self->adjust_karma( -1 ); + $self->adjust_karma(-1); - if ( ! $dnsbl ) { ($dnsbl) = ($result =~ m/(?:\d+\.){4}(.*)/); }; - if ( ! $dnsbl ) { $dnsbl = $result; }; + if (!$dnsbl) { ($dnsbl) = ($result =~ m/(?:\d+\.){4}(.*)/); } + if (!$dnsbl) { $dnsbl = $result; } if ($a_record) { if (defined $dnsbl_zones->{$dnsbl}) { - my $smtp_msg = $dnsbl_zones->{$dnsbl}; - my $remote_ip= $self->qp->connection->remote_ip; + my $smtp_msg = $dnsbl_zones->{$dnsbl}; + my $remote_ip = $self->qp->connection->remote_ip; $smtp_msg =~ s/%IP%/$remote_ip/g; - return $self->get_reject( $smtp_msg, $dnsbl ); + return $self->get_reject($smtp_msg, $dnsbl); } - return $self->get_reject( "Blocked by $dnsbl" ); + return $self->get_reject("Blocked by $dnsbl"); } - return $self->get_reject( $result, $dnsbl ); + return $self->get_reject($result, $dnsbl); } } $self->log(LOGINFO, 'pass'); return DECLINED; -}; +} sub get_dnsbl_zones { my $self = shift; - my %dnsbl_zones = map { (split /:/, $_, 2)[0,1] } $self->qp->config('dnsbl_zones'); - if ( ! %dnsbl_zones ) { - $self->log( LOGDEBUG, "skip, no zones"); + my %dnsbl_zones = + map { (split /:/, $_, 2)[0, 1] } $self->qp->config('dnsbl_zones'); + if (!%dnsbl_zones) { + $self->log(LOGDEBUG, "skip, no zones"); return; - }; + } $self->{_dnsbl}{zones} = \%dnsbl_zones; return \%dnsbl_zones; -}; +} sub get_query { my ($self, $dnsbl) = @_; @@ -234,24 +237,24 @@ sub get_query { my $reversed_ip = join('.', reverse(split(/\./, $remote_ip))); # fix to find A records, if the dnsbl_zones line has a second field 20/1/04 ++msp - if ( defined $self->{_dnsbl}{zones}{$dnsbl} ) { + if (defined $self->{_dnsbl}{zones}{$dnsbl}) { $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for A record"); return $self->{_resolver}->query("$reversed_ip.$dnsbl"); - }; + } $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for TXT record"); return $self->{_resolver}->query("$reversed_ip.$dnsbl", 'TXT'); -}; +} sub is_set_rblsmtpd { my $self = shift; my $remote_ip = $self->qp->connection->remote_ip; - if ( ! defined $ENV{'RBLSMTPD'} ) { + if (!defined $ENV{'RBLSMTPD'}) { $self->log(LOGDEBUG, "RBLSMTPD not set for $remote_ip"); return; - }; + } if ($ENV{'RBLSMTPD'} ne '') { $self->log(LOGINFO, "RBLSMTPD=\"$ENV{'RBLSMTPD'}\" for $remote_ip"); @@ -259,38 +262,39 @@ sub is_set_rblsmtpd { } $self->log(LOGINFO, "RBLSMTPD set, but empty for $remote_ip"); - return 1; # don't return empty string, it evaluates to false -}; + return 1; # don't return empty string, it evaluates to false +} sub ip_whitelisted { my ($self) = @_; my $remote_ip = $self->qp->connection->remote_ip; - return grep { s/\.?$/./; - $_ eq substr($remote_ip . '.', 0, length $_) - } - $self->qp->config('dnsbl_allow'); -}; + return grep { + s/\.?$/./; + $_ eq substr($remote_ip . '.', 0, length $_) + } $self->qp->config('dnsbl_allow'); +} sub return_env_message { - my $self = shift; - my $result = $ENV{'RBLSMTPD'}; + my $self = shift; + my $result = $ENV{'RBLSMTPD'}; my $remote_ip = $self->qp->connection->remote_ip; $result =~ s/%IP%/$remote_ip/g; - my $msg = $self->qp->config('dnsbl_rejectmsg'); + my $msg = $self->qp->config('dnsbl_rejectmsg'); $self->log(LOGINFO, "fail, $msg"); - return ( $self->get_reject_type(), join(' ', $msg, $result)); + return ($self->get_reject_type(), join(' ', $msg, $result)); } sub hook_rcpt { my ($self, $transaction, $rcpt, %param) = @_; - if ( $rcpt->user =~ /^(?:postmaster|abuse|mailer-daemon|root)$/i ) { - $self->log(LOGWARN, "skip, don't blacklist special account: ".$rcpt->user); + if ($rcpt->user =~ /^(?:postmaster|abuse|mailer-daemon|root)$/i) { + $self->log(LOGWARN, + "skip, don't blacklist special account: " . $rcpt->user); # clear the naughty connection note here, if desired. - $self->connection->notes('naughty', 0 ); + $self->connection->notes('naughty', 0); } return DECLINED; @@ -299,11 +303,11 @@ sub hook_rcpt { sub get_resolver { my $self = shift; return $self->{_resolver} if $self->{_resolver}; - $self->log( LOGDEBUG, "initializing Net::DNS::Resolver"); + $self->log(LOGDEBUG, "initializing Net::DNS::Resolver"); $self->{_resolver} = Net::DNS::Resolver->new(dnsrch => 0); my $timeout = $self->{_args}{timeout} || 30; $self->{_resolver}->tcp_timeout($timeout); $self->{_resolver}->udp_timeout($timeout); return $self->{_resolver}; -}; +} diff --git a/plugins/domainkeys b/plugins/domainkeys index b01a814..eac7abb 100644 --- a/plugins/domainkeys +++ b/plugins/domainkeys @@ -57,68 +57,69 @@ use Qpsmtpd::Constants; sub init { my ($self, $qp, %args) = @_; - foreach my $key ( %args ) { + foreach my $key (%args) { $self->{$key} = $args{$key}; } - $self->{reject} = 1 if ! defined $self->{reject}; # default reject - $self->{reject_type} = 'perm' if ! defined $self->{reject_type}; + $self->{reject} = 1 if !defined $self->{reject}; # default reject + $self->{reject_type} = 'perm' if !defined $self->{reject_type}; - if ( $args{'warn_only'} ) { + if ($args{'warn_only'}) { $self->log(LOGNOTICE, "warn_only is deprecated. Use reject instead"); $self->{'reject'} = 0; - }; + } } sub register { my $self = shift; - for my $m ( qw/ Mail::DomainKeys::Message Mail::DomainKeys::Policy / ) { + for my $m (qw/ Mail::DomainKeys::Message Mail::DomainKeys::Policy /) { eval "use $m"; - if ( $@ ) { + if ($@) { warn "skip: plugin disabled, could not load $m\n"; $self->log(LOGERROR, "skip: plugin disabled, is $m installed?"); return; - }; - }; + } + } $self->register_hook('data_post', 'data_post_handler'); -}; +} sub data_post_handler { my ($self, $transaction) = @_; return DECLINED if $self->is_immune(); - if ( ! $transaction->header->get('DomainKey-Signature') ) { + if (!$transaction->header->get('DomainKey-Signature')) { $self->log(LOGINFO, "skip, unsigned"); return DECLINED; - }; + } - my $body = $self->assemble_body( $transaction ); + my $body = $self->assemble_body($transaction); - my $message = load Mail::DomainKeys::Message( - HeadString => $transaction->header->as_string, - BodyReference => $body) or do { - $self->log(LOGWARN, "skip, unable to load message"), - return DECLINED; - }; + my $message = + load Mail::DomainKeys::Message( + HeadString => $transaction->header->as_string, + BodyReference => $body) + or do { + $self->log(LOGWARN, "skip, unable to load message"), return DECLINED; + }; # no sender domain means no verification - if ( ! $message->senderdomain ) { + if (!$message->senderdomain) { $self->log(LOGINFO, "skip, failed to parse sender domain"), - return DECLINED; - }; + return DECLINED; + } - my $status = $self->get_message_status( $message ); + my $status = $self->get_message_status($message); - if ( defined $status ) { + if (defined $status) { $transaction->header->add("DomainKey-Status", $status, 0); $self->log(LOGINFO, "pass, $status"); return DECLINED; - }; + } $self->log(LOGERROR, "fail, signature invalid"); - return DECLINED if ! $self->{reject}; + return DECLINED if !$self->{reject}; my $deny = $self->{reject_type} eq 'temp' ? DENYSOFT : DENY; return ($deny, "DomainKeys signature validation failed"); } @@ -126,45 +127,44 @@ sub data_post_handler { sub get_message_status { my ($self, $message) = @_; - if ( $message->testing ) { - return "testing"; # key testing, don't do anything else - }; + if ($message->testing) { + return "testing"; # key testing, don't do anything else + } - if ( $message->signed && $message->verify ) { - return $message->signature->status; # verified: add good header - }; + if ($message->signed && $message->verify) { + return $message->signature->status; # verified: add good header + } # not signed or not verified - my $policy = fetch Mail::DomainKeys::Policy( - Protocol => 'dns', - Domain => $message->senderdomain - ); + my $policy = + fetch Mail::DomainKeys::Policy(Protocol => 'dns', + Domain => $message->senderdomain); - if ( ! $policy ) { + if (!$policy) { return $message->signed ? "non-participant" : "no signature"; - }; + } - if ( $policy->testing ) { - return "testing"; # Don't do anything else - }; + if ($policy->testing) { + return "testing"; # Don't do anything else + } - if ( $policy->signall ) { - return undef; # policy requires all mail to be signed - }; + if ($policy->signall) { + return undef; # policy requires all mail to be signed + } # $policy->signsome - return "no signature"; # not signed and domain doesn't sign all -}; + return "no signature"; # not signed and domain doesn't sign all +} sub assemble_body { my ($self, $transaction) = @_; $transaction->body_resetpos; - $transaction->body_getline; # \r\n seperator is NOT part of the body + $transaction->body_getline; # \r\n seperator is NOT part of the body my @body; while (my $line = $transaction->body_getline) { push @body, $line; } return \@body; -}; +} diff --git a/plugins/dont_require_anglebrackets b/plugins/dont_require_anglebrackets index 000030a..b81df88 100644 --- a/plugins/dont_require_anglebrackets +++ b/plugins/dont_require_anglebrackets @@ -1,5 +1,5 @@ #!perl -w - + =head1 NAME dont_require_anglebrackets @@ -22,19 +22,19 @@ MAIL FROM:user@example.com =cut sub hook_mail_pre { - my ($self,$transaction, $addr) = @_; + my ($self, $transaction, $addr) = @_; unless ($addr =~ /^<.*>$/) { $self->log(LOGINFO, "added MAIL angle brackets"); - $addr = '<'.$addr.'>'; + $addr = '<' . $addr . '>'; } return (OK, $addr); } sub hook_rcpt_pre { - my ($self,$transaction, $addr) = @_; + my ($self, $transaction, $addr) = @_; unless ($addr =~ /^<.*>$/) { $self->log(LOGINFO, "added RCPT angle brackets"); - $addr = '<'.$addr.'>'; + $addr = '<' . $addr . '>'; } return (OK, $addr); } diff --git a/plugins/dspam b/plugins/dspam index 593a129..39849a9 100644 --- a/plugins/dspam +++ b/plugins/dspam @@ -212,10 +212,10 @@ sub register { $self->log(LOGERROR, "Bad parameters for the dspam plugin") if @_ % 2; - $self->{_args} = { @_ }; - $self->{_args}{reject} = 1 if ! defined $self->{_args}{reject}; + $self->{_args} = {@_}; + $self->{_args}{reject} = 1 if !defined $self->{_args}{reject}; $self->{_args}{reject_type} ||= 'perm'; - $self->{_args}{dspam_bin} ||= '/usr/local/bin/dspam'; + $self->{_args}{dspam_bin} ||= '/usr/local/bin/dspam'; $self->get_dspam_bin() or return DECLINED; @@ -226,16 +226,18 @@ sub get_dspam_bin { my $self = shift; my $bin = $self->{_args}{dspam_bin}; - if ( ! -e $bin ) { - $self->log(LOGERROR, "error, dspam CLI binary not found: install dspam and/or set dspam_bin"); + if (!-e $bin) { + $self->log(LOGERROR, +"error, dspam CLI binary not found: install dspam and/or set dspam_bin" + ); return; - }; - if ( ! -x $bin ) { + } + if (!-x $bin) { $self->log(LOGERROR, "error, no permission to run $bin"); return; - }; + } return $bin; -}; +} sub data_post_handler { my $self = shift; @@ -243,29 +245,30 @@ sub data_post_handler { return (DECLINED) if $self->is_immune(); - if ( $transaction->data_size > 500_000 ) { - $self->log(LOGINFO, "skip, too big (" . $transaction->data_size . ")" ); + if ($transaction->data_size > 500_000) { + $self->log(LOGINFO, "skip, too big (" . $transaction->data_size . ")"); return (DECLINED); - }; + } - my $user = $self->select_username( $transaction ); + my $user = $self->select_username($transaction); my $bin = $self->{_args}{dspam_bin}; - my $filtercmd = "$bin --user $user --mode=tum --process --deliver=summary --stdout"; + my $filtercmd = + "$bin --user $user --mode=tum --process --deliver=summary --stdout"; $self->log(LOGDEBUG, $filtercmd); - my $response = $self->dspam_process( $filtercmd, $transaction ); - if ( ! $response->{result} ) { + my $response = $self->dspam_process($filtercmd, $transaction); + if (!$response->{result}) { $self->log(LOGWARN, "error, no dspam response. Check logs for errors."); return (DECLINED); - }; + } $transaction->notes('dspam', $response); - $self->attach_headers( $response, $transaction ); - $self->autolearn( $response, $transaction ); + $self->attach_headers($response, $transaction); + $self->autolearn($response, $transaction); - return $self->log_and_return( $transaction ); -}; + return $self->log_and_return($transaction); +} sub select_username { my ($self, $transaction) = @_; @@ -273,34 +276,36 @@ sub select_username { my $recipient_count = scalar $transaction->recipients; $self->log(LOGDEBUG, "Message has $recipient_count recipients"); - if ( $recipient_count > 1 ) { - $self->log(LOGINFO, "multiple recipients ($recipient_count), ignoring user prefs"); + if ($recipient_count > 1) { + $self->log(LOGINFO, + "multiple recipients ($recipient_count), ignoring user prefs"); return getpwuid($>); - }; + } -# use the recipients email address as username. This enables user prefs + # use the recipients email address as username. This enables user prefs my $username = ($transaction->recipients)[0]->address; return lc($username); -}; +} sub assemble_message { my ($self, $transaction) = @_; - my $message = "X-Envelope-From: " - . $transaction->sender->format . "\n" - . $transaction->header->as_string . "\n\n"; + my $message = + "X-Envelope-From: " + . $transaction->sender->format . "\n" + . $transaction->header->as_string . "\n\n"; $transaction->body_resetpos; - while (my $line = $transaction->body_getline) { $message .= $line; }; + while (my $line = $transaction->body_getline) { $message .= $line; } $message = join(CRLF, split /\n/, $message); return $message . CRLF; -}; +} sub parse_response { my $self = shift; my $response = shift or do { - $self->log( LOGDEBUG, "missing dspam response!" ); + $self->log(LOGDEBUG, "missing dspam response!"); return; }; @@ -313,22 +318,22 @@ sub parse_response { my ($user, $result, $class, $prob, $conf, $sig) = split /; /, $response; (undef, $result) = split /=/, $result; - (undef, $class ) = split /=/, $class; - (undef, $prob ) = split /=/, $prob; - (undef, $conf ) = split /=/, $conf; - (undef, $sig ) = split /=/, $sig; + (undef, $class) = split /=/, $class; + (undef, $prob) = split /=/, $prob; + (undef, $conf) = split /=/, $conf; + (undef, $sig) = split /=/, $sig; - $result = substr($result, 1, -1); # strip off quotes + $result = substr($result, 1, -1); # strip off quotes $class = substr($class, 1, -1); return { - class => $class, - result => $result, - probability => $prob, - confidence => $conf, - signature => $sig, - }; -}; + class => $class, + result => $result, + probability => $prob, + confidence => $conf, + signature => $sig, + }; +} sub parse_response_regexp { my ($self, $response) = @_; @@ -342,107 +347,114 @@ sub parse_response_regexp { /x; return { - class => $class, - result => $result, - probability => $prob, - confidence => $conf, - signature => $sig, - }; -}; + class => $class, + result => $result, + probability => $prob, + confidence => $conf, + signature => $sig, + }; +} sub dspam_process { - my ( $self, $filtercmd, $transaction ) = @_; + my ($self, $filtercmd, $transaction) = @_; + + my $response = $self->dspam_process_backticks($filtercmd); - my $response = $self->dspam_process_backticks( $filtercmd ); #my $response = $self->dspam_process_open2( $filtercmd, $transaction ); #my $response = $self->dspam_process_fork( $filtercmd ); - return $self->parse_response( $response ); -}; + return $self->parse_response($response); +} sub dspam_process_fork { - my ( $self, $filtercmd, $transaction ) = @_; + my ($self, $filtercmd, $transaction) = @_; # yucky. This method (which forks) exercises a bug in qpsmtpd. When the # child exits, the Transaction::DESTROY method is called, which deletes # the spooled file from disk. The contents of $self->qp->transaction # needed to spool it again are also destroyed. Don't use this. - my $message = $self->assemble_message( $transaction ); + my $message = $self->assemble_message($transaction); my $in_fh; - if (! open($in_fh, '-|')) { # forks child for writing + if (!open($in_fh, '-|')) { # forks child for writing open(my $out_fh, "|$filtercmd") or die "Can't run $filtercmd: $!\n"; print $out_fh $message; close $out_fh; exit(0); - }; + } my $response = <$in_fh>; close $in_fh; chomp $response; $self->log(LOGDEBUG, $response); return $response; -}; +} sub dspam_process_backticks { - my ( $self, $filtercmd ) = @_; + my ($self, $filtercmd) = @_; my $transaction = $self->qp->transaction; my $message = $self->temp_file(); open my $fh, '>', $message; print $fh "X-Envelope-From: " - . $transaction->sender->format . CRLF - . $transaction->header->as_string . CRLF . CRLF; + . $transaction->sender->format + . CRLF + . $transaction->header->as_string + . CRLF + . CRLF; $transaction->body_resetpos; - while (my $line = $transaction->body_getline) { print $fh $line; }; + while (my $line = $transaction->body_getline) { print $fh $line; } close $fh; my ($line1) = split /[\r|\n]/, `$filtercmd < $message`; $self->log(LOGDEBUG, $line1); return $line1; -}; +} sub dspam_process_open2 { - my ( $self, $filtercmd, $transaction ) = @_; + my ($self, $filtercmd, $transaction) = @_; - my $message = $self->assemble_message( $transaction ); + my $message = $self->assemble_message($transaction); -# not sure why, but this is not as reliable as I'd like. What's a dspam -# error -5 mean anyway? + # not sure why, but this is not as reliable as I'd like. What's a dspam + # error -5 mean anyway? use FileHandle; use IPC::Open3; my ($read, $write, $err); - use Symbol 'gensym'; $err = gensym; + use Symbol 'gensym'; + $err = gensym; my $pid = open3($write, $read, $err, $filtercmd); print $write $message; close $write; + #my $response = join('', <$dspam_out>); # get full response - my $response = <$read>; # get first line only + my $response = <$read>; # get first line only waitpid $pid, 0; my $child_exit_status = $? >> 8; + #$self->log(LOGINFO, "exit status: $child_exit_status"); - if ( $response ) { + if ($response) { chomp $response; $self->log(LOGDEBUG, $response); - }; + } my $err_msg = <$err>; - if ( $err_msg ) { - $self->log(LOGDEBUG, $err_msg ); - }; + if ($err_msg) { + $self->log(LOGDEBUG, $err_msg); + } return $response; -}; +} sub log_and_return { my $self = shift; my $transaction = shift || $self->qp->transaction; - my $d = $self->get_dspam_results( $transaction ) or return DECLINED; + my $d = $self->get_dspam_results($transaction) or return DECLINED; - if ( ! $d->{class} ) { + if (!$d->{class}) { $self->log(LOGWARN, "skip, no dspam class detected"); return DECLINED; - }; + } my $status = "$d->{class}, $d->{confidence} c."; my $reject = $self->{_args}{reject} or do { @@ -450,26 +462,30 @@ sub log_and_return { return DECLINED; }; - if ( $reject eq 'agree' ) { - return $self->reject_agree( $transaction ); - }; + if ($reject eq 'agree') { + return $self->reject_agree($transaction); + } - if ( $d->{class} eq 'Innocent' ) { + if ($d->{class} eq 'Innocent') { $self->log(LOGINFO, "pass, $status"); return DECLINED; - }; - if ( $self->qp->connection->relay_client ) { - $self->log(LOGINFO, "skip, allowing spam, user authenticated ($status)"); + } + if ($self->qp->connection->relay_client) { + $self->log(LOGINFO, + "skip, allowing spam, user authenticated ($status)"); return DECLINED; - }; - if ( $d->{probability} <= $reject ) { - $self->log(LOGINFO, "pass, $d->{class} probability is too low ($d->{probability} < $reject)"); + } + if ($d->{probability} <= $reject) { + $self->log(LOGINFO, +"pass, $d->{class} probability is too low ($d->{probability} < $reject)" + ); return DECLINED; - }; - if ( $d->{confidence} != 1 ) { - $self->log(LOGINFO, "pass, $d->{class} confidence is too low ($d->{confidence})"); + } + if ($d->{confidence} != 1) { + $self->log(LOGINFO, + "pass, $d->{class} confidence is too low ($d->{confidence})"); return DECLINED; - }; + } # dspam is more than $reject percent sure this message is spam $self->log(LOGINFO, "fail, $d->{class}, ($d->{confidence} confident)"); @@ -478,82 +494,84 @@ sub log_and_return { } sub reject_agree { - my ($self, $transaction ) = @_; + my ($self, $transaction) = @_; - my $sa = $transaction->notes('spamassassin' ); - my $d = $transaction->notes('dspam' ); + my $sa = $transaction->notes('spamassassin'); + my $d = $transaction->notes('dspam'); my $status = "$d->{class}, $d->{confidence} c"; - if ( ! $sa->{is_spam} ) { + if (!$sa->{is_spam}) { $self->log(LOGINFO, "pass, cannot agree, SA results missing ($status)"); return DECLINED; - }; + } - if ( $d->{class} eq 'Spam' ) { - if ( $sa->{is_spam} eq 'Yes' ) { - $self->adjust_karma( -2 ); + if ($d->{class} eq 'Spam') { + if ($sa->{is_spam} eq 'Yes') { + $self->adjust_karma(-2); $self->log(LOGINFO, "fail, agree, $status"); my $reject = $self->get_reject_type(); return ($reject, 'we agree, no spam please'); - }; + } $self->log(LOGINFO, "fail, disagree, $status"); return DECLINED; - }; + } - if ( $d->{class} eq 'Innocent' ) { - if ( $sa->{is_spam} eq 'No' ) { - if ( $d->{confidence} > .9 ) { - $self->adjust_karma( 1 ); - }; + if ($d->{class} eq 'Innocent') { + if ($sa->{is_spam} eq 'No') { + if ($d->{confidence} > .9) { + $self->adjust_karma(1); + } $self->log(LOGINFO, "pass, agree, $status"); return DECLINED; - }; + } $self->log(LOGINFO, "pass, disagree, $status"); return DECLINED; - }; + } $self->log(LOGINFO, "pass, other $status"); return DECLINED; -}; +} sub get_dspam_results { my $self = shift; my $transaction = shift || $self->qp->transaction; - if ( $transaction->notes('dspam') ) { + if ($transaction->notes('dspam')) { return $transaction->notes('dspam'); - }; + } my $string = $transaction->header->get('X-DSPAM-Result') or do { $self->log(LOGWARN, "get_dspam_results: failed to find the header"); return; }; - my @bits = split /,\s+/, $string; chomp @bits; + my @bits = split /,\s+/, $string; + chomp @bits; my $class = shift @bits; my %d; foreach (@bits) { - my ($key,$val) = split /=/, $_; + my ($key, $val) = split /=/, $_; $d{$key} = $val; - }; + } $d{class} = $class; my $message = $d{class}; - if ( defined $d{probability} && defined $d{confidence} ) { + if (defined $d{probability} && defined $d{confidence}) { $message .= ", prob: $d{probability}, conf: $d{confidence}"; - }; + } $self->log(LOGDEBUG, $message); $transaction->notes('dspam', \%d); return \%d; -}; +} sub attach_headers { my ($self, $r, $transaction) = @_; $transaction ||= $self->qp->transaction; - my $header_str = "$r->{result}, probability=$r->{probability}, confidence=$r->{confidence}"; + my $header_str = +"$r->{result}, probability=$r->{probability}, confidence=$r->{confidence}"; $self->log(LOGDEBUG, $header_str); my $name = 'X-DSPAM-Result'; $transaction->header->delete($name) if $transaction->header->get($name); @@ -562,135 +580,160 @@ sub attach_headers { # the signature header is required if you intend to train dspam later. # In dspam.conf, set: Preference "signatureLocation=headers" $transaction->header->add('X-DSPAM-Signature', $r->{signature}, 0); -}; +} sub train_error_as_ham { - my $self = shift; + my $self = shift; my $transaction = shift; - my $user = $self->select_username( $transaction ); + my $user = $self->select_username($transaction); my $dspam_bin = $self->{_args}{dspam_bin} || '/usr/local/bin/dspam'; - my $cmd = "$dspam_bin --user $user --mode=toe --source=error --class=innocent --deliver=summary --stdout"; - my $response = $self->dspam_process( $cmd, $transaction ); - if ( $response ) { + my $cmd = +"$dspam_bin --user $user --mode=toe --source=error --class=innocent --deliver=summary --stdout"; + my $response = $self->dspam_process($cmd, $transaction); + if ($response) { $transaction->notes('dspam', $response); } else { - $transaction->notes('dspam', { class => 'Innocent', result => 'Innocent', confidence=>1 } ); - }; -}; + $transaction->notes( + 'dspam', + { + class => 'Innocent', + result => 'Innocent', + confidence => 1 + } + ); + } +} sub train_error_as_spam { - my $self = shift; + my $self = shift; my $transaction = shift; - my $user = $self->select_username( $transaction ); + my $user = $self->select_username($transaction); my $dspam_bin = $self->{_args}{dspam_bin} || '/usr/local/bin/dspam'; - my $cmd = "$dspam_bin --user $user --mode=toe --source=error --class=spam --deliver=summary --stdout"; - my $response = $self->dspam_process( $cmd, $transaction ); - if ( $response ) { + my $cmd = +"$dspam_bin --user $user --mode=toe --source=error --class=spam --deliver=summary --stdout"; + my $response = $self->dspam_process($cmd, $transaction); + if ($response) { $transaction->notes('dspam', $response); } else { - $transaction->notes('dspam', { class => 'Spam', result => 'Spam', confidence=>1 } ); - }; -}; + $transaction->notes( + 'dspam', + { + class => 'Spam', + result => 'Spam', + confidence => 1 + } + ); + } +} sub autolearn { - my ( $self, $response, $transaction ) = @_; + my ($self, $response, $transaction) = @_; defined $self->{_args}{autolearn} or return; if ( $self->{_args}{autolearn} ne 'any' && $self->{_args}{autolearn} ne 'karma' && $self->{_args}{autolearn} ne 'naughty' - && $self->{_args}{autolearn} ne 'spamassassin' - ) { - $self->log(LOGERROR, "bad autolearn setting! Read 'perldoc plugins/dspam' again!"); + && $self->{_args}{autolearn} ne 'spamassassin') + { + $self->log(LOGERROR, + "bad autolearn setting! Read 'perldoc plugins/dspam' again!"); return; - }; + } # only train once. - $self->autolearn_naughty( $response, $transaction ) and return; - $self->autolearn_karma( $response, $transaction ) and return; - $self->autolearn_spamassassin( $response, $transaction ) and return; -}; + $self->autolearn_naughty($response, $transaction) and return; + $self->autolearn_karma($response, $transaction) and return; + $self->autolearn_spamassassin($response, $transaction) and return; +} sub autolearn_naughty { - my ( $self, $response, $transaction ) = @_; + my ($self, $response, $transaction) = @_; my $learn = $self->{_args}{autolearn} or return; - if ( $learn ne 'naughty' && $learn ne 'any' ) { + if ($learn ne 'naughty' && $learn ne 'any') { $self->log(LOGDEBUG, "skipping naughty autolearn"); return; - }; + } - if ( $self->connection->notes('naughty') && $response->{result} eq 'Innocent' ) { + if ( $self->connection->notes('naughty') + && $response->{result} eq 'Innocent') + { $self->log(LOGINFO, "training naughty FN message as spam"); - $self->train_error_as_spam( $transaction ); + $self->train_error_as_spam($transaction); return 1; - }; + } $self->log(LOGDEBUG, "falling through naughty autolearn"); return; -}; +} sub autolearn_karma { - my ( $self, $response, $transaction ) = @_; + my ($self, $response, $transaction) = @_; my $learn = $self->{_args}{autolearn} or return; - return if ( $learn ne 'karma' && $learn ne 'any' ); + return if ($learn ne 'karma' && $learn ne 'any'); my $karma = $self->connection->notes('karma'); - return if ! defined $karma; + return if !defined $karma; - if ( $karma < -2 && $response->{result} eq 'Innocent' ) { + if ($karma < -2 && $response->{result} eq 'Innocent') { $self->log(LOGINFO, "training bad karma ($karma) FN as spam"); - $self->train_error_as_spam( $transaction ); + $self->train_error_as_spam($transaction); return 1; - }; + } - if ( $karma > 2 && $response->{result} eq 'Spam' ) { + if ($karma > 2 && $response->{result} eq 'Spam') { $self->log(LOGINFO, "training good karma ($karma) FP as ham"); - $self->train_error_as_ham( $transaction ); + $self->train_error_as_ham($transaction); return 1; - }; + } return; -}; +} sub autolearn_spamassassin { - my ( $self, $response, $transaction ) = @_; + my ($self, $response, $transaction) = @_; my $learn = $self->{_args}{autolearn} or return; - return if ( $learn ne 'spamassassin' && $learn ne 'any' ); + return if ($learn ne 'spamassassin' && $learn ne 'any'); - my $sa = $transaction->notes('spamassassin' ); - if ( ! $sa || ! $sa->{is_spam} ) { - if ( ! $self->connection->notes('naughty') ) { - $self->log(LOGERROR, "SA results missing"); # SA skips naughty - }; + my $sa = $transaction->notes('spamassassin'); + if (!$sa || !$sa->{is_spam}) { + if (!$self->connection->notes('naughty')) { + $self->log(LOGERROR, "SA results missing"); # SA skips naughty + } return; - }; + } - if ( ! $sa->{autolearn} ) { + if (!$sa->{autolearn}) { $self->log(LOGERROR, "SA autolearn unset"); return; - }; + } - if ( $sa->{is_spam} eq 'Yes' && $sa->{autolearn} eq 'spam' && $response->{result} eq 'Innocent' ) { + if ( $sa->{is_spam} eq 'Yes' + && $sa->{autolearn} eq 'spam' + && $response->{result} eq 'Innocent') + { $self->log(LOGINFO, "training SA FN as spam"); - $self->train_error_as_spam( $transaction ); + $self->train_error_as_spam($transaction); return 1; } - elsif ( $sa->{is_spam} eq 'No' && $sa->{autolearn} eq 'ham' && $response->{result} eq 'Spam' ) { + elsif ( $sa->{is_spam} eq 'No' + && $sa->{autolearn} eq 'ham' + && $response->{result} eq 'Spam') + { $self->log(LOGINFO, "training SA FP as ham"); - $self->train_error_as_ham( $transaction ); + $self->train_error_as_ham($transaction); return 1; - }; + } return; -}; +} diff --git a/plugins/earlytalker b/plugins/earlytalker index 33cbf19..788d32d 100644 --- a/plugins/earlytalker +++ b/plugins/earlytalker @@ -70,52 +70,57 @@ use IO::Select; use Qpsmtpd::Constants; sub register { - my ($self, $qp, @args) = @_; + my ($self, $qp, @args) = @_; - if (@args % 2) { + if (@args % 2) { $self->log(LOGERROR, "Unrecognized/mismatched arguments"); return; - } - my %check_at; - for (0..$#args) { - next if $_ % 2; - if (lc($args[$_]) eq 'check-at') { - my $val = $args[$_ + 1]; - $check_at{uc($val)}++; } - } - if (!%check_at) { - $check_at{CONNECT} = 1; - } - $self->{_args} = { - 'wait' => 1, - @args, - 'check-at' => \%check_at, - }; -# backwards compat with old 'action' argument - if ( defined $self->{_args}{action} && ! defined $self->{_args}{reject} ) { - $self->{_args}{reject} = $self->{_args}{action} =~ /^deny/i ? 1 : 0; - }; - if ( defined $self->{_args}{'defer-reject'} && ! defined $self->{_args}{reject_type} ) { - $self->{_args}{reject_type} = $self->{_args}{action} == 'denysoft' ? 'temp' : 'perm'; - }; - if ( ! defined $self->{_args}{reject_type} ) { - $self->{_args}{reject_type} = 'perm'; - }; -# /end compat - if ( $qp->{conn} && $qp->{conn}->isa('Apache2::Connection')) { - require APR::Const; - APR::Const->import(qw(POLLIN SUCCESS)); - $self->register_hook('connect', 'apr_connect_handler'); - $self->register_hook('data', 'apr_data_handler'); - } - else { - $self->register_hook('connect', 'connect_handler'); - $self->register_hook('data', 'data_handler'); - } - $self->register_hook('mail', 'mail_handler') - if $self->{_args}{'defer-reject'}; - $self->{_args}{reject} = 1 if ! defined $self->{_args}{reject}; + my %check_at; + for (0 .. $#args) { + next if $_ % 2; + if (lc($args[$_]) eq 'check-at') { + my $val = $args[$_ + 1]; + $check_at{uc($val)}++; + } + } + if (!%check_at) { + $check_at{CONNECT} = 1; + } + $self->{_args} = { + 'wait' => 1, + @args, + 'check-at' => \%check_at, + }; + + # backwards compat with old 'action' argument + if (defined $self->{_args}{action} && !defined $self->{_args}{reject}) { + $self->{_args}{reject} = $self->{_args}{action} =~ /^deny/i ? 1 : 0; + } + if (defined $self->{_args}{'defer-reject'} + && !defined $self->{_args}{reject_type}) + { + $self->{_args}{reject_type} = + $self->{_args}{action} == 'denysoft' ? 'temp' : 'perm'; + } + if (!defined $self->{_args}{reject_type}) { + $self->{_args}{reject_type} = 'perm'; + } + + # /end compat + if ($qp->{conn} && $qp->{conn}->isa('Apache2::Connection')) { + require APR::Const; + APR::Const->import(qw(POLLIN SUCCESS)); + $self->register_hook('connect', 'apr_connect_handler'); + $self->register_hook('data', 'apr_data_handler'); + } + else { + $self->register_hook('connect', 'connect_handler'); + $self->register_hook('data', 'data_handler'); + } + $self->register_hook('mail', 'mail_handler') + if $self->{_args}{'defer-reject'}; + $self->{_args}{reject} = 1 if !defined $self->{_args}{reject}; } sub apr_connect_handler { @@ -124,7 +129,7 @@ sub apr_connect_handler { return DECLINED unless $self->{_args}{'check-at'}{CONNECT}; return DECLINED if $self->is_immune(); - my $c = $self->qp->{conn} or return DECLINED; + my $c = $self->qp->{conn} or return DECLINED; my $socket = $c->client_socket or return DECLINED; my $timeout = $self->{_args}{'wait'} * 1_000_000; @@ -133,9 +138,9 @@ sub apr_connect_handler { if ($self->{_args}{'defer-reject'}) { $self->connection->notes('earlytalker', 1); return DECLINED; - }; + } return $self->log_and_deny(); - }; + } return $self->log_and_pass(); } @@ -145,14 +150,14 @@ sub apr_data_handler { return DECLINED unless $self->{_args}{'check-at'}{DATA}; return DECLINED if $self->is_immune(); - my $c = $self->qp->{conn} or return DECLINED; + my $c = $self->qp->{conn} or return DECLINED; my $socket = $c->client_socket or return DECLINED; my $timeout = $self->{_args}{'wait'} * 1_000_000; my $rc = $socket->poll($c->pool, $timeout, APR::Const::POLLIN()); if ($rc == APR::Const::SUCCESS()) { return $self->log_and_deny(); - }; + } return $self->log_and_pass(); } @@ -168,19 +173,19 @@ sub connect_handler { if (defined $karma && $karma > 5) { $self->log(LOGINFO, "skip, karma $karma"); return DECLINED; - }; + } $in->add(\*STDIN) or return DECLINED; - if (! $in->can_read($self->{_args}{'wait'})) { + if (!$in->can_read($self->{_args}{'wait'})) { return $self->log_and_pass(); - }; + } - if ( ! $self->{_args}{'defer-reject'}) { + if (!$self->{_args}{'defer-reject'}) { return $self->log_and_deny(); - }; + } $self->connection->notes('earlytalker', 1); - $self->adjust_karma( -1 ); + $self->adjust_karma(-1); return DECLINED; } @@ -192,12 +197,12 @@ sub data_handler { return DECLINED if $self->is_immune(); $in->add(\*STDIN) or return DECLINED; - if ( ! $in->can_read($self->{_args}{'wait'})) { + if (!$in->can_read($self->{_args}{'wait'})) { return $self->log_and_pass(); - }; + } return $self->log_and_deny(); -}; +} sub log_and_pass { my $self = shift; @@ -212,18 +217,18 @@ sub log_and_deny { my $ip = $self->qp->connection->remote_ip || 'remote host'; $self->connection->notes('earlytalker', 1); - $self->adjust_karma( -1 ); + $self->adjust_karma(-1); my $log_mess = "remote started talking before we said hello"; my $smtp_msg = 'Connecting host started transmitting before SMTP greeting'; - return $self->get_reject( $smtp_msg, $log_mess ); + return $self->get_reject($smtp_msg, $log_mess); } sub mail_handler { - my ($self, $transaction) = @_; + my ($self, $transaction) = @_; - return DECLINED unless $self->connection->notes('earlytalker'); - return $self->log_and_deny(); + return DECLINED unless $self->connection->notes('earlytalker'); + return $self->log_and_deny(); } diff --git a/plugins/fcrdns b/plugins/fcrdns index c1f2e56..b8190e4 100644 --- a/plugins/fcrdns +++ b/plugins/fcrdns @@ -102,20 +102,20 @@ use Qpsmtpd::Constants; sub register { my ($self, $qp) = (shift, shift); - $self->{_args} = { @_ }; + $self->{_args} = {@_}; $self->{_args}{reject_type} = 'temp'; $self->{_args}{timeout} ||= 5; $self->{_args}{ptr_hosts} = {}; - if ( ! defined $self->{_args}{reject} ) { + if (!defined $self->{_args}{reject}) { $self->{_args}{reject} = 0; - }; + } $self->init_resolver() or return; $self->register_hook('connect', 'connect_handler'); $self->register_hook('data_post', 'data_post_handler'); -}; +} sub connect_handler { my ($self) = @_; @@ -123,9 +123,9 @@ sub connect_handler { return DECLINED if $self->is_immune(); # run a couple cheap tests before the more expensive DNS tests - foreach my $test ( qw/ invalid_localhost is_not_fqdn / ) { + foreach my $test (qw/ invalid_localhost is_not_fqdn /) { $self->$test() or return DECLINED; - }; + } $self->has_reverse_dns() or return DECLINED; $self->has_forward_dns() or return DECLINED; @@ -138,91 +138,93 @@ sub data_post_handler { my ($self, $transaction) = @_; my $match = $self->connection->notes('fcrdns_match') || 0; - $transaction->header->add('X-Fcrdns', $match ? 'Yes' : 'No', 0 ); + $transaction->header->add('X-Fcrdns', $match ? 'Yes' : 'No', 0); return (DECLINED); -}; +} sub invalid_localhost { - my ( $self ) = @_; + my ($self) = @_; return 1 if lc $self->qp->connection->remote_host ne 'localhost'; if ( $self->qp->connection->remote_ip ne '127.0.0.1' - && $self->qp->connection->remote_ip ne '::1' ) { - $self->adjust_karma( -1 ); - $self->log( LOGINFO, "fail, not localhost" ); + && $self->qp->connection->remote_ip ne '::1') + { + $self->adjust_karma(-1); + $self->log(LOGINFO, "fail, not localhost"); return; - }; - $self->adjust_karma( 1 ); - $self->log( LOGDEBUG, "pass, is localhost" ); + } + $self->adjust_karma(1); + $self->log(LOGDEBUG, "pass, is localhost"); return 1; -}; +} sub is_not_fqdn { my ($self) = @_; my $host = $self->qp->connection->remote_host or return 1; - return 1 if $host eq 'Unknown'; # QP assigns this to a "no DNS result" + return 1 if $host eq 'Unknown'; # QP assigns this to a "no DNS result" # Since QP looked it up, perform some quick validation - if ( $host !~ /\./ ) { # has no dots - $self->adjust_karma( -1 ); + if ($host !~ /\./) { # has no dots + $self->adjust_karma(-1); $self->log(LOGINFO, "fail, not FQDN"); return; - }; - if ( $host =~ /[^a-zA-Z0-9\-\.]/ ) { - $self->adjust_karma( -1 ); + } + if ($host =~ /[^a-zA-Z0-9\-\.]/) { + $self->adjust_karma(-1); $self->log(LOGINFO, "fail, invalid FQDN chars"); return; - }; + } return 1; -}; +} sub has_reverse_dns { - my ( $self ) = @_; + my ($self) = @_; my $res = $self->init_resolver(); my $ip = $self->qp->connection->remote_ip; - my $query = $res->query( $ip ) or do { - if ( $res->errorstring eq 'NXDOMAIN' ) { - $self->adjust_karma( -1 ); - $self->log( LOGINFO, "fail, no rDNS: ".$res->errorstring ); + my $query = $res->query($ip) or do { + if ($res->errorstring eq 'NXDOMAIN') { + $self->adjust_karma(-1); + $self->log(LOGINFO, "fail, no rDNS: " . $res->errorstring); return; - }; - $self->log( LOGINFO, "fail, error getting rDNS: ".$res->errorstring ); + } + $self->log(LOGINFO, "fail, error getting rDNS: " . $res->errorstring); return; }; my $hits = 0; - $self->{_args}{ptr_hosts} = {}; # reset hash + $self->{_args}{ptr_hosts} = {}; # reset hash for my $rr ($query->answer) { next if $rr->type ne 'PTR'; $hits++; - $self->{_args}{ptr_hosts}{ $rr->ptrdname } = 1; - $self->log(LOGDEBUG, "PTR: " . $rr->ptrdname ); - }; - if ( ! $hits ) { - $self->adjust_karma( -1 ); - $self->log( LOGINFO, "fail, no PTR records"); + $self->{_args}{ptr_hosts}{$rr->ptrdname} = 1; + $self->log(LOGDEBUG, "PTR: " . $rr->ptrdname); + } + if (!$hits) { + $self->adjust_karma(-1); + $self->log(LOGINFO, "fail, no PTR records"); return; - }; + } $self->log(LOGDEBUG, "has rDNS"); return 1; -}; +} sub has_forward_dns { - my ( $self ) = @_; + my ($self) = @_; my $res = $self->init_resolver(); - foreach my $host ( keys %{ $self->{_args}{ptr_hosts} } ) { + foreach my $host (keys %{$self->{_args}{ptr_hosts}}) { - $host .= '.' if '.' ne substr( $host, -1, 1); # fully qualify name + $host .= '.' if '.' ne substr($host, -1, 1); # fully qualify name my $query = $res->search($host) or do { - if ( $res->errorstring eq 'NXDOMAIN' ) { - $self->log(LOGDEBUG, "host $host does not exist" ); + if ($res->errorstring eq 'NXDOMAIN') { + $self->log(LOGDEBUG, "host $host does not exist"); next; } - $self->log(LOGDEBUG, "query for $host failed (", $res->errorstring, ")" ); + $self->log(LOGDEBUG, "query for $host failed (", + $res->errorstring, ")"); next; }; @@ -230,38 +232,39 @@ sub has_forward_dns { foreach my $rr ($query->answer) { next unless $rr->type =~ /^(?:A|AAAA)$/; $hits++; - $self->check_ip_match( $rr->address ) and return 1; + $self->check_ip_match($rr->address) and return 1; } - if ( $hits ) { + if ($hits) { $self->log(LOGDEBUG, "PTR host has forward DNS") if $hits; return 1; - }; - }; - $self->adjust_karma( -1 ); + } + } + $self->adjust_karma(-1); $self->log(LOGINFO, "fail, no PTR hosts have forward DNS"); return; -}; +} sub check_ip_match { my $self = shift; my $ip = shift or return; - if ( $ip eq $self->qp->connection->remote_ip ) { - $self->log( LOGDEBUG, "forward ip match" ); + if ($ip eq $self->qp->connection->remote_ip) { + $self->log(LOGDEBUG, "forward ip match"); $self->connection->notes('fcrdns_match', 1); - $self->adjust_karma( 1 ); + $self->adjust_karma(1); return 1; - }; + } -# TODO: make this IPv6 compatible - my $dns_net = join('.', (split(/\./, $ip))[0,1,2] ); - my $rem_net = join('.', (split(/\./, $self->qp->connection->remote_ip))[0,1,2] ); + # TODO: make this IPv6 compatible + my $dns_net = join('.', (split(/\./, $ip))[0, 1, 2]); + my $rem_net = + join('.', (split(/\./, $self->qp->connection->remote_ip))[0, 1, 2]); - if ( $dns_net eq $rem_net ) { - $self->log( LOGNOTICE, "forward network match" ); + if ($dns_net eq $rem_net) { + $self->log(LOGNOTICE, "forward network match"); $self->connection->notes('fcrdns_match', 1); return 1; - }; + } return; -}; +} diff --git a/plugins/greylisting b/plugins/greylisting index 158404e..166130e 100644 --- a/plugins/greylisting +++ b/plugins/greylisting @@ -176,47 +176,51 @@ use AnyDBM_File; use Fcntl qw(:DEFAULT :flock LOCK_EX LOCK_NB); use Net::IP; -my $DENYMSG = "This mail is temporarily denied"; -my ($QPHOME) = ($0 =~ m!(.*?)/([^/]+)$!); -my $DB = "greylist.dbm"; +my $DENYMSG = "This mail is temporarily denied"; +my ($QPHOME) = ($0 =~ m!(.*?)/([^/]+)$!); +my $DB = "greylist.dbm"; my %PERMITTED_ARGS = map { $_ => 1 } qw(per_recipient remote_ip sender recipient black_timeout grey_timeout white_timeout deny_late db_dir nfslock p0f reject loglevel geoip upgrade ); my %DEFAULTS = ( - remote_ip => 1, - sender => 0, - recipient => 0, - reject => 1, - black_timeout => 50 * 60, # 50m - grey_timeout => 3 * 3600 + 20 * 60, # 3h:20m - white_timeout => 36 * 3600 * 24, # 36 days - nfslock => 0, - p0f => undef, -); + remote_ip => 1, + sender => 0, + recipient => 0, + reject => 1, + black_timeout => 50 * 60, # 50m + grey_timeout => 3 * 3600 + 20 * 60, # 3h:20m + white_timeout => 36 * 3600 * 24, # 36 days + nfslock => 0, + p0f => undef, + ); sub register { my ($self, $qp, %arg) = @_; - my $config = { %DEFAULTS, - map { split /\s+/, $_, 2 } $self->qp->config('denysoft_greylist'), - %arg }; - if (my @bad = grep { ! exists $PERMITTED_ARGS{$_} } sort keys %$config) { - $self->log(LOGALERT, "invalid parameter(s): " . join(',',@bad)); - } - # backwards compatibility with deprecated 'mode' setting - if ( defined $config->{mode} && ! defined $config->{reject} ) { - $config->{reject} = $config->{mode} =~ /testonly|off/i ? 0 : 1; + my $config = { + %DEFAULTS, + map { split /\s+/, $_, 2 } $self->qp->config('denysoft_greylist'), + %arg }; + if (my @bad = grep { !exists $PERMITTED_ARGS{$_} } sort keys %$config) { + $self->log(LOGALERT, "invalid parameter(s): " . join(',', @bad)); + } + + # backwards compatibility with deprecated 'mode' setting + if (defined $config->{mode} && !defined $config->{reject}) { + $config->{reject} = $config->{mode} =~ /testonly|off/i ? 0 : 1; + } $self->{_args} = $config; unless ($config->{recipient} || $config->{per_recipient}) { $self->register_hook('mail', 'mail_handler'); - } else { + } + else { $self->register_hook('rcpt', 'rcpt_handler'); } $self->prune_db(); - if ( $self->{_args}{upgrade} ) { + if ($self->{_args}{upgrade}) { $self->convert_db(); - }; + } } sub mail_handler { @@ -226,144 +230,159 @@ sub mail_handler { return DECLINED if $status != DENYSOFT; - if ( ! $self->{_args}{deny_late} ) { + if (!$self->{_args}{deny_late}) { return (DENYSOFT, $msg); - }; + } $transaction->notes('greylist', $msg); return DECLINED; } sub rcpt_handler { - my ($self, $transaction, $rcpt) = @_; - # Load per_recipient configs - my $config = { %{$self->{_args}}, - map { split /\s+/, $_, 2 } $self->qp->config('denysoft_greylist', { rcpt => $rcpt }) }; - # Check greylisting - my $sender = $transaction->sender; - my ($status, $msg) = $self->greylist($transaction, $sender, $rcpt, $config); - if ($status == DENYSOFT) { - # Deny here (per-rcpt) unless this is a <> sender, for smtp probes - return DENYSOFT, $msg if $sender->address; - $transaction->notes('greylist', $msg); - } - return DECLINED; + my ($self, $transaction, $rcpt) = @_; + + # Load per_recipient configs + my $config = { + %{$self->{_args}}, + map { split /\s+/, $_, 2 } + $self->qp->config('denysoft_greylist', {rcpt => $rcpt}) + }; + + # Check greylisting + my $sender = $transaction->sender; + my ($status, $msg) = $self->greylist($transaction, $sender, $rcpt, $config); + if ($status == DENYSOFT) { + + # Deny here (per-rcpt) unless this is a <> sender, for smtp probes + return DENYSOFT, $msg if $sender->address; + $transaction->notes('greylist', $msg); + } + return DECLINED; } sub hook_data { - my ($self, $transaction) = @_; - return DECLINED unless $transaction->notes('greylist'); - # Decline if ALL recipients are whitelisted - if (($transaction->notes('whitelistrcpt')||0) == scalar($transaction->recipients)) { - $self->log(LOGWARN,"skip: all recipients whitelisted"); - return DECLINED; - } - return DENYSOFT, $transaction->notes('greylist'); + my ($self, $transaction) = @_; + return DECLINED unless $transaction->notes('greylist'); + + # Decline if ALL recipients are whitelisted + if (($transaction->notes('whitelistrcpt') || 0) == + scalar($transaction->recipients)) + { + $self->log(LOGWARN, "skip: all recipients whitelisted"); + return DECLINED; + } + return DENYSOFT, $transaction->notes('greylist'); } sub greylist { my ($self, $transaction, $sender, $rcpt, $config) = @_; $config ||= $self->{_args}; - $self->log(LOGDEBUG, "config: " . - join(',',map { $_ . '=' . $config->{$_} } sort keys %$config)); + $self->log(LOGDEBUG, + "config: " + . join(',', + map { $_ . '=' . $config->{$_} } sort keys %$config) + ); return DECLINED if $self->is_immune(); - return DECLINED if ! $self->is_p0f_match(); + return DECLINED if !$self->is_p0f_match(); return DECLINED if $self->geoip_match(); my $db = $self->get_db_location(); - my $lock = $self->get_db_lock( $db ) or return DECLINED; - my $tied = $self->get_db_tie( $db, $lock ) or return DECLINED; - my $key = $self->get_db_key( $sender, $rcpt ) or return DECLINED; + my $lock = $self->get_db_lock($db) or return DECLINED; + my $tied = $self->get_db_tie($db, $lock) or return DECLINED; + my $key = $self->get_db_key($sender, $rcpt) or return DECLINED; - my $fmt = "%s:%d:%d:%d"; + my $fmt = "%s:%d:%d:%d"; -# new IP or entry timed out - record new - if ( ! $tied->{$key} ) { + # new IP or entry timed out - record new + if (!$tied->{$key}) { $tied->{$key} = sprintf $fmt, time, 1, 0, 0; $self->log(LOGWARN, "fail: initial DENYSOFT, unknown"); - return $self->cleanup_and_return( $tied, $lock ); - }; + return $self->cleanup_and_return($tied, $lock); + } my ($ts, $new, $black, $white) = split /:/, $tied->{$key}; $self->log(LOGDEBUG, "ts: " . localtime($ts) . ", now: " . localtime); - if ( $white ) { -# white IP - accept unless timed out + if ($white) { + + # white IP - accept unless timed out if (time - $ts < $config->{white_timeout}) { $tied->{$key} = sprintf $fmt, time, $new, $black, ++$white; $self->log(LOGINFO, "pass: white, $white deliveries"); - return $self->cleanup_and_return( $tied, $lock, DECLINED ); + return $self->cleanup_and_return($tied, $lock, DECLINED); } else { $self->log(LOGINFO, "key $key has timed out (white)"); } - }; - -# Black IP - deny, but don't update timestamp - if (time - $ts < $config->{black_timeout}) { - $tied->{$key} = sprintf $fmt, $ts, $new, ++$black, 0; - $self->log(LOGWARN, "fail: black DENYSOFT - $black deferred connections"); - return $self->cleanup_and_return( $tied, $lock ); } -# Grey IP - accept unless timed out + # Black IP - deny, but don't update timestamp + if (time - $ts < $config->{black_timeout}) { + $tied->{$key} = sprintf $fmt, $ts, $new, ++$black, 0; + $self->log(LOGWARN, + "fail: black DENYSOFT - $black deferred connections"); + return $self->cleanup_and_return($tied, $lock); + } + + # Grey IP - accept unless timed out elsif (time - $ts < $config->{grey_timeout}) { $tied->{$key} = sprintf $fmt, time, $new, $black, 1; $self->log(LOGWARN, "pass: updated grey->white"); - return $self->cleanup_and_return( $tied, $lock, DECLINED ); + return $self->cleanup_and_return($tied, $lock, DECLINED); } $self->log(LOGWARN, "pass: timed out (grey)"); - return $self->cleanup_and_return( $tied, $lock, DECLINED ); + return $self->cleanup_and_return($tied, $lock, DECLINED); } sub cleanup_and_return { - my ($self, $tied, $lock, $return_val ) = @_; + my ($self, $tied, $lock, $return_val) = @_; untie $tied; close $lock; - return $return_val if defined $return_val; # explicit override - return DECLINED if defined $self->{_args}{reject} && ! $self->{_args}{reject}; + return $return_val if defined $return_val; # explicit override + return DECLINED + if defined $self->{_args}{reject} && !$self->{_args}{reject}; return (DENYSOFT, $DENYMSG); -}; +} sub get_db_key { - my $self = shift; + my $self = shift; my $sender = shift || $self->qp->transaction->sender; - my $rcpt = shift || ($self->qp->transaction->recipients)[0]; + my $rcpt = shift || ($self->qp->transaction->recipients)[0]; my @key; - if ( $self->{_args}{remote_ip} ) { - my $nip = Net::IP->new( $self->qp->connection->remote_ip ); - push @key, $nip->intip; # convert IP to integer - }; + if ($self->{_args}{remote_ip}) { + my $nip = Net::IP->new($self->qp->connection->remote_ip); + push @key, $nip->intip; # convert IP to integer + } push @key, $sender->address || '' if $self->{_args}{sender}; - push @key, $rcpt->address if $rcpt && $self->{_args}{recipient}; - if ( ! scalar @key ) { + push @key, $rcpt->address if $rcpt && $self->{_args}{recipient}; + if (!scalar @key) { $self->log(LOGERROR, "enable one of remote_ip, sender, or recipient!"); return; - }; + } return join ':', @key; -}; +} sub get_db_tie { - my ( $self, $db, $lock ) = @_; + my ($self, $db, $lock) = @_; - tie( my %db, 'AnyDBM_File', $db, O_CREAT|O_RDWR, 0600) or do { + tie(my %db, 'AnyDBM_File', $db, O_CREAT | O_RDWR, 0600) or do { $self->log(LOGCRIT, "tie to database $db failed: $!"); close $lock; return; }; return \%db; -}; +} sub get_db_location { my $self = shift; my $transaction = $self->qp->transaction; - my $config = $self->{_args}; + my $config = $self->{_args}; if ($config->{db_dir} && $config->{db_dir} =~ m{^([-a-zA-Z0-9./_]+)$}) { $config->{db_dir} = $1; @@ -371,25 +390,28 @@ sub get_db_location { # Setup database location my $dbdir; - if ( $config->{per_recipient_db} ) { + if ($config->{per_recipient_db}) { $dbdir = $transaction->notes('per_rcpt_configdir'); - }; + } - my @candidate_dirs = ( $dbdir, $config->{db_dir}, - "/var/lib/qpsmtpd/greylisting", "$QPHOME/var/db", "$QPHOME/config", '.' ); + my @candidate_dirs = ( + $dbdir, $config->{db_dir}, + "/var/lib/qpsmtpd/greylisting", + "$QPHOME/var/db", "$QPHOME/config", '.' + ); - for my $d ( @candidate_dirs ) { - next if ! $d || ! -d $d; # impossible + for my $d (@candidate_dirs) { + next if !$d || !-d $d; # impossible $dbdir = $d; - last; # first match wins + last; # first match wins } my $db = "$dbdir/$DB"; - if ( ! -f $db && -f "$dbdir/denysoft_greylist.dbm" ) { - $db = "$dbdir/denysoft_greylist.dbm"; # old DB name + if (!-f $db && -f "$dbdir/denysoft_greylist.dbm") { + $db = "$dbdir/denysoft_greylist.dbm"; # old DB name } - $self->log(LOGDEBUG,"using $db as greylisting database"); + $self->log(LOGDEBUG, "using $db as greylisting database"); return $db; -}; +} sub get_db_lock { my ($self, $db) = @_; @@ -397,12 +419,12 @@ sub get_db_lock { return $self->get_db_lock_nfs($db) if $self->{_args}{nfslock}; # Check denysoft db - open( my $lock, ">$db.lock" ) or do { + open(my $lock, ">$db.lock") or do { $self->log(LOGCRIT, "opening lockfile failed: $!"); return; }; - flock( $lock, LOCK_EX ) or do { + flock($lock, LOCK_EX) or do { $self->log(LOGCRIT, "flock of lockfile failed: $!"); close $lock; return; @@ -418,110 +440,111 @@ sub get_db_lock_nfs { ### set up a lock - lasts until object looses scope my $nfslock = new File::NFSLock { - file => "$db.lock", - lock_type => LOCK_EX|LOCK_NB, - blocking_timeout => 10, # 10 sec - stale_lock_timeout => 30 * 60, # 30 min - } or do { + file => "$db.lock", + lock_type => LOCK_EX | LOCK_NB, + blocking_timeout => 10, # 10 sec + stale_lock_timeout => 30 * 60, # 30 min + } + or do { $self->log(LOGCRIT, "nfs lockfile failed: $!"); return; - }; + }; - open( my $lock, "+<$db.lock") or do { + open(my $lock, "+<$db.lock") or do { $self->log(LOGCRIT, "opening nfs lockfile failed: $!"); return; }; return $lock; -}; +} sub convert_db { my $self = shift; - my $db = $self->get_db_location(); - my $lock = $self->get_db_lock( $db ) or return DECLINED; - my $tied = $self->get_db_tie( $db, $lock ) or return DECLINED; + my $db = $self->get_db_location(); + my $lock = $self->get_db_lock($db) or return DECLINED; + my $tied = $self->get_db_tie($db, $lock) or return DECLINED; my $count = keys %$tied; my $converted = 0; - foreach my $key ( keys %$tied ) { - my ( @parts ) = split /:/, $key; - next if $parts[0] =~ /^[\d]+$/; # already converted + foreach my $key (keys %$tied) { + my (@parts) = split /:/, $key; + next if $parts[0] =~ /^[\d]+$/; # already converted $converted++; - my $nip = Net::IP->new( $parts[0] ); - $parts[0] = $nip->intip; # convert IP to integer + my $nip = Net::IP->new($parts[0]); + $parts[0] = $nip->intip; # convert IP to integer my $new_key = join ':', @parts; $tied->{$new_key} = $tied->{$key}; delete $tied->{$key}; - }; + } untie $tied; close $lock; - $self->log( LOGINFO, "converted $converted of $count DB entries" ); - return $self->cleanup_and_return( $tied, $lock, DECLINED ); -}; + $self->log(LOGINFO, "converted $converted of $count DB entries"); + return $self->cleanup_and_return($tied, $lock, DECLINED); +} sub prune_db { my $self = shift; - my $db = $self->get_db_location(); - my $lock = $self->get_db_lock( $db ) or return DECLINED; - my $tied = $self->get_db_tie( $db, $lock ) or return DECLINED; + my $db = $self->get_db_location(); + my $lock = $self->get_db_lock($db) or return DECLINED; + my $tied = $self->get_db_tie($db, $lock) or return DECLINED; my $count = keys %$tied; my $pruned = 0; - foreach my $key ( keys %$tied ) { + foreach my $key (keys %$tied) { my ($ts, $new, $black, $white) = split /:/, $tied->{$key}; my $age = time - $ts; next if $age < $self->{_args}{white_timeout}; $pruned++; delete $tied->{$key}; - }; + } untie $tied; close $lock; - $self->log( LOGINFO, "pruned $pruned of $count DB entries" ); - return $self->cleanup_and_return( $tied, $lock, DECLINED ); -}; + $self->log(LOGINFO, "pruned $pruned of $count DB entries"); + return $self->cleanup_and_return($tied, $lock, DECLINED); +} sub p0f_match { my $self = shift; - return if ! $self->{_args}{p0f}; + return if !$self->{_args}{p0f}; my $p0f = $self->connection->notes('p0f'); - if ( !$p0f || !ref $p0f ) { # p0f fingerprint info not found + if (!$p0f || !ref $p0f) { # p0f fingerprint info not found $self->LOGINFO(LOGERROR, "p0f info missing"); return; - }; + } my %valid_matches = map { $_ => 1 } qw( genre detail uptime link distance ); - my %requested_matches = split(/\,/, $self->{_args}{p0f} ); + my %requested_matches = split(/\,/, $self->{_args}{p0f}); foreach my $key (keys %requested_matches) { - next if ! $key; - if ( ! defined $valid_matches{$key} ) { - $self->log(LOGERROR, "discarding invalid match key ($key)" ); + next if !$key; + if (!defined $valid_matches{$key}) { + $self->log(LOGERROR, "discarding invalid match key ($key)"); next; - }; + } my $value = $requested_matches{$key}; - next if ! defined $value; # bad config setting? - next if ! defined $p0f->{$key}; # p0f didn't detect the value + next if !defined $value; # bad config setting? + next if !defined $p0f->{$key}; # p0f didn't detect the value - if ( $key eq 'distance' && $p0f->{$key} > $value ) { + if ($key eq 'distance' && $p0f->{$key} > $value) { $self->log(LOGDEBUG, "p0f distance match ($value)"); return 1; - }; - if ( $key eq 'genre' && $p0f->{$key} =~ /$value/i ) { + } + if ($key eq 'genre' && $p0f->{$key} =~ /$value/i) { $self->log(LOGDEBUG, "p0f genre match ($value)"); return 1; - }; - if ( $key eq 'uptime' && $p0f->{$key} < $value ) { + } + if ($key eq 'uptime' && $p0f->{$key} < $value) { $self->log(LOGDEBUG, "p0f uptime match ($value)"); return 1; - }; - if ( $key eq 'link' && $p0f->{$key} =~ /$value/i ) { + } + if ($key eq 'link' && $p0f->{$key} =~ /$value/i) { $self->log(LOGDEBUG, "p0f link match ($value)"); return 1; - }; + } } $self->log(LOGINFO, "skip: no p0f match"); return; @@ -530,21 +553,21 @@ sub p0f_match { sub geoip_match { my $self = shift; - return if ! $self->{_args}{geoip}; + return if !$self->{_args}{geoip}; my $country = $self->connection->notes('geoip_country'); - my $c_name = $self->connection->notes('geoip_country_name') || ''; + my $c_name = $self->connection->notes('geoip_country_name') || ''; - if ( !$country ) { + if (!$country) { $self->LOGINFO(LOGNOTICE, "skip: no geoip country"); return; - }; + } my @countries = split /,/, $self->{_args}{geoip}; - foreach ( @countries ) { + foreach (@countries) { $self->LOGINFO(LOGINFO, "pass: geoip country match ($_, $c_name)"); return 1 if lc $_ eq lc $country; - }; + } $self->LOGINFO(LOGINFO, "skip: no geoip match ($c_name)"); return; diff --git a/plugins/headers b/plugins/headers index deb5b70..8dd0220 100644 --- a/plugins/headers +++ b/plugins/headers @@ -97,71 +97,73 @@ use Qpsmtpd::Constants; use Date::Parse qw(str2time); my @required_headers = qw/ From /; # <- to be RFC 5322 compliant, add Date here + #my @should_headers = qw/ Message-ID /; my @singular_headers = qw/ Date From Sender Reply-To To Cc Bcc - Message-Id In-Reply-To References - Subject /; + Message-Id In-Reply-To References + Subject /; sub register { - my ($self, $qp ) = (shift, shift); + my ($self, $qp) = (shift, shift); $self->log(LOGWARN, "invalid arguments") if @_ % 2; - $self->{_args} = { @_ }; + $self->{_args} = {@_}; - $self->{_args}{reject_type} ||= 'perm'; # set default - if ( ! defined $self->{_args}{reject} ) { - $self->{_args}{reject} = 1; # set default - }; + $self->{_args}{reject_type} ||= 'perm'; # set default + if (!defined $self->{_args}{reject}) { + $self->{_args}{reject} = 1; # set default + } - if ( $self->{_args}{require} ) { + if ($self->{_args}{require}) { @required_headers = split /,/, $self->{_args}{require}; - }; + } } sub hook_data_post { my ($self, $transaction) = @_; - if ( $transaction->data_size == 0 ) { - return $self->get_reject( "You must send some data first", "no data" ); - }; + if ($transaction->data_size == 0) { + return $self->get_reject("You must send some data first", "no data"); + } my $header = $transaction->header or do { - return $self->get_reject( "Headers are missing", "missing headers" ); + return $self->get_reject("Headers are missing", "missing headers"); }; return (DECLINED, "immune") if $self->is_immune(); - foreach my $h ( @required_headers ) { + foreach my $h (@required_headers) { next if $header->get($h); - $self->adjust_karma( -1 ); - return $self->get_reject( "We require a valid $h header", "no $h header"); - }; + $self->adjust_karma(-1); + return $self->get_reject("We require a valid $h header", + "no $h header"); + } - foreach my $h ( @singular_headers ) { - next if ! $header->get($h); # doesn't exist + foreach my $h (@singular_headers) { + next if !$header->get($h); # doesn't exist my @qty = $header->get($h); - next if @qty == 1; # only 1 header - $self->adjust_karma( -1 ); - return $self->get_reject( - "Only one $h header allowed. See RFC 5322, Section 3.6", - "too many $h headers", - ); - }; + next if @qty == 1; # only 1 header + $self->adjust_karma(-1); + return + $self->get_reject( + "Only one $h header allowed. See RFC 5322, Section 3.6", + "too many $h headers",); + } my $err_msg = $self->invalid_date_range(); - if ( $err_msg ) { - $self->adjust_karma( -1 ); + if ($err_msg) { + $self->adjust_karma(-1); return $self->get_reject($err_msg, $err_msg); - }; + } - $self->log( LOGINFO, 'pass' ); + $self->log(LOGINFO, 'pass'); return (DECLINED); -}; +} sub invalid_date_range { my $self = shift; - return if ! $self->transaction->header; + return if !$self->transaction->header; my $date = shift || $self->transaction->header->get('Date') or return; chomp $date; @@ -171,16 +173,16 @@ sub invalid_date_range { }; my $past = $self->{_args}{past}; - if ( $past && $ts < time - ($past*24*3600) ) { + if ($past && $ts < time - ($past * 24 * 3600)) { $self->log(LOGINFO, "fail, date too old ($date)"); return "The Date header is too far in the past"; - }; + } my $future = $self->{_args}{future}; - if ( $future && $ts > time + ($future*24*3600) ) { + if ($future && $ts > time + ($future * 24 * 3600)) { $self->log(LOGINFO, "fail, date in future ($date)"); return "The Date header is too far in the future"; - }; + } return; } diff --git a/plugins/helo b/plugins/helo index a4c5404..b5d7fb3 100644 --- a/plugins/helo +++ b/plugins/helo @@ -225,40 +225,40 @@ use Qpsmtpd::Constants; sub register { my ($self, $qp) = (shift, shift); - $self->{_args} = { @_ }; + $self->{_args} = {@_}; $self->{_args}{reject_type} = 'disconnect'; $self->{_args}{policy} ||= 'lenient'; $self->{_args}{dns_timeout} ||= $self->{_args}{timeout} || 5; - if ( ! defined $self->{_args}{reject} ) { + if (!defined $self->{_args}{reject}) { $self->{_args}{reject} = 1; - }; + } $self->populate_tests(); $self->init_resolver() or return; - $self->register_hook('helo', 'helo_handler'); - $self->register_hook('ehlo', 'helo_handler'); + $self->register_hook('helo', 'helo_handler'); + $self->register_hook('ehlo', 'helo_handler'); $self->register_hook('data_post', 'data_post_handler'); -}; +} sub helo_handler { my ($self, $transaction, $host) = @_; - if ( ! $host ) { + if (!$host) { $self->log(LOGINFO, "fail, no helo host"); return DECLINED; - }; + } return DECLINED if $self->is_immune(); - foreach my $test ( @{ $self->{_helo_tests} } ) { - my @err = $self->$test( $host ); - if ( scalar @err ) { - $self->adjust_karma( -1 ); - return $self->get_reject( @err ); - }; - }; + foreach my $test (@{$self->{_helo_tests}}) { + my @err = $self->$test($host); + if (scalar @err) { + $self->adjust_karma(-1); + return $self->get_reject(@err); + } + } $self->log(LOGINFO, "pass"); return DECLINED; @@ -268,239 +268,249 @@ sub data_post_handler { my ($self, $transaction) = @_; $transaction->header->delete('X-HELO'); - $transaction->header->add('X-HELO', $self->qp->connection->hello_host, 0 ); + $transaction->header->add('X-HELO', $self->qp->connection->hello_host, 0); return (DECLINED); -}; +} sub populate_tests { my $self = shift; my $policy = $self->{_args}{policy}; - @{ $self->{_helo_tests} } = qw/ is_in_badhelo invalid_localhost is_forged_literal is_plain_ip /; + @{$self->{_helo_tests}} = + qw/ is_in_badhelo invalid_localhost is_forged_literal is_plain_ip /; - if ( $policy eq 'rfc' || $policy eq 'strict' ) { - push @{ $self->{_helo_tests} }, qw/ is_not_fqdn no_forward_dns no_reverse_dns /; - }; + if ($policy eq 'rfc' || $policy eq 'strict') { + push @{$self->{_helo_tests}}, + qw/ is_not_fqdn no_forward_dns no_reverse_dns /; + } - if ( $policy eq 'strict' ) { - push @{ $self->{_helo_tests} }, qw/ is_address_literal no_matching_dns /; - }; -}; + if ($policy eq 'strict') { + push @{$self->{_helo_tests}}, qw/ is_address_literal no_matching_dns /; + } +} sub is_in_badhelo { - my ( $self, $host ) = @_; + my ($self, $host) = @_; my $error = "I do not believe you are $host."; $host = lc $host; foreach my $bad ($self->qp->config('badhelo')) { - if ( $bad =~ /[\{\}\[\]\(\)\^\$\|\*\+\?\\\!]/ ) { # it's a regexp - return $self->is_regex_match( $host, $bad ); - }; - if ( $host eq lc $bad) { + if ($bad =~ /[\{\}\[\]\(\)\^\$\|\*\+\?\\\!]/) { # it's a regexp + return $self->is_regex_match($host, $bad); + } + if ($host eq lc $bad) { return ($error, "in badhelo"); } } return; -}; +} sub is_regex_match { - my ( $self, $host, $pattern ) = @_; + my ($self, $host, $pattern) = @_; my $error = "Your HELO hostname is not allowed"; #$self->log( LOGDEBUG, "is regex ($pattern)"); - if ( substr( $pattern, 0, 1) eq '!' ) { + if (substr($pattern, 0, 1) eq '!') { $pattern = substr $pattern, 1; - if ( $host !~ /$pattern/ ) { + if ($host !~ /$pattern/) { + #$self->log( LOGDEBUG, "matched ($pattern)"); return ($error, "badhelo pattern match ($pattern)"); - }; + } return; } - if ( $host =~ /$pattern/ ) { + if ($host =~ /$pattern/) { + #$self->log( LOGDEBUG, "matched ($pattern)"); return ($error, "badhelo pattern match ($pattern)"); - }; + } return; } sub invalid_localhost { - my ( $self, $host ) = @_; + my ($self, $host) = @_; return if lc $host ne 'localhost'; - if ( $self->qp->connection->remote_ip ne '127.0.0.1' ) { + if ($self->qp->connection->remote_ip ne '127.0.0.1') { + #$self->log( LOGINFO, "fail, not localhost" ); return ("You are not localhost", "invalid localhost"); - }; - $self->log( LOGDEBUG, "pass, is localhost" ); + } + $self->log(LOGDEBUG, "pass, is localhost"); return; -}; +} sub is_plain_ip { - my ( $self, $host ) = @_; - return if $host =~ /[^\d\.]+/; # has chars other than digits and a dot + my ($self, $host) = @_; + return if $host =~ /[^\d\.]+/; # has chars other than digits and a dot return if $host !~ m/^(\d{1,3}\.){3}\d{1,3}$/; - $self->log( LOGDEBUG, "fail, plain IP" ); + $self->log(LOGDEBUG, "fail, plain IP"); return ("Plain IP is invalid HELO hostname (RFC 2821)", "plain IP"); -}; +} sub is_address_literal { - my ( $self, $host ) = @_; + my ($self, $host) = @_; return if $host !~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/; - $self->log( LOGDEBUG, "fail, bracketed IP" ); - return ("RFC 2821 allows an address literal, but we do not", "bracketed IP"); -}; + $self->log(LOGDEBUG, "fail, bracketed IP"); + return ("RFC 2821 allows an address literal, but we do not", + "bracketed IP"); +} sub is_forged_literal { - my ( $self, $host ) = @_; + my ($self, $host) = @_; return if $host !~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/; -# should we add exceptions for reserved internal IP space? (192.168,10., etc?) + # should we add exceptions for reserved internal IP space? (192.168,10., etc?) $host = substr $host, 1, -1; return if $host eq $self->qp->connection->remote_ip; return ("Forged IPs not accepted here", "forged IP literal"); -}; +} sub is_not_fqdn { my ($self, $host) = @_; - return if $host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/; # address literal, skip - if ( $host !~ /\./ ) { # has no dots + return if $host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/; # address literal, skip + if ($host !~ /\./) { # has no dots return ("HELO name is not fully qualified. Read RFC 2821", "not FQDN"); - }; - if ( $host =~ /[^a-zA-Z0-9\-\.]/ ) { - return ("HELO name contains invalid FQDN characters. Read RFC 1035", "invalid FQDN chars"); - }; + } + if ($host =~ /[^a-zA-Z0-9\-\.]/) { + return ("HELO name contains invalid FQDN characters. Read RFC 1035", + "invalid FQDN chars"); + } return; -}; +} sub no_forward_dns { - my ( $self, $host ) = @_; + my ($self, $host) = @_; - return if $self->is_address_literal( $host ); + return if $self->is_address_literal($host); my $res = $self->init_resolver(); - $host = "$host." if $host !~ /\.$/; # fully qualify name + $host = "$host." if $host !~ /\.$/; # fully qualify name my $query = $res->search($host); - if (! $query) { - if ( $res->errorstring eq 'NXDOMAIN' ) { + if (!$query) { + if ($res->errorstring eq 'NXDOMAIN') { return ("HELO hostname does not exist", "no such host"); } - $self->log(LOGERROR, "skip, query failed (", $res->errorstring, ")" ); + $self->log(LOGERROR, "skip, query failed (", $res->errorstring, ")"); return; - }; + } my $hits = 0; foreach my $rr ($query->answer) { next unless $rr->type =~ /^(?:A|AAAA)$/; - $self->check_ip_match( $rr->address ); + $self->check_ip_match($rr->address); $hits++; last if $self->connection->notes('helo_forward_match'); } - if ( $hits ) { + if ($hits) { $self->log(LOGDEBUG, "pass, forward DNS") if $hits; return; - }; + } return ("HELO hostname did not resolve", "no forward DNS"); -}; +} sub no_reverse_dns { - my ( $self, $host, $ip ) = @_; + my ($self, $host, $ip) = @_; my $res = $self->init_resolver(); $ip ||= $self->qp->connection->remote_ip; - my $query = $res->query( $ip ) or do { - if ( $res->errorstring eq 'NXDOMAIN' ) { + my $query = $res->query($ip) or do { + if ($res->errorstring eq 'NXDOMAIN') { return ("no rDNS for $ip", "no rDNS"); - }; - $self->log( LOGINFO, $res->errorstring ); - return ("error getting reverse DNS for $ip", "rDNS " . $res->errorstring); + } + $self->log(LOGINFO, $res->errorstring); + return ("error getting reverse DNS for $ip", + "rDNS " . $res->errorstring); }; my $hits = 0; for my $rr ($query->answer) { next if $rr->type ne 'PTR'; - $self->log(LOGDEBUG, "PTR: " . $rr->ptrdname ); - $self->check_name_match( lc $rr->ptrdname, lc $host ); + $self->log(LOGDEBUG, "PTR: " . $rr->ptrdname); + $self->check_name_match(lc $rr->ptrdname, lc $host); $hits++; - }; - if ( $hits ) { + } + if ($hits) { $self->log(LOGDEBUG, "has rDNS"); return; - }; + } return ("no reverse DNS for $ip", "no rDNS"); -}; +} sub no_matching_dns { - my ( $self, $host ) = @_; + my ($self, $host) = @_; -# this is called iprev, or "Forward-confirmed reverse DNS" and is discussed -# in RFC 5451. FCrDNS is done for the remote IP in the fcrdns plugin. Here -# we do it on the HELO hostname. -# consider adding status to Authentication-Results header + # this is called iprev, or "Forward-confirmed reverse DNS" and is discussed + # in RFC 5451. FCrDNS is done for the remote IP in the fcrdns plugin. Here + # we do it on the HELO hostname. + # consider adding status to Authentication-Results header - if ( $self->connection->notes('helo_forward_match') && - $self->connection->notes('helo_reverse_match') ) { - $self->log( LOGDEBUG, "foward and reverse match" ); - $self->adjust_karma( 1 ); # a perfect match - return; - }; - - if ( $self->connection->notes('helo_forward_match') ) { - $self->log( LOGDEBUG, "name matches IP" ); + if ( $self->connection->notes('helo_forward_match') + && $self->connection->notes('helo_reverse_match')) + { + $self->log(LOGDEBUG, "foward and reverse match"); + $self->adjust_karma(1); # a perfect match return; } - if ( $self->connection->notes('helo_reverse_match') ) { - $self->log( LOGDEBUG, "reverse matches name" ); - return; - }; - $self->log( LOGINFO, "fail, no forward or reverse DNS match" ); + if ($self->connection->notes('helo_forward_match')) { + $self->log(LOGDEBUG, "name matches IP"); + return; + } + if ($self->connection->notes('helo_reverse_match')) { + $self->log(LOGDEBUG, "reverse matches name"); + return; + } + + $self->log(LOGINFO, "fail, no forward or reverse DNS match"); return ("That HELO hostname fails FCrDNS", "no matching DNS"); -}; +} sub check_ip_match { my $self = shift; my $ip = shift or return; - if ( $ip eq $self->qp->connection->remote_ip ) { - $self->log( LOGDEBUG, "forward ip match" ); + if ($ip eq $self->qp->connection->remote_ip) { + $self->log(LOGDEBUG, "forward ip match"); $self->connection->notes('helo_forward_match', 1); return; - }; + } - my $dns_net = join('.', (split(/\./, $ip))[0,1,2] ); - my $rem_net = join('.', (split(/\./, $self->qp->connection->remote_ip))[0,1,2] ); + my $dns_net = join('.', (split(/\./, $ip))[0, 1, 2]); + my $rem_net = + join('.', (split(/\./, $self->qp->connection->remote_ip))[0, 1, 2]); - if ( $dns_net eq $rem_net ) { - $self->log( LOGNOTICE, "forward network match" ); + if ($dns_net eq $rem_net) { + $self->log(LOGNOTICE, "forward network match"); $self->connection->notes('helo_forward_match', 1); - }; -}; + } +} sub check_name_match { my $self = shift; my ($dns_name, $helo_name) = @_; - return if ! $dns_name; - return if split(/\./, $dns_name) < 2; # not a FQDN + return if !$dns_name; + return if split(/\./, $dns_name) < 2; # not a FQDN - if ( $dns_name eq $helo_name ) { - $self->log( LOGDEBUG, "reverse name match" ); + if ($dns_name eq $helo_name) { + $self->log(LOGDEBUG, "reverse name match"); $self->connection->notes('helo_reverse_match', 1); return; - }; + } - my $dns_dom = join('.', (split(/\./, $dns_name ))[-2,-1] ); - my $helo_dom = join('.', (split(/\./, $helo_name))[-2,-1] ); + my $dns_dom = join('.', (split(/\./, $dns_name))[-2, -1]); + my $helo_dom = join('.', (split(/\./, $helo_name))[-2, -1]); - if ( $dns_dom eq $helo_dom ) { - $self->log( LOGNOTICE, "reverse domain match" ); + if ($dns_dom eq $helo_dom) { + $self->log(LOGNOTICE, "reverse domain match"); $self->connection->notes('helo_reverse_match', 1); - }; -}; + } +} diff --git a/plugins/help b/plugins/help index e9cd4d5..4c24c22 100644 --- a/plugins/help +++ b/plugins/help @@ -42,15 +42,15 @@ The hard coded F path should be changed. my %config = (); sub register { - my ($self,$qp,%args) = @_; + my ($self, $qp, %args) = @_; my ($file, $cmd); unless (%args) { $config{help_dir} = './help/'; } foreach (keys %args) { - /^(\w+)$/ or - $self->log(LOGWARN, "Invalid argument for the 'help' plugin $_"), - next; + /^(\w+)$/ + or $self->log(LOGWARN, "Invalid argument for the 'help' plugin $_"), + next; $cmd = $1; if ($cmd eq 'not_implemented') { $config{'not_implemented'} = $args{'not_implemented'}; @@ -58,28 +58,28 @@ sub register { elsif ($cmd eq 'help_dir') { $file = $args{$cmd}; $file =~ m#^([\w\.\-/]+)$# - or $self->log(LOGERROR, + or $self->log(LOGERROR, "Invalid charachters in filename for command $cmd"), - next; + next; $config{'help_dir'} = $1; } else { $file = $args{$cmd}; $file =~ m#^([\w\.\-/]+)$# - or $self->log(LOGERROR, + or $self->log(LOGERROR, "Invalid charachters in filename for command $cmd"), - next; + next; $file = $1; if ($file =~ m#/#) { - -e $file + -e $file or $self->log(LOGWARN, "No help file for command '$cmd'"), - next; + next; } else { $file = "help/$file"; - if (-e "help/$file") { ## FIXME: path + if (-e "help/$file") { ## FIXME: path $file = "help/$file"; - } + } else { $self->log(LOGWARN, "No help file for command '$cmd'"); next; @@ -105,8 +105,8 @@ sub hook_help { $cmd = lc $args[0]; - unless ($cmd =~ /^(\w+)$/) { # else someone could request - # "HELP ../../../../../../../../etc/passwd" + unless ($cmd =~ /^(\w+)$/) { # else someone could request + # "HELP ../../../../../../../../etc/passwd" $self->qp->respond(502, "Invalid command name"); return DONE; } @@ -114,25 +114,25 @@ sub hook_help { if (exists $config{$cmd}) { $help = read_helpfile($config{$cmd}, $cmd) - or $self->log(LOGERROR, "failed to open help file for $cmd: $!"), - return OK, "No help available for SMTP command: $cmd"; + or $self->log(LOGERROR, "failed to open help file for $cmd: $!"), + return OK, "No help available for SMTP command: $cmd"; } - elsif (exists $config{'help_dir'} && -e $config{'help_dir'}."/$cmd") { - $help = read_helpfile($config{help_dir}."/$cmd", $cmd) - or $self->log(LOGERROR, "failed to open help file for $cmd: $!"), - return OK, "No help available for SMTP command: $cmd"; + elsif (exists $config{'help_dir'} && -e $config{'help_dir'} . "/$cmd") { + $help = read_helpfile($config{help_dir} . "/$cmd", $cmd) + or $self->log(LOGERROR, "failed to open help file for $cmd: $!"), + return OK, "No help available for SMTP command: $cmd"; } - $help = "No help available for SMTP command: $cmd" # empty file + $help = "No help available for SMTP command: $cmd" # empty file unless $help; return OK, split(/\n/, $help); } sub read_helpfile { - my ($file,$cmd) = @_; + my ($file, $cmd) = @_; my $help; open HELP, $file - or return undef; - { + or return undef; + { local $/ = undef; $help = ; }; diff --git a/plugins/hosts_allow b/plugins/hosts_allow index 1ea62df..e5c2cc8 100644 --- a/plugins/hosts_allow +++ b/plugins/hosts_allow @@ -57,7 +57,7 @@ use Qpsmtpd::Constants; use Socket; sub hook_pre_connection { - my ($self,$transaction,%args) = @_; + my ($self, $transaction, %args) = @_; # remote_ip => inet_ntoa($iaddr), # remote_port => $port, @@ -70,62 +70,62 @@ sub hook_pre_connection { my $max = $args{max_conn_ip}; my $karma = $self->connection->notes('karma_history'); - if ( $max ) { - my $num_conn = 1; # seed with current value + if ($max) { + my $num_conn = 1; # seed with current value my $raddr = inet_aton($remote); foreach my $rip (@{$args{child_addrs}}) { ++$num_conn if (defined $rip && $rip eq $raddr); } - $max = $self->karma_bump( $karma, $max ) if defined $karma; - if ($num_conn > $max ) { + $max = $self->karma_bump($karma, $max) if defined $karma; + if ($num_conn > $max) { my $err_mess = "too many connections from $remote"; $self->log(LOGINFO, "fail: $err_mess ($num_conn > $max)"); return (DENYSOFT, "$err_mess, try again later"); } } - my @r = $self->in_hosts_allow( $remote ); + my @r = $self->in_hosts_allow($remote); return @r if scalar @r; - $self->log(LOGDEBUG, "pass" ); + $self->log(LOGDEBUG, "pass"); return (DECLINED); } sub in_hosts_allow { - my $self = shift; + my $self = shift; my $remote = shift; - foreach ( $self->qp->config('hosts_allow') ) { + foreach ($self->qp->config('hosts_allow')) { s/^\s*//; # trim leading whitespace my ($ipmask, $const, $message) = split /\s+/, $_, 3; next unless defined $const; - my ($net,$mask) = split /\//, $ipmask, 2; - $mask = 32 if ! defined $mask; - $mask = pack "B32", "1"x($mask)."0"x(32-$mask); + my ($net, $mask) = split /\//, $ipmask, 2; + $mask = 32 if !defined $mask; + $mask = pack "B32", "1" x ($mask) . "0" x (32 - $mask); if (join('.', unpack('C4', inet_aton($remote) & $mask)) eq $net) { $const = Qpsmtpd::Constants::return_code($const) || DECLINED; - if ( $const =~ /deny/i ) { - $self->log( LOGINFO, "fail, $message" ); - }; - $self->log( LOGDEBUG, "pass, $const, $message" ); - return($const, $message); + if ($const =~ /deny/i) { + $self->log(LOGINFO, "fail, $message"); + } + $self->log(LOGDEBUG, "pass, $const, $message"); + return ($const, $message); } } return; -}; +} sub karma_bump { my ($self, $karma, $max) = @_; - if ( $karma > 5 ) { + if ($karma > 5) { $self->log(LOGDEBUG, "connect limit +3 for positive karma"); return $max + 3; - }; - if ( $karma <= 0 ) { + } + if ($karma <= 0) { $self->log(LOGINFO, "connect limit 1, karma $karma"); return 1; - }; + } return $max; -}; +} diff --git a/plugins/http_config b/plugins/http_config index bb3f674..79bdece 100644 --- a/plugins/http_config +++ b/plugins/http_config @@ -1,4 +1,5 @@ #!perl -w + =head1 NAME http_config @@ -30,21 +31,22 @@ use LWP::Simple qw(get); my @urls; sub register { - my ($self, $qp, @args) = @_; - @urls = @args; + my ($self, $qp, @args) = @_; + @urls = @args; } sub hook_config { - my ($self, $transaction, $config) = @_; - $self->log(LOGNOTICE, "http_config called with $config"); - for my $url (@urls) { - $self->log(LOGDEBUG, "http_config loading from $url"); - my @config = split /[\r\n]+/, (get "$url$config" || ""); - chomp @config; - @config = grep { $_ and $_ !~ m/^\s*#/ and $_ =~ m/\S/ } @config; - close CF; - # $self->log(LOGNOTICE, "returning http_config for $config ",Data::Dumper->Dump([\@config], [qw(config)])); - return (OK, @config) if @config; - } - return DECLINED; + my ($self, $transaction, $config) = @_; + $self->log(LOGNOTICE, "http_config called with $config"); + for my $url (@urls) { + $self->log(LOGDEBUG, "http_config loading from $url"); + my @config = split /[\r\n]+/, (get "$url$config" || ""); + chomp @config; + @config = grep { $_ and $_ !~ m/^\s*#/ and $_ =~ m/\S/ } @config; + close CF; + +# $self->log(LOGNOTICE, "returning http_config for $config ",Data::Dumper->Dump([\@config], [qw(config)])); + return (OK, @config) if @config; + } + return DECLINED; } diff --git a/plugins/ident/geoip b/plugins/ident/geoip index 9964457..b25408b 100644 --- a/plugins/ident/geoip +++ b/plugins/ident/geoip @@ -111,22 +111,23 @@ use strict; use warnings; use Qpsmtpd::Constants; + #use Geo::IP; # eval'ed in register() #use Math::Trig; # eval'ed in set_distance_gc sub register { - my ($self, $qp ) = shift, shift; + my ($self, $qp) = shift, shift; $self->log(LOGERROR, "Bad arguments") if @_ % 2; - $self->{_args} = { @_ }; - $self->{_args}{db_dir} ||= '/usr/local/share/GeoIP'; + $self->{_args} = {@_}; + $self->{_args}{db_dir} ||= '/usr/local/share/GeoIP'; eval 'use Geo::IP'; - if ( $@ ) { + if ($@) { warn "could not load Geo::IP"; - $self->log( LOGERROR, "could not load Geo::IP" ); + $self->log(LOGERROR, "could not load Geo::IP"); return; - }; + } # Note that opening the GeoIP DB only in register has caused problems before: # https://github.com/smtpd/qpsmtpd/commit/29ea9516806e9a8ca6519fcf987dbd684793ebdd#plugins/ident/geoip @@ -136,8 +137,8 @@ sub register { $self->init_my_country_code(); - $self->register_hook( 'connect', 'connect_handler' ); -}; + $self->register_hook('connect', 'connect_handler'); +} sub connect_handler { my $self = shift; @@ -146,7 +147,7 @@ sub connect_handler { $self->open_geoip_db(); my $c_code = $self->set_country_code() or do { - $self->log( LOGINFO, "skip, no results" ); + $self->log(LOGINFO, "skip, no results"); return DECLINED; }; $self->qp->connection->notes('geoip_country', $c_code); @@ -154,24 +155,26 @@ sub connect_handler { my $c_name = $self->set_country_name(); my ($city, $continent_code, $distance) = ''; - if ( $self->{_my_country_code} ) { - $continent_code = $self->set_continent( $c_code ); - $city = $self->set_city_gc(); - $distance = $self->set_distance_gc(); - }; + if ($self->{_my_country_code}) { + $continent_code = $self->set_continent($c_code); + $city = $self->set_city_gc(); + $distance = $self->set_distance_gc(); + } my @msg_parts; - push @msg_parts, $continent_code if $continent_code && $continent_code ne '--'; - push @msg_parts, $c_code if $c_code; + push @msg_parts, $continent_code + if $continent_code && $continent_code ne '--'; + push @msg_parts, $c_code if $c_code; + #push @msg_parts, $c_name if $c_name; - push @msg_parts, $city if $city; - if ( $distance ) { + push @msg_parts, $city if $city; + if ($distance) { push @msg_parts, "\t$distance km"; - if ( $self->{_args}{too_far} && $distance > $self->{_args}{too_far} ) { - $self->adjust_karma( -1 ); - }; - }; - $self->log(LOGINFO, join( ", ", @msg_parts) ); + if ($self->{_args}{too_far} && $distance > $self->{_args}{too_far}) { + $self->adjust_karma(-1); + } + } + $self->log(LOGINFO, join(", ", @msg_parts)); return DECLINED; } @@ -181,156 +184,159 @@ sub open_geoip_db { # this might detect if the DB connection failed. If not, this is where # to add more code to do it. - return if ( defined $self->{_geoip_city} || defined $self->{_geoip} ); + return if (defined $self->{_geoip_city} || defined $self->{_geoip}); # The methods for using GeoIP work differently for the City vs Country DB # save the handles in different locations my $db_dir = $self->{_args}{db_dir}; - foreach my $db ( qw/ GeoIPCity GeoLiteCity / ) { - if ( -f "$db_dir/$db.dat" ) { + foreach my $db (qw/ GeoIPCity GeoLiteCity /) { + if (-f "$db_dir/$db.dat") { $self->log(LOGDEBUG, "using db $db"); - $self->{_geoip_city} = Geo::IP->open( "$db_dir/$db.dat" ); + $self->{_geoip_city} = Geo::IP->open("$db_dir/$db.dat"); } - }; + } # can't think of a good reason to load country if city data is present - if ( ! $self->{_geoip_city} ) { + if (!$self->{_geoip_city}) { $self->log(LOGDEBUG, "using default db"); - $self->{_geoip} = Geo::IP->new(); # loads default Country DB - }; -}; + $self->{_geoip} = Geo::IP->new(); # loads default Country DB + } +} sub init_my_country_code { my $self = shift; my $ip = $self->{_args}{distance} or return; - $self->{_my_country_code} = $self->get_country_code( $ip ); -}; + $self->{_my_country_code} = $self->get_country_code($ip); +} sub set_country_code { my $self = shift; return $self->get_country_code_gc() if $self->{_geoip_city}; my $remote_ip = $self->qp->connection->remote_ip; - my $code = $self->get_country_code(); + my $code = $self->get_country_code(); $self->qp->connection->notes('geoip_country', $code); return $code; -}; +} sub get_country_code { my $self = shift; my $ip = shift || $self->qp->connection->remote_ip; - return $self->get_country_code_gc( $ip ) if $self->{_geoip_city}; - return $self->{_geoip}->country_code_by_addr( $ip ); -}; + return $self->get_country_code_gc($ip) if $self->{_geoip_city}; + return $self->{_geoip}->country_code_by_addr($ip); +} sub get_country_code_gc { my $self = shift; - my $ip = shift || $self->qp->connection->remote_ip; - $self->{_geoip_record} = $self->{_geoip_city}->record_by_addr($ip) or return; + my $ip = shift || $self->qp->connection->remote_ip; + $self->{_geoip_record} = $self->{_geoip_city}->record_by_addr($ip) + or return; return $self->{_geoip_record}->country_code; -}; +} sub set_country_name { my $self = shift; return $self->set_country_name_gc() if $self->{_geoip_city}; my $remote_ip = $self->qp->connection->remote_ip; - my $name = $self->{_geoip}->country_name_by_addr( $remote_ip ) or return; + my $name = $self->{_geoip}->country_name_by_addr($remote_ip) or return; $self->qp->connection->notes('geoip_country_name', $name); return $name; -}; +} sub set_country_name_gc { my $self = shift; - return if ! $self->{_geoip_record}; + return if !$self->{_geoip_record}; my $remote_ip = $self->qp->connection->remote_ip; my $name = $self->{_geoip_record}->country_name() or return; $self->qp->connection->notes('geoip_country_name', $name); return $name; -}; +} sub set_continent { my $self = shift; return $self->set_continent_gc() if $self->{_geoip_city}; my $c_code = shift or return; - my $continent = $self->{_geoip}->continent_code_by_country_code( $c_code ) - or return; + my $continent = $self->{_geoip}->continent_code_by_country_code($c_code) + or return; $self->qp->connection->notes('geoip_continent', $continent); return $continent; -}; +} sub set_continent_gc { my $self = shift; - return if ! $self->{_geoip_record}; + return if !$self->{_geoip_record}; my $continent = $self->{_geoip_record}->continent_code() or return; $self->qp->connection->notes('geoip_continent', $continent); return $continent; -}; +} sub set_city_gc { my $self = shift; - return if ! $self->{_geoip_record}; + return if !$self->{_geoip_record}; my $remote_ip = $self->qp->connection->remote_ip; my $city = $self->{_geoip_record}->city() or return; $self->qp->connection->notes('geoip_city', $city); return $city; -}; +} sub set_distance_gc { my $self = shift; - return if ! $self->{_geoip_record}; + return if !$self->{_geoip_record}; - my ($self_lat, $self_lon) = $self->get_my_lat_lon() or return; + my ($self_lat, $self_lon) = $self->get_my_lat_lon() or return; my ($sender_lat, $sender_lon) = $self->get_sender_lat_lon() or return; eval 'use Math::Trig qw(great_circle_distance deg2rad)'; - if ( $@ ) { - $self->log( LOGERROR, "can't calculate distance, Math::Trig not installed"); + if ($@) { + $self->log(LOGERROR, + "can't calculate distance, Math::Trig not installed"); return; - }; + } # Notice the 90 - latitude: phi zero is at the North Pole. - sub NESW { deg2rad($_[0]), deg2rad(90 - $_[1]) }; - my @me = NESW($self_lon, $self_lat ); + sub NESW { deg2rad($_[0]), deg2rad(90 - $_[1]) } + my @me = NESW($self_lon, $self_lat); my @sender = NESW($sender_lon, $sender_lat); - my $km = great_circle_distance(@me, @sender, 6378); + my $km = great_circle_distance(@me, @sender, 6378); $km = sprintf("%.0f", $km); $self->qp->connection->notes('geoip_distance', $km); + #$self->log( LOGINFO, "distance $km km"); return $km; -}; +} sub get_my_lat_lon { my $self = shift; - return if ! $self->{_geoip_city}; + return if !$self->{_geoip_city}; - if ( $self->{_latitude} && $self->{_longitude} ) { - return ( $self->{_latitude}, $self->{_longitude} ); # cached - }; + if ($self->{_latitude} && $self->{_longitude}) { + return ($self->{_latitude}, $self->{_longitude}); # cached + } - my $ip = $self->{_args}{distance} or return; + my $ip = $self->{_args}{distance} or return; my $record = $self->{_geoip_city}->record_by_addr($ip) or do { - $self->log( LOGERROR, "no record for my Geo::IP location"); + $self->log(LOGERROR, "no record for my Geo::IP location"); return; }; $self->{_latitude} = $record->latitude(); $self->{_longitude} = $record->longitude(); - if ( ! $self->{_latitude} || ! $self->{_longitude} ) { - $self->log( LOGNOTICE, "could not get my lat/lon"); - }; - return ( $self->{_latitude}, $self->{_longitude} ); -}; + if (!$self->{_latitude} || !$self->{_longitude}) { + $self->log(LOGNOTICE, "could not get my lat/lon"); + } + return ($self->{_latitude}, $self->{_longitude}); +} sub get_sender_lat_lon { my $self = shift; my $lat = $self->{_geoip_record}->latitude(); my $lon = $self->{_geoip_record}->longitude(); - if ( ! $lat || ! $lon ) { - $self->log( LOGNOTICE, "could not get sender lat/lon"); + if (!$lat || !$lon) { + $self->log(LOGNOTICE, "could not get sender lat/lon"); return; - }; + } return ($lat, $lon); -}; +} diff --git a/plugins/ident/p0f b/plugins/ident/p0f index d3a1c2b..ad0e591 100644 --- a/plugins/ident/p0f +++ b/plugins/ident/p0f @@ -140,7 +140,7 @@ use Net::IP; my $QUERY_MAGIC_V2 = 0x0defaced; my $QUERY_MAGIC_V3 = 0x50304601; -my $RESP_MAGIC_V3 = 0x50304602; +my $RESP_MAGIC_V3 = 0x50304602; my $P0F_STATUS_BADQUERY = 0x00; my $P0F_STATUS_OK = 0x10; @@ -149,7 +149,7 @@ my $P0F_STATUS_NOMATCH = 0x20; sub register { my ($self, $qp, $p0f_socket, %args) = @_; - $p0f_socket =~ /(.*)/; # untaint + $p0f_socket =~ /(.*)/; # untaint $self->{_args}->{p0f_socket} = $1; foreach (keys %args) { $self->{_args}->{$_} = $args{$_}; @@ -157,18 +157,18 @@ sub register { } sub hook_connect { - my($self, $qp) = @_; + my ($self, $qp) = @_; my $p0f_version = $self->{_args}{version} || 3; - if ( $p0f_version == 3 ) { + if ($p0f_version == 3) { my $response = $self->query_p0f_v3() or return DECLINED; - $self->test_v3_response( $response ) or return DECLINED; - $self->store_v3_results( $response ); + $self->test_v3_response($response) or return DECLINED; + $self->store_v3_results($response); } else { my $response = $self->query_p0f_v2() or return DECLINED; - $self->test_v2_response( $response ) or return DECLINED; - $self->store_v2_results( $response ); + $self->test_v2_response($response) or return DECLINED; + $self->store_v2_results($response); } return DECLINED; @@ -179,38 +179,41 @@ sub get_v2_query { my $local_ip = $self->{_args}{local_ip} || $self->qp->connection->local_ip; - my $src = new Net::IP ($self->qp->connection->remote_ip) - or $self->log(LOGERROR, "skip, ".Net::IP::Error()), return; + my $src = new Net::IP($self->qp->connection->remote_ip) + or $self->log(LOGERROR, "skip, " . Net::IP::Error()), return; my $dst = new Net::IP($local_ip) - or $self->log(LOGERROR, "skip, ".NET::IP::Error()), return; + or $self->log(LOGERROR, "skip, " . NET::IP::Error()), return; - return pack("L L L N N S S", - $QUERY_MAGIC_V2, - 1, - rand ^ 42 ^ time, - $src->intip(), - $dst->intip(), - $self->qp->connection->remote_port, - $self->qp->connection->local_port); -}; + return + pack("L L L N N S S", + $QUERY_MAGIC_V2, + 1, + rand ^ 42 ^ time, + $src->intip(), + $dst->intip(), + $self->qp->connection->remote_port, + $self->qp->connection->local_port); +} sub get_v3_query { my $self = shift; my $src_ip = $self->qp->connection->remote_ip or do { - $self->log( LOGERROR, "skip, unable to determine remote IP"); + $self->log(LOGERROR, "skip, unable to determine remote IP"); return; }; - if ( $src_ip =~ /:/ ) { # IPv6 - my @bits = split(/\:/, $src_ip ); - return pack( "L C C C C C C C C C C C C C C C C C", $QUERY_MAGIC_V3, 0x06, @bits ); - }; + if ($src_ip =~ /:/) { # IPv6 + my @bits = split(/\:/, $src_ip); + return + pack("L C C C C C C C C C C C C C C C C C", + $QUERY_MAGIC_V3, 0x06, @bits); + } my @octets = split(/\./, $src_ip); - return pack( "L C C16", $QUERY_MAGIC_V3, 0x04, @octets ); -}; + return pack("L C C16", $QUERY_MAGIC_V3, 0x04, @octets); +} sub query_p0f_v3 { my $self = shift; @@ -221,38 +224,39 @@ sub query_p0f_v3 { }; my $query = $self->get_v3_query() or return; -# Open the connection to p0f + # Open the connection to p0f my $sock; eval { - $sock = IO::Socket::UNIX->new(Peer => $p0f_socket, Type => SOCK_STREAM ); + $sock = IO::Socket::UNIX->new(Peer => $p0f_socket, Type => SOCK_STREAM); }; - if ( ! $sock ) { + if (!$sock) { $self->log(LOGERROR, "skip, could not open socket: $@"); return; + } + + $sock->autoflush(1); # paranoid redundancy + $sock->connected or do { + $self->log(LOGERROR, "skip, socket not connected: $!"); + return; }; - $sock->autoflush(1); # paranoid redundancy - $sock->connected or do { - $self->log(LOGERROR, "skip, socket not connected: $!"); - return; - }; - my $sent = $sock->send($query, 0) or do { - $self->log(LOGERROR, "skip, send failed: $!"); - return; - }; + $self->log(LOGERROR, "skip, send failed: $!"); + return; + }; - print $sock $query; # yes, this is redundant, but I get no response from p0f otherwise + print $sock $query + ; # yes, this is redundant, but I get no response from p0f otherwise $self->log(LOGDEBUG, "sent $sent byte request"); my $response; - $sock->recv( $response, 232 ); + $sock->recv($response, 232); my $length = length $response; $self->log(LOGDEBUG, "received $length byte response"); close $sock; return $response; -}; +} sub query_p0f_v2 { my $self = shift; @@ -262,24 +266,24 @@ sub query_p0f_v2 { # Open the connection to p0f socket(SOCK, PF_UNIX, SOCK_STREAM, 0) - or $self->log(LOGERROR, "socket: $!"), return; + or $self->log(LOGERROR, "socket: $!"), return; connect(SOCK, sockaddr_un($p0f_socket)) - or $self->log(LOGERROR, "connect: $! ($p0f_socket)"), return; + or $self->log(LOGERROR, "connect: $! ($p0f_socket)"), return; defined syswrite SOCK, $query - or $self->log(LOGERROR, "write: $!"), close SOCK, return; + or $self->log(LOGERROR, "write: $!"), close SOCK, return; my $response; defined sysread SOCK, $response, 1024 - or $self->log(LOGERROR, "read: $!"), close SOCK, return; + or $self->log(LOGERROR, "read: $!"), close SOCK, return; close SOCK; return $response; -}; +} sub test_v2_response { - my ($self, $response ) = @_; + my ($self, $response) = @_; # Extract part of the p0f response - my ($magic, $id, $type) = unpack ("L L C", $response); + my ($magic, $id, $type) = unpack("L L C", $response); # $self->log(LOGERROR, $response); if ($magic != $QUERY_MAGIC_V2) { @@ -296,84 +300,87 @@ sub test_v2_response { return; } return 1; -}; +} sub test_v3_response { - my ($self, $response ) = @_; + my ($self, $response) = @_; - my ($magic,$status) = unpack ("L L", $response); + my ($magic, $status) = unpack("L L", $response); # check the magic response value (a p0f constant) - if ($magic != $RESP_MAGIC_V3 ) { + if ($magic != $RESP_MAGIC_V3) { $self->log(LOGERROR, "skip, Bad response magic."); return; } # check the response status - if ($status == $P0F_STATUS_BADQUERY ) { + if ($status == $P0F_STATUS_BADQUERY) { $self->log(LOGERROR, "skip, bad query"); return; } - elsif ($status == $P0F_STATUS_NOMATCH ) { + elsif ($status == $P0F_STATUS_NOMATCH) { $self->log(LOGINFO, "skip, no match"); return; } - if ($status == $P0F_STATUS_OK ) { + if ($status == $P0F_STATUS_OK) { $self->log(LOGDEBUG, "pass, query ok"); return 1; } return; -}; +} sub store_v2_results { - my ($self, $response ) = @_; + my ($self, $response) = @_; - my ($magic, $id, $type, $genre, $detail, $dist, $link, $tos, $fw, - $nat, $real, $score, $mflags, $uptime) = - unpack ("L L C Z20 Z40 c Z30 Z30 C C C s S N", $response); + my ( + $magic, $id, $type, $genre, $detail, $dist, $link, + $tos, $fw, $nat, $real, $score, $mflags, $uptime + ) + = unpack("L L C Z20 Z40 c Z30 Z30 C C C s S N", $response); my $p0f = { - genre => $genre, - detail => $detail, - distance => $dist, - link => $link, - uptime => $uptime, - }; + genre => $genre, + detail => $detail, + distance => $dist, + link => $link, + uptime => $uptime, + }; $self->connection->notes('p0f', $p0f); - $self->log(LOGINFO, $genre." (".$detail.")"); - $self->log(LOGERROR,"error: $@") if $@; + $self->log(LOGINFO, $genre . " (" . $detail . ")"); + $self->log(LOGERROR, "error: $@") if $@; return $p0f; -}; +} sub store_v3_results { - my ($self, $response ) = @_; + my ($self, $response) = @_; my @labels = qw/ magic status first_seen last_seen total_conn uptime_min - up_mod_days last_nat last_chg distance bad_sw os_match_q os_name os_flavor - http_name http_flavor link_type language /; - my @values = unpack ("L L L L L L L L L s C C A32 A32 A32 A32 A32 A32 A32", $response); + up_mod_days last_nat last_chg distance bad_sw os_match_q os_name os_flavor + http_name http_flavor link_type language /; + my @values = + unpack("L L L L L L L L L s C C A32 A32 A32 A32 A32 A32 A32", $response); my %r; - foreach my $i ( 0 .. ( scalar @labels -1 ) ) { - next if ! defined $values[$i]; - next if ! defined $values[$i]; - $r{ $labels[$i] } = $values[$i]; - }; - if ( $r{os_name} ) { # compat with p0f v2 + foreach my $i (0 .. (scalar @labels - 1)) { + next if !defined $values[$i]; + next if !defined $values[$i]; + $r{$labels[$i]} = $values[$i]; + } + if ($r{os_name}) { # compat with p0f v2 $r{genre} = "$r{os_name} $r{os_flavor}"; $r{link} = $r{link_type} if $r{link_type}; $r{uptime} = $r{uptime_min} if $r{uptime_min}; - }; + } - if ( $r{genre} && $self->{_args}{smite_os} ) { + if ($r{genre} && $self->{_args}{smite_os}) { my $sos = $self->{_args}{smite_os}; - $self->adjust_karma( -1 ) if $r{genre} =~ /$sos/i; - }; + $self->adjust_karma(-1) if $r{genre} =~ /$sos/i; + } $self->connection->notes('p0f', \%r); - $self->log(LOGINFO, "$r{os_name} $r{os_flavor}"); - $self->log(LOGDEBUG, join(' ', @values )); - $self->log(LOGERROR,"error: $@") if $@; + $self->log(LOGINFO, "$r{os_name} $r{os_flavor}"); + $self->log(LOGDEBUG, join(' ', @values)); + $self->log(LOGERROR, "error: $@") if $@; return \%r; -}; +} diff --git a/plugins/karma b/plugins/karma index f83a679..8cc91e6 100644 --- a/plugins/karma +++ b/plugins/karma @@ -231,113 +231,117 @@ use Fcntl qw(:DEFAULT :flock LOCK_EX LOCK_NB); use Net::IP; sub register { - my ($self, $qp ) = (shift, shift); + my ($self, $qp) = (shift, shift); $self->log(LOGERROR, "Bad arguments") if @_ % 2; - $self->{_args} = { @_ }; + $self->{_args} = {@_}; $self->{_args}{negative} ||= 1; $self->{_args}{penalty_days} ||= 1; $self->{_args}{reject_type} ||= 'disconnect'; - if ( ! defined $self->{_args}{reject} ) { + if (!defined $self->{_args}{reject}) { $self->{_args}{reject} = 'naughty'; - }; + } + #$self->prune_db(); # keep the DB compact - $self->register_hook('connect', 'connect_handler'); - $self->register_hook('data', 'data_handler' ); - $self->register_hook('disconnect', 'disconnect_handler'); - $self->register_hook('received_line', 'rcpt_handler'); + $self->register_hook('connect', 'connect_handler'); + $self->register_hook('data', 'data_handler'); + $self->register_hook('disconnect', 'disconnect_handler'); + $self->register_hook('received_line', 'rcpt_handler'); } sub hook_pre_connection { - my ($self,$transaction,%args) = @_; + my ($self, $transaction, %args) = @_; $self->connection->notes('karma_history', 0); my $remote_ip = $args{remote_ip}; + #my $max_conn = $args{max_conn_ip}; my $db = $self->get_db_location(); - my $lock = $self->get_db_lock( $db ) or return DECLINED; - my $tied = $self->get_db_tie( $db, $lock ) or return DECLINED; - my $key = $self->get_db_key( $remote_ip ) or do { - $self->log( LOGINFO, "skip, unable to get DB key" ); + my $lock = $self->get_db_lock($db) or return DECLINED; + my $tied = $self->get_db_tie($db, $lock) or return DECLINED; + my $key = $self->get_db_key($remote_ip) or do { + $self->log(LOGINFO, "skip, unable to get DB key"); return DECLINED; }; - if ( ! $tied->{$key} ) { + if (!$tied->{$key}) { $self->log(LOGDEBUG, "pass, no record"); - return $self->cleanup_and_return($tied, $lock ); - }; + return $self->cleanup_and_return($tied, $lock); + } - my ($penalty_start_ts, $naughty, $nice, $connects) = $self->parse_value( $tied->{$key} ); + my ($penalty_start_ts, $naughty, $nice, $connects) = + $self->parse_value($tied->{$key}); $self->calc_karma($naughty, $nice); - return $self->cleanup_and_return($tied, $lock ); -}; + return $self->cleanup_and_return($tied, $lock); +} sub connect_handler { my $self = shift; - $self->connection->notes('karma', 0); # default + $self->connection->notes('karma', 0); # default return DECLINED if $self->is_immune(); my $db = $self->get_db_location(); - my $lock = $self->get_db_lock( $db ) or return DECLINED; - my $tied = $self->get_db_tie( $db, $lock ) or return DECLINED; + my $lock = $self->get_db_lock($db) or return DECLINED; + my $tied = $self->get_db_tie($db, $lock) or return DECLINED; my $key = $self->get_db_key() or do { - $self->log( LOGINFO, "skip, unable to get DB key" ); + $self->log(LOGINFO, "skip, unable to get DB key"); return DECLINED; }; - if ( ! $tied->{$key} ) { + if (!$tied->{$key}) { $self->log(LOGINFO, "pass, no record"); - return $self->cleanup_and_return($tied, $lock ); - }; + return $self->cleanup_and_return($tied, $lock); + } - my ($penalty_start_ts, $naughty, $nice, $connects) = $self->parse_value( $tied->{$key} ); + my ($penalty_start_ts, $naughty, $nice, $connects) = + $self->parse_value($tied->{$key}); my $summary = "$naughty naughty, $nice nice, $connects connects"; my $karma = $self->calc_karma($naughty, $nice); - if ( ! $penalty_start_ts ) { + if (!$penalty_start_ts) { $self->log(LOGINFO, "pass, no penalty ($summary)"); - return $self->cleanup_and_return($tied, $lock ); - }; + return $self->cleanup_and_return($tied, $lock); + } my $days_old = (time - $penalty_start_ts) / 86400; - if ( $days_old >= $self->{_args}{penalty_days} ) { + if ($days_old >= $self->{_args}{penalty_days}) { $self->log(LOGINFO, "pass, penalty expired ($summary)"); - return $self->cleanup_and_return($tied, $lock ); - }; + return $self->cleanup_and_return($tied, $lock); + } $tied->{$key} = join(':', $penalty_start_ts, $naughty, $nice, ++$connects); - $self->cleanup_and_return($tied, $lock ); + $self->cleanup_and_return($tied, $lock); my $left = sprintf "%.2f", $self->{_args}{penalty_days} - $days_old; my $mess = "You were naughty. You cannot connect for $left more days."; - return $self->get_reject( $mess, $karma ); + return $self->get_reject($mess, $karma); } sub rcpt_handler { my ($self, $transaction, $recipient, %args) = @_; my $recipients = scalar $self->transaction->recipients; - return DECLINED if $recipients < 2; # only one recipient + return DECLINED if $recipients < 2; # only one recipient my $karma = $self->connection->notes('karma_history'); - return DECLINED if $karma > 0; # good karma, no limit + return DECLINED if $karma > 0; # good karma, no limit -# limit # of recipients if host has negative or unknown karma - return $self->get_reject( "too many recipients"); -}; + # limit # of recipients if host has negative or unknown karma + return $self->get_reject("too many recipients"); +} sub data_handler { my ($self, $transaction) = @_; - return DECLINED if ! $self->qp->connection->relay_client; + return DECLINED if !$self->qp->connection->relay_client; - $self->adjust_karma( 5 ); # big karma boost for authenticated user/IP + $self->adjust_karma(5); # big karma boost for authenticated user/IP return DECLINED; -}; +} sub disconnect_handler { my $self = shift; @@ -348,30 +352,31 @@ sub disconnect_handler { }; my $db = $self->get_db_location(); - my $lock = $self->get_db_lock( $db ) or return DECLINED; - my $tied = $self->get_db_tie( $db, $lock ) or return DECLINED; + my $lock = $self->get_db_lock($db) or return DECLINED; + my $tied = $self->get_db_tie($db, $lock) or return DECLINED; my $key = $self->get_db_key(); - my ($penalty_start_ts, $naughty, $nice, $connects) = $self->parse_value( $tied->{$key} ); - my $history = ($nice || 0) - $naughty; + my ($penalty_start_ts, $naughty, $nice, $connects) = + $self->parse_value($tied->{$key}); + my $history = ($nice || 0) - $naughty; my $log_mess = ''; - if ( $karma < -1 ) { # they achieved at least 2 strikes + if ($karma < -1) { # they achieved at least 2 strikes $history--; my $negative_limit = 0 - $self->{_args}{negative}; - if ( $history <= $negative_limit ) { - if ( $nice == 0 && $history < -5 ) { + if ($history <= $negative_limit) { + if ($nice == 0 && $history < -5) { $log_mess = ", penalty box bonus!"; $penalty_start_ts = sprintf "%s", time + abs($history) * 86400; } else { $penalty_start_ts = sprintf "%s", time; - }; + } $log_mess = "negative, sent to penalty box" . $log_mess; } else { $log_mess = "negative"; - }; + } } elsif ($karma > 1) { $nice++; @@ -380,84 +385,87 @@ sub disconnect_handler { else { $log_mess = "neutral"; } - $self->log(LOGINFO, $log_mess . ", (msg: $karma, his: $history)" ); + $self->log(LOGINFO, $log_mess . ", (msg: $karma, his: $history)"); $tied->{$key} = join(':', $penalty_start_ts, $naughty, $nice, ++$connects); - return $self->cleanup_and_return($tied, $lock ); + return $self->cleanup_and_return($tied, $lock); } sub parse_value { my ($self, $value) = @_; my $penalty_start_ts = my $naughty = my $nice = my $connects = 0; - if ( $value ) { + if ($value) { ($penalty_start_ts, $naughty, $nice, $connects) = split /:/, $value; $penalty_start_ts ||= 0; - $nice ||= 0; - $naughty ||= 0; - $connects ||= 0; - }; - return ($penalty_start_ts, $naughty, $nice, $connects ); -}; + $nice ||= 0; + $naughty ||= 0; + $connects ||= 0; + } + return ($penalty_start_ts, $naughty, $nice, $connects); +} sub calc_karma { my ($self, $naughty, $nice) = @_; - return 0 if ( ! $naughty && ! $nice ); + return 0 if (!$naughty && !$nice); - my $karma = ( $nice || 0 ) - ( $naughty || 0 ); - $self->connection->notes('karma_history', $karma ); - $self->adjust_karma( 1 ) if $karma > 10; + my $karma = ($nice || 0) - ($naughty || 0); + $self->connection->notes('karma_history', $karma); + $self->adjust_karma(1) if $karma > 10; return $karma; -}; +} sub cleanup_and_return { - my ($self, $tied, $lock, $return_val ) = @_; + my ($self, $tied, $lock, $return_val) = @_; untie $tied; close $lock; - return ($return_val) if defined $return_val; # explicit override + return ($return_val) if defined $return_val; # explicit override return (DECLINED); -}; +} sub get_db_key { my $self = shift; - my $ip = shift || $self->qp->connection->remote_ip; - my $nip = Net::IP->new( $ip ) or do { + my $ip = shift || $self->qp->connection->remote_ip; + my $nip = Net::IP->new($ip) or do { $self->log(LOGERROR, "skip, unable to determine remote IP"); return; }; - return $nip->intip; # convert IP to an int -}; + return $nip->intip; # convert IP to an int +} sub get_db_tie { - my ( $self, $db, $lock ) = @_; + my ($self, $db, $lock) = @_; - tie( my %db, 'AnyDBM_File', $db, O_CREAT|O_RDWR, 0600) or do { + tie(my %db, 'AnyDBM_File', $db, O_CREAT | O_RDWR, 0600) or do { $self->log(LOGCRIT, "error, tie to database $db failed: $!"); close $lock; return; }; return \%db; -}; +} sub get_db_location { my $self = shift; # Setup database location my ($QPHOME) = ($0 =~ m!(.*?)/([^/]+)$!); - my @candidate_dirs = ( $self->{args}{db_dir}, - "/var/lib/qpsmtpd/karma", "$QPHOME/var/db", "$QPHOME/config", '.' ); + my @candidate_dirs = ( + $self->{args}{db_dir}, + "/var/lib/qpsmtpd/karma", "$QPHOME/var/db", + "$QPHOME/config", '.' + ); my $dbdir; - for my $d ( @candidate_dirs ) { - next if ! $d || ! -d $d; # impossible + for my $d (@candidate_dirs) { + next if !$d || !-d $d; # impossible $dbdir = $d; - last; # first match wins + last; # first match wins } my $db = "$dbdir/karma.dbm"; - $self->log(LOGDEBUG,"using $db as karma database"); + $self->log(LOGDEBUG, "using $db as karma database"); return $db; -}; +} sub get_db_lock { my ($self, $db) = @_; @@ -465,12 +473,12 @@ sub get_db_lock { return $self->get_db_lock_nfs($db) if $self->{_args}{nfslock}; # Check denysoft db - open( my $lock, ">$db.lock" ) or do { + open(my $lock, ">$db.lock") or do { $self->log(LOGCRIT, "error, opening lockfile failed: $!"); return; }; - flock( $lock, LOCK_EX ) or do { + flock($lock, LOCK_EX) or do { $self->log(LOGCRIT, "error, flock of lockfile failed: $!"); close $lock; return; @@ -486,42 +494,43 @@ sub get_db_lock_nfs { ### set up a lock - lasts until object looses scope my $nfslock = new File::NFSLock { - file => "$db.lock", - lock_type => LOCK_EX|LOCK_NB, - blocking_timeout => 10, # 10 sec - stale_lock_timeout => 30 * 60, # 30 min - } or do { + file => "$db.lock", + lock_type => LOCK_EX | LOCK_NB, + blocking_timeout => 10, # 10 sec + stale_lock_timeout => 30 * 60, # 30 min + } + or do { $self->log(LOGCRIT, "error, nfs lockfile failed: $!"); return; - }; + }; - open( my $lock, "+<$db.lock") or do { + open(my $lock, "+<$db.lock") or do { $self->log(LOGCRIT, "error, opening nfs lockfile failed: $!"); return; }; return $lock; -}; +} sub prune_db { my $self = shift; - my $db = $self->get_db_location(); - my $lock = $self->get_db_lock( $db ) or return DECLINED; - my $tied = $self->get_db_tie( $db, $lock ) or return DECLINED; + my $db = $self->get_db_location(); + my $lock = $self->get_db_lock($db) or return DECLINED; + my $tied = $self->get_db_tie($db, $lock) or return DECLINED; my $count = keys %$tied; my $pruned = 0; - foreach my $key ( keys %$tied ) { - my $ts = $tied->{$key}; - my $days_old = ( time - $ts ) / 86400; + foreach my $key (keys %$tied) { + my $ts = $tied->{$key}; + my $days_old = (time - $ts) / 86400; next if $days_old < $self->{_args}{penalty_days} * 2; delete $tied->{$key}; $pruned++; - }; + } untie $tied; close $lock; - $self->log( LOGINFO, "pruned $pruned of $count DB entries" ); - return $self->cleanup_and_return( $tied, $lock, DECLINED ); -}; + $self->log(LOGINFO, "pruned $pruned of $count DB entries"); + return $self->cleanup_and_return($tied, $lock, DECLINED); +} diff --git a/plugins/karma_tool b/plugins/karma_tool index 627725c..b617e4b 100755 --- a/plugins/karma_tool +++ b/plugins/karma_tool @@ -11,27 +11,27 @@ use Fcntl qw(:DEFAULT :flock LOCK_EX LOCK_NB); use Net::IP qw(:PROC); use POSIX qw(strftime); -my $self = bless( { args => { db_dir => 'config' }, }, 'Karma' ); +my $self = bless({args => {db_dir => 'config'},}, 'Karma'); my $command = $ARGV[0]; -if ( ! $command ) { +if (!$command) { $self->usage(); } -elsif ( $command eq 'capture' ) { - $self->capture( $ARGV[1] ); +elsif ($command eq 'capture') { + $self->capture($ARGV[1]); } -elsif ( $command eq 'release' ) { - $self->release( $ARGV[1] ); +elsif ($command eq 'release') { + $self->release($ARGV[1]); } -elsif ( $command eq 'prune' ) { - $self->prune_db( $ARGV[1] || 7 ); +elsif ($command eq 'prune') { + $self->prune_db($ARGV[1] || 7); } -elsif ( $command eq 'search' && is_ip( $ARGV[1] ) ) { - $self->show_ip( $ARGV[1] ); +elsif ($command eq 'search' && is_ip($ARGV[1])) { + $self->show_ip($ARGV[1]); } -elsif ( $command eq 'list' | $command eq 'search' ) { +elsif ($command eq 'list' | $command eq 'search') { $self->main(); -}; +} exit(0); @@ -54,157 +54,170 @@ prune takes no arguments. prunes database of entries older than 7 days EO_HELP -; -}; + ; +} sub capture { my $self = shift; my $ip = shift or return; - is_ip( $ip ) or do { + is_ip($ip) or do { warn "not an IP: $ip\n"; return; }; my $db = $self->get_db_location(); - my $lock = $self->get_db_lock( $db ) or return; - my $tied = $self->get_db_tie( $db, $lock ) or return; - my $key = $self->get_db_key( $ip ); + my $lock = $self->get_db_lock($db) or return; + my $tied = $self->get_db_tie($db, $lock) or return; + my $key = $self->get_db_key($ip); - my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/, $tied->{$key}; + my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/, + $tied->{$key}; - $tied->{$key} = join(':', time, $naughty+1, $nice, $connects); - return $self->cleanup_and_return( $tied, $lock ); -}; + $tied->{$key} = join(':', time, $naughty + 1, $nice, $connects); + return $self->cleanup_and_return($tied, $lock); +} sub release { my $self = shift; my $ip = shift or return; - is_ip( $ip ) or do { warn "not an IP: $ip\n"; return; }; + is_ip($ip) or do { warn "not an IP: $ip\n"; return; }; my $db = $self->get_db_location(); - my $lock = $self->get_db_lock( $db ) or return; - my $tied = $self->get_db_tie( $db, $lock ) or return; - my $key = $self->get_db_key( $ip ); + my $lock = $self->get_db_lock($db) or return; + my $tied = $self->get_db_tie($db, $lock) or return; + my $key = $self->get_db_key($ip); - my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/, $tied->{$key}; + my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/, + $tied->{$key}; $tied->{$key} = join(':', 0, 0, $nice, $connects); - return $self->cleanup_and_return( $tied, $lock ); -}; + return $self->cleanup_and_return($tied, $lock); +} sub show_ip { my $self = shift; - my $ip = shift or return; + my $ip = shift or return; my $db = $self->get_db_location(); - my $lock = $self->get_db_lock( $db ) or return; - my $tied = $self->get_db_tie( $db, $lock ) or return; - my $key = $self->get_db_key( $ip ); + my $lock = $self->get_db_lock($db) or return; + my $tied = $self->get_db_tie($db, $lock) or return; + my $key = $self->get_db_key($ip); - my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/, $tied->{$key}; - $naughty ||= 0; - $nice ||= 0; + my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/, + $tied->{$key}; + $naughty ||= 0; + $nice ||= 0; $connects ||= 0; my $time_human = ''; - if ( $penalty_start_ts ) { + if ($penalty_start_ts) { $time_human = strftime "%a %b %e %H:%M", localtime $penalty_start_ts; - }; - my $hostname = `dig +short -x $ip` || ''; chomp $hostname; - print " IP Address Penalty Naughty Nice Connects Hostname\n"; - printf(" %-18s %24s %3s %3s %3s %-30s\n", $ip, $time_human, $naughty, $nice, $connects, $hostname); -}; + } + my $hostname = `dig +short -x $ip` || ''; + chomp $hostname; + print +" IP Address Penalty Naughty Nice Connects Hostname\n"; + printf(" %-18s %24s %3s %3s %3s %-30s\n", + $ip, $time_human, $naughty, $nice, $connects, $hostname); +} sub main { my $self = shift; my $db = $self->get_db_location(); - my $lock = $self->get_db_lock( $db ) or return; - my $tied = $self->get_db_tie( $db, $lock ) or return; + my $lock = $self->get_db_lock($db) or return; + my $tied = $self->get_db_tie($db, $lock) or return; my %totals; - print " IP Address Penalty Naughty Nice Connects Hostname\n"; - foreach my $r ( sort keys %$tied ) { - my $ip = ip_bintoip( ip_inttobin( $r, 4 ), 4); - my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/, $tied->{$r}; - $naughty ||= ''; - $nice ||= ''; + print +" IP Address Penalty Naughty Nice Connects Hostname\n"; + foreach my $r (sort keys %$tied) { + my $ip = ip_bintoip(ip_inttobin($r, 4), 4); + my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/, + $tied->{$r}; + $naughty ||= ''; + $nice ||= ''; $connects ||= ''; my $time_human = ''; - if ( $command eq 'search' ) { + if ($command eq 'search') { my $search = $ARGV[1]; - if ( $search eq 'nice' ) { - next if ! $nice; + if ($search eq 'nice') { + next if !$nice; } - elsif ( $search eq 'naughty' ) { - next if ! $naughty; + elsif ($search eq 'naughty') { + next if !$naughty; } - elsif ( $search eq 'both' ) { - next if ! $naughty || ! $nice; + elsif ($search eq 'both') { + next if !$naughty || !$nice; } - elsif ( is_ip( $ARGV[1] ) && $search ne $ip ) { + elsif (is_ip($ARGV[1]) && $search ne $ip) { next; } - }; - if ( $penalty_start_ts ) { - $time_human = strftime "%a %b %e %H:%M", localtime $penalty_start_ts; - }; + } + if ($penalty_start_ts) { + $time_human = strftime "%a %b %e %H:%M", + localtime $penalty_start_ts; + } my $hostname = ''; - if ( $naughty && $nice ) { + if ($naughty && $nice) { + #$hostname = `dig +short -x $ip`; chomp $hostname; - }; - printf(" %-18s %24s %3s %3s %3s %30s\n", $ip, $time_human, $naughty, $nice, $connects, $hostname); + } + printf(" %-18s %24s %3s %3s %3s %30s\n", + $ip, $time_human, $naughty, $nice, $connects, $hostname); $totals{naughty} += $naughty if $naughty; $totals{nice} += $nice if $nice; $totals{connects} += $connects if $connects; - }; + } print Dumper(\%totals); } sub is_ip { my $ip = shift || $ARGV[0]; - new Net::IP( $ip ) or return; + new Net::IP($ip) or return; return 1; -}; +} sub cleanup_and_return { - my ($self, $tied, $lock ) = @_; + my ($self, $tied, $lock) = @_; untie $tied; close $lock; -}; +} sub get_db_key { my $self = shift; - my $nip = Net::IP->new( shift ) or return; - return $nip->intip; # convert IP to an int -}; + my $nip = Net::IP->new(shift) or return; + return $nip->intip; # convert IP to an int +} sub get_db_tie { - my ( $self, $db, $lock ) = @_; + my ($self, $db, $lock) = @_; - tie( my %db, 'AnyDBM_File', $db, O_CREAT|O_RDWR, 0600) or do { + tie(my %db, 'AnyDBM_File', $db, O_CREAT | O_RDWR, 0600) or do { warn "tie to database $db failed: $!"; close $lock; return; }; return \%db; -}; +} sub get_db_location { my $self = shift; # Setup database location - my @candidate_dirs = ( $self->{args}{db_dir}, - "/var/lib/qpsmtpd/karma", "./var/db", "./config", '.' ); + my @candidate_dirs = ( + $self->{args}{db_dir}, + "/var/lib/qpsmtpd/karma", "./var/db", "./config", '.' + ); my $dbdir; - for my $d ( @candidate_dirs ) { - next if ! $d || ! -d $d; # impossible + for my $d (@candidate_dirs) { + next if !$d || !-d $d; # impossible $dbdir = $d; - last; # first match wins + last; # first match wins } my $db = "$dbdir/karma.dbm"; print "using karma db at $db\n"; return $db; -}; +} sub get_db_lock { my ($self, $db) = @_; @@ -212,12 +225,12 @@ sub get_db_lock { return $self->get_db_lock_nfs($db) if $self->{_args}{nfslock}; # Check denysoft db - open( my $lock, ">$db.lock" ) or do { + open(my $lock, ">$db.lock") or do { warn "opening lockfile failed: $!"; return; }; - flock( $lock, LOCK_EX ) or do { + flock($lock, LOCK_EX) or do { warn "flock of lockfile failed: $!"; close $lock; return; @@ -233,43 +246,44 @@ sub get_db_lock_nfs { ### set up a lock - lasts until object looses scope my $nfslock = new File::NFSLock { - file => "$db.lock", - lock_type => LOCK_EX|LOCK_NB, - blocking_timeout => 10, # 10 sec - stale_lock_timeout => 30 * 60, # 30 min - } or do { + file => "$db.lock", + lock_type => LOCK_EX | LOCK_NB, + blocking_timeout => 10, # 10 sec + stale_lock_timeout => 30 * 60, # 30 min + } + or do { warn "nfs lockfile failed: $!"; return; - }; + }; - open( my $lock, "+<$db.lock") or do { + open(my $lock, "+<$db.lock") or do { warn "opening nfs lockfile failed: $!"; return; }; return $lock; -}; +} sub prune_db { - my $self = shift; + my $self = shift; my $prune_days = shift; - my $db = $self->get_db_location(); - my $lock = $self->get_db_lock( $db ) or return; - my $tied = $self->get_db_tie( $db, $lock ) or return; + my $db = $self->get_db_location(); + my $lock = $self->get_db_lock($db) or return; + my $tied = $self->get_db_tie($db, $lock) or return; my $count = keys %$tied; my $pruned = 0; - foreach my $key ( keys %$tied ) { + foreach my $key (keys %$tied) { my ($ts, $naughty, $nice, $connects) = split /:/, $tied->{$key}; - my $days_old = ( time - $ts ) / 86400; + my $days_old = (time - $ts) / 86400; next if $days_old < $prune_days; delete $tied->{$key}; $pruned++; - }; + } untie $tied; close $lock; warn "pruned $pruned of $count DB entries"; - return $self->cleanup_and_return( $tied, $lock ); -}; + return $self->cleanup_and_return($tied, $lock); +} diff --git a/plugins/logging/adaptive b/plugins/logging/adaptive index 4e96ba6..572fbfd 100644 --- a/plugins/logging/adaptive +++ b/plugins/logging/adaptive @@ -3,92 +3,93 @@ # one level for DENY'd messages sub register { - my ( $self, $qp, %args ) = @_; + my ($self, $qp, %args) = @_; $self->{_minlevel} = LOGERROR; - if ( defined( $args{accept} ) ) { - if ( $args{accept} =~ /^\d+$/ ) { + if (defined($args{accept})) { + if ($args{accept} =~ /^\d+$/) { $self->{_minlevel} = $args{accept}; } else { - $self->{_minlevel} = log_level( $args{accept} ); + $self->{_minlevel} = log_level($args{accept}); } } $self->{_maxlevel} = LOGWARN; - if ( defined( $args{reject} ) ) { - if ( $args{reject} =~ /^\d+$/ ) { + if (defined($args{reject})) { + if ($args{reject} =~ /^\d+$/) { $self->{_maxlevel} = $args{reject}; } else { - $self->{_maxlevel} = log_level( $args{reject} ); + $self->{_maxlevel} = log_level($args{reject}); } } $self->{_prefix} = '`'; - if ( defined $args{prefix} and $args{prefix} =~ /^(.+)$/ ) { + if (defined $args{prefix} and $args{prefix} =~ /^(.+)$/) { $self->{_prefix} = $1; } # If you want to capture this log entry with this plugin, you need to # wait until after you register the plugin - $self->log( LOGINFO, 'Initializing logging::adaptive plugin' ); + $self->log(LOGINFO, 'Initializing logging::adaptive plugin'); } -sub hook_logging { # wlog - my ( $self, $transaction, $trace, $hook, $plugin, @log ) = @_; +sub hook_logging { # wlog + my ($self, $transaction, $trace, $hook, $plugin, @log) = @_; # Don't log your own log entries! If this is the only logging plugin # then these lines will not be logged at all. You can safely comment # out this line and it will not cause an infinite loop. return DECLINED if defined $plugin and $plugin eq $self->plugin_name; - if ( defined $self->{_maxlevel} && $trace <= $self->{_maxlevel} ) { + if (defined $self->{_maxlevel} && $trace <= $self->{_maxlevel}) { warn join( - " ", $$. - ( - defined $plugin ? " $plugin plugin:" - : defined $hook ? " running plugin ($hook):" - : "" - ), - @log - ), + " ", + $$ + . ( + defined $plugin ? " $plugin plugin:" + : defined $hook ? " running plugin ($hook):" + : "" + ), + @log + ), "\n" unless $log[0] =~ /logging::adaptive/; - push @{ $transaction->{_log} }, [ $trace, $hook, $plugin, @log ] - if ( defined $self->{_minlevel} && $trace <= $self->{_minlevel} ); + push @{$transaction->{_log}}, [$trace, $hook, $plugin, @log] + if (defined $self->{_minlevel} && $trace <= $self->{_minlevel}); } return DECLINED; } -sub hook_deny { # dlog - my ( $self, $transaction, $prev_hook, $return, $return_text ) = @_; +sub hook_deny { # dlog + my ($self, $transaction, $prev_hook, $return, $return_text) = @_; $self->{_denied} = 1; } -sub hook_reset_transaction { # slog +sub hook_reset_transaction { # slog # fires when a message is accepted - my ( $self, $transaction, @args ) = @_; + my ($self, $transaction, @args) = @_; return DECLINED if $self->{_denied}; - foreach my $row ( @{ $transaction->{_log} } ) { + foreach my $row (@{$transaction->{_log}}) { next unless scalar @$row; # skip over empty log lines - my ( $trace, $hook, $plugin, @log ) = @$row; + my ($trace, $hook, $plugin, @log) = @$row; warn join( - " ", $$, - $self->{_prefix}. - ( - defined $plugin ? " $plugin plugin:" - : defined $hook ? " running plugin ($hook):" - : "" - ), - @log - ), + " ", $$, + $self->{_prefix} + . ( + defined $plugin ? " $plugin plugin:" + : defined $hook ? " running plugin ($hook):" + : "" + ), + @log + ), "\n" - if ( $trace <= $self->{_minlevel} ); + if ($trace <= $self->{_minlevel}); } return DECLINED; diff --git a/plugins/logging/apache b/plugins/logging/apache index 317b45c..b609922 100644 --- a/plugins/logging/apache +++ b/plugins/logging/apache @@ -64,7 +64,7 @@ sub hook_logging { . ( defined $plugin ? " $plugin plugin:" : defined $hook ? " running plugin ($hook):" - : "" + : "" ), @log ) diff --git a/plugins/logging/connection_id b/plugins/logging/connection_id index 7023601..fda0da9 100644 --- a/plugins/logging/connection_id +++ b/plugins/logging/connection_id @@ -5,41 +5,48 @@ # as how to ignore log entries from itself sub register { - my ($self, $qp, $loglevel) = @_; - die "The connection ID feature is currently unsupported"; - $self->{_level} = LOGWARN; - if ( defined($loglevel) ) { - if ($loglevel =~ /^\d+$/) { - $self->{_level} = $loglevel; - } - else { - $self->{_level} = log_level($loglevel); - } - } + my ($self, $qp, $loglevel) = @_; + die "The connection ID feature is currently unsupported"; + $self->{_level} = LOGWARN; + if (defined($loglevel)) { + if ($loglevel =~ /^\d+$/) { + $self->{_level} = $loglevel; + } + else { + $self->{_level} = log_level($loglevel); + } + } - # If you want to capture this log entry with this plugin, you need to - # wait until after you register the plugin - $self->log(LOGINFO,'Initializing logging::connection_id plugin'); + # If you want to capture this log entry with this plugin, you need to + # wait until after you register the plugin + $self->log(LOGINFO, 'Initializing logging::connection_id plugin'); } sub hook_logging { - my ($self, $transaction, $trace, $hook, $plugin, @log) = @_; + my ($self, $transaction, $trace, $hook, $plugin, @log) = @_; - # Don't log your own log entries! If this is the only logging plugin - # then these lines will not be logged at all. You can safely comment - # out this line and it will not cause an infinite loop. - return DECLINED if defined $plugin and $plugin eq $self->plugin_name; + # Don't log your own log entries! If this is the only logging plugin + # then these lines will not be logged at all. You can safely comment + # out this line and it will not cause an infinite loop. + return DECLINED if defined $plugin and $plugin eq $self->plugin_name; - my $connection = $self->qp && $self->qp->connection; - # warn "connection = $connection\n"; - warn - join(" ", ($connection ? $connection->id : "???") . - (defined $plugin ? " $plugin plugin:" : - defined $hook ? " running plugin ($hook):" : ""), - @log), "\n" - if ($trace <= $self->{_level}); + my $connection = $self->qp && $self->qp->connection; - return DECLINED; + # warn "connection = $connection\n"; + warn join( + " ", + ($connection ? $connection->id : "???") + . ( + defined $plugin ? " $plugin plugin:" + : defined $hook ? " running plugin ($hook):" + : "" + ), + @log + ), + "\n" + if ($trace <= $self->{_level}); + + return DECLINED; } =head1 NAME diff --git a/plugins/logging/devnull b/plugins/logging/devnull index e8bbf8f..e55050f 100644 --- a/plugins/logging/devnull +++ b/plugins/logging/devnull @@ -2,6 +2,6 @@ # this is a simple 'drop packets on the floor' plugin sub hook_logging { - return DECLINED; + return DECLINED; } diff --git a/plugins/logging/file b/plugins/logging/file index cc51d92..7c82bf7 100644 --- a/plugins/logging/file +++ b/plugins/logging/file @@ -128,11 +128,11 @@ sub register { my %args; $self->{_loglevel} = LOGWARN; - $self->{_tsformat} = '%a %b %d %T %Y'; # same as scalar localtime + $self->{_tsformat} = '%a %b %d %T %Y'; # same as scalar localtime while (1) { - last if !@args; - if (lc $args[0] eq 'loglevel') { + last if !@args; + if (lc $args[0] eq 'loglevel') { shift @args; my $ll = shift @args; if (!defined $ll) { @@ -147,19 +147,19 @@ sub register { defined $self->{_loglevel} or $self->{_loglevel} = LOGWARN; } } - elsif (lc $args[0] eq 'nosplit') { - shift @args; - $self->{_nosplit} = 1; - } - elsif (lc $args[0] eq 'reopen') { - shift @args; - $self->{_reopen} = 1; - } - elsif (lc $args[0] eq 'tsformat') { - shift @args; - my $format = shift @args; - $self->{_tsformat} = $format; - } + elsif (lc $args[0] eq 'nosplit') { + shift @args; + $self->{_nosplit} = 1; + } + elsif (lc $args[0] eq 'reopen') { + shift @args; + $self->{_reopen} = 1; + } + elsif (lc $args[0] eq 'tsformat') { + shift @args; + my $format = shift @args; + $self->{_tsformat} = $format; + } else { last } } @@ -171,13 +171,14 @@ sub register { my $output = join(' ', @args); if ($output =~ /^\s*\|(.*)/) { - $self->{_log_pipe} = 1; - $self->{_log_format} = $1; - } else { - $output =~ /^(.*)/; # detaint + $self->{_log_pipe} = 1; $self->{_log_format} = $1; } - $self->{_current_output} = ''; + else { + $output =~ /^(.*)/; # detaint + $self->{_log_format} = $1; + } + $self->{_current_output} = ''; $self->{_session_counter} = 0; 1; } @@ -191,14 +192,15 @@ sub log_output { } sub open_log { - my ($self,$output,$qp) = @_; + my ($self, $output, $qp) = @_; if ($self->{_log_pipe}) { unless ($self->{_f} = new IO::File "|$output") { warn "Error opening log output to command $output: $!"; return undef; } - } else { + } + else { unless ($self->{_f} = new IO::File ">>$output") { warn "Error opening log output to path $output: $!"; return undef; @@ -209,7 +211,6 @@ sub open_log { 1; } - # Reopen the output iff the interpolated output filename has changed # from the one currently open, or if reopening was selected and we haven't # yet done so during this session. @@ -219,10 +220,13 @@ sub maybe_reopen { my ($self, $transaction) = @_; my $new_output = $self->log_output($transaction); - if (!$self->{_current_output} || - $self->{_current_output} ne $new_output || - ($self->{_reopen} && - !$transaction->notes('file-reopened-this-session'))) { + if ( + !$self->{_current_output} + || $self->{_current_output} ne $new_output + || ($self->{_reopen} + && !$transaction->notes('file-reopened-this-session')) + ) + { unless ($self->open_log($new_output, $transaction)) { return undef; } @@ -235,11 +239,14 @@ sub maybe_reopen { sub hook_connect { my ($self, $transaction) = @_; - $transaction->notes('file-logged-this-session', 0); + $transaction->notes('file-logged-this-session', 0); $transaction->notes('file-reopened-this-session', 0); - $transaction->notes('logging-session-id', - sprintf("%08d-%04d-%d", - scalar time, $$, ++$self->{_session_counter})); + $transaction->notes( + 'logging-session-id', + sprintf("%08d-%04d-%d", + scalar time, $$, + ++$self->{_session_counter}) + ); return DECLINED; } @@ -255,8 +262,9 @@ sub hook_disconnect { sub hook_logging { my ($self, $transaction, $trace, $hook, $plugin, @log) = @_; - return DECLINED if !defined $self->{_loglevel} or - $trace > $self->{_loglevel}; + return DECLINED + if !defined $self->{_loglevel} + or $trace > $self->{_loglevel}; return DECLINED if defined $plugin and $plugin eq $self->plugin_name; # Possibly reopen the log iff: @@ -264,10 +272,11 @@ sub hook_logging { # - We're allowed to split sessions across logfiles # - We haven't logged anything yet this session # - We aren't in a session - if (!$self->{_f} || - !$self->{_nosplit} || - !$transaction || - !$transaction->notes('file-logged-this-session')) { + if ( !$self->{_f} + || !$self->{_nosplit} + || !$transaction + || !$transaction->notes('file-logged-this-session')) + { unless (defined $self->maybe_reopen($transaction)) { return DECLINED; } @@ -276,7 +285,7 @@ sub hook_logging { my $f = $self->{_f}; print $f strftime($self->{_tsformat}, localtime), ' ', - hostname(), '[', $$, ']: ', @log, "\n"; + hostname(), '[', $$, ']: ', @log, "\n"; return DECLINED; } diff --git a/plugins/logging/syslog b/plugins/logging/syslog index 8552650..b37def2 100644 --- a/plugins/logging/syslog +++ b/plugins/logging/syslog @@ -116,13 +116,14 @@ sub register { if (@args % 2 == 0) { %args = @args; - } else { + } + else { warn "Malformed arguments to syslog plugin"; return; } - my $ident = 'qpsmtpd'; - my $logopt = 'pid'; + my $ident = 'qpsmtpd'; + my $logopt = 'pid'; my $facility = 'LOG_MAIL'; $self->{_loglevel} = LOGWARN; @@ -150,8 +151,8 @@ sub register { } if ($args{logsock}) { - my @logopt = split(/,/, $args{logsock}); - setlogsock(@logopt); + my @logopt = split(/,/, $args{logsock}); + setlogsock(@logopt); } unless (openlog $ident, $logopt, $facility) { @@ -161,15 +162,15 @@ sub register { } my %priorities_ = ( - 0 => 'LOG_EMERG', - 1 => 'LOG_ALERT', - 2 => 'LOG_CRIT', - 3 => 'LOG_ERR', - 4 => 'LOG_WARNING', - 5 => 'LOG_NOTICE', - 6 => 'LOG_INFO', - 7 => 'LOG_DEBUG', -); + 0 => 'LOG_EMERG', + 1 => 'LOG_ALERT', + 2 => 'LOG_CRIT', + 3 => 'LOG_ERR', + 4 => 'LOG_WARNING', + 5 => 'LOG_NOTICE', + 6 => 'LOG_INFO', + 7 => 'LOG_DEBUG', + ); sub hook_logging { my ($self, $transaction, $trace, $hook, $plugin, @log) = @_; @@ -177,8 +178,8 @@ sub hook_logging { return DECLINED if $trace > $self->{_loglevel}; return DECLINED if defined $plugin and $plugin eq $self->plugin_name; - my $priority = $self->{_priority} ? - $self->{_priority} : $priorities_{$trace}; + my $priority = + $self->{_priority} ? $self->{_priority} : $priorities_{$trace}; syslog $priority, '%s', join(' ', @log); return DECLINED; diff --git a/plugins/logging/transaction_id b/plugins/logging/transaction_id index bc5a293..aa6d503 100644 --- a/plugins/logging/transaction_id +++ b/plugins/logging/transaction_id @@ -5,40 +5,46 @@ # as how to ignore log entries from itself sub register { - my ($self, $qp, $loglevel) = @_; - die "The transaction ID feature is currently unsupported"; + my ($self, $qp, $loglevel) = @_; + die "The transaction ID feature is currently unsupported"; - $self->{_level} = LOGWARN; - if ( defined($loglevel) ) { - if ($loglevel =~ /^\d+$/) { - $self->{_level} = $loglevel; - } - else { - $self->{_level} = log_level($loglevel); - } - } + $self->{_level} = LOGWARN; + if (defined($loglevel)) { + if ($loglevel =~ /^\d+$/) { + $self->{_level} = $loglevel; + } + else { + $self->{_level} = log_level($loglevel); + } + } - # If you want to capture this log entry with this plugin, you need to - # wait until after you register the plugin - $self->log(LOGINFO,'Initializing logging::transaction_id plugin'); + # If you want to capture this log entry with this plugin, you need to + # wait until after you register the plugin + $self->log(LOGINFO, 'Initializing logging::transaction_id plugin'); } sub hook_logging { - my ($self, $transaction, $trace, $hook, $plugin, @log) = @_; + my ($self, $transaction, $trace, $hook, $plugin, @log) = @_; - # Don't log your own log entries! If this is the only logging plugin - # then these lines will not be logged at all. You can safely comment - # out this line and it will not cause an infinite loop. - return DECLINED if defined $plugin and $plugin eq $self->plugin_name; + # Don't log your own log entries! If this is the only logging plugin + # then these lines will not be logged at all. You can safely comment + # out this line and it will not cause an infinite loop. + return DECLINED if defined $plugin and $plugin eq $self->plugin_name; - warn - join(" ", ($transaction ? $transaction->id : "???") . - (defined $plugin ? " $plugin plugin:" : - defined $hook ? " running plugin ($hook):" : ""), - @log), "\n" - if ($trace <= $self->{_level}); + warn join( + " ", + ($transaction ? $transaction->id : "???") + . ( + defined $plugin ? " $plugin plugin:" + : defined $hook ? " running plugin ($hook):" + : "" + ), + @log + ), + "\n" + if ($trace <= $self->{_level}); - return DECLINED; + return DECLINED; } =head1 NAME diff --git a/plugins/logging/warn b/plugins/logging/warn index c85b9d5..1b772cd 100644 --- a/plugins/logging/warn +++ b/plugins/logging/warn @@ -38,36 +38,38 @@ Please see the LICENSE file included with qpsmtpd for details. =cut sub register { - my ($self, $qp, $loglevel) = @_; + my ($self, $qp, $loglevel) = @_; - $self->{_level} = LOGWARN; - if ( defined($loglevel) ) { - if ($loglevel =~ /^\d+$/) { - $self->{_level} = $loglevel; - } - else { - $self->{_level} = log_level($loglevel); - } - } + $self->{_level} = LOGWARN; + if (defined($loglevel)) { + if ($loglevel =~ /^\d+$/) { + $self->{_level} = $loglevel; + } + else { + $self->{_level} = log_level($loglevel); + } + } - # If you want to capture this log entry with this plugin, you need to - # wait until after you register the plugin - $self->log(LOGINFO,'Initializing logging::warn plugin'); + # If you want to capture this log entry with this plugin, you need to + # wait until after you register the plugin + $self->log(LOGINFO, 'Initializing logging::warn plugin'); } sub hook_logging { - my ($self, $transaction, $trace, $hook, $plugin, @log) = @_; + my ($self, $transaction, $trace, $hook, $plugin, @log) = @_; - # Don't log your own log entries! If this is the only logging plugin - # then these lines will not be logged at all. You can safely comment - # out this line and it will not cause an infinite loop. + # Don't log your own log entries! If this is the only logging plugin + # then these lines will not be logged at all. You can safely comment + # out this line and it will not cause an infinite loop. return DECLINED if defined $plugin && $plugin eq $self->plugin_name; return DECLINED if $trace > $self->{_level}; - my $prefix = defined $plugin && defined $hook ? " ($hook) $plugin:" : - defined $plugin ? " $plugin:" : - defined $hook ? " ($hook) running plugin:" : ''; + my $prefix = + defined $plugin && defined $hook ? " ($hook) $plugin:" + : defined $plugin ? " $plugin:" + : defined $hook ? " ($hook) running plugin:" + : ''; warn join(' ', $$ . $prefix, @log), "\n"; diff --git a/plugins/loop b/plugins/loop index 1a3d264..b0d8e51 100644 --- a/plugins/loop +++ b/plugins/loop @@ -29,28 +29,30 @@ Released to the public domain, 17 June 2005. use Qpsmtpd::DSN; sub init { - my ($self, $qp, @args) = @_; + my ($self, $qp, @args) = @_; - $self->{_max_hops} = $args[0] || 100; + $self->{_max_hops} = $args[0] || 100; - if ( $self->{_max_hops} !~ /^\d+$/ ) { - $self->log(LOGWARN, "Invalid max_hops value -- using default"); - $self->{_max_hops} = 100; - } - $self->log(LOGWARN, "Ignoring additional arguments") if @args > 1; + if ($self->{_max_hops} !~ /^\d+$/) { + $self->log(LOGWARN, "Invalid max_hops value -- using default"); + $self->{_max_hops} = 100; + } + $self->log(LOGWARN, "Ignoring additional arguments") if @args > 1; } sub hook_data_post { - my ($self, $transaction) = @_; + my ($self, $transaction) = @_; - my $hops = 0; - $hops++ for $transaction->header->get('Received'), - $transaction->header->get('Delivered-To'); + my $hops = 0; + $hops++ + for $transaction->header->get('Received'), + $transaction->header->get('Delivered-To'); - if ( $hops >= $self->{_max_hops} ) { - # default of too_many_hops is DENY, see comment in POD of Qpsmtpd::DSN - return Qpsmtpd::DSN->too_many_hops(); - } + if ($hops >= $self->{_max_hops}) { - return DECLINED; + # default of too_many_hops is DENY, see comment in POD of Qpsmtpd::DSN + return Qpsmtpd::DSN->too_many_hops(); + } + + return DECLINED; } diff --git a/plugins/milter b/plugins/milter index 64370e9..824e10e 100644 --- a/plugins/milter +++ b/plugins/milter @@ -1,4 +1,5 @@ #!perl -w + =head1 NAME milter @@ -31,19 +32,19 @@ use Qpsmtpd::Constants; no warnings; sub register { - my ($self, $qp, @args) = @_; + my ($self, $qp, @args) = @_; + + die "Invalid milter setup args: '@args'" unless @args > 1; + my ($name, $port) = @args; + my $host = '127.0.0.1'; + if ($port =~ s/^(.*)://) { + $host = $1; + } + + $self->{name} = $name; + $self->{host} = $host; + $self->{port} = $port; - die "Invalid milter setup args: '@args'" unless @args > 1; - my ($name, $port) = @args; - my $host = '127.0.0.1'; - if ($port =~ s/^(.*)://) { - $host = $1; - } - - $self->{name} = $name; - $self->{host} = $host; - $self->{port} = $port; - } sub hook_disconnect { @@ -51,8 +52,8 @@ sub hook_disconnect { my $milter = $self->connection->notes('milter') || return DECLINED; $milter->send_quit(); - - $self->connection->notes('spam', undef); + + $self->connection->notes('spam', undef); $self->connection->notes('milter', undef); return DECLINED; @@ -62,9 +63,11 @@ sub check_results { my ($self, $transaction, $where, @results) = @_; foreach my $result (@results) { next if $result->{action} eq 'continue'; - $self->log(LOGINFO, "milter $self->{name} result action: $result->{action}"); + $self->log(LOGINFO, + "milter $self->{name} result action: $result->{action}"); if ($result->{action} eq 'reject') { - die("Rejected at $where by $self->{name} milter ($result->{explanation})"); + die( +"Rejected at $where by $self->{name} milter ($result->{explanation})"); } elsif ($result->{action} eq 'add') { if ($result->{header} eq 'body') { @@ -72,27 +75,29 @@ sub check_results { } else { push @{$transaction->notes('milter_header_changes')->{add}}, - [$result->{header}, $result->{value}]; + [$result->{header}, $result->{value}]; } } elsif ($result->{action} eq 'delete') { push @{$transaction->notes('milter_header_changes')->{delete}}, - $result->{header}; + $result->{header}; } elsif ($result->{action} eq 'accept') { + # TODO - figure out what this is used for } elsif ($result->{action} eq 'replace') { push @{$transaction->notes('milter_header_changes')->{replace}}, - [$result->{header}, $result->{value}]; + [$result->{header}, $result->{value}]; } } } sub hook_connect { my ($self, $transaction) = @_; - - $self->log(LOGDEBUG, "milter $self->{name} opening connection to milter backend"); + + $self->log(LOGDEBUG, + "milter $self->{name} opening connection to milter backend"); my $milter = Net::Milter->new(); $milter->open($self->{host}, $self->{port}, 'tcp'); $milter->protocol_negotiation(); @@ -100,15 +105,21 @@ sub hook_connect { $self->connection->notes(milter => $milter); $self->connection->notes( - milter_header_changes => { add => [], delete => [], replace => [], } - ); - my $remote_ip = $self->qp->connection->remote_ip; + milter_header_changes => {add => [], delete => [], replace => [],}); + my $remote_ip = $self->qp->connection->remote_ip; my $remote_host = $self->qp->connection->remote_host; - $self->log(LOGDEBUG, "milter $self->{name} checking connect from $remote_host\[$remote_ip\]"); - + $self->log(LOGDEBUG, + "milter $self->{name} checking connect from $remote_host\[$remote_ip\]" + ); + eval { - $self->check_results($transaction, "connection", - $milter->send_connect($remote_host, 'tcp4', 0, $remote_ip)); + $self->check_results( + $transaction, + "connection", + $milter->send_connect( + $remote_host, 'tcp4', 0, $remote_ip + ) + ); }; $self->connection->notes('spam', $@) if $@; @@ -121,44 +132,51 @@ sub hook_helo { if (my $txt = $self->connection->notes('spam')) { return DENY, $txt; } - + my $milter = $self->connection->notes('milter'); - + my $helo = $self->qp->connection->hello; my $host = $self->qp->connection->hello_host; $self->log(LOGDEBUG, "milter $self->{name} checking HELO $host"); - - eval { $self->check_results($transaction, "HELO", - $milter->send_helo($host)) }; - return(DENY, $@) if $@; - + + eval { + $self->check_results($transaction, "HELO", $milter->send_helo($host)); + }; + return (DENY, $@) if $@; + return DECLINED; } sub hook_mail { my ($self, $transaction, $address, %param) = @_; - + my $milter = $self->connection->notes('milter'); - $self->log(LOGDEBUG, "milter $self->{name} checking MAIL FROM " . $address->format); - eval { $self->check_results($transaction, "MAIL FROM", - $milter->send_mail_from($address->format)) }; - return(DENY, $@) if $@; + $self->log(LOGDEBUG, + "milter $self->{name} checking MAIL FROM " . $address->format); + eval { + $self->check_results($transaction, "MAIL FROM", + $milter->send_mail_from($address->format)); + }; + return (DENY, $@) if $@; return DECLINED; } sub hook_rcpt { my ($self, $transaction, $address, %param) = @_; - + my $milter = $self->connection->notes('milter'); - $self->log(LOGDEBUG, "milter $self->{name} checking RCPT TO " . $address->format); + $self->log(LOGDEBUG, + "milter $self->{name} checking RCPT TO " . $address->format); - eval { $self->check_results($transaction, "RCPT TO", - $milter->send_rcpt_to($address->format)) }; - return(DENY, $@) if $@; + eval { + $self->check_results($transaction, "RCPT TO", + $milter->send_rcpt_to($address->format)); + }; + return (DENY, $@) if $@; return DECLINED; } @@ -170,25 +188,31 @@ sub hook_data_post { $self->log(LOGDEBUG, "milter $self->{name} checking headers"); - my $headers = $transaction->header(); # Mail::Header object + my $headers = $transaction->header(); # Mail::Header object foreach my $h ($headers->tags) { + # munge these headers because milters prefer them this way $h =~ s/\b(\w)/\U$1/g; $h =~ s/\bid\b/ID/g; foreach my $val ($headers->get($h)) { - # $self->log(LOGDEBUG, "milter $self->{name} checking header: $h: $val"); - eval { $self->check_results($transaction, "header $h", - $milter->send_header($h, $val)) }; - return(DENY, $@) if $@; + + # $self->log(LOGDEBUG, "milter $self->{name} checking header: $h: $val"); + eval { + $self->check_results($transaction, "header $h", + $milter->send_header($h, $val)); + }; + return (DENY, $@) if $@; } } - - eval { $self->check_results($transaction, "end headers", - $milter->send_end_headers()) }; - return(DENY, $@) if $@; - + + eval { + $self->check_results($transaction, "end headers", + $milter->send_end_headers()); + }; + return (DENY, $@) if $@; + $transaction->body_resetpos; - + # skip past headers while (my $line = $transaction->body_getline) { $line =~ s/\r?\n//; @@ -202,25 +226,31 @@ sub hook_data_post { while (my $line = $transaction->body_getline) { $data .= $line; if (length($data) > 60000) { - eval { $self->check_results($transaction, "body", - $milter->send_body($data)) }; - return(DENY, $@) if $@; + eval { + $self->check_results($transaction, "body", + $milter->send_body($data)); + }; + return (DENY, $@) if $@; $data = ''; } } - + if (length($data)) { - eval { $self->check_results($transaction, "body", - $milter->send_body($data)) }; - return(DENY, $@) if $@; + eval { + $self->check_results($transaction, "body", + $milter->send_body($data)); + }; + return (DENY, $@) if $@; $data = ''; } - - eval { $self->check_results($transaction, "end of DATA", - $milter->send_end_body()) }; - return(DENY, $@) if $@; - my $milter_header_changes = $transaction->notes('milter_header_changes'); + eval { + $self->check_results($transaction, "end of DATA", + $milter->send_end_body()); + }; + return (DENY, $@) if $@; + + my $milter_header_changes = $transaction->notes('milter_header_changes'); foreach my $add (@{$milter_header_changes->{add}}) { $headers->add($add->[0], $add->[1]); @@ -231,6 +261,6 @@ sub hook_data_post { foreach my $repl (@{$milter_header_changes->{replace}}) { $headers->replace($repl->[0], $repl->[1]); } - + return DECLINED; } diff --git a/plugins/naughty b/plugins/naughty index b1f4441..3b41826 100644 --- a/plugins/naughty +++ b/plugins/naughty @@ -109,28 +109,28 @@ use Qpsmtpd::Constants; sub register { my ($self, $qp) = (shift, shift); $self->log(LOGERROR, "Bad arguments") if @_ % 2; - $self->{_args} = { @_ }; - $self->{_args}{reject} ||= 'rcpt'; + $self->{_args} = {@_}; + $self->{_args}{reject} ||= 'rcpt'; $self->{_args}{reject_type} ||= 'disconnect'; my $reject = lc $self->{_args}{reject}; - my %hooks = map { $_ => 1 } - qw/ connect mail rcpt data data_post hook_queue_post /; + my %hooks = + map { $_ => 1 } qw/ connect mail rcpt data data_post hook_queue_post /; - if ( ! $hooks{$reject} ) { - $self->log( LOGERROR, "fail, invalid hook $reject" ); - $self->register_hook( 'data_post', 'naughty'); + if (!$hooks{$reject}) { + $self->log(LOGERROR, "fail, invalid hook $reject"); + $self->register_hook('data_post', 'naughty'); return; - }; + } # just in case naughty doesn't disconnect, which can happen if a plugin # with the same hook returned OK before naughty ran, or .... - if ( $reject ne 'data_post' && $reject ne 'hook_queue_post' ) { - $self->register_hook( 'data_post', 'naughty'); - }; + if ($reject ne 'data_post' && $reject ne 'hook_queue_post') { + $self->register_hook('data_post', 'naughty'); + } $self->log(LOGDEBUG, "registering hook $reject"); - $self->register_hook( $reject, 'naughty'); + $self->register_hook($reject, 'naughty'); } sub naughty { @@ -140,8 +140,11 @@ sub naughty { return DECLINED; }; $self->log(LOGINFO, "disconnecting"); - my $type = $self->get_reject_type( 'disconnect', - $self->connection->notes('naughty_reject_type') ); - return ( $type, $naughty ); -}; + my $type = $self->get_reject_type( + 'disconnect', + $self->connection->notes( + 'naughty_reject_type') + ); + return ($type, $naughty); +} diff --git a/plugins/noop_counter b/plugins/noop_counter index 6ce949b..8e9840e 100644 --- a/plugins/noop_counter +++ b/plugins/noop_counter @@ -33,30 +33,30 @@ sub register { sub hook_noop { my ($self, $transaction, @args) = @_; ++$self->{_noop_count}; - ### the following block is not used, RFC 2821 says we SHOULD ignore - ### any arguments... so we MAY return an error if we want to :-) + ### the following block is not used, RFC 2821 says we SHOULD ignore + ### any arguments... so we MAY return an error if we want to :-) # return (DENY, "Syntax error, NOOP does not take any arguments") # if $args[0]; - + if ($self->{_noop_count} >= $self->{_max_noop}) { - return (DENY_DISCONNECT, - "Stop wasting my time, too many consecutive NOOPs"); + return (DENY_DISCONNECT, + "Stop wasting my time, too many consecutive NOOPs"); } return (DECLINED); } sub reset_noop_counter { - $_[0]->{_noop_count} = 0; - return (DECLINED); + $_[0]->{_noop_count} = 0; + return (DECLINED); } # and bind the counter reset to the hooks, QUIT not useful here: -*hook_helo = *hook_ehlo = # HELO / EHLO - *hook_mail = # MAIL FROM: - *hook_rcpt = # RCPT TO: - *hook_data = # DATA - *hook_reset_transaction = # RSET - *hook_vrfy = # VRFY - *hook_help = # HELP - \&reset_noop_counter; +*hook_helo = *hook_ehlo = # HELO / EHLO + *hook_mail = # MAIL FROM: + *hook_rcpt = # RCPT TO: + *hook_data = # DATA + *hook_reset_transaction = # RSET + *hook_vrfy = # VRFY + *hook_help = # HELP + \&reset_noop_counter; diff --git a/plugins/parse_addr_withhelo b/plugins/parse_addr_withhelo index 2d70e7b..2af5f4c 100644 --- a/plugins/parse_addr_withhelo +++ b/plugins/parse_addr_withhelo @@ -35,20 +35,20 @@ sub hook_rcpt_parse { } sub _parse { - my ($self,$cmd,$line) = @_; + my ($self, $cmd, $line) = @_; $self->log(LOGDEBUG, "_parse() cmd=[$cmd], line=[$line]"); if ($cmd eq 'mail') { - return(DENY, "Syntax error in command") + return (DENY, "Syntax error in command") unless ($line =~ s/^from:\s*//i); } - else { # cmd eq 'rcpt' - return(DENY, "Syntax error in command") + else { # cmd eq 'rcpt' + return (DENY, "Syntax error in command") unless ($line =~ s/^to:\s*//i); } if ($line =~ s/^(<.*>)\s*//) { my $addr = $1; - return (DENY, "No parameters allowed in ".uc($cmd)) + return (DENY, "No parameters allowed in " . uc($cmd)) if ($line =~ /^\S/); return (OK, $addr, ()); } @@ -56,13 +56,13 @@ sub _parse { ## now, no <> are given $line =~ s/\s*$//; if ($line =~ /\@/) { - return (DENY, "No parameters allowed in ".uc($cmd)) + return (DENY, "No parameters allowed in " . uc($cmd)) if ($line =~ /\@\S+\s+\S/); return (OK, $line, ()); } if ($cmd eq "mail") { - return (OK, "<>") unless $line; # 'MAIL FROM:' -> 'MAIL FROM:<>' + return (OK, "<>") unless $line; # 'MAIL FROM:' -> 'MAIL FROM:<>' return (DENY, "Could not parse your MAIL FROM command"); } else { diff --git a/plugins/qmail_deliverable b/plugins/qmail_deliverable old mode 100755 new mode 100644 index ec45024..62609f8 --- a/plugins/qmail_deliverable +++ b/plugins/qmail_deliverable @@ -90,21 +90,21 @@ BEGIN { if (not $INC{'Qpsmtpd.pm'}) { my $dir = '$PLUGINS_DIRECTORY'; -d and $dir = $_ for qw( - /home/qpsmtpd/plugins - /home/smtp/qpsmtpd/plugins - /usr/local/qpsmtpd/plugins - /usr/local/share/qpsmtpd/plugins - /usr/share/qpsmtpd/plugins - ); + /home/qpsmtpd/plugins + /home/smtp/qpsmtpd/plugins + /usr/local/qpsmtpd/plugins + /usr/local/share/qpsmtpd/plugins + /usr/share/qpsmtpd/plugins + ); my $file = "the 'plugins' configuration file"; -f and $file = $_ for qw( - /home/qpsmtpd/config/plugins - /home/smtp/qpsmtpd/config/plugins - /usr/local/qpsmtpd/config/plugins - /usr/local/etc/qpsmtpd/plugins - /etc/qpsmtpd/plugins - ); + /home/qpsmtpd/config/plugins + /home/smtp/qpsmtpd/config/plugins + /usr/local/qpsmtpd/config/plugins + /usr/local/etc/qpsmtpd/plugins + /etc/qpsmtpd/plugins + ); # "die" would print "BEGIN failed" garbage print STDERR <<"END"; @@ -135,20 +135,21 @@ use Qpsmtpd::Constants; use Qmail::Deliverable::Client qw(deliverable); my %smtproutes; -my $shared_domain; # global variable to be closed over by the SERVER callback +my $shared_domain; # global variable to be closed over by the SERVER callback sub register { my ($self, $qp, @args) = @_; if (@args % 2) { $self->log(LOGWARN, "Odd number of arguments, using default config"); - } else { + } + else { my %args = @args; if ($args{server} && $args{server} =~ /^smtproutes:/) { my ($fallback, $port) = $args{server} =~ /:(?:(.*?):?)(\d+)/; open my $fh, "/var/qmail/control/smtproutes" - or warn "Could not read smtproutes"; + or warn "Could not read smtproutes"; for (readline $fh) { my ($domain, $mx) = /^(.*?) : \[? ( [^\]:\s]* )/x; $smtproutes{$domain} = $mx; @@ -161,16 +162,17 @@ sub register { return; }; - } elsif ($args{server}) { + } + elsif ($args{server}) { $Qmail::Deliverable::Client::SERVER = $args{server}; } - if ( $args{vpopmail_ext} ) { + if ($args{vpopmail_ext}) { $Qmail::Deliverable::VPOPMAIL_EXT = $args{vpopmail_ext}; - }; - if ( $args{reject} ) { + } + if ($args{reject}) { $self->{_args}{reject} = $args{reject}; - }; + } } $self->register_hook("rcpt", "rcpt_handler"); } @@ -178,7 +180,7 @@ sub register { sub rcpt_handler { my ($self, $transaction, $rcpt) = @_; - return DECLINED if $self->is_immune(); # requires QP 0.90+ + return DECLINED if $self->is_immune(); # requires QP 0.90+ my $address = $rcpt->address; $self->log(LOGDEBUG, "Checking deliverability for recipient '$address'"); @@ -192,38 +194,41 @@ sub rcpt_handler { return DECLINED; } - my $k = 0; # known status code - $self->log(LOGINFO, "error, permission failure"), $k++ if $rv == 0x11; - $self->log(LOGINFO, "pass, qmail-command in dot-qmail"),$k++ if $rv == 0x12; + my $k = 0; # known status code + $self->log(LOGINFO, "error, permission failure"), $k++ if $rv == 0x11; + $self->log(LOGINFO, "pass, qmail-command in dot-qmail"), $k++ + if $rv == 0x12; $self->log(LOGINFO, "pass, bouncesaying with program"), $k++ if $rv == 0x13; - if ( $rv == 0x14 ) { + if ($rv == 0x14) { my $s = $transaction->sender->address; return (DENY, "mailing lists do not accept null senders") - if ( ! $s || $s eq '<>'); - $self->log(LOGINFO, "pass, ezmlm list"); $k++; - }; + if (!$s || $s eq '<>'); + $self->log(LOGINFO, "pass, ezmlm list"); + $k++; + } $self->log(LOGINFO, "Temporarily undeliverable: group/world writable"), $k++ - if $rv == 0x21; - $self->log(LOGINFO, "Temporarily undeliverable: sticky home directory"),$k++ - if $rv == 0x22; + if $rv == 0x21; + $self->log(LOGINFO, "Temporarily undeliverable: sticky home directory"), + $k++ + if $rv == 0x22; $self->log(LOGINFO, "error, $Qmail::Deliverable::Client::ERROR"), $k++ - if $rv == 0x2f; - $self->log(LOGINFO, "pass, normal delivery"), $k++ if $rv == 0xf1; - $self->log(LOGINFO, "pass, vpopmail dir"), $k++ if $rv == 0xf2; - $self->log(LOGINFO, "pass, vpopmail alias"), $k++ if $rv == 0xf3; - $self->log(LOGINFO, "pass, vpopmail catchall"), $k++ if $rv == 0xf4; - $self->log(LOGINFO, "pass, vpopmail vuser"), $k++ if $rv == 0xf5; - $self->log(LOGINFO, "pass, vpopmail qmail-ext"), $k++ if $rv == 0xf6; - $self->log(LOGINFO, "error, SHOULD NOT HAPPEN"), $k++ if $rv == 0xfe; - $self->log(LOGINFO, "fail, address not local"), $k++ if $rv == 0xff; + if $rv == 0x2f; + $self->log(LOGINFO, "pass, normal delivery"), $k++ if $rv == 0xf1; + $self->log(LOGINFO, "pass, vpopmail dir"), $k++ if $rv == 0xf2; + $self->log(LOGINFO, "pass, vpopmail alias"), $k++ if $rv == 0xf3; + $self->log(LOGINFO, "pass, vpopmail catchall"), $k++ if $rv == 0xf4; + $self->log(LOGINFO, "pass, vpopmail vuser"), $k++ if $rv == 0xf5; + $self->log(LOGINFO, "pass, vpopmail qmail-ext"), $k++ if $rv == 0xf6; + $self->log(LOGINFO, "error, SHOULD NOT HAPPEN"), $k++ if $rv == 0xfe; + $self->log(LOGINFO, "fail, address not local"), $k++ if $rv == 0xff; - if ( $rv ) { + if ($rv) { $self->log(LOGINFO, sprintf("error, unknown: 0x%02x", $rv)) if not $k; return DECLINED; - }; + } - $self->adjust_karma( -1 ); - return $self->get_reject( "Sorry, no mailbox by that name. qd (#5.1.1)" ); + $self->adjust_karma(-1); + return $self->get_reject("Sorry, no mailbox by that name. qd (#5.1.1)"); } sub _smtproute { diff --git a/plugins/queue/exim-bsmtp b/plugins/queue/exim-bsmtp index 0dd4246..784f5ab 100644 --- a/plugins/queue/exim-bsmtp +++ b/plugins/queue/exim-bsmtp @@ -1,4 +1,5 @@ #!perl -w + =head1 NAME exim-bsmtp @@ -69,8 +70,10 @@ sub register { $self->{_exim_path} = $args{exim_path} || '/usr/sbin/rsmtp'; $self->{_exim_path} = $1 if $self->{_exim_path} =~ /(.*)/; unless (-x $self->{_exim_path}) { - $self->log(LOGERROR, "Could not find exim at $self->{_exim_path};". - " please set exim_path in config/plugins"); + $self->log(LOGERROR, + "Could not find exim at $self->{_exim_path};" + . " please set exim_path in config/plugins" + ); return undef; } } @@ -91,14 +94,14 @@ sub hook_queue { } print $tmp "HELO ", hostname(), "\n", - "MAIL FROM:<", ($transaction->sender->address || ''), ">\n"; + "MAIL FROM:<", ($transaction->sender->address || ''), ">\n"; print $tmp "RCPT TO:<", ($_->address || ''), ">\n" for $transaction->recipients; print $tmp "DATA\n", $transaction->header->as_string; $transaction->body_resetpos; while (my $line = $transaction->body_getline) { - $line =~ s/^\./../; - print $tmp $line; + $line =~ s/^\./../; + print $tmp $line; } print $tmp ".\nQUIT\n"; close $tmp; @@ -111,6 +114,7 @@ sub hook_queue { unlink $tmpfn or $self->log(LOGERROR, "unlink: $tmpfn: $!"); return (DECLINED, "Internal error enqueuing mail"); } + # Normally exim produces no output in BSMTP mode; anything that # does come out is an error worth logging. my $start = time; @@ -122,20 +126,23 @@ sub hook_queue { ($bsmtp_error, $bsmtp_msg) = ($1, $2); } } - $self->log(LOGDEBUG, "BSMTP finished (".(time - $start)." sec)"); + $self->log(LOGDEBUG, "BSMTP finished (" . (time - $start) . " sec)"); $exim->close; my $exit = $?; unlink $tmpfn or $self->log(LOGERROR, "unlink: $tmpfn: $!"); $self->log(LOGDEBUG, "Exitcode from exim: $exit"); if ($bsmtp_error && $bsmtp_error >= 400 && $bsmtp_error < 600) { - $self->log(LOGERROR, "BSMTP enqueue failed; response $bsmtp_error". - " ($bsmtp_msg)"); + $self->log(LOGERROR, + "BSMTP enqueue failed; response $bsmtp_error" . " ($bsmtp_msg)"); return ($bsmtp_error < 400 ? DECLINED : DENY, $bsmtp_msg); } elsif (($exit >> 8) != 0 || $bsmtp_error) { - $self->log(LOGERROR, 'BSMTP enqueue failed; exitcode '.($exit >> 8). - " from $self->{_exim_path} -bS"); + $self->log(LOGERROR, + 'BSMTP enqueue failed; exitcode ' + . ($exit >> 8) + . " from $self->{_exim_path} -bS" + ); return (DECLINED, 'Internal error enqueuing mail'); } diff --git a/plugins/queue/maildir b/plugins/queue/maildir index 0c71b85..b90d4e3 100644 --- a/plugins/queue/maildir +++ b/plugins/queue/maildir @@ -41,9 +41,9 @@ Replaced by the full address. =cut # =item %% -# +# # Replaced by a single percent sign (%) -# +# # =cut =back @@ -82,133 +82,145 @@ use Sys::Hostname qw(hostname); use Time::HiRes qw(gettimeofday); sub register { - my ($self, $qp, @args) = @_; + my ($self, $qp, @args) = @_; - if (@args > 0) { - ($self->{_maildir}) = ($args[0] =~ m!([-/\w\.]+)!); - } + if (@args > 0) { + ($self->{_maildir}) = ($args[0] =~ m!([-/\w\.]+)!); + } + + if (@args > 1) { + ($self->{_subdirs}) = ($args[1] =~ m#^(.*\%[ldu].*)$#); + unless ($self->{_subdirs}) { + $self->log(LOGWARN, + "WARNING: sub directory does not contain a " + . "substitution parameter" + ); + return 0; + } + } + + if (@args > 2) { + ($self->{_perms}) = ($args[2] =~ /^([0-7]{3})$/); + unless ($self->{_perms}) { # 000 is unfortunately true ;-) + $self->log(LOGWARN, "WARNING: mode is not an octal number"); + return 0; + } + $self->{_perms} = oct($self->{_perms}); + } + + $self->{_perms} = 0700 + unless $self->{_perms}; + + unless ($self->{_maildir}) { + $self->log(LOGWARN, "WARNING: maildir directory not specified"); + return 0; + } - if (@args > 1) { - ($self->{_subdirs}) = ($args[1] =~ m#^(.*\%[ldu].*)$#); unless ($self->{_subdirs}) { - $self->log(LOGWARN, "WARNING: sub directory does not contain a " - ."substitution parameter"); - return 0; + + # mkpath is influenced by umask... + my $old_umask = umask 000; + map { + my $d = $self->{_maildir} . "/$_"; + -e $d or mkpath $d, 0, $self->{_perms} + } qw(cur tmp new); + umask $old_umask; } - } - if (@args > 2) { - ($self->{_perms}) = ($args[2] =~ /^([0-7]{3})$/); - unless ($self->{_perms}) { # 000 is unfortunately true ;-) - $self->log(LOGWARN, "WARNING: mode is not an octal number"); - return 0; - } - $self->{_perms} = oct($self->{_perms}); - } - - $self->{_perms} = 0700 - unless $self->{_perms}; - - unless ($self->{_maildir}) { - $self->log(LOGWARN, "WARNING: maildir directory not specified"); - return 0; - } - - unless ($self->{_subdirs}) { - # mkpath is influenced by umask... - my $old_umask = umask 000; - map { my $d = $self->{_maildir} . "/$_"; -e $d or mkpath $d, 0, $self->{_perms} } qw(cur tmp new); - umask $old_umask; - } - - my $hostname = (hostname =~ m/([\w\._\-]+)/)[0]; - $self->{_hostname} = $hostname; + my $hostname = (hostname =~ m/([\w\._\-]+)/)[0]; + $self->{_hostname} = $hostname; } my $maildir_counter = 0; sub hook_queue { - my ($self, $transaction) = @_; - my ($rc, @msg); - my $old_umask = umask($self->{_perms} ^ 0777); + my ($self, $transaction) = @_; + my ($rc, @msg); + my $old_umask = umask($self->{_perms} ^ 0777); - if ($self->{_subdirs}) { - foreach my $addr ($transaction->recipients) { - ($rc, @msg) = $self->deliver_user($transaction, $addr); - unless($rc == OK) { + if ($self->{_subdirs}) { + foreach my $addr ($transaction->recipients) { + ($rc, @msg) = $self->deliver_user($transaction, $addr); + unless ($rc == OK) { + umask $old_umask; + return ($rc, @msg); + } + } umask $old_umask; - return ($rc, @msg); - } + return (OK, @msg); # last @msg is the same like any other before... } - umask $old_umask; - return (OK, @msg); # last @msg is the same like any other before... - } - $transaction->header->add('Delivered-To', $_->address, 0) - for $transaction->recipients; - ($rc, @msg) = $self->write_file($transaction, $self->{_maildir}); - umask $old_umask; - return ($rc, @msg); + $transaction->header->add('Delivered-To', $_->address, 0) + for $transaction->recipients; + ($rc, @msg) = $self->write_file($transaction, $self->{_maildir}); + umask $old_umask; + return ($rc, @msg); } sub write_file { - my ($self, $transaction, $maildir, $addr) = @_; - my ($time, $microseconds) = gettimeofday; + my ($self, $transaction, $maildir, $addr) = @_; + my ($time, $microseconds) = gettimeofday; - $time = ($time =~ m/(\d+)/)[0]; - $microseconds =~ s/\D//g; + $time = ($time =~ m/(\d+)/)[0]; + $microseconds =~ s/\D//g; - my $unique = "P$$" . "M$microseconds" . "Q" . $maildir_counter++; - my $file = join ".", $time, $unique, $self->{_hostname}; + my $unique = "P$$" . "M$microseconds" . "Q" . $maildir_counter++; + my $file = join ".", $time, $unique, $self->{_hostname}; - open (MF, ">$maildir/tmp/$file") or - $self->log(LOGWARN, "could not open $maildir/tmp/$file: $!"), - return(DECLINED, "queue error (open)"); + open(MF, ">$maildir/tmp/$file") + or $self->log(LOGWARN, "could not open $maildir/tmp/$file: $!"), + return (DECLINED, "queue error (open)"); - print MF "Return-Path: ", $transaction->sender->format , "\n"; + print MF "Return-Path: ", $transaction->sender->format, "\n"; - print MF "Delivered-To: ",$addr->address,"\n" - if $addr; # else it had been added before... + print MF "Delivered-To: ", $addr->address, "\n" + if $addr; # else it had been added before... - $transaction->header->print(\*MF); - $transaction->body_resetpos; - while (my $line = $transaction->body_getline) { - print MF $line; - } - close MF or - $self->log(LOGWARN, "could not close $maildir/tmp/$file: $!") - and return(DECLINED, "queue error (close)"); + $transaction->header->print(\*MF); + $transaction->body_resetpos; + while (my $line = $transaction->body_getline) { + print MF $line; + } + close MF + or $self->log(LOGWARN, "could not close $maildir/tmp/$file: $!") + and return (DECLINED, "queue error (close)"); - link "$maildir/tmp/$file", "$maildir/new/$file" or - $self->log(LOGWARN, "could not link $maildir/tmp/$file to $maildir/new/$file: $!") - and return(DECLINED, "queue error (link)"); + link "$maildir/tmp/$file", + "$maildir/new/$file" + or $self->log(LOGWARN, + "could not link $maildir/tmp/$file to $maildir/new/$file: $!") + and return (DECLINED, "queue error (link)"); - unlink "$maildir/tmp/$file"; + unlink "$maildir/tmp/$file"; - my $msg_id = $transaction->header->get('Message-Id') || ''; - $msg_id =~ s/[\r\n].*//s; + my $msg_id = $transaction->header->get('Message-Id') || ''; + $msg_id =~ s/[\r\n].*//s; - return (OK, "Queued! $msg_id"); + return (OK, "Queued! $msg_id"); } sub deliver_user { - my ($self, $transaction, $addr) = @_; - my $user = $addr->user; $user =~ tr/-A-Za-z0-9+_.,@=/_/c; - my $host = $addr->host; $host =~ tr/-A-Za-z0-9+_.,@=/_/c; - my $rcpt = $user.'@'.$host; + my ($self, $transaction, $addr) = @_; + my $user = $addr->user; + $user =~ tr/-A-Za-z0-9+_.,@=/_/c; + my $host = $addr->host; + $host =~ tr/-A-Za-z0-9+_.,@=/_/c; + my $rcpt = $user . '@' . $host; - my $subdir = $self->{_subdirs}; - $subdir =~ s/\%l/$user/g; - $subdir =~ s/\%d/$host/g; - $subdir =~ s/\%u/$rcpt/g; -# $subdir =~ s/\%%/%/g; + my $subdir = $self->{_subdirs}; + $subdir =~ s/\%l/$user/g; + $subdir =~ s/\%d/$host/g; + $subdir =~ s/\%u/$rcpt/g; - my $maildir = $self->{_maildir}."/$subdir"; - my $old_umask = umask 000; - map { my $d = $maildir . "/$_"; -e $d or mkpath $d, 0, $self->{_perms} } qw(cur tmp new); - umask $old_umask; + # $subdir =~ s/\%%/%/g; - return $self->write_file($transaction, $maildir, $addr); + my $maildir = $self->{_maildir} . "/$subdir"; + my $old_umask = umask 000; + map { my $d = $maildir . "/$_"; -e $d or mkpath $d, 0, $self->{_perms} } + qw(cur tmp new); + umask $old_umask; + + return $self->write_file($transaction, $maildir, $addr); } diff --git a/plugins/queue/postfix-queue b/plugins/queue/postfix-queue index 2586d9a..9eea355 100644 --- a/plugins/queue/postfix-queue +++ b/plugins/queue/postfix-queue @@ -128,20 +128,22 @@ use Qpsmtpd::Postfix::Constants; sub register { my ($self, $qp, @args) = @_; - $self->log(LOGDEBUG, "using constants generated from Postfix" - ."v$postfix_version"); + $self->log(LOGDEBUG, + "using constants generated from Postfix" . "v$postfix_version"); $self->{_queue_flags} = 0; if (@args > 0) { if ($args[0] =~ m#^(/.+)#) { + # untaint socket path $self->{_queue_socket} = $1; shift @args; } foreach (@args) { - if ($self->can("CLEANUP_".$_) and /^(FLAG_[A-Z0-9_]+)$/) { + if ($self->can("CLEANUP_" . $_) and /^(FLAG_[A-Z0-9_]+)$/) { $_ = $1; $self->{_queue_flags} |= (eval "CLEANUP_$_;" || 0); + #print STDERR "queue flag: $_: ".$self->{_queue_flags}."\n"; } else { @@ -166,29 +168,32 @@ sub hook_queue { @queue = ($self->{_queue_socket} // ()) unless @queue; $transaction->notes('postfix-queue-sockets', \@queue) if @queue; - # $self->log(LOGDEBUG, "queue-flags=".$transaction->notes('postfix-queue-flags')); +# $self->log(LOGDEBUG, "queue-flags=".$transaction->notes('postfix-queue-flags')); my ($status, $qid, $reason) = Qpsmtpd::Postfix->inject_mail($transaction); if ($status) { - # this split is needed, because if cleanup returns - # CLEANUP_STAT_MASK_INCOMPLETE we might return DENY (CLEANUP_STAT_SIZE) - # instead of DENYSOFT (CLEANUP_STAT_WRITE, CLEANUP_STAT_BAD, - # CLEANUP_STAT_DEFER) ... n.b. this is the behaviour of 667. - foreach my $key (keys %cleanup_soft) { - my $stat = eval $key # keys have the same names as the constants - or next; - if ($status & $stat) { - return (DENYSOFT, $reason || $cleanup_soft{$key}); + + # this split is needed, because if cleanup returns + # CLEANUP_STAT_MASK_INCOMPLETE we might return DENY (CLEANUP_STAT_SIZE) + # instead of DENYSOFT (CLEANUP_STAT_WRITE, CLEANUP_STAT_BAD, + # CLEANUP_STAT_DEFER) ... n.b. this is the behaviour of 667. + foreach my $key (keys %cleanup_soft) { + my $stat = eval $key # keys have the same names as the constants + or next; + if ($status & $stat) { + return (DENYSOFT, $reason || $cleanup_soft{$key}); + } } - } - foreach my $key (keys %cleanup_hard) { - my $stat = eval $key # keys have the same names as the constants - or next; - if ($status & $stat) { - return (DENY, $reason || $cleanup_hard{$key}); + foreach my $key (keys %cleanup_hard) { + my $stat = eval $key # keys have the same names as the constants + or next; + if ($status & $stat) { + return (DENY, $reason || $cleanup_hard{$key}); + } } - } - # we have no idea why we're here. - return (DECLINED, $reason || "Unable to queue message ($status, $reason)"); + + # we have no idea why we're here. + return (DECLINED, + $reason || "Unable to queue message ($status, $reason)"); } my $msg_id = $transaction->header->get('Message-Id') || ''; diff --git a/plugins/queue/qmail-queue b/plugins/queue/qmail-queue index b50b73a..1d97fc3 100644 --- a/plugins/queue/qmail-queue +++ b/plugins/queue/qmail-queue @@ -20,7 +20,6 @@ If set the environment variable QMAILQUEUE overrides this setting. =cut - use strict; use warnings; @@ -32,7 +31,8 @@ sub register { if (@args > 0) { $self->{_queue_exec} = $args[0]; - $self->log(LOGWARN, "WARNING: Ignoring additional arguments.") if @args > 1; + $self->log(LOGWARN, "WARNING: Ignoring additional arguments.") + if @args > 1; } $self->{_queue_exec} ||= ($ENV{QMAIL} || '/var/qmail') . "/bin/qmail-queue"; @@ -42,19 +42,23 @@ sub register { sub hook_queue { my ($self, $transaction) = @_; -# these bits inspired by Peter Samuels "qmail-queue wrapper" + # these bits inspired by Peter Samuels "qmail-queue wrapper" pipe(MESSAGE_READER, MESSAGE_WRITER) or die "Could not create message pipe"; - pipe(ENVELOPE_READER, ENVELOPE_WRITER) or die "Could not create envelope pipe"; + pipe(ENVELOPE_READER, ENVELOPE_WRITER) + or die "Could not create envelope pipe"; local $SIG{PIPE} = sub { die 'SIGPIPE' }; my $child = fork(); - ! defined $child and die "Could not fork"; + !defined $child and die "Could not fork"; if ($child) { -# Parent - my $oldfh = select MESSAGE_WRITER; $| = 1; - select ENVELOPE_WRITER; $| = 1; + + # Parent + my $oldfh = select MESSAGE_WRITER; + $| = 1; + select ENVELOPE_WRITER; + $| = 1; select $oldfh; close MESSAGE_READER or die "close msg reader fault"; @@ -68,51 +72,59 @@ sub hook_queue { close MESSAGE_WRITER; my @rcpt = map { "T" . $_->address } $transaction->recipients; - my $from = "F".($transaction->sender->address|| "" ); - print ENVELOPE_WRITER "$from\0", join("\0",@rcpt), "\0\0" - or return(DECLINED,"Could not print addresses to queue"); + my $from = "F" . ($transaction->sender->address || ""); + print ENVELOPE_WRITER "$from\0", join("\0", @rcpt), "\0\0" + or return (DECLINED, "Could not print addresses to queue"); close ENVELOPE_WRITER; waitpid($child, 0); my $exit_code = $? >> 8; - $exit_code and return(DECLINED, "Unable to queue message ($exit_code)"); + $exit_code + and return (DECLINED, "Unable to queue message ($exit_code)"); my $msg_id = $transaction->header->get('Message-Id') || ''; $msg_id =~ s/[\r\n].*//s; # don't allow newlines in the Message-Id here - $msg_id = "<$msg_id>" unless $msg_id =~ /^<.*>$/; # surround in <>'s - return (OK, "Queued! " . time . " qp $child $msg_id"); + $msg_id = "<$msg_id>" unless $msg_id =~ /^<.*>$/; # surround in <>'s + return (OK, "Queued! " . time . " qp $child $msg_id"); } elsif (defined $child) { -# Child - close MESSAGE_WRITER or exit 1; + + # Child + close MESSAGE_WRITER or exit 1; close ENVELOPE_WRITER or exit 2; -# Untaint $self->{_queue_exec} + # Untaint $self->{_queue_exec} my $queue_exec = $self->{_queue_exec}; if ($queue_exec =~ /^(\/[\/\-\_\.a-z0-9A-Z]*)$/) { $queue_exec = $1; - } else { - $self->log(LOGERROR, "FATAL ERROR: Unexpected characters in qmail-queue plugin argument"); -# This exit is ok as we're exiting a forked child process. + } + else { + $self->log(LOGERROR, +"FATAL ERROR: Unexpected characters in qmail-queue plugin argument" + ); + + # This exit is ok as we're exiting a forked child process. exit 3; } -# save the original STDIN and STDOUT in case exec() fails below - open(SAVE_STDIN, "<&STDIN"); + # save the original STDIN and STDOUT in case exec() fails below + open(SAVE_STDIN, "<&STDIN"); open(SAVE_STDOUT, ">&STDOUT"); - POSIX::dup2(fileno(MESSAGE_READER), 0) or die "Unable to dup MESSAGE_READER: $!"; - POSIX::dup2(fileno(ENVELOPE_READER), 1) or die "Unable to dup ENVELOPE_READER: $!"; + POSIX::dup2(fileno(MESSAGE_READER), 0) + or die "Unable to dup MESSAGE_READER: $!"; + POSIX::dup2(fileno(ENVELOPE_READER), 1) + or die "Unable to dup ENVELOPE_READER: $!"; my $ppid = getppid(); $self->log(LOGNOTICE, "(for $ppid) Queuing to $queue_exec"); my $rc = exec $queue_exec; -# close the pipe + # close the pipe close(MESSAGE_READER); close(MESSAGE_WRITER); - exit 6; # we'll only get here if the exec fails + exit 6; # we'll only get here if the exec fails } } diff --git a/plugins/queue/smtp-forward b/plugins/queue/smtp-forward index a6c23c3..5491569 100644 --- a/plugins/queue/smtp-forward +++ b/plugins/queue/smtp-forward @@ -1,4 +1,5 @@ #!perl -w + =head1 NAME smtp-forward @@ -23,48 +24,56 @@ Optionally you can also add a port: use Net::SMTP; sub init { - my ($self, $qp, @args) = @_; + my ($self, $qp, @args) = @_; - if (@args > 0) { - if ($args[0] =~ /^([\.\w_-]+)$/) { - $self->{_smtp_server} = $1; + if (@args > 0) { + if ($args[0] =~ /^([\.\w_-]+)$/) { + $self->{_smtp_server} = $1; + } + else { + die "Bad data in smtp server: $args[0]"; + } + $self->{_smtp_port} = 25; + if (@args > 1 and $args[1] =~ /^(\d+)$/) { + $self->{_smtp_port} = $1; + } + $self->log(LOGWARN, "WARNING: Ignoring additional arguments.") + if (@args > 2); } else { - die "Bad data in smtp server: $args[0]"; + die("No SMTP server specified in smtp-forward config"); } - $self->{_smtp_port} = 25; - if (@args > 1 and $args[1] =~ /^(\d+)$/) { - $self->{_smtp_port} = $1; - } - $self->log(LOGWARN, "WARNING: Ignoring additional arguments.") if (@args > 2); - } else { - die("No SMTP server specified in smtp-forward config"); - } } sub hook_queue { - my ($self, $transaction) = @_; + my ($self, $transaction) = @_; - $self->log(LOGINFO, "forwarding to $self->{_smtp_server}:$self->{_smtp_port}"); - my $smtp = Net::SMTP->new( - $self->{_smtp_server}, - Port => $self->{_smtp_port}, - Timeout => 60, - Hello => $self->qp->config("me"), - ) || die $!; - $smtp->mail( $transaction->sender->address || "" ) or return(DECLINED, "Unable to queue message ($!)"); - for ($transaction->recipients) { - $smtp->to($_->address) or return(DECLINED, "Unable to queue message ($!)"); - } - $smtp->data() or return(DECLINED, "Unable to queue message ($!)"); - $smtp->datasend($transaction->header->as_string) or return(DECLINED, "Unable to queue message ($!)"); - $transaction->body_resetpos; - while (my $line = $transaction->body_getline) { - $smtp->datasend($line) or return(DECLINED, "Unable to queue message ($!)"); - } - $smtp->dataend() or return(DECLINED, "Unable to queue message ($!)"); - $smtp->quit() or return(DECLINED, "Unable to queue message ($!)"); - $self->log(LOGINFO, "finished queueing"); - return (OK, "Queued!"); + $self->log(LOGINFO, + "forwarding to $self->{_smtp_server}:$self->{_smtp_port}"); + my $smtp = Net::SMTP->new( + $self->{_smtp_server}, + Port => $self->{_smtp_port}, + Timeout => 60, + Hello => $self->qp->config("me"), + ) + || die $!; + $smtp->mail($transaction->sender->address || "") + or return (DECLINED, "Unable to queue message ($!)"); + for ($transaction->recipients) { + $smtp->to($_->address) + or return (DECLINED, "Unable to queue message ($!)"); + } + $smtp->data() or return (DECLINED, "Unable to queue message ($!)"); + $smtp->datasend($transaction->header->as_string) + or return (DECLINED, "Unable to queue message ($!)"); + $transaction->body_resetpos; + while (my $line = $transaction->body_getline) { + $smtp->datasend($line) + or return (DECLINED, "Unable to queue message ($!)"); + } + $smtp->dataend() or return (DECLINED, "Unable to queue message ($!)"); + $smtp->quit() or return (DECLINED, "Unable to queue message ($!)"); + $self->log(LOGINFO, "finished queueing"); + return (OK, "Queued!"); } diff --git a/plugins/quit_fortune b/plugins/quit_fortune index 2e1effe..15abfc9 100644 --- a/plugins/quit_fortune +++ b/plugins/quit_fortune @@ -1,17 +1,17 @@ #!perl -w sub hook_quit { - my $qp = shift->qp; + my $qp = shift->qp; - # if she talks EHLO she is probably too sophisticated to enjoy the - # fun, so skip it. - return (DECLINED) if ($qp->connection->hello || '') eq "ehlo"; + # if she talks EHLO she is probably too sophisticated to enjoy the + # fun, so skip it. + return (DECLINED) if ($qp->connection->hello || '') eq "ehlo"; - my $fortune = '/usr/games/fortune'; - return DECLINED unless -e $fortune; + my $fortune = '/usr/games/fortune'; + return DECLINED unless -e $fortune; - my @fortune = `$fortune -s`; - @fortune = map { chop; s/^/ \/ /; $_ } @fortune; - $qp->respond(221, $qp->config('me') . " closing connection.", @fortune); - return DONE; + my @fortune = `$fortune -s`; + @fortune = map { chop; s/^/ \/ /; $_ } @fortune; + $qp->respond(221, $qp->config('me') . " closing connection.", @fortune); + return DONE; } diff --git a/plugins/random_error b/plugins/random_error index 780ee06..bceb2c5 100644 --- a/plugins/random_error +++ b/plugins/random_error @@ -27,17 +27,17 @@ For use with other plugins, scribble the revised failure rate to =cut sub register { - my ($self, $qp, @args) = @_; + my ($self, $qp, @args) = @_; + + die "Invalid args: '@args'" unless @args < 2; + ($self->{__PACKAGE__ . '_how'}) = $args[0] || 1; - die "Invalid args: '@args'" unless @args < 2; - ($self->{__PACKAGE__.'_how'}) = $args[0] || 1; - } sub NEXT() { DECLINED } sub random_fail { - my $fpct = $_[0]->connection->notes('random_fail_%'); + my $fpct = $_[0]->connection->notes('random_fail_%'); =head1 calculating the probability of failure @@ -52,40 +52,41 @@ or x = 1 - ( (1 - input_number ) ** (1/6) ) =cut - my $successp = 1 - ($fpct / 100); - $_[0]->log(LOGINFO, "to fail, rand(1) must be more than ". ($successp ** (1 / 6)) ); - rand(1) < ($successp ** (1 / 6)) and return NEXT; - rand(5) < 2 and return (DENYSOFT_DISCONNECT, "random failure"); - return (DENYSOFT, "random failure"); + + my $successp = 1 - ($fpct / 100); + $_[0]->log(LOGINFO, + "to fail, rand(1) must be more than " . ($successp**(1 / 6))); + rand(1) < ($successp**(1 / 6)) and return NEXT; + rand(5) < 2 and return (DENYSOFT_DISCONNECT, "random failure"); + return (DENYSOFT, "random failure"); } - sub hook_connect { - $_[0]->connection->notes('random_fail_%', $_[0]->{__PACKAGE__.'_how'}); - goto &random_fail + $_[0]->connection->notes('random_fail_%', $_[0]->{__PACKAGE__ . '_how'}); + goto &random_fail; } sub hook_helo { - goto &random_fail + goto &random_fail; } sub hook_ehlo { - goto &random_fail + goto &random_fail; } sub hook_mail { - goto &random_fail + goto &random_fail; } sub hook_rcpt { - goto &random_fail + goto &random_fail; } sub hook_data { - goto &random_fail + goto &random_fail; } sub hook_data_post { - goto &random_fail + goto &random_fail; } diff --git a/plugins/rcpt_map b/plugins/rcpt_map index e18d168..367fa07 100644 --- a/plugins/rcpt_map +++ b/plugins/rcpt_map @@ -113,17 +113,17 @@ sub register { $self->{_default} or $self->{_default} = [DENY, "No such user."]; - $self->{_file} + $self->{_file} or die "No map file given..."; - $self->{_domain} + $self->{_domain} or die "No domain name given..."; $self->{_domain} = lc $self->{_domain}; - $self->log(LOGDEBUG, - "Using map ".$self->{_file}." for domain ".$self->{_domain}); + $self->log(LOGDEBUG, + "Using map " . $self->{_file} . " for domain " . $self->{_domain}); %map = $self->read_map(1); - die "Empty map file ".$self->{_file} + die "Empty map file " . $self->{_file} unless keys %map; } @@ -132,7 +132,7 @@ sub hook_pre_connection { my ($time) = (stat($self->{_file}))[9] || 0; if ($time > $self->{_time}) { my %temp = $self->read_map(); - keys %temp + keys %temp or return DECLINED; %map = %temp; } @@ -157,14 +157,14 @@ sub read_map { next unless $addr; unless ($code) { - $self->log(LOGERROR, - "No constant in line $line in ".$self->{_file}); + $self->log(LOGERROR, + "No constant in line $line in " . $self->{_file}); next; } $code = Qpsmtpd::Constants::return_code($code); unless (defined $code) { - $self->log(LOGERROR, - "Not a valid constant in line $line in ".$self->{_file}); + $self->log(LOGERROR, + "Not a valid constant in line $line in " . $self->{_file}); next; } $msg or $msg = "No such user."; @@ -184,6 +184,6 @@ sub hook_rcpt { my $rcpt = lc $recipient->user . '@' . lc $recipient->host; return (@{$self->{_default}}) unless exists $map{$rcpt}; - + return @{$map{$rcpt}}; } diff --git a/plugins/rcpt_ok b/plugins/rcpt_ok index ba4ba45..57f64b7 100644 --- a/plugins/rcpt_ok +++ b/plugins/rcpt_ok @@ -28,16 +28,16 @@ use Qpsmtpd::Constants; use Qpsmtpd::DSN; sub hook_rcpt { - my ($self, $transaction, $recipient, %param) = @_; + my ($self, $transaction, $recipient, %param) = @_; - # Allow 'no @' addresses for 'postmaster' and 'abuse' - # qmail-smtpd will do this for all users without a domain, but we'll - # be a bit more picky. Maybe that's a bad idea. - my $host = $self->get_rcpt_host( $recipient ) or return (OK); + # Allow 'no @' addresses for 'postmaster' and 'abuse' + # qmail-smtpd will do this for all users without a domain, but we'll + # be a bit more picky. Maybe that's a bad idea. + my $host = $self->get_rcpt_host($recipient) or return (OK); - return (OK) if $self->is_in_rcpthosts( $host ); - return (OK) if $self->is_in_morercpthosts( $host ); - return (OK) if $self->qp->connection->relay_client; # failsafe + return (OK) if $self->is_in_rcpthosts($host); + return (OK) if $self->is_in_morercpthosts($host); + return (OK) if $self->qp->connection->relay_client; # failsafe # default of relaying_denied is obviously DENY, # we use the default "Relaying denied" message... @@ -45,55 +45,55 @@ sub hook_rcpt { } sub is_in_rcpthosts { - my ( $self, $host ) = @_; + my ($self, $host) = @_; my @rcpt_hosts = ($self->qp->config('me'), $self->qp->config('rcpthosts')); # Check if this recipient host is allowed for my $allowed (@rcpt_hosts) { $allowed =~ s/^\s*(\S+)/$1/; - if ( $host eq lc $allowed ) { - $self->log( LOGINFO, "pass: $host in rcpthosts" ); + if ($host eq lc $allowed) { + $self->log(LOGINFO, "pass: $host in rcpthosts"); return 1; - }; + } - if ( substr($allowed,0,1) eq '.' and $host =~ m/\Q$allowed\E$/i ) { - $self->log( LOGINFO, "pass: $host in rcpthosts as $allowed" ); + if (substr($allowed, 0, 1) eq '.' and $host =~ m/\Q$allowed\E$/i) { + $self->log(LOGINFO, "pass: $host in rcpthosts as $allowed"); return 1; - }; + } } return; -}; +} sub is_in_morercpthosts { - my ( $self, $host ) = @_; + my ($self, $host) = @_; my $more_rcpt_hosts = $self->qp->config('morercpthosts', 'map'); - if ( exists $more_rcpt_hosts->{$host} ) { - $self->log( LOGINFO, "pass: $host found in morercpthosts" ); + if (exists $more_rcpt_hosts->{$host}) { + $self->log(LOGINFO, "pass: $host found in morercpthosts"); return 1; - }; + } - $self->log( LOGINFO, "fail: $host not in morercpthosts" ); + $self->log(LOGINFO, "fail: $host not in morercpthosts"); return; -}; +} sub get_rcpt_host { - my ( $self, $recipient ) = @_; + my ($self, $recipient) = @_; - return if ! $recipient; # Qpsmtpd::Address couldn't parse the recipient + return if !$recipient; # Qpsmtpd::Address couldn't parse the recipient - if ( $recipient->host ) { + if ($recipient->host) { return lc $recipient->host; - }; + } # no host portion exists my $user = $recipient->user or return; - if ( lc $user eq 'postmaster' || lc $user eq 'abuse' ) { + if (lc $user eq 'postmaster' || lc $user eq 'abuse') { return $self->qp->config('me'); - }; + } return; -}; +} diff --git a/plugins/rcpt_regexp b/plugins/rcpt_regexp index 40705b7..41d93a4 100644 --- a/plugins/rcpt_regexp +++ b/plugins/rcpt_regexp @@ -1,4 +1,5 @@ #!perl -w + =head1 NAME rcpt_regexp - check recipients against a list of regular expressions diff --git a/plugins/relay b/plugins/relay index 7cba450..61a2ec5 100644 --- a/plugins/relay +++ b/plugins/relay @@ -105,14 +105,14 @@ use Qpsmtpd::Constants; use Net::IP qw(:PROC); sub register { - my ($self, $qp) = ( shift, shift ); + my ($self, $qp) = (shift, shift); $self->log(LOGERROR, "Bad arguments") if @_ % 2; - $self->{_args} = { @_ }; + $self->{_args} = {@_}; - if ( $self->{_args}{only} ) { + if ($self->{_args}{only}) { $self->register_hook('rcpt', 'relay_only'); - }; -}; + } +} sub is_in_norelayclients { my $self = shift; @@ -121,30 +121,30 @@ sub is_in_norelayclients { my $ip = $self->qp->connection->remote_ip; - while ( $ip ) { - if ( exists $no_relay_clients{$ip} ) { + while ($ip) { + if (exists $no_relay_clients{$ip}) { $self->log(LOGINFO, "$ip in norelayclients"); return 1; } - $ip =~ s/(\d|\w)+(:|\.)?$// or last; # strip off another octet - }; + $ip =~ s/(\d|\w)+(:|\.)?$// or last; # strip off another octet + } $self->log(LOGDEBUG, "no match in norelayclients"); return; -}; +} sub populate_relayclients { my $self = shift; - foreach ( $self->qp->config('relayclients') ) { + foreach ($self->qp->config('relayclients')) { my ($network, $netmask) = ip_splitprefix($_); - if ( $netmask ) { - push @{ $self->{_cidr_blocks} }, $_; + if ($netmask) { + push @{$self->{_cidr_blocks}}, $_; next; } - $self->{_octets}{$_} = 1; # no prefix, split + $self->{_octets}{$_} = 1; # no prefix, split } -}; +} sub is_in_cidr_block { my $self = shift; @@ -154,20 +154,20 @@ sub is_in_cidr_block { return; }; my $cversion = ip_get_version($ip); - for ( @{ $self->{_cidr_blocks} } ) { - my ($network, $mask) = ip_splitprefix($_); # split IP & CIDR range - my $rversion = ip_get_version($network); # get IP version (4 vs 6) - my ($begin, $end) = ip_normalize($_, $rversion); # get pool start/end + for (@{$self->{_cidr_blocks}}) { + my ($network, $mask) = ip_splitprefix($_); # split IP & CIDR range + my $rversion = ip_get_version($network); # get IP version (4 vs 6) + my ($begin, $end) = ip_normalize($_, $rversion); # get pool start/end -# expand the client address (zero pad it) before converting to binary + # expand the client address (zero pad it) before converting to binary my $bin_ip = ip_iptobin(ip_expand_address($ip, $cversion), $cversion) - or next; + or next; - next if ! $begin || ! $end; # probably not a netmask entry + next if !$begin || !$end; # probably not a netmask entry - if ( ip_bincomp($bin_ip, 'gt', ip_iptobin($begin, $rversion)) - && ip_bincomp($bin_ip, 'lt', ip_iptobin($end, $rversion)) - ) { + if ( ip_bincomp($bin_ip, 'gt', ip_iptobin($begin, $rversion)) + && ip_bincomp($bin_ip, 'lt', ip_iptobin($end, $rversion))) + { $self->log(LOGINFO, "pass, cidr match ($ip)"); return 1; } @@ -175,75 +175,75 @@ sub is_in_cidr_block { $self->log(LOGDEBUG, "no cidr match"); return; -}; +} sub is_octet_match { my $self = shift; my $ip = $self->qp->connection->remote_ip; - if ( $ip eq '::1' ) { + if ($ip eq '::1') { $self->log(LOGINFO, "pass, octet matched localhost ($ip)"); return 1; - }; + } my $more_relay_clients = $self->qp->config('morerelayclients', 'map'); my $ipv6 = $ip =~ /:/ ? 1 : 0; - if ( $ipv6 && $ip =~ /::/ ) { # IPv6 compressed notation - $ip = Net::IP::ip_expand_address($ip,6); - }; + if ($ipv6 && $ip =~ /::/) { # IPv6 compressed notation + $ip = Net::IP::ip_expand_address($ip, 6); + } while ($ip) { - if ( exists $self->{_octets}{$ip} ) { + if (exists $self->{_octets}{$ip}) { $self->log(LOGINFO, "pass, octet match in relayclients ($ip)"); return 1; - }; + } - if ( exists $more_relay_clients->{$ip} ) { + if (exists $more_relay_clients->{$ip}) { $self->log(LOGINFO, "pass, octet match in morerelayclients ($ip)"); return 1; - }; + } # added IPv6 support (Michael Holzt - 2012-11-14) - if ( $ipv6 ) { - $ip =~ s/[0-9a-f]:?$//; # strip off another nibble + if ($ipv6) { + $ip =~ s/[0-9a-f]:?$//; # strip off another nibble chop $ip if ':' eq substr($ip, -1, 1); } else { - $ip =~ s/\d+\.?$// or last; # strip off another 8 bits + $ip =~ s/\d+\.?$// or last; # strip off another 8 bits } } - $self->log(LOGDEBUG, "no octet match" ); + $self->log(LOGDEBUG, "no octet match"); return; } sub hook_connect { my ($self, $transaction) = @_; - if ( $self->is_in_norelayclients() ) { + if ($self->is_in_norelayclients()) { $self->qp->connection->relay_client(0); delete $ENV{RELAYCLIENT}; $self->log(LOGINFO, "fail, disabled by norelayclients"); return (DECLINED); } - if ( $ENV{RELAYCLIENT} ) { + if ($ENV{RELAYCLIENT}) { $self->qp->connection->relay_client(1); $self->log(LOGINFO, "pass, enabled by env"); return (DECLINED); - }; + } $self->populate_relayclients(); -# 95586 (connect) relay: pass, octet match in relayclients (127.0.0.) + # 95586 (connect) relay: pass, octet match in relayclients (127.0.0.) - if ( $self->is_in_cidr_block() || $self->is_octet_match() ) { + if ($self->is_in_cidr_block() || $self->is_octet_match()) { $self->qp->connection->relay_client(1); return (DECLINED); - }; + } $self->log(LOGINFO, "skip, no match"); return (DECLINED); @@ -251,9 +251,9 @@ sub hook_connect { sub relay_only { my $self = shift; - if ( $self->qp->connection->relay_client ) { + if ($self->qp->connection->relay_client) { return (OK); - }; + } return (DENY); } diff --git a/plugins/resolvable_fromhost b/plugins/resolvable_fromhost index 6d4ed0a..aa881a3 100644 --- a/plugins/resolvable_fromhost +++ b/plugins/resolvable_fromhost @@ -86,9 +86,9 @@ sub register { foreach (keys %args) { $self->{_args}->{$_} = $args{$_}; } - if ( ! defined $self->{_args}{reject} ) { + if (!defined $self->{_args}{reject}) { $self->{_args}{reject} = 1; - }; + } $self->{_args}{reject_type} ||= 'soft'; } @@ -97,82 +97,86 @@ sub hook_mail { return DECLINED if $self->is_immune(); - if ( $sender eq '<>' ) { + if ($sender eq '<>') { $transaction->notes('resolvable_fromhost', 'null'); $self->log(LOGINFO, "pass, null sender"); return DECLINED; - }; + } $self->populate_invalid_networks(); my $resolved = $self->check_dns($sender->host, $transaction); - return DECLINED if $resolved; # success, no need to continue - #return DECLINED if $sender->host; # reject later + return DECLINED if $resolved; # success, no need to continue + #return DECLINED if $sender->host; # reject later my $result = $transaction->notes('resolvable_fromhost') or do { - if ( $self->{_args}{reject} ) {; - $self->log(LOGINFO, 'fail, missing result' ); - return Qpsmtpd::DSN->temp_resolver_failed( $self->get_reject_type(), '' ); - }; - $self->log(LOGINFO, 'fail, missing result, reject disabled' ); + if ($self->{_args}{reject}) { + ; + $self->log(LOGINFO, 'fail, missing result'); + return Qpsmtpd::DSN->temp_resolver_failed($self->get_reject_type(), + ''); + } + $self->log(LOGINFO, 'fail, missing result, reject disabled'); return DECLINED; }; - return DECLINED if $result =~ /^(?:a|ip|mx)$/; # success - return DECLINED if $result =~ /^(?:whitelist|null|naughty)$/; # immunity + return DECLINED if $result =~ /^(?:a|ip|mx)$/; # success + return DECLINED if $result =~ /^(?:whitelist|null|naughty)$/; # immunity - $self->adjust_karma( -1 ); + $self->adjust_karma(-1); - if ( ! $self->{_args}{reject} ) {; - $self->log(LOGINFO, "fail, reject disabled, $result" ); + if (!$self->{_args}{reject}) { + ; + $self->log(LOGINFO, "fail, reject disabled, $result"); return DECLINED; - }; + } - $self->log(LOGINFO, "fail, $result" ); # log error - return Qpsmtpd::DSN->addr_bad_from_system( $self->get_reject_type(), - "FQDN required in the envelope sender"); + $self->log(LOGINFO, "fail, $result"); # log error + return + Qpsmtpd::DSN->addr_bad_from_system($self->get_reject_type(), + "FQDN required in the envelope sender"); } sub check_dns { my ($self, $host, $transaction) = @_; # we can't even parse a hostname out of the address - if ( ! $host ) { + if (!$host) { $transaction->notes('resolvable_fromhost', 'unparsable host'); - $self->adjust_karma( -1 ); + $self->adjust_karma(-1); return; - }; + } $transaction->notes('resolvable_fromhost_host', $host); - if ( $host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/ ) { + if ($host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/) { $self->log(LOGINFO, "skip, $host is an IP"); $transaction->notes('resolvable_fromhost', 'ip'); - $self->adjust_karma( -1 ); + $self->adjust_karma(-1); return 1; - }; + } my $res = new Net::DNS::Resolver(dnsrch => 0); $res->tcp_timeout(30); $res->udp_timeout(30); - my $has_mx = $self->get_and_validate_mx( $res, $host, $transaction ); - return 1 if $has_mx == 1; # success, has MX! - return if $has_mx == -1; # has invalid MX records - # at this point, no MX for fh is resolvable + my $has_mx = $self->get_and_validate_mx($res, $host, $transaction); + return 1 if $has_mx == 1; # success, has MX! + return if $has_mx == -1; # has invalid MX records + # at this point, no MX for fh is resolvable - my @host_answers = $self->get_host_records( $res, $host, $transaction ); + my @host_answers = $self->get_host_records($res, $host, $transaction); foreach my $rr (@host_answers) { - if ( $rr->type eq 'A' || $rr->type eq 'AAAA' ) { + if ($rr->type eq 'A' || $rr->type eq 'AAAA') { $self->log(LOGINFO, "pass, found A for $host"); $transaction->notes('resolvable_fromhost', 'a'); return $self->ip_is_valid($rr->address); - }; - if ( $rr->type eq 'MX' ) { + } + if ($rr->type eq 'MX') { $self->log(LOGINFO, "pass, found MX for $host"); $transaction->notes('resolvable_fromhost', 'mx'); return $self->mx_address_resolves($rr->exchange, $host); - }; + } } return; } @@ -193,33 +197,34 @@ sub ip_is_valid { } sub get_and_validate_mx { - my ($self, $res, $host, $transaction ) = @_; + my ($self, $res, $host, $transaction) = @_; my @mx = mx($res, $host); - if ( ! scalar @mx ) { # no mx records - $self->adjust_karma( -1 ); + if (!scalar @mx) { # no mx records + $self->adjust_karma(-1); $self->log(LOGINFO, "$host has no MX"); return 0; - }; + } foreach my $mx (@mx) { + # if any MX is valid, then we consider the domain resolvable - if ( $self->mx_address_resolves($mx->exchange, $host) ) { + if ($self->mx_address_resolves($mx->exchange, $host)) { $self->log(LOGINFO, "pass, $host has MX at " . $mx->exchange); $transaction->notes('resolvable_fromhost', 'mx'); return 1; - }; + } } # if there are MX records, and we got here, none are valid #$self->log(LOGINFO, "fail, invalid MX for $host"); $transaction->notes('resolvable_fromhost', "invalid MX for $host"); - $self->adjust_karma( -1 ); + $self->adjust_karma(-1); return -1; -}; +} sub get_host_records { - my ($self, $res, $host, $transaction ) = @_; + my ($self, $res, $host, $transaction) = @_; my @answers; my $query = $res->search($host); @@ -239,15 +244,15 @@ sub get_host_records { } } - if ( ! scalar @answers) { - if ( $res->errorstring ne 'NXDOMAIN' ) { + if (!scalar @answers) { + if ($res->errorstring ne 'NXDOMAIN') { $self->log(LOGWARN, "fail, query for $host, ", $res->errorstring); - }; + } return; - }; + } return @answers; -}; +} sub mx_address_resolves { my ($self, $name, $fromhost) = @_; @@ -271,15 +276,16 @@ sub mx_address_resolves { } } } - if (! @mx_answers) { - if ( $res->errorstring eq 'NXDOMAIN' ) { - $self->log(LOGWARN, "fail, query for $fromhost, ", $res->errorstring); - }; + if (!@mx_answers) { + if ($res->errorstring eq 'NXDOMAIN') { + $self->log(LOGWARN, "fail, query for $fromhost, ", + $res->errorstring); + } return; } foreach my $rr (@mx_answers) { - next if ( $rr->type ne 'A' && $rr->type ne 'AAAA' ); + next if ($rr->type ne 'A' && $rr->type ne 'AAAA'); return $self->ip_is_valid($rr->address); } @@ -290,11 +296,11 @@ sub populate_invalid_networks { my $self = shift; foreach my $i ($self->qp->config("invalid_resolvable_fromhost")) { - $i =~ s/^\s*//; # trim leading spaces - $i =~ s/\s*$//; # trim trailing spaces + $i =~ s/^\s*//; # trim leading spaces + $i =~ s/\s*$//; # trim trailing spaces if ($i =~ m#^((\d{1,3}\.){3}\d{1,3})/(\d\d?)#) { $invalid{$1} = $3; } } -}; +} diff --git a/plugins/rhsbl b/plugins/rhsbl index eea19f5..4682c83 100644 --- a/plugins/rhsbl +++ b/plugins/rhsbl @@ -31,29 +31,29 @@ use warnings; use Qpsmtpd::Constants; sub register { - my ($self, $qp ) = (shift, shift); + my ($self, $qp) = (shift, shift); - if ( @_ == 1 ) { - $self->legacy_positional_args( @_ ); + if (@_ == 1) { + $self->legacy_positional_args(@_); } else { - $self->{_args} = { @_ }; - }; + $self->{_args} = {@_}; + } - $self->{_args}{reject} = 1 if ! defined $self->{_args}{reject}; + $self->{_args}{reject} = 1 if !defined $self->{_args}{reject}; $self->{_args}{reject_type} ||= 'perm'; } sub legacy_positional_args { my ($self, $denial) = @_; - if ( defined $denial && $denial =~ /^disconnect$/i ) { + if (defined $denial && $denial =~ /^disconnect$/i) { $self->{_args}{reject_type} = 'disconnect'; } else { $self->{_args}{reject_type} = 'perm'; } -}; +} sub hook_mail { my ($self, $transaction, $sender, %param) = @_; @@ -63,7 +63,7 @@ sub hook_mail { if ($sender->format eq '<>') { $self->log(LOGINFO, 'pass, null sender'); return DECLINED; - }; + } my %rhsbl_zones = $self->populate_zones() or return DECLINED; @@ -73,47 +73,53 @@ sub hook_mail { for my $host (@hosts) { for my $rhsbl (keys %rhsbl_zones) { my $query; -# fix to find TXT records, if the rhsbl_zones line doesn't have second field + + # fix to find TXT records, if the rhsbl_zones line doesn't have second field if (defined($rhsbl_zones{$rhsbl})) { $self->log(LOGDEBUG, "Checking $host.$rhsbl for A record"); $query = $res->query("$host.$rhsbl"); - } else { + } + else { $self->log(LOGDEBUG, "Checking $host.$rhsbl for TXT record"); $query = $res->query("$host.$rhsbl", 'TXT'); } - if ( ! $query) { - if ( $res->errorstring ne 'NXDOMAIN' ) { + if (!$query) { + if ($res->errorstring ne 'NXDOMAIN') { $self->log(LOGCRIT, "query failed: ", $res->errorstring); - }; + } next; - }; + } my $result; foreach my $rr ($query->answer) { - $self->log(LOGDEBUG, 'got an ' . $rr->type . ' record ' . $rr->name); + $self->log(LOGDEBUG, + 'got an ' . $rr->type . ' record ' . $rr->name); if ($rr->type eq 'A') { - $self->log(LOGDEBUG, "A record found for $result with IP " . $rr->address); + $self->log(LOGDEBUG, + "A record found for $result with IP " . $rr->address); $result = $rr->name; } elsif ($rr->type eq 'TXT') { $result = $rr->txtdata; $self->log(LOGDEBUG, "TXT record found: " . $rr->txtdata); - }; + } - next if ! $result; + next if !$result; $self->log(LOGINFO, "fail, $result"); - if ( $transaction->sender ) { + if ($transaction->sender) { my $host = $transaction->sender->host; - if ($result =~ /^$host\./ ) { - return $self->get_reject( "Mail from $host rejected because it $result" ); - }; - }; + if ($result =~ /^$host\./) { + return $self->get_reject( + "Mail from $host rejected because it $result"); + } + } my $hello = $self->qp->connection->hello_host; - return $self->get_reject( "Mail from HELO $hello rejected because it $result" ); + return $self->get_reject( + "Mail from HELO $hello rejected because it $result"); } } } @@ -125,15 +131,14 @@ sub hook_mail { sub populate_zones { my $self = shift; - my %rhsbl_zones - = map { (split /\s+/, $_, 2)[0,1] } - $self->qp->config('rhsbl_zones'); + my %rhsbl_zones = + map { (split /\s+/, $_, 2)[0, 1] } $self->qp->config('rhsbl_zones'); - if ( ! keys %rhsbl_zones ) { + if (!keys %rhsbl_zones) { $self->log(LOGINFO, 'pass, no zones'); return; - }; + } return %rhsbl_zones; -}; +} diff --git a/plugins/sender_permitted_from b/plugins/sender_permitted_from index 1978f91..e9a1f9e 100644 --- a/plugins/sender_permitted_from +++ b/plugins/sender_permitted_from @@ -68,19 +68,19 @@ use Qpsmtpd::Constants; sub register { my ($self, $qp, %args) = @_; eval 'use Mail::SPF'; - if ( $@ ) { + if ($@) { warn "skip: plugin disabled, is Mail::SPF installed?\n"; $self->log(LOGERROR, "skip: plugin disabled, is Mail::SPF installed?"); return; - }; - $self->{_args} = { %args }; - if ( $self->{_args}{spf_deny} ) { + } + $self->{_args} = {%args}; + if ($self->{_args}{spf_deny}) { $self->{_args}{reject} = 3 if $self->{_args}{spf_deny} == 1; $self->{_args}{reject} = 4 if $self->{_args}{spf_deny} == 2; - }; - if ( ! $self->{_args}{reject} && $self->qp->config('spfbehavior') ) { + } + if (!$self->{_args}{reject} && $self->qp->config('spfbehavior')) { $self->{_args}{reject} = $self->qp->config('spfbehavior'); - }; + } $self->register_hook('mail', 'mail_handler'); $self->register_hook('data_post', 'data_post_handler'); } @@ -91,28 +91,29 @@ sub mail_handler { return (DECLINED) if $self->is_immune(); my $format = $sender->format; - if ( $format eq '<>' || ! $sender->host || ! $sender->user ) { - $self->log( LOGINFO, "skip, null sender" ); + if ($format eq '<>' || !$sender->host || !$sender->user) { + $self->log(LOGINFO, "skip, null sender"); return (DECLINED, "SPF - null sender"); - }; + } - if ( $self->qp->connection->relay_client ) { - $self->log( LOGINFO, "skip, relay_client" ); + if ($self->qp->connection->relay_client) { + $self->log(LOGINFO, "skip, relay_client"); return (DECLINED, "SPF - relaying permitted"); - }; + } - if ( ! $self->{_args}{reject} ) { - $self->log( LOGINFO, "skip, reject disabled" ); + if (!$self->{_args}{reject}) { + $self->log(LOGINFO, "skip, reject disabled"); return (DECLINED); - }; + } - my $client_ip = $self->qp->connection->remote_ip; - my $from = $sender->user . '@' . lc($sender->host); - my $helo = $self->qp->connection->hello_host; - my $scope = $from ? 'mfrom' : 'helo'; - my %req_params = ( versions => [1, 2], # optional - scope => $scope, - ip_address => $client_ip, + my $client_ip = $self->qp->connection->remote_ip; + my $from = $sender->user . '@' . lc($sender->host); + my $helo = $self->qp->connection->hello_host; + my $scope = $from ? 'mfrom' : 'helo'; + my %req_params = ( + versions => [1, 2], # optional + scope => $scope, + ip_address => $client_ip, ); if ($scope =~ /^mfrom|pra$/) { @@ -127,7 +128,7 @@ sub mail_handler { my $spf_server = Mail::SPF::Server->new(); my $request = Mail::SPF::Request->new(%req_params); my $result = $spf_server->process($request) or do { - $self->log( LOGINFO, "fail, no result" ); + $self->log(LOGINFO, "fail, no result"); return DECLINED; }; @@ -137,49 +138,49 @@ sub mail_handler { my $why = $result->local_explanation; my $reject = $self->{_args}{reject}; - if ( ! $code ) { - $self->log( LOGINFO, "fail, no response" ); + if (!$code) { + $self->log(LOGINFO, "fail, no response"); return (DENYSOFT, "SPF - no response") if $reject >= 2; return (DECLINED, "SPF - no response"); - }; + } - if ( ! $reject ) { - $self->log( LOGINFO, "fail, no reject policy ($code: $why)" ); - return (DECLINED, "SPF - $code: $why") - }; + if (!$reject) { + $self->log(LOGINFO, "fail, no reject policy ($code: $why)"); + return (DECLINED, "SPF - $code: $why"); + } -# SPF result codes: pass fail softfail neutral none error permerror temperror + # SPF result codes: pass fail softfail neutral none error permerror temperror return $self->handle_code_none($reject, $why) if $code eq 'none'; - if ( $code eq 'fail' ) { - $self->adjust_karma( -1 ); + if ($code eq 'fail') { + $self->adjust_karma(-1); return $self->handle_code_fail($reject, $why); } - elsif ( $code eq 'softfail' ) { - $self->adjust_karma( -1 ); + elsif ($code eq 'softfail') { + $self->adjust_karma(-1); return $self->handle_code_softfail($reject, $why); } - elsif ( $code eq 'pass' ) { - $self->adjust_karma( 1 ); + elsif ($code eq 'pass') { + $self->adjust_karma(1); $transaction->notes('spf_pass_host', lc $sender->host); - $self->log(LOGINFO, "pass, $code: $why" ); + $self->log(LOGINFO, "pass, $code: $why"); return (DECLINED); } - elsif ( $code eq 'neutral' ) { - $self->log(LOGINFO, "fail, $code, $why" ); + elsif ($code eq 'neutral') { + $self->log(LOGINFO, "fail, $code, $why"); return (DENY, "SPF - $code: $why") if $reject >= 5; } - elsif ( $code eq 'error' ) { - $self->log(LOGINFO, "fail, $code, $why" ); - return (DENY, "SPF - $code: $why") if $reject >= 6; + elsif ($code eq 'error') { + $self->log(LOGINFO, "fail, $code, $why"); + return (DENY, "SPF - $code: $why") if $reject >= 6; return (DENYSOFT, "SPF - $code: $why") if $reject > 3; } - elsif ( $code eq 'permerror' ) { - $self->log(LOGINFO, "fail, $code, $why" ); - return (DENY, "SPF - $code: $why") if $reject >= 6; + elsif ($code eq 'permerror') { + $self->log(LOGINFO, "fail, $code, $why"); + return (DENY, "SPF - $code: $why") if $reject >= 6; return (DENYSOFT, "SPF - $code: $why") if $reject > 3; } - elsif ( $code eq 'temperror' ) { - $self->log(LOGINFO, "fail, $code, $why" ); + elsif ($code eq 'temperror') { + $self->log(LOGINFO, "fail, $code, $why"); return (DENYSOFT, "SPF - $code: $why") if $reject >= 2; } @@ -188,60 +189,61 @@ sub mail_handler { } sub handle_code_none { - my ($self, $reject, $why ) = @_; + my ($self, $reject, $why) = @_; - if ( $reject >= 6 ) { - $self->log(LOGINFO, "fail, none, $why" ); + if ($reject >= 6) { + $self->log(LOGINFO, "fail, none, $why"); return (DENY, "SPF - none: $why"); - }; + } - $self->log(LOGINFO, "pass, none, $why" ); + $self->log(LOGINFO, "pass, none, $why"); return DECLINED; -}; +} sub handle_code_fail { - my ($self, $reject, $why ) = @_; + my ($self, $reject, $why) = @_; - if ( $reject >= 2 ) { - $self->log(LOGINFO, "fail, $why" ); + if ($reject >= 2) { + $self->log(LOGINFO, "fail, $why"); return (DENY, "SPF - forgery: $why") if $reject >= 3; - return (DENYSOFT, "SPF - fail: $why") - }; + return (DENYSOFT, "SPF - fail: $why"); + } - $self->log(LOGINFO, "pass, fail tolerated, $why" ); + $self->log(LOGINFO, "pass, fail tolerated, $why"); return DECLINED; -}; +} sub handle_code_softfail { - my ($self, $reject, $why ) = @_; + my ($self, $reject, $why) = @_; - if ( $reject >= 3 ) { - $self->log(LOGINFO, "fail, soft, $why" ); - return (DENY, "SPF - fail: $why") if $reject >= 4; + if ($reject >= 3) { + $self->log(LOGINFO, "fail, soft, $why"); + return (DENY, "SPF - fail: $why") if $reject >= 4; return (DENYSOFT, "SPF - fail: $why") if $reject >= 3; - }; + } - $self->log(LOGINFO, "pass, softfail tolerated, $why" ); + $self->log(LOGINFO, "pass, softfail tolerated, $why"); return DECLINED; -}; +} sub data_post_handler { my ($self, $transaction) = @_; my $result = $transaction->notes('spfquery') or return DECLINED; -# if we skipped processing in mail_handler, we should skip here too + # if we skipped processing in mail_handler, we should skip here too return (DECLINED) if $self->is_immune(); $self->log(LOGDEBUG, "result was $result->code"); - if ( ! $transaction->header ) { + if (!$transaction->header) { $self->log(LOGERROR, "missing headers!"); return DECLINED; - }; + } $transaction->header->add('Received-SPF', $result->received_spf_header, 0); -# consider also adding SPF status to Authentication-Results header + + # consider also adding SPF status to Authentication-Results header return DECLINED; } @@ -249,20 +251,20 @@ sub data_post_handler { sub is_special_recipient { my ($self, $rcpt) = @_; - if ( ! $rcpt ) { + if (!$rcpt) { $self->log(LOGINFO, "skip: missing recipient"); return 1; - }; - if ( ! $rcpt->user ) { + } + if (!$rcpt->user) { $self->log(LOGINFO, "skip: missing user"); return 1; - }; + } # special addresses don't get SPF-tested. - if ( $rcpt->user =~ /^(?:postmaster|abuse|mailer-daemon|root)$/i ) { - $self->log(LOGINFO, "skip: special user (".$rcpt->user.")"); + if ($rcpt->user =~ /^(?:postmaster|abuse|mailer-daemon|root)$/i) { + $self->log(LOGINFO, "skip: special user (" . $rcpt->user . ")"); return 1; - }; + } return; -}; +} diff --git a/plugins/spamassassin b/plugins/spamassassin index 6d0a559..7d7f734 100644 --- a/plugins/spamassassin +++ b/plugins/spamassassin @@ -153,17 +153,20 @@ use IO::Handle; sub register { my ($self, $qp, %args) = @_; - $self->log(LOGERROR, "Bad parameters for the spamassassin plugin") if @_ % 2; + $self->log(LOGERROR, "Bad parameters for the spamassassin plugin") + if @_ % 2; - $self->{_args} = { %args }; + $self->{_args} = {%args}; # backwards compatibility with previous config syntax - if ( ! defined $self->{_args}{reject} && defined $self->{_args}{reject_threshold} ) { + if ( !defined $self->{_args}{reject} + && defined $self->{_args}{reject_threshold}) + { $self->{_args}{reject} = $self->{_args}{reject_threshold}; - }; - if ( ! defined $self->{_args}{reject_type} ) { + } + if (!defined $self->{_args}{reject_type}) { $self->{_args}{reject_type} = 'perm'; - }; + } $self->register_hook('data_post', 'data_post_handler'); } @@ -173,24 +176,25 @@ sub data_post_handler { return (DECLINED) if $self->is_immune(); - if ( $transaction->data_size > 500_000 ) { - $self->log(LOGINFO, "skip: too large (".$transaction->data_size.")"); + if ($transaction->data_size > 500_000) { + $self->log(LOGINFO, + "skip: too large (" . $transaction->data_size . ")"); return (DECLINED); - }; + } my $SPAMD = $self->connect_to_spamd() or return (DECLINED); - my $username = $self->select_spamd_username( $transaction ); + my $username = $self->select_spamd_username($transaction); my $message = $self->assemble_message($transaction); my $length = length $message; - $self->print_to_spamd( $SPAMD, $message, $length, $username ); - shutdown($SPAMD, 1); # close our side of the socket (tell spamd we're done) - my $headers = $self->parse_spamd_response( $SPAMD ) or return (DECLINED); + $self->print_to_spamd($SPAMD, $message, $length, $username); + shutdown($SPAMD, 1); # close our side of the socket (tell spamd we're done) + my $headers = $self->parse_spamd_response($SPAMD) or return (DECLINED); - $self->insert_spam_headers( $transaction, $headers, $username ); - $self->munge_subject( $transaction ); - return $self->reject( $transaction ); -}; + $self->insert_spam_headers($transaction, $headers, $username); + $self->munge_subject($transaction); + return $self->reject($transaction); +} sub select_spamd_username { my ($self, $transaction) = @_; @@ -198,40 +202,41 @@ sub select_spamd_username { my $username = $self->{_args}{spamd_user} || getpwuid($>); my $recipient_count = scalar $transaction->recipients; - if ( $recipient_count > 1 ) { + if ($recipient_count > 1) { $self->log(LOGDEBUG, "Message has $recipient_count recipients"); return $username; - }; + } - if ( $username eq 'vpopmail' ) { -# use the recipients email address as username. This enables per-user SA prefs + if ($username eq 'vpopmail') { + + # use the recipients email address as username. This enables per-user SA prefs $username = ($transaction->recipients)[0]->address; } else { $self->log(LOGDEBUG, "skipping per-user SA prefs"); - }; + } return $username; -}; +} sub parse_spamd_response { - my ( $self, $SPAMD ) = @_; + my ($self, $SPAMD) = @_; - my $line0 = <$SPAMD>; # get the first protocol line - if ( $line0 !~ /EX_OK/ ) { - $self->log(LOGERROR, "invalid response from spamd: $line0"); - return; - }; + my $line0 = <$SPAMD>; # get the first protocol line + if ($line0 !~ /EX_OK/) { + $self->log(LOGERROR, "invalid response from spamd: $line0"); + return; + } my (%new_headers, $last_header); while (<$SPAMD>) { s/[\r\n]//g; - if ( m/^(X-Spam-.*?): (.*)?/ ) { + if (m/^(X-Spam-.*?): (.*)?/) { $new_headers{$1} = $2 || ''; $last_header = $1; next; } - if ( $last_header && m/^(\s+.*)/ ) { # a folded line, append to last + if ($last_header && m/^(\s+.*)/) { # a folded line, append to last $new_headers{$last_header} .= CRLF . "\t" . $1; next; } @@ -241,37 +246,41 @@ sub parse_spamd_response { $self->log(LOGDEBUG, "finished reading from spamd"); return scalar keys %new_headers ? \%new_headers : undef; -}; +} sub insert_spam_headers { - my ( $self, $transaction, $new_headers, $username ) = @_; + my ($self, $transaction, $new_headers, $username) = @_; - if ( $self->{_args}{headers} && $self->{_args}{headers} eq 'none' ) { - my $r = $self->parse_spam_header( $new_headers->{'X-Spam-Status'} ); + if ($self->{_args}{headers} && $self->{_args}{headers} eq 'none') { + my $r = $self->parse_spam_header($new_headers->{'X-Spam-Status'}); $transaction->notes('spamassassin', $r); return; - }; + } my $recipient_count = scalar $transaction->recipients; - $self->_cleanup_spam_header($transaction, 'X-Spam-User'); # always clean up - if ( $recipient_count > 1 ) { # add for multiple recipients - $transaction->header->add('X-Spam-User', $username . ", $recipient_count recipients", 0); - }; + $self->_cleanup_spam_header($transaction, 'X-Spam-User'); # always clean up + if ($recipient_count > 1) { # add for multiple recipients + $transaction->header->add('X-Spam-User', + $username . ", $recipient_count recipients", + 0); + } - foreach my $name ( keys %$new_headers ) { - next if $name eq 'X-Spam-Prev-Subject'; # might exist if SA rewrote subject - if ( $name eq 'X-Spam-Report' ) { - next; # Mail::Header mangles this prefolded header -# $self->log(LOGDEBUG, $new_headers->{$name} ); - }; - if ( $name eq 'X-Spam-Status' ) { - $self->parse_spam_header( $new_headers->{$name} ); - }; - $new_headers->{$name} =~ s/\015//; # hack for outlook + foreach my $name (keys %$new_headers) { + next + if $name eq 'X-Spam-Prev-Subject'; # might exist if SA rewrote subject + if ($name eq 'X-Spam-Report') { + next; # Mail::Header mangles this prefolded header + + # $self->log(LOGDEBUG, $new_headers->{$name} ); + } + if ($name eq 'X-Spam-Status') { + $self->parse_spam_header($new_headers->{$name}); + } + $new_headers->{$name} =~ s/\015//; # hack for outlook $self->_cleanup_spam_header($transaction, $name); $transaction->header->add($name, $new_headers->{$name}, 0); - }; + } } sub assemble_message { @@ -279,39 +288,40 @@ sub assemble_message { $transaction->body_resetpos; - my $message = "X-Envelope-From: " - . $transaction->sender->format . "\n" - . $transaction->header->as_string . "\n\n"; + my $message = + "X-Envelope-From: " + . $transaction->sender->format . "\n" + . $transaction->header->as_string . "\n\n"; - while (my $line = $transaction->body_getline) { $message .= $line; }; + while (my $line = $transaction->body_getline) { $message .= $line; } - $message = join(CRLF, split/\n/, $message); + $message = join(CRLF, split /\n/, $message); return $message . CRLF; -}; +} sub connect_to_spamd { - my $self = shift; + my $self = shift; my $socket = $self->{_args}{spamd_socket}; my $SPAMD; - if ( $socket && $socket =~ /\// ) { # file path - $SPAMD = $self->connect_to_spamd_socket( $socket ); + if ($socket && $socket =~ /\//) { # file path + $SPAMD = $self->connect_to_spamd_socket($socket); } else { - $SPAMD = $self->connect_to_spamd_tcpip( $socket ); - }; + $SPAMD = $self->connect_to_spamd_tcpip($socket); + } - return if ! $SPAMD; + return if !$SPAMD; $SPAMD->autoflush(1); return $SPAMD; -}; +} sub connect_to_spamd_socket { - my ( $self, $socket ) = @_; + my ($self, $socket) = @_; - if ( ! $socket || $socket !~ /^([\w\/.-]+)$/ ) { # Unix Domain Socket + if (!$socket || $socket !~ /^([\w\/.-]+)$/) { # Unix Domain Socket $self->log(LOGERROR, "not a valid path"); return; - }; + } # Sanitize for use with taint mode $socket =~ /^([\w\/.-]+)$/; @@ -321,7 +331,7 @@ sub connect_to_spamd_socket { $self->log(LOGERROR, "Could not open socket: $!"); return; }; - my $paddr = sockaddr_un( $socket ); + my $paddr = sockaddr_un($socket); connect($SPAMD, $paddr) or do { $self->log(LOGERROR, "Could not connect to spamd socket: $!"); @@ -330,23 +340,23 @@ sub connect_to_spamd_socket { $self->log(LOGDEBUG, "connected to spamd"); return $SPAMD; -}; +} sub connect_to_spamd_tcpip { - my ( $self, $socket ) = @_; + my ($self, $socket) = @_; - my $remote = 'localhost'; - my $port = 783; + my $remote = 'localhost'; + my $port = 783; if (defined $socket && $socket =~ /^([\w.-]+):(\d+)$/) { - $remote = $1; - $port = $2; + $remote = $1; + $port = $2; } - if ($port =~ /\D/) { $port = getservbyname($port, 'tcp') }; - if ( ! $port ) { + if ($port =~ /\D/) { $port = getservbyname($port, 'tcp') } + if (!$port) { $self->log(LOGERROR, "No spamd port, check your spamd_socket config."); return; - }; + } my $iaddr = inet_aton($remote) or do { $self->log(LOGERROR, "Could not resolve host: $remote"); return; @@ -361,24 +371,25 @@ sub connect_to_spamd_tcpip { connect($SPAMD, $paddr) or do { $self->log(LOGERROR, "Could not connect to spamd: $!"); - return; + return; }; $self->log(LOGDEBUG, "connected to spamd"); return $SPAMD; -}; +} sub print_to_spamd { - my ( $self, $SPAMD, $message, $length, $username ) = @_; + my ($self, $SPAMD, $message, $length, $username) = @_; print $SPAMD "HEADERS SPAMC/1.4" . CRLF; print $SPAMD "Content-length: $length" . CRLF; print $SPAMD "User: $username" . CRLF; print $SPAMD CRLF; - print $SPAMD $message or $self->log(LOGWARN, "Could not print to spamd: $!"); + print $SPAMD $message + or $self->log(LOGWARN, "Could not print to spamd: $!"); $self->log(LOGDEBUG, "check_spam: finished sending to spamd"); -}; +} sub reject { my ($self, $transaction) = @_; @@ -387,32 +398,32 @@ sub reject { $self->log(LOGNOTICE, "error, no results"); return DECLINED; }; - my $score = $sa_results->{score}; - if ( ! defined $score ) { + my $score = $sa_results->{score}; + if (!defined $score) { $self->log(LOGERROR, "error, error getting score"); return DECLINED; - }; + } my $ham_or_spam = $sa_results->{is_spam} eq 'Yes' ? 'Spam' : 'Ham'; - if ( $ham_or_spam eq 'Spam' ) { - $self->adjust_karma( -1 ); - }; + if ($ham_or_spam eq 'Spam') { + $self->adjust_karma(-1); + } my $status = "$ham_or_spam, $score"; - my $learn = ''; - my $al = $sa_results->{autolearn}; # subject to local SA learn scores - if ( $al ) { - $self->adjust_karma( 1 ) if $al eq 'ham'; - $self->adjust_karma( -1 ) if $al eq 'spam'; - $learn = "learn=". $al; - }; + my $learn = ''; + my $al = $sa_results->{autolearn}; # subject to local SA learn scores + if ($al) { + $self->adjust_karma(1) if $al eq 'ham'; + $self->adjust_karma(-1) if $al eq 'spam'; + $learn = "learn=" . $al; + } my $reject = $self->{_args}{reject} or do { $self->log(LOGERROR, "error, reject disabled ($status, $learn)"); return DECLINED; }; - if ( $score < $reject ) { - if ( $ham_or_spam eq 'Spam' ) { + if ($score < $reject) { + if ($ham_or_spam eq 'Spam') { $self->log(LOGINFO, "fail, $status < $reject, $learn"); return DECLINED; } @@ -440,20 +451,20 @@ sub munge_subject { }; return unless $sa->{score} > $required; - my $subject_prefix = $self->qp->config('subject_prefix') || '*** SPAM ***'; - my $subject = $transaction->header->get('Subject') || ''; + my $subject_prefix = $self->qp->config('subject_prefix') || '*** SPAM ***'; + my $subject = $transaction->header->get('Subject') || ''; $transaction->header->replace('Subject', "$subject_prefix $subject"); } sub get_spam_results { my ($self, $transaction) = @_; - if ( defined $transaction->notes('spamassassin') ) { + if (defined $transaction->notes('spamassassin')) { return $transaction->notes('spamassassin'); - }; + } my $header = $transaction->header->get('X-Spam-Status') or return; - my $r = $self->parse_spam_header( $header ); + my $r = $self->parse_spam_header($header); $self->log(LOGDEBUG, "$r->{is_spam}, $r->{score}"); $transaction->notes('spamassassin', $r); @@ -464,44 +475,48 @@ sub get_spam_results { sub parse_spam_header { my ($self, $string) = @_; -# the X-Spam-Score header contents vary based on the settings in -# the spamassassin *.cf files. Rather than parse via regexp, split -# on the consistent whitespace and = delimiters. More reliable and -# likely faster. + # the X-Spam-Score header contents vary based on the settings in + # the spamassassin *.cf files. Rather than parse via regexp, split + # on the consistent whitespace and = delimiters. More reliable and + # likely faster. my @parts = split(/\s+/, $string); my $is_spam = shift @parts; chomp @parts; - chop $is_spam; # remove trailing , + chop $is_spam; # remove trailing , my %r; - foreach ( @parts ) { - my ($key,$val) = split(/=/, $_); + foreach (@parts) { + my ($key, $val) = split(/=/, $_); $r{$key} = $val; } $r{is_spam} = $is_spam; # compatibility for SA versions < 3 - if ( defined $r{hits} && ! defined $r{score} ) { + if (defined $r{hits} && !defined $r{score}) { $r{score} = delete $r{hits}; - }; + } return \%r; -}; +} sub _cleanup_spam_header { my ($self, $transaction, $header_name) = @_; my $action = 'rename'; - if ( $self->{_args}->{leave_old_headers} ) { + if ($self->{_args}->{leave_old_headers}) { $action = lc($self->{_args}->{leave_old_headers}); - }; + } return unless $action eq 'drop' || $action eq 'rename'; my $old_header_name = $header_name; - $old_header_name = ($old_header_name =~ s/^X-//) ? "X-Old-$old_header_name" : "Old-$old_header_name"; + $old_header_name = + ($old_header_name =~ s/^X-//) + ? "X-Old-$old_header_name" + : "Old-$old_header_name"; - for my $header ( $transaction->header->get($header_name) ) { - $transaction->header->add($old_header_name, $header, 0) if $action eq 'rename'; + for my $header ($transaction->header->get($header_name)) { + $transaction->header->add($old_header_name, $header, 0) + if $action eq 'rename'; $transaction->header->delete($header_name); } } diff --git a/plugins/tls b/plugins/tls index 75c6751..533c5df 100644 --- a/plugins/tls +++ b/plugins/tls @@ -67,8 +67,9 @@ sub init { $cert ||= "$dir/qpsmtpd-server.crt"; $key ||= "$dir/qpsmtpd-server.key"; $ca ||= "$dir/qpsmtpd-ca.crt"; - unless ( -f $cert && -f $key && -f $ca ) { - $self->log(LOGERROR, "Cannot locate cert/key! Run plugins/tls_cert to generate"); + unless (-f $cert && -f $key && -f $ca) { + $self->log(LOGERROR, + "Cannot locate cert/key! Run plugins/tls_cert to generate"); return; } $self->tls_cert($cert); @@ -76,31 +77,34 @@ sub init { $self->tls_ca($ca); $self->tls_ciphers($self->qp->config('tls_ciphers') || 'HIGH'); - $self->log(LOGDEBUG, "ciphers: ".$self->tls_ciphers); + $self->log(LOGDEBUG, "ciphers: " . $self->tls_ciphers); + + local $^W; # this bit is very noisy... + my $ssl_ctx = + IO::Socket::SSL::SSL_Context->new( + SSL_use_cert => 1, + SSL_cert_file => $self->tls_cert, + SSL_key_file => $self->tls_key, + SSL_ca_file => $self->tls_ca, + SSL_cipher_list => $self->tls_ciphers, + SSL_server => 1 + ) + or die "Could not create SSL context: $!"; - local $^W; # this bit is very noisy... - my $ssl_ctx = IO::Socket::SSL::SSL_Context->new( - SSL_use_cert => 1, - SSL_cert_file => $self->tls_cert, - SSL_key_file => $self->tls_key, - SSL_ca_file => $self->tls_ca, - SSL_cipher_list => $self->tls_ciphers, - SSL_server => 1 - ) or die "Could not create SSL context: $!"; # now extract the password... $self->ssl_context($ssl_ctx); # Check for possible AUTH mechanisms -HOOK: foreach my $hook ( keys %{$qp->hooks} ) { + HOOK: foreach my $hook (keys %{$qp->hooks}) { no strict 'refs'; - if ( $hook =~ m/^auth-?(.+)?$/ ) { - if ( defined $1 ) { + if ($hook =~ m/^auth-?(.+)?$/) { + if (defined $1) { my $hooksub = "hook_$hook"; $hooksub =~ s/\W/_/g; *$hooksub = \&bad_ssl_hook; } - else { # at least one polymorphous auth provider + else { # at least one polymorphous auth provider *hook_auth = \&bad_ssl_hook; } } @@ -111,10 +115,11 @@ sub hook_ehlo { my ($self, $transaction) = @_; return DECLINED unless $self->can_do_tls; return DECLINED if $self->connection->notes('tls_enabled'); - return DENY, "Command refused due to lack of security" if $transaction->notes('ssl_failed'); + return DENY, "Command refused due to lack of security" + if $transaction->notes('ssl_failed'); my $cap = $transaction->notes('capabilities') || []; push @$cap, 'STARTTLS'; - $transaction->notes('tls_enabled', 1); + $transaction->notes('tls_enabled', 1); $transaction->notes('capabilities', $cap); return DECLINED; } @@ -126,9 +131,10 @@ sub hook_unrecognized_command { return DENY, "Syntax error (no parameters allowed)" if @args; # OK, now we setup TLS - $self->qp->respond (220, "Go ahead with TLS"); + $self->qp->respond(220, "Go ahead with TLS"); + + unless (_convert_to_ssl($self)) { - unless ( _convert_to_ssl($self) ) { # SSL setup failed. Now we must respond to every command with 5XX warn("TLS failed: $@\n"); $transaction->notes('ssl_failed', 1); @@ -143,9 +149,9 @@ sub hook_connect { my ($self, $transaction) = @_; my $local_port = $self->qp->connection->local_port; - return DECLINED unless defined $local_port && $local_port == 465; # SMTPS + return DECLINED unless defined $local_port && $local_port == 465; # SMTPS - unless ( _convert_to_ssl($self) ) { + unless (_convert_to_ssl($self)) { return (DENY_DISCONNECT, "Cannot establish SSL session"); } $self->log(LOGWARN, "Connected via SMTPS"); @@ -156,9 +162,10 @@ sub hook_post_connection { my ($self, $transaction) = @_; my $tls_socket = $self->connection->notes('tls_socket'); - if (defined $tls_socket && $self->connection->notes('tls_socket_is_duped')) { + if (defined $tls_socket && $self->connection->notes('tls_socket_is_duped')) + { $tls_socket->close; - $self->connection->notes('tls_socket', undef); + $self->connection->notes('tls_socket', undef); $self->connection->notes('tls_socked_is_duped', 0); } @@ -173,34 +180,36 @@ sub _convert_to_ssl { } eval { - my $tlssocket = IO::Socket::SSL->new_from_fd( - fileno(STDIN), '+>', - SSL_use_cert => 1, - SSL_cert_file => $self->tls_cert, - SSL_key_file => $self->tls_key, - SSL_ca_file => $self->tls_ca, - SSL_cipher_list => $self->tls_ciphers, - SSL_server => 1, - SSL_reuse_ctx => $self->ssl_context, - ) or die "Could not create SSL socket: $!"; + my $tlssocket = + IO::Socket::SSL->new_from_fd( + fileno(STDIN), '+>', + SSL_use_cert => 1, + SSL_cert_file => $self->tls_cert, + SSL_key_file => $self->tls_key, + SSL_ca_file => $self->tls_ca, + SSL_cipher_list => $self->tls_ciphers, + SSL_server => 1, + SSL_reuse_ctx => $self->ssl_context, + ) + or die "Could not create SSL socket: $!"; # Clone connection object (without data received from client) $self->qp->connection($self->connection->clone()); $self->qp->reset_transaction; *STDIN = *STDOUT = $self->connection->notes('tls_socket', $tlssocket); $self->connection->notes('tls_socket_is_duped', 1); - $self->connection->notes('tls_enabled', 1); + $self->connection->notes('tls_enabled', 1); }; if ($@) { return 0; - }; + } return 1; } sub _convert_to_ssl_async { my ($self) = @_; - my $upgrader = $self->connection - ->notes( 'tls_upgrader', UpgradeClientSSL->new($self) ); + my $upgrader = + $self->connection->notes('tls_upgrader', UpgradeClientSSL->new($self)); $upgrader->upgrade_socket(); return 1; } @@ -243,7 +252,8 @@ sub ssl_context { # Fulfill RFC 2487 secn 5.1 sub bad_ssl_hook { my ($self, $transaction) = @_; - return DENY, "Command refused due to lack of security" if $transaction->notes('ssl_failed'); + return DENY, "Command refused due to lack of security" + if $transaction->notes('ssl_failed'); return DECLINED; } *hook_helo = *hook_data = *hook_rcpt = *hook_mail = \&bad_ssl_hook; @@ -254,7 +264,7 @@ package UpgradeClientSSL; use strict; use warnings; -no warnings qw(deprecated); +no warnings qw(deprecated); use IO::Socket::SSL 0.98; use Errno qw( EAGAIN ); @@ -265,27 +275,29 @@ sub new { my UpgradeClientSSL $self = shift; $self = fields::new($self) unless ref $self; $self->{_stashed_plugin} = shift; - $self->{_stashed_qp} = $self->{_stashed_plugin}->qp; + $self->{_stashed_qp} = $self->{_stashed_plugin}->qp; return $self; } sub upgrade_socket { my UpgradeClientSSL $self = shift; - unless ( $self->{_ssl_started} ) { + unless ($self->{_ssl_started}) { $self->{_stashed_qp}->clear_data(); IO::Socket::SSL->start_SSL( - $self->{_stashed_qp}->{sock}, { - SSL_use_cert => 1, - SSL_cert_file => $self->{_stashed_plugin}->tls_cert, - SSL_key_file => $self->{_stashed_plugin}->tls_key, - SSL_ca_file => $self->{_stashed_plugin}->tls_ca, - SSL_cipher_list => $self->{_stashed_plugin}->tls_ciphers, - SSL_startHandshake => 0, - SSL_server => 1, - SSL_reuse_ctx => $self->{_stashed_plugin}->ssl_context, - } - ) or die "Could not upgrade socket to SSL: $!"; + $self->{_stashed_qp}->{sock}, + { + SSL_use_cert => 1, + SSL_cert_file => $self->{_stashed_plugin}->tls_cert, + SSL_key_file => $self->{_stashed_plugin}->tls_key, + SSL_ca_file => $self->{_stashed_plugin}->tls_ca, + SSL_cipher_list => $self->{_stashed_plugin}->tls_ciphers, + SSL_startHandshake => 0, + SSL_server => 1, + SSL_reuse_ctx => $self->{_stashed_plugin}->ssl_context, + } + ) + or die "Could not upgrade socket to SSL: $!"; $self->{_ssl_started} = 1; } @@ -296,14 +308,14 @@ sub event_read { my UpgradeClientSSL $self = shift; my $qp = shift; - $qp->watch_read( 0 ); + $qp->watch_read(0); my $sock = $qp->{sock}->accept_SSL; if (defined $sock) { - $qp->connection( $qp->connection->clone ); + $qp->connection($qp->connection->clone); $qp->reset_transaction; - $self->connection->notes('tls_socket', $sock); + $self->connection->notes('tls_socket', $sock); $self->connection->notes('tls_enabled', 1); $qp->watch_read(1); return 1; @@ -314,12 +326,15 @@ sub event_read { $qp->set_reader_object($self); if ($SSL_ERROR == SSL_WANT_READ) { $qp->watch_read(1); - } elsif ($SSL_ERROR == SSL_WANT_WRITE) { + } + elsif ($SSL_ERROR == SSL_WANT_WRITE) { $qp->watch_write(1); - } else { + } + else { $qp->disconnect(); } - } else { + } + else { $qp->disconnect(); } } diff --git a/plugins/uribl b/plugins/uribl index 25ee88d..4834101 100644 --- a/plugins/uribl +++ b/plugins/uribl @@ -101,46 +101,47 @@ use IO::Select; # ccTLDs that allocate domain names within a strict two-level hierarchy, # as in *.co.uk my %strict_twolevel_cctlds = ( - 'ac' => 1, - 'ae' => 1, - 'uk' => 1, - 'ai' => 1, - 'ar' => 1, - 'at' => 1, - 'au' => 1, - 'az' => 1, - 'bb' => 1, - 'bh' => 1, - 'bm' => 1, - 'br' => 1, - 'bs' => 1, - 'ca' => 1, - 'ck' => 1, - 'cn' => 1, - 'co' => 1, - 'cr' => 1, - 'cu' => 1, - 'cy' => 1, - 'do' => 1, - 'et' => 1, - 'ge' => 1, - 'hk' => 1, - 'id' => 1, - 'il' => 1, - 'jp' => 1, - 'kr' => 1, - 'kw' => 1, - 'lv' => 1, - 'sg' => 1, - 'za' => 1, -); + 'ac' => 1, + 'ae' => 1, + 'uk' => 1, + 'ai' => 1, + 'ar' => 1, + 'at' => 1, + 'au' => 1, + 'az' => 1, + 'bb' => 1, + 'bh' => 1, + 'bm' => 1, + 'br' => 1, + 'bs' => 1, + 'ca' => 1, + 'ck' => 1, + 'cn' => 1, + 'co' => 1, + 'cr' => 1, + 'cu' => 1, + 'cy' => 1, + 'do' => 1, + 'et' => 1, + 'ge' => 1, + 'hk' => 1, + 'id' => 1, + 'il' => 1, + 'jp' => 1, + 'kr' => 1, + 'kw' => 1, + 'lv' => 1, + 'sg' => 1, + 'za' => 1, + ); # async version: OK sub init { my ($self, $qp, %args) = @_; - $self->{action} = $args{action} || 'add-header'; + $self->{action} = $args{action} || 'add-header'; $self->{timeout} = $args{timeout} || 30; + # scan-headers was the originally documented name for this option, while # check-headers actually implements it, so tolerate both. $self->{check_headers} = $args{'check-headers'} || $args{'scan-headers'}; @@ -152,7 +153,7 @@ sub init { for (@zones) { chomp; next if !$_ or /^\s*#/; - my @z = split (/\s+/, $_); + my @z = split(/\s+/, $_); next unless $z[0]; my $mask = 0; @@ -171,16 +172,14 @@ sub init { } $self->{uribl_zones}->{$z[0]} = { - mask => $mask, - action => $action, - }; + mask => $mask, + action => $action, + }; } keys %{$self->{uribl_zones}} or return 0; my @whitelist = $self->qp->config('uribl_whitelist_domains'); - $self->{whitelist_zones} = { - ( map { ($_ => 1) } @whitelist ) - }; + $self->{whitelist_zones} = {(map { ($_ => 1) } @whitelist)}; $self->init_resolver; } @@ -194,17 +193,17 @@ sub register { # async version: not used sub send_query { - my $self = shift; - my $name = shift || return undef; + my $self = shift; + my $name = shift || return undef; my $count = 0; $self->{socket_select} ||= new IO::Select or return undef; for my $z (keys %{$self->{uribl_zones}}) { my ($s, $s1); my $index = { - zone => $z, - name => $name, - }; + zone => $z, + name => $name, + }; next unless $z; next if exists $self->{sockets}->{$z}->{$name}; @@ -214,10 +213,12 @@ sub send_query { $self->{socket_select}->add($s); $self->{socket_idx}->{"$s"} = $index; $count++; - } else { + } + else { $self->log(LOGERROR, - "Couldn't open socket for A record '$name.$z': ". - ($self->{resolver}->errorstring || 'unknown error')); + "Couldn't open socket for A record '$name.$z': " + . ($self->{resolver}->errorstring || 'unknown error') + ); } $s1 = $self->{resolver}->bgsend("$name.$z", 'TXT'); @@ -226,10 +227,12 @@ sub send_query { $self->{socket_select}->add($s1); $self->{socket_idx}->{"$s1"} = $index; $count++; - } else { + } + else { $self->log(LOGERROR, - "Couldn't open socket for TXT record '$name.$z': ". - ($self->{resolver}->errorstring || 'unknown error')); + "Couldn't open socket for TXT record '$name.$z': " + . ($self->{resolver}->errorstring || 'unknown error') + ); } $self->{sockets}->{$z}->{$name} = {}; @@ -241,7 +244,7 @@ sub send_query { sub lookup_finish { my $self = shift; $self->{socket_idx} = {}; - $self->{sockets} = {}; + $self->{sockets} = {}; undef $self->{socket_select}; } @@ -249,14 +252,13 @@ sub lookup_finish { sub evaluate { my $self = shift; my $zone = shift || return undef; - my $a = shift || return undef; + my $a = shift || return undef; my $mask = $self->{uribl_zones}->{$zone}->{mask} || $self->{mask}; $a =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/ or return undef; - my $v = (($1 & 0xff) << 24) | - (($2 & 0xff) << 16) | - (($3 & 0xff) << 8) | - ($4 & 0xff); + my $v = + (($1 & 0xff) << 24) | (($2 & 0xff) << 16) | (($3 & 0xff) << 8) | + ($4 & 0xff); return ($v & $mask); } @@ -270,8 +272,9 @@ sub lookup_start { my @qp_continuations; $transaction->body_resetpos; - # if we're not looking for URIs in the headers, read past that point - # before starting to actually look for any + + # if we're not looking for URIs in the headers, read past that point + # before starting to actually look for any while (!$self->{check_headers} and $l = $transaction->body_getline) { chomp $l; last if !$l; @@ -281,51 +284,62 @@ sub lookup_start { if ($l =~ /(.*)=$/) { push @qp_continuations, $1; - } elsif (@qp_continuations) { + } + elsif (@qp_continuations) { $l = join('', @qp_continuations, $l); @qp_continuations = (); } # Undo URI escape munging $l =~ s/[=%]([0-9A-Fa-f]{2,2})/chr(hex($1))/ge; + # Undo HTML entity munging (e.g. in parameterized redirects) $l =~ s/&#(\d{2,3});?/chr($1)/ge; + # Dodge inserted-semicolon munging $l =~ tr/;//d; - while ($l =~ m{ + while ( + $l =~ m{ \w{3,16}:/+ # protocol (?:\S+@)? # user/pass (\d{7,}) # raw-numeric IP (?::\d*)?([/?\s]|$) # port, slash # or EOL - }gx) { + }gx + ) + { my @octets = ( - (($1 >> 24) & 0xff), - (($1 >> 16) & 0xff), - (($1 >> 8) & 0xff), - ($1 & 0xff) - ); + (($1 >> 24) & 0xff), + (($1 >> 16) & 0xff), + (($1 >> 8) & 0xff), + ($1 & 0xff) + ); my $fwd = join('.', @octets); my $rev = join('.', reverse @octets); - $self->log(LOGDEBUG, "uribl: matched pure-integer ipaddr $1 ($fwd)"); + $self->log(LOGDEBUG, + "uribl: matched pure-integer ipaddr $1 ($fwd)"); unless (exists $pending{$rev}) { $queries += $start_query->($self, $rev); $pending{$rev} = 1; } } - while ($l =~ m{ + while ( + $l =~ m{ \w{3,16}:/+ # protocol (?:\S+@)? # user/pass (\d+|0[xX][0-9A-Fa-f]+)\. # IP address (\d+|0[xX][0-9A-Fa-f]+)\. (\d+|0[xX][0-9A-Fa-f]+)\. (\d+|0[xX][0-9A-Fa-f]+) - }gx) { - my @octets = ($1,$2,$3,$4); + }gx + ) + { + my @octets = ($1, $2, $3, $4); + # return any octal/hex octets in the IP addr back # to decimal form (e.g. http://0x7f.0.0.00001) - for (0..$#octets) { + for (0 .. $#octets) { $octets[$_] =~ s/^0([0-7]+)$/oct($1)/e; $octets[$_] =~ s/^0x([0-9a-fA-F]+)$/hex($1)/e; } @@ -337,7 +351,8 @@ sub lookup_start { $pending{$rev} = 1; } } - while ($l =~ m{ + while ( + $l =~ m{ ((?:www\.)? # www? [a-zA-Z0-9][a-zA-Z0-9\-.]+\. # hostname (?:aero|arpa|asia|biz|cat|com|coop| # tld @@ -345,22 +360,33 @@ sub lookup_start { museum|name|net|org|pro|tel|travel| [a-zA-Z]{2}) )(?!\w) - }gix) { + }gix + ) + { my $host = lc $1; my @host_domains = split /\./, $host; $self->log(LOGDEBUG, "uribl: matched 'www.' hostname $host"); - my $cutoff = exists - $strict_twolevel_cctlds{$host_domains[$#host_domains]} ? 3 : 2; - if (exists $self->{whitelist_zones}->{ - join('.', - @host_domains[($#host_domains-$cutoff+1)..$#host_domains])}) { + my $cutoff = + exists $strict_twolevel_cctlds{$host_domains[$#host_domains]} + ? 3 + : 2; + if ( + exists $self->{whitelist_zones}->{ + join('.', + @host_domains[($#host_domains - $cutoff + 1) + .. $#host_domains]) + } + ) + { $self->log(LOGINFO, "Skipping whitelist URI domain '$host'"); - } else { + } + else { while (@host_domains >= $cutoff) { my $subhost = join('.', @host_domains); unless (exists $pending{$subhost}) { - $self->log(LOGINFO, "URIBL: checking sub-host $subhost"); + $self->log(LOGINFO, + "URIBL: checking sub-host $subhost"); $queries += $start_query->($self, $subhost); $pending{$subhost} = 1; } @@ -368,7 +394,8 @@ sub lookup_start { } } } - while ($l =~ m{ + while ( + $l =~ m{ \w{3,16}:/+ # protocol (?:\S+@)? # user/pass ( @@ -378,22 +405,30 @@ sub lookup_start { museum|name|net|org|pro|tel|travel| [a-zA-Z]{2}) ) - }gix) { + }gix + ) + { my $host = lc $1; my @host_domains = split /\./, $host; $self->log(LOGDEBUG, "uribl: matched full URI hostname $host"); - my $cutoff = exists - $strict_twolevel_cctlds{$host_domains[$#host_domains]} ? 3 : 2; - if (exists $self->{whitelist_zones}->{ - join('.', @host_domains[($cutoff-1)..$#host_domains])}) { + my $cutoff = + exists $strict_twolevel_cctlds{$host_domains[$#host_domains]} + ? 3 + : 2; + if ( + exists $self->{whitelist_zones} + ->{join('.', @host_domains[($cutoff - 1) .. $#host_domains])}) + { $self->log(LOGINFO, "Skipping whitelist URI domain '$host'"); - } else { + } + else { while (@host_domains >= $cutoff) { my $subhost = join('.', @host_domains); unless (exists $pending{$subhost}) { - $self->log(LOGINFO, "URIBL: checking sub-host $subhost"); + $self->log(LOGINFO, + "URIBL: checking sub-host $subhost"); $queries += $start_query->($self, $subhost); $pending{$subhost} = 1; } @@ -411,8 +446,8 @@ sub lookup_start { sub collect_results { my ($self, $transaction) = @_; - my $matches = 0; - my $complete = 0; + my $matches = 0; + my $complete = 0; my $start_time = time; while ($self->{socket_select}->handles) { my $timeout = ($start_time + $self->{timeout}) - time; @@ -420,16 +455,18 @@ sub collect_results { my @ready = $self->{socket_select}->can_read($timeout); - SOCK: for my $s (@ready) { + SOCK: for my $s (@ready) { $self->{socket_select}->remove($s); my $r = $self->{socket_idx}->{"$s"} or next SOCK; - $self->log(LOGDEBUG, "from $r: socket $s: ". - join(', ', map { "$_=$r->{$_}" } keys %{$r})); - my $zone = $r->{zone}; - my $name = $r->{name}; - my $h = $self->{sockets}->{$zone}->{$name}; + $self->log(LOGDEBUG, + "from $r: socket $s: " + . join(', ', map { "$_=$r->{$_}" } keys %{$r}) + ); + my $zone = $r->{zone}; + my $name = $r->{name}; + my $h = $self->{sockets}->{$zone}->{$name}; my $packet = $self->{resolver}->bgread($s) - or next SOCK; + or next SOCK; for my $a ($packet->answer) { if ($a->type eq 'TXT') { @@ -438,8 +475,7 @@ sub collect_results { elsif ($a->type eq 'A') { $h->{a} = $a->address; if ($self->evaluate($zone, $h->{a})) { - $self->log(LOGDEBUG, - "match in $zone"); + $self->log(LOGDEBUG, "match in $zone"); $h->{match} = 1; $matches++; } @@ -451,21 +487,23 @@ sub collect_results { } my $elapsed = time - $start_time; $self->log(LOGINFO, - sprintf("$complete lookup%s finished in %.2f sec (%d match%s)", - $complete == 1 ? '' : 's', $elapsed, - $matches, $matches == 1 ? '' : 'es')); + sprintf( + "$complete lookup%s finished in %.2f sec (%d match%s)", + $complete == 1 ? '' : 's', $elapsed, + $matches, $matches == 1 ? '' : 'es' + ) + ); my @matches = (); for my $z (keys %{$self->{sockets}}) { for my $n (keys %{$self->{sockets}->{$z}}) { my $h = $self->{sockets}->{$z}->{$n}; next unless $h->{match}; - push @matches, { - action => - $self->{uribl_zones}->{$z}->{action}, - desc => "$n in $z: ". - ($h->{txt} || $h->{a}), - }; + push @matches, + { + action => $self->{uribl_zones}->{$z}->{action}, + desc => "$n in $z: " . ($h->{txt} || $h->{a}), + }; } } @@ -480,10 +518,13 @@ sub data_handler { return (DECLINED) if $self->is_immune(); - my $queries = $self->lookup_start($transaction, sub { - my ($self, $name) = @_; - return $self->send_query($name); - }); + my $queries = $self->lookup_start( + $transaction, + sub { + my ($self, $name) = @_; + return $self->send_query($name); + } + ); unless ($queries) { $self->log(LOGINFO, "pass, No URIs found in mail"); @@ -495,9 +536,11 @@ sub data_handler { $self->log(LOGWARN, $_->{desc}); if ($_->{action} eq 'add-header') { $transaction->header->add('X-URIBL-Match', $_->{desc}, 0); - } elsif ($_->{action} eq 'deny') { + } + elsif ($_->{action} eq 'deny') { return (DENY, $_->{desc}); - } elsif ($_->{action} eq 'denysoft') { + } + elsif ($_->{action} eq 'denysoft') { return (DENYSOFT, $_->{desc}); } } diff --git a/plugins/virus/aveclient b/plugins/virus/aveclient index f321f76..8f5c38c 100644 --- a/plugins/virus/aveclient +++ b/plugins/virus/aveclient @@ -1,4 +1,5 @@ #!perl -w + =head1 NAME aveclient @@ -92,89 +93,112 @@ SOFTWARE. use File::Temp qw(tempfile); use Mail::Address; - + sub register { - my ($self, $qp, @args) = @_; - - # defaults to be used - $self->{_avclient_bin} = "/opt/kav/bin/aveclient"; - $self->{_avdaemon_sock} = "/var/run/aveserver"; - $self->{_blockonerror} = 0; - - # parse optional arguments - my %args = @args; - foreach my $key (keys %args) { - my $arg = $key; - $key =~ s/^/_/; - $self->{$key} = $args{$arg}; - } + my ($self, $qp, @args) = @_; - # Untaint client location - # socket will be tested during scan (response-code) - if (exists $self->{_avclient_bin} && $self->{_avclient_bin} =~ /^(\/[\/\-\_\.a-z0-9A-Z]*)$/) { - $self->{_avclient_bin} = $1; - } else { - $self->log(LOGALERT, "FATAL ERROR: No binary aveclient found: '".$self->{_avclient_bin}."'"); - exit 3; - } + # defaults to be used + $self->{_avclient_bin} = "/opt/kav/bin/aveclient"; + $self->{_avdaemon_sock} = "/var/run/aveserver"; + $self->{_blockonerror} = 0; + + # parse optional arguments + my %args = @args; + foreach my $key (keys %args) { + my $arg = $key; + $key =~ s/^/_/; + $self->{$key} = $args{$arg}; + } + + # Untaint client location + # socket will be tested during scan (response-code) + if (exists $self->{_avclient_bin} + && $self->{_avclient_bin} =~ /^(\/[\/\-\_\.a-z0-9A-Z]*)$/) + { + $self->{_avclient_bin} = $1; + } + else { + $self->log(LOGALERT, + "FATAL ERROR: No binary aveclient found: '" + . $self->{_avclient_bin} . "'" + ); + exit 3; + } } - -sub hook_data_post { - my ($self, $transaction) = @_; - my ($temp_fh, $filename) = tempfile(); - my $description = 'clean'; - - # a temporary file is needed to be scanned - print $temp_fh $transaction->header->as_string; - print $temp_fh "\n"; - - $transaction->body_resetpos; - - while (my $line = $transaction->body_getline) { - print $temp_fh $line; - } - seek($temp_fh, 0, 0); - - # Now scan this file - my $cmd = $self->{_avclient_bin}." -p ".$self->{_avdaemon_sock}." -s $filename 2>&1"; - my @output = `$cmd`; - chomp(@output); - - my $result = ($? >> 8); - my $signal = ($? & 127); - - # tidy up a bit - unlink($filename); - close $temp_fh; - - # check if something went wrong - if ($signal) { - $self->log(LOGERROR, "kavscanner exited with signal: $signal"); - return (DECLINED); - } - - # either we found a virus or something went wrong - if ($result > 0) { - if ($result =~ /^(2|3|4|6|8)$/) { - - # ok a somewhat virus was found - shift @output; - $description = "REPORT: ".join(", ",@output); - $self->log(LOGWARN, "Virus found! ($description)"); - - # we don't want to be disturbed be these, so block mail and DENY connection - return(DENY, "Virus found: $description"); - - } else { - $self->log(LOGCRIT, "aveserver: no viruses have been detected.") if($result =~ /^0$/); - $self->log(LOGCRIT, "aveserver: system error launching the application (file not found, unable to read the file).") if($result =~ /^0$/); - $self->log(LOGCRIT, "aveserver: some of the required parameters are missing from the command line.") if($result =~ /^9$/); - return(DENY, "Unable to scan for virus, please contact admin of ".$self->qp->config("me").", if you feel this is an error!") if $self->{_blockonerror}; - } - } - - $self->log(LOGINFO, "kavscanner results: $description"); - $transaction->header->add('X-Virus-Checked', 'Checked by Kaspersky on '.$self->qp->config("me")); - return (DECLINED); -} +sub hook_data_post { + my ($self, $transaction) = @_; + my ($temp_fh, $filename) = tempfile(); + my $description = 'clean'; + + # a temporary file is needed to be scanned + print $temp_fh $transaction->header->as_string; + print $temp_fh "\n"; + + $transaction->body_resetpos; + + while (my $line = $transaction->body_getline) { + print $temp_fh $line; + } + seek($temp_fh, 0, 0); + + # Now scan this file + my $cmd = + $self->{_avclient_bin} . " -p " + . $self->{_avdaemon_sock} + . " -s $filename 2>&1"; + + my @output = `$cmd`; + chomp(@output); + + my $result = ($? >> 8); + my $signal = ($? & 127); + + # tidy up a bit + unlink($filename); + close $temp_fh; + + # check if something went wrong + if ($signal) { + $self->log(LOGERROR, "kavscanner exited with signal: $signal"); + return (DECLINED); + } + + # either we found a virus or something went wrong + if ($result > 0) { + if ($result =~ /^(2|3|4|6|8)$/) { + + # ok a somewhat virus was found + shift @output; + $description = "REPORT: " . join(", ", @output); + $self->log(LOGWARN, "Virus found! ($description)"); + + # we don't want to be disturbed be these, so block mail and DENY connection + return (DENY, "Virus found: $description"); + + } + else { + $self->log(LOGCRIT, "aveserver: no viruses have been detected.") + if ($result =~ /^0$/); + $self->log(LOGCRIT, +"aveserver: system error launching the application (file not found, unable to read the file)." + ) + if ($result =~ /^0$/); + $self->log(LOGCRIT, +"aveserver: some of the required parameters are missing from the command line." + ) + if ($result =~ /^9$/); + return (DENY, + "Unable to scan for virus, please contact admin of " + . $self->qp->config("me") + . ", if you feel this is an error!" + ) + if $self->{_blockonerror}; + } + } + + $self->log(LOGINFO, "kavscanner results: $description"); + $transaction->header->add('X-Virus-Checked', + 'Checked by Kaspersky on ' . $self->qp->config("me")); + return (DECLINED); +} diff --git a/plugins/virus/bitdefender b/plugins/virus/bitdefender index 17609a2..ea01e6c 100644 --- a/plugins/virus/bitdefender +++ b/plugins/virus/bitdefender @@ -67,10 +67,10 @@ use File::Path; use Qpsmtpd::Constants; sub register { - my ( $self, $qp, @args ) = @_; + my ($self, $qp, @args) = @_; while (@args) { - $self->{"_bitd"}->{ pop @args } = pop @args; + $self->{"_bitd"}->{pop @args} = pop @args; } $self->{"_bitd"}->{"bitdefender_location"} ||= "/opt/bdc/bdc"; $self->{"_bitd"}->{"deny_viruses"} ||= "yes"; @@ -79,31 +79,31 @@ sub register { } sub hook_data_post { - my ( $self, $transaction ) = @_; + my ($self, $transaction) = @_; - if ( $transaction->data_size > $self->{"_bitd"}->{"max_size"} ) { - $self->log( LOGWARN, - 'Mail too large to scan (' - . $transaction->data_size . " vs " - . $self->{"_bitd"}->{"max_size"} - . ")" ); + if ($transaction->data_size > $self->{"_bitd"}->{"max_size"}) { + $self->log(LOGWARN, + 'Mail too large to scan (' + . $transaction->data_size . " vs " + . $self->{"_bitd"}->{"max_size"} . ")" + ); return (DECLINED); } # Ignore non-multipart emails my $content_type = $transaction->header->get('Content-Type'); $content_type =~ s/\s/ /g if defined $content_type; - unless ( $content_type - && $content_type =~ m!\bmultipart/.*\bboundary="?([^"]+)!i ) + unless ( $content_type + && $content_type =~ m!\bmultipart/.*\bboundary="?([^"]+)!i) { - $self->log( LOGERROR, "non-multipart mail - skipping" ); + $self->log(LOGERROR, "non-multipart mail - skipping"); return DECLINED; } my $filename = $transaction->body_filename; unless (defined $filename) { - $self->log(LOGERROR, "didn't get a filename"); - return DECLINED; + $self->log(LOGERROR, "didn't get a filename"); + return DECLINED; } # Now do the actual scanning! @@ -121,9 +121,9 @@ sub hook_data_post { close $bdc; if ($output) { - $self->log( LOGINFO, "Virus(es) found: $output" ); - if ( $self->{"_bitd"}->{"deny_viruses"} eq "yes" ) { - return ( DENY, "Virus Found: $output" ); + $self->log(LOGINFO, "Virus(es) found: $output"); + if ($self->{"_bitd"}->{"deny_viruses"} eq "yes") { + return (DENY, "Virus Found: $output"); } } diff --git a/plugins/virus/clamav b/plugins/virus/clamav index 73d505c..e7452f1 100644 --- a/plugins/virus/clamav +++ b/plugins/virus/clamav @@ -105,127 +105,133 @@ This plugin is licensed under the same terms as the qpsmtpd package itself. Please see the LICENSE file included with qpsmtpd for details. =cut - + use strict; use warnings; - + use Qpsmtpd::Constants; sub register { - my ($self, $qp, @args) = @_; - my %args; + my ($self, $qp, @args) = @_; + my %args; - if ($args[0] && $args[0] =~ /^(\/[\/\-\_\.a-z0-9A-Z]*)$/ && -x $1) { - $self->{_clamscan_loc} = $1; - shift @args; - } - - for (@args) { - if (/^max_size=(\d+)$/) { - $self->{_max_size} = $1; - } - elsif (/^clamscan_path=(\/[\/\-\_\.a-z0-9A-Z]*)$/) { + if ($args[0] && $args[0] =~ /^(\/[\/\-\_\.a-z0-9A-Z]*)$/ && -x $1) { $self->{_clamscan_loc} = $1; + shift @args; } - elsif (/^clamd_conf=(\/[\/\-\_\.a-z0-9A-Z]*)$/) { - $self->{_clamd_conf} = "$1"; - } - elsif (/^tmp_dir=(\/[\/\-\_\.a-z0-9A-Z]*)$/) { - $self->{_spool_dir} = $1; - } - elsif (/^action=(add-header|reject)$/) { - $self->{_action} = $1; - } - elsif (/back_compat/) { - $self->{_back_compat} = '-i --max-recursion=50'; - } - elsif (/declined_on_fail/) { - $self->{_declined_on_fail} = 1; - } - else { - $self->log(LOGERROR, "Unrecognized argument '$_' to clamav plugin"); - return undef; - } - } - $self->{_max_size} ||= 512 * 1024; - $self->{_spool_dir} ||= $self->spool_dir(); - $self->{_back_compat} ||= ''; # make sure something is set - $self->{_clamd_conf} ||= '/etc/clamd.conf'; # make sure something is set - $self->{_declined_on_fail} ||= 0; # decline the message on clamav failure + for (@args) { + if (/^max_size=(\d+)$/) { + $self->{_max_size} = $1; + } + elsif (/^clamscan_path=(\/[\/\-\_\.a-z0-9A-Z]*)$/) { + $self->{_clamscan_loc} = $1; + } + elsif (/^clamd_conf=(\/[\/\-\_\.a-z0-9A-Z]*)$/) { + $self->{_clamd_conf} = "$1"; + } + elsif (/^tmp_dir=(\/[\/\-\_\.a-z0-9A-Z]*)$/) { + $self->{_spool_dir} = $1; + } + elsif (/^action=(add-header|reject)$/) { + $self->{_action} = $1; + } + elsif (/back_compat/) { + $self->{_back_compat} = '-i --max-recursion=50'; + } + elsif (/declined_on_fail/) { + $self->{_declined_on_fail} = 1; + } + else { + $self->log(LOGERROR, "Unrecognized argument '$_' to clamav plugin"); + return undef; + } + } - unless ($self->{_spool_dir}) { + $self->{_max_size} ||= 512 * 1024; + $self->{_spool_dir} ||= $self->spool_dir(); + $self->{_back_compat} ||= ''; # make sure something is set + $self->{_clamd_conf} ||= '/etc/clamd.conf'; # make sure something is set + $self->{_declined_on_fail} ||= 0; # decline the message on clamav failure + + unless ($self->{_spool_dir}) { $self->log(LOGERROR, "No spool dir configuration found"); return undef; - } - unless (-d $self->{_spool_dir}) { + } + unless (-d $self->{_spool_dir}) { $self->log(LOGERROR, "Spool dir $self->{_spool_dir} does not exist"); return undef; - } + } } - + sub hook_data_post { - my ($self, $transaction) = @_; + my ($self, $transaction) = @_; - if ($transaction->data_size > $self->{_max_size}) { - $self->log(LOGWARN, 'Mail too large to scan ('. - $transaction->data_size . " vs $self->{_max_size})" ); - return (DECLINED); - } + if ($transaction->data_size > $self->{_max_size}) { + $self->log(LOGWARN, + 'Mail too large to scan (' + . $transaction->data_size + . " vs $self->{_max_size})" + ); + return (DECLINED); + } - my $filename = $transaction->body_filename; - unless (defined $filename) { + my $filename = $transaction->body_filename; + unless (defined $filename) { $self->log(LOGWARN, "didn't get a filename"); return DECLINED; - } - my $mode = (stat($self->{_spool_dir}))[2]; - if ( $mode & 07077 ) { # must be sharing spool directory with external app - $self->log(LOGWARN, - "Changing permissions on file to permit scanner access"); - chmod $mode, $filename; - } - - # Now do the actual scanning! - my $cmd = $self->{_clamscan_loc} - . " --stdout " - . $self->{_back_compat} - . " --config-file=" . $self->{_clamd_conf} - . " --no-summary $filename 2>&1"; - $self->log(LOGDEBUG, "Running: $cmd"); - my $output = `$cmd`; - - my $result = ($? >> 8); - my $signal = ($? & 127); - - chomp($output); - - $output =~ s/^.* (.*) FOUND$/$1 /mg; - - $self->log(LOGINFO, "clamscan results: $output"); - - if ($signal) { - $self->log(LOGINFO, "clamscan exited with signal: $signal"); - return (DENYSOFT) if (!$self->{_declined_on_fail}); - return (DECLINED); - } - if ($result == 1) { - $self->log(LOGINFO, "Virus(es) found: $output"); - if ($self->{_action} eq 'add-header') { - $transaction->header->add('X-Virus-Found', 'Yes'); - $transaction->header->add('X-Virus-Details', $output); - } else { - return (DENY, "Virus Found: $output"); } - } - elsif ($result) { - $self->log(LOGERROR, "ClamAV error: $cmd: $result\n"); - return (DENYSOFT) if (!$self->{_declined_on_fail}); - } - else { - $transaction->header->add( 'X-Virus-Checked', - "Checked by ClamAV on " . $self->qp->config("me") ); - } - return (DECLINED); -} + my $mode = (stat($self->{_spool_dir}))[2]; + if ($mode & 07077) { # must be sharing spool directory with external app + $self->log(LOGWARN, + "Changing permissions on file to permit scanner access"); + chmod $mode, $filename; + } + + # Now do the actual scanning! + my $cmd = + $self->{_clamscan_loc} + . " --stdout " + . $self->{_back_compat} + . " --config-file=" + . $self->{_clamd_conf} + . " --no-summary $filename 2>&1"; + $self->log(LOGDEBUG, "Running: $cmd"); + my $output = `$cmd`; + + my $result = ($? >> 8); + my $signal = ($? & 127); + + chomp($output); + + $output =~ s/^.* (.*) FOUND$/$1 /mg; + + $self->log(LOGINFO, "clamscan results: $output"); + + if ($signal) { + $self->log(LOGINFO, "clamscan exited with signal: $signal"); + return (DENYSOFT) if (!$self->{_declined_on_fail}); + return (DECLINED); + } + if ($result == 1) { + $self->log(LOGINFO, "Virus(es) found: $output"); + if ($self->{_action} eq 'add-header') { + $transaction->header->add('X-Virus-Found', 'Yes'); + $transaction->header->add('X-Virus-Details', $output); + } + else { + return (DENY, "Virus Found: $output"); + } + } + elsif ($result) { + $self->log(LOGERROR, "ClamAV error: $cmd: $result\n"); + return (DENYSOFT) if (!$self->{_declined_on_fail}); + } + else { + $transaction->header->add('X-Virus-Checked', + "Checked by ClamAV on " . $self->qp->config("me")); + } + return (DECLINED); +} diff --git a/plugins/virus/clamdscan b/plugins/virus/clamdscan index 4148bd8..00feaae 100644 --- a/plugins/virus/clamdscan +++ b/plugins/virus/clamdscan @@ -109,17 +109,17 @@ use warnings; use Qpsmtpd::Constants; sub register { - my ( $self, $qp ) = shift, shift; + my ($self, $qp) = shift, shift; $self->log(LOGERROR, "Bad parameters for the clamdscan plugin") if @_ % 2; - $self->{'_args'} = { @_ }; + $self->{'_args'} = {@_}; eval 'use ClamAV::Client'; - if ( $@ ) { + if ($@) { warn "unable to load ClamAV::Client\n"; $self->log(LOGERROR, "unable to load ClamAV::Client"); return; - }; + } # Set some sensible defaults $self->{'_args'}{'deny_viruses'} ||= 'yes'; @@ -127,73 +127,75 @@ sub register { $self->{'_args'}{'scan_all'} ||= 0; for my $setting ('deny_viruses', 'defer_on_error') { next unless $self->{'_args'}{$setting}; - if ( lc $self->{'_args'}{$setting} eq 'no' ) { + if (lc $self->{'_args'}{$setting} eq 'no') { $self->{'_args'}{$setting} = 0; - }; + } } $self->register_hook('data_post', 'data_post_handler'); } sub data_post_handler { - my ( $self, $transaction ) = @_; + my ($self, $transaction) = @_; - my $filename = $self->get_filename( $transaction ) or return DECLINED; + my $filename = $self->get_filename($transaction) or return DECLINED; - if ( $self->connection->notes('naughty') ) { - $self->log( LOGINFO, "skip, naughty" ); + if ($self->connection->notes('naughty')) { + $self->log(LOGINFO, "skip, naughty"); return (DECLINED); - }; - return (DECLINED) if $self->is_too_big( $transaction ); - return (DECLINED) if $self->is_not_multipart( $transaction ); + } + return (DECLINED) if $self->is_too_big($transaction); + return (DECLINED) if $self->is_not_multipart($transaction); - $self->set_permission( $filename ) or return DECLINED; + $self->set_permission($filename) or return DECLINED; my $clamd = $self->get_clamd() - or return $self->err_and_return( "Cannot instantiate ClamAV::Client" ); + or return $self->err_and_return("Cannot instantiate ClamAV::Client"); - unless ( eval { $clamd->ping() } ) { - return $self->err_and_return( "Cannot ping clamd server: $@" ); + unless (eval { $clamd->ping() }) { + return $self->err_and_return("Cannot ping clamd server: $@"); } my ($version) = split(/\//, $clamd->version); $version ||= 'ClamAV'; - my ( $path, $found ) = eval { $clamd->scan_path( $filename ) }; + my ($path, $found) = eval { $clamd->scan_path($filename) }; if ($@) { - return $self->err_and_return( "Error scanning mail: $@" ); - }; + return $self->err_and_return("Error scanning mail: $@"); + } - if ( $found ) { - $self->log( LOGNOTICE, "fail, found virus $found" ); + if ($found) { + $self->log(LOGNOTICE, "fail, found virus $found"); - $self->connection->notes('naughty', 1); # see plugins/naughty - $self->adjust_karma( -1 ); + $self->connection->notes('naughty', 1); # see plugins/naughty + $self->adjust_karma(-1); - if ( $self->{_args}{deny_viruses} ) { - return ( DENY, "Virus found: $found" ); + if ($self->{_args}{deny_viruses}) { + return (DENY, "Virus found: $found"); } - $transaction->header->add( 'X-Virus-Found', 'Yes', 0 ); - $transaction->header->add( 'X-Virus-Details', $found, 0 ); + $transaction->header->add('X-Virus-Found', 'Yes', 0); + $transaction->header->add('X-Virus-Details', $found, 0); return (DECLINED); } - $self->log( LOGINFO, "pass, clean"); - $transaction->header->add( 'X-Virus-Found', 'No', 0 ); - $transaction->header->add( 'X-Virus-Checked', "by $version on " . $self->qp->config('me'), 0); + $self->log(LOGINFO, "pass, clean"); + $transaction->header->add('X-Virus-Found', 'No', 0); + $transaction->header->add('X-Virus-Checked', + "by $version on " . $self->qp->config('me'), 0); return (DECLINED); } sub err_and_return { - my $self = shift; + my $self = shift; my $message = shift; - if ( $message ) { - $self->log( LOGERROR, $message ); - }; - return (DENYSOFT, "Unable to scan for viruses") if $self->{_args}{defer_on_error}; + if ($message) { + $self->log(LOGERROR, $message); + } + return (DENYSOFT, "Unable to scan for viruses") + if $self->{_args}{defer_on_error}; return (DECLINED, "skip"); -}; +} sub get_filename { my $self = shift; @@ -201,25 +203,25 @@ sub get_filename { my $filename = $transaction->body_filename; - if ( ! $filename ) { - $self->log( LOGWARN, "Cannot process due to lack of filename" ); + if (!$filename) { + $self->log(LOGWARN, "Cannot process due to lack of filename"); return; } - if ( ! -f $filename ) { - $self->log( LOGERROR, "spool file missing! Attempting to respool" ); + if (!-f $filename) { + $self->log(LOGERROR, "spool file missing! Attempting to respool"); $transaction->body_spool; $filename = $transaction->body_filename; - if ( ! -f $filename ) { - $self->log( LOGERROR, "skip: failed spool to $filename! Giving up" ); + if (!-f $filename) { + $self->log(LOGERROR, "skip: failed spool to $filename! Giving up"); return; - }; + } my $size = (stat($filename))[7]; - $self->log( LOGDEBUG, "Spooled $size bytes to $filename" ); + $self->log(LOGDEBUG, "Spooled $size bytes to $filename"); } return $filename; -}; +} sub set_permission { my ($self, $filename) = @_; @@ -227,26 +229,28 @@ sub set_permission { # the spool directory must be readable and executable by the scanner; # this generally means either group or world exec; if # neither of these is set, issue a warning but try to proceed anyway - my $dir_mode = ( stat( $self->spool_dir() ) )[2]; - $self->log( LOGDEBUG, "spool dir mode: $dir_mode" ); + my $dir_mode = (stat($self->spool_dir()))[2]; + $self->log(LOGDEBUG, "spool dir mode: $dir_mode"); + + if ($dir_mode & 0010 || $dir_mode & 0001) { - if ( $dir_mode & 0010 || $dir_mode & 0001 ) { # match the spool file mode with the mode of the directory -- add # the read bit for group, world, or both, depending on what the # spool dir had, and strip all other bits, especially the sticky bit - my $fmode = ($dir_mode & 0044) | - ($dir_mode & 0010 ? 0040 : 0) | - ($dir_mode & 0001 ? 0004 : 0); + my $fmode = + ($dir_mode & 0044) | ($dir_mode & 0010 ? 0040 : 0) | + ($dir_mode & 0001 ? 0004 : 0); - unless ( chmod $fmode, $filename ) { - $self->log( LOGERROR, "chmod: $filename: $!" ); + unless (chmod $fmode, $filename) { + $self->log(LOGERROR, "chmod: $filename: $!"); return; } return 1; } - $self->log( LOGWARN, "spool directory permissions do not permit scanner access" ); + $self->log(LOGWARN, + "spool directory permissions do not permit scanner access"); return 1; -}; +} sub get_clamd { my $self = shift; @@ -254,34 +258,34 @@ sub get_clamd { my $port = $self->{'_args'}{'clamd_port'}; my $host = $self->{'_args'}{'clamd_host'} || 'localhost'; - if ( $port && $port =~ /^(\d+)/ ) { - return new ClamAV::Client( socket_host => $host, socket_port => $1 ); - }; + if ($port && $port =~ /^(\d+)/) { + return new ClamAV::Client(socket_host => $host, socket_port => $1); + } my $socket = $self->{'_args'}{'clamd_socket'}; - if ( $socket ) { - if ( $socket =~ /([\w\/.]+)/ ) { - return new ClamAV::Client( socket_name => $1 ); + if ($socket) { + if ($socket =~ /([\w\/.]+)/) { + return new ClamAV::Client(socket_name => $1); } - $self->log( LOGERROR, "invalid characters in socket name" ); + $self->log(LOGERROR, "invalid characters in socket name"); } return new ClamAV::Client; -}; +} sub is_too_big { my $self = shift; my $transaction = shift || $self->qp->transaction; my $size = $transaction->data_size; - if ( $size > $self->{_args}{max_size} * 1024 ) { - $self->log( LOGINFO, "skip, too big ($size)" ); + if ($size > $self->{_args}{max_size} * 1024) { + $self->log(LOGINFO, "skip, too big ($size)"); return 1; } - $self->log( LOGDEBUG, "data_size, $size" ); + $self->log(LOGDEBUG, "data_size, $size"); return; -}; +} sub is_not_multipart { my $self = shift; @@ -289,15 +293,15 @@ sub is_not_multipart { return if $self->{'_args'}{'scan_all'}; - return 1 if ! $transaction->header; + return 1 if !$transaction->header; # Ignore non-multipart emails my $content_type = $transaction->header->get('Content-Type') or return 1; $content_type =~ s/\s/ /g; - if ( $content_type !~ m!\bmultipart/.*\bboundary="?([^"]+)!i ) { - $self->log( LOGNOTICE, "skip, not multipart" ); + if ($content_type !~ m!\bmultipart/.*\bboundary="?([^"]+)!i) { + $self->log(LOGNOTICE, "skip, not multipart"); return 1; } return; -}; +} diff --git a/plugins/virus/hbedv b/plugins/virus/hbedv index 60e01de..856d4c6 100644 --- a/plugins/virus/hbedv +++ b/plugins/virus/hbedv @@ -49,110 +49,120 @@ Written by Hanno Hecker Ehah@uu-x.deE. The B plugin is published under the same licence as qpsmtpd itself. =cut - + sub register { - my ($self, $qp, @args) = @_; - - if (@args % 2) { - $self->log(LOGERROR, "FATAL ERROR: odd number of arguments"); - exit 3; - } - my %args = @args; - if (!exists $args{hbedvscanner}) { - $self->{_hbedvscan_loc} = "/usr/bin/antivir"; - } else { - if ($args{hbedvscanner} =~ /^(\/[\/\-\_\.a-z0-9A-Z]*)$/) { - $self->{_hbedvscan_loc} = $1; - } else { - $self->log(LOGERROR, "FATAL ERROR: Unexpected characters in hbedvscanner argument"); - exit 3; + my ($self, $qp, @args) = @_; + + if (@args % 2) { + $self->log(LOGERROR, "FATAL ERROR: odd number of arguments"); + exit 3; } - } -} - -sub hook_data_post { - my ($self, $transaction) = @_; - - my $filename = $transaction->body_filename; - unless (defined $filename) { - $self->log(LOGWARN, "didn't get a file name"); - return (DECLINED); - } - - # Now do the actual scanning! - my $cmd = $self->{_hbedvscan_loc}." --archive-max-recursion=50 --alltypes -z -noboot -nombr -rs $filename 2>&1"; - $self->log(LOGDEBUG, "Running: $cmd"); - my @output = `$cmd`; - - my $result = ($? >> 8); - my $signal = ($? & 127); - - chomp(@output); - my @virii = (); - foreach my $line (@output) { - next unless $line =~ /^ALERT: \[([^\]]+)\s+(\w+)?\]/; # $2 =~ /^(virus|worm)$/; - push @virii, $1; - } - @virii = unique(@virii); - - $self->log(LOGDEBUG, "results: ".join("//",@output)); - - if ($signal) { - $self->log(LOGWARN, "scanner exited with signal: $signal"); - return (DECLINED); - } - my $output = join(", ", @virii); - $output = substr($output, 0, 60); - if ($result == 1 || $result == 3) { - $self->log(LOGWARN, "Virus(es) found: $output"); - # return (DENY, "Virus Found: $output"); - # $transaction->header->add('X-Virus-Found', 'Yes', 0); - # $transaction->header->add('X-Virus-Details', $output, 0); - $transaction->header->add('X-H+BEDV-Virus-Found', 'Yes', 0); - $transaction->header->add('X-H+BEDV-Virus-Details', $output, 0); - } - elsif ($result == 200) { - $self->log(LOGWARN, "Program aborted, not enough memory available"); - } - elsif ($result == 211) { - $self->log(LOGWARN, "Programm aborted, because the self check failed"); - } - elsif ($result == 214) { - $self->log(LOGWARN, "License key not found"); - } - elsif ($result) { - $self->log(LOGWARN, "Error: $result, look for exit codes in the output of '" - .$self->{_hbedvscan_loc}." --help' for more info\n"); - } - - # $transaction->header->add('X-Virus-Checked', 'Checked', 0); - $transaction->header->add('X-H+BEDV-Virus-Checked', 'Checked', 0); - return (DECLINED) unless $result; - - if (@virii) { - return(DENY, "Virus found: $output") - unless $self->qp->config("hbedv_deny"); - foreach my $d ($self->qp->config("hbedv_deny")) { - foreach my $v (@virii) { - if ($v =~ /^$d$/i) { - $self->log(LOGWARN, "Denying mail with virus '$v'"); - return(DENY, "Virus found: $output"); + my %args = @args; + if (!exists $args{hbedvscanner}) { + $self->{_hbedvscan_loc} = "/usr/bin/antivir"; + } + else { + if ($args{hbedvscanner} =~ /^(\/[\/\-\_\.a-z0-9A-Z]*)$/) { + $self->{_hbedvscan_loc} = $1; + } + else { + $self->log(LOGERROR, + "FATAL ERROR: Unexpected characters in hbedvscanner argument"); + exit 3; } - } } - } - return (DECLINED); -} +} + +sub hook_data_post { + my ($self, $transaction) = @_; + + my $filename = $transaction->body_filename; + unless (defined $filename) { + $self->log(LOGWARN, "didn't get a file name"); + return (DECLINED); + } + + # Now do the actual scanning! + my $cmd = $self->{_hbedvscan_loc} + . " --archive-max-recursion=50 --alltypes -z -noboot -nombr -rs $filename 2>&1"; + $self->log(LOGDEBUG, "Running: $cmd"); + my @output = `$cmd`; + + my $result = ($? >> 8); + my $signal = ($? & 127); + + chomp(@output); + my @virii = (); + foreach my $line (@output) { + next + unless $line =~ + /^ALERT: \[([^\]]+)\s+(\w+)?\]/; # $2 =~ /^(virus|worm)$/; + push @virii, $1; + } + @virii = unique(@virii); + + $self->log(LOGDEBUG, "results: " . join("//", @output)); + + if ($signal) { + $self->log(LOGWARN, "scanner exited with signal: $signal"); + return (DECLINED); + } + my $output = join(", ", @virii); + $output = substr($output, 0, 60); + if ($result == 1 || $result == 3) { + $self->log(LOGWARN, "Virus(es) found: $output"); + + # return (DENY, "Virus Found: $output"); + # $transaction->header->add('X-Virus-Found', 'Yes', 0); + # $transaction->header->add('X-Virus-Details', $output, 0); + $transaction->header->add('X-H+BEDV-Virus-Found', 'Yes', 0); + $transaction->header->add('X-H+BEDV-Virus-Details', $output, 0); + } + elsif ($result == 200) { + $self->log(LOGWARN, "Program aborted, not enough memory available"); + } + elsif ($result == 211) { + $self->log(LOGWARN, "Programm aborted, because the self check failed"); + } + elsif ($result == 214) { + $self->log(LOGWARN, "License key not found"); + } + elsif ($result) { + $self->log(LOGWARN, + "Error: $result, look for exit codes in the output of '" + . $self->{_hbedvscan_loc} + . " --help' for more info\n" + ); + } + + # $transaction->header->add('X-Virus-Checked', 'Checked', 0); + $transaction->header->add('X-H+BEDV-Virus-Checked', 'Checked', 0); + return (DECLINED) unless $result; + + if (@virii) { + return (DENY, "Virus found: $output") + unless $self->qp->config("hbedv_deny"); + foreach my $d ($self->qp->config("hbedv_deny")) { + foreach my $v (@virii) { + if ($v =~ /^$d$/i) { + $self->log(LOGWARN, "Denying mail with virus '$v'"); + return (DENY, "Virus found: $output"); + } + } + } + } + return (DECLINED); +} sub unique { - ## This is the short version, I haven't tried if any warnings - ## are generated by perl if you use just this... if you need - ## every cpu cycle, try this: - ## my %h;foreach (@_) { ++$h{$_}; }; return keys(%h); - my @list = @_; - my %hash; - foreach my $item (@list) { - exists $hash{$item} || ($hash{$item} = 1); - } - return keys(%hash) + ## This is the short version, I haven't tried if any warnings + ## are generated by perl if you use just this... if you need + ## every cpu cycle, try this: + ## my %h;foreach (@_) { ++$h{$_}; }; return keys(%h); + my @list = @_; + my %hash; + foreach my $item (@list) { + exists $hash{$item} || ($hash{$item} = 1); + } + return keys(%hash); } diff --git a/plugins/virus/kavscanner b/plugins/virus/kavscanner index 92a1bd5..993f21d 100644 --- a/plugins/virus/kavscanner +++ b/plugins/virus/kavscanner @@ -54,123 +54,139 @@ B option. use File::Temp qw(tempfile); use Mail::Address; - + sub register { - my ($self, $qp, @args) = @_; + my ($self, $qp, @args) = @_; - if (@args % 2) { - $self->log(LOGWARN, "kavscanner: Wrong number of arguments"); - $self->{_kavscanner_bin} = "/opt/AVP/kavscanner"; - } else { - my %args = @args; - foreach my $key (keys %args) { - my $arg = $key; - $key =~ s/^/_/; - $self->{$key} = $args{$arg}; + if (@args % 2) { + $self->log(LOGWARN, "kavscanner: Wrong number of arguments"); + $self->{_kavscanner_bin} = "/opt/AVP/kavscanner"; } - # Untaint scanner location - if (exists $self->{_kavscanner_bin} && - $self->{_kavscanner_bin} =~ /^(\/[\/\-\_\.a-z0-9A-Z]*)$/) { - $self->{_kavscanner_bin} = $1; - } else { - $self->log(LOGALERT, "FATAL ERROR: Unexpected characters in kavscanner argument"); - exit 3; + else { + my %args = @args; + foreach my $key (keys %args) { + my $arg = $key; + $key =~ s/^/_/; + $self->{$key} = $args{$arg}; + } + + # Untaint scanner location + if (exists $self->{_kavscanner_bin} + && $self->{_kavscanner_bin} =~ /^(\/[\/\-\_\.a-z0-9A-Z]*)$/) + { + $self->{_kavscanner_bin} = $1; + } + else { + $self->log(LOGALERT, + "FATAL ERROR: Unexpected characters in kavscanner argument"); + exit 3; + } } - } } - + sub hook_data_post { - my ($self, $transaction) = @_; - - my ($temp_fh, $filename) = tempfile(); - print $temp_fh $transaction->header->as_string; - print $temp_fh "\n"; - $transaction->body_resetpos; - while (my $line = $transaction->body_getline) { - print $temp_fh $line; - } - seek($temp_fh, 0, 0); - - # Now do the actual scanning! - my $cmd = $self->{_kavscanner_bin}." -Y -P -B -MP -MD -* $filename 2>&1"; - $self->log(LOGNOTICE, "Running: $cmd"); - my @output = `$cmd`; - chomp(@output); - - my $result = ($? >> 8); - my $signal = ($? & 127); - - unlink($filename); - close $temp_fh; + my ($self, $transaction) = @_; - if ($signal) { - $self->log(LOGWARN, "kavscanner exited with signal: $signal"); - return (DECLINED); - } - - my $description = 'clean'; - my @infected = (); - my @suspicious = (); - if ($result > 0) { - if ($result =~ /^(2|3|4|8)$/) { - foreach (@output) { - if (/^.* infected: (.*)$/) { - # This covers the specific - push @infected, $1; - } elsif (/^\s*.* suspicion: (.*)$/) { - # This covers the potential viruses - push @suspicious, $1; - } - } - $description = "infected by: ".join(", ",@infected)."; " - ."suspicions: ".join(", ", @suspicious); - # else we may get a veeeery long X-Virus-Details: line or log entry - $description = substr($description,0,60); - $self->log(LOGWARN, "There be a virus! ($description)"); - ### Untested by now, need volunteers ;-) - #if ($self->qp->config("kav_deny")) { - # foreach my $d (keys %{$self->qp->config("kav_deny", "map")}) { - # foreach my $v (@infected) { - # return(DENY, "Virus found: $description") - # if ($v =~ /^$d$/i); - # } - # foreach my $s (@suspicious) { - # return(DENY, "Virus found: $description") - # if ($s =~ /^$d$/i); - # } - # } - #} - $transaction->header->add('X-Virus-Found', 'Yes'); - $transaction->header->add('X-Virus-Details', $description); - ### maybe the spamassassin plugin can skip this mail if a virus - ### was found (and $transaction->notes('virus_flag') exists :)) - ### ...ok, works with our spamassassin plugin version - ### -- hah - $transaction->notes('virus', $description); - $transaction->notes('virus_flag', 'Yes'); - - #### requires modification of Qpsmtpd/Transaction.pm: - # if ($self->{_to_virusadmin}) { - # my @addrs = (); - # foreach (@{$transaction->recipients}) { - # push @addr, $_->address; - # } - # $transaction->header->add('X-Virus-Orig-RcptTo', join(", ", @addrs)); - # $transaction->set_recipients(@{ Mail::Address->parse($self->{_to_virusadmin}) }); - # } elsif ($self->{_bcc_virusadmin}) { - if ($self->{_bcc_virusadmin}) { - foreach ( @{ Mail::Address->parse($self->{_bcc_virusadmin}) } ) { - $transaction->add_recipient($_); - } - } - } else { - $self->log(LOGEMERG, "corrupt or unknown Kaspersky scanner/resource problems - exit status $result"); + my ($temp_fh, $filename) = tempfile(); + print $temp_fh $transaction->header->as_string; + print $temp_fh "\n"; + $transaction->body_resetpos; + while (my $line = $transaction->body_getline) { + print $temp_fh $line; } - } - - $self->log(LOGINFO, "kavscanner results: $description"); - - $transaction->header->add('X-Virus-Checked', 'Checked by '.$self->qp->config("me")); - return (DECLINED); -} + seek($temp_fh, 0, 0); + + # Now do the actual scanning! + my $cmd = $self->{_kavscanner_bin} . " -Y -P -B -MP -MD -* $filename 2>&1"; + $self->log(LOGNOTICE, "Running: $cmd"); + my @output = `$cmd`; + chomp(@output); + + my $result = ($? >> 8); + my $signal = ($? & 127); + + unlink($filename); + close $temp_fh; + + if ($signal) { + $self->log(LOGWARN, "kavscanner exited with signal: $signal"); + return (DECLINED); + } + + my $description = 'clean'; + my @infected = (); + my @suspicious = (); + if ($result > 0) { + if ($result =~ /^(2|3|4|8)$/) { + foreach (@output) { + if (/^.* infected: (.*)$/) { + + # This covers the specific + push @infected, $1; + } + elsif (/^\s*.* suspicion: (.*)$/) { + + # This covers the potential viruses + push @suspicious, $1; + } + } + $description = + "infected by: " + . join(", ", @infected) . "; " + . "suspicions: " + . join(", ", @suspicious); + + # else we may get a veeeery long X-Virus-Details: line or log entry + $description = substr($description, 0, 60); + $self->log(LOGWARN, "There be a virus! ($description)"); + ### Untested by now, need volunteers ;-) + #if ($self->qp->config("kav_deny")) { + # foreach my $d (keys %{$self->qp->config("kav_deny", "map")}) { + # foreach my $v (@infected) { + # return(DENY, "Virus found: $description") + # if ($v =~ /^$d$/i); + # } + # foreach my $s (@suspicious) { + # return(DENY, "Virus found: $description") + # if ($s =~ /^$d$/i); + # } + # } + #} + $transaction->header->add('X-Virus-Found', 'Yes'); + $transaction->header->add('X-Virus-Details', $description); + ### maybe the spamassassin plugin can skip this mail if a virus + ### was found (and $transaction->notes('virus_flag') exists :)) + ### ...ok, works with our spamassassin plugin version + ### -- hah + $transaction->notes('virus', $description); + $transaction->notes('virus_flag', 'Yes'); + + #### requires modification of Qpsmtpd/Transaction.pm: +# if ($self->{_to_virusadmin}) { +# my @addrs = (); +# foreach (@{$transaction->recipients}) { +# push @addr, $_->address; +# } +# $transaction->header->add('X-Virus-Orig-RcptTo', join(", ", @addrs)); +# $transaction->set_recipients(@{ Mail::Address->parse($self->{_to_virusadmin}) }); +# } elsif ($self->{_bcc_virusadmin}) { + if ($self->{_bcc_virusadmin}) { + foreach (@{Mail::Address->parse($self->{_bcc_virusadmin})}) { + $transaction->add_recipient($_); + } + } + } + else { + $self->log(LOGEMERG, +"corrupt or unknown Kaspersky scanner/resource problems - exit status $result" + ); + } + } + + $self->log(LOGINFO, "kavscanner results: $description"); + + $transaction->header->add('X-Virus-Checked', + 'Checked by ' . $self->qp->config("me")); + return (DECLINED); +} diff --git a/plugins/virus/klez_filter b/plugins/virus/klez_filter index 8a977fc..e45a7aa 100644 --- a/plugins/virus/klez_filter +++ b/plugins/virus/klez_filter @@ -1,34 +1,36 @@ #!perl -w sub hook_data_post { - my ($self, $transaction) = @_; + my ($self, $transaction) = @_; - # klez files are always sorta big .. how big? Dunno. - return (DECLINED) - if $transaction->data_size < 60_000; - # 220k was too little, so let's just disable the "big size check" - # or $transaction->data_size > 1_000_000; + # klez files are always sorta big .. how big? Dunno. + return (DECLINED) + if $transaction->data_size < 60_000; - # maybe it would be worthwhile to add a check for - # Content-Type: multipart/alternative; here? + # 220k was too little, so let's just disable the "big size check" + # or $transaction->data_size > 1_000_000; - # make sure we read from the beginning; - $transaction->body_resetpos; - - my $line_number = 0; - my $seen_klez_signature = 0; + # maybe it would be worthwhile to add a check for + # Content-Type: multipart/alternative; here? - while ($_ = $transaction->body_getline) { - last if $line_number++ > 40; + # make sure we read from the beginning; + $transaction->body_resetpos; - m/^Content-type:.*(?:audio|application)/i - and ++$seen_klez_signature and next; + my $line_number = 0; + my $seen_klez_signature = 0; - return (DENY, "Klez Virus Detected") - if $seen_klez_signature - and m!^TVqQAAMAAAAEAAAA//8AALgAAAAAAAAAQA!; + while ($_ = $transaction->body_getline) { + last if $line_number++ > 40; - } + m/^Content-type:.*(?:audio|application)/i + and ++$seen_klez_signature + and next; - return (DECLINED); + return (DENY, "Klez Virus Detected") + if $seen_klez_signature + and m!^TVqQAAMAAAAEAAAA//8AALgAAAAAAAAAQA!; + + } + + return (DECLINED); } diff --git a/plugins/virus/sophie b/plugins/virus/sophie index 6fc0f52..e84dd38 100644 --- a/plugins/virus/sophie +++ b/plugins/virus/sophie @@ -2,9 +2,9 @@ use IO::Socket; sub register { - my ( $self, $qp, @args ) = @_; + my ($self, $qp, @args) = @_; - %{ $self->{"_sophie"} } = @args; + %{$self->{"_sophie"}} = @args; # Set some sensible defaults $self->{"_sophie"}->{"sophie_socket"} ||= "/var/run/sophie"; @@ -13,68 +13,66 @@ sub register { } sub hook_data_post { - my ( $self, $transaction ) = @_; + my ($self, $transaction) = @_; $DB::single = 1; - if ( $transaction->data_size > $self->{"_sophie"}->{"max_size"} * 1024 ) { - $self->log( LOGNOTICE, "Declining due to data_size" ); + if ($transaction->data_size > $self->{"_sophie"}->{"max_size"} * 1024) { + $self->log(LOGNOTICE, "Declining due to data_size"); return (DECLINED); } # Ignore non-multipart emails my $content_type = $transaction->header->get('Content-Type'); $content_type =~ s/\s/ /g if defined $content_type; - unless ( $content_type - && $content_type =~ m!\bmultipart/.*\bboundary="?([^"]+)!i ) + unless ( $content_type + && $content_type =~ m!\bmultipart/.*\bboundary="?([^"]+)!i) { - $self->log( LOGWARN, "non-multipart mail - skipping" ); + $self->log(LOGWARN, "non-multipart mail - skipping"); return DECLINED; } my $filename = $transaction->body_filename; unless ($filename) { - $self->log( LOGWARN, "Cannot process due to lack of filename" ); + $self->log(LOGWARN, "Cannot process due to lack of filename"); return (DECLINED); # unless $filename; } - my $mode = ( stat( $self->spool_dir() ) )[2]; - if ( $mode & 07077 ) { # must be sharing spool directory with external app - $self->log( LOGWARN, - "Changing permissions on file to permit scanner access" ); + my $mode = (stat($self->spool_dir()))[2]; + if ($mode & 07077) { # must be sharing spool directory with external app + $self->log(LOGWARN, + "Changing permissions on file to permit scanner access"); chmod $mode, $filename; } my ($SOPHIE, $response); socket(\*SOPHIE, AF_UNIX, SOCK_STREAM, 0) - || die "Couldn't create socket ($!)\n"; + || die "Couldn't create socket ($!)\n"; connect(\*SOPHIE, pack_sockaddr_un $self->{"_sophie"}->{"sophie_socket"}) - || die "Couldn't connect() to the socket ($!)\n"; + || die "Couldn't connect() to the socket ($!)\n"; - syswrite(\*SOPHIE, $filename."\n", length($filename)+1); - sysread(\*SOPHIE, $response, 256); - close (\*SOPHIE); + syswrite(\*SOPHIE, $filename . "\n", length($filename) + 1); + sysread(\*SOPHIE, $response, 256); + close(\*SOPHIE); my $virus; - if ( ($virus) = ( $response =~ m/^1:?(.*)?$/ ) ) { - $self->log( LOGERROR, "One or more virus(es) found: $virus" ); + if (($virus) = ($response =~ m/^1:?(.*)?$/)) { + $self->log(LOGERROR, "One or more virus(es) found: $virus"); - if ( lc( $self->{"_sophie"}->{"deny_viruses"} ) eq "yes" ) { - return ( DENY, - "Virus" - . ( $virus =~ /,/ ? "es " : " " ) - . "Found: $virus" ); + if (lc($self->{"_sophie"}->{"deny_viruses"}) eq "yes") { + return (DENY, + "Virus" . ($virus =~ /,/ ? "es " : " ") . "Found: $virus"); } else { - $transaction->header->add( 'X-Virus-Found', 'Yes' ); - $transaction->header->add( 'X-Virus-Details', $virus ); + $transaction->header->add('X-Virus-Found', 'Yes'); + $transaction->header->add('X-Virus-Details', $virus); return (DECLINED); } } - $transaction->header->add( 'X-Virus-Checked', - "Checked by SOPHIE on " . $self->qp->config("me") ); + $transaction->header->add('X-Virus-Checked', + "Checked by SOPHIE on " . $self->qp->config("me")); return (DECLINED); } diff --git a/plugins/virus/uvscan b/plugins/virus/uvscan index 8faa531..eab7bfa 100644 --- a/plugins/virus/uvscan +++ b/plugins/virus/uvscan @@ -44,91 +44,99 @@ Please see the LICENSE file included with qpsmtpd for details. =cut sub register { - my ($self, $qp, @args) = @_; + my ($self, $qp, @args) = @_; - while (@args) { - $self->{"_uvscan"}->{pop @args}=pop @args; - } - $self->{"_uvscan"}->{"uvscan_location"}||="/usr/local/bin/uvscan"; + while (@args) { + $self->{"_uvscan"}->{pop @args} = pop @args; + } + $self->{"_uvscan"}->{"uvscan_location"} ||= "/usr/local/bin/uvscan"; } - + sub hook_data_post { - my ($self, $transaction) = @_; - - return (DECLINED) - if $transaction->data_size > 250_000; + my ($self, $transaction) = @_; - # Ignore non-multipart emails - my $content_type = $transaction->header->get('Content-Type'); - $content_type =~ s/\s/ /g if defined $content_type; - unless ( $content_type - && $content_type =~ m!\bmultipart/.*\bboundary="?([^"]+)!i ) - { - $self->log( LOGWARN, "non-multipart mail - skipping" ); - return DECLINED; - } + return (DECLINED) + if $transaction->data_size > 250_000; - my $filename = $transaction->body_filename; - return (DECLINED) unless $filename; - - # Now do the actual scanning! - my @cmd =($self->{"_uvscan"}->{"uvscan_location"}, - '--mime', '--unzip', '--secure', '--noboot', - $filename, '2>&1 |'); - $self->log(LOGINFO, "Running: ",join(' ', @cmd)); - open(FILE, join(' ', @cmd)); #perl 5.6 doesn't properly support the pipe - # mode list form of open, but this is basically the same thing. This form - # of exec is safe(ish). - my $output; - while () { $output.=$_; } - close FILE; - - my $result = ($? >> 8); - my $signal = ($? & 127); - - my $virus; - if ($output && $output =~ m/.*\W+Found (.*)\n/m) { - $virus=$1; - } - if ($output && $output =~ m/password-protected/m) { - return (DENY, 'We do not accept password-protected zip files!'); - } - - if ($signal) { - $self->log(LOGWARN, "uvscan exited with signal: $signal"); - return (DECLINED); - } - if ($result == 2) { - $self->log(LOGERROR, "Integrity check for a DAT file failed."); - return (DECLINED); - } elsif ($result == 6) { - $self->log(LOGERROR, "A general problem has occurred."); - return (DECLINED); - } elsif ($result == 8) { - $self->log(LOGERROR, "The program could not find a DAT file."); - return (DECLINED); - } elsif ($result == 15) { - $self->log(LOGERROR, "The program self-check failed"); - return (DECLINED); - } elsif ( $result ) { # all of the possible virus returns - if ($result == 12) { - $self->log(LOGERROR, "The program tried to clean a file but failed."); - } elsif ($result == 13) { - $self->log(LOGERROR, "One or more virus(es) found"); - } elsif ($result == 19) { - $self->log(LOGERROR, "Successfully cleaned the file"); + # Ignore non-multipart emails + my $content_type = $transaction->header->get('Content-Type'); + $content_type =~ s/\s/ /g if defined $content_type; + unless ( $content_type + && $content_type =~ m!\bmultipart/.*\bboundary="?([^"]+)!i) + { + $self->log(LOGWARN, "non-multipart mail - skipping"); + return DECLINED; } - if (lc($self->{"_uvscan"}->{"deny_viruses"}) eq "yes") { - return (DENY, "Virus Found: $virus"); - } - $transaction->header->add('X-Virus-Found', 'Yes'); - $transaction->header->add('X-Virus-Details', $virus); - return (DECLINED); - } - - $transaction->header->add('X-Virus-Checked', - "Checked by McAfee uvscan on ".$self->qp->config("me")); + my $filename = $transaction->body_filename; + return (DECLINED) unless $filename; - return (DECLINED); -} + # Now do the actual scanning! + my @cmd = ( + $self->{"_uvscan"}->{"uvscan_location"}, + '--mime', '--unzip', '--secure', '--noboot', $filename, '2>&1 |' + ); + $self->log(LOGINFO, "Running: ", join(' ', @cmd)); + open(FILE, join(' ', @cmd)); #perl 5.6 doesn't properly support the pipe + # mode list form of open, but this is basically the same thing. This form + # of exec is safe(ish). + my $output; + while () { $output .= $_; } + close FILE; + + my $result = ($? >> 8); + my $signal = ($? & 127); + + my $virus; + if ($output && $output =~ m/.*\W+Found (.*)\n/m) { + $virus = $1; + } + if ($output && $output =~ m/password-protected/m) { + return (DENY, 'We do not accept password-protected zip files!'); + } + + if ($signal) { + $self->log(LOGWARN, "uvscan exited with signal: $signal"); + return (DECLINED); + } + if ($result == 2) { + $self->log(LOGERROR, "Integrity check for a DAT file failed."); + return (DECLINED); + } + elsif ($result == 6) { + $self->log(LOGERROR, "A general problem has occurred."); + return (DECLINED); + } + elsif ($result == 8) { + $self->log(LOGERROR, "The program could not find a DAT file."); + return (DECLINED); + } + elsif ($result == 15) { + $self->log(LOGERROR, "The program self-check failed"); + return (DECLINED); + } + elsif ($result) { # all of the possible virus returns + if ($result == 12) { + $self->log(LOGERROR, + "The program tried to clean a file but failed."); + } + elsif ($result == 13) { + $self->log(LOGERROR, "One or more virus(es) found"); + } + elsif ($result == 19) { + $self->log(LOGERROR, "Successfully cleaned the file"); + } + + if (lc($self->{"_uvscan"}->{"deny_viruses"}) eq "yes") { + return (DENY, "Virus Found: $virus"); + } + $transaction->header->add('X-Virus-Found', 'Yes'); + $transaction->header->add('X-Virus-Details', $virus); + return (DECLINED); + } + + $transaction->header->add('X-Virus-Checked', + "Checked by McAfee uvscan on " . $self->qp->config("me")); + + return (DECLINED); +} diff --git a/plugins/whitelist b/plugins/whitelist index 76797ce..1ccdbae 100644 --- a/plugins/whitelist +++ b/plugins/whitelist @@ -139,7 +139,7 @@ sub check_host { if (exists $ENV{WHITELISTCLIENT}) { $self->qp->connection->notes('whitelistclient', 1); $self->log(2, "pass, is whitelisted client"); - $self->adjust_karma( 5 ); + $self->adjust_karma(5); return OK; } @@ -148,7 +148,7 @@ sub check_host { if ($h eq $ip or $ip =~ /^\Q$h\E/) { $self->qp->connection->notes('whitelisthost', 1); $self->log(2, "pass, is a whitelisted host"); - $self->adjust_karma( 5 ); + $self->adjust_karma(5); return OK; } }