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