# SPDX-License-Identifier: GPL-2.0-or-later

package Amavis::Lookup::SQL;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  import Amavis::Out::SQL::Connection ();
}

use DBI qw(:sql_types);

use Amavis::Conf qw(:platform :confvars c cr ca);
use Amavis::rfc2821_2822_Tools qw(make_query_keys);
use Amavis::Timing qw(section_time);
use Amavis::Util qw(untaint untaint_inplace snmp_count
                    ll do_log do_log_safe);

# return a new Lookup::SQL object to contain DBI handle and prepared selects
#
sub new {
  my($class, $conn_h, $clause_name) = @_;
  if ($clause_name eq '') { undef }
  else {
    # $clause_name is a key into %sql_clause of the currently selected
    # policy bank; one level of indirection is allowed in %sql_clause result,
    # the resulting SQL clause may include %k, %a, %l, %u, %e, %d placeholders,
    # to be expanded
    bless { conn_h => $conn_h, incarnation => 0, clause_name => $clause_name },
          $class;
  }
}

sub DESTROY {
  my $self = $_[0]; local($@,$!,$_);
  do_log_safe(5,"Amavis::Lookup::SQL DESTROY called");
}

sub init {
  my $self = $_[0];
  if ($self->{incarnation} != $self->{conn_h}->incarnation) {  # invalidated?
    $self->{incarnation} = $self->{conn_h}->incarnation;
    $self->clear_cache;  # db handle has changed, invalidate cache
  }
  $self;
}

sub clear_cache {
  my $self = $_[0];
  delete $self->{cache};
}

