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