File: //usr/share/perl5/vendor_perl/Amavis/Lookup/SQL.pm
# 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;