# lookup_sql() performs a lookup for an e-mail address against a SQL map.
# If a match is found it returns whatever the query returns (a reference
# to a hash containing values of requested fields), otherwise returns undef.
# A match aborts further fetching sequence, unless $get_all is true.
#
# The $addr may be a string of octets (assumed to be UTF-8 encoded)
# or a string of characters which gets first encoded to UTF-8 octets.
# International domain name (IDN) in $addr will be converted to ACE
# and lowercased. International domain names in SQL are expected to be
# encoded in ASCII-compatible encoding (ACE).
#
# SQL lookups (e.g. for user+foo@example.com) are performed in order
# which can be requested by 'ORDER BY' in the SELECT statement, otherwise
# the order is unspecified, which is only useful if only specific entries
# exist in a database (e.g. only full addresses, not domains).
#
# The following order is recommended, going from specific to more general:
#  - lookup for user+foo@example.com
#  - lookup for user@example.com (only if $recipient_delimiter nonempty)
#  - lookup for user+foo ('naked lookup' (i.e. no '@'): only if local)
#  - lookup for user  ('naked lookup': local and $recipient_delimiter nonempty)
#  - lookup for @sub.example.com
#  - lookup for @.sub.example.com
#  - lookup for @.example.com
#  - lookup for @.com
#  - lookup for @.       (catchall)
# NOTE:
#  this is different from hash and ACL lookups in two important aspects:
#    - a key without '@' implies a mailbox (=user) name, not domain name;
#    - a naked mailbox name (i.e. no '@' in the query) lookups are only
#      performed when the e-mail address (usually its domain part) matches
#      static local_domains* lookups.
#
# Domain part is always lowercased when constructing a key,
# localpart is lowercased unless $localpart_is_case_sensitive is true.
#
sub lookup_sql($$$%) {
  my($self, $addr,$get_all,%options) = @_;
  my(@matchingkey,@result);
  my $extra_args = $options{ExtraArguments};
  my $sel; my $sql_cl_r = cr('sql_clause');
  my $clause_name = $self->{clause_name};
  $sel = $sql_cl_r->{$clause_name}  if defined $sql_cl_r;
  $sel = $$sel  if ref $sel eq 'SCALAR';  # allow one level of indirection
  if (!defined($sel) || $sel eq '') {
    ll(4) && do_log(4,"lookup_sql disabled for clause: %s", $clause_name);
    return(!wantarray ? undef : (undef,undef));
  } elsif (!defined $extra_args &&
           exists $self->{cache} && exists $self->{cache}->{$addr})
  { # cached ?
    my $c = $self->{cache}->{$addr}; @result = @$c if ref $c;
    @matchingkey = map('/cached/',@result); # will do for now, improve some day
#   if (!ll(5)) {}# don't bother preparing log report which will not be printed
#   elsif (!@result) { do_log(5,'lookup_sql (cached): "%s" no match', $addr) }
#   else {
#     for my $m (@result) {
#       do_log(5, "lookup_sql (cached): \"%s\" matches, result=(%s)",
#         $addr, join(", ", map { sprintf("%s=>%s", $_,
#                                 !defined($m->{$_})?'-':'"'.$m->{$_}.'"'
#                                        ) } sort keys(%$m) ) );
#     }
#   }
    if (!$get_all) {
      return(!wantarray ? $result[0] : ($result[0], $matchingkey[0]));
    } else {
      return(!wantarray ? \@result   : (\@result,   \@matchingkey));
    }
  }
  my $is_local;  # not looked up in SQL and LDAP to avoid recursion!
  $is_local = Amavis::Lookup::lookup(0,$addr,
                                     grep(ref ne 'Amavis::Lookup::SQL' &&
                                          ref ne 'Amavis::Lookup::SQLfield' &&
                                          ref ne 'Amavis::Lookup::LDAP' &&
                                          ref ne 'Amavis::Lookup::LDAPattr',
                                          @{ca('local_domains_maps')}));
  my($keys_ref,$rhs_ref) = make_query_keys($addr,
                                    $sql_lookups_no_at_means_domain,$is_local);
  if (!$sql_allow_8bit_address) { s/[^\040-\176]/?/gs for @$keys_ref }
  my $n = scalar(@$keys_ref);  # number of keys
  my(@extras_tmp,@pos_args); local($1);
  @extras_tmp = @$extra_args  if $extra_args;
  my $sel_taint = substr($sel,0,0);  # taintedness
  my $datatype = $sql_allow_8bit_address ? SQL_VARBINARY : SQL_VARCHAR;

  # substitute %k for a list of keys, %a for unmodified full mail address,
  # %l for full unmodified localpart, %u for lowercased username (a localpart
  # without extension), %e for lowercased extension, %d for lowercased domain,
  # and ? for each extra argument
  $sel =~ s{ ( %[kaluedL] | \? ) }
           { push(@pos_args,
                  $1 eq '%k' ? map([$_,$datatype], @$keys_ref)
                : $1 eq '%a' ? [$rhs_ref->[0], $datatype] #full addr
                : $1 eq '%l' ? [$rhs_ref->[1], $datatype] #localpart
                : $1 eq '%u' ? [$rhs_ref->[2], $datatype] #username
                : $1 eq '%e' ? [$rhs_ref->[3], $datatype] #extension
                : $1 eq '%d' ? [$rhs_ref->[4], $datatype] #domain
                   #*** (%L is experimental, incomplete)
                : $1 eq '%L' ? [($is_local?'1':'0'), SQL_BOOLEAN] #is local
                : shift @extras_tmp),
             $1 eq '%k' ? join(',', ('?') x $n) : '?' }xgse;
  $sel = untaint($sel) . $sel_taint;  # keep original clause taintedness
  ll(4) && do_log(4,"lookup_sql %s \"%s\", query args: %s",
                   $clause_name, $addr,
                   join(', ', map(!ref $_ ? '"'.$_.'"' : '['.join(',',@$_).']',
                                  @pos_args)) );
  ll(4) && do_log(4,"lookup_sql select: %s", $sel);
  my $a_ref; my $match = {}; my $conn_h = $self->{conn_h};
  $conn_h->begin_work_nontransaction;  # (re)connect if not connected
  my $driver = $conn_h->driver_name;  # only available when connected
  if ($driver eq 'Pg') {
    $datatype = { pg_type => DBD::Pg::PG_BYTEA() };
    for (@pos_args)
      { $_->[1] = $datatype  if ref($_) && $_->[1]==SQL_VARBINARY }
  }
  for (@pos_args) {
    if (ref $_) { untaint_inplace($_->[0]) } else { untaint_inplace($_) }
  }
  eval {
    snmp_count('OpsSqlSelect');
    $conn_h->execute($sel,@pos_args);  # do the query
    # fetch query results
    while ( defined($a_ref=$conn_h->fetchrow_arrayref($sel)) ) {
      my(@names) = @{$conn_h->sth($sel)->{NAME_lc}};
      $match = {}; @$match{@names} = @$a_ref;
      if ($clause_name eq 'sel_policy' && !exists $match->{'local'} &&
          defined $match->{'email'} && $match->{'email'} eq '@.') {
        # UGLY HACK to let a catchall (@.) imply that field 'local' has
        # a value undef (NULL) when that field is not present in the
        # database. This overrides B1 fieldtype default by an explicit
        # undef for '@.', causing a fallback to static lookup tables.
        # The purpose is to provide a useful default for local_domains
        # lookup if the field 'local' is not present in the SQL table.
        # NOTE: field names 'local' and 'email' are hardwired here!!!
        push(@names,'local'); $match->{'local'} = undef;
        do_log(5, 'lookup_sql: "%s" matches catchall, local=>undef', $addr);
      }
      push(@result, {%$match});  # copy hash
      push(@matchingkey, join(", ", map { sprintf("%s=>%s", $_,
                                !defined($match->{$_})?'-':'"'.$match->{$_}.'"'
                                ) } @names));
      last  if !$get_all;
    }
    $conn_h->finish($sel)  if defined $a_ref;  # only if not all read
    1;
  } or do {
    my $err = $@ ne '' ? $@ : "errno=$!";  chomp $err;
    do_log(-1, "lookup_sql: %s, %s, %s", $err, $DBI::err, $DBI::errstr);
    die $err  if $err =~ /^timed out\b/;  # resignal timeout
    die $err;
  };
  if (!ll(4)) {
    # don't bother preparing log report which will not be printed
  } elsif (!@result) {
    do_log(4,'lookup_sql, "%s" no match', $addr);
  } else {
    do_log(4,'lookup_sql(%s) matches, result=(%s)', $addr,$_) for @matchingkey;
  }
  # save for future use, but only within processing of this message
  $self->{cache}->{$addr} = \@result;
  section_time('lookup_sql');
  if (!$get_all) { !wantarray ? $result[0] : ($result[0], $matchingkey[0]) }
  else           { !wantarray ? \@result   : (\@result,   \@matchingkey)   }
}

1;