Changeset 1034 for branches/stable/DNSDB.pm

Timestamp:

02/11/26 14:51:02 (9 hours ago)

Author:

Kris Deugau

Message:

/branches/stable

Completed triaging existing trunk commits from production

Location:

branches/stable

Files:

• . (modified) (1 prop)
• DNSDB.pm (modified) (9 diffs)

branches/stable/DNSDB.pm

@@ -689 +689 @@
     return ('FAIL', $errstr) if ! _check_hostname_form(${$args{host}}, ${$args{rectype}}, $args{defrec}, $args{revrec});
   } else {
-    # CNAME target check - IP addresses not allowed.  Must be a more or less well-formed hostname.
-    return ('FAIL', "CNAME records cannot point directly to an IP address")
-      if ${$args{val}} =~ /^(?:[\d.]+|[0-9a-fA-F:]+)$/;
-
-    # Make sure target is a well-formed hostname
-    return ('FAIL', $errstr) if ! _check_hostname_form(${$args{val}}, ${$args{rectype}}, $args{defrec}, $args{revrec});
-
-    # Forcibly append the domain name if the hostname being added does not end with the current domain name
-    my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : $self->domainName($args{id}));
-    ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/i;
-
-    # CNAMEs can not be used for parent nodes;  just leaf nodes with no other record types
-    # Enforce this for the zone name
-    return ('FAIL', "The bare zone name may not be a CNAME") if ${$args{host}} eq $pname || ${$args{host}} =~ /^\@/;
+    # a bit expensive to put this here, but we need some kind of cheap flag for an RPZ zone with different rules
+    my $zname = $self->domainName($args{id});
+    if ($zname =~ /\.rpz$/) {
+      # RPZ domains consist almost entirely of CNAME records, and have special rules for their syntax
+      # From the Unbound doc:  https://unbound.docs.nlnetlabs.nl/en/latest/topics/filtering/rpz.html
+      # Supposedly other overrides are also valid
+      return ('FAIL', "Unsupported RPZ override ${$args{val}}")
+        unless ${$args{val}} =~ /^(?:\.|\*\.|rpz-passthru\.|rpz-drop\.|rpz-tcp-only\.)$/;
+      # Append the RPZ name
+      my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : $self->domainName($args{id}));
+      ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/i;
+    } else {
+      # CNAME target check - IP addresses not allowed.  Must be a more or less well-formed hostname.
+      return ('FAIL', "CNAME records cannot point directly to an IP address")
+        if ${$args{val}} =~ /^(?:[\d.]+|[0-9a-fA-F:]+)$/;
+
+      # Make sure target is a well-formed hostname
+      return ('FAIL', $errstr) if ! _check_hostname_form(${$args{val}}, ${$args{rectype}}, $args{defrec}, $args{revrec});
+
+      # Forcibly append the domain name if the hostname being added does not end with the current domain name
+      my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : $zname);
+      ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/i;
+
+      # CNAMEs can not be used for parent nodes;  just leaf nodes with no other record types
+      # Enforce this for the zone name
+      return ('FAIL', "The bare zone name may not be a CNAME") if ${$args{host}} eq $pname || ${$args{host}} =~ /^\@/;
 
 ##enhance:  Look up the passed value to see if it exists.  Ooo, fancy.
-    return ('FAIL', $errstr) if ! _check_hostname_form(${$args{val}}, ${$args{rectype}}, $args{defrec}, $args{revrec});
-  }
+      return ('FAIL', $errstr) if ! _check_hostname_form(${$args{val}}, ${$args{rectype}}, $args{defrec}, $args{revrec});
+    } # $zname !~ .rpz
+  } # revzone eq 'n'
 
   return ('OK','OK');
@@ -1033 +1046 @@
     # Not strictly true, but SRV records not following this convention won't be found.
     return ('FAIL',"SRV records must begin with _service._protocol [${$args{host}}]")
-        unless ${$args{host}} =~ /^_[A-Za-z-]+\._[A-Za-z]+\.[a-zA-Z0-9-]+/;
+        unless ${$args{host}} =~ /^_[A-Za-z\d-]+\._[A-Za-z]+\.[a-zA-Z0-9-]+/;
 
     # SRV target check - IP addresses not allowed.  Must be a more or less well-formed hostname.
