File: //usr/share/perl5/vendor_perl/Amavis/Lookup.pm
# SPDX-License-Identifier: GPL-2.0-or-later
package Amavis::Lookup;
use strict;
use re 'taint';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
$VERSION = '2.412';
@ISA = qw(Exporter);
@EXPORT_OK = qw(&lookup &lookup2 &lookup_hash &lookup_acl);
}
use subs @EXPORT_OK;
use Amavis::Conf qw(:platform c cr ca);
use Amavis::rfc2821_2822_Tools qw(split_address make_query_keys);
use Amavis::Timing qw(section_time);
use Amavis::Util qw(ll do_log fmt_struct unique_list idn_to_ascii
safe_encode_utf8_inplace);
# lookup_hash() performs a lookup for an e-mail address against a hash map.
# If a match is found (a hash key exists in the Perl hash) the function returns
# whatever the map returns, otherwise undef is returned. First match wins,
# aborting further search sequence.
#
# 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. Keys of a hash table are expected to be in octets (utf8 flag
# off) and their international domain names encoded in ASCII-compatible
# encoding (ACE).
#
sub lookup_hash($$;$%) {
my($addr, $hash_ref,$get_all,%options) = @_;
ref($hash_ref) eq 'HASH'
or die "lookup_hash: arg2 must be a hash ref: $hash_ref";
local($1,$2,$3,$4); my(@matchingkey,@result); my $append_string;
$append_string = $options{AppendStr} if defined $options{AppendStr};
my($keys_ref,$rhs_ref) = make_query_keys($addr,1,1,$append_string);
for my $key (@$keys_ref) { # do the search
if (exists $$hash_ref{$key}) { # got it
push(@result,$$hash_ref{$key}); push(@matchingkey,$key);
last if !$get_all;
}
}
# do the right-hand side replacements if any $n, ${n} or $(n) is specified
for my $r (@result) { # $r is just an alias to array elements
if (defined($r) && !ref($r) && index($r,'$') >= 0) { # plain string with $
my $any = $r =~ s{ \$ ( (\d+) | \{ (\d+) \} | \( (\d+) \) ) }
{ my $j = $2+$3+$4; $j<1 ? '' : $rhs_ref->[$j-1] }xgse;
# bring taintedness of input to the result
$r .= substr($addr,0,0) if $any;
}
}
if (!ll(5)) {
# only bother with logging when needed
} elsif (!@result) {
do_log(5,"lookup_hash(%s), no matches", $addr);
} elsif (!$get_all) { # first match wins
do_log(5,'lookup_hash(%s) matches key "%s", result=%s',
$addr, $matchingkey[0], !defined($result[0])?'undef':$result[0]);
} else { # want all matches
do_log(5,"lookup_hash(%s) matches keys: %s", $addr,
join(', ', map {sprintf('"%s"=>%s',$matchingkey[$_],$result[$_])}
(0..$#result)) );
}
if (!$get_all) { !wantarray ? $result[0] : ($result[0], $matchingkey[0]) }
else { !wantarray ? \@result : (\@result, \@matchingkey) }
}
# lookup_acl() performs a lookup for an e-mail address against
# access control list.
#
# 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. Array elements are expected to be in octets (utf8
# flag off) and their international domain names encoded in
# ASCII-compatible encoding (ACE).
#
# The supplied e-mail address is compared with each member of the
# lookup list in turn, the first match wins (terminates the search),
# and its value decides whether the result is true (yes, permit, pass)
# or false (no, deny, drop). Falling through without a match produces
# false (undef). Search is always case-insensitive on domain part,
# local part matching depends on $localpart_is_case_sensitive setting.
#
# NOTE: lookup_acl is not aware of address extensions and they are
# not handled specially!
#
# If a list element contains a '@', the full e-mail address is compared,
# otherwise if a list element has a leading dot, the domain name part is
# matched only, and the domain as well as its subdomains can match. If there
# is no leading dot, the domain must match exactly (subdomains do not match).
#
# The presence of a character '!' prepended to a list element decides
# whether the result will be true (without a '!') or false (with '!')
# in case where this list element matches and terminates the search.
#
# Because search stops at the first match, it only makes sense
# to place more specific patterns before the more general ones.
#
# Although not a special case, it is good to remember that '.' always matches,
# so a '.' would stop the search and return true, whereas '!.' would stop the
# search and return false (0).
#
# Examples:
#
# given: @acl = qw( me.ac.uk !.ac.uk .uk )
# 'me.ac.uk' matches me.ac.uk, returns true and search stops
#
# given: @acl = qw( me.ac.uk !.ac.uk .uk )
# 'you.ac.uk' matches .ac.uk, returns false (because of '!') and search stops
#
# given: @acl = qw( me.ac.uk !.ac.uk .uk )
# 'them.co.uk' matches .uk, returns true and search stops
#
# given: @acl = qw( me.ac.uk !.ac.uk .uk )
# 'some.com' does not match anything, falls through and returns false (undef)
#
# given: @acl = qw( me.ac.uk !.ac.uk .uk !. )
# 'some.com' similar to previous, except it returns 0 instead of undef,
# which would only make a difference if this ACL is not the last argument
# in a call to lookup(), because a defined result stops further lookups
#
# given: @acl = qw( me.ac.uk !.ac.uk .uk . )
# 'some.com' matches catchall ".", and returns true. The ".uk" is redundant
#
# more complex example: @acl = qw(
# !The.Boss@dept1.xxx.com .dept1.xxx.com
# .dept2.xxx.com .dept3.xxx.com lab.dept4.xxx.com
# sub.xxx.com !.sub.xxx.com
# me.d.aaa.com him.d.aaa.com !.d.aaa.com .aaa.com
# );
#
sub lookup_acl($$%) {
my($addr, $acl_ref,%options) = @_;
ref($acl_ref) eq 'ARRAY'
or die "lookup_acl: arg2 must be a list ref: $acl_ref";
return if !@$acl_ref; # empty list can't match anything
safe_encode_utf8_inplace($addr); # to octets (if not already)
my $lpcs = c('localpart_is_case_sensitive');
my($localpart,$domain) = split_address($addr);
$localpart = lc $localpart if !$lpcs;
local($1,$2);
# chop off leading '@' and trailing dots
$domain = $1 if $domain =~ /^\@?(.*?)\.*\z/s;
$domain = idn_to_ascii($domain) if $domain ne ''; # lowercase, ToASCII
$domain .= $options{AppendStr} if defined $options{AppendStr};
my($matchingkey, $result); my $found = 0;
for my $e (@$acl_ref) {
$result = 1; $matchingkey = $e; my $key = $e;
if ($key =~ /^(!+)(.*)\z/s) { # starts with an exclamation mark(s)
$key = $2;
$result = 1-$result if length($1) & 1; # negate if odd
}
if ($key =~ /^(.*?)\@([^\@]*)\z/s) { # contains '@', check full address
$found=1 if $localpart eq ($lpcs?$1:lc($1)) && $domain eq lc($2);
} elsif ($key =~ /^\.(.*)\z/s) { # leading dot: domain or subdomain
my $key_t = lc($1);
$found=1 if $domain eq $key_t || $domain =~ /(\.|\z)\Q$key_t\E\z/s;
} else { # match domain (but not its subdomains)
$found=1 if $domain eq lc($key);
}
last if $found;
}
$matchingkey = $result = undef if !$found;
ll(5) && do_log(5, 'lookup_acl(%s)%s', $addr,
(!$found ? ", no match"
: " matches key \"$matchingkey\", result=$result"));
!wantarray ? $result : ($result, $matchingkey);
}
# Perform a lookup for an e-mail address against any number of supplied maps:
# - SQL map,
# - LDAP map,
# - hash map (associative array),
# - (access control) list,
# - a list of regular expressions (an Amavis::Lookup::RE object),
# - a (defined) scalar always matches, and returns itself as the map value
# (useful as a catchall for a final 'pass' or 'fail');
# (see lookup_hash, lookup_acl, lookup_sql and lookup_ldap for details).
#
# when $get_all is 0 (the common usage):
# If a match is found (a defined value), returns whatever the map returns,
# otherwise returns undef. FIRST match aborts further search sequence.
# when $get_all is true:
# Collects a list of results from ALL matching tables, and within each
# table from ALL matching key. Returns a ref to a list of results
# (and a ref to a list of matching keys if returning a pair).
# The first element of both lists is supposed to be what lookup() would
# have returned if $get_all were 0. The order of returned elements
# corresponds to the order of the search.
#
# traditional API, deprecated
#
sub lookup($$@) {
my($get_all, $addr, @tables) = @_;
lookup2($get_all, $addr, \@tables);
}
# generalized API
#
sub lookup2($$$%) {
my($get_all, $addr, $tables_ref, %options) = @_;
(@_ - 3) % 2 == 0 or die "lookup2: options argument not in pairs (not hash)";
my($label, @result, @matchingkey);
for my $tb (!$tables_ref ? () : @$tables_ref) {
my $t = ref($tb) eq 'REF' ? $$tb : $tb; # allow one level of indirection
my $reft = ref($t);
if ($reft eq 'CODE') { # lazy evaluation
$t = &$t($addr,$get_all,%options);
$reft = ref($t);
}
if (!$reft || $reft eq 'SCALAR') { # a scalar always matches
my $r = $reft ? $$t : $t; # allow direct or indirect reference
if (defined $r) {
ll(5) && do_log(5, 'lookup: (scalar) matches, result="%s"', $r);
push(@result,$r); push(@matchingkey,"(constant:$r)");
}
} elsif ($reft eq 'HASH') {
my($r,$mk);
($r,$mk) = lookup_hash($addr,$t,$get_all,%options) if %$t;
if (!defined $r) {}
elsif (!$get_all) { push(@result,$r); push(@matchingkey,$mk) }
elsif (@$r) { push(@result,@$r); push(@matchingkey,@$mk) }
} elsif ($reft eq 'ARRAY') {
my($r,$mk);
($r,$mk) = lookup_acl($addr,$t,%options) if @$t;
if (defined $r) { push(@result,$r); push(@matchingkey,$mk) }
} elsif ($t->isa('Amavis::Lookup::Label')) { # logging label
# just a convenience for logging purposes, not a real lookup method
$label = $t->display; # grab the name, and proceed with the next table
} elsif ($t->isa('Amavis::Lookup::Opaque') || # a structured constant
$t->isa('Amavis::Lookup::OpaqueRef')) { # ref to structured const
my $r = $t->get; # behaves like a constant pseudo-lookup
if (defined $r) {
ll(5) && do_log(5, 'lookup: (opaque) matches, result="%s"', $r);
push(@result,$r); push(@matchingkey,"(opaque:$r)");
}
} elsif ($t->isa('Amavis::Lookup::RE')) {
my($r,$mk);
($r,$mk) = $t->lookup_re($addr,$get_all,%options) if @$t;
if (!defined $r) {}
elsif (!$get_all) { push(@result,$r); push(@matchingkey,$mk) }
elsif (@$r) { push(@result,@$r); push(@matchingkey,@$mk) }
} elsif ($t->isa('Amavis::Lookup::SQL')) {
my($r,$mk) = $t->lookup_sql($addr,$get_all,%options);
if (!defined $r) {}
elsif (!$get_all) { push(@result,$r); push(@matchingkey,$mk) }
elsif (@$r) { push(@result,@$r); push(@matchingkey,@$mk) }
} elsif ($t->isa('Amavis::Lookup::SQLfield')) {
if ($Amavis::sql_lookups) { # triage
my($r,$mk) = $t->lookup_sql_field($addr,$get_all,%options);
if (!defined $r) {}
elsif (!$get_all) { push(@result,$r); push(@matchingkey,$mk) }
elsif (@$r) { push(@result,@$r); push(@matchingkey,@$mk) }
}
} elsif ($t->isa('Amavis::Lookup::LDAP')) {
if ($Amavis::ldap_lookups && c('enable_ldap')) { # triage
my($r,$mk) = $t->lookup_ldap($addr,$get_all,%options);
if (!defined $r) {}
elsif (!$get_all) { push(@result,$r); push(@matchingkey,$mk) }
elsif (@$r) { push(@result,@$r); push(@matchingkey,@$mk) }
}
} elsif ($t->isa('Amavis::Lookup::LDAPattr')) {
if ($Amavis::ldap_lookups && c('enable_ldap')) { # triage
my($r,$mk) = $t->lookup_ldap_attr($addr,$get_all,%options);
if (!defined $r) {}
elsif (!$get_all) { push(@result,$r); push(@matchingkey,$mk) }
elsif (@$r) { push(@result,@$r); push(@matchingkey,@$mk) }
}
} else {
die "TROUBLE: lookup table is an unknown object: " . $reft;
}
last if @result && !$get_all;
}
# pretty logging
if (ll(4)) { # only bother preparing log report which will be printed
my $opt_label = $options{Label};
my(@lbl) = grep(defined $_ && $_ ne '', ($opt_label,$label));
$label = ' [' . join(',',unique_list(\@lbl)) . ']' if @lbl;
if (!$tables_ref || !@$tables_ref) {
do_log(4, "lookup%s => undef, %s, no lookup tables",
$label, fmt_struct($addr));
} elsif (!@result) {
do_log(4, "lookup%s => undef, %s does not match",
$label, fmt_struct($addr));
} elsif (!$get_all) { # first match wins
do_log(4, 'lookup%s => %-6s %s matches, result=%s, matching_key="%s"',
$label, $result[0] ? 'true,' : 'false,',
fmt_struct($addr), fmt_struct($result[0]), $matchingkey[0]);
} else { # want all matches
do_log(4, 'lookup%s, %d matches for %s, results: %s',
$label, scalar(@result), fmt_struct($addr),
join(', ', map { sprintf('"%s"=>%s',
$matchingkey[$_], fmt_struct($result[$_]))
} (0 .. $#result) ));
}
}
if (!$get_all) { !wantarray ? $result[0] : ($result[0], $matchingkey[0]) }
else { !wantarray ? \@result : (\@result, \@matchingkey) }
}
1;