File: //usr/share/perl5/vendor_perl/Amavis/Lookup/IP.pm
# SPDX-License-Identifier: GPL-2.0-or-later
package Amavis::Lookup::IP;
use strict;
use re 'taint';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION $have_patricia);
$VERSION = '2.412';
@ISA = qw(Exporter);
@EXPORT_OK = qw(&lookup_ip_acl &ip_to_vec &normalize_ip_addr);
}
use subs @EXPORT_OK;
use Amavis::Util qw(ll do_log);
BEGIN {
eval {
require Net::Patricia;
Net::Patricia->VERSION(1.015); # need AF_INET6 support
import Net::Patricia;
$have_patricia = 1;
} or do {
undef $have_patricia;
};
}
# ip_to_vec() takes an IPv6 or IPv4 address with optional prefix length
# (or an IPv4 mask), parses and validates it, and returns it as a 128-bit
# vector string that can be used as operand to Perl bitwise string operators.
# Syntax and other errors in the argument throw exception (die).
# If the second argument $allow_mask is 0, the prefix length or mask
# specification is not allowed as part of the IP address.
#
# The IPv6 syntax parsing and validation adheres to RFC 4291 (ex RFC 3513).
# All the following IPv6 address forms are supported:
# x:x:x:x:x:x:x:x preferred form
# x:x:x:x:x:x:d.d.d.d alternative form
# ...::... zero-compressed form
# addr/prefix-length prefix length may be specified (defaults to 128)
# Optionally an "IPv6:" prefix may be prepended to an IPv6 address
# as specified by RFC 5321 (ex RFC 2821). Brackets enclosing the address
# are optional, e.g. [::1]/128 .
#
# The following IPv4 forms are allowed:
# d.d.d.d
# d.d.d.d/prefix-length CIDR mask length is allowed (defaults to 32)
# d.d.d.d/m.m.m.m network mask (gets converted to prefix-length)
# If prefix-length or a mask is specified with an IPv4 address, the address
# may be shortened to d.d.d/n or d.d/n or d/n. Such truncation is allowed
# for compatibility with earlier version, but is deprecated and is not
# allowed for IPv6 addresses.
#
# IPv4 addresses and masks are converted to IPv4-mapped IPv6 addresses
# of the form ::FFFF:d.d.d.d, The CIDR mask length (0..32) is converted
# to an IPv6 prefix-length (96..128). The returned vector strings resulting
# from IPv4 and IPv6 forms are indistinguishable.
#
# NOTE:
# d.d.d.d is equivalent to ::FFFF:d.d.d.d (IPv4-mapped IPv6 address)
# which is not the same as ::d.d.d.d (IPv4-compatible IPv6 address)
#
# A quadruple is returned:
# - an IP address represented as a 128-bit vector (a string)
# - network mask derived from prefix length, a 128-bit vector (string)
# - prefix length as an integer (0..128)
# - zone_id, e.g. an interface scope for link-local addresses,
# undef if not specified (implies a default zone_id 0, RFC 4007 sect. 11)
#
sub ip_to_vec($;$) {
my($ip,$allow_mask) = @_;
my($ip_len, @ip_fields, $scope);
local($1,$2,$3,$4,$5,$6);
$ip =~ s/^[ \t]+//; $ip =~ s/[ \t\r\n]+\z//s; # trim
my $ipa = $ip;
($ipa,$ip_len) = ($1,$2) if $allow_mask && $ip =~ m{^ ([^/]*) / (.*) \z}xs;
$ipa = $1 if $ipa =~ m{^ \[ (.*) \] \z}xs; # discard optional brackets
my $have_ipv6;
if ($ipa =~ s/^IPv6://i) { $have_ipv6 = 1 }
elsif ($ipa =~ /:[0-9a-f]*:/i) { $have_ipv6 = 1 }
# RFC 4007: IPv6 Scoped Address Architecture, sect 11: textual representation
# RFC 6874 A <zone_id> SHOULD contain only ASCII characters
# classified as "unreserved" for use in URIs [RFC 3986]
# RFC 3986: unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~"
$scope = $1 if $ipa =~ s/ ( % [A-Z0-9._~-]* ) \z//xsi; # scoped address
if ($have_ipv6 &&
$ipa =~ m{^(.*:) (\d{1,3}) \. (\d{1,3}) \. (\d{1,3}) \. (\d{1,3})\z}xsi){
# IPv6 alternative form x:x:x:x:x:x:d.d.d.d
my(@d) = ($2,$3,$4,$5);
!grep($_ > 255, @d)
or die "Invalid decimal field value in IPv6 address: [$ip]\n";
$ipa = $1 . sprintf('%02x%02x:%02x%02x', @d);
} elsif (!$have_ipv6 &&
$ipa =~ m{^ \d{1,3} (?: \. \d{1,3}){0,3} \z}xs) { # IPv4
my(@d) = split(/\./,$ipa,-1);
!grep($_ > 255, @d)
or die "Invalid field value in IPv4 address: [$ip]\n";
defined($ip_len) || @d==4
or die "IPv4 address [$ip] contains fewer than 4 fields\n";
$ipa = '::ffff:' . sprintf('%02x%02x:%02x%02x', @d); # IPv4-mapped IPv6
if (!defined($ip_len)) { $ip_len = 32; # no length, defaults to /32
} elsif ($ip_len =~ /^\d{1,9}\z/) { # /n, IPv4 CIDR notation
} elsif ($ip_len =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})\z/) {
my(@d) = ($1,$2,$3,$4);
!grep($_ > 255, @d)
or die "Illegal field value in IPv4 mask: [$ip]\n";
my $mask1 = pack('C4', @d); # /m.m.m.m
my $len = unpack('%b*', $mask1); # count ones
my $mask2 = pack('B32', '1' x $len); # reconstruct mask from count
$mask1 eq $mask2
or die "IPv4 mask not representing a valid CIDR mask: [$ip]\n";
$ip_len = $len;
} else {
die "Invalid IPv4 network mask or CIDR prefix length: [$ip]\n";
}
$ip_len<=32 or die "IPv4 network prefix length greater than 32: [$ip]\n";
$ip_len += 128-32; # convert IPv4 net mask length to IPv6 prefix length
}
# now we presumably have an IPv6 compressed or preferred form x:x:x:x:x:x:x:x
if ($ipa !~ /^(.*?)::(.*)\z/s) { # zero-compressing form used?
@ip_fields = split(/:/,$ipa,-1); # no, have preferred form
} else { # expand zero-compressing form
my($before,$after) = ($1,$2);
my(@bfr) = split(/:/,$before,-1); my(@aft) = split(/:/,$after,-1);
my $missing_cnt = 8-(@bfr+@aft); $missing_cnt = 1 if $missing_cnt<1;
@ip_fields = (@bfr, ('0') x $missing_cnt, @aft);
}
@ip_fields >= 8 or die "IPv6 address [$ip] contains fewer than 8 fields\n";
@ip_fields <= 8 or die "IPv6 address [$ip] contains more than 8 fields\n";
!grep(!/^[0-9a-fA-F]{1,4}\z/, @ip_fields) # this is quite slow
or die "Invalid syntax of IPv6 address: [$ip]\n";
my $vec = pack('n8', map(hex($_),@ip_fields));
if (!defined($ip_len)) {
$ip_len = 128;
} elsif ($ip_len !~ /^\d{1,3}\z/) {
die "Invalid prefix length syntax in IP address: [$ip]\n";
} elsif ($ip_len > 128) {
die "IPv6 network prefix length greater than 128: [$ip]\n";
}
my $mask = pack('B128', '1' x $ip_len);
# do_log(5, "ip_to_vec: %s => %s/%d\n", # unpack('B*',$vec)
# $ip, join(':',unpack('(H4)*',$vec)), $ip_len);
($vec, $mask, $ip_len, $scope);
}
use vars qw($ip_mapd_vec $ip_mapd_mask $ip_xlat_vec $ip_xlat_mask
$ip_6to4_vec $ip_6to4_mask $ip_nat64_vec $ip_nat64_mask);
BEGIN {
# RFC 4291: IPv4-mapped
($ip_mapd_vec, $ip_mapd_mask) = ip_to_vec('::ffff:0:0/96',1); # IPv4-mapped
# RFC 2765 (SIIT): IPv4-translated
($ip_xlat_vec, $ip_xlat_mask) = ip_to_vec('::ffff:0:0:0/96',1); # IPv4-xlat
# RFC 3056 (6to4)
($ip_6to4_vec, $ip_6to4_mask) = ip_to_vec('2002::/16',1); # 6to4
# RFC 6052, RFC 6146 (NAT64)
($ip_nat64_vec, $ip_nat64_mask) = ip_to_vec('64:ff9b::/96',1); # NAT64
# check, just in case
$ip_mapd_vec = $ip_mapd_vec & $ip_mapd_mask;
$ip_xlat_vec = $ip_xlat_vec & $ip_xlat_mask;
$ip_6to4_vec = $ip_6to4_vec & $ip_6to4_mask;
$ip_nat64_vec = $ip_nat64_vec & $ip_nat64_mask;
}
# strip an optional 'IPv6:' prefix, lowercase hex digits,
# convert an IPv4-mapped IPv6 address into a plain IPv4 dot-quad form;
# leave unchanged if syntactically incorrect
#
sub normalize_ip_addr($) {
my $ip = $_[0];
my($have_ipv6, $scope);
if ($ip =~ s/^IPv6://i) { $have_ipv6 = 1 }
elsif ($ip =~ /:[0-9a-f]*:/i) { $have_ipv6 = 1 }
if ($have_ipv6) {
local($1);
$scope = $1 if $ip =~ s/ % ( [A-Z0-9._~-]* ) \z//xsi; # scoped address
if ($ip !~ /^[0:]+:ffff:/i) { # triage for IPv4-mapped
$ip = lc $ip; # lowercase: RFC 5952
} else { # looks like an IPv4-mapped address
my($ip_vec,$ip_mask);
if (!eval { ($ip_vec,$ip_mask) = ip_to_vec($ip,0); 1 }) {
do_log(3, "normalize_ip_addr: bad IP address: %s", $_[0]);
} elsif (($ip_vec & $ip_mapd_mask) ne $ip_mapd_vec) {
$ip = lc $ip; # lowercase: RFC 5952
# RFC 5952 - Recommendation for IPv6 Text Representation
# TODO: apply suppression of leading zeroes, zero compression
} else { # IPv4-mapped address
my $ip_dq = join('.', unpack('C4',substr($ip_vec,12,4))); # 32 bits
do_log(5, "IPv4-mapped: %s -> %s", $ip, $ip_dq);
$ip = $ip_dq;
}
}
}
$ip .= '%'.$scope if $scope; # defined, nonempty and nonzero
$ip;
}
# lookup_ip_acl() performs a lookup for an IPv4 or IPv6 address against a list
# of lookup tables, each may be a constant, or a ref to an access control
# list or a ref to an associative array (hash) of network or host addresses.
# Interface zone_id (e.g. scope for link-local addresses) is ignored.
#
# IP address is compared to each member of an access 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 a false (undef).
#
# For lookup tables which are a ref to a an array (a traditional ACL),
# the presence of a character '!' prepended to a list member decides
# whether the result will be true (without a '!') or false (with a '!')
# in case this list member 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.
#
# For IPv4 a network address can be specified in classless notation
# n.n.n.n/k, or using a mask n.n.n.n/m.m.m.m . Missing mask implies /32,
# i.e. a host address. For IPv6 addresses all RFC 4291 forms are allowed
# and the /k specifies a prefix length. See also comments at ip_to_vec().
#
# Although not a special case, it is good to remember that '::/0'
# always matches any IPv4 or IPv6 address (even syntactically invalid address).
#
# The '0/0' is equivalent to '::ffff:0:0/96' and matches any syntactically
# valid IPv4 address (including IPv4-mapped IPv6 addresses), but not other
# IPv6 addresses!
#
# Example
# given: @acl = qw( !192.168.1.12 172.16.3.3 !172.16.3.0/255.255.255.0
# 10.0.0.0/8 172.16.0.0/12 192.168.0.0/16
# !0.0.0.0/8 !:: 127.0.0.0/8 ::1 );
# matches RFC 1918 private address space except host 192.168.1.12
# and net 172.16.3/24 (but host 172.16.3.3 within 172.16.3/24 still matches).
# In addition, the 'unspecified' (null, i.e. all zeros) IPv4 and IPv6
# addresses return false, and IPv4 and IPv6 loopback addresses match
# and return true.
#
# If the supplied lookup table is a hash reference, match a canonical
# IP address: dot-quad IPv4, or a preferred IPv6 form, against hash keys.
# For IPv4 addresses a simple classful subnet specification is allowed in
# hash keys by truncating trailing bytes from the looked up IPv4 address.
# A syntactically invalid IP address cannot match any hash entry.
#
sub lookup_ip_acl($@) {
my($ip, @nets_ref) = @_;
my($ip_vec,$ip_mask); my $eval_stat;
eval { ($ip_vec,$ip_mask) = ip_to_vec($ip,0); 1 }
or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" };
my($label,$fullkey,$result,$lookup_type); my $found = 0;
for my $tb (@nets_ref) {
my $t = ref($tb) eq 'REF' ? $$tb : $tb; # allow one level of indirection
if (!ref($t) || ref($t) eq 'SCALAR') { # a scalar always matches
my $r = ref($t) ? $$t : $t; # allow direct or indirect reference
$result = $r; $fullkey = "(constant:$r)"; $lookup_type = 'const';
$found=1 if defined $result;
} elsif (ref($t) eq 'HASH') {
$lookup_type = 'hash';
if (!defined $ip_vec) { # syntactically invalid IP address
$fullkey = undef; $result = $t->{$fullkey}; # only matches undef key
$found=1 if defined $result;
} else { # valid IP address
# match a canonical IP address: dot-quad IPv4, or preferred IPv6 form
my $ip_c; # IP address in a canonical form: x:x:x:x:x:x:x:x
$ip_c = join(':', map(sprintf('%04x',$_), unpack('n8',$ip_vec)));
if (($ip_vec & $ip_mapd_mask) ne $ip_mapd_vec) {
do_log(5, 'lookup_ip_acl keys: "%s"', $ip_c);
} else { # is an IPv4-mapped addr
my $ip_dq; # IPv4 in dotted-quad form
$ip_dq = join('.', unpack('C4',substr($ip_vec,12,4))); # 32 bits
# try dot-quad, stripping off trailing bytes repeatedly
do_log(5, 'lookup_ip_acl keys: "%s", "%s"', $ip_dq, $ip_c);
for (my(@f)=split(/\./,$ip_dq); @f && !$found; $#f--) {
$fullkey = join('.',@f); $result = $t->{$fullkey};
$found=1 if defined $result;
}
}
# test for 6to4 too? not now
# if ($ip_vec & $ip_6to4_mask) eq $ip_6to4_vec) {
# # yields an IPv4 address of a client's 6to4 router
# $ip_dq = join('.', unpack('C4',substr($ip_vec,2,4)));
# }
if (!$found) { # try the 'preferred IPv6 form', lowercase hex letters
$fullkey = lc $ip_c; $result = $t->{$fullkey};
$found=1 if defined $result;
}
}
} elsif (ref($t) eq 'ARRAY') {
$lookup_type = 'array';
my($key,$acl_ip_vec,$acl_mask,$acl_mask_len); local($1,$2);
for my $net (@$t) {
$fullkey = $key = $net; $result = 1;
if ($key =~ /^(!+)(.*)\z/s) { # starts with exclamation mark(s)
$key = $2;
$result = 1 - $result if (length($1) & 1); # negate if odd
}
($acl_ip_vec, $acl_mask, $acl_mask_len) = ip_to_vec($key,1);
if ($acl_mask_len == 0) { $found=1 } #even an invalid addr matches ::/0
elsif (!defined($ip_vec)) {} # no other matches for invalid address
elsif (($ip_vec & $acl_mask) eq ($acl_ip_vec & $acl_mask)) { $found=1 }
last if $found;
}
} elsif ($t->isa('Net::Patricia::AF_INET6')) { # Patricia Trie
$lookup_type = 'patricia';
local($1,$2,$3,$4); local($_) = $ip;
$_ = $1 if /^ \[ ( [^\]]* ) \] \z/xs; # discard optional brackets
s/%[A-Z0-9:._-]+\z//si; # discard interface specification
if (m{^ (\d+) \. (\d+) \. (\d+) \. (\d+) \z}x) {
$_ = sprintf('::ffff:%d.%d.%d.%d', $1,$2,$3,$4);
} else {
s/^IPv6://i; # discard optional 'IPv6:' prefix
}
eval { $result = $t->match_string($_); 1 } or $result=undef;
if (defined $result) {
$fullkey = $result;
if ($fullkey =~ s/^!//) { $result = 0 }
else { $result = 1; $found = 1 }
}
} elsif ($t->isa('Amavis::Lookup::IP')) { # pre-parsed IP lookup array obj
$lookup_type = 'arr.obj';
my($acl_ip_vec, $acl_mask, $acl_mask_len);
for my $e (@$t) {
($fullkey, $acl_ip_vec, $acl_mask, $acl_mask_len, $result) = @$e;
if ($acl_mask_len == 0) { $found=1 } #even an invalid addr matches ::/0
elsif (!defined($ip_vec)) {} # no other matches for invalid address
elsif (($ip_vec & $acl_mask) eq ($acl_ip_vec & $acl_mask)) { $found=1 }
last if $found;
}
} elsif ($t->isa('Amavis::Lookup::DNSxL')) { # DNSxL lookup obj, RFC 5782
$lookup_type = 'dns';
($result, $fullkey) = $t->lookup_ip($ip);
$found = $result;
} 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
} else {
die "TROUBLE: lookup table is an unknown object: " . ref($t);
}
last if $found;
}
$fullkey = $result = undef if !$found;
if ($label ne '') { $label = " ($label)" }
ll(4) && do_log(4, 'lookup_ip_acl%s %s: key="%s"%s',
$label, $lookup_type, $ip,
!$found ? ", no match"
: " matches \"$fullkey\", result=$result");
if (defined $eval_stat) {
chomp $eval_stat;
die $eval_stat if $eval_stat =~ /^timed out\b/; # resignal timeout
$eval_stat = "lookup_ip_acl$label: $eval_stat";
do_log(2, "%s", $eval_stat);
}
!wantarray ? $result : ($result, $fullkey, $eval_stat);
}
# Create a pre-parsed object from a list of IP networks, which
# may be used as an argument to lookup_ip_acl to speed up its searches.
# Interface zone_id (e.g. scope for link-local addresses) is ignored.
#
sub new($@) {
my($class,@nets) = @_;
my $build_patricia_trie = $have_patricia && (@nets > 20);
if (!$build_patricia_trie) {
# build a traditional pre-parsed search list for a small number of entries
my(@list); local($1,$2);
for my $net (@nets) {
my $key = $net; my $result = 1;
if ($key =~ /^(!+)(.*)\z/s) { # starts with exclamation mark(s)
$key = $2;
$result = 1 - $result if (length($1) & 1); # negate if odd
}
my($ip_vec, $ip_mask, $ip_mask_len) = ip_to_vec($key,1);
push(@list, [$net, $ip_vec, $ip_mask, $ip_mask_len, $result]);
}
return bless(\@list, $class);
} else {
# build a patricia trie, it offers more efficient searching in large sets
my $pt = Net::Patricia->new(&AF_INET6);
do_log(5, "building a patricia trie out of %d nets", scalar(@nets));
for my $net (@nets) {
local $_ = $net;
local($1,$2,$3,$4); my $masklen;
if (s{ / ([0-9.]+) \z }{}x) {
$masklen = $1;
$masklen =~ /^\d{1,3}\z/
or die "Network mask not supported, use a CIDR syntax: $net";
}
s/^!//; # strip a negation from a key, it will be retained in data
$_ = $1 if /^ \[ ( [^\]]* ) \] \z/xs; # discard optional brackets
s/%[A-Z0-9:._-]+\z//si; # discard interface specification
if (/^ \d+ (?: \. | \z) /x) { # triage for an IPv4 network address
if (/^ (\d+) \. (\d+) \. (\d+) \. (\d+) \z/x) {
$_ = sprintf('::ffff:%d.%d.%d.%d', $1,$2,$3,$4);
$masklen = 32 if !defined $masklen;
} elsif (/^ (\d+) \. (\d+) \. (\d+) \.? \z/x) {
$_ = sprintf('::ffff:%d.%d.%d.0', $1,$2,$3);
$masklen = 24 if !defined $masklen;
} elsif (/^ (\d+) \. (\d+) \.? \z/x) {
$_ = sprintf('::ffff:%d.%d.0.0', $1,$2);
$masklen = 16 if !defined $masklen;
} elsif (/^ (\d+) \.? \z/x) {
$_ = sprintf('::ffff:%d.0.0.0', $1);
$masklen = 8 if !defined $masklen;
}
$masklen += 96 if defined $masklen;
} else { # looks like an IPv6 network
s/^IPv6://i; # discard optional 'IPv6:' prefix
}
$masklen = 128 if !defined $masklen;
$_ .= '/' . $masklen;
eval { $pt->add_string($_, $net); 1 }
or die "Adding a network $net to a patricia trie failed: $@";
}
# ll(5) && $pt->climb(sub { do_log(5,"patricia trie, node $_[0]") });
return $pt; # a Net::Patricia::AF_INET6 object
}
}
1;