@@ -1048 +1061 @@
     # Not strictly true, but SRV records not following this convention won't be found.
     return ('FAIL',"SRV records must begin with _service._protocol [${$args{host}}]")
-        unless ${$args{val}} =~ /^_[A-Za-z]+\._[A-Za-z]+\.[a-zA-Z0-9-]+/;
+        unless ${$args{val}} =~ /^_[A-Za-z\d-]+\._[A-Za-z]+\.[a-zA-Z0-9-]+/;
 
     # SRV target check - IP addresses not allowed.  Must be a more or less well-formed hostname.
@@ -1075 +1088 @@
   return ('OK','OK');
 } # done SRV record
+
+# CAA record
+sub _validate_257 {
+  my $self = shift;
+  my $dbh = $self->{dbh};
+
+  my %args = @_;
+
+  my $code = 'OK';
+  my $msg = '';    # Default to no message, because there are a lot of handwavy warning cases.
+
+  if ($args{revrec} eq 'n') {
+    # Coerce all hostnames to end in ".DOMAIN" for group/default records,
+    # or the intended parent domain for live records.
+    my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : $self->domainName($args{id}));
+    ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/i;
+
+    my ($caaflag, $caatag, $caadetail) = (${$args{val}} =~ /(\d+)\s+(\w+)\s+(.+)/);
+
+    return ('FAIL', "Poorly formed CAA record missing one or more of flag, tag, or detail")
+      if (!defined($caaflag) || !defined($caatag) || !defined($caadetail));
+
+    # flag is a bitfield, only bit 0 currently has meaning as "Issuer Critical"
+    # Not 100% clear if this flag is permitted on known tags, or if it's
+    # semantically null since the known tags are already defined.  We'll allow it.
+    return ('FAIL', "CAA flags other than 0 or 128 not currently supported in DNS") if $caaflag ne '0' && $caaflag ne '128';
+
+    # known tags:
+    #    issue
+    #    issuewild
+    #    iodef  (RFC5070)
+    #    auth (reserved, do not use)
+    #    path (reserved, do not use)
+    #    policy (reserved, do not use)
+    return ('FAIL', "CAA tags may only use a-z, A-Z, and 0-9") if $caatag !~ /^[a-zA-Z0-9]+$/;
+    return ('FAIL', "Can't use reserved CAA tag '$caatag'") if $caatag =~ /^(?:auth|path|policy)$/;
+    if ($caatag !~ /^(?:issue|issuewild|iodef)$/) {
+      $code = 'WARN';
+      $msg = ($msg ? $msg."  " : '')."Unknown CAA tag '$caatag' will be published as-is.";
+    }
+    if (length($caatag) > 15) {
+      $code = 'WARN';
+      $msg = ($msg ? $msg."  " : '').'Custom CAA tag > 15 characters may not behave as intended.';
+    }
+
+    if ($caatag eq 'issue' || $caatag eq 'issuewild') {
+      # Detail format is possibly as complex as:
+      # [;|cert-authority [; key=value[ key=value ...]]
+      # but arguably a strict reading says there can only be one key, and the
+      # rest of the string after first = is the value, even if it appears to
+      # contain extra key=value pairs.
+      # See https://datatracker.ietf.org/doc/html/rfc6844 for full ABNF definition.
+      # Either way all we need to validate is that it's within the specified characters.
+      if ($caadetail eq ';') {
+        # No certs permitted
+      } else {
+        my ($certauth,$remainder) = ($caadetail =~ /^\s*([a-zA-Z0-9.-]+)\s*((?:;|\s|$).*)?$/);
+        if (!$certauth) {
+          # We can't reasonably validate individual domains, just that it's well-formed
+          return ('FAIL', "CAA authority domain must be a valid domain name");
+        }
+        if ($remainder) {
+          return ('FAIL', "CAA authority domain and optional key=value entry or entries must be separated by a ';'")
+            if $remainder !~ /^\s*;/;
+          $remainder =~ s/\s*;\s*//;
+          # Just validate the characters in the remainder.  Any details are CA-specific and not sanely validateable.
+          return ('FAIL', "Invalid characters in optional key=value entry or entries")
+            if $remainder !~ /^[a-zA-Z0-9]+\s*=[\x21-\x7e\s]+$/;
+        }
+      }
+    } # issue/isseuewild
+
+    elsif ($caatag eq 'iodef') {
+      # Two valid forms:
+      # mailto:address@example.com
+      # http://iodef.example.com/
+      # RFC seems a little handwavy whether https:// is valid or not, but the chained
+      # RFC for the HTTP-based reporting protocol says that this should be assumed to
+      # be a dedicated port (4590) and service, requiring TLS.  Allowing https:// per
+      # the detail description in https://datatracker.ietf.org/doc/html/rfc6844#section-5.4.
+      return ('FAIL', "iodef tag data must reference a mailto: or http: URI") if $caadetail !~ /^(mailto|https?):/;
+      if ($1 eq 'mailto') {
+        # not going full RFC on validating form, just "reasonably sane"
+        return ('FAIL', "Poorly formed email for iodef tag") if $caadetail !~ /^mailto:[^\s]+\@[a-zA-z0-9._-]+$/
+      } else {
+        return ('FAIL', "Poorly formed URI for iodef tag") if $caadetail !~ m,^https?://[a-zA-z0-9._-]+/?$,
+      }
+    } # iodef
+
+  } else {
+    # CAA records don't make much sense in reverse zones
+    return ('FAIL', "CAA records not supported in reverse zones");
+  }
+
+  # Allow CAA records in default record sets for now, but it's a bit iffy
+  # whether this makes any sense.  Not nice to publish a default "issue ;"
+  # record, then go through a support mess trying to figure out why a
+  # customer can't register a cert somewhere.
+#  if ($args{defrec} eq 'n') {
+#  } else {
+#  }
+
+  return ($code, $msg);
+} # done CAA record
+
 
 # Now the custom types
