File: //usr/share/perl5/vendor_perl/Amavis/SpamControl.pm
# SPDX-License-Identifier: GPL-2.0-or-later
package Amavis::SpamControl;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';
use Fcntl qw(:flock);
use IO::File qw(O_RDONLY O_WRONLY O_RDWR O_APPEND O_CREAT O_EXCL);
use Amavis::Lookup::Label;
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
$VERSION = '2.412';
@ISA = qw(Exporter);
}
use Amavis::Conf qw(:platform c cr ca);
use Amavis::Lookup qw(lookup lookup2);
use Amavis::Lookup::SQLfield;
use Amavis::rfc2821_2822_Tools qw(make_query_keys qquote_rfc2821_local);
use Amavis::Util qw(ll do_log min max minmax untaint untaint_inplace
unique_list);
sub new {
my $class = $_[0];
my $self = bless { scanners_list => [] }, $class;
for my $as (@{ca('spam_scanners')}) {
if (ref $as && defined $as->[1] && $as->[1] ne '') {
my($scanner_name,$module,@args) = @$as; my $scanner_obj;
do_log(5, "SpamControl: attempting to load scanner %s, module %s",
$scanner_name,$module);
{ no strict 'subs';
$scanner_obj = $module->new($scanner_name,$module,@args);
}
if ($scanner_obj) {
push(@{$self->{scanners_list}}, [$scanner_obj, @$as]);
do_log(2, "SpamControl: scanner %s, module %s",
$scanner_name,$module);
} else {
do_log(5, "SpamControl: no scanner %s, module %s",
$scanner_name,$module);
}
}
}
$self;
}
# called at startup, before chroot and before main fork
#
sub init_pre_chroot {
my $self = $_[0];
for my $as (@{$self->{scanners_list}}) {
my($scanner_obj,$scanner_name) = @$as;
if ($scanner_obj && $scanner_obj->UNIVERSAL::can('init_pre_chroot')) {
$scanner_obj->init_pre_chroot;
do_log(1, "SpamControl: init_pre_chroot on %s done", $scanner_name);
}
}
}
# called at startup, after chroot and changing UID, but before main fork
#
sub init_pre_fork {
my $self = $_[0];
for my $as (@{$self->{scanners_list}}) {
my($scanner_obj,$scanner_name) = @$as;
if ($scanner_obj && $scanner_obj->UNIVERSAL::can('init_pre_fork')) {
$scanner_obj->init_pre_fork;
do_log(1, "SpamControl: init_pre_fork on %s done", $scanner_name);
}
}
}
# called during child process initialization
#
sub init_child {
my $self = $_[0];
my $failure_msg;
for my $as (@{$self->{scanners_list}}) {
my($scanner_obj,$scanner_name) = @$as;
if ($scanner_obj && $scanner_obj->UNIVERSAL::can('init_child')) {
eval {
$scanner_obj->init_child;
do_log(5, "SpamControl: init_child on %s done", $scanner_name);
1;
} or do {
my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
do_log(-1, "init_child on spam scanner %s failed: %s",
$scanner_name, $eval_stat);
$failure_msg = "init_child $scanner_name failed: $eval_stat"
if !defined $failure_msg;
};
}
}
if (defined $failure_msg) { die $failure_msg }
}
sub lock {
my($self,$scanner_obj,$lock_type_name) = @_;
my $lock_file = $scanner_obj->{options}->{'lock_file'};
if (defined $lock_file && $lock_file ne '') {
my $lock_type = $scanner_obj->{options}->{$lock_type_name};
$lock_type = $scanner_obj->{options}->{'lock_type'} if !defined $lock_type;
$lock_type = 'exclusive' if !defined $lock_type;
if ($lock_type ne '' && lc($lock_type) ne 'none') {
my $lock_fh = IO::File->new;
$lock_fh->open($lock_file, O_CREAT|O_RDWR, 0640)
or die "Can't open a lock file $lock_file: $!";
$scanner_obj->{lock_fh} = $lock_fh;
my $lock_type_displ;
if (defined $lock_type && lc($lock_type) eq 'shared') {
$lock_type = LOCK_SH; $lock_type_displ = 'a shared';
} else {
$lock_type = LOCK_EX; $lock_type_displ = 'an exclusive';
}
do_log(5,"acquring %s lock on %s for %s",
$lock_type_displ, $lock_file, $scanner_obj->{scanner_name});
flock($lock_fh, $lock_type)
or die "Can't acquire $lock_type_displ lock on $lock_file: $!";
}
}
}
sub unlock {
my($self,$scanner_obj) = @_;
my $lock_fh = $scanner_obj->{lock_fh};
if ($lock_fh) {
my $scanner_name = $scanner_obj->{scanner_name};
do_log(5, "releasing a lock for %s", $scanner_name);
# close would unlock automatically, but let's check for locking mistakes
flock($lock_fh, LOCK_UN)
or die "Can't release a lock for $scanner_name: $!";
$lock_fh->close or die "Can't close a lock file for $scanner_name: $!";
undef $scanner_obj->{lock_fh};
}
}
# actual spam checking for every message
#
sub spam_scan {
my($self,$msginfo) = @_;
my $failure_msg;
for my $as (@{$self->{scanners_list}}) {
my($scanner_obj,$scanner_name) = @$as;
next if !$scanner_obj && !$scanner_obj->UNIVERSAL::can('check');
do_log(5, "SpamControl: calling spam scanner %s", $scanner_name);
$self->lock($scanner_obj, 'classifier_lock_type');
eval {
$scanner_obj->check($msginfo); 1;
} or do {
my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
do_log(-1, "checking with spam scanner %s failed: %s",
$scanner_name, $eval_stat);
$failure_msg =
"$scanner_name failed: $eval_stat" if !defined $failure_msg;
};
$self->unlock($scanner_obj);
}
if (defined $failure_msg) { die $failure_msg }
1;
}
sub auto_learn {
my($self,$msginfo) = @_;
my $failure_msg;
for my $as (@{$self->{scanners_list}}) {
my($scanner_obj,$scanner_name) = @$as;
next if !$scanner_obj || !$scanner_obj->UNIVERSAL::can('auto_learn');
next if !$scanner_obj->UNIVERSAL::can('can_auto_learn') ||
!$scanner_obj->can_auto_learn;
# learn-on-error logic: what was the final outcome
my($min_spam_level, $max_spam_level) =
minmax(map($_->spam_level, @{$msginfo->per_recip_data}));
next if !defined $min_spam_level || !defined $max_spam_level;
# learn-on-error logic: what this scanner thinks
my $my_verdict = $msginfo->supplementary_info('VERDICT-'.$scanner_name);
$my_verdict = !defined $my_verdict ? '' : lc $my_verdict;
my $my_score = $msginfo->supplementary_info('SCORE-'.$scanner_name);
$my_score = 0 if !defined $my_score;
# learn-on-error logic: opinions differ?
my $learn_as; # leaving out a contribution by this spam scanner
if ($my_verdict ne 'ham' && $max_spam_level-$my_score < 0.5) {
$learn_as = 'ham';
} elsif ($my_verdict ne 'spam' && $min_spam_level-$my_score >= 5) {
$learn_as = 'spam';
}
next if !defined $learn_as;
ll(2) && do_log(2,
"SpamControl: scanner %s, auto-learn as %s / %.3f (was: %s / %s)",
$scanner_name, $learn_as,
$my_verdict ne 'ham' ? $max_spam_level : $min_spam_level,
$my_verdict, !$my_score ? '0' : sprintf("%.3f",$my_score));
$self->lock($scanner_obj, 'learner_lock_type');
eval {
$scanner_obj->auto_learn($msginfo,$learn_as); 1;
} or do {
my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
do_log(-1, "auto-learning with spam scanner %s failed: %s",
$scanner_name, $eval_stat);
$failure_msg =
"$scanner_name failed: $eval_stat" if !defined $failure_msg;
};
$self->unlock($scanner_obj);
}
if (defined $failure_msg) { die $failure_msg }
1;
}
# called during child process shutdown
#
sub rundown_child() {
my $self = $_[0];
for my $as (@{$self->{scanners_list}}) {
my($scanner_obj,$scanner_name) = @$as;
if ($scanner_obj && $scanner_obj->UNIVERSAL::can('rundown_child')) {
eval {
$scanner_obj->rundown_child;
do_log(5, "SpamControl: rundown_child on %s done", $scanner_name);
1;
} or do {
my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
do_log(-1, "rundown_child on spam scanner %s failed: %s",
$scanner_name, $eval_stat);
};
}
}
}
# check envelope sender and author for white or blacklisting by each recipient;
# Saves the result in recip_blacklisted_sender and recip_whitelisted_sender
# properties of each recipient object, and updates spam score for each
# recipient according to soft-w/b-listing.
#
sub white_black_list($$$$) {
my($msginfo,$sql_wblist,$user_id_sql,$ldap_lookups) = @_;
my $fm = $msginfo->rfc2822_from;
my(@rfc2822_from) = !defined($fm) ? () : ref $fm ? @$fm : $fm;
my(@senders) = ($msginfo->sender, @rfc2822_from);
@senders = unique_list(\@senders); # remove possible duplicates
ll(4) && do_log(4,"wbl: checking sender %s",
scalar(qquote_rfc2821_local(@senders)));
my($any_w,$any_b,$all,$wr,$br);
$any_w = 0; $any_b = 0; $all = 1;
for my $r (@{$msginfo->per_recip_data}) { # for each recipient
next if $r->recip_done; # already dealt with
my($wb,$boost); my $found = 0; my $recip = $r->recip_addr;
my($user_id_ref,$mk_ref);
$user_id_ref = $r->user_id;
$user_id_ref = [] if !defined $user_id_ref;
do_log(5,"wbl: (SQL) recip <%s>, %s matches",
$recip, scalar(@$user_id_ref)) if $sql_wblist && ll(5);
for my $sender (@senders) {
for my $ind (0..$#{$user_id_ref}) { # for ALL SQL sets matching the recip
my $user_id = $user_id_ref->[$ind]; my $mkey;
($wb,$mkey) = lookup(0,$sender,
Amavis::Lookup::SQLfield->new($sql_wblist,'wb','S',$user_id) );
do_log(4,'wbl: (SQL) recip <%s>, rid=%s, got: "%s"',
$recip,$user_id,$wb);
if (!defined($wb)) {
# NULL field or no match: remains undefined
} elsif ($wb =~ /^ *([+-]?\d+(?:\.\d*)?) *\z/) { # numeric
my $val = 0+$1; # penalty points to be added to the score
$boost += $val;
ll(2) && do_log(2,
'wbl: (SQL) soft-%slisted (%s) sender <%s> => <%s> (rid=%s)',
($val<0?'white':'black'), $val, $sender, $recip, $user_id);
$wb = undef; # not hard- white or blacklisting, does not exit loop
} elsif ($wb =~ /^[ \000]*\z/) { # neutral, stops the search
$found=1; $wb = 0;
do_log(5, 'wbl: (SQL) recip <%s> is neutral to sender <%s>',
$recip,$sender);
} elsif ($wb =~ /^([BbNnFf])[ ]*\z/) { # blacklisted (B,N(o), F(alse))
$found=1; $wb = -1; $any_b++; $br = $recip;
$r->recip_blacklisted_sender(1);
do_log(5, 'wbl: (SQL) recip <%s> blacklisted sender <%s>',
$recip,$sender);
} else { # whitelisted (W, Y(es), T(true), or anything else)
if ($wb =~ /^([WwYyTt])[ ]*\z/) {
do_log(5, 'wbl: (SQL) recip <%s> whitelisted sender <%s>',
$recip,$sender);
} else {
do_log(-1,'wbl: (SQL) recip <%s> whitelisted sender <%s>, '.
'unexpected wb field value: "%s"', $recip,$sender,$wb);
}
$found=1; $wb = +1; $any_w++; $wr = $recip;
$r->recip_whitelisted_sender(1);
}
last if $found;
}
if (!$found && $ldap_lookups && c('enable_ldap')) { # LDAP queries
my $wblist;
my($keys_ref,$rhs_ref) = make_query_keys($sender,0,0);
my(@keys) = @$keys_ref;
unshift(@keys, '<>') if $sender eq ''; # a hack for a null return path
untaint_inplace($_) for @keys; # untaint keys
$_ = Net::LDAP::Util::escape_filter_value($_) for @keys;
do_log(5,'wbl: (LDAP) query keys: %s', join(', ',map("\"$_\"",@keys)));
$wblist = lookup(0,$recip,Amavis::Lookup::LDAPattr->new(
$ldap_lookups, 'amavisBlacklistSender', 'L-'));
for my $key (@keys) {
if (grep(lc($_) eq lc($key), @$wblist)) {
$found=1; $wb = -1; $br = $recip; $any_b++;
$r->recip_blacklisted_sender(1);
do_log(5,'wbl: (LDAP) recip <%s> blacklisted sender <%s>',
$recip,$sender);
}
}
$wblist = lookup(0,$recip,Amavis::Lookup::LDAPattr->new(
$ldap_lookups, 'amavisWhitelistSender', 'L-'));
for my $key (@keys) {
if (grep(lc($_) eq lc($key), @$wblist)) {
$found=1; $wb = +1; $wr = $recip; $any_w++;
$r->recip_whitelisted_sender(1);
do_log(5,'wbl: (LDAP) recip <%s> whitelisted sender <%s>',
$recip,$sender);
}
}
}
if (!$found) { # fall back to static lookups if no match
# sender can be both white- and blacklisted at the same time
my($val, $r_ref, $mk_ref, @t);
# NOTE on the specifics of $per_recip_blacklist_sender_lookup_tables :
# the $r_ref below is supposed to be a ref to a single lookup table
# for compatibility with pre-2.0 versions of amavisd-new;
# Note that this is different from @score_sender_maps, which is
# supposed to contain a ref to a _list_ of lookup tables as a result
# of the first-level lookup (on the recipient address as a key).
#
($r_ref,$mk_ref) = lookup(0,$recip,
Amavis::Lookup::Label->new("blacklist_recip<$recip>"),
cr('per_recip_blacklist_sender_lookup_tables'));
@t = ((defined $r_ref ? $r_ref : ()), @{ca('blacklist_sender_maps')});
$val = lookup2(0,$sender,\@t,Label=>"blacklist_sender<$sender>") if @t;
if ($val) {
$found=1; $wb = -1; $br = $recip; $any_b++;
$r->recip_blacklisted_sender(1);
do_log(5,'wbl: recip <%s> blacklisted sender <%s>', $recip,$sender);
}
# similar for whitelists:
($r_ref,$mk_ref) = lookup(0,$recip,
Amavis::Lookup::Label->new("whitelist_recip<$recip>"),
cr('per_recip_whitelist_sender_lookup_tables'));
@t = ((defined $r_ref ? $r_ref : ()), @{ca('whitelist_sender_maps')});
$val = lookup2(0,$sender,\@t,Label=>"whitelist_sender<$sender>") if @t;
if ($val) {
$found=1; $wb = +1; $wr = $recip; $any_w++;
$r->recip_whitelisted_sender(1);
do_log(5,'wbl: recip <%s> whitelisted sender <%s>', $recip,$sender);
}
}
if (!defined($boost)) { # lookup @score_sender_maps if no match with SQL
# note the first argument of lookup() is true, requesting ALL matches
my($r_ref,$mk_ref) = lookup2(1,$recip, ca('score_sender_maps'),
Label=>"score_recip<$recip>");
for my $j (0..$#{$r_ref}) { # for ALL tables matching the recipient
my($val,$key) = lookup2(0,$sender,$r_ref->[$j],
Label=>"score_sender<$sender>");
if (defined $val && $val != 0) {
$boost += $val;
ll(2) && do_log(2,'wbl: soft-%slisted (%s) sender <%s> => <%s>, '.
'recip_key="%s"', ($val<0?'white':'black'),
$val, $sender, $recip, $mk_ref->[$j]);
}
}
}
} # endfor on @senders
if ($boost) { # defined and nonzero
$r->spam_level( ($r->spam_level || 0) + $boost);
my $spam_tests = 'AM.WBL=' . (0+sprintf("%.3f",$boost));
if (!$r->spam_tests) {
$r->spam_tests([ \$spam_tests ]);
} else {
unshift(@{$r->spam_tests}, \$spam_tests);
}
}
$all = 0 if !$wb;
} # endfor on recips
if (!ll(2)) {
# don't bother preparing a log report which will not be printed
} else {
my $msg = '';
if ($all && $any_w && !$any_b) { $msg = "whitelisted" }
elsif ($all && $any_b && !$any_w) { $msg = "blacklisted" }
elsif ($all) { $msg = "black or whitelisted by all recips" }
elsif ($any_b || $any_w) {
$msg .= "whitelisted by ".($any_w>1?"$any_w recips, ":"$wr, ") if $any_w;
$msg .= "blacklisted by ".($any_b>1?"$any_b recips, ":"$br, ") if $any_b;
$msg .= "but not by all,";
}
do_log(2,"wbl: %s sender %s",
$msg, scalar(qquote_rfc2821_local(@senders))) if $msg ne '';
}
($any_w+$any_b, $all);
}
1;
__DATA__
#
package Amavis::Unpackers;