@@ -4393 +4511 @@
   # Filtering on host/val (mainly normal record list)
   if ($args{filter}) {
-    $sql .= " AND (r.host ~* ? OR r.val ~* ? OR r.host ~* ? OR r.val ~* ?)";
-    my $tmp = join('.',reverse(split(/\./,$args{filter})));
-    push @bindvars, ($args{filter},$args{filter});
-    push @bindvars, ($tmp, $tmp);
+    # not much use to end users, but internal callers may want more fine-grained restriction on CIDR ranges
+    # we'll only support the value-comparison operators;  bitwise/add/subtract don't make much sense in this context
+    my $ipfilt = 0;
+    if ($args{filter} =~ /^\s*(<|<=|=|>=|>|<>|<<|<<=|>>|>>=)\s*([\da-fA-F].+)\s*$/) {
+      my $filt_op = $1;
+      my $filt_val = $2;
+      # do we have an IP-ish value?
+      if ($filt_val =~ m,^(?:[\d.]+|[0-9a-f]+)(?:/\d+)?$,) {
+        # now make sure
+        my $tmp = new NetAddr::IP $filt_val;
+        if ($tmp) {
+          $sql .= " AND inetlazy(r.val) $filt_op ?";
+          push @bindvars, $filt_val;
+          $ipfilt = 1;
+        } # really looks like a valid IP/CIDR
+      } # looks IPish
+    } # has CIDR operator
+    if (!$ipfilt) {
+      # simple text matching, with a bit of mix-n-match to account for .arpa names
+      $sql .= " AND (r.host ~* ? OR r.val ~* ? OR r.host ~* ? OR r.val ~* ?)";
+      my $tmp = join('.',reverse(split(/\./,$args{filter})));
+      push @bindvars, ($args{filter},$args{filter});
+      push @bindvars, ($tmp, $tmp);
+    }
   }
 
@@ -4470 +4608 @@
   # Filtering on host/val (mainly normal record list)
   if ($args{filter}) {
-    $sql .= " AND (r.host ~* ? OR r.val ~* ? OR r.host ~* ? OR r.val ~* ?)";
-    my $tmp = join('.',reverse(split(/\./,$args{filter})));
-    push @bindvars, ($args{filter},$args{filter});
-    push @bindvars, ($tmp, $tmp);
+    # not much use to end users, but internal callers may want more fine-grained restriction on CIDR ranges
+    # we'll only support the value-comparison operators;  bitwise/add/subtract don't make much sense in this context
+    my $ipfilt = 0;
+    if ($args{filter} =~ /^\s*(<|<=|=|>=|>|<>|<<|<<=|>>|>>=)\s*([\da-fA-F].+)\s*$/) {
+      my $filt_op = $1;
+      my $filt_val = $2;
+      # do we have an IP-ish value?
+      if ($filt_val =~ m,^(?:[\d.]+|[0-9a-f]+)(?:/\d+)?$,) {
+        # now make sure
+        my $tmp = new NetAddr::IP $filt_val;
+        if ($tmp) {
+          $sql .= " AND inetlazy(r.val) $filt_op ?";
+          push @bindvars, $filt_val;
+          $ipfilt = 1;
+        } # really looks like a valid IP/CIDR
+      } # looks IPish
+    } # has CIDR operator
+    if (!$ipfilt) {
+      # simple text matching, with a bit of mix-n-match to account for .arpa names
+      $sql .= " AND (r.host ~* ? OR r.val ~* ? OR r.host ~* ? OR r.val ~* ?)";
+      my $tmp = join('.',reverse(split(/\./,$args{filter})));
+      push @bindvars, ($args{filter},$args{filter});
+      push @bindvars, ($tmp, $tmp);
+    }
   }
 
@@ -5829 +5987 @@
         $warnmsg .= "Suspect record '".$rr->string."' may not be imported correctly: SRV records may not be bare IP addresses\n"
           if $val =~ /^(?:(?:\d+\.){3}\d+|[a-fA-F0-9:]+)$/;
-      } elsif ($type eq 'KEY') {
+      }
+
+      elsif ($type eq 'CAA') {
+        # Store CAA records without the syntactic quotes
+        $val = join(" ", $rr->flags, $rr->tag, $rr->value);
+      }
+
+      elsif ($type eq 'KEY') {
         # we don't actually know what to do with these...
         $val = $rr->flags.":".$rr->protocol.":".$rr->algorithm.":".$rr->key.":".$rr->keytag.":".$rr->privatekeyname;
@@ -6691 +6856 @@
   elsif ($typemap{$type} eq 'CNAME') {
     ($host,$val) = __revswap($host,$val) if $revrec eq 'y';
+    if ($zone =~ /\.rpz$/) {
+      $val = '..' if $val eq '.';
+    }
     print $datafile "C$host:$val:$ttl:$stamp:$loc\n" or die $!;
   } # CNAME
@@ -6708 +6876 @@
     print $datafile "$prefix\\000:$ttl:$stamp:$loc\n" or die $!;
   } # SRV
+
+  elsif ($typemap{$type} eq 'CAA') {
+    # CAA records really don't make much sense in reverse zones
+    #($host,$val) = __revswap($host,$val) if $revrec eq 'y';
+    return if $revrec eq 'y';
+
+    # data is a bitfield byte, length byte+string, then "everything else"
+
+    my $prefix = ":$host:257:";
+
+    my ($caaflags, $caatag, $caadetail) = ($val =~ /(\d+)\s+(\w+)\s+(.+)/);
+    $prefix .= sprintf "\\%0.3o", $caaflags;
+    $prefix .= sprintf "\\%0.3o%s", length($caatag), $caatag;
+    $caadetail =~ s/:/\\072/g;
+    $caadetail =~ s/;/\\073/g;  # Not strictly necessary but may be helpful validating records by eye
+    $caadetail =~ s/^\s*"\s*//; # AXFR imports may produce strings with embedded quotes;  these
+    $caadetail =~ s/\s*"\s*$//; # are purely a syntactic crutch for BIND-style zone files
+    print $datafile "$prefix$caadetail:$ttl:$stamp:$loc\n" or die $!;
+  } # CAA
 
   elsif ($typemap{$type} eq 'RP') {